From 1bb7a7fa7af9157e4b6b04dfb46c2e0ddcf9cb45 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 13 Jul 2015 11:01:43 +0200 Subject: [PATCH 001/865] Reorganizing of intset/intmap helper functions * module/language/cps2/split-rec.scm (intmap-keys): Move to utils. * module/language/cps2/utils.scm (trivial-intset): New function. (intmap-keys, invert-bijection, invert-partition): New functions. --- module/language/cps2/split-rec.scm | 4 ---- module/language/cps2/utils.scm | 30 ++++++++++++++++++++++++++++++ 2 files changed, 30 insertions(+), 4 deletions(-) diff --git a/module/language/cps2/split-rec.scm b/module/language/cps2/split-rec.scm index 763ede570..20cb516a2 100644 --- a/module/language/cps2/split-rec.scm +++ b/module/language/cps2/split-rec.scm @@ -105,10 +105,6 @@ references." (persistent-intset defs))))))) (visit-fun kfun)) -(define (intmap-keys map) - (persistent-intset - (intmap-fold (lambda (k v keys) (intset-add! keys k)) map empty-intset))) - (define (compute-sorted-strongly-connected-components edges) (define nodes (intmap-keys edges)) diff --git a/module/language/cps2/utils.scm b/module/language/cps2/utils.scm index d375925c9..e4ed47389 100644 --- a/module/language/cps2/utils.scm +++ b/module/language/cps2/utils.scm @@ -37,7 +37,10 @@ ;; Various utilities. fold1 fold2 + trivial-intset intmap-map + intmap-keys + invert-bijection invert-partition intset->intmap worklist-fold fixpoint @@ -108,12 +111,39 @@ (lambda (s0 s1) (lp l s0 s1))))))) +(define (trivial-intset set) + "Returns the sole member of @var{set}, if @var{set} has exactly one +member, or @code{#f} otherwise." + (let ((first (intset-next set))) + (and first + (not (intset-next set (1+ first))) + first))) + (define (intmap-map proc map) (persistent-intmap (intmap-fold (lambda (k v out) (intmap-replace! out k (proc k v))) map map))) +(define (intmap-keys map) + "Return an intset of the keys in @var{map}." + (persistent-intset + (intmap-fold (lambda (k v keys) (intset-add! keys k)) map empty-intset))) + +(define (invert-bijection map) + "Assuming the values of @var{map} are integers and are unique, compute +a map in which each value maps to its key. If the values are not +unique, an error will be signalled." + (intmap-fold (lambda (k v out) (intmap-add out v k)) map empty-intmap)) + +(define (invert-partition map) + "Assuming the values of @var{map} are disjoint intsets, compute a map +in which each member of each set maps to its key. If the values are not +disjoint, an error will be signalled." + (intmap-fold (lambda (k v* out) + (intset-fold (lambda (v out) (intmap-add out v k)) v* out)) + map empty-intmap)) + (define (intset->intmap f set) (persistent-intmap (intset-fold (lambda (label preds) From 47a4727b78c146adc24cbfbeeabc3abf022e14f8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 13 Jul 2015 11:02:29 +0200 Subject: [PATCH 002/865] intset-union fast paths * module/language/cps/intset.scm (intset-union): Add fast paths for union with empty intset. --- module/language/cps/intset.scm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/module/language/cps/intset.scm b/module/language/cps/intset.scm index 87956c525..7f8316ea7 100644 --- a/module/language/cps/intset.scm +++ b/module/language/cps/intset.scm @@ -508,6 +508,8 @@ (match (cons a b) ((($ a-min a-shift a-root) . ($ b-min b-shift b-root)) (cond + ((not b-root) a) + ((not a-root) b) ((not (= b-shift a-shift)) ;; Hoist the set with the lowest shift to meet the one with the ;; higher shift. From dc27708f0b0b039d9356e8d93d71daf563906fb7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 13 Jul 2015 11:03:00 +0200 Subject: [PATCH 003/865] Fix intset-subtract to reliably produce empty-intset * module/language/cps/intset.scm (intset-subtract): Reliably produce empty-intset if the result is empty. --- module/language/cps/intset.scm | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/module/language/cps/intset.scm b/module/language/cps/intset.scm index 7f8316ea7..005bb7e26 100644 --- a/module/language/cps/intset.scm +++ b/module/language/cps/intset.scm @@ -646,10 +646,10 @@ (else (make-intset/prune a-min a-shift root))))))))) (define (intset-subtract a b) - (define tmp (new-leaf)) ;; Intersect leaves. (define (subtract-leaves a b) - (logand a (lognot b))) + (let ((out (logand a (lognot b)))) + (if (zero? out) #f out))) ;; Subtract B from A starting at index I; the result will be fresh. (define (subtract-branches/fresh shift a b i fresh) (let lp ((i 0)) @@ -721,7 +721,9 @@ (new (lp a-min a-shift old))) (if (eq? old new) a-root - (clone-branch-and-set a-root a-idx new))))))))))) + (let ((root (clone-branch-and-set a-root a-idx new))) + (and (or new (not (branch-empty? root))) + root)))))))))))) (define (bitvector->intset bv) (define (finish-tail out min tail) From a15a14203e15c5c0dc037ff935c23d345070c819 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 14 Jul 2015 13:53:56 +0200 Subject: [PATCH 004/865] CPS2 renumber works with first-order CPS * module/language/cps2/renumber.scm (compute-renaming): Add support for $closure and $callk. --- module/language/cps2/renumber.scm | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/module/language/cps2/renumber.scm b/module/language/cps2/renumber.scm index 2c07e03a4..16ed29ced 100644 --- a/module/language/cps2/renumber.scm +++ b/module/language/cps2/renumber.scm @@ -128,6 +128,10 @@ (($ $kfun src meta self tail clause) (rename-var self vars)) (_ vars)))) + (define (maybe-visit-fun kfun labels vars) + (if (intmap-ref labels kfun (lambda (_) #f)) + (values labels vars) + (visit-fun kfun labels vars))) (define (visit-nested-funs k labels vars) (match (intmap-ref conts k) (($ $kargs names syms ($ $continue k src ($ $fun kfun))) @@ -135,6 +139,14 @@ (($ $kargs names syms ($ $continue k src ($ $rec names* syms* (($ $fun kfun) ...)))) (fold2 visit-fun kfun labels vars)) + (($ $kargs names syms ($ $continue k src ($ $closure kfun nfree))) + ;; Closures with zero free vars get copy-propagated so it's + ;; possible to already have visited them. + (maybe-visit-fun kfun labels vars)) + (($ $kargs names syms ($ $continue k src ($ $callk kfun))) + ;; Well-known functions never have a $closure created for them + ;; and are only referenced by their $callk call sites. + (maybe-visit-fun kfun labels vars)) (_ (values labels vars)))) (define (visit-fun kfun labels vars) (let* ((preds (compute-predecessors conts kfun)) From 363d6498e59180e02f30ed4716ba5e4980c703db Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 14 Jul 2015 13:54:19 +0200 Subject: [PATCH 005/865] Tweak intset printing * module/language/cps/intset.scm: Print members of set as absolute values, not diffs from set minumum. --- module/language/cps/intset.scm | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/module/language/cps/intset.scm b/module/language/cps/intset.scm index 005bb7e26..7a16464f2 100644 --- a/module/language/cps/intset.scm +++ b/module/language/cps/intset.scm @@ -768,13 +768,8 @@ (match ranges (() (format port "#<~a>" tag)) - (((0 . _) . _) - (format port "#<~a ~a>" tag (range-string ranges))) - (((min . end) . ranges) - (let ((ranges (map (match-lambda - ((start . end) (cons (- start min) (- end min)))) - (acons min end ranges)))) - (format port "#<~a ~a+~a>" tag min (range-string ranges))))))) + (_ + (format port "#<~a ~a>" tag (range-string ranges)))))) (define (print-intset intset port) (print-helper port "intset" intset)) From e0ef087cebe0f59c334cb94b0da3051684ccc9e6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 14 Jul 2015 14:12:00 +0200 Subject: [PATCH 006/865] Beginnings of first-order CPS optimization * module/language/cps2/optimize.scm (optimize-higher-order-cps): Renamed from "optimize". (optimize-first-order-cps): New function. * module/language/cps2/compile-cps.scm: Adapt. --- module/language/cps2/compile-cps.scm | 2 +- module/language/cps2/optimize.scm | 76 +++++++++++++++------------- 2 files changed, 42 insertions(+), 36 deletions(-) diff --git a/module/language/cps2/compile-cps.scm b/module/language/cps2/compile-cps.scm index e505233ca..4294f9463 100644 --- a/module/language/cps2/compile-cps.scm +++ b/module/language/cps2/compile-cps.scm @@ -100,5 +100,5 @@ (convert-fun 0)) (define (compile-cps exp env opts) - (let ((exp (renumber (optimize exp opts)))) + (let ((exp (renumber (optimize-higher-order-cps exp opts)))) (values (conts->fun exp) env env))) diff --git a/module/language/cps2/optimize.scm b/module/language/cps2/optimize.scm index 3d4bb2753..4a19a57b7 100644 --- a/module/language/cps2/optimize.scm +++ b/module/language/cps2/optimize.scm @@ -37,7 +37,8 @@ #:use-module (language cps2 split-rec) #:use-module (language cps2 type-fold) #:use-module (language cps2 verify) - #:export (optimize)) + #:export (optimize-higher-order-cps + optimize-first-order-cps)) (define (kw-arg-ref args kw default) (match (memq kw args) @@ -51,40 +52,45 @@ (verify program) program)) -(define* (optimize program #:optional (opts '())) - (define (run-pass! pass kw default) +(define-syntax-rule (define-optimizer optimize (pass kw default) ...) + (define* (optimize program #:optional (opts '())) + ;; This series of assignments to `program' used to be a series of + ;; let* bindings of `program', as you would imagine. In compiled + ;; code this is fine because the compiler is able to allocate all + ;; let*-bound variable to the same slot, which also means that the + ;; garbage collector doesn't have to retain so many copies of the + ;; term being optimized. However during bootstrap, the interpreter + ;; doesn't do this optimization, leading to excessive data retention + ;; as the terms are rewritten. To marginally improve bootstrap + ;; memory usage, here we use set! instead. The compiler should + ;; produce the same code in any case, though currently it does not + ;; because it doesn't do escape analysis on the box created for the + ;; set!. + (maybe-verify program) (set! program - (if (kw-arg-ref opts kw default) - (maybe-verify (pass program)) - program))) + (if (kw-arg-ref opts kw default) + (maybe-verify (pass program)) + program)) + ... + (verify program) + program)) - (maybe-verify program) +(define-optimizer optimize-higher-order-cps + (split-rec #:split-rec? #t) + (eliminate-dead-code #:eliminate-dead-code? #t) + (prune-top-level-scopes #:prune-top-level-scopes? #t) + (simplify #:simplify? #t) + (contify #:contify? #t) + (inline-constructors #:inline-constructors? #t) + (specialize-primcalls #:specialize-primcalls? #t) + (elide-values #:elide-values? #t) + (prune-bailouts #:prune-bailouts? #t) + (eliminate-common-subexpressions #:cse? #t) + (type-fold #:type-fold? #t) + (resolve-self-references #:resolve-self-references? #t) + (eliminate-dead-code #:eliminate-dead-code? #t) + (simplify #:simplify? #t)) - ;; This series of assignments to `program' used to be a series of let* - ;; bindings of `program', as you would imagine. In compiled code this - ;; is fine because the compiler is able to allocate all let*-bound - ;; variable to the same slot, which also means that the garbage - ;; collector doesn't have to retain so many copies of the term being - ;; optimized. However during bootstrap, the interpreter doesn't do - ;; this optimization, leading to excessive data retention as the terms - ;; are rewritten. To marginally improve bootstrap memory usage, here - ;; we use set! instead. The compiler should produce the same code in - ;; any case, though currently it does not because it doesn't do escape - ;; analysis on the box created for the set!. - - (run-pass! split-rec #:split-rec? #t) - (run-pass! eliminate-dead-code #:eliminate-dead-code? #t) - (run-pass! prune-top-level-scopes #:prune-top-level-scopes? #t) - (run-pass! simplify #:simplify? #t) - (run-pass! contify #:contify? #t) - (run-pass! inline-constructors #:inline-constructors? #t) - (run-pass! specialize-primcalls #:specialize-primcalls? #t) - (run-pass! elide-values #:elide-values? #t) - (run-pass! prune-bailouts #:prune-bailouts? #t) - (run-pass! eliminate-common-subexpressions #:cse? #t) - (run-pass! type-fold #:type-fold? #t) - (run-pass! resolve-self-references #:resolve-self-references? #t) - (run-pass! eliminate-dead-code #:eliminate-dead-code? #t) - (run-pass! simplify #:simplify? #t) - - (verify program)) +(define-optimizer optimize-first-order-cps + (eliminate-dead-code #:eliminate-dead-code? #t) + (simplify #:simplify? #t)) From bf5c7954ffdfe33d88ed7fe2d89ded338d82c1f9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 14 Jul 2015 16:10:58 +0200 Subject: [PATCH 007/865] Verify pass works on first-order CPS * module/language/cps2/verify.scm: Work with first-order CPS. --- module/language/cps2/verify.scm | 111 +++++++++++++++++++++----------- 1 file changed, 73 insertions(+), 38 deletions(-) diff --git a/module/language/cps2/verify.scm b/module/language/cps2/verify.scm index 8d5504282..c833d0dfe 100644 --- a/module/language/cps2/verify.scm +++ b/module/language/cps2/verify.scm @@ -128,75 +128,110 @@ definitions that are available at LABEL." (define (check-valid-var-uses conts kfun) (define (adjoin-def var defs) (intset-add defs var)) - (let visit-fun ((kfun kfun) (free empty-intset)) - (define (visit-exp exp bound) + (let visit-fun ((kfun kfun) (free empty-intset) (first-order empty-intset)) + (define (visit-exp exp bound first-order) (define (check-use var) (unless (intset-ref bound var) (error "unbound var" var))) + (define (visit-first-order kfun) + (if (intset-ref first-order kfun) + first-order + (visit-fun kfun empty-intset (intset-add first-order kfun)))) (match exp - ((or ($ $const) ($ $prim)) #t) + ((or ($ $const) ($ $prim)) first-order) ;; todo: $closure (($ $fun kfun) - (visit-fun kfun bound)) + (visit-fun kfun bound first-order)) + (($ $closure kfun) + (visit-first-order kfun)) (($ $rec names vars (($ $fun kfuns) ...)) (let ((bound (fold1 adjoin-def vars bound))) - (for-each (lambda (kfun) (visit-fun kfun bound)) kfuns))) + (fold1 (lambda (kfun first-order) + (visit-fun kfun bound first-order)) + kfuns first-order))) (($ $values args) - (for-each check-use args)) + (for-each check-use args) + first-order) (($ $call proc args) (check-use proc) - (for-each check-use args)) - (($ $callk k proc args) + (for-each check-use args) + first-order) + (($ $callk kfun proc args) (check-use proc) - (for-each check-use args)) + (for-each check-use args) + (visit-first-order kfun)) (($ $branch kt ($ $values (arg))) - (check-use arg)) + (check-use arg) + first-order) (($ $branch kt ($ $primcall name args)) - (for-each check-use args)) + (for-each check-use args) + first-order) (($ $primcall name args) - (for-each check-use args)) + (for-each check-use args) + first-order) (($ $prompt escape? tag handler) - (check-use tag)))) - (intmap-for-each - (lambda (label bound) + (check-use tag) + first-order))) + (intmap-fold + (lambda (label bound first-order) (let ((bound (intset-union free bound))) (match (intmap-ref conts label) (($ $kargs names vars ($ $continue k src exp)) - (visit-exp exp (fold1 adjoin-def vars bound))) - (_ #t)))) - (compute-available-definitions conts kfun)))) + (visit-exp exp (fold1 adjoin-def vars bound) first-order)) + (_ first-order)))) + (compute-available-definitions conts kfun) + first-order))) -(define (fold-nested-funs f conts kfun seed) - (intset-fold - (lambda (label seed) - (match (intmap-ref conts label) - (($ $kargs _ _ ($ $continue _ _ ($ $fun label))) - (f label seed)) - (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun label) ...)))) - (fold1 f label seed)) - (_ seed))) - (compute-function-body conts kfun) - seed)) +(define (reachable-functions conts kfun) + (worklist-fold* + (lambda (kfun kfuns) + ;(pk 'verify kfun kfuns) + (let ((kfuns (intset-add kfuns kfun))) + (values (intset-fold + (lambda (label nested) + (define (return kfun*) + ;(pk 'return label kfuns kfun* nested) + (append (filter (lambda (kfun) + (not (intset-ref kfuns kfun))) + kfun*) + nested)) + (define (return1 kfun) (return (list kfun))) + (define (return0) (return '())) + (match (intmap-ref conts label) + (($ $kargs _ _ ($ $continue _ _ exp)) + (match exp + (($ $fun label) (return1 label)) + (($ $rec _ _ (($ $fun labels) ...)) (return labels)) + (($ $closure label nfree) (return1 label)) + (($ $callk label) (return1 label)) + (_ (return0)))) + (_ (return0)))) + (compute-function-body conts kfun) + '()) + kfuns))) + (intset kfun) + empty-intset)) (define (check-label-partition conts kfun) ;; A continuation can only belong to one function. - (let visit-fun ((kfun kfun) (seen empty-intmap)) - (fold-nested-funs - visit-fun - conts - kfun + (intset-fold + (lambda (kfun seen) (intset-fold (lambda (label seen) (intmap-add seen label kfun (lambda (old new) (error "label used by two functions" label old new)))) (compute-function-body conts kfun) - seen)))) + seen)) + (reachable-functions conts kfun) + empty-intmap)) (define (compute-reachable-labels conts kfun) - (let visit-fun ((kfun kfun) (seen empty-intset)) - (fold-nested-funs visit-fun conts kfun - (intset-union seen (compute-function-body conts kfun))))) + (intset-fold + (lambda (kfun seen) + (intset-union seen (compute-function-body conts kfun))) + (reachable-functions conts kfun) + empty-intset)) (define (check-arities conts kfun) (define (check-arity exp cont) From 285f62a07798293b328c1989dba846a4bd1b2609 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 13 Jul 2015 11:03:53 +0200 Subject: [PATCH 008/865] Add CPS2 closure conversion module * module/language/cps2/closure-conversion.scm: New module. * module/Makefile.am: Add new file. --- module/Makefile.am | 3 +- module/language/cps2/closure-conversion.scm | 828 ++++++++++++++++++++ 2 files changed, 830 insertions(+), 1 deletion(-) create mode 100644 module/language/cps2/closure-conversion.scm diff --git a/module/Makefile.am b/module/Makefile.am index 88b84a1a3..270699b96 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -148,10 +148,11 @@ CPS_LANG_SOURCES = \ CPS2_LANG_SOURCES = \ language/cps2.scm \ - language/cps2/cse.scm \ + language/cps2/closure-conversion.scm \ language/cps2/compile-cps.scm \ language/cps2/constructors.scm \ language/cps2/contification.scm \ + language/cps2/cse.scm \ language/cps2/dce.scm \ language/cps2/effects-analysis.scm \ language/cps2/elide-values.scm \ diff --git a/module/language/cps2/closure-conversion.scm b/module/language/cps2/closure-conversion.scm new file mode 100644 index 000000000..2d20919a6 --- /dev/null +++ b/module/language/cps2/closure-conversion.scm @@ -0,0 +1,828 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; This pass converts a CPS term in such a way that no function has any +;;; free variables. Instead, closures are built explicitly with +;;; make-closure primcalls, and free variables are referenced through +;;; the closure. +;;; +;;; Closure conversion also removes any $rec expressions that +;;; contification did not handle. See (language cps) for a further +;;; discussion of $rec. +;;; +;;; Code: + +(define-module (language cps2 closure-conversion) + #:use-module (ice-9 match) + #:use-module ((srfi srfi-1) #:select (fold + filter-map + )) + #:use-module (srfi srfi-11) + #:use-module (language cps2) + #:use-module (language cps2 utils) + #:use-module (language cps2 with-cps) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (convert-closures)) + +(define (compute-function-bodies conts kfun) + "Compute a map from FUN-LABEL->BODY-LABEL... for all $fun instances in +conts." + (let visit-fun ((kfun kfun) (out empty-intmap)) + (let ((body (compute-function-body conts kfun))) + (intset-fold + (lambda (label out) + (match (intmap-ref conts label) + (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun))) + (visit-fun kfun out)) + (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfun) ...)))) + (fold visit-fun out kfun)) + (_ out))) + body + (intmap-add out kfun body))))) + +(define (compute-program-body functions) + (intmap-fold (lambda (label body out) (intset-union body out)) + functions + empty-intset)) + +(define (filter-reachable conts functions) + (let ((reachable (compute-program-body functions))) + (intmap-fold + (lambda (label cont out) + (if (intset-ref reachable label) + out + (intmap-remove out label))) + conts conts))) + +(define (compute-non-operator-uses conts) + (persistent-intset + (intmap-fold + (lambda (label cont uses) + (define (add-use var uses) (intset-add! uses var)) + (define (add-uses vars uses) + (match vars + (() uses) + ((var . vars) (add-uses vars (add-use var uses))))) + (match cont + (($ $kargs _ _ ($ $continue _ _ exp)) + (match exp + ((or ($ $const) ($ $prim) ($ $fun) ($ $rec)) uses) + (($ $values args) + (add-uses args uses)) + (($ $call proc args) + (add-uses args uses)) + (($ $branch kt ($ $values (arg))) + (add-use arg uses)) + (($ $branch kt ($ $primcall name args)) + (add-uses args uses)) + (($ $primcall name args) + (add-uses args uses)) + (($ $prompt escape? tag handler) + (add-use tag uses)))) + (_ uses))) + conts + empty-intset))) + +(define (compute-singly-referenced-labels conts body) + (define (add-ref label single multiple) + (define (ref k single multiple) + (if (intset-ref single k) + (values single (intset-add! multiple k)) + (values (intset-add! single k) multiple))) + (define (ref0) (values single multiple)) + (define (ref1 k) (ref k single multiple)) + (define (ref2 k k*) + (if k* + (let-values (((single multiple) (ref k single multiple))) + (ref k* single multiple)) + (ref1 k))) + (match (intmap-ref conts label) + (($ $kreceive arity k) (ref1 k)) + (($ $kfun src meta self ktail kclause) (ref2 ktail kclause)) + (($ $ktail) (ref0)) + (($ $kclause arity kbody kalt) (ref2 kbody kalt)) + (($ $kargs names syms ($ $continue k src exp)) + (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f)))))) + (let*-values (((single multiple) (values empty-intset empty-intset)) + ((single multiple) (intset-fold add-ref body single multiple))) + (intset-subtract (persistent-intset single) + (persistent-intset multiple)))) + +(define (compute-function-names conts functions) + "Compute a map of FUN-LABEL->BOUND-VAR... for each labelled function +whose bound vars we know." + (define (add-named-fun var kfun out) + (let ((self (match (intmap-ref conts kfun) + (($ $kfun src meta self) self)))) + (intmap-add out kfun (intset var self)))) + (intmap-fold + (lambda (label body out) + (let ((single (compute-singly-referenced-labels conts body))) + (intset-fold + (lambda (label out) + (match (intmap-ref conts label) + (($ $kargs _ _ ($ $continue k _ ($ $fun kfun))) + (if (intset-ref single k) + (match (intmap-ref conts k) + (($ $kargs (_) (var)) (add-named-fun var kfun out)) + (_ out)) + out)) + (($ $kargs _ _ ($ $continue k _ ($ $rec _ vars (($ $fun kfun) ...)))) + (unless (intset-ref single k) + (error "$rec continuation has multiple predecessors??")) + (fold add-named-fun out vars kfun)) + (_ out))) + body + out))) + functions + empty-intmap)) + +(define (compute-well-known-functions conts bound->label) + "Compute a set of labels indicating the well-known functions in +@var{conts}. A well-known function is a function whose bound names we +know and which is never used in a non-operator position." + (intset-subtract + (persistent-intset + (intmap-fold (lambda (bound label candidates) + (intset-add! candidates label)) + bound->label + empty-intset)) + (persistent-intset + (intset-fold (lambda (var not-well-known) + (match (intmap-ref bound->label var (lambda (_) #f)) + (#f not-well-known) + (label (intset-add! not-well-known label)))) + (compute-non-operator-uses conts) + empty-intset)))) + +(define (intset-cons i set) + (intset-add set i)) + +(define (compute-shared-closures conts well-known) + "Compute a map LABEL->VAR indicating the sets of functions that will +share a closure. If a functions's label is in the map, it is shared. +The entries indicate the var of the shared closure, which will be one of +the bound vars of the closure." + (intmap-fold + (lambda (label cont out) + (match cont + (($ $kargs _ _ + ($ $continue _ _ ($ $rec names vars (($ $fun kfuns) ...)))) + ;; The split-rec pass should have ensured that this $rec forms a + ;; strongly-connected component, so the free variables from all of + ;; the functions will be alive as long as one of the closures is + ;; alive. For that reason we can consider storing all free + ;; variables in one closure and sharing it. + (let* ((kfuns-set (fold intset-cons empty-intset kfuns)) + (unknown-kfuns (intset-subtract kfuns-set well-known))) + (cond + ((or (eq? empty-intset kfuns-set) (trivial-intset kfuns-set)) + ;; There is only zero or one function bound here. Trivially + ;; shared already. + out) + ((eq? empty-intset unknown-kfuns) + ;; All functions are well-known; we can share a closure. Use + ;; the first bound variable. + (pk 'all-well-known kfuns) + (let ((closure (car vars))) + (intset-fold (lambda (kfun out) + (intmap-add out kfun closure)) + kfuns-set out))) + ((trivial-intset unknown-kfuns) + => (lambda (unknown-kfun) + ;; Only one function is not-well-known. Use that + ;; function's closure as the shared closure. + (let ((closure (assq-ref (map cons kfuns vars) unknown-kfun))) + (pk 'one-not-well-known kfuns closure) + (intset-fold (lambda (kfun out) + (intmap-add out kfun closure)) + kfuns-set out)))) + (else + ;; More than one not-well-known function means we need more + ;; than one proper closure, so we can't share. + out)))) + (_ out))) + conts + empty-intmap)) + +(define* (rewrite-shared-closure-calls cps functions label->bound shared kfun) + "Rewrite CPS such that every call to a function with a shared closure +instead is a $callk to that label, but passing the shared closure as the +proc argument. For recursive calls, use the appropriate 'self' +variable, if possible. Also rewrite uses of the non-well-known but +shared closures to use the appropriate 'self' variable, if possible." + ;; env := var -> (var . label) + (define (rewrite-fun kfun cps env) + (define (subst var) + (match (intmap-ref env var (lambda (_) #f)) + (#f var) + ((var . label) var))) + + (define (rename-exp label cps names vars k src exp) + (intmap-replace! + cps label + (build-cont + ($kargs names vars + ($continue k src + ,(rewrite-exp exp + ((or ($ $const) ($ $prim)) ,exp) + (($ $call proc args) + ,(let ((args (map subst args))) + (rewrite-exp (intmap-ref env proc (lambda (_) #f)) + (#f ($call proc ,args)) + ((closure . label) ($callk label closure ,args))))) + (($ $primcall name args) + ($primcall name ,(map subst args))) + (($ $branch k ($ $values (arg))) + ($branch k ($values ((subst arg))))) + (($ $branch k ($ $primcall name args)) + ($branch k ($primcall name ,(map subst args)))) + (($ $values args) + ($values ,(map subst args))) + (($ $prompt escape? tag handler) + ($prompt escape? (subst tag) handler)))))))) + + (define (visit-exp label cps names vars k src exp) + (define (compute-env label bound self rec-bound env) + (define (add-bound-var bound env) + (intmap-add env bound (cons self label) (lambda (old new) new))) + (if (intmap-ref shared label (lambda (_) #f)) + ;; Within a function with a shared closure, rewrite + ;; references to bound vars to use the "self" var. + (fold add-bound-var env rec-bound) + ;; Otherwise be sure to use "self" references in any + ;; closure. + (add-bound-var bound env))) + (match exp + (($ $fun label) + (rewrite-fun label cps env)) + (($ $rec names vars (($ $fun labels) ...)) + (fold (lambda (label var cps) + (match (intmap-ref cps label) + (($ $kfun src meta self) + (rewrite-fun label cps + (compute-env label var self vars env))))) + cps labels vars)) + (_ (rename-exp label cps names vars k src exp)))) + + (define (rewrite-cont label cps) + (match (intmap-ref cps label) + (($ $kargs names vars ($ $continue k src exp)) + (visit-exp label cps names vars k src exp)) + (_ cps))) + + (intset-fold rewrite-cont (intmap-ref functions kfun) cps)) + + ;; Initial environment is bound-var -> (shared-var . label) map for + ;; functions with shared closures. + (let ((env (intmap-fold (lambda (label shared env) + (intset-fold (lambda (bound env) + (intmap-add env bound + (cons shared label))) + (intset-remove + (intmap-ref label->bound label) + (match (intmap-ref cps label) + (($ $kfun src meta self) self))) + env)) + shared + empty-intmap))) + (persistent-intmap (rewrite-fun kfun cps env)))) + +(define (compute-free-vars conts kfun shared) + "Compute a FUN-LABEL->FREE-VAR... map describing all free variable +references." + (define (add-def var defs) (intset-add! defs var)) + (define (add-defs vars defs) + (match vars + (() defs) + ((var . vars) (add-defs vars (add-def var defs))))) + (define (add-use var uses) + (intset-add! uses var)) + (define (add-uses vars uses) + (match vars + (() uses) + ((var . vars) (add-uses vars (add-use var uses))))) + (define (visit-nested-funs body) + (intset-fold + (lambda (label out) + (match (intmap-ref conts label) + (($ $kargs _ _ ($ $continue _ _ + ($ $fun kfun))) + (intmap-union out (visit-fun kfun))) + (($ $kargs _ _ ($ $continue _ _ + ($ $rec _ _ (($ $fun labels) ...)))) + (let* ((out (fold (lambda (kfun out) + (intmap-union out (visit-fun kfun))) + out labels)) + (free (fold (lambda (kfun free) + (intset-union free (intmap-ref out kfun))) + empty-intset labels))) + (fold (lambda (kfun out) + ;; For functions that share a closure, the free + ;; variables for one will be the union of the free + ;; variables for all. + (if (intmap-ref shared kfun (lambda (_) #f)) + (intmap-replace out kfun free) + out)) + out + labels))) + (_ out))) + body + empty-intmap)) + (define (visit-fun kfun) + (let* ((body (compute-function-body conts kfun)) + (free (visit-nested-funs body))) + (call-with-values + (lambda () + (intset-fold + (lambda (label defs uses) + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src exp)) + (values + (add-defs vars defs) + (match exp + ((or ($ $const) ($ $prim)) uses) + (($ $fun kfun) + (intset-union (persistent-intset uses) + (intmap-ref free kfun))) + (($ $rec names vars (($ $fun kfun) ...)) + (fold (lambda (kfun uses) + (intset-union (persistent-intset uses) + (intmap-ref free kfun))) + uses kfun)) + (($ $values args) + (add-uses args uses)) + (($ $call proc args) + (add-use proc (add-uses args uses))) + (($ $callk label proc args) + (add-use proc (add-uses args uses))) + (($ $branch kt ($ $values (arg))) + (add-use arg uses)) + (($ $branch kt ($ $primcall name args)) + (add-uses args uses)) + (($ $primcall name args) + (add-uses args uses)) + (($ $prompt escape? tag handler) + (add-use tag uses))))) + (($ $kfun src meta self) + (values (add-def self defs) uses)) + (_ (values defs uses)))) + body empty-intset empty-intset)) + (lambda (defs uses) + (intmap-add free kfun (intset-subtract + (persistent-intset uses) + (persistent-intset defs))))))) + (visit-fun kfun)) + +(define (eliminate-closure? label free-vars) + (eq? (intmap-ref free-vars label) empty-intset)) + +(define (closure-alias label well-known free-vars) + (and (intset-ref well-known label) + (trivial-intset (intmap-ref free-vars label)))) + +(define (prune-free-vars free-vars bound->label well-known) + "Given the label->bound-var map @var{free-vars}, remove free variables +that are well-known functions with zero free variables, and replace +references to well-known functions with one free variable with that free +variable, until we reach a fixed point on the free-vars map." + (define (prune-free in-label free free-vars) + (intset-fold (lambda (var free) + (match (intmap-ref bound->label var (lambda (_) #f)) + (#f free) + (label + (cond + ((eliminate-closure? label free-vars) + (intset-remove free var)) + ((closure-alias label well-known free-vars) + => (lambda (alias) + ;; If VAR is free in LABEL, then ALIAS must + ;; also be free because its definition must + ;; precede VAR's definition. + (intset-add (intset-remove free var) alias))) + (else free))))) + free free)) + (fixpoint (lambda (free-vars) + (intmap-fold (lambda (label free free-vars) + (intmap-replace free-vars label + (prune-free label free free-vars))) + free-vars + free-vars)) + free-vars)) + +(define (intset-find set i) + (let lp ((idx 0) (start #f)) + (let ((start (intset-next set start))) + (cond + ((not start) (error "not found" set i)) + ((= start i) idx) + (else (lp (1+ idx) (1+ start))))))) + +(define (intmap-select map set) + (persistent-intmap + (intmap-fold + (lambda (k v out) + (if (intset-ref set k) + (intmap-add! out k v) + out)) + map + empty-intmap))) + +(define (intset-count set) + (intset-fold (lambda (_ count) (1+ count)) set 0)) + +(define (convert-one cps label body free-vars bound->label well-known shared) + (define (well-known? label) + (intset-ref well-known label)) + + (let* ((free (intmap-ref free-vars label)) + (nfree (intset-count free)) + (self-known? (well-known? label)) + (self (match (intmap-ref cps label) (($ $kfun _ _ self) self)))) + (define (convert-arg cps var k) + "Convert one possibly free variable reference to a bound reference. + +If @var{var} is free, it is replaced by a closure reference via a +@code{free-ref} primcall, and @var{k} is called with the new var. +Otherwise @var{var} is bound, so @var{k} is called with @var{var}." + ;; We know that var is not the name of a well-known function. + (cond + ((and=> (intmap-ref bound->label var (lambda (_) #f)) + (lambda (kfun) + (and (eq? empty-intset (intmap-ref free-vars kfun)) + kfun))) + ;; A not-well-known function with zero free vars. Copy as a + ;; constant, relying on the linker to reify just one copy. + => (lambda (kfun) + (with-cps cps + (letv var*) + (let$ body (k var*)) + (letk k* ($kargs (#f) (var*) ,body)) + (build-term ($continue k* #f ($closure kfun 0)))))) + ((intset-ref free var) + (match (vector self-known? nfree) + (#(#t 1) + ;; A reference to the one free var of a well-known function. + (with-cps cps + ($ (k self)))) + (#(#t 2) + ;; A reference to one of the two free vars in a well-known + ;; function. + (let ((op (if (= var (intset-next free)) 'car 'cdr))) + (with-cps cps + (letv var*) + (let$ body (k var*)) + (letk k* ($kargs (#f) (var*) ,body)) + (build-term ($continue k* #f ($primcall op (self))))))) + (_ + (let* ((idx (intset-find free var)) + (op (cond + ((not self-known?) 'free-ref) + ((<= idx #xff) 'vector-ref/immediate) + (else 'vector-ref)))) + (with-cps cps + (letv var*) + (let$ body (k var*)) + (letk k* ($kargs (#f) (var*) ,body)) + ($ (with-cps-constants ((idx idx)) + (build-term + ($continue k* #f ($primcall op (self idx))))))))))) + (else + (with-cps cps + ($ (k var)))))) + + (define (convert-args cps vars k) + "Convert a number of possibly free references to bound references. +@var{k} is called with the bound references, and should return the +term." + (match vars + (() + (with-cps cps + ($ (k '())))) + ((var . vars) + (convert-arg cps var + (lambda (cps var) + (convert-args cps vars + (lambda (cps vars) + (with-cps cps + ($ (k (cons var vars))))))))))) + + (define (allocate-closure cps k src label known? nfree) + "Allocate a new closure, and pass it to $var{k}." + (match (vector known? nfree) + (#(#f nfree) + ;; The call sites cannot be enumerated; allocate a closure. + (with-cps cps + (build-term ($continue k src ($closure label nfree))))) + (#(#t 2) + ;; Well-known closure with two free variables; the closure is a + ;; pair. + (with-cps cps + ($ (with-cps-constants ((false #f)) + (build-term + ($continue k src ($primcall 'cons (false false)))))))) + ;; Well-known callee with more than two free variables; the closure + ;; is a vector. + (#(#t nfree) + (unless (> nfree 2) + (error "unexpected well-known nullary, unary, or binary closure")) + (let ((op (if (<= nfree #xff) 'make-vector/immediate 'make-vector))) + (with-cps cps + ($ (with-cps-constants ((nfree nfree) + (false #f)) + (build-term + ($continue k src ($primcall op (nfree false))))))))))) + + (define (init-closure cps k src var known? free) + "Initialize the free variables @var{closure-free} in a closure +bound to @var{var}, and continue to @var{k}." + (match (vector known? (intset-count free)) + ;; Well-known callee with zero or one free variables; no + ;; initialization necessary. + (#(#t (or 0 1)) + (with-cps cps + (build-term ($continue k src ($values ()))))) + ;; Well-known callee with two free variables; do a set-car! and + ;; set-cdr!. + (#(#t 2) + (let* ((free0 (intset-next free)) + (free1 (intset-next free (1+ free0)))) + (convert-arg cps free0 + (lambda (cps v0) + (with-cps cps + (let$ body + (convert-arg free1 + (lambda (cps v1) + (with-cps cps + (build-term + ($continue k src + ($primcall 'set-cdr! (var v1)))))))) + (letk kcdr ($kargs () () ,body)) + (build-term + ($continue kcdr src ($primcall 'set-car! (var v0))))))))) + ;; Otherwise residualize a sequence of vector-set! or free-set!, + ;; depending on whether the callee is well-known or not. + (_ + (let lp ((cps cps) (prev #f) (idx 0)) + (match (intset-next free prev) + (#f (with-cps cps + (build-term ($continue k src ($values ()))))) + (v (with-cps cps + (let$ body (lp (1+ v) (1+ idx))) + (letk k ($kargs () () ,body)) + ($ (convert-arg v + (lambda (cps v) + (with-cps cps + ($ (with-cps-constants ((idx idx)) + (let ((op (cond + ((not known?) 'free-set!) + ((<= idx #xff) 'vector-set!/immediate) + (else 'vector-set!)))) + (build-term + ($continue k src + ($primcall op (var idx v)))))))))))))))))) + + (define (make-single-closure cps k src kfun) + (let ((free (intmap-ref free-vars kfun))) + (match (vector (well-known? kfun) (intset-count free)) + (#(#f 0) + (with-cps cps + (build-term ($continue k src ($closure kfun 0))))) + (#(#t 0) + (with-cps cps + (build-term ($continue k src ($const #f))))) + (#(#t 1) + ;; A well-known closure of one free variable is replaced + ;; at each use with the free variable itself, so we don't + ;; need a binding at all; and yet, the continuation + ;; expects one value, so give it something. DCE should + ;; clean up later. + (with-cps cps + (build-term ($continue k src ($const #f))))) + (#(well-known? nfree) + ;; A bit of a mess, but beta conversion should remove the + ;; final $values if possible. + (with-cps cps + (letv closure) + (letk k* ($kargs () () ($continue k src ($values (closure))))) + (let$ init (init-closure k* src closure well-known? free)) + (letk knew ($kargs (#f) (closure) ,init)) + ($ (allocate-closure knew src kfun well-known? nfree))))))) + + ;; The callee is known, but not necessarily well-known. + (define (convert-known-proc-call cps k src label closure args) + (define (have-closure cps closure) + (convert-args cps args + (lambda (cps args) + (with-cps cps + (build-term + ($continue k src ($callk label closure args))))))) + (cond + ((eq? (intmap-ref free-vars label) empty-intset) + ;; Known call, no free variables; no closure needed. + ;; Pass #f as closure argument. + (with-cps cps + ($ (with-cps-constants ((false #f)) + ($ (have-closure false)))))) + ((and (well-known? label) + (trivial-intset (intmap-ref free-vars label))) + ;; Well-known closures with one free variable are + ;; replaced at their use sites by uses of the one free + ;; variable. + => (lambda (var) + (convert-arg cps var have-closure))) + (else + ;; Otherwise just load the proc. + (convert-arg cps closure have-closure)))) + + (define (visit-term cps term) + (match term + (($ $continue k src (or ($ $const) ($ $prim))) + (with-cps cps + term)) + + (($ $continue k src ($ $fun kfun)) + (with-cps cps + ($ (make-single-closure k src kfun)))) + + ;; Remove letrec. + (($ $continue k src ($ $rec names vars (($ $fun kfuns) ...))) + (match (vector names vars kfuns) + (#(() () ()) + ;; Trivial empty case. + (with-cps cps + (build-term ($continue k src ($values ()))))) + (#((name) (var) (kfun)) + ;; Trivial single case. We have already proven that K has + ;; only LABEL as its predecessor, so we have been able + ;; already to rewrite free references to the bound name with + ;; the self name. + (with-cps cps + ($ (make-single-closure k src kfun)))) + (#(_ _ (kfun0 . _)) + ;; A non-trivial strongly-connected component. Does it have + ;; a shared closure? + (match (intmap-ref shared kfun0 (lambda (_) #f)) + (#f + ;; Nope. Allocate closures for each function. + (let lp ((cps (match (intmap-ref cps k) + ;; Steal declarations from the continuation. + (($ $kargs names vals body) + (intmap-replace cps k + (build-cont + ($kargs () () ,body)))))) + (in (map vector names vars kfuns)) + (init (lambda (cps) + (with-cps cps + (build-term + ($continue k src ($values ()))))))) + (match in + (() (init cps)) + ((#(name var kfun) . in) + (let* ((known? (well-known? kfun)) + (free (intmap-ref free-vars kfun)) + (nfree (intset-count free))) + (define (next-init cps) + (with-cps cps + (let$ body (init)) + (letk k ($kargs () () ,body)) + ($ (init-closure k src var known? free)))) + (with-cps cps + (let$ body (lp in next-init)) + (letk k ($kargs (name) (var) ,body)) + ($ (allocate-closure k src kfun known? nfree)))))))) + (shared + ;; If shared is in the bound->var map, that means one of + ;; the functions is not well-known. Otherwise use kfun0 + ;; as the function label, but just so make-single-closure + ;; can find the free vars, not for embedding in the + ;; closure. + (let* ((kfun (intmap-ref bound->label shared (lambda (_) kfun0))) + (cps (match (intmap-ref cps k) + ;; Make continuation declare only the shared + ;; closure. + (($ $kargs names vals body) + (intmap-replace cps k + (build-cont + ($kargs (#f) (shared) ,body))))))) + (with-cps cps + ($ (make-single-closure k src kfun))))))))) + + (($ $continue k src ($ $call proc args)) + (match (intmap-ref bound->label proc (lambda (_) #f)) + (#f + (convert-arg cps proc + (lambda (cps proc) + (convert-args cps args + (lambda (cps args) + (with-cps cps + (build-term + ($continue k src ($call proc args))))))))) + (label + (convert-known-proc-call cps k src label proc args)))) + + (($ $continue k src ($ $callk label proc args)) + (convert-known-proc-call cps k src label proc args)) + + (($ $continue k src ($ $primcall name args)) + (convert-args cps args + (lambda (cps args) + (with-cps cps + (build-term + ($continue k src ($primcall name args))))))) + + (($ $continue k src ($ $branch kt ($ $primcall name args))) + (convert-args cps args + (lambda (cps args) + (with-cps cps + (build-term + ($continue k src + ($branch kt ($primcall name args)))))))) + + (($ $continue k src ($ $branch kt ($ $values (arg)))) + (convert-arg cps arg + (lambda (cps arg) + (with-cps cps + (build-term + ($continue k src + ($branch kt ($values (arg))))))))) + + (($ $continue k src ($ $values args)) + (convert-args cps args + (lambda (cps args) + (with-cps cps + (build-term + ($continue k src ($values args))))))) + + (($ $continue k src ($ $prompt escape? tag handler)) + (convert-arg cps tag + (lambda (cps tag) + (with-cps cps + (build-term + ($continue k src + ($prompt escape? tag handler))))))))) + + (pk 'convert-one label body free self-known?) + (intset-fold (lambda (label cps) + (match (intmap-ref cps label (lambda (_) #f)) + (($ $kargs names vars term) + (with-cps cps + (let$ term (visit-term term)) + (setk label ($kargs names vars ,term)))) + (_ cps))) + body + cps))) + +(define (convert-closures cps) + "Convert free reference in @var{cps} to primcalls to @code{free-ref}, +and allocate and initialize flat closures." + (let* ((kfun 0) ;; Ass-u-me. + ;; label -> body-label... + (functions (compute-function-bodies cps kfun)) + (cps (filter-reachable cps functions)) + ;; label -> bound-var... + (label->bound (compute-function-names cps functions)) + ;; bound-var -> label + (bound->label (invert-partition label->bound)) + ;; label... + (well-known (compute-well-known-functions cps bound->label)) + ;; label -> closure-var + (shared (compute-shared-closures cps well-known)) + (cps (rewrite-shared-closure-calls cps functions label->bound shared + kfun)) + ;; label -> free-var... + (free-vars (compute-free-vars cps kfun shared)) + (free-vars (prune-free-vars free-vars bound->label well-known))) + (let ((free-in-program (intmap-ref free-vars kfun))) + (unless (eq? empty-intset free-in-program) + (error "Expected no free vars in program" free-in-program))) + (with-fresh-name-state cps + (persistent-intmap + (intmap-fold + (lambda (label body cps) + (convert-one cps label body free-vars bound->label well-known shared)) + functions + cps))))) + +;;; Local Variables: +;;; eval: (put 'convert-arg 'scheme-indent-function 2) +;;; eval: (put 'convert-args 'scheme-indent-function 2) +;;; End: From 981802c4c228c9f662ebb22cefcbb241cf2b107b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 15 Jul 2015 09:43:33 +0200 Subject: [PATCH 009/865] Wire up new closure conversion pass * module/language/cps/compile-bytecode.scm (compile-bytecode): Only convert closures if the #:cps2-convert? option is not passed. * module/language/cps2/compile-cps.scm (conts->fun*, compile-cps): Add support for CPS2 closure conversion, disabled by default. --- module/language/cps/compile-bytecode.scm | 4 +++- module/language/cps2/compile-cps.scm | 27 ++++++++++++++++++++---- 2 files changed, 26 insertions(+), 5 deletions(-) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 86a3db733..b66b1a693 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -517,7 +517,9 @@ ;; ;; (set! exp (optimize exp opts)) - (set! exp (convert-closures exp)) + (set! exp (if (not (kw-arg-ref opts #:cps2-convert? #f)) + (convert-closures exp) + exp)) ;; first-order optimization should go here (set! exp (reify-primitives exp)) (set! exp (renumber exp)) diff --git a/module/language/cps2/compile-cps.scm b/module/language/cps2/compile-cps.scm index 4294f9463..da51d3536 100644 --- a/module/language/cps2/compile-cps.scm +++ b/module/language/cps2/compile-cps.scm @@ -27,6 +27,7 @@ #:use-module (language cps2) #:use-module ((language cps) #:prefix cps:) #:use-module (language cps2 utils) + #:use-module (language cps2 closure-conversion) #:use-module (language cps2 optimize) #:use-module (language cps2 renumber) #:use-module (language cps intmap) @@ -34,7 +35,7 @@ ;; Precondition: For each function in CONTS, the continuation names are ;; topologically sorted. -(define (conts->fun conts) +(define* (conts->fun conts #:optional (kfun 0)) (define (convert-fun kfun) (let ((doms (compute-dom-edges (compute-idoms conts kfun)))) (define (visit-cont label) @@ -97,8 +98,26 @@ (($ $kfun src meta self tail clause) (kfun (cps:$kfun src meta self (tail (cps:$ktail)) ,(visit-clause clause))))))) - (convert-fun 0)) + (convert-fun kfun)) + +(define (conts->fun* conts) + (cps:build-cps-term + (cps:$program + ,(intmap-fold-right (lambda (label cont out) + (match cont + (($ $kfun) + (cons (conts->fun conts label) out)) + (_ out))) + conts + '())))) + +(define (kw-arg-ref args kw default) + (match (memq kw args) + ((_ val . _) val) + (_ default))) (define (compile-cps exp env opts) - (let ((exp (renumber (optimize-higher-order-cps exp opts)))) - (values (conts->fun exp) env env))) + (let ((exp (optimize-higher-order-cps exp opts))) + (if (kw-arg-ref opts #:cps2-convert? #f) + (values (conts->fun* (renumber (convert-closures exp))) env env) + (values (conts->fun (renumber exp)) env env)))) From e9e6da1902b116af36f3daa57f0caec5a04b9fa6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 15 Jul 2015 15:15:41 +0200 Subject: [PATCH 010/865] closure-conversion docstring tweak * module/language/cps2/closure-conversion.scm (prune-free-vars): Fix docstring. --- module/language/cps2/closure-conversion.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/language/cps2/closure-conversion.scm b/module/language/cps2/closure-conversion.scm index 2d20919a6..cf15e1584 100644 --- a/module/language/cps2/closure-conversion.scm +++ b/module/language/cps2/closure-conversion.scm @@ -401,7 +401,7 @@ references." (define (prune-free-vars free-vars bound->label well-known) "Given the label->bound-var map @var{free-vars}, remove free variables -that are well-known functions with zero free variables, and replace +that are known functions with zero free variables, and replace references to well-known functions with one free variable with that free variable, until we reach a fixed point on the free-vars map." (define (prune-free in-label free free-vars) From 6cfb7afb61343d061ad04fb28cfd496e136dd2e8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 15 Jul 2015 16:11:09 +0200 Subject: [PATCH 011/865] CPS2 closure conversion bugfixes * module/language/cps2/closure-conversion.scm (rewrite-shared-closure-calls): Fix to make shared closures call the right label. (closure-label): New helper. (prune-free-vars): If a shared closure is not well-known, don't use the alias optimization. (convert-one): Fix for shared closures with one not-well-known closure. --- module/language/cps2/closure-conversion.scm | 29 ++++++++++++++------- 1 file changed, 19 insertions(+), 10 deletions(-) diff --git a/module/language/cps2/closure-conversion.scm b/module/language/cps2/closure-conversion.scm index cf15e1584..0ae1bf341 100644 --- a/module/language/cps2/closure-conversion.scm +++ b/module/language/cps2/closure-conversion.scm @@ -261,16 +261,16 @@ shared closures to use the appropriate 'self' variable, if possible." ($prompt escape? (subst tag) handler)))))))) (define (visit-exp label cps names vars k src exp) - (define (compute-env label bound self rec-bound env) - (define (add-bound-var bound env) + (define (compute-env label bound self rec-bound rec-labels env) + (define (add-bound-var bound label env) (intmap-add env bound (cons self label) (lambda (old new) new))) (if (intmap-ref shared label (lambda (_) #f)) ;; Within a function with a shared closure, rewrite ;; references to bound vars to use the "self" var. - (fold add-bound-var env rec-bound) + (fold add-bound-var env rec-bound rec-labels) ;; Otherwise be sure to use "self" references in any ;; closure. - (add-bound-var bound env))) + (add-bound-var bound label env))) (match exp (($ $fun label) (rewrite-fun label cps env)) @@ -279,7 +279,8 @@ shared closures to use the appropriate 'self' variable, if possible." (match (intmap-ref cps label) (($ $kfun src meta self) (rewrite-fun label cps - (compute-env label var self vars env))))) + (compute-env label var self vars labels + env))))) cps labels vars)) (_ (rename-exp label cps names vars k src exp)))) @@ -395,11 +396,18 @@ references." (define (eliminate-closure? label free-vars) (eq? (intmap-ref free-vars label) empty-intset)) +(define (closure-label label shared bound->label) + (cond + ((intmap-ref shared label (lambda (_) #f)) + => (lambda (closure) + (intmap-ref bound->label closure))) + (else label))) + (define (closure-alias label well-known free-vars) (and (intset-ref well-known label) (trivial-intset (intmap-ref free-vars label)))) -(define (prune-free-vars free-vars bound->label well-known) +(define (prune-free-vars free-vars bound->label well-known shared) "Given the label->bound-var map @var{free-vars}, remove free variables that are known functions with zero free variables, and replace references to well-known functions with one free variable with that free @@ -412,7 +420,8 @@ variable, until we reach a fixed point on the free-vars map." (cond ((eliminate-closure? label free-vars) (intset-remove free var)) - ((closure-alias label well-known free-vars) + ((closure-alias (closure-label label shared bound->label) + well-known free-vars) => (lambda (alias) ;; If VAR is free in LABEL, then ALIAS must ;; also be free because its definition must @@ -455,7 +464,7 @@ variable, until we reach a fixed point on the free-vars map." (let* ((free (intmap-ref free-vars label)) (nfree (intset-count free)) - (self-known? (well-known? label)) + (self-known? (well-known? (closure-label label shared bound->label))) (self (match (intmap-ref cps label) (($ $kfun _ _ self) self)))) (define (convert-arg cps var k) "Convert one possibly free variable reference to a bound reference. @@ -642,7 +651,7 @@ bound to @var{var}, and continue to @var{k}." (with-cps cps ($ (with-cps-constants ((false #f)) ($ (have-closure false)))))) - ((and (well-known? label) + ((and (well-known? (closure-label label shared bound->label)) (trivial-intset (intmap-ref free-vars label))) ;; Well-known closures with one free variable are ;; replaced at their use sites by uses of the one free @@ -810,7 +819,7 @@ and allocate and initialize flat closures." kfun)) ;; label -> free-var... (free-vars (compute-free-vars cps kfun shared)) - (free-vars (prune-free-vars free-vars bound->label well-known))) + (free-vars (prune-free-vars free-vars bound->label well-known shared))) (let ((free-in-program (intmap-ref free-vars kfun))) (unless (eq? empty-intset free-in-program) (error "Expected no free vars in program" free-in-program))) From 030e9b76036beeffff845619875124400f33ef5b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 15 Jul 2015 16:44:49 +0200 Subject: [PATCH 012/865] Enable CPS2 closure conversion * module/language/cps2/closure-conversion.scm: Remove debug printfs. * module/language/cps2/compile-cps.scm (compile-cps): * module/language/cps/compile-bytecode.scm (compile-bytecode): Use CPS2 closure conversion by default. --- module/language/cps/compile-bytecode.scm | 2 +- module/language/cps2/closure-conversion.scm | 3 --- module/language/cps2/compile-cps.scm | 2 +- 3 files changed, 2 insertions(+), 5 deletions(-) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index b66b1a693..cc696a92f 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -517,7 +517,7 @@ ;; ;; (set! exp (optimize exp opts)) - (set! exp (if (not (kw-arg-ref opts #:cps2-convert? #f)) + (set! exp (if (not (kw-arg-ref opts #:cps2-convert? #t)) (convert-closures exp) exp)) ;; first-order optimization should go here diff --git a/module/language/cps2/closure-conversion.scm b/module/language/cps2/closure-conversion.scm index 0ae1bf341..9e3a099ce 100644 --- a/module/language/cps2/closure-conversion.scm +++ b/module/language/cps2/closure-conversion.scm @@ -201,7 +201,6 @@ the bound vars of the closure." ((eq? empty-intset unknown-kfuns) ;; All functions are well-known; we can share a closure. Use ;; the first bound variable. - (pk 'all-well-known kfuns) (let ((closure (car vars))) (intset-fold (lambda (kfun out) (intmap-add out kfun closure)) @@ -211,7 +210,6 @@ the bound vars of the closure." ;; Only one function is not-well-known. Use that ;; function's closure as the shared closure. (let ((closure (assq-ref (map cons kfuns vars) unknown-kfun))) - (pk 'one-not-well-known kfuns closure) (intset-fold (lambda (kfun out) (intmap-add out kfun closure)) kfuns-set out)))) @@ -789,7 +787,6 @@ bound to @var{var}, and continue to @var{k}." ($continue k src ($prompt escape? tag handler))))))))) - (pk 'convert-one label body free self-known?) (intset-fold (lambda (label cps) (match (intmap-ref cps label (lambda (_) #f)) (($ $kargs names vars term) diff --git a/module/language/cps2/compile-cps.scm b/module/language/cps2/compile-cps.scm index da51d3536..4c0947be5 100644 --- a/module/language/cps2/compile-cps.scm +++ b/module/language/cps2/compile-cps.scm @@ -118,6 +118,6 @@ (define (compile-cps exp env opts) (let ((exp (optimize-higher-order-cps exp opts))) - (if (kw-arg-ref opts #:cps2-convert? #f) + (if (kw-arg-ref opts #:cps2-convert? #t) (values (conts->fun* (renumber (convert-closures exp))) env env) (values (conts->fun (renumber exp)) env env)))) From 263b4099182c8d6f4e7e0f266f145c1d31f3ab33 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 15 Jul 2015 17:15:03 +0200 Subject: [PATCH 013/865] Prepare DCE pass for first-order CPS2 * module/language/cps2/dce.scm (compute-live-code): Prepare for handling first-order CPS by tracking functions in the live label set. --- module/language/cps2/dce.scm | 92 ++++++++++++++++++++---------------- 1 file changed, 52 insertions(+), 40 deletions(-) diff --git a/module/language/cps2/dce.scm b/module/language/cps2/dce.scm index 28ef04f23..6fa95f735 100644 --- a/module/language/cps2/dce.scm +++ b/module/language/cps2/dce.scm @@ -159,38 +159,37 @@ sites." (($ $kargs _ vars) vars) (_ #f))) - (define (visit-live-exp label k exp live-exps live-vars) + (define (visit-live-exp label k exp live-labels live-vars) (match exp ((or ($ $const) ($ $prim)) - (values live-exps live-vars)) + (values live-labels live-vars)) (($ $fun body) - (visit-fun body live-exps live-vars)) + (values (intset-add live-labels body) live-vars)) (($ $rec names vars (($ $fun kfuns) ...)) (let lp ((vars vars) (kfuns kfuns) - (live-exps live-exps) (live-vars live-vars)) + (live-labels live-labels) (live-vars live-vars)) (match (vector vars kfuns) - (#(() ()) (values live-exps live-vars)) + (#(() ()) (values live-labels live-vars)) (#((var . vars) (kfun . kfuns)) - (if (var-live? var live-vars) - (call-with-values (lambda () - (visit-fun kfun live-exps live-vars)) - (lambda (live-exps live-vars) - (lp vars kfuns live-exps live-vars))) - (lp vars kfuns live-exps live-vars)))))) + (lp vars kfuns + (if (var-live? var live-vars) + (intset-add live-labels kfun) + live-labels) + live-vars))))) (($ $prompt escape? tag handler) - (values live-exps (adjoin-var tag live-vars))) + (values live-labels (adjoin-var tag live-vars))) (($ $call proc args) - (values live-exps (adjoin-vars args (adjoin-var proc live-vars)))) + (values live-labels (adjoin-vars args (adjoin-var proc live-vars)))) (($ $callk k proc args) - (values live-exps (adjoin-vars args (adjoin-var proc live-vars)))) + (values live-labels (adjoin-vars args (adjoin-var proc live-vars)))) (($ $primcall name args) - (values live-exps (adjoin-vars args live-vars))) + (values live-labels (adjoin-vars args live-vars))) (($ $branch k ($ $primcall name args)) - (values live-exps (adjoin-vars args live-vars))) + (values live-labels (adjoin-vars args live-vars))) (($ $branch k ($ $values (arg))) - (values live-exps (adjoin-var arg live-vars))) + (values live-labels (adjoin-var arg live-vars))) (($ $values args) - (values live-exps + (values live-labels (match (cont-defs k) (#f (adjoin-vars args live-vars)) (defs (fold (lambda (use def live-vars) @@ -199,11 +198,11 @@ sites." live-vars)) live-vars args defs))))))) - (define (visit-exp label k exp live-exps live-vars) + (define (visit-exp label k exp live-labels live-vars) (cond - ((intset-ref live-exps label) + ((intset-ref live-labels label) ;; Expression live already. - (visit-live-exp label k exp live-exps live-vars)) + (visit-live-exp label k exp live-labels live-vars)) ((let ((defs (cont-defs k)) (fx (intmap-ref effects label))) (or @@ -233,31 +232,44 @@ sites." (not (intset-ref known-allocations obj)))) (_ #t))))) ;; Mark expression as live and visit. - (visit-live-exp label k exp (intset-add live-exps label) live-vars)) + (visit-live-exp label k exp (intset-add live-labels label) live-vars)) (else ;; Still dead. - (values live-exps live-vars)))) + (values live-labels live-vars)))) - (define (visit-fun label live-exps live-vars) + (define (visit-fun label live-labels live-vars) ;; Visit uses before definitions. (postorder-fold-local-conts2 - (lambda (label cont live-exps live-vars) + (lambda (label cont live-labels live-vars) (match cont (($ $kargs _ _ ($ $continue k src exp)) - (visit-exp label k exp live-exps live-vars)) + (visit-exp label k exp live-labels live-vars)) (($ $kreceive arity kargs) - (values live-exps live-vars)) + (values live-labels live-vars)) (($ $kclause arity kargs kalt) - (values live-exps (adjoin-vars (cont-defs kargs) live-vars))) + (values live-labels (adjoin-vars (cont-defs kargs) live-vars))) (($ $kfun src meta self) - (values live-exps (adjoin-var self live-vars))) + (values live-labels (adjoin-var self live-vars))) (($ $ktail) - (values live-exps live-vars)))) - conts label live-exps live-vars)) + (values live-labels live-vars)))) + conts label live-labels live-vars)) - (fixpoint (lambda (live-exps live-vars) - (visit-fun 0 live-exps live-vars)) - empty-intset + (fixpoint (lambda (live-labels live-vars) + (let lp ((label 0) + (live-labels live-labels) + (live-vars live-vars)) + (match (intset-next live-labels label) + (#f (values live-labels live-vars)) + (label + (call-with-values + (lambda () + (match (intmap-ref conts label) + (($ $kfun) + (visit-fun label live-labels live-vars)) + (_ (values live-labels live-vars)))) + (lambda (live-labels live-vars) + (lp (1+ label) live-labels live-vars))))))) + (intset 0) empty-intset))) (define-syntax adjoin-conts @@ -271,9 +283,9 @@ sites." ((_ cps) cps))) -(define (process-eliminations conts live-exps live-vars) - (define (exp-live? label) - (intset-ref live-exps label)) +(define (process-eliminations conts live-labels live-vars) + (define (label-live? label) + (intset-ref live-labels label)) (define (value-live? var) (intset-ref live-vars var)) (define (make-adaptor k src defs) @@ -288,7 +300,7 @@ sites." (define (visit-term label term cps) (match term (($ $continue k src exp) - (if (exp-live? label) + (if (label-live? label) (match exp (($ $fun body) (values (visit-fun body cps) @@ -370,8 +382,8 @@ sites." ;; inference. (let ((conts (renumber conts))) (call-with-values (lambda () (compute-live-code conts)) - (lambda (live-exps live-vars) - (process-eliminations conts live-exps live-vars))))) + (lambda (live-labels live-vars) + (process-eliminations conts live-labels live-vars))))) ;;; Local Variables: ;;; eval: (put 'adjoin-conts 'scheme-indent-function 1) From 1b95487501e2c55bc63b3f71931993cdb52f9ec8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 16 Jul 2015 07:22:59 +0200 Subject: [PATCH 014/865] compute-reachable-functions refactor * module/language/cps2/utils.scm (compute-reachable-functions): New function. * module/language/cps2/verify.scm (check-label-partition) (compute-reachable-labels): Use the new function. * module/language/cps2/simplify.scm (compute-singly-referenced-vars): Allow $closure. (compute-eta-reductions, compute-beta-reductions): Use compute-reachable-functions, which besides being a simplification also allows simplification to work on first-order CPS. --- module/language/cps2/simplify.scm | 74 +++++++++++++------------------ module/language/cps2/utils.scm | 39 ++++++++++++++++ module/language/cps2/verify.scm | 46 +++---------------- 3 files changed, 77 insertions(+), 82 deletions(-) diff --git a/module/language/cps2/simplify.scm b/module/language/cps2/simplify.scm index 685327a40..b87b044cd 100644 --- a/module/language/cps2/simplify.scm +++ b/module/language/cps2/simplify.scm @@ -74,7 +74,7 @@ (match cont (($ $kargs _ _ ($ $continue _ _ exp)) (match exp - ((or ($ $const) ($ $prim) ($ $fun) ($ $rec)) + ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure)) (values single multiple)) (($ $call proc args) (ref* (cons proc args))) @@ -118,30 +118,24 @@ (() #t) ((var . vars) (and (intset-ref singly-used var) (singly-used? vars))))) - (define (visit-fun kfun nested-funs eta) - (let ((body (compute-function-body conts kfun))) - (define (visit-cont label nested-funs eta) - (match (intmap-ref conts label) - (($ $kargs names vars ($ $continue k src ($ $values vars))) - (values nested-funs - (intset-maybe-add! eta label - (match (intmap-ref conts k) - (($ $kargs) - (and (not (eqv? label k)) ; A - (not (intset-ref eta label)) ; B - (singly-used? vars))) - (_ #f))))) - (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun))) - (values (intset-add! nested-funs kfun) eta)) - (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfun) ...)))) - (values (intset-add*! nested-funs kfun) eta)) - (_ - (values nested-funs eta)))) - (intset-fold visit-cont body nested-funs eta))) - (define (visit-funs worklist eta) - (intset-fold visit-fun worklist empty-intset eta)) + (define (visit-fun kfun body eta) + (define (visit-cont label eta) + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src ($ $values vars))) + (intset-maybe-add! eta label + (match (intmap-ref conts k) + (($ $kargs) + (and (not (eqv? label k)) ; A + (not (intset-ref eta label)) ; B + (singly-used? vars))) + (_ #f)))) + (_ + eta))) + (intset-fold visit-cont body eta)) (persistent-intset - (worklist-fold visit-funs (intset-add empty-intset kfun) empty-intset)))) + (intmap-fold visit-fun + (compute-reachable-functions conts kfun) + empty-intset)))) (define (eta-reduce conts kfun) (let ((label-set (compute-eta-reductions conts kfun))) @@ -197,32 +191,26 @@ (persistent-intset multiple)))) (define (compute-beta-reductions conts kfun) - (define (visit-fun kfun nested-funs beta) - (let* ((body (compute-function-body conts kfun)) - (single (compute-singly-referenced-labels conts body))) - (define (visit-cont label nested-funs beta) + (define (visit-fun kfun body beta) + (let ((single (compute-singly-referenced-labels conts body))) + (define (visit-cont label beta) (match (intmap-ref conts label) ;; A continuation's body can be inlined in place of a $values ;; expression if the continuation is a $kargs. It should only ;; be inlined if it is used only once, and not recursively. (($ $kargs _ _ ($ $continue k src ($ $values))) - (values nested-funs - (intset-maybe-add! beta label - (and (intset-ref single k) - (match (intmap-ref conts k) - (($ $kargs) #t) - (_ #f)))))) - (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun))) - (values (intset-add nested-funs kfun) beta)) - (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfun) ...)))) - (values (intset-add* nested-funs kfun) beta)) + (intset-maybe-add! beta label + (and (intset-ref single k) + (match (intmap-ref conts k) + (($ $kargs) #t) + (_ #f))))) (_ - (values nested-funs beta)))) - (intset-fold visit-cont body nested-funs beta))) - (define (visit-funs worklist beta) - (intset-fold visit-fun worklist empty-intset beta)) + beta))) + (intset-fold visit-cont body beta))) (persistent-intset - (worklist-fold visit-funs (intset-add empty-intset kfun) empty-intset))) + (intmap-fold visit-fun + (compute-reachable-functions conts kfun) + empty-intset))) (define (compute-beta-var-substitutions conts label-set) (define (add-var-substs label var-map) diff --git a/module/language/cps2/utils.scm b/module/language/cps2/utils.scm index e4ed47389..d96b776c9 100644 --- a/module/language/cps2/utils.scm +++ b/module/language/cps2/utils.scm @@ -48,6 +48,7 @@ ;; Flow analysis. compute-constant-values compute-function-body + compute-reachable-functions compute-successors invert-graph compute-predecessors @@ -231,6 +232,44 @@ disjoint, an error will be signalled." (visit-cont k labels)) (_ labels))))))))))) +(define (compute-reachable-functions conts kfun) + "Compute a mapping LABEL->LABEL..., where each key is a reachable +$kfun and each associated value is the body of the function, as an +intset." + (define (intset-cons i set) (intset-add set i)) + (define (visit-fun kfun body to-visit) + (intset-fold + (lambda (label to-visit) + (define (return kfun*) (fold intset-cons to-visit kfun*)) + (define (return1 kfun) (intset-add to-visit kfun)) + (define (return0) to-visit) + (match (intmap-ref conts label) + (($ $kargs _ _ ($ $continue _ _ exp)) + (match exp + (($ $fun label) (return1 label)) + (($ $rec _ _ (($ $fun labels) ...)) (return labels)) + (($ $closure label nfree) (return1 label)) + (($ $callk label) (return1 label)) + (_ (return0)))) + (_ (return0)))) + body + to-visit)) + (let lp ((to-visit (intset kfun)) (visited empty-intmap)) + (let ((to-visit (intset-subtract to-visit (intmap-keys visited)))) + (if (eq? to-visit empty-intset) + visited + (call-with-values + (lambda () + (intset-fold + (lambda (kfun to-visit visited) + (let ((body (compute-function-body conts kfun))) + (values (visit-fun kfun body to-visit) + (intmap-add visited kfun body)))) + to-visit + empty-intset + visited)) + lp))))) + (define (compute-successors conts kfun) (define (visit label succs) (let visit ((label kfun) (succs empty-intmap)) diff --git a/module/language/cps2/verify.scm b/module/language/cps2/verify.scm index c833d0dfe..79b43f4fd 100644 --- a/module/language/cps2/verify.scm +++ b/module/language/cps2/verify.scm @@ -182,56 +182,24 @@ definitions that are available at LABEL." (compute-available-definitions conts kfun) first-order))) -(define (reachable-functions conts kfun) - (worklist-fold* - (lambda (kfun kfuns) - ;(pk 'verify kfun kfuns) - (let ((kfuns (intset-add kfuns kfun))) - (values (intset-fold - (lambda (label nested) - (define (return kfun*) - ;(pk 'return label kfuns kfun* nested) - (append (filter (lambda (kfun) - (not (intset-ref kfuns kfun))) - kfun*) - nested)) - (define (return1 kfun) (return (list kfun))) - (define (return0) (return '())) - (match (intmap-ref conts label) - (($ $kargs _ _ ($ $continue _ _ exp)) - (match exp - (($ $fun label) (return1 label)) - (($ $rec _ _ (($ $fun labels) ...)) (return labels)) - (($ $closure label nfree) (return1 label)) - (($ $callk label) (return1 label)) - (_ (return0)))) - (_ (return0)))) - (compute-function-body conts kfun) - '()) - kfuns))) - (intset kfun) - empty-intset)) - (define (check-label-partition conts kfun) ;; A continuation can only belong to one function. - (intset-fold - (lambda (kfun seen) + (intmap-fold + (lambda (kfun body seen) (intset-fold (lambda (label seen) (intmap-add seen label kfun (lambda (old new) (error "label used by two functions" label old new)))) - (compute-function-body conts kfun) + body seen)) - (reachable-functions conts kfun) + (compute-reachable-functions conts kfun) empty-intmap)) (define (compute-reachable-labels conts kfun) - (intset-fold - (lambda (kfun seen) - (intset-union seen (compute-function-body conts kfun))) - (reachable-functions conts kfun) - empty-intset)) + (intmap-fold (lambda (kfun body seen) (intset-union seen body)) + (compute-reachable-functions conts kfun) + empty-intset)) (define (check-arities conts kfun) (define (check-arity exp cont) From e419e9e3dfe6a7194a68ac2990d854911cddbad6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 16 Jul 2015 07:24:51 +0200 Subject: [PATCH 015/865] DCE works on first-order CPS * module/language/cps2/dce.scm (compute-live-code): Use the live-labels set to indicate function liveness. $closure and $callk mark their associated functions as live. (process-eliminations): Handle $closure. * module/language/cps2/effects-analysis.scm (expression-effects): Handle $closure. --- module/language/cps2/dce.scm | 31 +++++++++++++++-------- module/language/cps2/effects-analysis.scm | 2 +- 2 files changed, 21 insertions(+), 12 deletions(-) diff --git a/module/language/cps2/dce.scm b/module/language/cps2/dce.scm index 6fa95f735..e743bc4a6 100644 --- a/module/language/cps2/dce.scm +++ b/module/language/cps2/dce.scm @@ -165,6 +165,8 @@ sites." (values live-labels live-vars)) (($ $fun body) (values (intset-add live-labels body) live-vars)) + (($ $closure body) + (values (intset-add live-labels body) live-vars)) (($ $rec names vars (($ $fun kfuns) ...)) (let lp ((vars vars) (kfuns kfuns) (live-labels live-labels) (live-vars live-vars)) @@ -180,8 +182,9 @@ sites." (values live-labels (adjoin-var tag live-vars))) (($ $call proc args) (values live-labels (adjoin-vars args (adjoin-var proc live-vars)))) - (($ $callk k proc args) - (values live-labels (adjoin-vars args (adjoin-var proc live-vars)))) + (($ $callk kfun proc args) + (values (intset-add live-labels kfun) + (adjoin-vars args (adjoin-var proc live-vars)))) (($ $primcall name args) (values live-labels (adjoin-vars args live-vars))) (($ $branch k ($ $primcall name args)) @@ -303,7 +306,10 @@ sites." (if (label-live? label) (match exp (($ $fun body) - (values (visit-fun body cps) + (values cps + term)) + (($ $closure body nfree) + (values cps term)) (($ $rec names vars funs) (match (filter-map (lambda (name var fun) @@ -314,11 +320,7 @@ sites." (values cps (build-term ($continue k src ($values ()))))) (((names vars funs) ...) - (values (fold1 (lambda (fun cps) - (match fun - (($ $fun kfun) - (visit-fun kfun cps)))) - funs cps) + (values cps (build-term ($continue k src ($rec names vars funs))))))) (_ @@ -370,10 +372,17 @@ sites." (label ($kreceive req rest adapt))))))) (_ (adjoin-conts cps (label ,cont))))) - (define (visit-fun kfun cps) - (fold-local-conts visit-cont conts kfun cps)) (with-fresh-name-state conts - (persistent-intmap (visit-fun 0 empty-intmap)))) + (persistent-intmap + (intmap-fold (lambda (label cont cps) + (match cont + (($ $kfun) + (if (label-live? label) + (fold-local-conts visit-cont conts label cps) + cps)) + (_ cps))) + conts + empty-intmap)))) (define (eliminate-dead-code conts) ;; We work on a renumbered program so that we can easily visit uses diff --git a/module/language/cps2/effects-analysis.scm b/module/language/cps2/effects-analysis.scm index a41c5f2a3..ef5d8c8e9 100644 --- a/module/language/cps2/effects-analysis.scm +++ b/module/language/cps2/effects-analysis.scm @@ -438,7 +438,7 @@ is or might be a read or a write to the same location as A." (match exp ((or ($ $const) ($ $prim) ($ $values)) &no-effects) - ((or ($ $fun) ($ $rec)) + ((or ($ $fun) ($ $rec) ($ $closure)) (&allocate &unknown-memory-kinds)) (($ $prompt) (&write-object &prompt)) From 099784ca9178c441eaf03a37349c463b75b57523 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 16 Jul 2015 07:32:52 +0200 Subject: [PATCH 016/865] Beta reduction over first-order CPS * module/language/cps2/simplify.scm (beta-reduce): Handle $closure. --- module/language/cps2/simplify.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/language/cps2/simplify.scm b/module/language/cps2/simplify.scm index b87b044cd..19d7a1799 100644 --- a/module/language/cps2/simplify.scm +++ b/module/language/cps2/simplify.scm @@ -238,7 +238,7 @@ (build-term ($continue k src ,(rewrite-exp exp - ((or ($ $const) ($ $prim) ($ $fun) ($ $rec)) + ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure)) ,exp) (($ $call proc args) ($call (subst proc) ,(map subst args))) From 6f6a6aee9d4b40d15aabbb39b4a53e3ef3f380d6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 16 Jul 2015 07:44:30 +0200 Subject: [PATCH 017/865] Optimize first-order CPS * module/language/cps2/optimize.scm: Move comments here from cps/compile-bytecode.scm. * module/language/cps/compile-bytecode.scm: Remove optimization and closure conversion calls, since CPS2 does this for us. * module/language/cps2/compile-cps.scm (compile-cps): Use set! to save memory at bootstrap-time. Optimize first-order CPS, to get rid of strangeness introduced in closure conversion. --- module/language/cps/compile-bytecode.scm | 83 +----------------------- module/language/cps2/compile-cps.scm | 12 ++-- module/language/cps2/optimize.scm | 10 +++ 3 files changed, 20 insertions(+), 85 deletions(-) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index cc696a92f..c07db2621 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -27,85 +27,19 @@ #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (language cps) - #:use-module (language cps closure-conversion) - #:use-module (language cps contification) - #:use-module (language cps constructors) - #:use-module (language cps cse) - #:use-module (language cps dce) #:use-module (language cps dfg) - #:use-module (language cps elide-values) #:use-module (language cps primitives) - #:use-module (language cps prune-bailouts) - #:use-module (language cps prune-top-level-scopes) #:use-module (language cps reify-primitives) #:use-module (language cps renumber) - #:use-module (language cps self-references) - #:use-module (language cps simplify) #:use-module (language cps slot-allocation) - #:use-module (language cps specialize-primcalls) - #:use-module (language cps type-fold) #:use-module (system vm assembler) #:export (compile-bytecode)) -;; TODO: Local var names. - (define (kw-arg-ref args kw default) (match (memq kw args) ((_ val . _) val) (_ default))) -(define (optimize exp opts) - (define (run-pass! pass kw default) - (set! exp - (if (kw-arg-ref opts kw default) - (pass exp) - exp))) - - ;; The first DCE pass is mainly to eliminate functions that aren't - ;; called. The last is mainly to eliminate rest parameters that - ;; aren't used, and thus shouldn't be consed. - - ;; This series of assignments to `env' used to be a series of let* - ;; bindings of `env', as you would imagine. In compiled code this is - ;; fine because the compiler is able to allocate all let*-bound - ;; variable to the same slot, which also means that the garbage - ;; collector doesn't have to retain so many copies of the term being - ;; optimized. However during bootstrap, the interpreter doesn't do - ;; this optimization, leading to excessive data retention as the terms - ;; are rewritten. To marginally improve bootstrap memory usage, here - ;; we use set! instead. The compiler should produce the same code in - ;; any case, though currently it does not because it doesn't do escape - ;; analysis on the box created for the set!. - - (run-pass! eliminate-dead-code #:eliminate-dead-code? #t) - ;; The prune-top-level-scopes pass doesn't work if CSE has run - ;; beforehand. Since hopefully we will be able to just remove all the - ;; old CPS stuff, let's just disable the pass for now. - ;; (run-pass! prune-top-level-scopes #:prune-top-level-scopes? #t) - (run-pass! simplify #:simplify? #t) - (run-pass! contify #:contify? #t) - (run-pass! inline-constructors #:inline-constructors? #t) - (run-pass! specialize-primcalls #:specialize-primcalls? #t) - (run-pass! elide-values #:elide-values? #t) - (run-pass! prune-bailouts #:prune-bailouts? #t) - (run-pass! eliminate-common-subexpressions #:cse? #t) - (run-pass! type-fold #:type-fold? #t) - (run-pass! resolve-self-references #:resolve-self-references? #t) - (run-pass! eliminate-dead-code #:eliminate-dead-code? #t) - (run-pass! simplify #:simplify? #t) - - ;; Passes that are needed: - ;; - ;; * Abort contification: turning abort primcalls into continuation - ;; calls, and eliding prompts if possible. - ;; - ;; * Loop peeling. Unrolls the first round through a loop if the - ;; loop has effects that CSE can work on. Requires effects - ;; analysis. When run before CSE, loop peeling is the equivalent - ;; of loop-invariant code motion (LICM). - - exp) - (define (compile-fun f asm) (let* ((dfg (compute-dfg f #:global? #f)) (allocation (allocate-slots f dfg))) @@ -509,21 +443,8 @@ (compile-entry))))) (define (compile-bytecode exp env opts) - ;; See comment in `optimize' about the use of set!. - - ;; Since CPS2's optimization pass replaces CPS and uses less memory, - ;; we disable the optimization pass for now. We'll remove it once - ;; we're sure. - ;; - ;; (set! exp (optimize exp opts)) - - (set! exp (if (not (kw-arg-ref opts #:cps2-convert? #t)) - (convert-closures exp) - exp)) - ;; first-order optimization should go here - (set! exp (reify-primitives exp)) - (set! exp (renumber exp)) - (let* ((asm (make-assembler))) + (let* ((exp (renumber (reify-primitives exp))) + (asm (make-assembler))) (match exp (($ $program funs) (for-each (lambda (fun) (compile-fun fun asm)) diff --git a/module/language/cps2/compile-cps.scm b/module/language/cps2/compile-cps.scm index 4c0947be5..85b00c95c 100644 --- a/module/language/cps2/compile-cps.scm +++ b/module/language/cps2/compile-cps.scm @@ -117,7 +117,11 @@ (_ default))) (define (compile-cps exp env opts) - (let ((exp (optimize-higher-order-cps exp opts))) - (if (kw-arg-ref opts #:cps2-convert? #t) - (values (conts->fun* (renumber (convert-closures exp))) env env) - (values (conts->fun (renumber exp)) env env)))) + ;; Use set! to save memory at bootstrap-time. (The interpreter holds + ;; onto all free variables locally bound in a function, so if we used + ;; let*, we'd hold onto earlier copies of the term.) + (set! exp (optimize-higher-order-cps exp opts)) + (set! exp (convert-closures exp)) + (set! exp (optimize-first-order-cps exp opts)) + (set! exp (renumber exp)) + (values (conts->fun* exp) env env)) diff --git a/module/language/cps2/optimize.scm b/module/language/cps2/optimize.scm index 4a19a57b7..9e877b918 100644 --- a/module/language/cps2/optimize.scm +++ b/module/language/cps2/optimize.scm @@ -75,6 +75,16 @@ (verify program) program)) +;; Passes that are needed: +;; +;; * Abort contification: turning abort primcalls into continuation +;; calls, and eliding prompts if possible. +;; +;; * Loop peeling. Unrolls the first round through a loop if the +;; loop has effects that CSE can work on. Requires effects +;; analysis. When run before CSE, loop peeling is the equivalent +;; of loop-invariant code motion (LICM). +;; (define-optimizer optimize-higher-order-cps (split-rec #:split-rec? #t) (eliminate-dead-code #:eliminate-dead-code? #t) From 420423f9a09902cf5a839a0d9df4ca8d79611fea Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 16 Jul 2015 07:58:36 +0200 Subject: [PATCH 018/865] Remove CPS optimization passes and closure conversion * module/language/cps/closure-conversion.scm: * module/language/cps/constructors.scm: * module/language/cps/contification.scm: * module/language/cps/cse.scm: * module/language/cps/dce.scm: * module/language/cps/effects-analysis.scm: * module/language/cps/elide-values.scm: * module/language/cps/prune-bailouts.scm: * module/language/cps/prune-top-level-scopes.scm: * module/language/cps/self-references.scm: * module/language/cps/simplify.scm: * module/language/cps/specialize-primcalls.scm: * module/language/cps/type-fold.scm: * module/language/cps/types.scm: Remove these files, obsoleted by CPS2. * module/Makefile.am: Update. --- module/Makefile.am | 14 - module/language/cps/closure-conversion.scm | 565 ------- module/language/cps/constructors.scm | 104 -- module/language/cps/contification.scm | 414 ----- module/language/cps/cse.scm | 545 ------- module/language/cps/dce.scm | 363 ----- module/language/cps/effects-analysis.scm | 499 ------ module/language/cps/elide-values.scm | 109 -- module/language/cps/prune-bailouts.scm | 101 -- .../language/cps/prune-top-level-scopes.scm | 114 -- module/language/cps/self-references.scm | 79 - module/language/cps/simplify.scm | 328 ---- module/language/cps/specialize-primcalls.scm | 107 -- module/language/cps/type-fold.scm | 443 ----- module/language/cps/types.scm | 1424 ----------------- 15 files changed, 5209 deletions(-) delete mode 100644 module/language/cps/closure-conversion.scm delete mode 100644 module/language/cps/constructors.scm delete mode 100644 module/language/cps/contification.scm delete mode 100644 module/language/cps/cse.scm delete mode 100644 module/language/cps/dce.scm delete mode 100644 module/language/cps/effects-analysis.scm delete mode 100644 module/language/cps/elide-values.scm delete mode 100644 module/language/cps/prune-bailouts.scm delete mode 100644 module/language/cps/prune-top-level-scopes.scm delete mode 100644 module/language/cps/self-references.scm delete mode 100644 module/language/cps/simplify.scm delete mode 100644 module/language/cps/specialize-primcalls.scm delete mode 100644 module/language/cps/type-fold.scm delete mode 100644 module/language/cps/types.scm diff --git a/module/Makefile.am b/module/Makefile.am index 270699b96..188cc7626 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -123,27 +123,13 @@ TREE_IL_LANG_SOURCES = \ CPS_LANG_SOURCES = \ language/cps.scm \ - language/cps/closure-conversion.scm \ language/cps/compile-bytecode.scm \ - language/cps/constructors.scm \ - language/cps/contification.scm \ - language/cps/cse.scm \ - language/cps/dce.scm \ language/cps/dfg.scm \ - language/cps/effects-analysis.scm \ - language/cps/elide-values.scm \ language/cps/primitives.scm \ - language/cps/prune-bailouts.scm \ - language/cps/prune-top-level-scopes.scm \ language/cps/reify-primitives.scm \ language/cps/renumber.scm \ - language/cps/self-references.scm \ language/cps/slot-allocation.scm \ - language/cps/simplify.scm \ language/cps/spec.scm \ - language/cps/specialize-primcalls.scm \ - language/cps/type-fold.scm \ - language/cps/types.scm \ language/cps/verify.scm CPS2_LANG_SOURCES = \ diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm deleted file mode 100644 index 49ff30f93..000000000 --- a/module/language/cps/closure-conversion.scm +++ /dev/null @@ -1,565 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; This pass converts a CPS term in such a way that no function has any -;;; free variables. Instead, closures are built explicitly with -;;; make-closure primcalls, and free variables are referenced through -;;; the closure. -;;; -;;; Closure conversion also removes any $rec expressions that -;;; contification did not handle. See (language cps) for a further -;;; discussion of $rec. -;;; -;;; Code: - -(define-module (language cps closure-conversion) - #:use-module (ice-9 match) - #:use-module ((srfi srfi-1) #:select (fold - filter-map - lset-union lset-difference - list-index)) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-26) - #:use-module (language cps) - #:use-module (language cps dfg) - #:export (convert-closures)) - -;; free := var ... - -(define (analyze-closures exp dfg) - "Compute the set of free variables for all $fun instances in -@var{exp}." - (let ((bound-vars (make-hash-table)) - (free-vars (make-hash-table)) - (named-funs (make-hash-table)) - (well-known-vars (make-bitvector (var-counter) #t)) - (letrec-conts (make-hash-table))) - (define (add-named-fun! var cont) - (hashq-set! named-funs var cont) - (match cont - (($ $cont label ($ $kfun src meta self)) - (unless (eq? var self) - (hashq-set! bound-vars label var))))) - (define (clear-well-known! var) - (bitvector-set! well-known-vars var #f)) - (define (compute-well-known-labels) - (let ((bv (make-bitvector (label-counter) #f))) - (hash-for-each - (lambda (var cont) - (match cont - (($ $cont label ($ $kfun src meta self)) - (unless (equal? var self) - (bitvector-set! bv label - (and (bitvector-ref well-known-vars var) - (bitvector-ref well-known-vars self))))))) - named-funs) - bv)) - (define (union a b) - (lset-union eq? a b)) - (define (difference a b) - (lset-difference eq? a b)) - (define (visit-cont cont bound) - (match cont - (($ $cont label ($ $kargs names vars body)) - (visit-term body (append vars bound))) - (($ $cont label ($ $kfun src meta self tail clause)) - (add-named-fun! self cont) - (let ((free (if clause - (visit-cont clause (list self)) - '()))) - (hashq-set! free-vars label free) - (difference free bound))) - (($ $cont label ($ $kclause arity body alternate)) - (let ((free (visit-cont body bound))) - (if alternate - (union (visit-cont alternate bound) free) - free))) - (($ $cont) '()))) - (define (visit-term term bound) - (match term - (($ $letk conts body) - (fold (lambda (cont free) - (union (visit-cont cont bound) free)) - (visit-term body bound) - conts)) - (($ $continue k src ($ $fun body)) - (match (lookup-predecessors k dfg) - ((_) (match (lookup-cont k dfg) - (($ $kargs (name) (var)) - (add-named-fun! var body)))) - (_ #f)) - (visit-cont body bound)) - (($ $continue k src ($ $rec names vars (($ $fun cont) ...))) - (hashq-set! letrec-conts k (lookup-cont k dfg)) - (let ((bound (append vars bound))) - (for-each add-named-fun! vars cont) - (fold (lambda (cont free) - (union (visit-cont cont bound) free)) - '() - cont))) - (($ $continue k src exp) - (visit-exp exp bound)))) - (define (visit-exp exp bound) - (define (adjoin var free) - (if (or (memq var bound) (memq var free)) - free - (cons var free))) - (match exp - ((or ($ $const) ($ $prim)) '()) - (($ $call proc args) - (for-each clear-well-known! args) - (fold adjoin (adjoin proc '()) args)) - (($ $primcall name args) - (for-each clear-well-known! args) - (fold adjoin '() args)) - (($ $branch kt exp) - (visit-exp exp bound)) - (($ $values args) - (for-each clear-well-known! args) - (fold adjoin '() args)) - (($ $prompt escape? tag handler) - (clear-well-known! tag) - (adjoin tag '())))) - - (let ((free (visit-cont exp '()))) - (unless (null? free) - (error "Expected no free vars in toplevel thunk" free exp)) - (values bound-vars free-vars named-funs (compute-well-known-labels) - letrec-conts)))) - -(define (prune-free-vars free-vars named-funs well-known var-aliases) - (define (well-known? label) - (bitvector-ref well-known label)) - (let ((eliminated (make-bitvector (label-counter) #f)) - (label-aliases (make-vector (label-counter) #f))) - (let lp ((label 0)) - (let ((label (bit-position #t well-known label))) - (when label - (match (hashq-ref free-vars label) - ;; Mark all well-known closures that have no free variables - ;; for elimination. - (() (bitvector-set! eliminated label #t)) - ;; Replace well-known closures that have just one free - ;; variable by references to that free variable. - ((var) - (vector-set! label-aliases label var)) - (_ #f)) - (lp (1+ label))))) - ;; Iterative free variable elimination. - (let lp () - (let ((recurse? #f)) - (define (adjoin elt list) - ;; Normally you wouldn't see duplicates in a free variable - ;; list, but with aliases that is possible. - (if (memq elt list) list (cons elt list))) - (define (prune-free closure-label free) - (match free - (() '()) - ((var . free) - (let lp ((var var) (alias-stack '())) - (match (hashq-ref named-funs var) - (($ $cont label) - (cond - ((bitvector-ref eliminated label) - (prune-free closure-label free)) - ((vector-ref label-aliases label) - => (lambda (var) - (cond - ((memq label alias-stack) - ;; We have found a set of mutually recursive - ;; well-known procedures, each of which only - ;; closes over one of the others. Mark them - ;; all for elimination. - (for-each (lambda (label) - (bitvector-set! eliminated label #t) - (set! recurse? #t)) - alias-stack) - (prune-free closure-label free)) - (else - (lp var (cons label alias-stack)))))) - ((eq? closure-label label) - ;; Eliminate self-reference. - (prune-free closure-label free)) - (else - (adjoin var (prune-free closure-label free))))) - (_ (adjoin var (prune-free closure-label free)))))))) - (hash-for-each-handle - (lambda (pair) - (match pair - ((label . ()) #t) - ((label . free) - (let ((orig-nfree (length free)) - (free (prune-free label free))) - (set-cdr! pair free) - ;; If we managed to eliminate one or more free variables - ;; from a well-known function, it could be that we can - ;; eliminate or alias this function as well. - (when (and (well-known? label) - (< (length free) orig-nfree)) - (match free - (() - (bitvector-set! eliminated label #t) - (set! recurse? #t)) - ((var) - (vector-set! label-aliases label var) - (set! recurse? #t)) - (_ #t))))))) - free-vars) - ;; Iterate to fixed point. - (when recurse? (lp)))) - ;; Populate var-aliases from label-aliases. - (hash-for-each (lambda (var cont) - (match cont - (($ $cont label) - (let ((alias (vector-ref label-aliases label))) - (when alias - (vector-set! var-aliases var alias)))))) - named-funs))) - -(define (convert-one bound label fun free-vars named-funs well-known aliases - letrec-conts) - (define (well-known? label) - (bitvector-ref well-known label)) - - (let ((free (hashq-ref free-vars label)) - (self-known? (well-known? label)) - (self (match fun (($ $kfun _ _ self) self)))) - (define (convert-free-var var k) - "Convert one possibly free variable reference to a bound reference. - -If @var{var} is free, it is replaced by a closure reference via a -@code{free-ref} primcall, and @var{k} is called with the new var. -Otherwise @var{var} is bound, so @var{k} is called with @var{var}." - (cond - ((list-index (cut eq? <> var) free) - => (lambda (free-idx) - (match (cons self-known? free) - ;; A reference to the one free var of a well-known function. - ((#t _) (k self)) - ;; A reference to one of the two free vars in a well-known - ;; function. - ((#t _ _) - (let-fresh (k*) (var*) - (build-cps-term - ($letk ((k* ($kargs (var*) (var*) ,(k var*)))) - ($continue k* #f - ($primcall (match free-idx (0 'car) (1 'cdr)) (self))))))) - (_ - (let-fresh (k* kidx) (idx var*) - (build-cps-term - ($letk ((kidx ($kargs ('idx) (idx) - ($letk ((k* ($kargs (var*) (var*) ,(k var*)))) - ($continue k* #f - ($primcall - (cond - ((not self-known?) 'free-ref) - ((<= free-idx #xff) 'vector-ref/immediate) - (else 'vector-ref)) - (self idx))))))) - ($continue kidx #f ($const free-idx))))))))) - ((eq? var bound) (k self)) - (else (k var)))) - - (define (convert-free-vars vars k) - "Convert a number of possibly free references to bound references. -@var{k} is called with the bound references, and should return the -term." - (match vars - (() (k '())) - ((var . vars) - (convert-free-var var - (lambda (var) - (convert-free-vars vars - (lambda (vars) - (k (cons var vars))))))))) - - (define (allocate-closure src name var label known? free body) - "Allocate a new closure." - (match (cons known? free) - ((#f . _) - (let-fresh (k*) () - (build-cps-term - ($letk ((k* ($kargs (name) (var) ,body))) - ($continue k* src - ($closure label (length free))))))) - ((#t) - ;; Well-known closure with no free variables; elide the - ;; binding entirely. - body) - ((#t _) - ;; Well-known closure with one free variable; the free var is the - ;; closure, and no new binding need be made. - body) - ((#t _ _) - ;; Well-known closure with two free variables; the closure is a - ;; pair. - (let-fresh (kinit kfalse) (false) - (build-cps-term - ($letk ((kinit ($kargs (name) (var) - ,body)) - (kfalse ($kargs ('false) (false) - ($continue kinit src - ($primcall 'cons (false false)))))) - ($continue kfalse src ($const #f)))))) - ;; Well-known callee with more than two free variables; the closure - ;; is a vector. - ((#t . _) - (let ((nfree (length free))) - (let-fresh (kinit klen kfalse) (false len-var) - (build-cps-term - ($letk ((kinit ($kargs (name) (var) ,body)) - (kfalse - ($kargs ('false) (false) - ($letk ((klen - ($kargs ('len) (len-var) - ($continue kinit src - ($primcall (if (<= nfree #xff) - 'make-vector/immediate - 'make-vector) - (len-var false)))))) - ($continue klen src ($const nfree)))))) - ($continue kfalse src ($const #f))))))))) - - (define (init-closure src var known? closure-free body) - "Initialize the free variables @var{closure-free} in a closure -bound to @var{var}, and continue with @var{body}." - (match (cons known? closure-free) - ;; Well-known callee with no free variables; no initialization - ;; necessary. - ((#t) body) - ;; Well-known callee with one free variable; no initialization - ;; necessary. - ((#t _) body) - ;; Well-known callee with two free variables; do a set-car! and - ;; set-cdr!. - ((#t v0 v1) - (let-fresh (kcar kcdr) () - (convert-free-var - v0 - (lambda (v0) - (build-cps-term - ($letk ((kcar ($kargs () () - ,(convert-free-var - v1 - (lambda (v1) - (build-cps-term - ($letk ((kcdr ($kargs () () ,body))) - ($continue kcdr src - ($primcall 'set-cdr! (var v1)))))))))) - ($continue kcar src - ($primcall 'set-car! (var v0))))))))) - ;; Otherwise residualize a sequence of vector-set! or free-set!, - ;; depending on whether the callee is well-known or not. - (_ - (fold (lambda (free idx body) - (let-fresh (k) (idxvar) - (build-cps-term - ($letk ((k ($kargs () () ,body))) - ,(convert-free-var - free - (lambda (free) - (build-cps-term - ($letconst (('idx idxvar idx)) - ($continue k src - ($primcall (cond - ((not known?) 'free-set!) - ((<= idx #xff) 'vector-set!/immediate) - (else 'vector-set!)) - (var idxvar free))))))))))) - body - closure-free - (iota (length closure-free)))))) - - ;; Load the closure for a known call. The callee may or may not be - ;; known at all call sites. - (define (convert-known-proc-call var label self self-known? free k) - ;; Well-known closures with one free variable are replaced at their - ;; use sites by uses of the one free variable. The use sites of a - ;; well-known closures are only in well-known proc calls, and in - ;; free lists of other closures. Here we handle the call case; the - ;; free list case is handled by prune-free-vars. - (define (rename var) - (let ((var* (vector-ref aliases var))) - (if var* - (rename var*) - var))) - (match (cons (well-known? label) - (hashq-ref free-vars label)) - ((#t) - ;; Calling a well-known procedure with no free variables; pass #f - ;; as the closure. - (let-fresh (k*) (v*) - (build-cps-term - ($letk ((k* ($kargs (v*) (v*) ,(k v*)))) - ($continue k* #f ($const #f)))))) - ((#t _) - ;; Calling a well-known procedure with one free variable; pass - ;; the free variable as the closure. - (convert-free-var (rename var) k)) - (_ - (convert-free-var var k)))) - - (define (visit-cont cont) - (rewrite-cps-cont cont - (($ $cont label ($ $kargs names vars body)) - (label ($kargs names vars ,(visit-term body)))) - (($ $cont label ($ $kfun src meta self tail clause)) - (label ($kfun src meta self ,tail - ,(and clause (visit-cont clause))))) - (($ $cont label ($ $kclause arity body alternate)) - (label ($kclause ,arity ,(visit-cont body) - ,(and alternate (visit-cont alternate))))) - (($ $cont) ,cont))) - (define (maybe-visit-cont cont) - (match cont - ;; We will inline the $kargs that binds letrec vars in place of - ;; the $rec expression. - (($ $cont label) - (and (not (hashq-ref letrec-conts label)) - (visit-cont cont))))) - (define (visit-term term) - (match term - (($ $letk conts body) - (build-cps-term - ($letk ,(filter-map maybe-visit-cont conts) ,(visit-term body)))) - - (($ $continue k src (or ($ $const) ($ $prim))) - term) - - (($ $continue k src ($ $fun ($ $cont kfun))) - (let ((fun-free (hashq-ref free-vars kfun))) - (match (cons (well-known? kfun) fun-free) - ((known?) - (build-cps-term - ($continue k src ,(if known? - (build-cps-exp ($const #f)) - (build-cps-exp ($closure kfun 0)))))) - ((#t _) - ;; A well-known closure of one free variable is replaced - ;; at each use with the free variable itself, so we don't - ;; need a binding at all; and yet, the continuation - ;; expects one value, so give it something. DCE should - ;; clean up later. - (build-cps-term - ($continue k src ,(build-cps-exp ($const #f))))) - (_ - (let-fresh () (var) - (allocate-closure - src #f var kfun (well-known? kfun) fun-free - (init-closure - src var (well-known? kfun) fun-free - (build-cps-term ($continue k src ($values (var))))))))))) - - ;; Remove letrec. - (($ $continue k src ($ $rec names vars funs)) - (let lp ((in (map list names vars funs)) - (bindings (lambda (body) body)) - (body (match (hashq-ref letrec-conts k) - ;; Remove these letrec bindings, as we're - ;; going to inline the body after building - ;; each closure separately. - (($ $kargs names syms body) - (visit-term body))))) - (match in - (() (bindings body)) - (((name var ($ $fun - (and fun-body - ($ $cont kfun ($ $kfun src))))) . in) - (let ((fun-free (hashq-ref free-vars kfun))) - (lp in - (lambda (body) - (allocate-closure - src name var kfun (well-known? kfun) fun-free - (bindings body))) - (init-closure - src var (well-known? kfun) fun-free - body))))))) - - (($ $continue k src ($ $call proc args)) - (match (hashq-ref named-funs proc) - (($ $cont kfun) - (convert-known-proc-call - proc kfun self self-known? free - (lambda (proc) - (convert-free-vars args - (lambda (args) - (build-cps-term - ($continue k src - ($callk kfun proc args)))))))) - (#f - (convert-free-vars (cons proc args) - (match-lambda - ((proc . args) - (build-cps-term - ($continue k src - ($call proc args))))))))) - - (($ $continue k src ($ $primcall name args)) - (convert-free-vars args - (lambda (args) - (build-cps-term - ($continue k src ($primcall name args)))))) - - (($ $continue k src ($ $branch kt ($ $primcall name args))) - (convert-free-vars args - (lambda (args) - (build-cps-term - ($continue k src - ($branch kt ($primcall name args))))))) - - (($ $continue k src ($ $branch kt ($ $values (arg)))) - (convert-free-var arg - (lambda (arg) - (build-cps-term - ($continue k src - ($branch kt ($values (arg)))))))) - - (($ $continue k src ($ $values args)) - (convert-free-vars args - (lambda (args) - (build-cps-term - ($continue k src ($values args)))))) - - (($ $continue k src ($ $prompt escape? tag handler)) - (convert-free-var tag - (lambda (tag) - (build-cps-term - ($continue k src - ($prompt escape? tag handler)))))))) - (visit-cont (build-cps-cont (label ,fun))))) - -(define (convert-closures fun) - "Convert free reference in @var{exp} to primcalls to @code{free-ref}, -and allocate and initialize flat closures." - (let ((dfg (compute-dfg fun))) - (with-fresh-name-state-from-dfg dfg - (call-with-values (lambda () (analyze-closures fun dfg)) - (lambda (bound-vars free-vars named-funs well-known letrec-conts) - (let ((labels (sort (hash-map->list (lambda (k v) k) free-vars) <)) - (aliases (make-vector (var-counter) #f))) - (prune-free-vars free-vars named-funs well-known aliases) - (build-cps-term - ($program - ,(map (lambda (label) - (convert-one (hashq-ref bound-vars label) label - (lookup-cont label dfg) - free-vars named-funs well-known aliases - letrec-conts)) - labels))))))))) diff --git a/module/language/cps/constructors.scm b/module/language/cps/constructors.scm deleted file mode 100644 index bbe779d27..000000000 --- a/module/language/cps/constructors.scm +++ /dev/null @@ -1,104 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; Constructor inlining turns "list" primcalls into a series of conses, -;;; and does similar transformations for "vector". -;;; -;;; Code: - -(define-module (language cps constructors) - #:use-module (ice-9 match) - #:use-module (srfi srfi-26) - #:use-module (language cps) - #:export (inline-constructors)) - -(define (inline-constructors* fun) - (define (visit-cont cont) - (rewrite-cps-cont cont - (($ $cont sym ($ $kargs names syms body)) - (sym ($kargs names syms ,(visit-term body)))) - (($ $cont sym ($ $kfun src meta self tail clause)) - (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause))))) - (($ $cont sym ($ $kclause arity body alternate)) - (sym ($kclause ,arity ,(visit-cont body) - ,(and alternate (visit-cont alternate))))) - (($ $cont) - ,cont))) - (define (visit-term term) - (rewrite-cps-term term - (($ $letk conts body) - ($letk ,(map visit-cont conts) - ,(visit-term body))) - (($ $continue k src ($ $primcall 'list args)) - ,(let-fresh (kvalues) (val) - (build-cps-term - ($letk ((kvalues ($kargs ('val) (val) - ($continue k src - ($primcall 'values (val)))))) - ,(let lp ((args args) (k kvalues)) - (match args - (() - (build-cps-term - ($continue k src ($const '())))) - ((arg . args) - (let-fresh (ktail) (tail) - (build-cps-term - ($letk ((ktail ($kargs ('tail) (tail) - ($continue k src - ($primcall 'cons (arg tail)))))) - ,(lp args ktail))))))))))) - (($ $continue k src ($ $primcall 'vector args)) - ,(let-fresh (kalloc) (vec len init) - (define (initialize args n) - (match args - (() - (build-cps-term - ($continue k src ($primcall 'values (vec))))) - ((arg . args) - (let-fresh (knext) (idx) - (build-cps-term - ($letk ((knext ($kargs () () - ,(initialize args (1+ n))))) - ($letconst (('idx idx n)) - ($continue knext src - ($primcall 'vector-set! (vec idx arg)))))))))) - (build-cps-term - ($letk ((kalloc ($kargs ('vec) (vec) - ,(initialize args 0)))) - ($letconst (('len len (length args)) - ('init init #f)) - ($continue kalloc src - ($primcall 'make-vector (len init)))))))) - (($ $continue k src (and fun ($ $fun))) - ($continue k src ,(visit-fun fun))) - (($ $continue k src ($ $rec names syms funs)) - ($continue k src ($rec names syms (map visit-fun funs)))) - (($ $continue) - ,term))) - (define (visit-fun fun) - (rewrite-cps-exp fun - (($ $fun body) - ($fun ,(inline-constructors* body))))) - - (visit-cont fun)) - -(define (inline-constructors fun) - (with-fresh-name-state fun - (inline-constructors* fun))) diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm deleted file mode 100644 index 1f702310a..000000000 --- a/module/language/cps/contification.scm +++ /dev/null @@ -1,414 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; Contification is a pass that turns $fun instances into $cont -;;; instances if all calls to the $fun return to the same continuation. -;;; This is a more rigorous variant of our old "fixpoint labels -;;; allocation" optimization. -;;; -;;; See Kennedy's "Compiling with Continuations, Continued", and Fluet -;;; and Weeks's "Contification using Dominators". -;;; -;;; Code: - -(define-module (language cps contification) - #:use-module (ice-9 match) - #:use-module ((srfi srfi-1) #:select (concatenate filter-map)) - #:use-module (srfi srfi-26) - #:use-module (language cps) - #:use-module (language cps dfg) - #:use-module (language cps primitives) - #:use-module (language bytecode) - #:export (contify)) - -(define (compute-contification fun) - (let* ((dfg (compute-dfg fun)) - (scope-table (make-hash-table)) - (call-substs '()) - (cont-substs '()) - (cont-splices (make-hash-table))) - (define (subst-call! sym arities body-ks) - (set! call-substs (acons sym (map cons arities body-ks) call-substs))) - (define (subst-return! old-tail new-tail) - (set! cont-substs (acons old-tail new-tail cont-substs))) - (define (splice-conts! scope conts) - (for-each (match-lambda - (($ $cont k) (hashq-set! scope-table k scope))) - conts) - (hashq-set! cont-splices scope - (append conts (hashq-ref cont-splices scope '())))) - - (define (lookup-return-cont k) - (match (assq-ref cont-substs k) - (#f k) - (k (lookup-return-cont k)))) - - ;; If K is a continuation that binds one variable, and it has only - ;; one predecessor, return that variable. - (define (bound-symbol k) - (match (lookup-cont k dfg) - (($ $kargs (_) (sym)) - (match (lookup-predecessors k dfg) - ((_) - ;; K has one predecessor, the one that defined SYM. - sym) - (_ #f))) - (_ #f))) - - (define (extract-arities clause) - (match clause - (($ $cont _ ($ $kclause arity body alternate)) - (cons arity (extract-arities alternate))) - (#f '()))) - (define (extract-bodies clause) - (match clause - (($ $cont _ ($ $kclause arity body alternate)) - (cons body (extract-bodies alternate))) - (#f '()))) - - (define (contify-fun term-k sym self tail arities bodies) - (contify-funs term-k - (list sym) (list self) (list tail) - (list arities) (list bodies))) - - ;; Given a set of mutually recursive functions bound to local - ;; variables SYMS, with self symbols SELFS, tail continuations - ;; TAILS, arities ARITIES, and bodies BODIES, all bound in TERM-K, - ;; contify them if we can prove that they all return to the same - ;; continuation. Returns a true value on success, and false - ;; otherwise. - (define (contify-funs term-k syms selfs tails arities bodies) - (define (unused? sym) - (null? (lookup-uses sym dfg))) - - ;; Are the given args compatible with any of the arities? - (define (applicable? proc args) - (let lp ((arities (assq-ref (map cons syms arities) proc))) - (match arities - ((($ $arity req () #f () #f) . arities) - (or (= (length args) (length req)) - (lp arities))) - ;; If we reached the end of the arities, fail. Also fail if - ;; the next arity in the list has optional, keyword, or rest - ;; arguments. - (_ #f)))) - - ;; If the use of PROC in continuation USE is a call to PROC that - ;; is compatible with one of the procedure's arities, return the - ;; target continuation. Otherwise return #f. - (define (call-target use proc) - (match (find-call (lookup-cont use dfg)) - (($ $continue k src ($ $call proc* args)) - (and (eq? proc proc*) (not (memq proc args)) (applicable? proc args) - ;; Converge more quickly by resolving already-contified - ;; call targets. - (lookup-return-cont k))) - (_ #f))) - - ;; If this set of functions is always called with one - ;; continuation, not counting tail calls between the functions, - ;; return that continuation. - (define (find-common-continuation) - (let visit-syms ((syms syms) (k #f)) - (match syms - (() k) - ((sym . syms) - (let visit-uses ((uses (lookup-uses sym dfg)) (k k)) - (match uses - (() (visit-syms syms k)) - ((use . uses) - (and=> (call-target use sym) - (lambda (k*) - (cond - ((memq k* tails) (visit-uses uses k)) - ((not k) (visit-uses uses k*)) - ((eq? k k*) (visit-uses uses k)) - (else #f))))))))))) - - ;; Given that the functions are called with the common - ;; continuation K, determine the scope at which to contify the - ;; functions. If K is in scope in the term, we go ahead and - ;; contify them there. Otherwise the scope is inside the letrec - ;; body, and so choose the scope in which the continuation is - ;; defined, whose free variables are a superset of the free - ;; variables of the functions. - ;; - ;; There is some slight trickiness here. Call-target already uses - ;; the information we compute within this pass. Previous - ;; contifications may cause functions to be contified not at their - ;; point of definition but at their point of non-recursive use. - ;; That will cause the scope nesting to change. (It may - ;; effectively push a function deeper down the tree -- the second - ;; case above, a call within the letrec body.) What if we contify - ;; to the tail of a previously contified function? We have to - ;; track what the new scope tree will be when asking whether K - ;; will be bound in TERM-K's scope, not the scope tree that - ;; existed when we started the pass. - ;; - ;; FIXME: Does this choose the right scope for contified let-bound - ;; functions? - (define (find-contification-scope k) - (define (scope-contains? scope k) - (let ((k-scope (or (hashq-ref scope-table k) - (let ((k-scope (lookup-block-scope k dfg))) - (hashq-set! scope-table k k-scope) - k-scope)))) - (or (eq? scope k-scope) - (and k-scope (scope-contains? scope k-scope))))) - - ;; Find the scope of K. - (define (continuation-scope k) - (or (hashq-ref scope-table k) - (let ((scope (lookup-block-scope k dfg))) - (hashq-set! scope-table k scope) - scope))) - - (let ((k-scope (continuation-scope k))) - (if (scope-contains? k-scope term-k) - term-k - (match (lookup-cont k-scope dfg) - (($ $kfun src meta self tail clause) - ;; K is the tail of some function. If that function - ;; has just one clause, return that clause. Otherwise - ;; bail. - (match clause - (($ $cont _ ($ $kclause arity ($ $cont kargs) #f)) - kargs) - (_ #f))) - (_ k-scope))))) - - ;; We are going to contify. Mark all SYMs for replacement in - ;; calls, and mark the tail continuations for replacement by K. - ;; Arrange for the continuations to be spliced into SCOPE. - (define (enqueue-contification! k scope) - (for-each (lambda (sym tail arities bodies) - (match bodies - ((($ $cont body-k) ...) - (subst-call! sym arities body-k))) - (subst-return! tail k)) - syms tails arities bodies) - (splice-conts! scope (concatenate bodies)) - #t) - - ;; "Call me maybe" - (and (and-map unused? selfs) - (and=> (find-common-continuation) - (lambda (k) - (and=> (find-contification-scope k) - (cut enqueue-contification! k <>)))))) - - (define (visit-fun term) - (match term - (($ $fun body) - (visit-cont body)))) - (define (visit-cont cont) - (match cont - (($ $cont sym ($ $kargs _ _ body)) - (visit-term body sym)) - (($ $cont sym ($ $kfun src meta self tail clause)) - (when clause (visit-cont clause))) - (($ $cont sym ($ $kclause arity body alternate)) - (visit-cont body) - (when alternate (visit-cont alternate))) - (($ $cont) - #t))) - (define (visit-term term term-k) - (match term - (($ $letk conts body) - (for-each visit-cont conts) - (visit-term body term-k)) - (($ $continue k src exp) - (match exp - (($ $fun - ($ $cont fun-k - ($ $kfun src meta self ($ $cont tail-k ($ $ktail)) clause))) - (if (and=> (bound-symbol k) - (lambda (sym) - (contify-fun term-k sym self tail-k - (extract-arities clause) - (extract-bodies clause)))) - (begin - (for-each visit-cont (extract-bodies clause))) - (visit-fun exp))) - (($ $rec names syms funs) - (define (split-components nsf) - ;; FIXME: Compute strongly-connected components. Currently - ;; we just put non-recursive functions in their own - ;; components, and lump everything else in the remaining - ;; component. - (define (recursive? k) - (or-map (cut variable-free-in? <> k dfg) syms)) - (let lp ((nsf nsf) (rec '())) - (match nsf - (() - (if (null? rec) - '() - (list rec))) - (((and elt (n s ($ $fun ($ $cont kfun)))) - . nsf) - (if (recursive? kfun) - (lp nsf (cons elt rec)) - (cons (list elt) (lp nsf rec))))))) - (define (extract-arities+bodies clauses) - (values (map extract-arities clauses) - (map extract-bodies clauses))) - (define (visit-component component) - (match component - (((name sym fun) ...) - (match fun - ((($ $fun - ($ $cont fun-k - ($ $kfun src meta self ($ $cont tail-k ($ $ktail)) - clause))) - ...) - (call-with-values (lambda () (extract-arities+bodies clause)) - (lambda (arities bodies) - ;; Technically the procedures are created in - ;; term-k but bound for use in k. But, there is - ;; a tight link between term-k and k, as they - ;; are in the same block. Mark k as the - ;; contification scope, because that's where - ;; they'll be used. Perhaps we can fix this - ;; with the new CPS dialect that doesn't have - ;; $letk. - (if (contify-funs k sym self tail-k arities bodies) - (for-each (cut for-each visit-cont <>) bodies) - (for-each visit-fun fun))))))))) - (for-each visit-component - (split-components (map list names syms funs)))) - (_ #t))))) - - (visit-cont fun) - (values call-substs cont-substs cont-splices))) - -(define (apply-contification fun call-substs cont-substs cont-splices) - (define (contify-call src proc args) - (and=> (assq-ref call-substs proc) - (lambda (clauses) - (let lp ((clauses clauses)) - (match clauses - (() (error "invalid contification")) - (((($ $arity req () #f () #f) . k) . clauses) - (if (= (length req) (length args)) - (build-cps-term - ($continue k src - ($values args))) - (lp clauses))) - ((_ . clauses) (lp clauses))))))) - (define (continue k src exp) - (define (lookup-return-cont k) - (match (assq-ref cont-substs k) - (#f k) - (k (lookup-return-cont k)))) - (let ((k* (lookup-return-cont k))) - ;; We are contifying this return. It must be a call or a - ;; primcall to values, return, or return-values. - (if (eq? k k*) - (build-cps-term ($continue k src ,exp)) - (rewrite-cps-term exp - (($ $primcall 'return (val)) - ($continue k* src ($primcall 'values (val)))) - (($ $values vals) - ($continue k* src ($primcall 'values vals))) - (_ ($continue k* src ,exp)))))) - (define (splice-continuations term-k term) - (match (hashq-ref cont-splices term-k) - (#f term) - ((cont ...) - (let lp ((term term)) - (rewrite-cps-term term - (($ $letk conts* body) - ($letk ,(append conts* (filter-map visit-cont cont)) - ,body)) - (body - ($letk ,(filter-map visit-cont cont) - ,body))))))) - (define (visit-fun term) - (rewrite-cps-exp term - (($ $fun body) - ($fun ,(visit-cont body))))) - (define (visit-cont cont) - (rewrite-cps-cont cont - (($ $cont label ($ $kargs names syms body)) - ;; Remove bindings for functions that have been contified. - ,(rewrite-cps-cont (filter (match-lambda - ((name sym) (not (assq sym call-substs)))) - (map list names syms)) - (((names syms) ...) - (label ($kargs names syms ,(visit-term body label)))))) - (($ $cont label ($ $kfun src meta self tail clause)) - (label ($kfun src meta self ,tail ,(and clause (visit-cont clause))))) - (($ $cont label ($ $kclause arity body alternate)) - (label ($kclause ,arity ,(visit-cont body) - ,(and alternate (visit-cont alternate))))) - (($ $cont) - ,cont))) - (define (visit-term term term-k) - (match term - (($ $letk conts body) - ;; Visit the body first, so we rewrite depth-first. - (let lp ((body (visit-term body term-k))) - ;; Because we attach contified functions on a particular - ;; term-k, and one term-k can correspond to an arbitrarily - ;; nested sequence of $letk instances, normalize so that all - ;; continuations are bound by one $letk -- guaranteeing that - ;; they are in the same scope. - (rewrite-cps-term body - (($ $letk conts* body) - ($letk ,(append conts* (filter-map visit-cont conts)) - ,body)) - (body - ($letk ,(filter-map visit-cont conts) - ,body))))) - (($ $continue k src exp) - (splice-continuations - term-k - (match exp - (($ $fun - ($ $cont fun-k ($ $kfun src meta self ($ $cont tail-k)))) - ;; If the function's tail continuation has been substituted, - ;; that means it has been contified. - (continue k src - (if (assq tail-k cont-substs) - (build-cps-exp ($values ())) - (visit-fun exp)))) - (($ $rec names syms funs) - (match (filter (match-lambda - ((n s f) (not (assq s call-substs)))) - (map list names syms funs)) - (() (continue k src (build-cps-exp ($values ())))) - (((names syms funs) ...) - (continue k src - (build-cps-exp - ($rec names syms (map visit-fun funs))))))) - (($ $call proc args) - (or (contify-call src proc args) - (continue k src exp))) - (_ (continue k src exp))))))) - (visit-cont fun)) - -(define (contify fun) - (call-with-values (lambda () (compute-contification fun)) - (lambda (call-substs cont-substs cont-splices) - (if (null? call-substs) - fun - ;; Iterate to fixed point. - (contify - (apply-contification fun call-substs cont-substs cont-splices)))))) diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm deleted file mode 100644 index c8a57ca0b..000000000 --- a/module/language/cps/cse.scm +++ /dev/null @@ -1,545 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; Common subexpression elimination for CPS. -;;; -;;; Code: - -(define-module (language cps cse) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (language cps) - #:use-module (language cps dfg) - #:use-module (language cps effects-analysis) - #:use-module (language cps renumber) - #:use-module (language cps intset) - #:use-module (rnrs bytevectors) - #:export (eliminate-common-subexpressions)) - -(define (cont-successors cont) - (match cont - (($ $kargs names syms body) - (let lp ((body body)) - (match body - (($ $letk conts body) (lp body)) - (($ $continue k src exp) - (match exp - (($ $prompt escape? tag handler) (list k handler)) - (($ $branch kt) (list k kt)) - (_ (list k))))))) - - (($ $kreceive arity k) (list k)) - - (($ $kclause arity ($ $cont kbody)) (list kbody)) - - (($ $kfun src meta self tail clause) - (let lp ((clause clause)) - (match clause - (($ $cont kclause ($ $kclause _ _ alt)) - (cons kclause (lp alt))) - (#f '())))) - - (($ $kfun src meta self tail #f) '()) - - (($ $ktail) '()))) - -(define (compute-available-expressions dfg min-label label-count idoms) - "Compute and return the continuations that may be reached if flow -reaches a continuation N. Returns a vector of intsets, whose first -index corresponds to MIN-LABEL, and so on." - (let* ((effects (compute-effects dfg min-label label-count)) - ;; Vector of intsets, indicating that at a continuation N, the - ;; values from continuations M... are available. - (avail (make-vector label-count #f)) - (revisit-label #f)) - - (define (label->idx label) (- label min-label)) - (define (idx->label idx) (+ idx min-label)) - (define (get-effects label) (vector-ref effects (label->idx label))) - - (define (propagate! pred succ out) - (let* ((succ-idx (label->idx succ)) - (in (match (lookup-predecessors succ dfg) - ;; Fast path: normal control flow. - ((_) out) - ;; Slow path: control-flow join. - (_ (cond - ((vector-ref avail succ-idx) - => (lambda (in) - (intset-intersect in out))) - (else out)))))) - (when (and (<= succ pred) - (or (not revisit-label) (< succ revisit-label)) - (not (eq? in (vector-ref avail succ-idx)))) - ;; Arrange to revisit if this is not a forward edge and the - ;; available set changed. - (set! revisit-label succ)) - (vector-set! avail succ-idx in))) - - (define (clobber label in) - (let ((fx (get-effects label))) - (cond - ((not (causes-effect? fx &write)) - ;; Fast-path if this expression clobbers nothing. - in) - (else - ;; Kill clobbered expressions. There is no need to check on - ;; any label before than the last dominating label that - ;; clobbered everything. - (let ((first (let lp ((dom label)) - (let* ((dom (vector-ref idoms (label->idx dom)))) - (and (< min-label dom) - (let ((fx (vector-ref effects (label->idx dom)))) - (if (causes-all-effects? fx) - dom - (lp dom)))))))) - (let lp ((i first) (in in)) - (cond - ((intset-next in i) - => (lambda (i) - (if (effect-clobbers? fx (vector-ref effects (label->idx i))) - (lp (1+ i) (intset-remove in i)) - (lp (1+ i) in)))) - (else in)))))))) - - (synthesize-definition-effects! effects dfg min-label label-count) - - (vector-set! avail 0 empty-intset) - - (let lp ((n 0)) - (cond - ((< n label-count) - (let* ((label (idx->label n)) - ;; It's possible for "in" to be #f if it has no - ;; predecessors, as is the case for the ktail of a - ;; function with an iloop. - (in (or (vector-ref avail n) empty-intset)) - (out (intset-add (clobber label in) label))) - (lookup-predecessors label dfg) - (let visit-succs ((succs (cont-successors (lookup-cont label dfg)))) - (match succs - (() (lp (1+ n))) - ((succ . succs) - (propagate! label succ out) - (visit-succs succs)))))) - (revisit-label - (let ((n (label->idx revisit-label))) - (set! revisit-label #f) - (lp n))) - (else - (values avail effects)))))) - -(define (compute-truthy-expressions dfg min-label label-count) - "Compute a \"truth map\", indicating which expressions can be shown to -be true and/or false at each of LABEL-COUNT expressions in DFG, starting -from MIN-LABEL. Returns a vector of intsets, each intset twice as long -as LABEL-COUNT. The even elements of the intset indicate labels that -may be true, and the odd ones indicate those that may be false. It -could be that both true and false proofs are available." - (let ((boolv (make-vector label-count #f)) - (revisit-label #f)) - (define (label->idx label) (- label min-label)) - (define (idx->label idx) (+ idx min-label)) - (define (true-idx idx) (ash idx 1)) - (define (false-idx idx) (1+ (ash idx 1))) - - (define (propagate! pred succ out) - (let* ((succ-idx (label->idx succ)) - (in (match (lookup-predecessors succ dfg) - ;; Fast path: normal control flow. - ((_) out) - ;; Slow path: control-flow join. - (_ (cond - ((vector-ref boolv succ-idx) - => (lambda (in) - (intset-intersect in out))) - (else out)))))) - (when (and (<= succ pred) - (or (not revisit-label) (< succ revisit-label)) - (not (eq? in (vector-ref boolv succ-idx)))) - (set! revisit-label succ)) - (vector-set! boolv succ-idx in))) - - (vector-set! boolv 0 empty-intset) - - (let lp ((n 0)) - (cond - ((< n label-count) - (let* ((label (idx->label n)) - ;; It's possible for "in" to be #f if it has no - ;; predecessors, as is the case for the ktail of a - ;; function with an iloop. - (in (or (vector-ref boolv n) empty-intset))) - (define (default-propagate) - (let visit-succs ((succs (cont-successors (lookup-cont label dfg)))) - (match succs - (() (lp (1+ n))) - ((succ . succs) - (propagate! label succ in) - (visit-succs succs))))) - (match (lookup-cont label dfg) - (($ $kargs names syms body) - (match (find-call body) - (($ $continue k src ($ $branch kt)) - (propagate! label k (intset-add in (false-idx n))) - (propagate! label kt (intset-add in (true-idx n))) - (lp (1+ n))) - (_ (default-propagate)))) - (_ (default-propagate))))) - (revisit-label - (let ((n (label->idx revisit-label))) - (set! revisit-label #f) - (lp n))) - (else boolv))))) - -;; Returns a map of label-idx -> (var-idx ...) indicating the variables -;; defined by a given labelled expression. -(define (compute-defs dfg min-label label-count) - (define (cont-defs k) - (match (lookup-cont k dfg) - (($ $kargs names vars) vars) - (_ '()))) - (define (idx->label idx) (+ idx min-label)) - (let ((defs (make-vector label-count '()))) - (let lp ((n 0)) - (when (< n label-count) - (vector-set! - defs - n - (match (lookup-cont (idx->label n) dfg) - (($ $kargs _ _ body) - (match (find-call body) - (($ $continue k) (cont-defs k)))) - (($ $kreceive arity kargs) - (cont-defs kargs)) - (($ $kclause arity ($ $cont kargs ($ $kargs names syms))) - syms) - (($ $kfun src meta self) (list self)) - (($ $ktail) '()))) - (lp (1+ n)))) - defs)) - -(define (compute-label-and-var-ranges fun) - (match fun - (($ $cont kfun ($ $kfun src meta self)) - ((make-local-cont-folder min-label label-count min-var var-count) - (lambda (k cont min-label label-count min-var var-count) - (let ((min-label (min k min-label)) - (label-count (1+ label-count))) - (match cont - (($ $kargs names vars body) - (values min-label label-count - (fold min min-var vars) (+ var-count (length vars)))) - (($ $kfun src meta self) - (values min-label label-count (min self min-var) (1+ var-count))) - (_ - (values min-label label-count min-var var-count))))) - fun kfun 0 self 0)))) - -;; Compute a vector containing, for each node, a list of the nodes that -;; it immediately dominates. These are the "D" edges in the DJ tree. - -(define (compute-equivalent-subexpressions fun dfg) - (define (compute min-label label-count min-var var-count idoms avail effects) - (let ((defs (compute-defs dfg min-label label-count)) - (var-substs (make-vector var-count #f)) - (equiv-labels (make-vector label-count #f)) - (equiv-set (make-hash-table))) - (define (idx->label idx) (+ idx min-label)) - (define (label->idx label) (- label min-label)) - (define (idx->var idx) (+ idx min-var)) - (define (var->idx var) (- var min-var)) - - (define (for-each/2 f l1 l2) - (unless (= (length l1) (length l2)) - (error "bad lengths" l1 l2)) - (let lp ((l1 l1) (l2 l2)) - (when (pair? l1) - (f (car l1) (car l2)) - (lp (cdr l1) (cdr l2))))) - - (define (subst-var var) - ;; It could be that the var is free in this function; if so, its - ;; name will be less than min-var. - (let ((idx (var->idx var))) - (if (<= 0 idx) - (vector-ref var-substs idx) - var))) - - (define (compute-exp-key exp) - (match exp - (($ $const val) (cons 'const val)) - (($ $prim name) (cons 'prim name)) - (($ $fun body) #f) - (($ $rec names syms funs) #f) - (($ $call proc args) #f) - (($ $callk k proc args) #f) - (($ $primcall name args) - (cons* 'primcall name (map subst-var args))) - (($ $branch _ ($ $primcall name args)) - (cons* 'primcall name (map subst-var args))) - (($ $branch) #f) - (($ $values args) #f) - (($ $prompt escape? tag handler) #f))) - - (define (add-auxiliary-definitions! label exp-key) - (let ((defs (vector-ref defs (label->idx label)))) - (define (add-def! aux-key var) - (let ((equiv (hash-ref equiv-set aux-key '()))) - (hash-set! equiv-set aux-key - (acons label (list var) equiv)))) - (match exp-key - (('primcall 'box val) - (match defs - ((box) - (add-def! `(primcall box-ref ,(subst-var box)) val)))) - (('primcall 'box-set! box val) - (add-def! `(primcall box-ref ,box) val)) - (('primcall 'cons car cdr) - (match defs - ((pair) - (add-def! `(primcall car ,(subst-var pair)) car) - (add-def! `(primcall cdr ,(subst-var pair)) cdr)))) - (('primcall 'set-car! pair car) - (add-def! `(primcall car ,pair) car)) - (('primcall 'set-cdr! pair cdr) - (add-def! `(primcall cdr ,pair) cdr)) - (('primcall (or 'make-vector 'make-vector/immediate) len fill) - (match defs - ((vec) - (add-def! `(primcall vector-length ,(subst-var vec)) len)))) - (('primcall 'vector-set! vec idx val) - (add-def! `(primcall vector-ref ,vec ,idx) val)) - (('primcall 'vector-set!/immediate vec idx val) - (add-def! `(primcall vector-ref/immediate ,vec ,idx) val)) - (('primcall (or 'allocate-struct 'allocate-struct/immediate) - vtable size) - (match defs - (() #f) ;; allocate-struct in tail or kreceive position. - ((struct) - (add-def! `(primcall struct-vtable ,(subst-var struct)) - vtable)))) - (('primcall 'struct-set! struct n val) - (add-def! `(primcall struct-ref ,struct ,n) val)) - (('primcall 'struct-set!/immediate struct n val) - (add-def! `(primcall struct-ref/immediate ,struct ,n) val)) - (_ #t)))) - - ;; The initial substs vector is the identity map. - (let lp ((var min-var)) - (when (< (var->idx var) var-count) - (vector-set! var-substs (var->idx var) var) - (lp (1+ var)))) - - ;; Traverse the labels in fun in forward order, which will visit - ;; dominators first. - (let lp ((label min-label)) - (when (< (label->idx label) label-count) - (match (lookup-cont label dfg) - (($ $kargs names vars body) - (match (find-call body) - (($ $continue k src exp) - (let* ((exp-key (compute-exp-key exp)) - (equiv (hash-ref equiv-set exp-key '())) - (lidx (label->idx label)) - (fx (vector-ref effects lidx)) - (avail (vector-ref avail lidx))) - (let lp ((candidates equiv)) - (match candidates - (() - ;; No matching expressions. Add our expression - ;; to the equivalence set, if appropriate. Note - ;; that expressions that allocate a fresh object - ;; or change the current fluid environment can't - ;; be eliminated by CSE (though DCE might do it - ;; if the value proves to be unused, in the - ;; allocation case). - (when (and exp-key - (not (causes-effect? fx &allocation)) - (not (effect-clobbers? - fx - (&read-object &fluid)))) - (hash-set! equiv-set exp-key - (acons label (vector-ref defs lidx) - equiv)))) - (((and head (candidate . vars)) . candidates) - (cond - ((not (intset-ref avail candidate)) - ;; This expression isn't available here; try - ;; the next one. - (lp candidates)) - (else - ;; Yay, a match. Mark expression as equivalent. - (vector-set! equiv-labels lidx head) - ;; If we dominate the successor, mark vars - ;; for substitution. - (when (= label (vector-ref idoms (label->idx k))) - (for-each/2 - (lambda (var subst-var) - (vector-set! var-substs (var->idx var) subst-var)) - (vector-ref defs lidx) - vars))))))) - ;; If this expression defines auxiliary definitions, - ;; as `cons' does for the results of `car' and `cdr', - ;; define those. Do so after finding equivalent - ;; expressions, so that we can take advantage of - ;; subst'd output vars. - (add-auxiliary-definitions! label exp-key))))) - (_ #f)) - (lp (1+ label)))) - (values (compute-dom-edges idoms min-label) - equiv-labels min-label var-substs min-var))) - - (call-with-values (lambda () (compute-label-and-var-ranges fun)) - (lambda (min-label label-count min-var var-count) - (let ((idoms (compute-idoms dfg min-label label-count))) - (call-with-values - (lambda () - (compute-available-expressions dfg min-label label-count idoms)) - (lambda (avail effects) - (compute min-label label-count min-var var-count - idoms avail effects))))))) - -(define (apply-cse fun dfg - doms equiv-labels min-label var-substs min-var boolv) - (define (idx->label idx) (+ idx min-label)) - (define (label->idx label) (- label min-label)) - (define (idx->var idx) (+ idx min-var)) - (define (var->idx var) (- var min-var)) - (define (true-idx idx) (ash idx 1)) - (define (false-idx idx) (1+ (ash idx 1))) - - (define (subst-var var) - ;; It could be that the var is free in this function; if so, - ;; its name will be less than min-var. - (let ((idx (var->idx var))) - (if (<= 0 idx) - (vector-ref var-substs idx) - var))) - - (define (visit-fun-cont cont) - (rewrite-cps-cont cont - (($ $cont label ($ $kfun src meta self tail clause)) - (label ($kfun src meta self ,tail - ,(and clause (visit-fun-cont clause))))) - (($ $cont label ($ $kclause arity ($ $cont kbody body) alternate)) - (label ($kclause ,arity ,(visit-cont kbody body) - ,(and alternate (visit-fun-cont alternate))))))) - - (define (visit-cont label cont) - (rewrite-cps-cont cont - (($ $kargs names vars body) - (label ($kargs names vars ,(visit-term body label)))) - (_ (label ,cont)))) - - (define (visit-term term label) - (define (visit-exp exp) - ;; We shouldn't see $fun here. - (rewrite-cps-exp exp - ((or ($ $const) ($ $prim)) ,exp) - (($ $call proc args) - ($call (subst-var proc) ,(map subst-var args))) - (($ $callk k proc args) - ($callk k (subst-var proc) ,(map subst-var args))) - (($ $primcall name args) - ($primcall name ,(map subst-var args))) - (($ $branch k exp) - ($branch k ,(visit-exp exp))) - (($ $values args) - ($values ,(map subst-var args))) - (($ $prompt escape? tag handler) - ($prompt escape? (subst-var tag) handler)))) - - (define (visit-fun fun) - (rewrite-cps-exp fun - (($ $fun body) - ($fun ,(cse body dfg))))) - - (define (visit-exp* k src exp) - (match exp - (($ $fun) - (build-cps-term - ($continue k src ,(visit-fun exp)))) - (($ $rec names syms funs) - (build-cps-term - ($continue k src ($rec names syms (map visit-fun funs))))) - (_ - (cond - ((vector-ref equiv-labels (label->idx label)) - => (match-lambda - ((equiv . vars) - (let* ((eidx (label->idx equiv))) - (match exp - (($ $branch kt exp) - (let* ((bool (vector-ref boolv (label->idx label))) - (t (intset-ref bool (true-idx eidx))) - (f (intset-ref bool (false-idx eidx)))) - (if (eqv? t f) - (build-cps-term - ($continue k src - ($branch kt ,(visit-exp exp)))) - (build-cps-term - ($continue (if t kt k) src ($values ())))))) - (_ - ;; FIXME: can we always continue with $values? why - ;; or why not? - (rewrite-cps-term (lookup-cont k dfg) - (($ $kargs) - ($continue k src ($values vars))) - (_ - ($continue k src ,(visit-exp exp)))))))))) - (else - (build-cps-term - ($continue k src ,(visit-exp exp)))))))) - - (define (visit-dom-conts label) - (let ((cont (lookup-cont label dfg))) - (match cont - (($ $ktail) '()) - (($ $kargs) (list (visit-cont label cont))) - (else - (cons (visit-cont label cont) - (append-map visit-dom-conts - (vector-ref doms (label->idx label)))))))) - - (rewrite-cps-term term - (($ $letk conts body) - ,(visit-term body label)) - (($ $continue k src exp) - ,(let ((conts (append-map visit-dom-conts - (vector-ref doms (label->idx label))))) - (if (null? conts) - (visit-exp* k src exp) - (build-cps-term - ($letk ,conts ,(visit-exp* k src exp)))))))) - - (visit-fun-cont fun)) - -(define (cse fun dfg) - (call-with-values (lambda () (compute-equivalent-subexpressions fun dfg)) - (lambda (doms equiv-labels min-label var-substs min-var) - (apply-cse fun dfg doms equiv-labels min-label var-substs min-var - (compute-truthy-expressions dfg - min-label (vector-length doms)))))) - -(define (eliminate-common-subexpressions fun) - (call-with-values (lambda () (renumber fun)) - (lambda (fun nlabels nvars) - (cse fun (compute-dfg fun))))) diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm deleted file mode 100644 index 34ffc3a47..000000000 --- a/module/language/cps/dce.scm +++ /dev/null @@ -1,363 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; Various optimizations can inline calls from one continuation to some -;;; other continuation, usually in response to information about the -;;; return arity of the call. That leaves us with dangling -;;; continuations that aren't reachable any more from the procedure -;;; entry. This pass will remove them. -;;; -;;; This pass also kills dead expressions: code that has no side -;;; effects, and whose value is unused. It does so by marking all live -;;; values, and then discarding other values as dead. This happens -;;; recursively through procedures, so it should be possible to elide -;;; dead procedures as well. -;;; -;;; Code: - -(define-module (language cps dce) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (language cps) - #:use-module (language cps dfg) - #:use-module (language cps effects-analysis) - #:use-module (language cps renumber) - #:use-module (language cps types) - #:export (eliminate-dead-code)) - -(define-record-type $fun-data - (make-fun-data min-label effects live-conts defs) - fun-data? - (min-label fun-data-min-label) - (effects fun-data-effects) - (live-conts fun-data-live-conts) - (defs fun-data-defs)) - -(define (compute-defs dfg min-label label-count) - (define (cont-defs k) - (match (lookup-cont k dfg) - (($ $kargs names vars) vars) - (_ #f))) - (define (idx->label idx) (+ idx min-label)) - (let ((defs (make-vector label-count #f))) - (let lp ((n 0)) - (when (< n label-count) - (vector-set! - defs - n - (match (lookup-cont (idx->label n) dfg) - (($ $kargs _ _ body) - (match (find-call body) - (($ $continue k src exp) - (match exp - (($ $branch) #f) - (_ (cont-defs k)))))) - (($ $kreceive arity kargs) - (cont-defs kargs)) - (($ $kclause arity ($ $cont kargs ($ $kargs names syms))) - syms) - (($ $kfun src meta self) (list self)) - (($ $ktail) #f))) - (lp (1+ n)))) - defs)) - -(define (elide-type-checks! fun dfg effects min-label label-count) - (match fun - (($ $cont kfun ($ $kfun src meta min-var)) - (let ((typev (infer-types fun dfg))) - (define (idx->label idx) (+ idx min-label)) - (define (var->idx var) (- var min-var)) - (define (visit-primcall lidx fx name args) - (when (primcall-types-check? typev (idx->label lidx) name args) - (vector-set! effects lidx - (logand fx (lognot &type-check))))) - (let lp ((lidx 0)) - (when (< lidx label-count) - (let ((fx (vector-ref effects lidx))) - (unless (causes-all-effects? fx) - (when (causes-effect? fx &type-check) - (match (lookup-cont (idx->label lidx) dfg) - (($ $kargs _ _ term) - (match (find-call term) - (($ $continue k src ($ $primcall name args)) - (visit-primcall lidx fx name args)) - (($ $continue k src ($ $branch _ ($primcall name args))) - (visit-primcall lidx fx name args)) - (_ #f))) - (_ #f))))) - (lp (1+ lidx)))))))) - -(define (compute-live-code fun) - (let* ((fun-data-table (make-hash-table)) - (dfg (compute-dfg fun #:global? #t)) - (live-vars (make-bitvector (dfg-var-count dfg) #f)) - (changed? #f)) - (define (mark-live! var) - (unless (value-live? var) - (set! changed? #t) - (bitvector-set! live-vars var #t))) - (define (value-live? var) - (bitvector-ref live-vars var)) - (define (ensure-fun-data fun) - (or (hashq-ref fun-data-table fun) - (call-with-values (lambda () - ((make-local-cont-folder label-count max-label) - (lambda (k cont label-count max-label) - (values (1+ label-count) (max k max-label))) - fun 0 -1)) - (lambda (label-count max-label) - (let* ((min-label (- (1+ max-label) label-count)) - (effects (compute-effects dfg min-label label-count)) - (live-conts (make-bitvector label-count #f)) - (defs (compute-defs dfg min-label label-count)) - (fun-data (make-fun-data - min-label effects live-conts defs))) - (elide-type-checks! fun dfg effects min-label label-count) - (hashq-set! fun-data-table fun fun-data) - (set! changed? #t) - fun-data))))) - (define (visit-fun fun) - (match (ensure-fun-data fun) - (($ $fun-data min-label effects live-conts defs) - (define (idx->label idx) (+ idx min-label)) - (define (label->idx label) (- label min-label)) - (define (known-allocation? var dfg) - (match (lookup-predecessors (lookup-def var dfg) dfg) - ((def-exp-k) - (match (lookup-cont def-exp-k dfg) - (($ $kargs _ _ term) - (match (find-call term) - (($ $continue k src ($ $values (var))) - (known-allocation? var dfg)) - (($ $continue k src ($ $primcall)) - (let ((kidx (label->idx def-exp-k))) - (and (>= kidx 0) - (causes-effect? (vector-ref effects kidx) - &allocation)))) - (_ #f))) - (_ #f))) - (_ #f))) - (define (visit-grey-exp n exp) - (let ((defs (vector-ref defs n)) - (fx (vector-ref effects n))) - (or - ;; No defs; perhaps continuation is $ktail. - (not defs) - ;; Do we have a live def? - (or-map value-live? defs) - ;; Does this expression cause all effects? If so, it's - ;; definitely live. - (causes-all-effects? fx) - ;; Does it cause a type check, but we weren't able to - ;; prove that the types check? - (causes-effect? fx &type-check) - ;; We might have a setter. If the object being assigned - ;; to is live or was not created by us, then this - ;; expression is live. Otherwise the value is still dead. - (and (causes-effect? fx &write) - (match exp - (($ $primcall - (or 'vector-set! 'vector-set!/immediate - 'set-car! 'set-cdr! - 'box-set!) - (obj . _)) - (or (value-live? obj) - (not (known-allocation? obj dfg)))) - (_ #t)))))) - (let lp ((n (1- (vector-length effects)))) - (unless (< n 0) - (let ((cont (lookup-cont (idx->label n) dfg))) - (match cont - (($ $kargs _ _ body) - (let lp ((body body)) - (match body - (($ $letk conts body) (lp body)) - (($ $continue k src exp) - (unless (bitvector-ref live-conts n) - (when (visit-grey-exp n exp) - (set! changed? #t) - (bitvector-set! live-conts n #t))) - (when (bitvector-ref live-conts n) - (match exp - ((or ($ $const) ($ $prim)) - #f) - (($ $fun body) - (visit-fun body)) - (($ $rec names syms funs) - (for-each (lambda (sym fun) - (when (value-live? sym) - (match fun - (($ $fun body) - (visit-fun body))))) - syms funs)) - (($ $prompt escape? tag handler) - (mark-live! tag)) - (($ $call proc args) - (mark-live! proc) - (for-each mark-live! args)) - (($ $callk k proc args) - (mark-live! proc) - (for-each mark-live! args)) - (($ $primcall name args) - (for-each mark-live! args)) - (($ $branch k ($ $primcall name args)) - (for-each mark-live! args)) - (($ $branch k ($ $values (arg))) - (mark-live! arg)) - (($ $values args) - (match (vector-ref defs n) - (#f (for-each mark-live! args)) - (defs (for-each (lambda (use def) - (when (value-live? def) - (mark-live! use))) - args defs)))))))))) - (($ $kreceive arity kargs) #f) - (($ $kclause arity ($ $cont kargs ($ $kargs names syms body))) - (for-each mark-live! syms)) - (($ $kfun src meta self) - (mark-live! self)) - (($ $ktail) #f)) - (lp (1- n)))))))) - (unless (= (dfg-var-count dfg) (var-counter)) - (error "internal error" (dfg-var-count dfg) (var-counter))) - (let lp () - (set! changed? #f) - (visit-fun fun) - (when changed? (lp))) - (values fun-data-table live-vars))) - -(define (process-eliminations fun fun-data-table live-vars) - (define (value-live? var) - (bitvector-ref live-vars var)) - (define (make-adaptor name k defs) - (let* ((names (map (lambda (_) 'tmp) defs)) - (syms (map (lambda (_) (fresh-var)) defs)) - (live (filter-map (lambda (def sym) - (and (value-live? def) - sym)) - defs syms))) - (build-cps-cont - (name ($kargs names syms - ($continue k #f ($values live))))))) - (define (visit-fun fun) - (match (hashq-ref fun-data-table fun) - (($ $fun-data min-label effects live-conts defs) - (define (label->idx label) (- label min-label)) - (define (visit-cont cont) - (match (visit-cont* cont) - ((cont) cont))) - (define (visit-cont* cont) - (match cont - (($ $cont label cont) - (match cont - (($ $kargs names syms body) - (match (filter-map (lambda (name sym) - (and (value-live? sym) - (cons name sym))) - names syms) - (((names . syms) ...) - (list - (build-cps-cont - (label ($kargs names syms - ,(visit-term body label)))))))) - (($ $kfun src meta self tail clause) - (list - (build-cps-cont - (label ($kfun src meta self ,tail - ,(and clause (visit-cont clause))))))) - (($ $kclause arity body alternate) - (list - (build-cps-cont - (label ($kclause ,arity - ,(visit-cont body) - ,(and alternate - (visit-cont alternate))))))) - (($ $kreceive ($ $arity req () rest () #f) kargs) - (let ((defs (vector-ref defs (label->idx label)))) - (if (and-map value-live? defs) - (list (build-cps-cont (label ,cont))) - (let-fresh (adapt) () - (list (make-adaptor adapt kargs defs) - (build-cps-cont - (label ($kreceive req rest adapt)))))))) - (_ (list (build-cps-cont (label ,cont)))))))) - (define (visit-conts conts) - (append-map visit-cont* conts)) - (define (visit-term term term-k) - (match term - (($ $letk conts body) - (let ((body (visit-term body term-k))) - (match (visit-conts conts) - (() body) - (conts (build-cps-term ($letk ,conts ,body)))))) - (($ $continue k src ($ $values args)) - (match (vector-ref defs (label->idx term-k)) - (#f term) - (defs - (let ((args (filter-map (lambda (use def) - (and (value-live? def) use)) - args defs))) - (build-cps-term - ($continue k src ($values args))))))) - (($ $continue k src exp) - (if (bitvector-ref live-conts (label->idx term-k)) - (match exp - (($ $fun body) - (build-cps-term - ($continue k src ($fun ,(visit-fun body))))) - (($ $rec names syms funs) - (rewrite-cps-term - (filter-map - (lambda (name sym fun) - (and (value-live? sym) - (match fun - (($ $fun body) - (list name - sym - (build-cps-exp - ($fun ,(visit-fun body)))))))) - names syms funs) - (() - ($continue k src ($values ()))) - (((names syms funs) ...) - ($continue k src ($rec names syms funs))))) - (_ - (match (vector-ref defs (label->idx term-k)) - ((or #f ((? value-live?) ...)) - (build-cps-term - ($continue k src ,exp))) - (syms - (let-fresh (adapt) () - (build-cps-term - ($letk (,(make-adaptor adapt k syms)) - ($continue adapt src ,exp)))))))) - (build-cps-term ($continue k src ($values ()))))))) - (visit-cont fun)))) - (visit-fun fun)) - -(define (eliminate-dead-code fun) - (call-with-values (lambda () (renumber fun)) - (lambda (fun nlabels nvars) - (parameterize ((label-counter nlabels) - (var-counter nvars)) - (call-with-values (lambda () (compute-live-code fun)) - (lambda (fun-data-table live-vars) - (process-eliminations fun fun-data-table live-vars))))))) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm deleted file mode 100644 index 7a49f869f..000000000 --- a/module/language/cps/effects-analysis.scm +++ /dev/null @@ -1,499 +0,0 @@ -;;; Effects analysis on CPS - -;; Copyright (C) 2011, 2012, 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; A helper module to compute the set of effects caused by an -;;; expression. This information is useful when writing algorithms that -;;; move code around, while preserving the semantics of an input -;;; program. -;;; -;;; The effects set is represented as an integer with three parts. The -;;; low 4 bits indicate effects caused by an expression, as a bitfield. -;;; The next 4 bits indicate the kind of memory accessed by the -;;; expression, if it accesses mutable memory. Finally the rest of the -;;; bits indicate the field in the object being accessed, if known, or -;;; -1 for unknown. -;;; -;;; In this way we embed a coarse type-based alias analysis in the -;;; effects analysis. For example, a "car" call is modelled as causing -;;; a read to field 0 on a &pair, and causing a &type-check effect. If -;;; any intervening code sets the car of any pair, that will block -;;; motion of the "car" call, because any write to field 0 of a pair is -;;; seen by effects analysis as being a write to field 0 of all pairs. -;;; -;;; Code: - -(define-module (language cps effects-analysis) - #:use-module (language cps) - #:use-module (language cps dfg) - #:use-module (ice-9 match) - #:export (expression-effects - compute-effects - synthesize-definition-effects! - - &allocation - &type-check - &read - &write - - &fluid - &prompt - &car - &cdr - &vector - &box - &module - &struct - &string - &bytevector - - &object - &field - - &allocate - &read-object - &read-field - &write-object - &write-field - - &no-effects - &all-effects - - exclude-effects - effect-free? - constant? - causes-effect? - causes-all-effects? - effect-clobbers?)) - -(define-syntax define-flags - (lambda (x) - (syntax-case x () - ((_ all shift name ...) - (let ((count (length #'(name ...)))) - (with-syntax (((n ...) (iota count)) - (count count)) - #'(begin - (define-syntax name (identifier-syntax (ash 1 n))) - ... - (define-syntax all (identifier-syntax (1- (ash 1 count)))) - (define-syntax shift (identifier-syntax count))))))))) - -(define-syntax define-enumeration - (lambda (x) - (define (count-bits n) - (let lp ((out 1)) - (if (< n (ash 1 (1- out))) - out - (lp (1+ out))))) - (syntax-case x () - ((_ mask shift name ...) - (let* ((len (length #'(name ...))) - (bits (count-bits len))) - (with-syntax (((n ...) (iota len)) - (bits bits)) - #'(begin - (define-syntax name (identifier-syntax n)) - ... - (define-syntax mask (identifier-syntax (1- (ash 1 bits)))) - (define-syntax shift (identifier-syntax bits))))))))) - -(define-flags &all-effect-kinds &effect-kind-bits - ;; Indicates that an expression may cause a type check. A type check, - ;; for the purposes of this analysis, is the possibility of throwing - ;; an exception the first time an expression is evaluated. If the - ;; expression did not cause an exception to be thrown, users can - ;; assume that evaluating the expression again will not cause an - ;; exception to be thrown. - ;; - ;; For example, (+ x y) might throw if X or Y are not numbers. But if - ;; it doesn't throw, it should be safe to elide a dominated, common - ;; subexpression (+ x y). - &type-check - - ;; Indicates that an expression may return a fresh object. The kind - ;; of object is indicated in the object kind field. - &allocation - - ;; Indicates that an expression may cause a read from memory. The - ;; kind of memory is given in the object kind field. Some object - ;; kinds have finer-grained fields; those are expressed in the "field" - ;; part of the effects value. -1 indicates "the whole object". - &read - - ;; Indicates that an expression may cause a write to memory. - &write) - -(define-enumeration &memory-kind-mask &memory-kind-bits - ;; Indicates than an expression may access unknown kinds of memory. - &unknown-memory-kinds - - ;; Indicates that an expression depends on the value of a fluid - ;; variable, or on the current fluid environment. - &fluid - - ;; Indicates that an expression depends on the current prompt - ;; stack. - &prompt - - ;; Indicates that an expression depends on the value of the car or cdr - ;; of a pair. - &pair - - ;; Indicates that an expression depends on the value of a vector - ;; field. The effect field indicates the specific field, or zero for - ;; an unknown field. - &vector - - ;; Indicates that an expression depends on the value of a variable - ;; cell. - &box - - ;; Indicates that an expression depends on the current module. - &module - - ;; Indicates that an expression depends on the value of a struct - ;; field. The effect field indicates the specific field, or zero for - ;; an unknown field. - &struct - - ;; Indicates that an expression depends on the contents of a string. - &string - - ;; Indicates that an expression depends on the contents of a - ;; bytevector. We cannot be more precise, as bytevectors may alias - ;; other bytevectors. - &bytevector) - -(define-inlinable (&field kind field) - (ash (logior (ash field &memory-kind-bits) kind) &effect-kind-bits)) -(define-inlinable (&object kind) - (&field kind -1)) - -(define-inlinable (&allocate kind) - (logior &allocation (&object kind))) -(define-inlinable (&read-field kind field) - (logior &read (&field kind field))) -(define-inlinable (&read-object kind) - (logior &read (&object kind))) -(define-inlinable (&write-field kind field) - (logior &write (&field kind field))) -(define-inlinable (&write-object kind) - (logior &write (&object kind))) - -(define-syntax &no-effects (identifier-syntax 0)) -(define-syntax &all-effects - (identifier-syntax - (logior &all-effect-kinds (&object &unknown-memory-kinds)))) - -(define-inlinable (constant? effects) - (zero? effects)) - -(define-inlinable (causes-effect? x effects) - (not (zero? (logand x effects)))) - -(define-inlinable (causes-all-effects? x) - (eqv? x &all-effects)) - -(define (effect-clobbers? a b) - "Return true if A clobbers B. This is the case if A is a write, and B -is or might be a read or a write to the same location as A." - (define (locations-same?) - (let ((a (ash a (- &effect-kind-bits))) - (b (ash b (- &effect-kind-bits)))) - (or (eqv? &unknown-memory-kinds (logand a &memory-kind-mask)) - (eqv? &unknown-memory-kinds (logand b &memory-kind-mask)) - (and (eqv? (logand a &memory-kind-mask) (logand b &memory-kind-mask)) - ;; A negative field indicates "the whole object". - ;; Non-negative fields indicate only part of the object. - (or (< a 0) (< b 0) (= a b)))))) - (and (not (zero? (logand a &write))) - (not (zero? (logand b (logior &read &write)))) - (locations-same?))) - -(define (lookup-constant-index sym dfg) - (call-with-values (lambda () (find-constant-value sym dfg)) - (lambda (has-const? val) - (and has-const? (integer? val) (exact? val) (<= 0 val) val)))) - -(define-inlinable (indexed-field kind n dfg) - (cond - ((lookup-constant-index n dfg) - => (lambda (idx) - (&field kind idx))) - (else (&object kind)))) - -(define *primitive-effects* (make-hash-table)) - -(define-syntax-rule (define-primitive-effects* dfg - ((name . args) effects ...) - ...) - (begin - (hashq-set! *primitive-effects* 'name - (case-lambda* - ((dfg . args) (logior effects ...)) - (_ &all-effects))) - ...)) - -(define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...) - (define-primitive-effects* dfg ((name . args) effects ...) ...)) - -;; Miscellaneous. -(define-primitive-effects - ((values . _))) - -;; Generic effect-free predicates. -(define-primitive-effects - ((eq? . _)) - ((eqv? . _)) - ((equal? . _)) - ((pair? arg)) - ((null? arg)) - ((nil? arg )) - ((symbol? arg)) - ((variable? arg)) - ((vector? arg)) - ((struct? arg)) - ((string? arg)) - ((number? arg)) - ((char? arg)) - ((bytevector? arg)) - ((keyword? arg)) - ((bitvector? arg)) - ((procedure? arg)) - ((thunk? arg))) - -;; Fluids. -(define-primitive-effects - ((fluid-ref f) (&read-object &fluid) &type-check) - ((fluid-set! f v) (&write-object &fluid) &type-check) - ((push-fluid f v) (&write-object &fluid) &type-check) - ((pop-fluid) (&write-object &fluid) &type-check)) - -;; Prompts. -(define-primitive-effects - ((make-prompt-tag #:optional arg) (&allocate &unknown-memory-kinds))) - -;; Pairs. -(define-primitive-effects - ((cons a b) (&allocate &pair)) - ((list . _) (&allocate &pair)) - ((car x) (&read-field &pair 0) &type-check) - ((set-car! x y) (&write-field &pair 0) &type-check) - ((cdr x) (&read-field &pair 1) &type-check) - ((set-cdr! x y) (&write-field &pair 1) &type-check) - ((memq x y) (&read-object &pair) &type-check) - ((memv x y) (&read-object &pair) &type-check) - ((list? arg) (&read-field &pair 1)) - ((length l) (&read-field &pair 1) &type-check)) - -;; Variables. -(define-primitive-effects - ((box v) (&allocate &box)) - ((box-ref v) (&read-object &box) &type-check) - ((box-set! v x) (&write-object &box) &type-check)) - -;; Vectors. -(define (vector-field n dfg) - (indexed-field &vector n dfg)) -(define (read-vector-field n dfg) - (logior &read (vector-field n dfg))) -(define (write-vector-field n dfg) - (logior &write (vector-field n dfg))) -(define-primitive-effects* dfg - ((vector . _) (&allocate &vector)) - ((make-vector n init) (&allocate &vector) &type-check) - ((make-vector/immediate n init) (&allocate &vector)) - ((vector-ref v n) (read-vector-field n dfg) &type-check) - ((vector-ref/immediate v n) (read-vector-field n dfg) &type-check) - ((vector-set! v n x) (write-vector-field n dfg) &type-check) - ((vector-set!/immediate v n x) (write-vector-field n dfg) &type-check) - ((vector-length v) &type-check)) - -;; Structs. -(define (struct-field n dfg) - (indexed-field &struct n dfg)) -(define (read-struct-field n dfg) - (logior &read (struct-field n dfg))) -(define (write-struct-field n dfg) - (logior &write (struct-field n dfg))) -(define-primitive-effects* dfg - ((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 dfg) &type-check) - ((struct-ref/immediate s n) (read-struct-field n dfg) &type-check) - ((struct-set! s n x) (write-struct-field n dfg) &type-check) - ((struct-set!/immediate s n x) (write-struct-field n dfg) &type-check) - ((struct-vtable s) &type-check)) - -;; Strings. -(define-primitive-effects - ((string-ref s n) (&read-object &string) &type-check) - ((string-set! s n c) (&write-object &string) &type-check) - ((number->string _) (&allocate &string) &type-check) - ((string->number _) (&read-object &string) &type-check) - ((string-length s) &type-check)) - -;; Bytevectors. -(define-primitive-effects - ((bytevector-length _) &type-check) - - ((bv-u8-ref bv n) (&read-object &bytevector) &type-check) - ((bv-s8-ref bv n) (&read-object &bytevector) &type-check) - ((bv-u16-ref bv n) (&read-object &bytevector) &type-check) - ((bv-s16-ref bv n) (&read-object &bytevector) &type-check) - ((bv-u32-ref bv n) (&read-object &bytevector) &type-check) - ((bv-s32-ref bv n) (&read-object &bytevector) &type-check) - ((bv-u64-ref bv n) (&read-object &bytevector) &type-check) - ((bv-s64-ref bv n) (&read-object &bytevector) &type-check) - ((bv-f32-ref bv n) (&read-object &bytevector) &type-check) - ((bv-f64-ref bv n) (&read-object &bytevector) &type-check) - - ((bv-u8-set! bv n x) (&write-object &bytevector) &type-check) - ((bv-s8-set! bv n x) (&write-object &bytevector) &type-check) - ((bv-u16-set! bv n x) (&write-object &bytevector) &type-check) - ((bv-s16-set! bv n x) (&write-object &bytevector) &type-check) - ((bv-u32-set! bv n x) (&write-object &bytevector) &type-check) - ((bv-s32-set! bv n x) (&write-object &bytevector) &type-check) - ((bv-u64-set! bv n x) (&write-object &bytevector) &type-check) - ((bv-s64-set! bv n x) (&write-object &bytevector) &type-check) - ((bv-f32-set! bv n x) (&write-object &bytevector) &type-check) - ((bv-f64-set! bv n x) (&write-object &bytevector) &type-check)) - -;; Modules. -(define-primitive-effects - ((current-module) (&read-object &module)) - ((cache-current-module! m scope) (&write-object &box)) - ((resolve name bound?) (&read-object &module) &type-check) - ((cached-toplevel-box scope name bound?) &type-check) - ((cached-module-box mod name public? bound?) &type-check) - ((define! name val) (&read-object &module) (&write-object &box))) - -;; Numbers. -(define-primitive-effects - ((= . _) &type-check) - ((< . _) &type-check) - ((> . _) &type-check) - ((<= . _) &type-check) - ((>= . _) &type-check) - ((zero? . _) &type-check) - ((add . _) &type-check) - ((mul . _) &type-check) - ((sub . _) &type-check) - ((div . _) &type-check) - ((sub1 . _) &type-check) - ((add1 . _) &type-check) - ((quo . _) &type-check) - ((rem . _) &type-check) - ((mod . _) &type-check) - ((complex? _) &type-check) - ((real? _) &type-check) - ((rational? _) &type-check) - ((inf? _) &type-check) - ((nan? _) &type-check) - ((integer? _) &type-check) - ((exact? _) &type-check) - ((inexact? _) &type-check) - ((even? _) &type-check) - ((odd? _) &type-check) - ((ash n m) &type-check) - ((logand . _) &type-check) - ((logior . _) &type-check) - ((logxor . _) &type-check) - ((lognot . _) &type-check) - ((logtest a b) &type-check) - ((logbit? a b) &type-check) - ((sqrt _) &type-check) - ((abs _) &type-check)) - -;; Characters. -(define-primitive-effects - ((char=? . _) &type-check) - ((char>? . _) &type-check) - ((integer->char _) &type-check) - ((char->integer _) &type-check)) - -(define (primitive-effects dfg name args) - (let ((proc (hashq-ref *primitive-effects* name))) - (if proc - (apply proc dfg args) - &all-effects))) - -(define (expression-effects exp dfg) - (match exp - ((or ($ $const) ($ $prim) ($ $values)) - &no-effects) - ((or ($ $fun) ($ $rec)) - (&allocate &unknown-memory-kinds)) - (($ $prompt) - (&write-object &prompt)) - ((or ($ $call) ($ $callk)) - &all-effects) - (($ $branch k exp) - (expression-effects exp dfg)) - (($ $primcall name args) - (primitive-effects dfg name args)))) - -(define* (compute-effects dfg #:optional (min-label (dfg-min-label dfg)) - (label-count (dfg-label-count dfg))) - (let ((effects (make-vector label-count &no-effects))) - (define (idx->label idx) (+ idx min-label)) - (let lp ((n 0)) - (when (< n label-count) - (vector-set! - effects - n - (match (lookup-cont (idx->label n) dfg) - (($ $kargs names syms body) - (expression-effects (find-expression body) dfg)) - (($ $kreceive arity kargs) - (match arity - (($ $arity _ () #f () #f) &type-check) - (($ $arity () () _ () #f) (&allocate &pair)) - (($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check)))) - (($ $kfun) &type-check) - (($ $kclause) &type-check) - (($ $ktail) &no-effects))) - (lp (1+ n)))) - effects)) - -;; There is a way to abuse effects analysis in CSE to also do scalar -;; replacement, effectively adding `car' and `cdr' expressions to `cons' -;; expressions, and likewise with other constructors and setters. This -;; routine adds appropriate effects to `cons' and `set-car!' and the -;; like. -;; -;; This doesn't affect CSE's ability to eliminate expressions, given -;; that allocations aren't eliminated anyway, and the new effects will -;; just cause the allocations not to commute with e.g. set-car! which -;; is what we want anyway. -(define* (synthesize-definition-effects! effects dfg min-label #:optional - (label-count (vector-length effects))) - (define (label->idx label) (- label min-label)) - (let lp ((label min-label)) - (when (< label (+ min-label label-count)) - (let* ((lidx (label->idx label)) - (fx (vector-ref effects lidx))) - (unless (zero? (logand (logior &write &allocation) fx)) - (vector-set! effects lidx (logior (vector-ref effects lidx) &read))) - (lp (1+ label)))))) diff --git a/module/language/cps/elide-values.scm b/module/language/cps/elide-values.scm deleted file mode 100644 index dadbd403a..000000000 --- a/module/language/cps/elide-values.scm +++ /dev/null @@ -1,109 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; Primcalls that don't correspond to VM instructions are treated as if -;;; they are calls, and indeed the later reify-primitives pass turns -;;; them into calls. Because no return arity checking is done for these -;;; primitives, if a later optimization pass simplifies the primcall to -;;; a VM operation, the tail of the simplification has to be a -;;; primcall to 'values. Most of these primcalls can be elided, and -;;; that is the job of this pass. -;;; -;;; Code: - -(define-module (language cps elide-values) - #:use-module (ice-9 match) - #:use-module (srfi srfi-26) - #:use-module (language cps) - #:use-module (language cps dfg) - #:export (elide-values)) - -(define (elide-values* fun conts) - (define (visit-cont cont) - (rewrite-cps-cont cont - (($ $cont sym ($ $kargs names syms body)) - (sym ($kargs names syms ,(visit-term body)))) - (($ $cont sym ($ $kfun src meta self tail clause)) - (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause))))) - (($ $cont sym ($ $kclause arity body alternate)) - (sym ($kclause ,arity ,(visit-cont body) - ,(and alternate (visit-cont alternate))))) - (($ $cont) - ,cont))) - (define (visit-term term) - (rewrite-cps-term term - (($ $letk conts body) - ($letk ,(map visit-cont conts) - ,(visit-term body))) - (($ $continue k src ($ $primcall 'values vals)) - ,(rewrite-cps-term (vector-ref conts k) - (($ $ktail) - ($continue k src ($values vals))) - (($ $kreceive ($ $arity req () rest () #f) kargs) - ,(cond - ((and (not rest) (= (length vals) (length req))) - (build-cps-term - ($continue kargs src ($values vals)))) - ((and rest (>= (length vals) (length req))) - (let-fresh (krest) (rest) - (let ((vals* (append (list-head vals (length req)) - (list rest)))) - (build-cps-term - ($letk ((krest ($kargs ('rest) (rest) - ($continue kargs src - ($values vals*))))) - ,(let lp ((tail (list-tail vals (length req))) - (k krest)) - (match tail - (() - (build-cps-term ($continue k src - ($const '())))) - ((v . tail) - (let-fresh (krest) (rest) - (build-cps-term - ($letk ((krest ($kargs ('rest) (rest) - ($continue k src - ($primcall 'cons - (v rest)))))) - ,(lp tail krest)))))))))))) - (else term))) - (($ $kargs args) - ,(if (< (length vals) (length args)) - term - (let ((vals (list-head vals (length args)))) - (build-cps-term - ($continue k src ($values vals)))))))) - (($ $continue k src (and fun ($ $fun))) - ($continue k src ,(visit-fun fun))) - (($ $continue k src ($ $rec names syms funs)) - ($continue k src ($rec names syms (map visit-fun funs)))) - (($ $continue) - ,term))) - (define (visit-fun fun) - (rewrite-cps-exp fun - (($ $fun cont) - ($fun ,(visit-cont cont))))) - - (visit-cont fun)) - -(define (elide-values fun) - (with-fresh-name-state fun - (let ((conts (build-cont-table fun))) - (elide-values* fun conts)))) diff --git a/module/language/cps/prune-bailouts.scm b/module/language/cps/prune-bailouts.scm deleted file mode 100644 index c224f4531..000000000 --- a/module/language/cps/prune-bailouts.scm +++ /dev/null @@ -1,101 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; A pass that prunes successors of expressions that bail out. -;;; -;;; Code: - -(define-module (language cps prune-bailouts) - #:use-module (ice-9 match) - #:use-module (language cps) - #:export (prune-bailouts)) - -(define (module-box src module name public? bound? val-proc) - (let-fresh (kbox) (module-sym name-sym public?-sym bound?-sym box) - (build-cps-term - ($letconst (('module module-sym module) - ('name name-sym name) - ('public? public?-sym public?) - ('bound? bound?-sym bound?)) - ($letk ((kbox ($kargs ('box) (box) ,(val-proc box)))) - ($continue kbox src - ($primcall 'cached-module-box - (module-sym name-sym public?-sym bound?-sym)))))))) - -(define (primitive-ref name k src) - (module-box #f '(guile) name #f #t - (lambda (box) - (build-cps-term - ($continue k src ($primcall 'box-ref (box))))))) - -(define (prune-bailouts* fun) - (define (visit-cont cont ktail) - (rewrite-cps-cont cont - (($ $cont label ($ $kargs names vars body)) - (label ($kargs names vars ,(visit-term body ktail)))) - (($ $cont label ($ $kfun src meta self tail clause)) - (label ($kfun src meta self ,tail - ,(and clause (visit-cont clause ktail))))) - (($ $cont label ($ $kclause arity body alternate)) - (label ($kclause ,arity ,(visit-cont body ktail) - ,(and alternate (visit-cont alternate ktail))))) - (_ ,cont))) - - (define (visit-term term ktail) - (rewrite-cps-term term - (($ $letk conts body) - ($letk ,(map (lambda (cont) (visit-cont cont ktail)) conts) - ,(visit-term body ktail))) - (($ $continue k src exp) - ,(visit-exp k src exp ktail)))) - - (define (visit-exp k src exp ktail) - (rewrite-cps-term exp - (($ $fun) ($continue k src ,(visit-fun exp))) - (($ $rec names vars funs) - ($continue k src ($rec names vars (map visit-fun funs)))) - (($ $primcall (and name (or 'error 'scm-error 'throw)) args) - ,(if (eq? k ktail) - (build-cps-term ($continue k src ,exp)) - (let-fresh (kprim kresult kreceive) (prim rest) - (build-cps-term - ($letk ((kresult ($kargs ('rest) (rest) - ($continue ktail src ($values ())))) - (kreceive ($kreceive '() 'rest kresult)) - (kprim ($kargs ('prim) (prim) - ($continue kreceive src - ($call prim args))))) - ,(primitive-ref name kprim src)))))) - (_ ($continue k src ,exp)))) - - (define (visit-fun fun) - (rewrite-cps-exp fun - (($ $fun body) - ($fun ,(prune-bailouts* body))))) - - (rewrite-cps-cont fun - (($ $cont kfun - ($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause)) - (kfun ($kfun src meta self (ktail ($ktail)) - ,(and clause (visit-cont clause ktail))))))) - -(define (prune-bailouts fun) - (with-fresh-name-state fun - (prune-bailouts* fun))) diff --git a/module/language/cps/prune-top-level-scopes.scm b/module/language/cps/prune-top-level-scopes.scm deleted file mode 100644 index 4839b71f7..000000000 --- a/module/language/cps/prune-top-level-scopes.scm +++ /dev/null @@ -1,114 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; A simple pass to prune unneeded top-level scopes. -;;; -;;; Code: - -(define-module (language cps prune-top-level-scopes) - #:use-module (ice-9 match) - #:use-module (language cps) - #:export (prune-top-level-scopes)) - -(define (compute-referenced-scopes fun) - (let ((scope-name->used? (make-hash-table)) - (scope-var->used? (make-hash-table)) - (k->scope-var (make-hash-table))) - ;; Visit uses before defs. That way we know when visiting defs - ;; whether the scope is used or not. - (define (visit-cont cont) - (match cont - (($ $cont k ($ $kargs (name) (var) body)) - (visit-term body) - (when (hashq-get-handle scope-var->used? var) - (hashq-set! k->scope-var k var))) - (($ $cont k ($ $kargs names syms body)) - (visit-term body)) - (($ $cont k ($ $kfun src meta self tail clause)) - (when clause (visit-cont clause))) - (($ $cont k ($ $kclause arity body alternate)) - (visit-cont body) - (when alternate (visit-cont alternate))) - (($ $cont k ($ $kreceive)) - #t))) - (define (visit-term term) - (match term - (($ $letk conts body) - (for-each visit-cont conts) - (visit-term body)) - (($ $continue k src exp) - (match exp - (($ $fun) (visit-fun exp)) - (($ $rec names syms funs) - (for-each visit-fun funs)) - (($ $primcall 'cached-toplevel-box (scope name bound?)) - (hashq-set! scope-var->used? scope #t)) - (($ $primcall 'cache-current-module! (module scope)) - (hashq-set! scope-var->used? scope #f)) - (($ $const val) - ;; If there is an entry in the table for "k", it means "val" - ;; is a scope symbol, bound for use by cached-toplevel-box - ;; or cache-current-module!, or possibly both (though this - ;; is not currently the case). - (and=> (hashq-ref k->scope-var k) - (lambda (scope-var) - (when (hashq-ref scope-var->used? scope-var) - ;; We have a use via cached-toplevel-box. Mark - ;; this scope as used. - (hashq-set! scope-name->used? val #t)) - (when (and (hashq-ref scope-name->used? val) - (not (hashq-ref scope-var->used? scope-var))) - ;; There is a use, and this sym is used by - ;; cache-current-module!. - (hashq-set! scope-var->used? scope-var #t))))) - (_ #t))))) - (define (visit-fun fun) - (match fun - (($ $fun body) - (visit-cont body)))) - - (visit-cont fun) - scope-var->used?)) - -(define (prune-top-level-scopes fun) - (let ((scope-var->used? (compute-referenced-scopes fun))) - (define (visit-cont cont) - (rewrite-cps-cont cont - (($ $cont sym ($ $kargs names syms body)) - (sym ($kargs names syms ,(visit-term body)))) - (($ $cont sym ($ $kfun src meta self tail clause)) - (sym ($kfun src meta self ,tail ,(and clause (visit-cont clause))))) - (($ $cont sym ($ $kclause arity body alternate)) - (sym ($kclause ,arity ,(visit-cont body) - ,(and alternate (visit-cont alternate))))) - (($ $cont sym ($ $kreceive)) - ,cont))) - (define (visit-term term) - (rewrite-cps-term term - (($ $letk conts body) - ($letk ,(map visit-cont conts) ,(visit-term body))) - (($ $continue k src - (and ($ $primcall 'cache-current-module! (module scope)) - (? (lambda _ - (not (hashq-ref scope-var->used? scope)))))) - ($continue k src ($primcall 'values ()))) - (($ $continue) - ,term))) - (visit-cont fun))) diff --git a/module/language/cps/self-references.scm b/module/language/cps/self-references.scm deleted file mode 100644 index 45e2389ff..000000000 --- a/module/language/cps/self-references.scm +++ /dev/null @@ -1,79 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; A pass that prunes successors of expressions that bail out. -;;; -;;; Code: - -(define-module (language cps self-references) - #:use-module (ice-9 match) - #:use-module (language cps) - #:export (resolve-self-references)) - -(define* (resolve-self-references fun #:optional (env '())) - (define (subst var) - (or (assq-ref env var) var)) - - (define (visit-cont cont) - (rewrite-cps-cont cont - (($ $cont label ($ $kargs names vars body)) - (label ($kargs names vars ,(visit-term body)))) - (($ $cont label ($ $kfun src meta self tail clause)) - (label ($kfun src meta self ,tail - ,(and clause (visit-cont clause))))) - (($ $cont label ($ $kclause arity body alternate)) - (label ($kclause ,arity ,(visit-cont body) - ,(and alternate (visit-cont alternate))))) - (_ ,cont))) - - (define (visit-term term) - (rewrite-cps-term term - (($ $letk conts body) - ($letk ,(map visit-cont conts) - ,(visit-term body))) - (($ $continue k src exp) - ($continue k src ,(visit-exp exp))))) - - (define (visit-exp exp) - (rewrite-cps-exp exp - ((or ($ $const) ($ $prim)) ,exp) - (($ $fun body) - ($fun ,(resolve-self-references body env))) - (($ $rec names vars funs) - ($rec names vars (map visit-recursive-fun funs vars))) - (($ $call proc args) - ($call (subst proc) ,(map subst args))) - (($ $callk k proc args) - ($callk k (subst proc) ,(map subst args))) - (($ $primcall name args) - ($primcall name ,(map subst args))) - (($ $branch k exp) - ($branch k ,(visit-exp exp))) - (($ $values args) - ($values ,(map subst args))) - (($ $prompt escape? tag handler) - ($prompt escape? (subst tag) handler)))) - - (define (visit-recursive-fun fun var) - (rewrite-cps-exp fun - (($ $fun (and cont ($ $cont _ ($ $kfun src meta self)))) - ($fun ,(resolve-self-references cont (acons var self env)))))) - - (visit-cont fun)) diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm deleted file mode 100644 index 10e9d0aa2..000000000 --- a/module/language/cps/simplify.scm +++ /dev/null @@ -1,328 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; The fundamental lambda calculus reductions, like beta and eta -;;; reduction and so on. Pretty lame currently. -;;; -;;; Code: - -(define-module (language cps simplify) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) - #:use-module (language cps) - #:use-module (language cps dfg) - #:use-module (language cps renumber) - #:export (simplify)) - -(define (compute-eta-reductions fun) - (let ((table (make-hash-table))) - (define (visit-cont cont) - (match cont - (($ $cont sym ($ $kargs names syms body)) - (visit-term body sym syms)) - (($ $cont sym ($ $kfun src meta self tail clause)) - (when clause (visit-cont clause))) - (($ $cont sym ($ $kclause arity body alternate)) - (visit-cont body) - (when alternate (visit-cont alternate))) - (($ $cont sym _) #f))) - (define (visit-term term term-k term-args) - (match term - (($ $letk conts body) - (for-each visit-cont conts) - (visit-term body term-k term-args)) - (($ $continue k src ($ $values args)) - (when (and (equal? term-args args) (not (eq? k term-k))) - (hashq-set! table term-k k))) - (($ $continue k src (and fun ($ $fun))) - (visit-fun fun)) - (($ $continue k src ($ $rec names syms funs)) - (for-each visit-fun funs)) - (($ $continue k src _) - #f))) - (define (visit-fun fun) - (match fun - (($ $fun body) - (visit-cont body)))) - (visit-cont fun) - table)) - -(define (eta-reduce fun) - (let ((table (compute-eta-reductions fun)) - (dfg (compute-dfg fun))) - (define (reduce* k scope values?) - (match (hashq-ref table k) - (#f k) - (k* - (if (and (continuation-bound-in? k* scope dfg) - (or values? - (match (lookup-cont k* dfg) - (($ $kargs) #t) - (_ #f)))) - (reduce* k* scope values?) - k)))) - (define (reduce k scope) - (reduce* k scope #f)) - (define (reduce-values k scope) - (reduce* k scope #t)) - (define (reduce-const k src scope const) - (let lp ((k k) (seen '()) (const const)) - (match (lookup-cont k dfg) - (($ $kargs (_) (arg) term) - (match (find-call term) - (($ $continue k* src* ($ $values (arg*))) - (and (eqv? arg arg*) - (not (memq k* seen)) - (lp k* (cons k seen) const))) - (($ $continue k* src* ($ $primcall 'not (arg*))) - (and (eqv? arg arg*) - (not (memq k* seen)) - (lp k* (cons k seen) (not const)))) - (($ $continue k* src* ($ $branch kt ($ $values (arg*)))) - (and (eqv? arg arg*) - (let ((k* (if const kt k*))) - (and (continuation-bound-in? k* scope dfg) - (build-cps-term - ($continue k* src ($values ()))))))) - (_ - (and (continuation-bound-in? k scope dfg) - (build-cps-term - ($continue k src ($const const))))))) - (_ #f)))) - (define (visit-cont cont scope) - (rewrite-cps-cont cont - (($ $cont sym ($ $kargs names syms body)) - (sym ($kargs names syms ,(visit-term body sym)))) - (($ $cont sym ($ $kfun src meta self tail clause)) - (sym ($kfun src meta self ,tail - ,(and clause (visit-cont clause sym))))) - (($ $cont sym ($ $kclause arity body alternate)) - (sym ($kclause ,arity ,(visit-cont body sym) - ,(and alternate (visit-cont alternate sym))))) - (($ $cont sym ($ $kreceive ($ $arity req () rest () #f) kargs)) - (sym ($kreceive req rest (reduce kargs scope)))))) - (define (visit-term term scope) - (rewrite-cps-term term - (($ $letk conts body) - ($letk ,(map (cut visit-cont <> scope) conts) - ,(visit-term body scope))) - (($ $continue k src ($ $values args)) - ($continue (reduce-values k scope) src ($values args))) - (($ $continue k src (and fun ($ $fun))) - ($continue (reduce k scope) src ,(visit-fun fun))) - (($ $continue k src ($ $rec names syms funs)) - ($continue k src ($rec names syms (map visit-fun funs)))) - (($ $continue k src ($ $const const)) - ,(let ((k (reduce k scope))) - (or (reduce-const k src scope const) - (build-cps-term ($continue k src ($const const)))))) - (($ $continue k src exp) - ($continue (reduce k scope) src ,exp)))) - (define (visit-fun fun) - (rewrite-cps-exp fun - (($ $fun body) - ($fun ,(visit-cont body #f))))) - (visit-cont fun #f))) - -(define (compute-beta-reductions fun) - ;; A continuation's body can be inlined in place of a $values - ;; expression if the continuation is a $kargs. It should only be - ;; inlined if it is used only once, and not recursively. - (let ((var-table (make-hash-table)) - (k-table (make-hash-table)) - (dfg (compute-dfg fun))) - (define (visit-cont cont) - (match cont - (($ $cont sym ($ $kargs names syms body)) - (visit-term body)) - (($ $cont sym ($ $kfun src meta self tail clause)) - (when clause (visit-cont clause))) - (($ $cont sym ($ $kclause arity body alternate)) - (visit-cont body) - (when alternate (visit-cont alternate))) - (($ $cont sym (or ($ $ktail) ($ $kreceive))) - #f))) - (define (visit-term term) - (match term - (($ $letk conts body) - (for-each visit-cont conts) - (visit-term body)) - (($ $continue k src ($ $values args)) - (match (lookup-cont k dfg) - (($ $kargs names syms body) - (match (lookup-predecessors k dfg) - ((_) - ;; There is only one use, and it is this use. We assume - ;; it's not recursive, as there would to be some other - ;; use for control flow to reach this loop. Store the k - ;; -> body mapping in the table. Also store the - ;; substitutions for the variables bound by the inlined - ;; continuation. - (for-each (cut hashq-set! var-table <> <>) syms args) - (hashq-set! k-table k body)) - (_ #f))) - (_ #f))) - (($ $continue k src (and fun ($ $fun))) - (visit-fun fun)) - (($ $continue k src ($ $rec names syms funs)) - (for-each visit-fun funs)) - (($ $continue k src _) - #f))) - (define (visit-fun fun) - (match fun - (($ $fun body) - (visit-cont body)))) - (visit-cont fun) - (values var-table k-table))) - -(define (beta-reduce fun) - (let-values (((var-table k-table) (compute-beta-reductions fun))) - (define (subst var) - (cond ((hashq-ref var-table var) => subst) - (else var))) - (define (must-visit-cont cont) - (or (visit-cont cont) - (error "continuation must not be inlined" cont))) - (define (visit-cont cont) - (match cont - (($ $cont sym cont) - (and (not (hashq-ref k-table sym)) - (rewrite-cps-cont cont - (($ $kargs names syms body) - (sym ($kargs names syms ,(visit-term body)))) - (($ $kfun src meta self tail clause) - (sym ($kfun src meta self ,tail - ,(and clause (must-visit-cont clause))))) - (($ $kclause arity body alternate) - (sym ($kclause ,arity ,(must-visit-cont body) - ,(and alternate (must-visit-cont alternate))))) - (($ $kreceive) - (sym ,cont))))))) - (define (visit-term term) - (match term - (($ $letk conts body) - (match (filter-map visit-cont conts) - (() (visit-term body)) - (conts (build-cps-term - ($letk ,conts ,(visit-term body)))))) - (($ $continue k src exp) - (cond - ((hashq-ref k-table k) => visit-term) - (else - (build-cps-term ($continue k src ,(visit-exp exp)))))))) - (define (visit-exp exp) - (match exp - ((or ($ $const) ($ $prim)) exp) - (($ $fun) (visit-fun exp)) - (($ $rec names syms funs) - (build-cps-exp ($rec names (map subst syms) (map visit-fun funs)))) - (($ $call proc args) - (let ((args (map subst args))) - (build-cps-exp ($call (subst proc) args)))) - (($ $callk k proc args) - (let ((args (map subst args))) - (build-cps-exp ($callk k (subst proc) args)))) - (($ $primcall name args) - (let ((args (map subst args))) - (build-cps-exp ($primcall name args)))) - (($ $values args) - (let ((args (map subst args))) - (build-cps-exp ($values args)))) - (($ $branch kt exp) - (build-cps-exp ($branch kt ,(visit-exp exp)))) - (($ $prompt escape? tag handler) - (build-cps-exp ($prompt escape? (subst tag) handler))))) - (define (visit-fun fun) - (rewrite-cps-exp fun - (($ $fun body) - ($fun ,(must-visit-cont body))))) - (must-visit-cont fun))) - -;; Rewrite the scope tree to reflect the dominator tree. Precondition: -;; the fun has been renumbered, its min-label is 0, and its labels are -;; packed. -(define (redominate fun) - (let* ((dfg (compute-dfg fun)) - (idoms (compute-idoms dfg 0 (dfg-label-count dfg))) - (doms (compute-dom-edges idoms 0))) - (define (visit-fun-cont cont) - (rewrite-cps-cont cont - (($ $cont label ($ $kfun src meta self tail clause)) - (label ($kfun src meta self ,tail - ,(and clause (visit-fun-cont clause))))) - (($ $cont label ($ $kclause arity ($ $cont kbody body) alternate)) - (label ($kclause ,arity ,(visit-cont kbody body) - ,(and alternate (visit-fun-cont alternate))))))) - - (define (visit-cont label cont) - (rewrite-cps-cont cont - (($ $kargs names vars body) - (label ($kargs names vars ,(visit-term body label)))) - (_ (label ,cont)))) - - (define (visit-fun fun) - (rewrite-cps-exp fun - (($ $fun body) - ($fun ,(visit-fun-cont body))))) - - (define (visit-exp k src exp) - (rewrite-cps-term exp - (($ $fun body) - ($continue k src ,(visit-fun exp))) - (($ $rec names syms funs) - ($continue k src ($rec names syms (map visit-fun funs)))) - (_ - ($continue k src ,exp)))) - - (define (visit-term term label) - (define (visit-dom-conts label) - (let ((cont (lookup-cont label dfg))) - (match cont - (($ $ktail) '()) - (($ $kargs) (list (visit-cont label cont))) - (else - (cons (visit-cont label cont) - (visit-dom-conts* (vector-ref doms label))))))) - - (define (visit-dom-conts* labels) - (match labels - (() '()) - ((label . labels) - (append (visit-dom-conts label) - (visit-dom-conts* labels))))) - - (rewrite-cps-term term - (($ $letk conts body) - ,(visit-term body label)) - (($ $continue k src exp) - ,(let ((conts (visit-dom-conts* (vector-ref doms label)))) - (if (null? conts) - (visit-exp k src exp) - (build-cps-term - ($letk ,conts ,(visit-exp k src exp)))))))) - - (visit-fun-cont fun))) - -(define (simplify fun) - ;; Renumbering prunes continuations that are made unreachable by - ;; eta/beta reductions. - (redominate (renumber (eta-reduce (beta-reduce fun))))) diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm deleted file mode 100644 index e5b76fb13..000000000 --- a/module/language/cps/specialize-primcalls.scm +++ /dev/null @@ -1,107 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; Some bytecode operations can encode an immediate as an operand. -;;; This pass tranforms generic primcalls to these specialized -;;; primcalls, if possible. -;;; -;;; Code: - -(define-module (language cps specialize-primcalls) - #:use-module (ice-9 match) - #:use-module (language cps) - #:use-module (language cps dfg) - #:export (specialize-primcalls)) - -(define (specialize-primcalls fun) - (let ((dfg (compute-dfg fun #:global? #t))) - (with-fresh-name-state-from-dfg dfg - (define (immediate-u8? sym) - (call-with-values (lambda () (find-constant-value sym dfg)) - (lambda (has-const? val) - (and has-const? (integer? val) (exact? val) (<= 0 val 255))))) - (define (visit-cont cont) - (rewrite-cps-cont cont - (($ $cont sym ($ $kargs names syms body)) - (sym ($kargs names syms ,(visit-term body)))) - (($ $cont sym ($ $kfun src meta self tail clause)) - (sym ($kfun src meta self ,tail - ,(and clause (visit-cont clause))))) - (($ $cont sym ($ $kclause arity body alternate)) - (sym ($kclause ,arity ,(visit-cont body) - ,(and alternate (visit-cont alternate))))) - (($ $cont) - ,cont))) - (define (visit-term term) - (rewrite-cps-term term - (($ $letk conts body) - ($letk ,(map visit-cont conts) - ,(visit-term body))) - (($ $continue k src (and fun ($ $fun))) - ($continue k src ,(visit-fun fun))) - (($ $continue k src ($ $rec names syms funs)) - ($continue k src ($rec names syms (map visit-fun funs)))) - (($ $continue k src ($ $primcall name args)) - ,(visit-primcall k src name args)) - (($ $continue) - ,term))) - (define (visit-primcall k src name args) - ;; If we introduce a VM op from a primcall without a VM op, we - ;; will need to ensure that the return arity matches. Rely on the - ;; elide-values pass to clean up. - (define-syntax-rule (adapt-void exp) - (let-fresh (k* kvoid) (val) - (build-cps-term - ($letk ((k* ($kargs ('val) (val) - ($continue k src ($primcall 'values (val))))) - (kvoid ($kargs () () - ($continue k* src ($const *unspecified*))))) - ($continue kvoid src exp))))) - (define-syntax-rule (adapt-val exp) - (let-fresh (k*) (val) - (build-cps-term - ($letk ((k* ($kargs ('val) (val) - ($continue k src ($primcall 'values (val)))))) - ($continue k* src exp))))) - (match (cons name args) - (('make-vector (? immediate-u8? n) init) - (adapt-val ($primcall 'make-vector/immediate (n init)))) - (('vector-ref v (? immediate-u8? n)) - (build-cps-term - ($continue k src ($primcall 'vector-ref/immediate (v n))))) - (('vector-set! v (? immediate-u8? n) x) - (build-cps-term - ($continue k src ($primcall 'vector-set!/immediate (v n x))))) - (('allocate-struct v (? immediate-u8? n)) - (adapt-val ($primcall 'allocate-struct/immediate (v n)))) - (('struct-ref s (? immediate-u8? n)) - (adapt-val ($primcall 'struct-ref/immediate (s n)))) - (('struct-set! s (? immediate-u8? n) x) - (build-cps-term - ($continue k src ($primcall 'struct-set!/immediate (s n x))))) - (_ - (build-cps-term ($continue k src ($primcall name args)))))) - - (define (visit-fun fun) - (rewrite-cps-exp fun - (($ $fun body) - ($fun ,(visit-cont body))))) - - (visit-cont fun)))) diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm deleted file mode 100644 index ba66ec3ff..000000000 --- a/module/language/cps/type-fold.scm +++ /dev/null @@ -1,443 +0,0 @@ -;;; Abstract constant folding on CPS -;;; Copyright (C) 2014, 2015 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 License as -;;; published by the Free Software Foundation, either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; This library is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with this program. If not, see -;;; . - -;;; Commentary: -;;; -;;; This pass uses the abstract interpretation provided by type analysis -;;; to fold constant values and type predicates. It is most profitably -;;; run after CSE, to take advantage of scalar replacement. -;;; -;;; Code: - -(define-module (language cps type-fold) - #:use-module (ice-9 match) - #:use-module (language cps) - #:use-module (language cps dfg) - #:use-module (language cps renumber) - #:use-module (language cps types) - #:use-module (system base target) - #:export (type-fold)) - - - - -;; Branch folders. - -(define &scalar-types - (logior &exact-integer &flonum &char &unspecified &false &true &nil &null)) - -(define *branch-folders* (make-hash-table)) - -(define-syntax-rule (define-branch-folder name f) - (hashq-set! *branch-folders* 'name f)) - -(define-syntax-rule (define-branch-folder-alias to from) - (hashq-set! *branch-folders* 'to (hashq-ref *branch-folders* 'from))) - -(define-syntax-rule (define-unary-branch-folder (name arg min max) body ...) - (define-branch-folder name (lambda (arg min max) body ...))) - -(define-syntax-rule (define-binary-branch-folder (name arg0 min0 max0 - arg1 min1 max1) - body ...) - (define-branch-folder name (lambda (arg0 min0 max0 arg1 min1 max1) body ...))) - -(define-syntax-rule (define-unary-type-predicate-folder name &type) - (define-unary-branch-folder (name type min max) - (let ((type* (logand type &type))) - (cond - ((zero? type*) (values #t #f)) - ((eqv? type type*) (values #t #t)) - (else (values #f #f)))))) - -;; All the cases that are in compile-bytecode. -(define-unary-type-predicate-folder pair? &pair) -(define-unary-type-predicate-folder null? &null) -(define-unary-type-predicate-folder nil? &nil) -(define-unary-type-predicate-folder symbol? &symbol) -(define-unary-type-predicate-folder variable? &box) -(define-unary-type-predicate-folder vector? &vector) -(define-unary-type-predicate-folder struct? &struct) -(define-unary-type-predicate-folder string? &string) -(define-unary-type-predicate-folder number? &number) -(define-unary-type-predicate-folder char? &char) - -(define-binary-branch-folder (eq? type0 min0 max0 type1 min1 max1) - (cond - ((or (zero? (logand type0 type1)) (< max0 min1) (< max1 min0)) - (values #t #f)) - ((and (eqv? type0 type1) - (eqv? min0 min1 max0 max1) - (zero? (logand type0 (1- type0))) - (not (zero? (logand type0 &scalar-types)))) - (values #t #t)) - (else - (values #f #f)))) -(define-branch-folder-alias eqv? eq?) -(define-branch-folder-alias equal? eq?) - -(define (compare-ranges type0 min0 max0 type1 min1 max1) - (and (zero? (logand (logior type0 type1) (lognot &real))) - (cond ((< max0 min1) '<) - ((> min0 max1) '>) - ((= min0 max0 min1 max1) '=) - ((<= max0 min1) '<=) - ((>= min0 max1) '>=) - (else #f)))) - -(define-binary-branch-folder (< type0 min0 max0 type1 min1 max1) - (case (compare-ranges type0 min0 max0 type1 min1 max1) - ((<) (values #t #t)) - ((= >= >) (values #t #f)) - (else (values #f #f)))) - -(define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1) - (case (compare-ranges type0 min0 max0 type1 min1 max1) - ((< <= =) (values #t #t)) - ((>) (values #t #f)) - (else (values #f #f)))) - -(define-binary-branch-folder (= type0 min0 max0 type1 min1 max1) - (case (compare-ranges type0 min0 max0 type1 min1 max1) - ((=) (values #t #t)) - ((< >) (values #t #f)) - (else (values #f #f)))) - -(define-binary-branch-folder (>= type0 min0 max0 type1 min1 max1) - (case (compare-ranges type0 min0 max0 type1 min1 max1) - ((> >= =) (values #t #t)) - ((<) (values #t #f)) - (else (values #f #f)))) - -(define-binary-branch-folder (> type0 min0 max0 type1 min1 max1) - (case (compare-ranges type0 min0 max0 type1 min1 max1) - ((>) (values #t #t)) - ((= <= <) (values #t #f)) - (else (values #f #f)))) - -(define-binary-branch-folder (logtest type0 min0 max0 type1 min1 max1) - (define (logand-min a b) - (if (< a b 0) - (min a b) - 0)) - (define (logand-max a b) - (if (< a b 0) - 0 - (max a b))) - (if (and (= min0 max0) (= min1 max1) (eqv? type0 type1 &exact-integer)) - (values #t (logtest min0 min1)) - (values #f #f))) - - - - -;; Strength reduction. - -(define *primcall-reducers* (make-hash-table)) - -(define-syntax-rule (define-primcall-reducer name f) - (hashq-set! *primcall-reducers* 'name f)) - -(define-syntax-rule (define-unary-primcall-reducer (name dfg k src - arg type min max) - body ...) - (define-primcall-reducer name - (lambda (dfg k src arg type min max) body ...))) - -(define-syntax-rule (define-binary-primcall-reducer (name dfg k src - arg0 type0 min0 max0 - arg1 type1 min1 max1) - body ...) - (define-primcall-reducer name - (lambda (dfg k src arg0 type0 min0 max0 arg1 type1 min1 max1) body ...))) - -(define-binary-primcall-reducer (mul dfg k src - arg0 type0 min0 max0 - arg1 type1 min1 max1) - (define (negate arg) - (let-fresh (kzero) (zero) - (build-cps-term - ($letk ((kzero ($kargs (#f) (zero) - ($continue k src ($primcall 'sub (zero arg)))))) - ($continue kzero src ($const 0)))))) - (define (zero) - (build-cps-term ($continue k src ($const 0)))) - (define (identity arg) - (build-cps-term ($continue k src ($values (arg))))) - (define (double arg) - (build-cps-term ($continue k src ($primcall 'add (arg arg))))) - (define (power-of-two constant arg) - (let ((n (let lp ((bits 0) (constant constant)) - (if (= constant 1) bits (lp (1+ bits) (ash constant -1)))))) - (let-fresh (kbits) (bits) - (build-cps-term - ($letk ((kbits ($kargs (#f) (bits) - ($continue k src ($primcall 'ash (arg bits)))))) - ($continue kbits src ($const n))))))) - (define (mul/constant constant constant-type arg arg-type) - (and (or (= constant-type &exact-integer) (= constant-type arg-type)) - (case constant - ;; (* arg -1) -> (- 0 arg) - ((-1) (negate arg)) - ;; (* arg 0) -> 0 if arg is not a flonum or complex - ((0) (and (= constant-type &exact-integer) - (zero? (logand arg-type - (lognot (logior &flonum &complex)))) - (zero))) - ;; (* arg 1) -> arg - ((1) (identity arg)) - ;; (* arg 2) -> (+ arg arg) - ((2) (double arg)) - (else (and (= constant-type arg-type &exact-integer) - (positive? constant) - (zero? (logand constant (1- constant))) - (power-of-two constant arg)))))) - (cond - ((logtest (logior type0 type1) (lognot &number)) #f) - ((= min0 max0) (mul/constant min0 type0 arg1 type1)) - ((= min1 max1) (mul/constant min1 type1 arg0 type0)) - (else #f))) - -(define-binary-primcall-reducer (logbit? dfg k src - arg0 type0 min0 max0 - arg1 type1 min1 max1) - (define (convert-to-logtest bool-term) - (let-fresh (kt kf kmask kbool) (mask bool) - (build-cps-term - ($letk ((kt ($kargs () () - ($continue kbool src ($const #t)))) - (kf ($kargs () () - ($continue kbool src ($const #f)))) - (kbool ($kargs (#f) (bool) - ,(bool-term bool))) - (kmask ($kargs (#f) (mask) - ($continue kf src - ($branch kt ($primcall 'logtest (mask arg1))))))) - ,(if (eq? min0 max0) - ($continue kmask src ($const (ash 1 min0))) - (let-fresh (kone) (one) - (build-cps-term - ($letk ((kone ($kargs (#f) (one) - ($continue kmask src - ($primcall 'ash (one arg0)))))) - ($continue kone src ($const 1)))))))))) - ;; Hairiness because we are converting from a primcall with unknown - ;; arity to a branching primcall. - (let ((positive-fixnum-bits (- (* (target-word-size) 8) 3))) - (and (= type0 &exact-integer) - (<= 0 min0 positive-fixnum-bits) - (<= 0 max0 positive-fixnum-bits) - (match (lookup-cont k dfg) - (($ $kreceive arity kargs) - (match arity - (($ $arity (_) () (not #f) () #f) - (convert-to-logtest - (lambda (bool) - (let-fresh (knil) (nil) - (build-cps-term - ($letk ((knil ($kargs (#f) (nil) - ($continue kargs src - ($values (bool nil)))))) - ($continue knil src ($const '())))))))) - (_ - (convert-to-logtest - (lambda (bool) - (build-cps-term - ($continue k src ($primcall 'values (bool))))))))) - (($ $ktail) - (convert-to-logtest - (lambda (bool) - (build-cps-term - ($continue k src ($primcall 'return (bool))))))))))) - - - - -;; - -(define (fold-and-reduce fun dfg min-label min-var) - (define (scalar-value type val) - (cond - ((eqv? type &exact-integer) val) - ((eqv? type &flonum) (exact->inexact val)) - ((eqv? type &char) (integer->char val)) - ((eqv? type &unspecified) *unspecified*) - ((eqv? type &false) #f) - ((eqv? type &true) #t) - ((eqv? type &nil) #nil) - ((eqv? type &null) '()) - (else (error "unhandled type" type val)))) - (let* ((typev (infer-types fun dfg)) - (label-count ((make-local-cont-folder label-count) - (lambda (k cont label-count) (1+ label-count)) - fun 0)) - (folded? (make-bitvector label-count #f)) - (folded-values (make-vector label-count #f)) - (reduced-terms (make-vector label-count #f))) - (define (label->idx label) (- label min-label)) - (define (var->idx var) (- var min-var)) - (define (maybe-reduce-primcall! label k src name args) - (let* ((reducer (hashq-ref *primcall-reducers* name))) - (when reducer - (vector-set! - reduced-terms - (label->idx label) - (match args - ((arg0) - (call-with-values (lambda () (lookup-pre-type typev label arg0)) - (lambda (type0 min0 max0) - (reducer dfg k src arg0 type0 min0 max0)))) - ((arg0 arg1) - (call-with-values (lambda () (lookup-pre-type typev label arg0)) - (lambda (type0 min0 max0) - (call-with-values (lambda () (lookup-pre-type typev label arg1)) - (lambda (type1 min1 max1) - (reducer dfg k src arg0 type0 min0 max0 - arg1 type1 min1 max1)))))) - (_ #f)))))) - (define (maybe-fold-value! label name def) - (call-with-values (lambda () (lookup-post-type typev label def 0)) - (lambda (type min max) - (cond - ((and (not (zero? type)) - (zero? (logand type (1- type))) - (zero? (logand type (lognot &scalar-types))) - (eqv? min max)) - (bitvector-set! folded? (label->idx label) #t) - (vector-set! folded-values (label->idx label) - (scalar-value type min)) - #t) - (else #f))))) - (define (maybe-fold-unary-branch! label name arg) - (let* ((folder (hashq-ref *branch-folders* name))) - (when folder - (call-with-values (lambda () (lookup-pre-type typev label arg)) - (lambda (type min max) - (call-with-values (lambda () (folder type min max)) - (lambda (f? v) - (bitvector-set! folded? (label->idx label) f?) - (vector-set! folded-values (label->idx label) v)))))))) - (define (maybe-fold-binary-branch! label name arg0 arg1) - (let* ((folder (hashq-ref *branch-folders* name))) - (when folder - (call-with-values (lambda () (lookup-pre-type typev label arg0)) - (lambda (type0 min0 max0) - (call-with-values (lambda () (lookup-pre-type typev label arg1)) - (lambda (type1 min1 max1) - (call-with-values (lambda () - (folder type0 min0 max0 type1 min1 max1)) - (lambda (f? v) - (bitvector-set! folded? (label->idx label) f?) - (vector-set! folded-values (label->idx label) v)))))))))) - (define (visit-cont cont) - (match cont - (($ $cont label ($ $kargs _ _ body)) - (visit-term body label)) - (($ $cont label ($ $kclause arity body alternate)) - (visit-cont body) - (visit-cont alternate)) - (_ #f))) - (define (visit-term term label) - (match term - (($ $letk conts body) - (for-each visit-cont conts) - (visit-term body label)) - (($ $continue k src ($ $primcall name args)) - ;; We might be able to fold primcalls that define a value. - (match (lookup-cont k dfg) - (($ $kargs (_) (def)) - ;(pk 'maybe-fold-value src name args) - (unless (maybe-fold-value! label name def) - (maybe-reduce-primcall! label k src name args))) - (_ - (maybe-reduce-primcall! label k src name args)))) - (($ $continue kf src ($ $branch kt ($ $primcall name args))) - ;; We might be able to fold primcalls that branch. - ;(pk 'maybe-fold-branch label src name args) - (match args - ((arg) - (maybe-fold-unary-branch! label name arg)) - ((arg0 arg1) - (maybe-fold-binary-branch! label name arg0 arg1)))) - (_ #f))) - (when typev - (match fun - (($ $cont kfun ($ $kfun src meta self tail clause)) - (visit-cont clause)))) - (values folded? folded-values reduced-terms))) - -(define (fold-constants* fun dfg) - (match fun - (($ $cont min-label ($ $kfun _ _ min-var)) - (call-with-values (lambda () (fold-and-reduce fun dfg min-label min-var)) - (lambda (folded? folded-values reduced-terms) - (define (label->idx label) (- label min-label)) - (define (var->idx var) (- var min-var)) - (define (visit-cont cont) - (rewrite-cps-cont cont - (($ $cont label ($ $kargs names syms body)) - (label ($kargs names syms ,(visit-term body label)))) - (($ $cont label ($ $kclause arity body alternate)) - (label ($kclause ,arity ,(visit-cont body) - ,(and alternate (visit-cont alternate))))) - (_ ,cont))) - (define (visit-term term label) - (rewrite-cps-term term - (($ $letk conts body) - ($letk ,(map visit-cont conts) - ,(visit-term body label))) - (($ $continue k src (and fun ($ $fun))) - ($continue k src ,(visit-fun fun))) - (($ $continue k src ($ $rec names vars funs)) - ($continue k src ($rec names vars (map visit-fun funs)))) - (($ $continue k src (and primcall ($ $primcall name args))) - ,(cond - ((bitvector-ref folded? (label->idx label)) - (let ((val (vector-ref folded-values (label->idx label)))) - ;; Uncomment for debugging. - ;; (pk 'folded src primcall val) - (let-fresh (k*) (v*) - ;; Rely on DCE to elide this expression, if - ;; possible. - (build-cps-term - ($letk ((k* ($kargs (#f) (v*) - ($continue k src ($const val))))) - ($continue k* src ,primcall)))))) - (else - (or (vector-ref reduced-terms (label->idx label)) - term)))) - (($ $continue kf src ($ $branch kt ($ $primcall))) - ,(if (bitvector-ref folded? (label->idx label)) - ;; Folded branch. - (let ((val (vector-ref folded-values (label->idx label)))) - (build-cps-term - ($continue (if val kt kf) src ($values ())))) - term)) - (_ ,term))) - (define (visit-fun fun) - (rewrite-cps-exp fun - (($ $fun body) - ($fun ,(fold-constants* body dfg))))) - (rewrite-cps-cont fun - (($ $cont kfun ($ $kfun src meta self tail clause)) - (kfun ($kfun src meta self ,tail ,(visit-cont clause)))))))))) - -(define (type-fold fun) - (let* ((fun (renumber fun)) - (dfg (compute-dfg fun))) - (with-fresh-name-state-from-dfg dfg - (fold-constants* fun dfg)))) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm deleted file mode 100644 index 5e0b2d083..000000000 --- a/module/language/cps/types.scm +++ /dev/null @@ -1,1424 +0,0 @@ -;;; Type analysis on CPS -;;; Copyright (C) 2014, 2015 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 License as -;;; published by the Free Software Foundation, either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; This library is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with this program. If not, see -;;; . - -;;; Commentary: -;;; -;;; Type analysis computes the possible types and ranges that values may -;;; have at all program positions. This analysis can help to prove that -;;; a primcall has no side-effects, if its arguments have the -;;; appropriate type and range. It can also enable constant folding of -;;; type predicates and, in the future, enable the compiler to choose -;;; untagged, unboxed representations for numbers. -;;; -;;; For the purposes of this analysis, a "type" is an aspect of a value -;;; that will not change. Guile's CPS intermediate language does not -;;; carry manifest type information that asserts properties about given -;;; values; instead, we recover this information via flow analysis, -;;; garnering properties from type predicates, constant literals, -;;; primcall results, and primcalls that assert that their arguments are -;;; of particular types. -;;; -;;; A range denotes a subset of the set of values in a type, bounded by -;;; a minimum and a maximum. The precise meaning of a range depends on -;;; the type. For real numbers, the range indicates an inclusive lower -;;; and upper bound on the integer value of a type. For vectors, the -;;; range indicates the length of the vector. The range is limited to a -;;; signed 32-bit value, with the smallest and largest values indicating -;;; -inf.0 and +inf.0, respectively. For some types, like pairs, the -;;; concept of "range" makes no sense. In these cases we consider the -;;; range to be -inf.0 to +inf.0. -;;; -;;; Types are represented as a bitfield. Fewer bits means a more precise -;;; type. Although normally only values that have a single type will -;;; have an associated range, this is not enforced. The range applies -;;; to all types in the bitfield. When control flow meets, the types and -;;; ranges meet with the union operator. -;;; -;;; It is not practical to precisely compute value ranges in all cases. -;;; For example, in the following case: -;;; -;;; (let lp ((n 0)) (when (foo) (lp (1+ n)))) -;;; -;;; The first time that range analysis visits the program, N is -;;; determined to be the exact integer 0. The second time, it is an -;;; exact integer in the range [0, 1]; the third, [0, 2]; and so on. -;;; This analysis will terminate, but only after the positive half of -;;; the 32-bit range has been fully explored and we decide that the -;;; range of N is [0, +inf.0]. At the same time, we want to do range -;;; analysis and type analysis at the same time, as there are -;;; interactions between them, notably in the case of `sqrt' which -;;; returns a complex number if its argument cannot be proven to be -;;; non-negative. So what we do is, once the types reach a fixed point, -;;; we cause control-flow joins that would expand the range of a value -;;; to saturate that range towards positive or infinity (as -;;; appropriate). -;;; -;;; A naive approach to type analysis would build up a table that has -;;; entries for all variables at all program points, but this has -;;; N-squared complexity and quickly grows unmanageable. Instead, we -;;; use _intmaps_ from (language cps intmap) to share state between -;;; connected program points. -;;; -;;; Code: - -(define-module (language cps types) - #:use-module (ice-9 match) - #:use-module (language cps) - #:use-module (language cps dfg) - #:use-module (language cps intmap) - #:use-module (rnrs bytevectors) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-11) - #:export (;; Specific types. - &exact-integer - &flonum - &complex - &fraction - - &char - &unspecified - &unbound - &false - &true - &nil - &null - &symbol - &keyword - - &procedure - - &pointer - &fluid - &pair - &vector - &box - &struct - &string - &bytevector - &bitvector - &array - &hash-table - - ;; Union types. - &number &real - - infer-types - lookup-pre-type - lookup-post-type - primcall-types-check?)) - -(define-syntax define-flags - (lambda (x) - (syntax-case x () - ((_ all shift name ...) - (let ((count (length #'(name ...)))) - (with-syntax (((n ...) (iota count)) - (count count)) - #'(begin - (define-syntax name (identifier-syntax (ash 1 n))) - ... - (define-syntax all (identifier-syntax (1- (ash 1 count)))) - (define-syntax shift (identifier-syntax count))))))))) - -;; More precise types have fewer bits. -(define-flags &all-types &type-bits - &exact-integer - &flonum - &complex - &fraction - - &char - &unspecified - &unbound - &false - &true - &nil - &null - &symbol - &keyword - - &procedure - - &pointer - &fluid - &pair - &vector - &box - &struct - &string - &bytevector - &bitvector - &array - &hash-table) - -(define-syntax &no-type (identifier-syntax 0)) - -(define-syntax &number - (identifier-syntax (logior &exact-integer &flonum &complex &fraction))) -(define-syntax &real - (identifier-syntax (logior &exact-integer &flonum &fraction))) - -(define-syntax *max-s32* (identifier-syntax (- (ash 1 31) 1))) -(define-syntax *min-s32* (identifier-syntax (- 0 (ash 1 31)))) - -;; Versions of min and max that do not coerce exact numbers to become -;; inexact. -(define min - (case-lambda - ((a b) (if (< a b) a b)) - ((a b c) (min (min a b) c)) - ((a b c d) (min (min a b) c d)))) -(define max - (case-lambda - ((a b) (if (> a b) a b)) - ((a b c) (max (max a b) c)) - ((a b c d) (max (max a b) c d)))) - - - -(define-syntax-rule (define-compile-time-value name val) - (define-syntax name - (make-variable-transformer - (lambda (x) - (syntax-case x (set!) - (var (identifier? #'var) - (datum->syntax #'var val))))))) - -(define-compile-time-value min-fixnum most-negative-fixnum) -(define-compile-time-value max-fixnum most-positive-fixnum) - -(define-inlinable (make-unclamped-type-entry type min max) - (vector type min max)) -(define-inlinable (type-entry-type tentry) - (vector-ref tentry 0)) -(define-inlinable (type-entry-clamped-min tentry) - (vector-ref tentry 1)) -(define-inlinable (type-entry-clamped-max tentry) - (vector-ref tentry 2)) - -(define-syntax-rule (clamp-range val) - (cond - ((< val min-fixnum) min-fixnum) - ((< max-fixnum val) max-fixnum) - (else val))) - -(define-inlinable (make-type-entry type min max) - (vector type (clamp-range min) (clamp-range max))) -(define-inlinable (type-entry-min tentry) - (let ((min (type-entry-clamped-min tentry))) - (if (eq? min min-fixnum) -inf.0 min))) -(define-inlinable (type-entry-max tentry) - (let ((max (type-entry-clamped-max tentry))) - (if (eq? max max-fixnum) +inf.0 max))) - -(define all-types-entry (make-type-entry &all-types -inf.0 +inf.0)) - -(define* (var-type-entry typeset var #:optional (default all-types-entry)) - (intmap-ref typeset var (lambda (_) default))) - -(define (var-type typeset var) - (type-entry-type (var-type-entry typeset var))) -(define (var-min typeset var) - (type-entry-min (var-type-entry typeset var))) -(define (var-max typeset var) - (type-entry-max (var-type-entry typeset var))) - -;; Is the type entry A contained entirely within B? -(define (type-entry<=? a b) - (match (cons a b) - ((#(a-type a-min a-max) . #(b-type b-min b-max)) - (and (eqv? b-type (logior a-type b-type)) - (<= b-min a-min) - (>= b-max a-max))))) - -(define (type-entry-union a b) - (cond - ((type-entry<=? b a) a) - ((type-entry<=? a b) b) - (else (make-type-entry - (logior (type-entry-type a) (type-entry-type b)) - (min (type-entry-clamped-min a) (type-entry-clamped-min b)) - (max (type-entry-clamped-max a) (type-entry-clamped-max b)))))) - -(define (type-entry-intersection a b) - (cond - ((type-entry<=? a b) a) - ((type-entry<=? b a) b) - (else (make-type-entry - (logand (type-entry-type a) (type-entry-type b)) - (max (type-entry-clamped-min a) (type-entry-clamped-min b)) - (min (type-entry-clamped-max a) (type-entry-clamped-max b)))))) - -(define (adjoin-var typeset var entry) - (intmap-add typeset var entry type-entry-union)) - -(define (restrict-var typeset var entry) - (intmap-add typeset var entry type-entry-intersection)) - -(define (constant-type val) - "Compute the type and range of VAL. Return three values: the type, -minimum, and maximum." - (define (return type val) - (if val - (make-type-entry type val val) - (make-type-entry type -inf.0 +inf.0))) - (cond - ((number? val) - (cond - ((exact-integer? val) (return &exact-integer val)) - ((eqv? (imag-part val) 0) - (if (nan? val) - (make-type-entry &flonum -inf.0 +inf.0) - (make-type-entry - (if (exact? val) &fraction &flonum) - (if (rational? val) (inexact->exact (floor val)) val) - (if (rational? val) (inexact->exact (ceiling val)) val)))) - (else (return &complex #f)))) - ((eq? val '()) (return &null #f)) - ((eq? val #nil) (return &nil #f)) - ((eq? val #t) (return &true #f)) - ((eq? val #f) (return &false #f)) - ((char? val) (return &char (char->integer val))) - ((eqv? val *unspecified*) (return &unspecified #f)) - ((symbol? val) (return &symbol #f)) - ((keyword? val) (return &keyword #f)) - ((pair? val) (return &pair #f)) - ((vector? val) (return &vector (vector-length val))) - ((string? val) (return &string (string-length val))) - ((bytevector? val) (return &bytevector (bytevector-length val))) - ((bitvector? val) (return &bitvector (bitvector-length val))) - ((array? val) (return &array (array-rank val))) - ((not (variable-bound? (make-variable val))) (return &unbound #f)) - - (else (error "unhandled constant" val)))) - -(define *type-checkers* (make-hash-table)) -(define *type-inferrers* (make-hash-table)) - -(define-syntax-rule (define-type-helper name) - (define-syntax-parameter name - (lambda (stx) - (syntax-violation 'name - "macro used outside of define-type" - stx)))) -(define-type-helper define!) -(define-type-helper restrict!) -(define-type-helper &type) -(define-type-helper &min) -(define-type-helper &max) - -(define-syntax-rule (define-type-checker (name arg ...) body ...) - (hashq-set! - *type-checkers* - 'name - (lambda (typeset arg ...) - (syntax-parameterize - ((&type (syntax-rules () ((_ val) (var-type typeset val)))) - (&min (syntax-rules () ((_ val) (var-min typeset val)))) - (&max (syntax-rules () ((_ val) (var-max typeset val))))) - body ...)))) - -(define-syntax-rule (check-type arg type min max) - ;; If the arg is negative, it is a closure variable. - (and (>= arg 0) - (zero? (logand (lognot type) (&type arg))) - (<= min (&min arg)) - (<= (&max arg) max))) - -(define-syntax-rule (define-type-inferrer* (name succ var ...) body ...) - (hashq-set! - *type-inferrers* - 'name - (lambda (in succ var ...) - (let ((out in)) - (syntax-parameterize - ((define! - (syntax-rules () - ((_ val type min max) - (set! out (adjoin-var out val - (make-type-entry type min max)))))) - (restrict! - (syntax-rules () - ((_ val type min max) - (set! out (restrict-var out val - (make-type-entry type min max)))))) - (&type (syntax-rules () ((_ val) (var-type in val)))) - (&min (syntax-rules () ((_ val) (var-min in val)))) - (&max (syntax-rules () ((_ val) (var-max in val))))) - body ... - out))))) - -(define-syntax-rule (define-type-inferrer (name arg ...) body ...) - (define-type-inferrer* (name succ arg ...) body ...)) - -(define-syntax-rule (define-predicate-inferrer (name arg ... true?) body ...) - (define-type-inferrer* (name succ arg ...) - (let ((true? (not (zero? succ)))) - body ...))) - -(define-syntax define-simple-type-checker - (lambda (x) - (define (parse-spec l) - (syntax-case l () - (() '()) - (((type min max) . l) (cons #'(type min max) (parse-spec #'l))) - (((type min+max) . l) (cons #'(type min+max min+max) (parse-spec #'l))) - ((type . l) (cons #'(type -inf.0 +inf.0) (parse-spec #'l))))) - (syntax-case x () - ((_ (name arg-spec ...) result-spec ...) - (with-syntax - (((arg ...) (generate-temporaries #'(arg-spec ...))) - (((arg-type arg-min arg-max) ...) (parse-spec #'(arg-spec ...)))) - #'(define-type-checker (name arg ...) - (and (check-type arg arg-type arg-min arg-max) - ...))))))) - -(define-syntax define-simple-type-inferrer - (lambda (x) - (define (parse-spec l) - (syntax-case l () - (() '()) - (((type min max) . l) (cons #'(type min max) (parse-spec #'l))) - (((type min+max) . l) (cons #'(type min+max min+max) (parse-spec #'l))) - ((type . l) (cons #'(type -inf.0 +inf.0) (parse-spec #'l))))) - (syntax-case x () - ((_ (name arg-spec ...) result-spec ...) - (with-syntax - (((arg ...) (generate-temporaries #'(arg-spec ...))) - (((arg-type arg-min arg-max) ...) (parse-spec #'(arg-spec ...))) - ((res ...) (generate-temporaries #'(result-spec ...))) - (((res-type res-min res-max) ...) (parse-spec #'(result-spec ...)))) - #'(define-type-inferrer (name arg ... res ...) - (restrict! arg arg-type arg-min arg-max) - ... - (define! res res-type res-min res-max) - ...)))))) - -(define-syntax-rule (define-simple-type (name arg-spec ...) result-spec ...) - (begin - (define-simple-type-checker (name arg-spec ...)) - (define-simple-type-inferrer (name arg-spec ...) result-spec ...))) - -(define-syntax-rule (define-simple-types - ((name arg-spec ...) result-spec ...) - ...) - (begin - (define-simple-type (name arg-spec ...) result-spec ...) - ...)) - -(define-syntax-rule (define-type-checker-aliases orig alias ...) - (let ((check (hashq-ref *type-checkers* 'orig))) - (hashq-set! *type-checkers* 'alias check) - ...)) -(define-syntax-rule (define-type-inferrer-aliases orig alias ...) - (let ((check (hashq-ref *type-inferrers* 'orig))) - (hashq-set! *type-inferrers* 'alias check) - ...)) -(define-syntax-rule (define-type-aliases orig alias ...) - (begin - (define-type-checker-aliases orig alias ...) - (define-type-inferrer-aliases orig alias ...))) - - - - -;;; This list of primcall type definitions follows the order of -;;; effects-analysis.scm; please keep it in a similar order. -;;; -;;; There is no need to add checker definitions for expressions that do -;;; not exhibit the &type-check effect, as callers should not ask if -;;; such an expression does or does not type-check. For those that do -;;; exhibit &type-check, you should define a type inferrer unless the -;;; primcall will never typecheck. -;;; -;;; Likewise there is no need to define inferrers for primcalls which -;;; return &all-types values and which never raise exceptions from which -;;; we can infer the types of incoming values. - - - - -;;; -;;; Generic effect-free predicates. -;;; - -(define-predicate-inferrer (eq? a b true?) - ;; We can only propagate information down the true leg. - (when true? - (let ((type (logand (&type a) (&type b))) - (min (max (&min a) (&min b))) - (max (min (&max a) (&max b)))) - (restrict! a type min max) - (restrict! b type min max)))) -(define-type-inferrer-aliases eq? eqv? equal?) - -(define-syntax-rule (define-simple-predicate-inferrer predicate type) - (define-predicate-inferrer (predicate val true?) - (let ((type (if true? - type - (logand (&type val) (lognot type))))) - (restrict! val type -inf.0 +inf.0)))) -(define-simple-predicate-inferrer pair? &pair) -(define-simple-predicate-inferrer null? &null) -(define-simple-predicate-inferrer nil? &nil) -(define-simple-predicate-inferrer symbol? &symbol) -(define-simple-predicate-inferrer variable? &box) -(define-simple-predicate-inferrer vector? &vector) -(define-simple-predicate-inferrer struct? &struct) -(define-simple-predicate-inferrer string? &string) -(define-simple-predicate-inferrer bytevector? &bytevector) -(define-simple-predicate-inferrer bitvector? &bitvector) -(define-simple-predicate-inferrer keyword? &keyword) -(define-simple-predicate-inferrer number? &number) -(define-simple-predicate-inferrer char? &char) -(define-simple-predicate-inferrer procedure? &procedure) -(define-simple-predicate-inferrer thunk? &procedure) - - - -;;; -;;; Fluids. Note that we can't track bound-ness of fluids, as pop-fluid -;;; can change boundness. -;;; - -(define-simple-types - ((fluid-ref (&fluid 1)) &all-types) - ((fluid-set! (&fluid 0 1) &all-types)) - ((push-fluid (&fluid 0 1) &all-types)) - ((pop-fluid))) - - - - -;;; -;;; Prompts. (Nothing to do.) -;;; - - - - -;;; -;;; Pairs. -;;; - -(define-simple-types - ((cons &all-types &all-types) &pair) - ((car &pair) &all-types) - ((set-car! &pair &all-types)) - ((cdr &pair) &all-types) - ((set-cdr! &pair &all-types))) - - - - -;;; -;;; Variables. -;;; - -(define-simple-types - ((box &all-types) (&box 1)) - ((box-ref (&box 1)) &all-types)) - -(define-simple-type-checker (box-set! (&box 0 1) &all-types)) -(define-type-inferrer (box-set! box val) - (restrict! box &box 1 1)) - - - - -;;; -;;; Vectors. -;;; - -;; This max-vector-len computation is a hack. -(define *max-vector-len* (ash most-positive-fixnum -5)) - -(define-simple-type-checker (make-vector (&exact-integer 0 *max-vector-len*) - &all-types)) -(define-type-inferrer (make-vector size init result) - (restrict! size &exact-integer 0 *max-vector-len*) - (define! result &vector (max (&min size) 0) (&max size))) - -(define-type-checker (vector-ref v idx) - (and (check-type v &vector 0 *max-vector-len*) - (check-type idx &exact-integer 0 (1- (&min v))))) -(define-type-inferrer (vector-ref v idx result) - (restrict! v &vector (1+ (&min idx)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max v))) - (define! result &all-types -inf.0 +inf.0)) - -(define-type-checker (vector-set! v idx val) - (and (check-type v &vector 0 *max-vector-len*) - (check-type idx &exact-integer 0 (1- (&min v))))) -(define-type-inferrer (vector-set! v idx val) - (restrict! v &vector (1+ (&min idx)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max v)))) - -(define-type-aliases make-vector make-vector/immediate) -(define-type-aliases vector-ref vector-ref/immediate) -(define-type-aliases vector-set! vector-set!/immediate) - -(define-simple-type-checker (vector-length &vector)) -(define-type-inferrer (vector-length v result) - (restrict! v &vector 0 *max-vector-len*) - (define! result &exact-integer (max (&min v) 0) - (min (&max v) *max-vector-len*))) - - - - -;;; -;;; Structs. -;;; - -;; No type-checker for allocate-struct, as we can't currently check that -;; vt is actually a vtable. -(define-type-inferrer (allocate-struct vt size result) - (restrict! vt &struct vtable-offset-user +inf.0) - (restrict! size &exact-integer 0 +inf.0) - (define! result &struct (max (&min size) 0) (&max size))) - -(define-type-checker (struct-ref s idx) - (and (check-type s &struct 0 +inf.0) - (check-type idx &exact-integer 0 +inf.0) - ;; FIXME: is the field readable? - (< (&max idx) (&min s)))) -(define-type-inferrer (struct-ref s idx result) - (restrict! s &struct (1+ (&min idx)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max s))) - (define! result &all-types -inf.0 +inf.0)) - -(define-type-checker (struct-set! s idx val) - (and (check-type s &struct 0 +inf.0) - (check-type idx &exact-integer 0 +inf.0) - ;; FIXME: is the field writable? - (< (&max idx) (&min s)))) -(define-type-inferrer (struct-set! s idx val) - (restrict! s &struct (1+ (&min idx)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max s)))) - -(define-type-aliases allocate-struct allocate-struct/immediate) -(define-type-aliases struct-ref struct-ref/immediate) -(define-type-aliases struct-set! struct-set!/immediate) - -(define-simple-type (struct-vtable (&struct 0 +inf.0)) - (&struct vtable-offset-user +inf.0)) - - - - -;;; -;;; Strings. -;;; - -(define *max-char* (1- (ash 1 24))) - -(define-type-checker (string-ref s idx) - (and (check-type s &string 0 +inf.0) - (check-type idx &exact-integer 0 +inf.0) - (< (&max idx) (&min s)))) -(define-type-inferrer (string-ref s idx result) - (restrict! s &string (1+ (&min idx)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max s))) - (define! result &char 0 *max-char*)) - -(define-type-checker (string-set! s idx val) - (and (check-type s &string 0 +inf.0) - (check-type idx &exact-integer 0 +inf.0) - (check-type val &char 0 *max-char*) - (< (&max idx) (&min s)))) -(define-type-inferrer (string-set! s idx val) - (restrict! s &string (1+ (&min idx)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max s))) - (restrict! val &char 0 *max-char*)) - -(define-simple-type-checker (string-length &string)) -(define-type-inferrer (string-length s result) - (restrict! s &string 0 +inf.0) - (define! result &exact-integer (max (&min s) 0) (&max s))) - -(define-simple-type (number->string &number) (&string 0 +inf.0)) -(define-simple-type (string->number (&string 0 +inf.0)) - ((logior &number &false) -inf.0 +inf.0)) - - - - -;;; -;;; Bytevectors. -;;; - -(define-simple-type-checker (bytevector-length &bytevector)) -(define-type-inferrer (bytevector-length bv result) - (restrict! bv &bytevector 0 +inf.0) - (define! result &exact-integer (max (&min bv) 0) (&max bv))) - -(define-syntax-rule (define-bytevector-accessors ref set type size min max) - (begin - (define-type-checker (ref bv idx) - (and (check-type bv &bytevector 0 +inf.0) - (check-type idx &exact-integer 0 +inf.0) - (< (&max idx) (- (&min bv) size)))) - (define-type-inferrer (ref bv idx result) - (restrict! bv &bytevector (+ (&min idx) size) +inf.0) - (restrict! idx &exact-integer 0 (- (&max bv) size)) - (define! result type min max)) - (define-type-checker (set bv idx val) - (and (check-type bv &bytevector 0 +inf.0) - (check-type idx &exact-integer 0 +inf.0) - (check-type val type min max) - (< (&max idx) (- (&min bv) size)))) - (define-type-inferrer (set! bv idx val) - (restrict! bv &bytevector (+ (&min idx) size) +inf.0) - (restrict! idx &exact-integer 0 (- (&max bv) size)) - (restrict! val type min max)))) - -(define-syntax-rule (define-short-bytevector-accessors ref set size signed?) - (define-bytevector-accessors ref set &exact-integer size - (if signed? (- (ash 1 (1- (* size 8)))) 0) - (1- (ash 1 (if signed? (1- (* size 8)) (* size 8)))))) - -(define-short-bytevector-accessors bv-u8-ref bv-u8-set! 1 #f) -(define-short-bytevector-accessors bv-s8-ref bv-s8-set! 1 #t) -(define-short-bytevector-accessors bv-u16-ref bv-u16-set! 2 #f) -(define-short-bytevector-accessors bv-s16-ref bv-s16-set! 2 #t) - -;; The range analysis only works on signed 32-bit values, so some limits -;; are out of range. -(define-bytevector-accessors bv-u32-ref bv-u32-set! &exact-integer 4 0 +inf.0) -(define-bytevector-accessors bv-s32-ref bv-s32-set! &exact-integer 4 -inf.0 +inf.0) -(define-bytevector-accessors bv-u64-ref bv-u64-set! &exact-integer 8 0 +inf.0) -(define-bytevector-accessors bv-s64-ref bv-s64-set! &exact-integer 8 -inf.0 +inf.0) -(define-bytevector-accessors bv-f32-ref bv-f32-set! &real 4 -inf.0 +inf.0) -(define-bytevector-accessors bv-f64-ref bv-f64-set! &real 8 -inf.0 +inf.0) - - - - -;;; -;;; Numbers. -;;; - -;; First, branching primitives with no results. -(define-simple-type-checker (= &number &number)) -(define-predicate-inferrer (= a b true?) - (when (and true? - (zero? (logand (logior (&type a) (&type b)) (lognot &number)))) - (let ((min (max (&min a) (&min b))) - (max (min (&max a) (&max b)))) - (restrict! a &number min max) - (restrict! b &number min max)))) - -(define (restricted-comparison-ranges op type0 min0 max0 type1 min1 max1) - (define (infer-integer-ranges) - (match op - ('< (values min0 (min max0 (1- max1)) (max (1+ min0) min1) max1)) - ('<= (values min0 (min max0 max1) (max min0 min1) max1)) - ('>= (values (max min0 min1) max0 min1 (min max0 max1))) - ('> (values (max min0 (1+ min1)) max0 min1 (min (1- max0) max1))))) - (define (infer-real-ranges) - (match op - ((or '< '<=) (values min0 (min max0 max1) (max min0 min1) max1)) - ((or '> '>=) (values (max min0 min1) max0 min1 (min max0 max1))))) - (if (= (logior type0 type1) &exact-integer) - (infer-integer-ranges) - (infer-real-ranges))) - -(define-syntax-rule (define-comparison-inferrer (op inverse)) - (define-predicate-inferrer (op a b true?) - (when (zero? (logand (logior (&type a) (&type b)) (lognot &number))) - (call-with-values - (lambda () - (restricted-comparison-ranges (if true? 'op 'inverse) - (&type a) (&min a) (&max a) - (&type b) (&min b) (&max b))) - (lambda (min0 max0 min1 max1) - (restrict! a &real min0 max0) - (restrict! b &real min1 max1)))))) - -(define-simple-type-checker (< &real &real)) -(define-comparison-inferrer (< >=)) - -(define-simple-type-checker (<= &real &real)) -(define-comparison-inferrer (<= >)) - -(define-simple-type-checker (>= &real &real)) -(define-comparison-inferrer (>= <)) - -(define-simple-type-checker (> &real &real)) -(define-comparison-inferrer (> <=)) - -;; Arithmetic. -(define-syntax-rule (define-unary-result! a result min max) - (let ((min* min) - (max* max) - (type (logand (&type a) &number))) - (cond - ((not (= type (&type a))) - ;; Not a number. Punt and do nothing. - (define! result &all-types -inf.0 +inf.0)) - ;; Complex numbers don't have a range. - ((eqv? type &complex) - (define! result &complex -inf.0 +inf.0)) - (else - (define! result type min* max*))))) - -(define-syntax-rule (define-binary-result! a b result closed? min max) - (let ((min* min) - (max* max) - (a-type (logand (&type a) &number)) - (b-type (logand (&type b) &number))) - (cond - ((or (not (= a-type (&type a))) (not (= b-type (&type b)))) - ;; One input not a number. Perhaps we end up dispatching to - ;; GOOPS. - (define! result &all-types -inf.0 +inf.0)) - ;; Complex and floating-point numbers are contagious. - ((or (eqv? a-type &complex) (eqv? b-type &complex)) - (define! result &complex -inf.0 +inf.0)) - ((or (eqv? a-type &flonum) (eqv? b-type &flonum)) - (define! result &flonum min* max*)) - ;; Exact integers are closed under some operations. - ((and closed? (eqv? a-type &exact-integer) (eqv? b-type &exact-integer)) - (define! result &exact-integer min* max*)) - (else - ;; Fractions may become integers. - (let ((type (logior a-type b-type))) - (define! result - (if (zero? (logand type &fraction)) - type - (logior type &exact-integer)) - min* max*)))))) - -(define-simple-type-checker (add &number &number)) -(define-type-inferrer (add a b result) - (define-binary-result! a b result #t - (+ (&min a) (&min b)) - (+ (&max a) (&max b)))) - -(define-simple-type-checker (sub &number &number)) -(define-type-inferrer (sub a b result) - (define-binary-result! a b result #t - (- (&min a) (&max b)) - (- (&max a) (&min b)))) - -(define-simple-type-checker (mul &number &number)) -(define-type-inferrer (mul a b result) - (let ((min-a (&min a)) (max-a (&max a)) - (min-b (&min b)) (max-b (&max b))) - (define (nan* a b) - ;; We only really get +inf.0 at runtime for flonums and compnums. - ;; If we have inferred that the arguments are not flonums and not - ;; compnums, then the result of (* +inf.0 0) at range inference - ;; time is 0 and not +nan.0. - (if (and (or (and (inf? a) (zero? b)) - (and (zero? a) (inf? b))) - (not (logtest (logior (&type a) (&type b)) - (logior &flonum &complex)))) - 0 - (* a b))) - (let ((-- (nan* min-a min-b)) - (-+ (nan* min-a max-b)) - (++ (nan* max-a max-b)) - (+- (nan* max-a min-b))) - (let ((has-nan? (or (nan? --) (nan? -+) (nan? ++) (nan? +-)))) - (define-binary-result! a b result #t - (cond - ((eqv? a b) 0) - (has-nan? -inf.0) - (else (min -- -+ ++ +-))) - (if has-nan? - +inf.0 - (max -- -+ ++ +-))))))) - -(define-type-checker (div a b) - (and (check-type a &number -inf.0 +inf.0) - (check-type b &number -inf.0 +inf.0) - ;; We only know that there will not be an exception if b is not - ;; zero. - (not (<= (&min b) 0 (&max b))))) -(define-type-inferrer (div a b result) - (let ((min-a (&min a)) (max-a (&max a)) - (min-b (&min b)) (max-b (&max b))) - (call-with-values - (lambda () - (if (<= min-b 0 max-b) - ;; If the range of the divisor crosses 0, the result spans - ;; the whole range. - (values -inf.0 +inf.0) - ;; Otherwise min-b and max-b have the same sign, and cannot both - ;; be infinity. - (let ((--- (if (inf? min-b) 0 (floor/ min-a min-b))) - (-+- (if (inf? max-b) 0 (floor/ min-a max-b))) - (++- (if (inf? max-b) 0 (floor/ max-a max-b))) - (+-- (if (inf? min-b) 0 (floor/ max-a min-b))) - (--+ (if (inf? min-b) 0 (ceiling/ min-a min-b))) - (-++ (if (inf? max-b) 0 (ceiling/ min-a max-b))) - (+++ (if (inf? max-b) 0 (ceiling/ max-a max-b))) - (+-+ (if (inf? min-b) 0 (ceiling/ max-a min-b)))) - (values (min (min --- -+- ++- +--) - (min --+ -++ +++ +-+)) - (max (max --- -+- ++- +--) - (max --+ -++ +++ +-+)))))) - (lambda (min max) - (define-binary-result! a b result #f min max))))) - -(define-simple-type-checker (add1 &number)) -(define-type-inferrer (add1 a result) - (define-unary-result! a result (1+ (&min a)) (1+ (&max a)))) - -(define-simple-type-checker (sub1 &number)) -(define-type-inferrer (sub1 a result) - (define-unary-result! a result (1- (&min a)) (1- (&max a)))) - -(define-type-checker (quo a b) - (and (check-type a &exact-integer -inf.0 +inf.0) - (check-type b &exact-integer -inf.0 +inf.0) - ;; We only know that there will not be an exception if b is not - ;; zero. - (not (<= (&min b) 0 (&max b))))) -(define-type-inferrer (quo a b result) - (restrict! a &exact-integer -inf.0 +inf.0) - (restrict! b &exact-integer -inf.0 +inf.0) - (define! result &exact-integer -inf.0 +inf.0)) - -(define-type-checker-aliases quo rem) -(define-type-inferrer (rem a b result) - (restrict! a &exact-integer -inf.0 +inf.0) - (restrict! b &exact-integer -inf.0 +inf.0) - ;; Same sign as A. - (let ((max-abs-rem (1- (max (abs (&min b)) (abs (&max b)))))) - (cond - ((< (&min a) 0) - (if (< 0 (&max a)) - (define! result &exact-integer (- max-abs-rem) max-abs-rem) - (define! result &exact-integer (- max-abs-rem) 0))) - (else - (define! result &exact-integer 0 max-abs-rem))))) - -(define-type-checker-aliases quo mod) -(define-type-inferrer (mod a b result) - (restrict! a &exact-integer -inf.0 +inf.0) - (restrict! b &exact-integer -inf.0 +inf.0) - ;; Same sign as B. - (let ((max-abs-mod (1- (max (abs (&min b)) (abs (&max b)))))) - (cond - ((< (&min b) 0) - (if (< 0 (&max b)) - (define! result &exact-integer (- max-abs-mod) max-abs-mod) - (define! result &exact-integer (- max-abs-mod) 0))) - (else - (define! result &exact-integer 0 max-abs-mod))))) - -;; Predicates. -(define-syntax-rule (define-number-kind-predicate-inferrer name type) - (define-type-inferrer (name val result) - (cond - ((zero? (logand (&type val) type)) - (define! result &false 0 0)) - ((zero? (logand (&type val) (lognot type))) - (define! result &true 0 0)) - (else - (define! result (logior &true &false) 0 0))))) -(define-number-kind-predicate-inferrer complex? &number) -(define-number-kind-predicate-inferrer real? &real) -(define-number-kind-predicate-inferrer rational? - (logior &exact-integer &fraction)) -(define-number-kind-predicate-inferrer integer? - (logior &exact-integer &flonum)) -(define-number-kind-predicate-inferrer exact-integer? - &exact-integer) - -(define-simple-type-checker (exact? &number)) -(define-type-inferrer (exact? val result) - (restrict! val &number -inf.0 +inf.0) - (cond - ((zero? (logand (&type val) (logior &exact-integer &fraction))) - (define! result &false 0 0)) - ((zero? (logand (&type val) (lognot (logior &exact-integer &fraction)))) - (define! result &true 0 0)) - (else - (define! result (logior &true &false) 0 0)))) - -(define-simple-type-checker (inexact? &number)) -(define-type-inferrer (inexact? val result) - (restrict! val &number -inf.0 +inf.0) - (cond - ((zero? (logand (&type val) (logior &flonum &complex))) - (define! result &false 0 0)) - ((zero? (logand (&type val) (logand &number - (lognot (logior &flonum &complex))))) - (define! result &true 0 0)) - (else - (define! result (logior &true &false) 0 0)))) - -(define-simple-type-checker (inf? &real)) -(define-type-inferrer (inf? val result) - (restrict! val &real -inf.0 +inf.0) - (cond - ((or (zero? (logand (&type val) (logior &flonum &complex))) - (and (not (inf? (&min val))) (not (inf? (&max val))))) - (define! result &false 0 0)) - (else - (define! result (logior &true &false) 0 0)))) - -(define-type-aliases inf? nan?) - -(define-simple-type (even? &exact-integer) - ((logior &true &false) 0 0)) -(define-type-aliases even? odd?) - -;; Bit operations. -(define-simple-type-checker (ash &exact-integer &exact-integer)) -(define-type-inferrer (ash val count result) - (define (ash* val count) - ;; As we can only represent a 32-bit range, don't bother inferring - ;; shifts that might exceed that range. - (cond - ((inf? val) val) ; Preserves sign. - ((< -32 count 32) (ash val count)) - ((zero? val) 0) - ((positive? val) +inf.0) - (else -inf.0))) - (restrict! val &exact-integer -inf.0 +inf.0) - (restrict! count &exact-integer -inf.0 +inf.0) - (let ((-- (ash* (&min val) (&min count))) - (-+ (ash* (&min val) (&max count))) - (++ (ash* (&max val) (&max count))) - (+- (ash* (&max val) (&min count)))) - (define! result &exact-integer - (min -- -+ ++ +-) - (max -- -+ ++ +-)))) - -(define (next-power-of-two n) - (let lp ((out 1)) - (if (< n out) - out - (lp (ash out 1))))) - -(define-simple-type-checker (logand &exact-integer &exact-integer)) -(define-type-inferrer (logand a b result) - (define (logand-min a b) - (if (and (negative? a) (negative? b)) - (min a b) - 0)) - (define (logand-max a b) - (if (and (positive? a) (positive? b)) - (min a b) - 0)) - (restrict! a &exact-integer -inf.0 +inf.0) - (restrict! b &exact-integer -inf.0 +inf.0) - (define! result &exact-integer - (logand-min (&min a) (&min b)) - (logand-max (&max a) (&max b)))) - -(define-simple-type-checker (logior &exact-integer &exact-integer)) -(define-type-inferrer (logior a b result) - ;; Saturate all bits of val. - (define (saturate val) - (1- (next-power-of-two val))) - (define (logior-min a b) - (cond ((and (< a 0) (<= 0 b)) a) - ((and (< b 0) (<= 0 a)) b) - (else (max a b)))) - (define (logior-max a b) - ;; If either operand is negative, just assume the max is -1. - (cond - ((or (< a 0) (< b 0)) -1) - ((or (inf? a) (inf? b)) +inf.0) - (else (saturate (logior a b))))) - (restrict! a &exact-integer -inf.0 +inf.0) - (restrict! b &exact-integer -inf.0 +inf.0) - (define! result &exact-integer - (logior-min (&min a) (&min b)) - (logior-max (&max a) (&max b)))) - -;; For our purposes, treat logxor the same as logior. -(define-type-aliases logior logxor) - -(define-simple-type-checker (lognot &exact-integer)) -(define-type-inferrer (lognot a result) - (restrict! a &exact-integer -inf.0 +inf.0) - (define! result &exact-integer - (- -1 (&max a)) - (- -1 (&min a)))) - -(define-simple-type-checker (logtest &exact-integer &exact-integer)) -(define-predicate-inferrer (logtest a b true?) - (restrict! a &exact-integer -inf.0 +inf.0) - (restrict! b &exact-integer -inf.0 +inf.0)) - -(define-simple-type-checker (logbit? (&exact-integer 0 +inf.0) &exact-integer)) -(define-type-inferrer (logbit? a b result) - (let ((a-min (&min a)) - (a-max (&max a)) - (b-min (&min b)) - (b-max (&max b))) - (if (and (eqv? a-min a-max) (>= a-min 0) (not (inf? a-min)) - (eqv? b-min b-max) (>= b-min 0) (not (inf? b-min))) - (let ((type (if (logbit? a-min b-min) &true &false))) - (define! result type 0 0)) - (define! result (logior &true &false) 0 0)))) - -;; Flonums. -(define-simple-type-checker (sqrt &number)) -(define-type-inferrer (sqrt x result) - (let ((type (&type x))) - (cond - ((and (zero? (logand type &complex)) (<= 0 (&min x))) - (define! result - (logior type &flonum) - (inexact->exact (floor (sqrt (&min x)))) - (if (inf? (&max x)) - +inf.0 - (inexact->exact (ceiling (sqrt (&max x))))))) - (else - (define! result (logior type &flonum &complex) -inf.0 +inf.0))))) - -(define-simple-type-checker (abs &real)) -(define-type-inferrer (abs x result) - (let ((type (&type x))) - (cond - ((eqv? type (logand type &number)) - (restrict! x &real -inf.0 +inf.0) - (define! result (logand type &real) - (min (abs (&min x)) (abs (&max x))) - (max (abs (&min x)) (abs (&max x))))) - (else - (define! result (logior (logand (&type x) (lognot &number)) - (logand (&type x) &real)) - (max (&min x) 0) - (max (abs (&min x)) (abs (&max x)))))))) - - - - -;;; -;;; Characters. -;;; - -(define-simple-type (char=? char>?) - -(define-simple-type-checker (integer->char (&exact-integer 0 #x10ffff))) -(define-type-inferrer (integer->char i result) - (restrict! i &exact-integer 0 #x10ffff) - (define! result &char (max (&min i) 0) (min (&max i) #x10ffff))) - -(define-simple-type-checker (char->integer &char)) -(define-type-inferrer (char->integer c result) - (restrict! c &char 0 #x10ffff) - (define! result &exact-integer (max (&min c) 0) (min (&max c) #x10ffff))) - - - - -;;; -;;; Type flow analysis: the meet (ahem) of the algorithm. -;;; - -(define (infer-types* dfg min-label label-count) - "Compute types for all variables in @var{fun}. Returns a hash table -mapping symbols to types." - (let ((typev (make-vector label-count)) - (idoms (compute-idoms dfg min-label label-count)) - (revisit-label #f) - (types-changed? #f) - (saturate-ranges? #f)) - (define (label->idx label) (- label min-label)) - - (define (get-entry label) (vector-ref typev (label->idx label))) - - (define (in-types entry) (vector-ref entry 0)) - (define (out-types entry succ) (vector-ref entry (1+ succ))) - - (define (update-in-types! entry types) - (vector-set! entry 0 types)) - (define (update-out-types! entry succ types) - (vector-set! entry (1+ succ) types)) - - (define (prepare-initial-state!) - ;; The result is a vector with an entry for each label. Each entry - ;; is a vector. The first slot in the entry vector corresponds to - ;; the types that flow into the labelled expression. The following - ;; slot is for the types that flow out to the first successor, and - ;; so on for additional successors. - (let lp ((label min-label)) - (when (< label (+ min-label label-count)) - (let* ((nsuccs (match (lookup-cont label dfg) - (($ $kargs _ _ term) - (match (find-call term) - (($ $continue k src (or ($ $branch) ($ $prompt))) 2) - (_ 1))) - (($ $kfun src meta self tail clause) (if clause 1 0)) - (($ $kclause arity body alt) (if alt 2 1)) - (($ $kreceive) 1) - (($ $ktail) 0))) - (entry (make-vector (1+ nsuccs) #f))) - (vector-set! typev (label->idx label) entry) - (lp (1+ label))))) - - ;; Initial state: nothing flows into the $kfun. - (let ((entry (get-entry min-label))) - (update-in-types! entry empty-intmap))) - - (define (adjoin-vars types vars entry) - (match vars - (() types) - ((var . vars) - (adjoin-vars (adjoin-var types var entry) vars entry)))) - - (define (infer-primcall types succ name args result) - (cond - ((hashq-ref *type-inferrers* name) - => (lambda (inferrer) - ;; FIXME: remove the apply? - ;(pk 'primcall name args result) - (apply inferrer types succ - (if result - (append args (list result)) - args)))) - (result - (adjoin-var types result all-types-entry)) - (else - types))) - - (define (type-entry-saturating-union a b) - (cond - ((type-entry<=? b a) a) - #; - ((and (not saturate-ranges?) - (eqv? (a-type )) - (type-entry<=? a b)) b) - (else (make-type-entry - (let* ((a-type (type-entry-type a)) - (b-type (type-entry-type b)) - (type (logior a-type b-type))) - (unless (eqv? a-type type) - (set! types-changed? #t)) - type) - (let ((a-min (type-entry-clamped-min a)) - (b-min (type-entry-clamped-min b))) - (if (< b-min a-min) - (if saturate-ranges? min-fixnum b-min) - a-min)) - (let ((a-max (type-entry-clamped-max a)) - (b-max (type-entry-clamped-max b))) - (if (> b-max a-max) - (if saturate-ranges? max-fixnum b-max) - a-max)))))) - - (define (propagate-types! pred-label pred-entry succ-idx succ-label out) - ;; Update "in" set of continuation. - (let ((succ-entry (get-entry succ-label))) - (match (lookup-predecessors succ-label dfg) - ((_) - ;; A normal edge. - (update-in-types! succ-entry out)) - (_ - ;; A control-flow join. - (let* ((succ-dom-label (vector-ref idoms (label->idx succ-label))) - (succ-dom-entry (get-entry succ-dom-label)) - (old-in (in-types succ-entry)) - (in (if old-in - (intmap-intersect old-in out - type-entry-saturating-union) - out))) - ;; If the "in" set changed, update the entry and possibly - ;; arrange to iterate again. - (unless (eq? old-in in) - (update-in-types! succ-entry in) - ;; If the changed successor is a back-edge, ensure that - ;; we revisit the function. - (when (<= succ-label pred-label) - (unless (and revisit-label (<= revisit-label succ-label)) - ;; (pk 'marking-revisit pred-label succ-label) - (set! revisit-label succ-label)))))))) - ;; Finally update "out" set for current expression. - (update-out-types! pred-entry succ-idx out)) - - (define (visit-exp label entry k types exp) - (define (propagate! succ-idx succ-label types) - (propagate-types! label entry succ-idx succ-label types)) - ;; Each of these branches must propagate! to its successors. - (match exp - (($ $branch kt ($ $values (arg))) - ;; The "normal" continuation is the #f branch. - (let ((types (restrict-var types arg - (make-type-entry (logior &false &nil) - 0 - 0)))) - (propagate! 0 k types)) - (let ((types (restrict-var types arg - (make-type-entry - (logand &all-types - (lognot (logior &false &nil))) - -inf.0 +inf.0)))) - (propagate! 1 kt types))) - (($ $branch kt ($ $primcall name args)) - ;; The "normal" continuation is the #f branch. - (let ((types (infer-primcall types 0 name args #f))) - (propagate! 0 k types)) - (let ((types (infer-primcall types 1 name args #f))) - (propagate! 1 kt types))) - (($ $prompt escape? tag handler) - ;; The "normal" continuation enters the prompt. - (propagate! 0 k types) - (propagate! 1 handler types)) - (($ $primcall name args) - (propagate! 0 k - (match (lookup-cont k dfg) - (($ $kargs _ defs) - (infer-primcall types 0 name args - (match defs ((var) var) (() #f)))) - (_ - ;(pk 'warning-no-restrictions name) - types)))) - (($ $values args) - (match (lookup-cont k dfg) - (($ $kargs _ defs) - (let ((in types)) - (let lp ((defs defs) (args args) (out types)) - (match (cons defs args) - ((() . ()) - (propagate! 0 k out)) - (((def . defs) . (arg . args)) - (lp defs args - (adjoin-var out def (var-type-entry in arg)))))))) - (_ - (propagate! 0 k types)))) - ((or ($ $call) ($ $callk)) - (propagate! 0 k types)) - (($ $rec names vars funs) - (let ((proc-type (make-type-entry &procedure -inf.0 +inf.0))) - (propagate! 0 k (adjoin-vars types vars proc-type)))) - (_ - (match (lookup-cont k dfg) - (($ $kargs (_) (var)) - (let ((entry (match exp - (($ $const val) - (constant-type val)) - ((or ($ $prim) ($ $fun) ($ $closure)) - ;; Could be more precise here. - (make-type-entry &procedure -inf.0 +inf.0))))) - (propagate! 0 k (adjoin-var types var entry)))))))) - - (prepare-initial-state!) - - ;; Iterate over all labelled expressions in the function, - ;; propagating types and ranges to all successors. - (let lp ((label min-label)) - ;(pk 'visit label) - (cond - ((< label (+ min-label label-count)) - (let* ((entry (vector-ref typev (label->idx label))) - (types (in-types entry))) - (define (propagate! succ-idx succ-label types) - (propagate-types! label entry succ-idx succ-label types)) - ;; Add types for new definitions, and restrict types of - ;; existing variables due to side effects. - (match (lookup-cont label dfg) - (($ $kargs names vars term) - (let visit-term ((term term) (types types)) - (match term - (($ $letk conts term) - (visit-term term types)) - (($ $continue k src exp) - (visit-exp label entry k types exp))))) - (($ $kreceive arity k) - (match (lookup-cont k dfg) - (($ $kargs names vars) - (propagate! 0 k - (adjoin-vars types vars all-types-entry))))) - (($ $kfun src meta self tail clause) - (let ((types (adjoin-var types self all-types-entry))) - (match clause - (#f #f) - (($ $cont kclause) - (propagate! 0 kclause types))))) - (($ $kclause arity ($ $cont kbody ($ $kargs names vars)) alt) - (propagate! 0 kbody - (adjoin-vars types vars all-types-entry)) - (match alt - (#f #f) - (($ $cont kclause) - (propagate! 1 kclause types)))) - (($ $ktail) #t))) - - ;; And loop. - (lp (1+ label))) - - ;; Iterate until we reach a fixed point. - (revisit-label - ;; Once the types have a fixed point, iterate until ranges also - ;; reach a fixed point, saturating ranges to accelerate - ;; convergence. - (unless types-changed? - (set! saturate-ranges? #t)) - (set! types-changed? #f) - (let ((label revisit-label)) - (set! revisit-label #f) - ;(pk 'looping) - (lp label))) - - ;; All done! Return the computed types. - (else typev))))) - -(define-record-type - (make-type-analysis min-label label-count types) - type-analysis? - (min-label type-analysis-min-label) - (label-count type-analysis-label-count) - (types type-analysis-types)) - -(define (infer-types fun dfg) - ;; Fun must be renumbered. - (match fun - (($ $cont min-label ($ $kfun)) - (let ((label-count ((make-local-cont-folder label-count) - (lambda (k cont label-count) (1+ label-count)) - fun 0))) - (make-type-analysis min-label label-count - (infer-types* dfg min-label label-count)))))) - -(define (lookup-pre-type analysis label def) - (match analysis - (($ min-label label-count typev) - (let* ((entry (vector-ref typev (- label min-label))) - (tentry (var-type-entry (vector-ref entry 0) def))) - (values (type-entry-type tentry) - (type-entry-min tentry) - (type-entry-max tentry)))))) - -(define (lookup-post-type analysis label def succ-idx) - (match analysis - (($ min-label label-count typev) - (let* ((entry (vector-ref typev (- label min-label))) - (tentry (var-type-entry (vector-ref entry (1+ succ-idx)) def))) - (values (type-entry-type tentry) - (type-entry-min tentry) - (type-entry-max tentry)))))) - -(define (primcall-types-check? analysis label name args) - (match (hashq-ref *type-checkers* name) - (#f #f) - (checker - (match analysis - (($ min-label label-count typev) - (let ((entry (vector-ref typev (- label min-label)))) - (apply checker (vector-ref entry 0) args))))))) From 90aabcc56556c09a65e4257630b10589aab2d3dd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 16 Jul 2015 09:58:59 +0200 Subject: [PATCH 019/865] Fix type/range inference for mul * module/language/cps2/types.scm (mul): Fix nan testing. --- module/language/cps2/types.scm | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/module/language/cps2/types.scm b/module/language/cps2/types.scm index 6fca57d73..07da3d6a0 100644 --- a/module/language/cps2/types.scm +++ b/module/language/cps2/types.scm @@ -833,16 +833,17 @@ minimum, and maximum." (define-simple-type-checker (mul &number &number)) (define-type-inferrer (mul a b result) (let ((min-a (&min a)) (max-a (&max a)) - (min-b (&min b)) (max-b (&max b))) + (min-b (&min b)) (max-b (&max b)) + ;; We only really get +inf.0 at runtime for flonums and + ;; compnums. If we have inferred that the arguments are not + ;; flonums and not compnums, then the result of (* +inf.0 0) at + ;; range inference time is 0 and not +nan.0. + (nan-impossible? (not (logtest (logior (&type a) (&type b)) + (logior &flonum &complex))))) (define (nan* a b) - ;; We only really get +inf.0 at runtime for flonums and compnums. - ;; If we have inferred that the arguments are not flonums and not - ;; compnums, then the result of (* +inf.0 0) at range inference - ;; time is 0 and not +nan.0. (if (and (or (and (inf? a) (zero? b)) (and (zero? a) (inf? b))) - (not (logtest (logior (&type a) (&type b)) - (logior &flonum &complex)))) + nan-impossible?) 0 (* a b))) (let ((-- (nan* min-a min-b)) From 1a819eaaa73b6d3099661d6518f035bd36c79899 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 16 Jul 2015 11:27:14 +0200 Subject: [PATCH 020/865] Reify primitives in CPS2 * module/language/cps/reify-primitives.scm: Remove. * module/language/cps2/reify-primitives.scm: New file. * module/Makefile.am: Adapt build. * module/language/cps/compile-bytecode.scm: * module/language/cps2/compile-cps.scm: Reify primitives in CPS2 instead of CPS. --- module/Makefile.am | 2 +- module/language/cps/compile-bytecode.scm | 3 +- module/language/cps/reify-primitives.scm | 178 ---------------------- module/language/cps2/compile-cps.scm | 2 + module/language/cps2/reify-primitives.scm | 145 ++++++++++++++++++ 5 files changed, 149 insertions(+), 181 deletions(-) delete mode 100644 module/language/cps/reify-primitives.scm create mode 100644 module/language/cps2/reify-primitives.scm diff --git a/module/Makefile.am b/module/Makefile.am index 188cc7626..c1c3e5cf0 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -126,7 +126,6 @@ CPS_LANG_SOURCES = \ language/cps/compile-bytecode.scm \ language/cps/dfg.scm \ language/cps/primitives.scm \ - language/cps/reify-primitives.scm \ language/cps/renumber.scm \ language/cps/slot-allocation.scm \ language/cps/spec.scm \ @@ -144,6 +143,7 @@ CPS2_LANG_SOURCES = \ language/cps2/elide-values.scm \ language/cps2/prune-bailouts.scm \ language/cps2/prune-top-level-scopes.scm \ + language/cps2/reify-primitives.scm \ language/cps2/renumber.scm \ language/cps2/optimize.scm \ language/cps2/simplify.scm \ diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index c07db2621..c92c15d01 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -29,7 +29,6 @@ #:use-module (language cps) #:use-module (language cps dfg) #:use-module (language cps primitives) - #:use-module (language cps reify-primitives) #:use-module (language cps renumber) #:use-module (language cps slot-allocation) #:use-module (system vm assembler) @@ -443,7 +442,7 @@ (compile-entry))))) (define (compile-bytecode exp env opts) - (let* ((exp (renumber (reify-primitives exp))) + (let* ((exp (renumber exp)) (asm (make-assembler))) (match exp (($ $program funs) diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm deleted file mode 100644 index 286fd7c41..000000000 --- a/module/language/cps/reify-primitives.scm +++ /dev/null @@ -1,178 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; A pass to reify lone $prim's that were never folded into a -;;; $primcall, and $primcall's to primitives that don't have a -;;; corresponding VM op. -;;; -;;; Code: - -(define-module (language cps reify-primitives) - #:use-module (ice-9 match) - #:use-module (language cps) - #:use-module (language cps dfg) - #:use-module (language cps primitives) - #:use-module (language bytecode) - #:export (reify-primitives)) - -(define (module-box src module name public? bound? val-proc) - (let-fresh (kbox) (module-var name-var public?-var bound?-var box) - (build-cps-term - ($letconst (('module module-var module) - ('name name-var name) - ('public? public?-var public?) - ('bound? bound?-var bound?)) - ($letk ((kbox ($kargs ('box) (box) ,(val-proc box)))) - ($continue kbox src - ($primcall 'cached-module-box - (module-var name-var public?-var bound?-var)))))))) - -(define (primitive-module name) - (case name - ((bytevector? - bytevector-length - - bytevector-u8-ref bytevector-u8-set! - bytevector-s8-ref bytevector-s8-set! - - bytevector-u16-ref bytevector-u16-set! - bytevector-u16-native-ref bytevector-u16-native-set! - bytevector-s16-ref bytevector-s16-set! - bytevector-s16-native-ref bytevector-s16-native-set! - - bytevector-u32-ref bytevector-u32-set! - bytevector-u32-native-ref bytevector-u32-native-set! - bytevector-s32-ref bytevector-s32-set! - bytevector-s32-native-ref bytevector-s32-native-set! - - bytevector-u64-ref bytevector-u64-set! - bytevector-u64-native-ref bytevector-u64-native-set! - bytevector-s64-ref bytevector-s64-set! - bytevector-s64-native-ref bytevector-s64-native-set! - - bytevector-ieee-single-ref bytevector-ieee-single-set! - bytevector-ieee-single-native-ref bytevector-ieee-single-native-set! - bytevector-ieee-double-ref bytevector-ieee-double-set! - bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!) - '(rnrs bytevectors)) - ((class-of) '(oop goops)) - (else '(guile)))) - -(define (primitive-ref name k src) - (module-box #f (primitive-module name) name #f #t - (lambda (box) - (build-cps-term - ($continue k src ($primcall 'box-ref (box))))))) - -(define (builtin-ref idx k src) - (let-fresh () (idx-var) - (build-cps-term - ($letconst (('idx idx-var idx)) - ($continue k src - ($primcall 'builtin-ref (idx-var))))))) - -(define (reify-clause ktail) - (let-fresh (kclause kbody kthrow) (wna false str eol throw) - (build-cps-cont - (kclause ($kclause ('() '() #f '() #f) - (kbody - ($kargs () () - ($letconst (('wna wna 'wrong-number-of-args) - ('false false #f) - ('str str "Wrong number of arguments") - ('eol eol '())) - ($letk ((kthrow - ($kargs ('throw) (throw) - ($continue ktail #f - ($call throw - (wna false str eol false)))))) - ,(primitive-ref 'throw kthrow #f))))) - ,#f))))) - -(define (reify-primitives/1 fun single-value-conts) - (define (visit-clause cont) - (rewrite-cps-cont cont - (($ $cont label ($ $kclause arity body alternate)) - (label ($kclause ,arity ,(visit-cont body) - ,(and alternate (visit-clause alternate))))))) - (define (visit-cont cont) - (rewrite-cps-cont cont - (($ $cont label ($ $kargs (name) (var) body)) - ,(begin - (bitvector-set! single-value-conts label #t) - (build-cps-cont - (label ($kargs (name) (var) ,(visit-term body)))))) - (($ $cont label ($ $kargs names vars body)) - (label ($kargs names vars ,(visit-term body)))) - (($ $cont) - ,cont))) - (define (visit-term term) - (match term - (($ $letk conts body) - ;; Visit continuations before their uses. - (let ((conts (map visit-cont conts))) - (build-cps-term - ($letk ,conts ,(visit-term body))))) - (($ $continue k src exp) - (match exp - (($ $prim name) - (if (bitvector-ref single-value-conts k) - (cond - ((builtin-name->index name) - => (lambda (idx) - (builtin-ref idx k src))) - (else (primitive-ref name k src))) - (build-cps-term ($continue k src - ($const *unspecified*))))) - (($ $primcall 'call-thunk/no-inline (proc)) - (build-cps-term - ($continue k src ($call proc ())))) - (($ $primcall name args) - (cond - ((or (prim-instruction name) (branching-primitive? name)) - ;; Assume arities are correct. - term) - (else - (let-fresh (k*) (v) - (build-cps-term - ($letk ((k* ($kargs (v) (v) - ($continue k src ($call v args))))) - ,(cond - ((builtin-name->index name) - => (lambda (idx) - (builtin-ref idx k* src))) - (else (primitive-ref name k* src))))))))) - (_ term))))) - - (rewrite-cps-cont fun - (($ $cont label ($ $kfun src meta self (and tail ($ $cont ktail)) #f)) - ;; A case-lambda with no clauses. Reify a clause. - (label ($kfun src meta self ,tail ,(reify-clause ktail)))) - (($ $cont label ($ $kfun src meta self tail clause)) - (label ($kfun src meta self ,tail ,(visit-clause clause)))))) - -(define (reify-primitives term) - (with-fresh-name-state term - (let ((single-value-conts (make-bitvector (label-counter) #f))) - (rewrite-cps-term term - (($ $program procs) - ($program ,(map (lambda (cont) - (reify-primitives/1 cont single-value-conts)) - procs))))))) diff --git a/module/language/cps2/compile-cps.scm b/module/language/cps2/compile-cps.scm index 85b00c95c..ee6e3d5bb 100644 --- a/module/language/cps2/compile-cps.scm +++ b/module/language/cps2/compile-cps.scm @@ -29,6 +29,7 @@ #:use-module (language cps2 utils) #:use-module (language cps2 closure-conversion) #:use-module (language cps2 optimize) + #:use-module (language cps2 reify-primitives) #:use-module (language cps2 renumber) #:use-module (language cps intmap) #:export (compile-cps)) @@ -123,5 +124,6 @@ (set! exp (optimize-higher-order-cps exp opts)) (set! exp (convert-closures exp)) (set! exp (optimize-first-order-cps exp opts)) + (set! exp (reify-primitives exp)) (set! exp (renumber exp)) (values (conts->fun* exp) env env)) diff --git a/module/language/cps2/reify-primitives.scm b/module/language/cps2/reify-primitives.scm new file mode 100644 index 000000000..b5f62d456 --- /dev/null +++ b/module/language/cps2/reify-primitives.scm @@ -0,0 +1,145 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; A pass to reify lone $prim's that were never folded into a +;;; $primcall, and $primcall's to primitives that don't have a +;;; corresponding VM op. +;;; +;;; Code: + +(define-module (language cps2 reify-primitives) + #:use-module (ice-9 match) + #:use-module (language cps2) + #:use-module (language cps2 utils) + #:use-module (language cps2 with-cps) + #:use-module (language cps primitives) + #:use-module (language cps intmap) + #:use-module (language bytecode) + #:export (reify-primitives)) + +(define (module-box cps src module name public? bound? val-proc) + (with-cps cps + (letv box) + (let$ body (val-proc box)) + (letk kbox ($kargs ('box) (box) ,body)) + ($ (with-cps-constants ((module module) + (name name) + (public? public?) + (bound? bound?)) + (build-term ($continue kbox src + ($primcall 'cached-module-box + (module name public? bound?)))))))) + +(define (primitive-module name) + (case name + ((bytevector? + bytevector-length + + bytevector-u8-ref bytevector-u8-set! + bytevector-s8-ref bytevector-s8-set! + + bytevector-u16-ref bytevector-u16-set! + bytevector-u16-native-ref bytevector-u16-native-set! + bytevector-s16-ref bytevector-s16-set! + bytevector-s16-native-ref bytevector-s16-native-set! + + bytevector-u32-ref bytevector-u32-set! + bytevector-u32-native-ref bytevector-u32-native-set! + bytevector-s32-ref bytevector-s32-set! + bytevector-s32-native-ref bytevector-s32-native-set! + + bytevector-u64-ref bytevector-u64-set! + bytevector-u64-native-ref bytevector-u64-native-set! + bytevector-s64-ref bytevector-s64-set! + bytevector-s64-native-ref bytevector-s64-native-set! + + bytevector-ieee-single-ref bytevector-ieee-single-set! + bytevector-ieee-single-native-ref bytevector-ieee-single-native-set! + bytevector-ieee-double-ref bytevector-ieee-double-set! + bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!) + '(rnrs bytevectors)) + ((class-of) '(oop goops)) + (else '(guile)))) + +(define (primitive-ref cps name k src) + (module-box cps src (primitive-module name) name #f #t + (lambda (cps box) + (with-cps cps + (build-term + ($continue k src ($primcall 'box-ref (box)))))))) + +(define (builtin-ref cps idx k src) + (with-cps cps + ($ (with-cps-constants ((idx idx)) + (build-term + ($continue k src ($primcall 'builtin-ref (idx)))))))) + +(define (reify-clause cps ktail) + (with-cps cps + (letv throw) + (let$ throw-body + (with-cps-constants ((wna 'wrong-number-of-args) + (false #f) + (str "Wrong number of arguments") + (eol '())) + (build-term + ($continue ktail #f + ($call throw (wna false str eol false)))))) + (letk kthrow ($kargs ('throw) (throw) ,throw-body)) + (let$ body (primitive-ref 'throw kthrow #f)) + (letk kbody ($kargs () () ,body)) + (letk kclause ($kclause ('() '() #f '() #f) kbody #f)) + kclause)) + +(define (reify-primitives cps) + (define (visit-cont label cont cps) + (define (resolve-prim cps name k src) + (cond + ((builtin-name->index name) + => (lambda (idx) (builtin-ref cps idx k src))) + (else + (primitive-ref cps name k src)))) + (match cont + (($ $kfun src meta self tail #f) + (with-cps cps + (let$ clause (reify-clause tail)) + (setk label ($kfun src meta self tail clause)))) + (($ $kargs names vars ($ $continue k src ($ $prim name))) + (with-cps cps + (let$ body (resolve-prim name k src)) + (setk label ($kargs names vars ,body)))) + (($ $kargs names vars + ($ $continue k src ($ $primcall 'call-thunk/no-inline (proc)))) + (with-cps cps + (setk label ($kargs names vars ($continue k src ($call proc ())))))) + (($ $kargs names vars ($ $continue k src ($ $primcall name args))) + (if (or (prim-instruction name) (branching-primitive? name)) + ;; Assume arities are correct. + cps + (with-cps cps + (letv proc) + (letk kproc ($kargs ('proc) (proc) + ($continue k src ($call proc args)))) + (let$ body (resolve-prim name kproc src)) + (setk label ($kargs names vars ,body))))) + (_ cps))) + + (with-fresh-name-state cps + (persistent-intmap (intmap-fold visit-cont cps cps)))) From 3b1d316383a76a2933347ed07a3bd9ac3398ee6b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 19 Jul 2015 12:20:01 +0200 Subject: [PATCH 021/865] Add intset-prev and intset-fold-right * module/language/cps/intset.scm (intset-prev): New function. (make-intset-folder): Add forward? argument like make-intmap-folder. (intset-fold-right): New function. --- module/language/cps/intset.scm | 66 +++++++++++++++++++++++++++------- 1 file changed, 54 insertions(+), 12 deletions(-) diff --git a/module/language/cps/intset.scm b/module/language/cps/intset.scm index 7a16464f2..8c7a23bf3 100644 --- a/module/language/cps/intset.scm +++ b/module/language/cps/intset.scm @@ -40,7 +40,9 @@ intset-remove intset-ref intset-next + intset-prev intset-fold + intset-fold-right intset-union intset-intersect intset-subtract @@ -391,31 +393,62 @@ (assert-readable! edit) (next min shift root)))) -(define-syntax-rule (make-intset-folder seed ...) +(define* (intset-prev bs #:optional i) + (define (visit-leaf node i) + (let lp ((idx (logand i *leaf-mask*))) + (if (logbit? idx node) + (logior (logand i (lognot *leaf-mask*)) idx) + (let ((idx (1- idx))) + (and (<= 0 idx) (lp idx)))))) + (define (visit-branch node shift i) + (let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*))) + (and (<= 0 idx) + (or (let ((node (vector-ref node idx))) + (and node (visit-node node shift i))) + (lp (1- (round-down i shift)) (1- idx)))))) + (define (visit-node node shift i) + (if (= shift *leaf-bits*) + (visit-leaf node i) + (visit-branch node (- shift *branch-bits*) i))) + (define (prev min shift root) + (let ((i (if (and i (<= i (+ min (ash 1 shift)))) + (- i min) + (1- (ash 1 shift))))) + (and root (<= 0 i) + (let ((i (visit-node root shift i))) + (and i (+ min i)))))) + (match bs + (($ min shift root) + (prev min shift root)) + (($ min shift root edit) + (assert-readable! edit) + (prev min shift root)))) + +(define-syntax-rule (make-intset-folder forward? seed ...) (lambda (f set seed ...) (define (visit-branch node shift min seed ...) (cond ((= shift *leaf-bits*) - (let lp ((i 0) (seed seed) ...) - (if (< i *leaf-size*) + (let lp ((i (if forward? 0 (1- *leaf-size*))) (seed seed) ...) + (if (if forward? (< i *leaf-size*) (<= 0 i)) (if (logbit? i node) (call-with-values (lambda () (f (+ i min) seed ...)) (lambda (seed ...) - (lp (1+ i) seed ...))) - (lp (1+ i) seed ...)) + (lp (if forward? (1+ i) (1- i)) seed ...))) + (lp (if forward? (1+ i) (1- i)) seed ...)) (values seed ...)))) (else (let ((shift (- shift *branch-bits*))) - (let lp ((i 0) (seed seed) ...) - (if (< i *branch-size*) + (let lp ((i (if forward? 0 (1- *branch-size*))) (seed seed) ...) + (if (if forward? (< i *branch-size*) (<= 0 i)) (let ((elt (vector-ref node i))) (if elt (call-with-values (lambda () (visit-branch elt shift (+ min (ash i shift)) seed ...)) (lambda (seed ...) - (lp (1+ i) seed ...))) - (lp (1+ i) seed ...))) + (lp (if forward? (1+ i) (1- i)) seed ...))) + (lp (if forward? (1+ i) (1- i)) seed ...))) (values seed ...))))))) (match set (($ min shift root) @@ -428,11 +461,20 @@ (define intset-fold (case-lambda ((f set seed) - ((make-intset-folder seed) f set seed)) + ((make-intset-folder #t seed) f set seed)) ((f set s0 s1) - ((make-intset-folder s0 s1) f set s0 s1)) + ((make-intset-folder #t s0 s1) f set s0 s1)) ((f set s0 s1 s2) - ((make-intset-folder s0 s1 s2) f set s0 s1 s2)))) + ((make-intset-folder #t s0 s1 s2) f set s0 s1 s2)))) + +(define intset-fold-right + (case-lambda + ((f set seed) + ((make-intset-folder #f seed) f set seed)) + ((f set s0 s1) + ((make-intset-folder #f s0 s1) f set s0 s1)) + ((f set s0 s1 s2) + ((make-intset-folder #f s0 s1 s2) f set s0 s1 s2)))) (define (intset-size shift root) (cond From 19024bdc2715949bf65a270118fafe2057a84193 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 19 Jul 2015 12:21:31 +0200 Subject: [PATCH 022/865] Utils refactors * module/language/cps2/utils.scm (compute-successors): kfun is optional. (compute-sorted-strongly-connected-components): New function, moved from split-rec.scm. Doesn't assume that 0 is a free node identifier. * module/language/cps2/split-rec.scm (compute-sorted-strongly-connected-components): Remove, use utils.scm version instead. * module/language/cps2/closure-conversion.scm (intset-select): Remove unused function. --- module/language/cps2/closure-conversion.scm | 10 ---- module/language/cps2/split-rec.scm | 45 ----------------- module/language/cps2/utils.scm | 55 ++++++++++++++++++++- 3 files changed, 54 insertions(+), 56 deletions(-) diff --git a/module/language/cps2/closure-conversion.scm b/module/language/cps2/closure-conversion.scm index 9e3a099ce..7de34482f 100644 --- a/module/language/cps2/closure-conversion.scm +++ b/module/language/cps2/closure-conversion.scm @@ -443,16 +443,6 @@ variable, until we reach a fixed point on the free-vars map." ((= start i) idx) (else (lp (1+ idx) (1+ start))))))) -(define (intmap-select map set) - (persistent-intmap - (intmap-fold - (lambda (k v out) - (if (intset-ref set k) - (intmap-add! out k v) - out)) - map - empty-intmap))) - (define (intset-count set) (intset-fold (lambda (_ count) (1+ count)) set 0)) diff --git a/module/language/cps2/split-rec.scm b/module/language/cps2/split-rec.scm index 20cb516a2..aeb1c6397 100644 --- a/module/language/cps2/split-rec.scm +++ b/module/language/cps2/split-rec.scm @@ -105,51 +105,6 @@ references." (persistent-intset defs))))))) (visit-fun kfun)) -(define (compute-sorted-strongly-connected-components edges) - (define nodes - (intmap-keys edges)) - ;; Add a "start" node that links to all nodes in the graph, and then - ;; remove it from the result. - (define components - (intmap-remove - (compute-strongly-connected-components (intmap-add edges 0 nodes) 0) - 0)) - (define node-components - (intmap-fold (lambda (id nodes out) - (intset-fold (lambda (node out) (intmap-add out node id)) - nodes out)) - components - empty-intmap)) - (define (node-component node) - (intmap-ref node-components node)) - (define (component-successors id nodes) - (intset-remove - (intset-fold (lambda (node out) - (intset-fold - (lambda (successor out) - (intset-add out (node-component successor))) - (intmap-ref edges node) - out)) - nodes - empty-intset) - id)) - (define component-edges - (intmap-map component-successors components)) - (define preds - (invert-graph component-edges)) - (define roots - (intmap-fold (lambda (id succs out) - (if (eq? empty-intset succs) - (intset-add out id) - out)) - component-edges - empty-intset)) - ;; As above, add a "start" node that links to the roots, and remove it - ;; from the result. - (match (compute-reverse-post-order (intmap-add preds 0 roots) 0) - ((0 . ids) - (map (lambda (id) (intmap-ref components id)) ids)))) - (define (compute-split fns free-vars) (define (get-free kfun) ;; It's possible for a fun to have been skipped by diff --git a/module/language/cps2/utils.scm b/module/language/cps2/utils.scm index d96b776c9..e62966e40 100644 --- a/module/language/cps2/utils.scm +++ b/module/language/cps2/utils.scm @@ -54,6 +54,7 @@ compute-predecessors compute-reverse-post-order compute-strongly-connected-components + compute-sorted-strongly-connected-components compute-idoms compute-dom-edges )) @@ -270,7 +271,7 @@ intset." visited)) lp))))) -(define (compute-successors conts kfun) +(define* (compute-successors conts #:optional (kfun (intmap-next conts))) (define (visit label succs) (let visit ((label kfun) (succs empty-intmap)) (define (propagate0) @@ -374,6 +375,58 @@ partitioning the labels into strongly connected components (SCCs)." (fold visit-scc empty-intmap (compute-reverse-post-order succs start)) empty-intmap))) +(define (compute-sorted-strongly-connected-components edges) + "Given a LABEL->SUCCESSOR... graph, return a list of strongly +connected components in sorted order." + (define nodes + (intmap-keys edges)) + ;; Add a "start" node that links to all nodes in the graph, and then + ;; remove it from the result. + (define start + (if (eq? nodes empty-intset) + 0 + (1+ (intset-prev nodes)))) + (define components + (intmap-remove + (compute-strongly-connected-components (intmap-add edges start nodes) + start) + start)) + (define node-components + (intmap-fold (lambda (id nodes out) + (intset-fold (lambda (node out) (intmap-add out node id)) + nodes out)) + components + empty-intmap)) + (define (node-component node) + (intmap-ref node-components node)) + (define (component-successors id nodes) + (intset-remove + (intset-fold (lambda (node out) + (intset-fold + (lambda (successor out) + (intset-add out (node-component successor))) + (intmap-ref edges node) + out)) + nodes + empty-intset) + id)) + (define component-edges + (intmap-map component-successors components)) + (define preds + (invert-graph component-edges)) + (define roots + (intmap-fold (lambda (id succs out) + (if (eq? empty-intset succs) + (intset-add out id) + out)) + component-edges + empty-intset)) + ;; As above, add a "start" node that links to the roots, and remove it + ;; from the result. + (match (compute-reverse-post-order (intmap-add preds start roots) start) + (((? (lambda (id) (eqv? id start))) . ids) + (map (lambda (id) (intmap-ref components id)) ids)))) + ;; Precondition: For each function in CONTS, the continuation names are ;; topologically sorted. (define (compute-idoms conts kfun) From 365296a866598563a3641b541ea30fafa1d3dd32 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 19 Jul 2015 12:23:05 +0200 Subject: [PATCH 023/865] CPS1 slot-allocation simplification * module/language/cps/slot-allocation.scm (allocate-slots): Don't pass around nargs, as it's not used. --- module/language/cps/slot-allocation.scm | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index d8cbd15ba..400f9e390 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -281,7 +281,7 @@ are comparable with eqv?. A tmp slot may be used." 0 (1- (find-first-trailing-zero live-slots)))) - (define (recompute-live-slots k nargs) + (define (recompute-live-slots k) (let ((in (dfa-k-in dfa (label->idx k)))) (let lp ((v 0) (live-slots 0)) (let ((v (intset-next in v))) @@ -589,10 +589,10 @@ are comparable with eqv?. A tmp slot may be used." (hashq-set! call-allocations label (make-call-allocation #f moves #f)))))) - (define (allocate-prompt label k handler nargs) + (define (allocate-prompt label k handler) (match (lookup-cont handler dfg) (($ $kreceive arity kargs) - (let* ((handler-live (recompute-live-slots handler nargs)) + (let* ((handler-live (recompute-live-slots handler)) (proc-slot (compute-prompt-handler-proc-slot handler-live)) (result-vars (vector-ref defv (label->idx kargs))) (value-slots (map (cut + proc-slot 1 <>) @@ -618,8 +618,8 @@ are comparable with eqv?. A tmp slot may be used." ;; This traversal will visit definitions before uses, as ;; definitions dominate uses and a block's dominator will appear ;; before it, in reverse post-order. - (define (visit-clause n nargs live) - (let lp ((n n) (live (recompute-live-slots (idx->label n) nargs))) + (define (visit-clause n live) + (let lp ((n n) (live (recompute-live-slots (idx->label n)))) (define (kill-dead live vars-by-label-idx pred) (fold (lambda (v live) (let ((slot (vector-ref slots v))) @@ -636,7 +636,7 @@ are comparable with eqv?. A tmp slot may be used." n (let* ((label (idx->label n)) (live (if (control-point? label dfg) - (recompute-live-slots label nargs) + (recompute-live-slots label) live)) (live (kill-dead-defs (allocate-defs! n live))) (post-live (kill-dead-uses live))) @@ -649,7 +649,7 @@ are comparable with eqv?. A tmp slot may be used." (define (compute-k-live k) (match (lookup-predecessors k dfg) ((_) post-live) - (_ (recompute-live-slots k nargs)))) + (_ (recompute-live-slots k)))) (let ((uses (vector-ref usev n))) (match (find-call body) (($ $continue k src (or ($ $call) ($ $callk))) @@ -658,7 +658,7 @@ are comparable with eqv?. A tmp slot may be used." (($ $continue k src ($ $values)) (allocate-values label k uses live (compute-k-live k))) (($ $continue k src ($ $prompt escape? tag handler)) - (allocate-prompt label k handler nargs)) + (allocate-prompt label k handler)) (_ #f))) (lp (1+ n) post-live)) ((or ($ $kreceive) ($ $ktail)) @@ -675,7 +675,6 @@ are comparable with eqv?. A tmp slot may be used." (error "Unexpected label order")) (let* ((nargs (length names)) (next (visit-clause (1+ n) - nargs (fold allocate! live (vector-ref defv (1+ n)) (cdr (iota (1+ nargs))))))) From f63b2e4814761f805d3e7897bc543ebd3543b008 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 20 Jul 2015 10:57:52 +0200 Subject: [PATCH 024/865] More slot-allocation simplification * module/language/cps/slot-allocation.scm (allocate-slots): Remove unreachable clause. --- module/language/cps/slot-allocation.scm | 14 +------------- 1 file changed, 1 insertion(+), 13 deletions(-) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 400f9e390..c60f0f22f 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -542,19 +542,7 @@ are comparable with eqv?. A tmp slot may be used." (hashq-set! call-allocations label (make-call-allocation proc-slot arg-moves dead-slot-map)) (hashq-set! call-allocations k - (make-call-allocation proc-slot result-moves #f)))) - - (_ - (let* ((proc-slot (compute-call-proc-slot post-live)) - (call-slots (map (cut + proc-slot <>) (iota (length uses)))) - (pre-live (fold allocate! pre-live uses call-slots)) - (arg-moves (parallel-move (map (cut vector-ref slots <>) uses) - call-slots - (compute-tmp-slot pre-live - call-slots)))) - (bump-nlocals! (+ proc-slot (length uses))) - (hashq-set! call-allocations label - (make-call-allocation proc-slot arg-moves #f)))))) + (make-call-allocation proc-slot result-moves #f)))))) (define (allocate-values label k uses pre-live post-live) (match (lookup-cont k dfg) From 08cf30f2a0fc6c9e0851e229a11c09ab9aaacec0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 20 Jul 2015 16:24:49 +0200 Subject: [PATCH 025/865] Fix error printing some wrong-num-args backtraces * module/system/repl/debug.scm (print-frame): Pass #:top-frame? #t for the top frame. * module/system/vm/frame.scm (available-bindings): Be permissive and allow #:top-frame? #f even when the IP is at the start of the function. --- module/system/repl/debug.scm | 5 +++-- module/system/vm/frame.scm | 5 ++++- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm index 300145d16..6fff660e5 100644 --- a/module/system/repl/debug.scm +++ b/module/system/repl/debug.scm @@ -1,6 +1,6 @@ ;;; Guile VM debugging facilities -;;; Copyright (C) 2001, 2009, 2010, 2011, 2013, 2014 Free Software Foundation, Inc. +;;; Copyright (C) 2001, 2009, 2010, 2011, 2013, 2014, 2015 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 @@ -134,7 +134,8 @@ (format port "~&In ~a:~&" file)) (format port "~9@a~:[~*~3_~;~3d~] ~v:@y~%" (if line (format #f "~a:~a" line col) "") - index index width (frame-call-representation frame)) + index index width + (frame-call-representation frame #:top-frame? (zero? index))) (if full? (print-locals frame #:width width #:per-line-prefix " ")))) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index ac5fbf6f5..b84f6683e 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -206,7 +206,10 @@ (when (< offset 0) (error "ip did not correspond to an instruction boundary?")) (if (zero? offset) - (let ((live (if top-frame? + ;; It shouldn't be the case that both OFFSET and N are zero + ;; but TOP-FRAME? is false. Still, it could happen, as is + ;; currently the case in frame-arguments. + (let ((live (if (or top-frame? (zero? n)) (vector-ref inv n) ;; If we're not at a top frame, the IP points ;; to the continuation -- but we haven't From ff2beb186ef52286214ccd2e52c6262c84c3035f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 21 Jul 2015 17:48:22 +0200 Subject: [PATCH 026/865] Fix bad return shuffles for multiply-used $kreceive conts * module/language/cps2/reify-primitives.scm (uniquify-receive): (reify-primitives): Ensure that $kreceive conts can have only one predecessor. Otherwise return shuffles are incorrectly allocated. --- module/language/cps2/reify-primitives.scm | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/module/language/cps2/reify-primitives.scm b/module/language/cps2/reify-primitives.scm index b5f62d456..55409bfc1 100644 --- a/module/language/cps2/reify-primitives.scm +++ b/module/language/cps2/reify-primitives.scm @@ -108,6 +108,16 @@ (letk kclause ($kclause ('() '() #f '() #f) kbody #f)) kclause)) +;; A $kreceive continuation should have only one predecessor. +(define (uniquify-receive cps k) + (match (intmap-ref cps k) + (($ $kreceive ($ $arity req () rest () #f) kargs) + (with-cps cps + (letk k ($kreceive req rest kargs)) + k)) + (_ + (with-cps cps k)))) + (define (reify-primitives cps) (define (visit-cont label cont cps) (define (resolve-prim cps name k src) @@ -123,6 +133,7 @@ (setk label ($kfun src meta self tail clause)))) (($ $kargs names vars ($ $continue k src ($ $prim name))) (with-cps cps + (let$ k (uniquify-receive k)) (let$ body (resolve-prim name k src)) (setk label ($kargs names vars ,body)))) (($ $kargs names vars @@ -135,10 +146,21 @@ cps (with-cps cps (letv proc) + (let$ k (uniquify-receive k)) (letk kproc ($kargs ('proc) (proc) ($continue k src ($call proc args)))) (let$ body (resolve-prim name kproc src)) (setk label ($kargs names vars ,body))))) + (($ $kargs names vars ($ $continue k src ($ $call proc args))) + (with-cps cps + (let$ k (uniquify-receive k)) + (setk label ($kargs names vars + ($continue k src ($call proc args)))))) + (($ $kargs names vars ($ $continue k src ($ $callk k* proc args))) + (with-cps cps + (let$ k (uniquify-receive k)) + (setk label ($kargs names vars + ($continue k src ($callk k* proc args)))))) (_ cps))) (with-fresh-name-state cps From 2df454b95b67029e28bbe041885001ce4a14adfd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 22 Jul 2015 16:59:47 +0200 Subject: [PATCH 027/865] intset-intersect bugfix * module/language/cps/intset.scm (intset-intersect): Remove new-leaf procedure, inlining to single call site. An empty intersection properly produces #f so that the set can be pruned. --- module/language/cps/intset.scm | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/module/language/cps/intset.scm b/module/language/cps/intset.scm index 8c7a23bf3..bb35a23d3 100644 --- a/module/language/cps/intset.scm +++ b/module/language/cps/intset.scm @@ -102,7 +102,6 @@ (root transient-intset-root set-transient-intset-root!) (edit transient-intset-edit set-transient-intset-edit!)) -(define (new-leaf) 0) (define-inlinable (clone-leaf-and-set leaf i val) (if val (if leaf @@ -573,10 +572,10 @@ (else (make-intset a-min a-shift root))))))))) (define (intset-intersect a b) - (define tmp (new-leaf)) ;; Intersect leaves. (define (intersect-leaves a b) - (logand a b)) + (let ((leaf (logand a b))) + (if (eqv? leaf 0) #f leaf))) ;; Intersect A and B from index I; the result will be fresh. (define (intersect-branches/fresh shift a b i fresh) (let lp ((i 0)) From 16d92c566fe23e50359965056ccfe25b2ae92dd5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 22 Jul 2015 17:00:34 +0200 Subject: [PATCH 028/865] Fix CPS2 compute-successors * module/language/cps2/utils.scm (compute-successors): Propagate $kfun to $ktail so that we don't leave off the tail if the body iloops. --- module/language/cps2/utils.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/module/language/cps2/utils.scm b/module/language/cps2/utils.scm index e62966e40..eae6b69c6 100644 --- a/module/language/cps2/utils.scm +++ b/module/language/cps2/utils.scm @@ -293,8 +293,8 @@ intset." (propagate1 k)) (($ $kfun src meta self tail clause) (if clause - (propagate1 clause) - (propagate0))) + (propagate2 clause tail) + (propagate1 tail))) (($ $kclause arity kbody kalt) (if kalt (propagate2 kbody kalt) From 910054bfbc628843235db3a9d315986280f09bcd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 22 Jul 2015 17:01:19 +0200 Subject: [PATCH 029/865] Slot allocation and bytecode compilation from CPS2. * module/language/cps2/compile-bytecode.scm: New file. * module/language/cps2/slot-allocation.scm: New file. * module/Makefile.am: Add new files. --- module/Makefile.am | 2 + module/language/cps2/compile-bytecode.scm | 433 ++++++++++ module/language/cps2/slot-allocation.scm | 995 ++++++++++++++++++++++ 3 files changed, 1430 insertions(+) create mode 100644 module/language/cps2/compile-bytecode.scm create mode 100644 module/language/cps2/slot-allocation.scm diff --git a/module/Makefile.am b/module/Makefile.am index c1c3e5cf0..801f466cb 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -134,6 +134,7 @@ CPS_LANG_SOURCES = \ CPS2_LANG_SOURCES = \ language/cps2.scm \ language/cps2/closure-conversion.scm \ + language/cps2/compile-bytecode.scm \ language/cps2/compile-cps.scm \ language/cps2/constructors.scm \ language/cps2/contification.scm \ @@ -148,6 +149,7 @@ CPS2_LANG_SOURCES = \ language/cps2/optimize.scm \ language/cps2/simplify.scm \ language/cps2/self-references.scm \ + language/cps2/slot-allocation.scm \ language/cps2/spec.scm \ language/cps2/specialize-primcalls.scm \ language/cps2/split-rec.scm \ diff --git a/module/language/cps2/compile-bytecode.scm b/module/language/cps2/compile-bytecode.scm new file mode 100644 index 000000000..a39c9f222 --- /dev/null +++ b/module/language/cps2/compile-bytecode.scm @@ -0,0 +1,433 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Compiling CPS to bytecode. The result is in the bytecode language, +;;; which happens to be an ELF image as a bytecode. +;;; +;;; Code: + +(define-module (language cps2 compile-bytecode) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (language cps2) + #:use-module (language cps primitives) + #:use-module (language cps2 slot-allocation) + #:use-module (language cps2 utils) + #:use-module (language cps2 closure-conversion) + #:use-module (language cps2 optimize) + #:use-module (language cps2 reify-primitives) + #:use-module (language cps2 renumber) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:use-module (system vm assembler) + #:export (compile-bytecode)) + +(define (kw-arg-ref args kw default) + (match (memq kw args) + ((_ val . _) val) + (_ default))) + +(define (intmap-for-each f map) + (intmap-fold (lambda (k v seed) (f k v) seed) map *unspecified*)) + +(define (intmap-select map set) + (persistent-intmap + (intset-fold + (lambda (k out) + (intmap-add! out k (intmap-ref map k))) + set + empty-intmap))) + +(define (compile-function cps asm) + (let ((allocation (allocate-slots cps)) + (frame-size #f)) + (define (maybe-slot sym) + (lookup-maybe-slot sym allocation)) + + (define (slot sym) + (lookup-slot sym allocation)) + + (define (constant sym) + (lookup-constant-value sym allocation)) + + (define (maybe-mov dst src) + (unless (= dst src) + (emit-mov asm dst src))) + + (define (compile-tail label exp) + ;; There are only three kinds of expressions in tail position: + ;; tail calls, multiple-value returns, and single-value returns. + (match exp + (($ $call proc args) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation)) + (emit-tail-call asm (1+ (length args)))) + (($ $callk k proc args) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation)) + (emit-tail-call-label asm (1+ (length args)) k)) + (($ $values ()) + (emit-reset-frame asm 1) + (emit-return-values asm)) + (($ $values (arg)) + (if (maybe-slot arg) + (emit-return asm (slot arg)) + (begin + (emit-load-constant asm 1 (constant arg)) + (emit-return asm 1)))) + (($ $values args) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation)) + (emit-reset-frame asm (1+ (length args))) + (emit-return-values asm)) + (($ $primcall 'return (arg)) + (emit-return asm (slot arg))))) + + (define (compile-value label exp dst) + (match exp + (($ $values (arg)) + (maybe-mov dst (slot arg))) + (($ $const exp) + (emit-load-constant asm dst exp)) + (($ $closure k 0) + (emit-load-static-procedure asm dst k)) + (($ $closure k nfree) + (emit-make-closure asm dst k nfree)) + (($ $primcall 'current-module) + (emit-current-module asm dst)) + (($ $primcall 'cached-toplevel-box (scope name bound?)) + (emit-cached-toplevel-box asm dst (constant scope) (constant name) + (constant bound?))) + (($ $primcall 'cached-module-box (mod name public? bound?)) + (emit-cached-module-box asm dst (constant mod) (constant name) + (constant public?) (constant bound?))) + (($ $primcall 'resolve (name bound?)) + (emit-resolve asm dst (constant bound?) (slot name))) + (($ $primcall 'free-ref (closure idx)) + (emit-free-ref asm dst (slot closure) (constant idx))) + (($ $primcall 'vector-ref (vector index)) + (emit-vector-ref asm dst (slot vector) (slot index))) + (($ $primcall 'make-vector (length init)) + (emit-make-vector asm dst (slot length) (slot init))) + (($ $primcall 'make-vector/immediate (length init)) + (emit-make-vector/immediate asm dst (constant length) (slot init))) + (($ $primcall 'vector-ref/immediate (vector index)) + (emit-vector-ref/immediate asm dst (slot vector) (constant index))) + (($ $primcall 'allocate-struct (vtable nfields)) + (emit-allocate-struct asm dst (slot vtable) (slot nfields))) + (($ $primcall 'allocate-struct/immediate (vtable nfields)) + (emit-allocate-struct/immediate asm dst (slot vtable) (constant nfields))) + (($ $primcall 'struct-ref (struct n)) + (emit-struct-ref asm dst (slot struct) (slot n))) + (($ $primcall 'struct-ref/immediate (struct n)) + (emit-struct-ref/immediate asm dst (slot struct) (constant n))) + (($ $primcall 'builtin-ref (name)) + (emit-builtin-ref asm dst (constant name))) + (($ $primcall 'bv-u8-ref (bv idx)) + (emit-bv-u8-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-s8-ref (bv idx)) + (emit-bv-s8-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-u16-ref (bv idx)) + (emit-bv-u16-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-s16-ref (bv idx)) + (emit-bv-s16-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-u32-ref (bv idx val)) + (emit-bv-u32-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-s32-ref (bv idx val)) + (emit-bv-s32-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-u64-ref (bv idx val)) + (emit-bv-u64-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-s64-ref (bv idx val)) + (emit-bv-s64-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-f32-ref (bv idx val)) + (emit-bv-f32-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-f64-ref (bv idx val)) + (emit-bv-f64-ref asm dst (slot bv) (slot idx))) + (($ $primcall name args) + ;; FIXME: Inline all the cases. + (let ((inst (prim-instruction name))) + (emit-text asm `((,inst ,dst ,@(map slot args)))))))) + + (define (compile-effect label exp k) + (match exp + (($ $values ()) #f) + (($ $prompt escape? tag handler) + (match (intmap-ref cps handler) + (($ $kreceive ($ $arity req () rest () #f) khandler-body) + (let ((receive-args (gensym "handler")) + (nreq (length req)) + (proc-slot (lookup-call-proc-slot label allocation))) + (emit-prompt asm (slot tag) escape? proc-slot receive-args) + (emit-br asm k) + (emit-label asm receive-args) + (unless (and rest (zero? nreq)) + (emit-receive-values asm proc-slot (->bool rest) nreq)) + (when (and rest + (match (intmap-ref cps khandler-body) + (($ $kargs names (_ ... rest)) + (maybe-slot rest)))) + (emit-bind-rest asm (+ proc-slot 1 nreq))) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves handler allocation)) + (emit-reset-frame asm frame-size) + (emit-br asm khandler-body))))) + (($ $primcall 'cache-current-module! (sym scope)) + (emit-cache-current-module! asm (slot sym) (constant scope))) + (($ $primcall 'free-set! (closure idx value)) + (emit-free-set! asm (slot closure) (slot value) (constant idx))) + (($ $primcall 'box-set! (box value)) + (emit-box-set! asm (slot box) (slot value))) + (($ $primcall 'struct-set! (struct index value)) + (emit-struct-set! asm (slot struct) (slot index) (slot value))) + (($ $primcall 'struct-set!/immediate (struct index value)) + (emit-struct-set!/immediate asm (slot struct) (constant index) (slot value))) + (($ $primcall 'vector-set! (vector index value)) + (emit-vector-set! asm (slot vector) (slot index) (slot value))) + (($ $primcall 'vector-set!/immediate (vector index value)) + (emit-vector-set!/immediate asm (slot vector) (constant index) + (slot value))) + (($ $primcall 'set-car! (pair value)) + (emit-set-car! asm (slot pair) (slot value))) + (($ $primcall 'set-cdr! (pair value)) + (emit-set-cdr! asm (slot pair) (slot value))) + (($ $primcall 'define! (sym value)) + (emit-define! asm (slot sym) (slot value))) + (($ $primcall 'push-fluid (fluid val)) + (emit-push-fluid asm (slot fluid) (slot val))) + (($ $primcall 'pop-fluid ()) + (emit-pop-fluid asm)) + (($ $primcall 'wind (winder unwinder)) + (emit-wind asm (slot winder) (slot unwinder))) + (($ $primcall 'bv-u8-set! (bv idx val)) + (emit-bv-u8-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-s8-set! (bv idx val)) + (emit-bv-s8-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-u16-set! (bv idx val)) + (emit-bv-u16-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-s16-set! (bv idx val)) + (emit-bv-s16-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-u32-set! (bv idx val)) + (emit-bv-u32-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-s32-set! (bv idx val)) + (emit-bv-s32-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-u64-set! (bv idx val)) + (emit-bv-u64-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-s64-set! (bv idx val)) + (emit-bv-s64-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-f32-set! (bv idx val)) + (emit-bv-f32-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-f64-set! (bv idx val)) + (emit-bv-f64-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'unwind ()) + (emit-unwind asm)))) + + (define (compile-values label exp syms) + (match exp + (($ $values args) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation))))) + + (define (compile-test label exp kt kf next-label) + (define (unary op sym) + (cond + ((eq? kt next-label) + (op asm (slot sym) #t kf)) + (else + (op asm (slot sym) #f kt) + (unless (eq? kf next-label) + (emit-br asm kf))))) + (define (binary op a b) + (cond + ((eq? kt next-label) + (op asm (slot a) (slot b) #t kf)) + (else + (op asm (slot a) (slot b) #f kt) + (unless (eq? kf next-label) + (emit-br asm kf))))) + (match exp + (($ $values (sym)) + (call-with-values (lambda () + (lookup-maybe-constant-value sym allocation)) + (lambda (has-const? val) + (if has-const? + (if val + (unless (eq? kt next-label) + (emit-br asm kt)) + (unless (eq? kf next-label) + (emit-br asm kf))) + (unary emit-br-if-true sym))))) + (($ $primcall 'null? (a)) (unary emit-br-if-null a)) + (($ $primcall 'nil? (a)) (unary emit-br-if-nil a)) + (($ $primcall 'pair? (a)) (unary emit-br-if-pair a)) + (($ $primcall 'struct? (a)) (unary emit-br-if-struct a)) + (($ $primcall 'char? (a)) (unary emit-br-if-char a)) + (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a)) + (($ $primcall 'variable? (a)) (unary emit-br-if-variable a)) + (($ $primcall 'vector? (a)) (unary emit-br-if-vector a)) + (($ $primcall 'string? (a)) (unary emit-br-if-string a)) + (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a)) + (($ $primcall 'bitvector? (a)) (unary emit-br-if-bitvector a)) + (($ $primcall 'keyword? (a)) (unary emit-br-if-keyword a)) + ;; Add more TC7 tests here. Keep in sync with + ;; *branching-primcall-arities* in (language cps primitives) and + ;; the set of macro-instructions in assembly.scm. + (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b)) + (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b)) + (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b)) + (($ $primcall '< (a b)) (binary emit-br-if-< a b)) + (($ $primcall '<= (a b)) (binary emit-br-if-<= a b)) + (($ $primcall '= (a b)) (binary emit-br-if-= a b)) + (($ $primcall '>= (a b)) (binary emit-br-if-<= b a)) + (($ $primcall '> (a b)) (binary emit-br-if-< b a)) + (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b)))) + + (define (compile-trunc label k exp nreq rest-var) + (define (do-call proc args emit-call) + (let* ((proc-slot (lookup-call-proc-slot label allocation)) + (nargs (1+ (length args))) + (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs)))) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation)) + (emit-call asm proc-slot nargs) + (emit-dead-slot-map asm proc-slot + (lookup-dead-slot-map label allocation)) + (cond + ((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var)) + (match (lookup-parallel-moves k allocation) + ((((? (lambda (src) (= src (1+ proc-slot))) src) + . dst)) dst) + (_ #f))) + ;; The usual case: one required live return value, ignoring + ;; any additional values. + => (lambda (dst) + (emit-receive asm dst proc-slot frame-size))) + (else + (unless (and (zero? nreq) rest-var) + (emit-receive-values asm proc-slot (->bool rest-var) nreq)) + (when (and rest-var (maybe-slot rest-var)) + (emit-bind-rest asm (+ proc-slot 1 nreq))) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves k allocation)) + (emit-reset-frame asm frame-size))))) + (match exp + (($ $call proc args) + (do-call proc args + (lambda (asm proc-slot nargs) + (emit-call asm proc-slot nargs)))) + (($ $callk k proc args) + (do-call proc args + (lambda (asm proc-slot nargs) + (emit-call-label asm proc-slot nargs k)))))) + + (define (compile-expression label k exp) + (let* ((fallthrough? (= k (1+ label)))) + (define (maybe-emit-jump) + (unless fallthrough? + (emit-br asm k))) + (match (intmap-ref cps k) + (($ $ktail) + (compile-tail label exp)) + (($ $kargs (name) (sym)) + (let ((dst (maybe-slot sym))) + (when dst + (compile-value label exp dst))) + (maybe-emit-jump)) + (($ $kargs () ()) + (match exp + (($ $branch kt exp) + (compile-test label exp kt k (1+ label))) + (_ + (compile-effect label exp k) + (maybe-emit-jump)))) + (($ $kargs names syms) + (compile-values label exp syms) + (maybe-emit-jump)) + (($ $kreceive ($ $arity req () rest () #f) kargs) + (compile-trunc label k exp (length req) + (and rest + (match (intmap-ref cps kargs) + (($ $kargs names (_ ... rest)) rest)))) + (unless (and fallthrough? (= kargs (1+ k))) + (emit-br asm kargs)))))) + + (define (compile-cont label cont) + (match cont + (($ $kfun src meta self tail clause) + (when src + (emit-source asm src)) + (emit-begin-program asm label meta)) + (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alt) + (let ((first? (match (intmap-ref cps (1- label)) + (($ $kfun) #t) + (_ #f))) + (kw-indices (map (match-lambda + ((key name sym) + (cons key (lookup-slot sym allocation)))) + kw))) + (unless first? + (emit-end-arity asm)) + (emit-label asm label) + (set! frame-size (lookup-nlocals label allocation)) + (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys? + frame-size alt))) + (($ $kargs names vars ($ $continue k src exp)) + (emit-label asm label) + (for-each (lambda (name var) + (let ((slot (maybe-slot var))) + (when slot + (emit-definition asm name slot)))) + names vars) + (when src + (emit-source asm src)) + (compile-expression label k exp)) + (($ $kreceive arity kargs) + (emit-label asm label)) + (($ $ktail) + (emit-end-arity asm) + (emit-end-program asm)))) + + (intmap-for-each compile-cont cps))) + +(define (emit-bytecode exp env opts) + (let ((asm (make-assembler))) + (intmap-for-each (lambda (kfun body) + (compile-function (intmap-select exp body) asm)) + (compute-reachable-functions exp 0)) + (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f)) + env + env))) + +(define (lower-cps exp opts) + (set! exp (optimize-higher-order-cps exp opts)) + (set! exp (convert-closures exp)) + (set! exp (optimize-first-order-cps exp opts)) + (set! exp (reify-primitives exp)) + (renumber exp)) + +(define (compile-bytecode exp env opts) + (set! exp (lower-cps exp opts)) + (emit-bytecode exp env opts)) diff --git a/module/language/cps2/slot-allocation.scm b/module/language/cps2/slot-allocation.scm new file mode 100644 index 000000000..48f5a1fd3 --- /dev/null +++ b/module/language/cps2/slot-allocation.scm @@ -0,0 +1,995 @@ +;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; A module to assign stack slots to variables in a CPS term. +;;; +;;; Code: + +(define-module (language cps2 slot-allocation) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (language cps2) + #:use-module (language cps2 utils) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (allocate-slots + lookup-slot + lookup-maybe-slot + lookup-constant-value + lookup-maybe-constant-value + lookup-nlocals + lookup-call-proc-slot + lookup-parallel-moves + lookup-dead-slot-map)) + +(define-record-type $allocation + (make-allocation slots constant-values call-allocs shuffles frame-sizes) + allocation? + + ;; A map of VAR to slot allocation. A slot allocation is an integer, + ;; if the variable has been assigned a slot. + ;; + (slots allocation-slots) + + ;; A map of VAR to constant value, for variables with constant values. + ;; + (constant-values allocation-constant-values) + + ;; A map of LABEL to /call allocs/, for expressions that continue to + ;; $kreceive continuations: non-tail calls and $prompt expressions. + ;; + ;; A call alloc contains two pieces of information: the call's /proc + ;; slot/ and a /dead slot map/. The proc slot indicates the slot of a + ;; procedure in a procedure call, or where the procedure would be in a + ;; multiple-value return. + ;; + ;; The dead slot map indicates, what slots should be ignored by GC + ;; when marking the frame. A dead slot map is a bitfield, as an + ;; integer. + ;; + (call-allocs allocation-call-allocs) + + ;; A map of LABEL to /parallel moves/. Parallel moves shuffle locals + ;; into position for a $call, $callk, or $values, or shuffle returned + ;; values back into place in a $kreceive. + ;; + ;; A set of moves is expressed as an ordered list of (SRC . DST) + ;; moves, where SRC and DST are slots. This may involve a temporary + ;; variable. + ;; + (shuffles allocation-shuffles) + + ;; The number of locals for a $kclause. + ;; + (frame-sizes allocation-frame-sizes)) + +(define-record-type $call-alloc + (make-call-alloc proc-slot dead-slot-map) + call-alloc? + (proc-slot call-alloc-proc-slot) + (dead-slot-map call-alloc-dead-slot-map)) + +(define (lookup-maybe-slot var allocation) + (intmap-ref (allocation-slots allocation) var (lambda (_) #f))) + +(define (lookup-slot var allocation) + (intmap-ref (allocation-slots allocation) var)) + +(define *absent* (list 'absent)) + +(define (lookup-constant-value var allocation) + (let ((value (intmap-ref (allocation-constant-values allocation) var + (lambda (_) *absent*)))) + (when (eq? value *absent*) + (error "Variable does not have constant value" var)) + value)) + +(define (lookup-maybe-constant-value var allocation) + (let ((value (intmap-ref (allocation-constant-values allocation) var + (lambda (_) *absent*)))) + (if (eq? value *absent*) + (values #f #f) + (values #t value)))) + +(define (lookup-call-alloc k allocation) + (intmap-ref (allocation-call-allocs allocation) k)) + +(define (lookup-call-proc-slot k allocation) + (or (call-alloc-proc-slot (lookup-call-alloc k allocation)) + (error "Call has no proc slot" k))) + +(define (lookup-parallel-moves k allocation) + (intmap-ref (allocation-shuffles allocation) k)) + +(define (lookup-dead-slot-map k allocation) + (or (call-alloc-dead-slot-map (lookup-call-alloc k allocation)) + (error "Call has no dead slot map" k))) + +(define (lookup-nlocals k allocation) + (intmap-ref (allocation-frame-sizes allocation) k)) + +(define (intset-pop set) + (match (intset-next set) + (#f (values set #f)) + (i (values (intset-remove set i) i)))) + +(define (solve-flow-equations succs in out kill gen subtract add meet) + "Find a fixed point for flow equations for SUCCS, where IN and OUT are +the initial conditions as intmaps with one key for every node in SUCCS. +KILL and GEN are intmaps indicating the state that is killed or defined +at every node, and SUBTRACT, ADD, and MEET operates on that state." + (define (visit label in out) + (let* ((in-1 (intmap-ref in label)) + (kill-1 (intmap-ref kill label)) + (gen-1 (intmap-ref gen label)) + (out-1 (intmap-ref out label)) + (out-1* (add (subtract in-1 kill-1) gen-1))) + (if (eq? out-1 out-1*) + (values empty-intset in out) + (let ((out (intmap-replace! out label out-1*))) + (call-with-values + (lambda () + (intset-fold (lambda (succ in changed) + (let* ((in-1 (intmap-ref in succ)) + (in-1* (meet in-1 out-1*))) + (if (eq? in-1 in-1*) + (values in changed) + (values (intmap-replace! in succ in-1*) + (intset-add changed succ))))) + (intmap-ref succs label) in empty-intset)) + (lambda (in changed) + (values changed in out))))))) + + (let run ((worklist (intmap-keys succs)) (in in) (out out)) + (call-with-values (lambda () (intset-pop worklist)) + (lambda (worklist popped) + (if popped + (call-with-values (lambda () (visit popped in out)) + (lambda (changed in out) + (run (intset-union worklist changed) in out))) + (values (persistent-intmap in) + (persistent-intmap out))))))) + +(define-syntax-rule (persistent-intmap2 exp) + (call-with-values (lambda () exp) + (lambda (a b) + (values (persistent-intmap a) (persistent-intmap b))))) + +(define (compute-defs-and-uses cps) + "Return two LABEL->VAR... maps indicating values defined at and used +by a label, respectively." + (define (vars->intset vars) + (fold (lambda (var set) (intset-add set var)) empty-intset vars)) + (persistent-intmap2 + (intmap-fold + (lambda (label cont defs uses) + (define (get-defs k) + (match (intmap-ref cps k) + (($ $kargs names vars) (vars->intset vars)) + (_ empty-intset))) + (define (return d u) + (values (intmap-add! defs label d) + (intmap-add! uses label u))) + (match cont + (($ $kfun src meta self) + (return (intset self) empty-intset)) + (($ $kargs _ _ ($ $continue k src exp)) + (match exp + ((or ($ $const) ($ $closure)) + (return (get-defs k) empty-intset)) + (($ $call proc args) + (return (get-defs k) (intset-add (vars->intset args) proc))) + (($ $callk _ proc args) + (return (get-defs k) (intset-add (vars->intset args) proc))) + (($ $primcall name args) + (return (get-defs k) (vars->intset args))) + (($ $branch kt ($ $primcall name args)) + (return empty-intset (vars->intset args))) + (($ $branch kt ($ $values args)) + (return empty-intset (vars->intset args))) + (($ $values args) + (return (get-defs k) (vars->intset args))) + (($ $prompt escape? tag handler) + (return empty-intset (intset tag))))) + (($ $kclause arity body alt) + (return (get-defs body) empty-intset)) + (($ $kreceive arity kargs) + (return (get-defs kargs) empty-intset)) + (($ $ktail) + (return empty-intset empty-intset)))) + cps + empty-intmap + empty-intmap))) + +(define (compute-reverse-control-flow-order preds) + "Return a LABEL->ORDER bijection where ORDER is a contiguous set of +integers starting from 0 and incrementing in sort order." + ;; This is more involved than forward control flow because not all + ;; live labels are reachable from the tail. + (persistent-intmap + (fold2 (lambda (component order n) + (intset-fold (lambda (label order n) + (values (intmap-add! order label n) + (1+ n))) + component order n)) + (reverse (compute-sorted-strongly-connected-components preds)) + empty-intmap 0))) + +(define* (add-prompt-control-flow-edges conts succs #:key complete?) + "For all prompts in DFG in the range [MIN-LABEL, MIN-LABEL + +LABEL-COUNT), invoke F with arguments PROMPT, HANDLER, and BODY for each +body continuation in the prompt." + (define (intset-filter pred set) + (intset-fold (lambda (i set) + (if (pred i) set (intset-remove set i))) + set + set)) + (define (intset-any pred set) + (intset-fold (lambda (i res) + (if (or res (pred i)) #t res)) + set + #f)) + (define (visit-prompt label handler succs) + ;; FIXME: It isn't correct to use all continuations reachable from + ;; the prompt, because that includes continuations outside the + ;; prompt body. This point is moot if the handler's control flow + ;; joins with the the body, as is usually but not always the case. + ;; + ;; One counter-example is when the handler contifies an infinite + ;; loop; in that case we compute a too-large prompt body. This + ;; error is currently innocuous, but we should fix it at some point. + ;; + ;; The fix is to end the body at the corresponding "pop" primcall, + ;; if any. + (let ((body (intset-subtract (compute-function-body conts label) + (compute-function-body conts handler)))) + (define (out-or-back-edge? label) + ;; Most uses of visit-prompt-control-flow don't need every body + ;; continuation, and would be happy getting called only for + ;; continuations that postdominate the rest of the body. Unless + ;; you pass #:complete? #t, we only invoke F on continuations + ;; that can leave the body, or on back-edges in loops. + ;; + ;; You would think that looking for the final "pop" primcall + ;; would be sufficient, but that is incorrect; it's possible for + ;; a loop in the prompt body to be contified, and that loop need + ;; not continue to the pop if it never terminates. The pop could + ;; even be removed by DCE, in that case. + (intset-any (lambda (succ) + (or (not (intset-ref body succ)) + (<= succ label))) + (intmap-ref succs label))) + (intset-fold (lambda (pred succs) + (intmap-replace succs pred handler intset-add)) + (if complete? body (intset-filter out-or-back-edge? body)) + succs))) + (intmap-fold + (lambda (label cont succs) + (match cont + (($ $kargs _ _ + ($ $continue _ _ ($ $prompt escape? tag handler))) + (visit-prompt label handler succs)) + (_ succs))) + conts + succs)) + +(define (rename-keys map old->new) + (persistent-intmap + (intmap-fold (lambda (k v out) + (intmap-add! out (intmap-ref old->new k) v)) + map + empty-intmap))) + +(define (rename-intset set old->new) + (intset-fold (lambda (old set) (intset-add set (intmap-ref old->new old))) + set empty-intset)) + +(define (rename-graph graph old->new) + (persistent-intmap + (intmap-fold (lambda (pred succs out) + (intmap-add! out + (intmap-ref old->new pred) + (rename-intset succs old->new))) + graph + empty-intmap))) + +(define (compute-live-variables cps defs uses) + "Compute and return two values mapping LABEL->VAR..., where VAR... are +the definitions that are live before and after LABEL, as intsets." + (let* ((succs (add-prompt-control-flow-edges cps (compute-successors cps))) + (preds (invert-graph succs)) + (old->new (compute-reverse-control-flow-order preds))) + (call-with-values + (lambda () + (let ((init (rename-keys + (intmap-map (lambda (k v) empty-intset) preds) + old->new))) + (solve-flow-equations (rename-graph preds old->new) + init init + (rename-keys defs old->new) + (rename-keys uses old->new) + intset-subtract intset-union intset-union))) + (lambda (in out) + ;; As a reverse control-flow problem, the values flowing into a + ;; node are actually the live values after the node executes. + ;; Funny, innit? So we return them in the reverse order. + (let ((new->old (invert-bijection old->new))) + (values (rename-keys out new->old) + (rename-keys in new->old))))))) + +(define (compute-needs-slot cps defs uses) + (define (get-defs k) (intmap-ref defs k)) + (define (get-uses label) (intmap-ref uses label)) + (intmap-fold + (lambda (label cont needs-slot) + (intset-union + needs-slot + (match cont + (($ $kargs _ _ ($ $continue k src exp)) + (let ((defs (get-defs label))) + (define (defs+* uses) + (intset-union defs uses)) + (define (defs+ use) + (intset-add defs use)) + (match exp + (($ $const) + empty-intset) + (($ $primcall 'free-ref (closure slot)) + (defs+ closure)) + (($ $primcall 'free-set! (closure slot value)) + (defs+* (intset closure value))) + (($ $primcall 'cache-current-module! (mod . _)) + (defs+ mod)) + (($ $primcall 'cached-toplevel-box _) + defs) + (($ $primcall 'cached-module-box _) + defs) + (($ $primcall 'resolve (name bound?)) + (defs+ name)) + (($ $primcall 'make-vector/immediate (len init)) + (defs+ init)) + (($ $primcall 'vector-ref/immediate (v i)) + (defs+ v)) + (($ $primcall 'vector-set!/immediate (v i x)) + (defs+* (intset v x))) + (($ $primcall 'allocate-struct/immediate (vtable nfields)) + (defs+ vtable)) + (($ $primcall 'struct-ref/immediate (s n)) + (defs+ s)) + (($ $primcall 'struct-set!/immediate (s n x)) + (defs+* (intset s x))) + (($ $primcall 'builtin-ref (idx)) + defs) + (_ + (defs+* (get-uses label)))))) + (($ $kreceive arity k) + ;; Only allocate results of function calls to slots if they are + ;; used. + empty-intset) + (($ $kclause arity body alternate) + (get-defs label)) + (($ $kfun src meta self) + (intset self)) + (($ $ktail) + empty-intset)))) + cps + empty-intset)) + +(define (compute-lazy-vars cps live-in live-out defs needs-slot) + "Compute and return a set of vars whose allocation can be delayed +until their use is seen. These are \"lazy\" vars. A var is lazy if its +uses are calls, it is always dead after the calls, and if the uses flow +to the definition. A flow continues across a node iff the node kills no +values that need slots, and defines only lazy vars. Calls also kill +flows; there's no sense in trying to juggle a pending frame while there +is an active call." + (define (list->intset list) + (persistent-intset + (fold (lambda (i set) (intset-add! set i)) empty-intset list))) + + (let* ((succs (compute-successors cps)) + (gens (intmap-map + (lambda (label cont) + (match cont + (($ $kargs _ _ ($ $continue _ _ ($ $call proc args))) + (intset-subtract (intset-add (list->intset args) proc) + (intmap-ref live-out label))) + (($ $kargs _ _ ($ $continue _ _ ($ $callk _ proc args))) + (intset-subtract (intset-add (list->intset args) proc) + (intmap-ref live-out label))) + (_ #f))) + cps)) + (kills (intmap-map + (lambda (label in) + (let* ((out (intmap-ref live-out label)) + (killed (intset-subtract in out)) + (killed-slots (intset-intersect killed needs-slot))) + (and (eq? killed-slots empty-intset) + ;; Kill output variables that need slots. + (intset-intersect (intmap-ref defs label) + needs-slot)))) + live-in)) + (preds (invert-graph succs)) + (old->new (compute-reverse-control-flow-order preds))) + (define (subtract lazy kill) + (cond + ((eq? lazy empty-intset) + lazy) + ((not kill) + empty-intset) + ((and lazy (eq? empty-intset (intset-subtract kill lazy))) + (intset-subtract lazy kill)) + (else + empty-intset))) + (define (add live gen) (or gen live)) + (define (meet in out) + ;; Initial in is #f. + (if in (intset-intersect in out) out)) + (call-with-values + (lambda () + (let ((succs (rename-graph preds old->new)) + (in (rename-keys (intmap-map (lambda (k v) #f) preds) old->new)) + (out (rename-keys (intmap-map (lambda (k v) #f) preds) old->new)) + ;(out (rename-keys gens old->new)) + (kills (rename-keys kills old->new)) + (gens (rename-keys gens old->new))) + (solve-flow-equations succs in out kills gens subtract add meet))) + (lambda (in out) + ;; A variable is lazy if its uses reach its definition. + (intmap-fold (lambda (label out lazy) + (match (intmap-ref cps label) + (($ $kargs names vars) + (let ((defs (list->intset vars))) + (intset-union lazy (intset-intersect out defs)))) + (_ lazy))) + (rename-keys out (invert-bijection old->new)) + empty-intset))))) + +(define (find-first-zero n) + ;; Naive implementation. + (let lp ((slot 0)) + (if (logbit? slot n) + (lp (1+ slot)) + slot))) + +(define (find-first-trailing-zero n) + (let lp ((slot (let lp ((count 2)) + (if (< n (ash 1 (1- count))) + count + ;; Grow upper bound slower than factor 2 to avoid + ;; needless bignum allocation on 32-bit systems + ;; when there are more than 16 locals. + (lp (+ count (ash count -1))))))) + (if (or (zero? slot) (logbit? (1- slot) n)) + slot + (lp (1- slot))))) + +(define (integers from count) + (if (zero? count) + '() + (cons from (integers (1+ from) (1- count))))) + +(define (solve-parallel-move src dst tmp) + "Solve the parallel move problem between src and dst slot lists, which +are comparable with eqv?. A tmp slot may be used." + + ;; This algorithm is taken from: "Tilting at windmills with Coq: + ;; formal verification of a compilation algorithm for parallel moves" + ;; by Laurence Rideau, Bernard Paul Serpette, and Xavier Leroy + ;; + + (define (split-move moves reg) + (let loop ((revhead '()) (tail moves)) + (match tail + (((and s+d (s . d)) . rest) + (if (eqv? s reg) + (cons d (append-reverse revhead rest)) + (loop (cons s+d revhead) rest))) + (_ #f)))) + + (define (replace-last-source reg moves) + (match moves + ((moves ... (s . d)) + (append moves (list (cons reg d)))))) + + (let loop ((to-move (map cons src dst)) + (being-moved '()) + (moved '()) + (last-source #f)) + ;; 'last-source' should always be equivalent to: + ;; (and (pair? being-moved) (car (last being-moved))) + (match being-moved + (() (match to-move + (() (reverse moved)) + (((and s+d (s . d)) . t1) + (if (or (eqv? s d) ; idempotent + (not s)) ; src is a constant and can be loaded directly + (loop t1 '() moved #f) + (loop t1 (list s+d) moved s))))) + (((and s+d (s . d)) . b) + (match (split-move to-move d) + ((r . t1) (loop t1 (acons d r being-moved) moved last-source)) + (#f (match b + (() (loop to-move '() (cons s+d moved) #f)) + (_ (if (eqv? d last-source) + (loop to-move + (replace-last-source tmp b) + (cons s+d (acons d tmp moved)) + tmp) + (loop to-move b (cons s+d moved) last-source)))))))))) + +(define (compute-shuffles cps slots call-allocs live-in) + (define (add-live-slot slot live-slots) + (logior live-slots (ash 1 slot))) + + (define (get-cont label) + (intmap-ref cps label)) + + (define (get-slot var) + (intmap-ref slots var (lambda (_) #f))) + + (define (get-slots vars) + (let lp ((vars vars)) + (match vars + ((var . vars) (cons (get-slot var) (lp vars))) + (_ '())))) + + (define (get-proc-slot label) + (call-alloc-proc-slot (intmap-ref call-allocs label))) + + (define (compute-live-slots label) + (intset-fold (lambda (var live) + (match (get-slot var) + (#f live) + (slot (add-live-slot slot live)))) + (intmap-ref live-in label) + 0)) + + ;; Although some parallel moves may proceed without a temporary slot, + ;; in general one is needed. That temporary slot must not be part of + ;; the source or destination sets, and that slot should not correspond + ;; to a live variable. Usually the source and destination sets are a + ;; subset of the union of the live sets before and after the move. + ;; However for stack slots that don't have names -- those slots that + ;; correspond to function arguments or to function return values -- it + ;; could be that they are out of the computed live set. In that case + ;; they need to be adjoined to the live set, used when choosing a + ;; temporary slot. + ;; + ;; Note that although we reserve slots 253-255 for shuffling operands + ;; that address less than the full 24-bit range of locals, that + ;; reservation doesn't apply here, because this temporary itself is + ;; used while doing parallel assignment via "mov", and "mov" does not + ;; need shuffling. + (define (compute-tmp-slot live stack-slots) + (find-first-zero (fold add-live-slot live stack-slots))) + + (define (parallel-move src-slots dst-slots tmp-slot) + (solve-parallel-move src-slots dst-slots tmp-slot)) + + (define (compute-receive-shuffles label proc-slot) + (match (get-cont label) + (($ $kreceive arity kargs) + (let* ((results (match (get-cont kargs) + (($ $kargs names vars) vars))) + (value-slots (integers (1+ proc-slot) (length results))) + (result-slots (get-slots results)) + ;; Filter out unused results. + (value-slots (filter-map (lambda (val result) (and result val)) + value-slots result-slots)) + (result-slots (filter (lambda (x) x) result-slots)) + (live (compute-live-slots kargs))) + (parallel-move value-slots + result-slots + (compute-tmp-slot live value-slots)))))) + + (define (add-call-shuffles label k args shuffles) + (match (get-cont k) + (($ $ktail) + (let* ((live (compute-live-slots label)) + (tail-slots (integers 0 (length args))) + (moves (parallel-move (get-slots args) + tail-slots + (compute-tmp-slot live tail-slots)))) + (intmap-add! shuffles label moves))) + (($ $kreceive) + (let* ((live (compute-live-slots label)) + (proc-slot (get-proc-slot label)) + (call-slots (integers proc-slot (length args))) + (arg-moves (parallel-move (get-slots args) + call-slots + (compute-tmp-slot live call-slots)))) + (intmap-add! (intmap-add! shuffles label arg-moves) + k (compute-receive-shuffles k proc-slot)))))) + + (define (add-values-shuffles label k args shuffles) + (match (get-cont k) + (($ $ktail) + (let* ((live (compute-live-slots label)) + (src-slots (get-slots args)) + (dst-slots (integers 1 (length args))) + (moves (parallel-move src-slots dst-slots + (compute-tmp-slot live dst-slots)))) + (intmap-add! shuffles label moves))) + (($ $kargs _ dst-vars) + (let* ((live (logior (compute-live-slots label) + (compute-live-slots k))) + (src-slots (get-slots args)) + (dst-slots (get-slots dst-vars)) + (moves (parallel-move src-slots dst-slots + (compute-tmp-slot live '())))) + (intmap-add! shuffles label moves))))) + + (define (add-prompt-shuffles label k handler shuffles) + (intmap-add! shuffles handler + (compute-receive-shuffles handler (get-proc-slot label)))) + + (define (compute-shuffles label cont shuffles) + (match cont + (($ $kargs names vars ($ $continue k src exp)) + (match exp + (($ $call proc args) + (add-call-shuffles label k (cons proc args) shuffles)) + (($ $callk _ proc args) + (add-call-shuffles label k (cons proc args) shuffles)) + (($ $values args) + (add-values-shuffles label k args shuffles)) + (($ $prompt escape? tag handler) + (add-prompt-shuffles label k handler shuffles)) + (_ shuffles))) + (_ shuffles))) + + (persistent-intmap + (intmap-fold compute-shuffles cps empty-intmap))) + +(define (compute-frame-sizes cps slots call-allocs shuffles) + ;; Minimum frame has one slot: the closure. + (define minimum-frame-size 1) + (define (get-shuffles label) + (intmap-ref shuffles label)) + (define (get-proc-slot label) + (match (intmap-ref call-allocs label (lambda (_) #f)) + (#f 0) ;; Tail call. + (($ $call-alloc proc-slot) proc-slot))) + (define (max-size var size) + (match (intmap-ref slots var (lambda (_) #f)) + (#f size) + (slot (max size (1+ slot))))) + (define (max-size* vars size) + (fold max-size size vars)) + (define (shuffle-size moves size) + (match moves + (() size) + (((src . dst) . moves) + (shuffle-size moves (max size (1+ src) (1+ dst)))))) + (define (call-size label nargs size) + (shuffle-size (get-shuffles label) + (max (+ (get-proc-slot label) nargs) size))) + (define (measure-cont label cont frame-sizes clause size) + (match cont + (($ $kfun) + (values #f #f #f)) + (($ $kclause) + (let ((frame-sizes (if clause + (intmap-add! frame-sizes clause size) + empty-intmap))) + (values frame-sizes label minimum-frame-size))) + (($ $kargs names vars ($ $continue k src exp)) + (values frame-sizes clause + (let ((size (max-size* vars size))) + (match exp + (($ $call proc args) + (call-size label (1+ (length args)) size)) + (($ $callk _ proc args) + (call-size label (1+ (length args)) size)) + (($ $values args) + (shuffle-size (get-shuffles label) size)) + (_ size))))) + (($ $kreceive) + (values frame-sizes clause + (shuffle-size (get-shuffles label) size))) + (($ $ktail) + (values (intmap-add! frame-sizes clause size) #f #f)))) + + (persistent-intmap (intmap-fold measure-cont cps #f #f #f))) + +(define (allocate-args cps) + (intmap-fold (lambda (label cont slots) + (match cont + (($ $kfun src meta self) + (intmap-add! slots self 0)) + (($ $kclause arity body alt) + (match (intmap-ref cps body) + (($ $kargs names vars) + (let lp ((vars vars) (slots slots) (n 1)) + (match vars + (() slots) + ((var . vars) + (let ((n (if (<= 253 n 255) 256 n))) + (lp vars + (intmap-add! slots var n) + (1+ n))))))))) + (_ slots))) + cps empty-intmap)) + +(define-inlinable (add-live-slot slot live-slots) + (logior live-slots (ash 1 slot))) + +(define-inlinable (kill-dead-slot slot live-slots) + (logand live-slots (lognot (ash 1 slot)))) + +(define-inlinable (compute-slot live-slots hint) + ;; Slots 253-255 are reserved for shuffling; see comments in + ;; assembler.scm. + (if (and hint (not (logbit? hint live-slots)) + (or (< hint 253) (> hint 255))) + hint + (let ((slot (find-first-zero live-slots))) + (if (or (< slot 253) (> slot 255)) + slot + (+ 256 (find-first-zero (ash live-slots -256))))))) + +(define (allocate-lazy-vars cps slots call-allocs live-in lazy) + (define (compute-live-slots slots label) + (intset-fold (lambda (var live) + (match (intmap-ref slots var (lambda (_) #f)) + (#f live) + (slot (add-live-slot slot live)))) + (intmap-ref live-in label) + 0)) + + (define (allocate var hint slots live) + (match (and hint (intmap-ref slots var (lambda (_) #f))) + (#f (if (intset-ref lazy var) + (let ((slot (compute-slot live hint))) + (values (intmap-add! slots var slot) + (add-live-slot slot live))) + (values slots live))) + (slot (values slots (add-live-slot slot live))))) + + (define (allocate* vars hints slots live) + (match (vector vars hints) + (#(() ()) slots) + (#((var . vars) (hint . hints)) + (let-values (((slots live) (allocate var hint slots live))) + (allocate* vars hints slots live))))) + + (define (get-proc-slot label) + (match (intmap-ref call-allocs label (lambda (_) #f)) + (#f 0) + (call (call-alloc-proc-slot call)))) + + (define (allocate-call label args slots) + (allocate* args (integers (get-proc-slot label) (length args)) + slots (compute-live-slots slots label))) + + (define (allocate-values label k args slots) + (match (intmap-ref cps k) + (($ $ktail) + (allocate* args (integers 1 (length args)) + slots (compute-live-slots slots label))) + (($ $kargs names vars) + (allocate* args + (map (cut intmap-ref slots <> (lambda (_) #f)) vars) + slots (compute-live-slots slots label))))) + + (define (allocate-lazy label cont slots) + (match cont + (($ $kargs names vars ($ $continue k src exp)) + (match exp + (($ $call proc args) + (allocate-call label (cons proc args) slots)) + (($ $callk _ proc args) + (allocate-call label (cons proc args) slots)) + (($ $values args) + (allocate-values label k args slots)) + (_ slots))) + (_ + slots))) + + ;; Sweep right to left to visit uses before definitions. + (persistent-intmap + (intmap-fold-right allocate-lazy cps slots))) + +(define (allocate-slots cps) + (let*-values (((defs uses) (compute-defs-and-uses cps)) + ((live-in live-out) (compute-live-variables cps defs uses)) + ((constants) (compute-constant-values cps)) + ((needs-slot) (compute-needs-slot cps defs uses)) + ((lazy) (compute-lazy-vars cps live-in live-out defs + needs-slot))) + + (define (empty-live-slots) + #b0) + + (define (compute-call-proc-slot live-slots) + (+ 2 (find-first-trailing-zero live-slots))) + + (define (compute-prompt-handler-proc-slot live-slots) + (if (zero? live-slots) + 0 + (1- (find-first-trailing-zero live-slots)))) + + (define (get-cont label) + (intmap-ref cps label)) + + (define (get-slot slots var) + (intmap-ref slots var (lambda (_) #f))) + + (define (get-slots slots vars) + (let lp ((vars vars)) + (match vars + ((var . vars) (cons (get-slot slots var) (lp vars))) + (_ '())))) + + (define (compute-live-slots* slots label live-vars) + (intset-fold (lambda (var live) + (match (get-slot slots var) + (#f live) + (slot (add-live-slot slot live)))) + (intmap-ref live-vars label) + 0)) + + (define (compute-live-in-slots slots label) + (compute-live-slots* slots label live-in)) + + (define (compute-live-out-slots slots label) + (compute-live-slots* slots label live-out)) + + (define (allocate var hint slots live) + (cond + ((not (intset-ref needs-slot var)) + (values slots live)) + ((get-slot slots var) + => (lambda (slot) + (values slots (add-live-slot slot live)))) + ((and (not hint) (intset-ref lazy var)) + (values slots live)) + (else + (let ((slot (compute-slot live hint))) + (values (intmap-add! slots var slot) + (add-live-slot slot live)))))) + + (define (allocate* vars hints slots live) + (match (vector vars hints) + (#(() ()) (values slots live)) + (#((var . vars) (hint . hints)) + (call-with-values (lambda () (allocate var hint slots live)) + (lambda (slots live) + (allocate* vars hints slots live)))))) + + (define (allocate-defs label vars slots) + (let ((live (compute-live-in-slots slots label)) + (live-vars (intmap-ref live-in label))) + (let lp ((vars vars) (slots slots) (live live)) + (match vars + (() (values slots live)) + ((var . vars) + (call-with-values (lambda () (allocate var #f slots live)) + (lambda (slots live) + (lp vars slots + (let ((slot (get-slot slots var))) + (if (and slot (not (intset-ref live-vars var))) + (kill-dead-slot slot live) + live)))))))))) + + ;; PRE-LIVE are the live slots coming into the term. POST-LIVE + ;; is the subset of PRE-LIVE that is still live after the term + ;; uses its inputs. + (define (allocate-call label k args slots call-allocs pre-live) + (match (get-cont k) + (($ $ktail) + (let ((tail-slots (integers 0 (length args)))) + (values (allocate* args tail-slots slots pre-live) + call-allocs))) + (($ $kreceive arity kargs) + (let*-values + (((post-live) (compute-live-out-slots slots label)) + ((proc-slot) (compute-call-proc-slot post-live)) + ((call-slots) (integers proc-slot (length args))) + ((slots pre-live) (allocate* args call-slots slots pre-live)) + ;; Allow the first result to be hinted by its use, but + ;; hint the remaining results to stay in place. This + ;; strikes a balance between avoiding shuffling, + ;; especially for unused extra values, and avoiding frame + ;; size growth due to sparse locals. + ((slots result-live) + (match (get-cont kargs) + (($ $kargs () ()) + (values slots post-live)) + (($ $kargs (_ . _) (_ . results)) + (let ((result-slots (integers (+ proc-slot 2) + (length results)))) + (allocate* results result-slots slots post-live))))) + ((dead-slot-map) (logand (1- (ash 1 (- proc-slot 2))) + (lognot post-live))) + ((call) (make-call-alloc proc-slot dead-slot-map))) + (values slots + (intmap-add! call-allocs label call)))))) + + (define (allocate-values label k args slots call-allocs) + (match (get-cont k) + (($ $ktail) + (values slots call-allocs)) + (($ $kargs (_) (dst)) + ;; When there is only one value in play, we allow the dst to be + ;; hinted (see compute-lazy-vars). If the src doesn't have a + ;; slot, then the actual slot for the dst would end up being + ;; decided by the call that args it. Because we don't know the + ;; slot, we can't really compute the parallel moves in that + ;; case, so just bail and rely on the bytecode emitter to + ;; handle the one-value case specially. + (match args + ((src) + (let ((post-live (compute-live-out-slots slots label))) + (values (allocate dst (get-slot slots src) slots post-live) + call-allocs))))) + (($ $kargs _ dst-vars) + (let ((src-slots (get-slots slots args)) + (post-live (compute-live-out-slots slots label))) + (values (allocate* dst-vars src-slots slots post-live) + call-allocs))))) + + (define (allocate-prompt label k handler slots call-allocs) + (match (get-cont handler) + (($ $kreceive arity kargs) + (let*-values + (((handler-live) (compute-live-in-slots slots handler)) + ((proc-slot) (compute-prompt-handler-proc-slot handler-live)) + ((dead-slot-map) (logand (1- (ash 1 (- proc-slot 2))) + (lognot handler-live))) + ((result-vars) (match (get-cont kargs) + (($ $kargs names vars) vars))) + ((value-slots) (integers (1+ proc-slot) (length result-vars))) + ((slots result-live) (allocate* result-vars value-slots + slots handler-live))) + (values slots + (intmap-add! call-allocs label + (make-call-alloc proc-slot dead-slot-map))))))) + + (define (allocate-cont label cont slots call-allocs) + (match cont + (($ $kargs names vars ($ $continue k src exp)) + (let-values (((slots live) (allocate-defs label vars slots))) + (match exp + (($ $call proc args) + (allocate-call label k (cons proc args) slots call-allocs live)) + (($ $callk _ proc args) + (allocate-call label k (cons proc args) slots call-allocs live)) + (($ $values args) + (allocate-values label k args slots call-allocs)) + (($ $prompt escape? tag handler) + (allocate-prompt label k handler slots call-allocs)) + (_ + (values slots call-allocs))))) + (_ + (values slots call-allocs)))) + + (call-with-values (lambda () + (let ((slots (allocate-args cps))) + (intmap-fold allocate-cont cps slots empty-intmap))) + (lambda (slots calls) + (let* ((slots (allocate-lazy-vars cps slots calls live-in lazy)) + (shuffles (compute-shuffles cps slots calls live-in)) + (frame-sizes (compute-frame-sizes cps slots calls shuffles))) + (make-allocation slots constants calls shuffles frame-sizes)))))) From 39777b11b379ce103dcefe01adba3a6d480c574f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 22 Jul 2015 17:01:53 +0200 Subject: [PATCH 030/865] Compile CPS2 directly to bytecode * module/language/cps2/spec.scm (cps2): Compile directly to bytecode. --- module/language/cps2/spec.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/module/language/cps2/spec.scm b/module/language/cps2/spec.scm index 5ab30ff6b..ac8f06439 100644 --- a/module/language/cps2/spec.scm +++ b/module/language/cps2/spec.scm @@ -21,7 +21,7 @@ (define-module (language cps2 spec) #:use-module (system base language) #:use-module (language cps2) - #:use-module (language cps2 compile-cps) + #:use-module (language cps2 compile-bytecode) #:export (cps2)) (define* (write-cps exp #:optional (port (current-output-port))) @@ -32,6 +32,6 @@ #:reader (lambda (port env) (read port)) #:printer write-cps #:parser parse-cps - #:compilers `((cps . ,compile-cps)) + #:compilers `((bytecode . ,compile-bytecode)) #:for-humans? #f ) From 0d4c9377222ebb45c673b413c0a1f7abd993f8ed Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 22 Jul 2015 17:15:06 +0200 Subject: [PATCH 031/865] Remove CPS1 language * module/language/cps.scm: * module/language/cps/compile-bytecode.scm: * module/language/cps/dfg.scm: * module/language/cps/renumber.scm: * module/language/cps/slot-allocation.scm: * module/language/cps/spec.scm: * module/language/cps/verify.scm: * module/language/cps2/compile-cps.scm: Delete. * module/Makefile.am: Remove deleted files. --- module/Makefile.am | 10 +- module/language/cps.scm | 620 ---------------- module/language/cps/compile-bytecode.scm | 453 ------------ module/language/cps/dfg.scm | 904 ----------------------- module/language/cps/renumber.scm | 343 --------- module/language/cps/slot-allocation.scm | 689 ----------------- module/language/cps/spec.scm | 37 - module/language/cps/verify.scm | 195 ----- module/language/cps2/compile-cps.scm | 129 ---- 9 files changed, 1 insertion(+), 3379 deletions(-) delete mode 100644 module/language/cps.scm delete mode 100644 module/language/cps/compile-bytecode.scm delete mode 100644 module/language/cps/dfg.scm delete mode 100644 module/language/cps/renumber.scm delete mode 100644 module/language/cps/slot-allocation.scm delete mode 100644 module/language/cps/spec.scm delete mode 100644 module/language/cps/verify.scm delete mode 100644 module/language/cps2/compile-cps.scm diff --git a/module/Makefile.am b/module/Makefile.am index 801f466cb..c53f9e466 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -122,20 +122,12 @@ TREE_IL_LANG_SOURCES = \ language/tree-il/spec.scm CPS_LANG_SOURCES = \ - language/cps.scm \ - language/cps/compile-bytecode.scm \ - language/cps/dfg.scm \ - language/cps/primitives.scm \ - language/cps/renumber.scm \ - language/cps/slot-allocation.scm \ - language/cps/spec.scm \ - language/cps/verify.scm + language/cps/primitives.scm CPS2_LANG_SOURCES = \ language/cps2.scm \ language/cps2/closure-conversion.scm \ language/cps2/compile-bytecode.scm \ - language/cps2/compile-cps.scm \ language/cps2/constructors.scm \ language/cps2/contification.scm \ language/cps2/cse.scm \ diff --git a/module/language/cps.scm b/module/language/cps.scm deleted file mode 100644 index befa20f66..000000000 --- a/module/language/cps.scm +++ /dev/null @@ -1,620 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; This is the continuation-passing style (CPS) intermediate language -;;; (IL) for Guile. -;;; -;;; There are two kinds of terms in CPS: terms that bind continuations, -;;; and terms that call continuations. -;;; -;;; $letk binds a set of mutually recursive continuations, each one an -;;; instance of $cont. A $cont declares the name of a continuation, and -;;; then contains as a subterm the particular continuation instance: -;;; $kargs for continuations that bind values, $ktail for the tail -;;; continuation, etc. -;;; -;;; $continue nodes call continuations. The expression contained in the -;;; $continue node determines the value or values that are passed to the -;;; target continuation: $const to pass a constant value, $values to -;;; pass multiple named values, etc. $continue nodes also record the source at which -;;; -;;; Additionally there is $letrec, a term that binds mutually recursive -;;; functions. The contification pass will turn $letrec into $letk if -;;; it can do so. Otherwise, the closure conversion pass will desugar -;;; $letrec into an equivalent sequence of make-closure primcalls and -;;; subsequent initializations of the captured variables of the -;;; closures. You can think of $letrec as pertaining to "high CPS", -;;; whereas later passes will only see "low CPS", which does not have -;;; $letrec. -;;; -;;; This particular formulation of CPS was inspired by Andrew Kennedy's -;;; 2007 paper, "Compiling with Continuations, Continued". All Guile -;;; hackers should read that excellent paper! As in Kennedy's paper, -;;; continuations are second-class, and may be thought of as basic block -;;; labels. All values are bound to variables using continuation calls: -;;; even constants! -;;; -;;; There are some Guile-specific quirks as well: -;;; -;;; - $kreceive represents a continuation that receives multiple values, -;;; but which truncates them to some number of required values, -;;; possibly with a rest list. -;;; -;;; - $kfun labels an entry point for a $fun (a function), and -;;; contains a $ktail representing the formal argument which is the -;;; function's continuation. -;;; -;;; - $kfun also contain a $kclause continuation, corresponding to -;;; the first case-lambda clause of the function. $kclause actually -;;; contains the clause body, and the subsequent clause (if any). -;;; This is because the $kclause logically matches or doesn't match -;;; a given set of actual arguments against a formal arity, then -;;; proceeds to a "body" continuation (which is a $kargs). -;;; -;;; That's to say that a $fun can be matched like this: -;;; -;;; (match f -;;; (($ $fun -;;; ($ $cont kfun -;;; ($ $kfun src meta self ($ $cont ktail ($ $ktail)) -;;; ($ $kclause arity -;;; ($ $cont kbody ($ $kargs names syms body)) -;;; alternate)))) -;;; #t)) -;;; -;;; A $continue to ktail is in tail position. $kfun, $kclause, -;;; and $ktail will never be seen elsewhere in a CPS term. -;;; -;;; - $prompt continues to the body of the prompt, having pushed on a -;;; prompt whose handler will continue at its "handler" -;;; continuation. The continuation of the prompt is responsible for -;;; popping the prompt. -;;; -;;; In summary: -;;; -;;; - $letk, $letrec, and $continue are terms. -;;; -;;; - $cont is a continuation, containing a continuation body ($kargs, -;;; $ktail, etc). -;;; -;;; - $continue terms contain an expression ($call, $const, $fun, -;;; etc). -;;; -;;; See (language tree-il compile-cps) for details on how Tree-IL -;;; converts to CPS. -;;; -;;; Code: - -(define-module (language cps) - #:use-module (ice-9 match) - #:use-module ((srfi srfi-1) #:select (fold)) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-9 gnu) - #:use-module (srfi srfi-11) - #:export (;; Helper. - $arity - make-$arity - - ;; Terms. - $letk $continue - - ;; Continuations. - $cont - - ;; Continuation bodies. - $kreceive $kargs $kfun $ktail $kclause - - ;; Expressions. - $const $prim $fun $rec $closure $branch - $call $callk $primcall $values $prompt - - ;; First-order CPS root. - $program - - ;; Fresh names. - label-counter var-counter - fresh-label fresh-var - with-fresh-name-state compute-max-label-and-var - let-fresh - - ;; Building macros. - build-cps-term build-cps-cont build-cps-exp - rewrite-cps-term rewrite-cps-cont rewrite-cps-exp - - ;; Misc. - parse-cps unparse-cps - make-global-cont-folder make-local-cont-folder - fold-conts fold-local-conts - visit-cont-successors)) - -;; FIXME: Use SRFI-99, when Guile adds it. -(define-syntax define-record-type* - (lambda (x) - (define (id-append ctx . syms) - (datum->syntax ctx (apply symbol-append (map syntax->datum syms)))) - (syntax-case x () - ((_ name field ...) - (and (identifier? #'name) (and-map identifier? #'(field ...))) - (with-syntax ((cons (id-append #'name #'make- #'name)) - (pred (id-append #'name #'name #'?)) - ((getter ...) (map (lambda (f) - (id-append f #'name #'- f)) - #'(field ...)))) - #'(define-record-type name - (cons field ...) - pred - (field getter) - ...)))))) - -(define-syntax-rule (define-cps-type name field ...) - (begin - (define-record-type* name field ...) - (set-record-type-printer! name print-cps))) - -(define (print-cps exp port) - (format port "#" (unparse-cps exp))) - -;; Helper. -(define-record-type* $arity req opt rest kw allow-other-keys?) - -;; Terms. -(define-cps-type $letk conts body) -(define-cps-type $continue k src exp) - -;; Continuations -(define-cps-type $cont k cont) -(define-cps-type $kreceive arity k) -(define-cps-type $kargs names syms body) -(define-cps-type $kfun src meta self tail clause) -(define-cps-type $ktail) -(define-cps-type $kclause arity cont alternate) - -;; Expressions. -(define-cps-type $const val) -(define-cps-type $prim name) -(define-cps-type $fun body) ; Higher-order. -(define-cps-type $rec names syms funs) ; Higher-order. -(define-cps-type $closure label nfree) ; First-order. -(define-cps-type $branch k exp) -(define-cps-type $call proc args) -(define-cps-type $callk k proc args) ; First-order. -(define-cps-type $primcall name args) -(define-cps-type $values args) -(define-cps-type $prompt escape? tag handler) - -;; The root of a higher-order CPS term is $cont containing a $kfun. The -;; root of a first-order CPS term is a $program. -(define-cps-type $program funs) - -(define label-counter (make-parameter #f)) -(define var-counter (make-parameter #f)) - -(define (fresh-label) - (let ((count (or (label-counter) - (error "fresh-label outside with-fresh-name-state")))) - (label-counter (1+ count)) - count)) - -(define (fresh-var) - (let ((count (or (var-counter) - (error "fresh-var outside with-fresh-name-state")))) - (var-counter (1+ count)) - count)) - -(define-syntax-rule (let-fresh (label ...) (var ...) body ...) - (let ((label (fresh-label)) ... - (var (fresh-var)) ...) - body ...)) - -(define-syntax-rule (with-fresh-name-state fun body ...) - (call-with-values (lambda () (compute-max-label-and-var fun)) - (lambda (max-label max-var) - (parameterize ((label-counter (1+ max-label)) - (var-counter (1+ max-var))) - body ...)))) - -(define-syntax build-arity - (syntax-rules (unquote) - ((_ (unquote exp)) exp) - ((_ (req opt rest kw allow-other-keys?)) - (make-$arity req opt rest kw allow-other-keys?)))) - -(define-syntax build-cont-body - (syntax-rules (unquote $kreceive $kargs $kfun $ktail $kclause) - ((_ (unquote exp)) - exp) - ((_ ($kreceive req rest kargs)) - (make-$kreceive (make-$arity req '() rest '() #f) kargs)) - ((_ ($kargs (name ...) (unquote syms) body)) - (make-$kargs (list name ...) syms (build-cps-term body))) - ((_ ($kargs (name ...) (sym ...) body)) - (make-$kargs (list name ...) (list sym ...) (build-cps-term body))) - ((_ ($kargs names syms body)) - (make-$kargs names syms (build-cps-term body))) - ((_ ($kfun src meta self tail clause)) - (make-$kfun src meta self (build-cps-cont tail) (build-cps-cont clause))) - ((_ ($ktail)) - (make-$ktail)) - ((_ ($kclause arity cont alternate)) - (make-$kclause (build-arity arity) (build-cps-cont cont) - (build-cps-cont alternate))))) - -(define-syntax build-cps-cont - (syntax-rules (unquote) - ((_ (unquote exp)) exp) - ((_ (k cont)) (make-$cont k (build-cont-body cont))))) - -(define-syntax build-cps-exp - (syntax-rules (unquote - $const $prim $fun $rec $closure $branch - $call $callk $primcall $values $prompt) - ((_ (unquote exp)) exp) - ((_ ($const val)) (make-$const val)) - ((_ ($prim name)) (make-$prim name)) - ((_ ($fun body)) (make-$fun (build-cps-cont body))) - ((_ ($rec names gensyms funs)) (make-$rec names gensyms funs)) - ((_ ($closure k nfree)) (make-$closure k nfree)) - ((_ ($call proc (unquote args))) (make-$call proc args)) - ((_ ($call proc (arg ...))) (make-$call proc (list arg ...))) - ((_ ($call proc args)) (make-$call proc args)) - ((_ ($callk k proc (unquote args))) (make-$callk k proc args)) - ((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...))) - ((_ ($callk k proc args)) (make-$callk k proc args)) - ((_ ($primcall name (unquote args))) (make-$primcall name args)) - ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...))) - ((_ ($primcall name args)) (make-$primcall name args)) - ((_ ($values (unquote args))) (make-$values args)) - ((_ ($values (arg ...))) (make-$values (list arg ...))) - ((_ ($values args)) (make-$values args)) - ((_ ($branch k exp)) (make-$branch k (build-cps-exp exp))) - ((_ ($prompt escape? tag handler)) - (make-$prompt escape? tag handler)))) - -(define-syntax build-cps-term - (syntax-rules (unquote $letk $letk* $letconst $program $continue) - ((_ (unquote exp)) - exp) - ((_ ($letk (unquote conts) body)) - (make-$letk conts (build-cps-term body))) - ((_ ($letk (cont ...) body)) - (make-$letk (list (build-cps-cont cont) ...) - (build-cps-term body))) - ((_ ($letk* () body)) - (build-cps-term body)) - ((_ ($letk* (cont conts ...) body)) - (build-cps-term ($letk (cont) ($letk* (conts ...) body)))) - ((_ ($letconst () body)) - (build-cps-term body)) - ((_ ($letconst ((name sym val) tail ...) body)) - (let-fresh (kconst) () - (build-cps-term - ($letk ((kconst ($kargs (name) (sym) ($letconst (tail ...) body)))) - ($continue kconst (let ((props (source-properties val))) - (and (pair? props) props)) - ($const val)))))) - ((_ ($program (unquote conts))) - (make-$program conts)) - ((_ ($program (cont ...))) - (make-$program (list (build-cps-cont cont) ...))) - ((_ ($program conts)) - (make-$program conts)) - ((_ ($continue k src exp)) - (make-$continue k src (build-cps-exp exp))))) - -(define-syntax-rule (rewrite-cps-term x (pat body) ...) - (match x - (pat (build-cps-term body)) ...)) -(define-syntax-rule (rewrite-cps-cont x (pat body) ...) - (match x - (pat (build-cps-cont body)) ...)) -(define-syntax-rule (rewrite-cps-exp x (pat body) ...) - (match x - (pat (build-cps-exp body)) ...)) - -(define (parse-cps exp) - (define (src exp) - (let ((props (source-properties exp))) - (and (pair? props) props))) - (match exp - ;; Continuations. - (('letconst k (name sym c) body) - (build-cps-term - ($letk ((k ($kargs (name) (sym) - ,(parse-cps body)))) - ($continue k (src exp) ($const c))))) - (('let k (name sym val) body) - (build-cps-term - ($letk ((k ($kargs (name) (sym) - ,(parse-cps body)))) - ,(parse-cps val)))) - (('letk (cont ...) body) - (build-cps-term - ($letk ,(map parse-cps cont) ,(parse-cps body)))) - (('k sym body) - (build-cps-cont - (sym ,(parse-cps body)))) - (('kreceive req rest k) - (build-cont-body ($kreceive req rest k))) - (('kargs names syms body) - (build-cont-body ($kargs names syms ,(parse-cps body)))) - (('kfun src meta self tail clause) - (build-cont-body - ($kfun (src exp) meta self ,(parse-cps tail) - ,(and=> clause parse-cps)))) - (('ktail) - (build-cont-body - ($ktail))) - (('kclause (req opt rest kw allow-other-keys?) body) - (build-cont-body - ($kclause (req opt rest kw allow-other-keys?) - ,(parse-cps body) - ,#f))) - (('kclause (req opt rest kw allow-other-keys?) body alternate) - (build-cont-body - ($kclause (req opt rest kw allow-other-keys?) - ,(parse-cps body) - ,(parse-cps alternate)))) - (('kseq body) - (build-cont-body ($kargs () () ,(parse-cps body)))) - - ;; Calls. - (('continue k exp) - (build-cps-term ($continue k (src exp) ,(parse-cps exp)))) - (('const exp) - (build-cps-exp ($const exp))) - (('prim name) - (build-cps-exp ($prim name))) - (('fun body) - (build-cps-exp ($fun ,(parse-cps body)))) - (('closure k nfree) - (build-cps-exp ($closure k nfree))) - (('rec (name sym fun) ...) - (build-cps-exp ($rec name sym (map parse-cps fun)))) - (('program (cont ...)) - (build-cps-term ($program ,(map parse-cps cont)))) - (('call proc arg ...) - (build-cps-exp ($call proc arg))) - (('callk k proc arg ...) - (build-cps-exp ($callk k proc arg))) - (('primcall name arg ...) - (build-cps-exp ($primcall name arg))) - (('branch k exp) - (build-cps-exp ($branch k ,(parse-cps exp)))) - (('values arg ...) - (build-cps-exp ($values arg))) - (('prompt escape? tag handler) - (build-cps-exp ($prompt escape? tag handler))) - (_ - (error "unexpected cps" exp)))) - -(define (unparse-cps exp) - (match exp - ;; Continuations. - (($ $letk (($ $cont k ($ $kargs (name) (sym) body))) - ($ $continue k src ($ $const c))) - `(letconst ,k (,name ,sym ,c) - ,(unparse-cps body))) - (($ $letk (($ $cont k ($ $kargs (name) (sym) body))) val) - `(let ,k (,name ,sym ,(unparse-cps val)) - ,(unparse-cps body))) - (($ $letk conts body) - `(letk ,(map unparse-cps conts) ,(unparse-cps body))) - (($ $cont sym body) - `(k ,sym ,(unparse-cps body))) - (($ $kreceive ($ $arity req () rest '() #f) k) - `(kreceive ,req ,rest ,k)) - (($ $kargs () () body) - `(kseq ,(unparse-cps body))) - (($ $kargs names syms body) - `(kargs ,names ,syms ,(unparse-cps body))) - (($ $kfun src meta self tail clause) - `(kfun ,meta ,self ,(unparse-cps tail) ,(unparse-cps clause))) - (($ $ktail) - `(ktail)) - (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alternate) - `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,(unparse-cps body) - . ,(if alternate (list (unparse-cps alternate)) '()))) - - ;; Calls. - (($ $continue k src exp) - `(continue ,k ,(unparse-cps exp))) - (($ $const val) - `(const ,val)) - (($ $prim name) - `(prim ,name)) - (($ $fun body) - `(fun ,(unparse-cps body))) - (($ $closure k nfree) - `(closure ,k ,nfree)) - (($ $rec names syms funs) - `(rec ,@(map (lambda (name sym fun) - (list name sym (unparse-cps fun))) - names syms funs))) - (($ $program conts) - `(program ,(map unparse-cps conts))) - (($ $call proc args) - `(call ,proc ,@args)) - (($ $callk k proc args) - `(callk ,k ,proc ,@args)) - (($ $primcall name args) - `(primcall ,name ,@args)) - (($ $branch k exp) - `(branch ,k ,(unparse-cps exp))) - (($ $values args) - `(values ,@args)) - (($ $prompt escape? tag handler) - `(prompt ,escape? ,tag ,handler)) - (_ - (error "unexpected cps" exp)))) - -(define-syntax-rule (make-global-cont-folder seed ...) - (lambda (proc cont seed ...) - (define (cont-folder cont seed ...) - (match cont - (($ $cont k cont) - (let-values (((seed ...) (proc k cont seed ...))) - (match cont - (($ $kargs names syms body) - (term-folder body seed ...)) - - (($ $kfun src meta self tail clause) - (let-values (((seed ...) (cont-folder tail seed ...))) - (if clause - (cont-folder clause seed ...) - (values seed ...)))) - - (($ $kclause arity body alternate) - (let-values (((seed ...) (cont-folder body seed ...))) - (if alternate - (cont-folder alternate seed ...) - (values seed ...)))) - - (_ (values seed ...))))))) - - (define (fun-folder fun seed ...) - (match fun - (($ $fun body) - (cont-folder body seed ...)))) - - (define (term-folder term seed ...) - (match term - (($ $letk conts body) - (let-values (((seed ...) (term-folder body seed ...))) - (let lp ((conts conts) (seed seed) ...) - (if (null? conts) - (values seed ...) - (let-values (((seed ...) (cont-folder (car conts) seed ...))) - (lp (cdr conts) seed ...)))))) - - (($ $continue k src exp) - (match exp - (($ $fun) (fun-folder exp seed ...)) - (($ $rec names syms funs) - (let lp ((funs funs) (seed seed) ...) - (if (null? funs) - (values seed ...) - (let-values (((seed ...) (fun-folder (car funs) seed ...))) - (lp (cdr funs) seed ...))))) - (_ (values seed ...)))))) - - (cont-folder cont seed ...))) - -(define-syntax-rule (make-local-cont-folder seed ...) - (lambda (proc cont seed ...) - (define (cont-folder cont seed ...) - (match cont - (($ $cont k (and cont ($ $kargs names syms body))) - (let-values (((seed ...) (proc k cont seed ...))) - (term-folder body seed ...))) - (($ $cont k cont) - (proc k cont seed ...)))) - (define (term-folder term seed ...) - (match term - (($ $letk conts body) - (let-values (((seed ...) (term-folder body seed ...))) - (let lp ((conts conts) (seed seed) ...) - (match conts - (() (values seed ...)) - ((cont) (cont-folder cont seed ...)) - ((cont . conts) - (let-values (((seed ...) (cont-folder cont seed ...))) - (lp conts seed ...))))))) - (_ (values seed ...)))) - (define (clause-folder clause seed ...) - (match clause - (($ $cont k (and cont ($ $kclause arity body alternate))) - (let-values (((seed ...) (proc k cont seed ...))) - (if alternate - (let-values (((seed ...) (cont-folder body seed ...))) - (clause-folder alternate seed ...)) - (cont-folder body seed ...)))))) - (match cont - (($ $cont k (and cont ($ $kfun src meta self tail clause))) - (let*-values (((seed ...) (proc k cont seed ...)) - ((seed ...) (if clause - (clause-folder clause seed ...) - (values seed ...)))) - (cont-folder tail seed ...)))))) - -(define (compute-max-label-and-var fun) - (match fun - (($ $cont) - ((make-global-cont-folder max-label max-var) - (lambda (label cont max-label max-var) - (values (max label max-label) - (match cont - (($ $kargs names vars body) - (fold max max-var vars)) - (($ $kfun src meta self) - (max self max-var)) - (_ max-var)))) - fun -1 -1)) - (($ $program conts) - (define (fold/2 proc in s0 s1) - (if (null? in) - (values s0 s1) - (let-values (((s0 s1) (proc (car in) s0 s1))) - (fold/2 proc (cdr in) s0 s1)))) - (let lp ((conts conts) (max-label -1) (max-var -1)) - (if (null? conts) - (values max-label max-var) - (call-with-values (lambda () - ((make-local-cont-folder max-label max-var) - (lambda (label cont max-label max-var) - (values (max label max-label) - (match cont - (($ $kargs names vars body) - (fold max max-var vars)) - (($ $kfun src meta self) - (max self max-var)) - (_ max-var)))) - (car conts) max-label max-var)) - (lambda (max-label max-var) - (lp (cdr conts) max-label max-var)))))))) - -(define (fold-conts proc seed fun) - ((make-global-cont-folder seed) proc fun seed)) - -(define (fold-local-conts proc seed fun) - ((make-local-cont-folder seed) proc fun seed)) - -(define (visit-cont-successors proc cont) - (match cont - (($ $kargs names syms body) - (let lp ((body body)) - (match body - (($ $letk conts body) (lp body)) - (($ $continue k src exp) - (match exp - (($ $prompt escape? tag handler) (proc k handler)) - (($ $branch kt) (proc k kt)) - (_ (proc k))))))) - - (($ $kreceive arity k) (proc k)) - - (($ $kclause arity ($ $cont kbody) #f) (proc kbody)) - - (($ $kclause arity ($ $cont kbody) ($ $cont kalt)) (proc kbody kalt)) - - (($ $kfun src meta self tail ($ $cont clause)) (proc clause)) - - (($ $kfun src meta self tail #f) (proc)) - - (($ $ktail) (proc)))) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm deleted file mode 100644 index c92c15d01..000000000 --- a/module/language/cps/compile-bytecode.scm +++ /dev/null @@ -1,453 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; Compiling CPS to bytecode. The result is in the bytecode language, -;;; which happens to be an ELF image as a bytecode. -;;; -;;; Code: - -(define-module (language cps compile-bytecode) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (language cps) - #:use-module (language cps dfg) - #:use-module (language cps primitives) - #:use-module (language cps renumber) - #:use-module (language cps slot-allocation) - #:use-module (system vm assembler) - #:export (compile-bytecode)) - -(define (kw-arg-ref args kw default) - (match (memq kw args) - ((_ val . _) val) - (_ default))) - -(define (compile-fun f asm) - (let* ((dfg (compute-dfg f #:global? #f)) - (allocation (allocate-slots f dfg))) - (define (maybe-slot sym) - (lookup-maybe-slot sym allocation)) - - (define (slot sym) - (lookup-slot sym allocation)) - - (define (constant sym) - (lookup-constant-value sym allocation)) - - (define (maybe-mov dst src) - (unless (= dst src) - (emit-mov asm dst src))) - - (define (maybe-load-constant slot src) - (call-with-values (lambda () - (lookup-maybe-constant-value src allocation)) - (lambda (has-const? val) - (and has-const? - (begin - (emit-load-constant asm slot val) - #t))))) - - (define (compile-entry) - (let ((label (dfg-min-label dfg))) - (match (lookup-cont label dfg) - (($ $kfun src meta self tail clause) - (when src - (emit-source asm src)) - (emit-begin-program asm label meta) - (compile-clause (1+ label)) - (emit-end-program asm))))) - - (define (compile-clause label) - (match (lookup-cont label dfg) - (($ $kclause ($ $arity req opt rest kw allow-other-keys?) - body alternate) - (let* ((kw-indices (map (match-lambda - ((key name sym) - (cons key (lookup-slot sym allocation)))) - kw)) - (nlocals (lookup-nlocals label allocation))) - (emit-label asm label) - (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys? - nlocals - (match alternate (#f #f) (($ $cont alt) alt))) - (let ((next (compile-body (1+ label) nlocals))) - (emit-end-arity asm) - (match alternate - (($ $cont alt) - (unless (eq? next alt) - (error "unexpected k" alt)) - (compile-clause next)) - (#f - (unless (= next (+ (dfg-min-label dfg) (dfg-label-count dfg))) - (error "unexpected end of clauses"))))))))) - - (define (compile-body label nlocals) - (let compile-cont ((label label)) - (if (eq? label (+ (dfg-min-label dfg) (dfg-label-count dfg))) - label - (match (lookup-cont label dfg) - (($ $kclause) label) - (($ $kargs names vars term) - (emit-label asm label) - (for-each (lambda (name var) - (let ((slot (maybe-slot var))) - (when slot - (emit-definition asm name slot)))) - names vars) - (let find-exp ((term term)) - (match term - (($ $letk conts term) - (find-exp term)) - (($ $continue k src exp) - (when src - (emit-source asm src)) - (compile-expression label k exp nlocals) - (compile-cont (1+ label)))))) - (_ - (emit-label asm label) - (compile-cont (1+ label))))))) - - (define (compile-expression label k exp nlocals) - (let* ((fallthrough? (= k (1+ label)))) - (define (maybe-emit-jump) - (unless fallthrough? - (emit-br asm k))) - (match (lookup-cont k dfg) - (($ $ktail) - (compile-tail label exp)) - (($ $kargs (name) (sym)) - (let ((dst (maybe-slot sym))) - (when dst - (compile-value label exp dst nlocals))) - (maybe-emit-jump)) - (($ $kargs () ()) - (match exp - (($ $branch kt exp) - (compile-test label exp kt k (1+ label))) - (_ - (compile-effect label exp k nlocals) - (maybe-emit-jump)))) - (($ $kargs names syms) - (compile-values label exp syms) - (maybe-emit-jump)) - (($ $kreceive ($ $arity req () rest () #f) kargs) - (compile-trunc label k exp (length req) - (and rest - (match (lookup-cont kargs dfg) - (($ $kargs names (_ ... rest)) rest))) - nlocals) - (unless (and fallthrough? (= kargs (1+ k))) - (emit-br asm kargs)))))) - - (define (compile-tail label exp) - ;; There are only three kinds of expressions in tail position: - ;; tail calls, multiple-value returns, and single-value returns. - (match exp - (($ $call proc args) - (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) - (lookup-parallel-moves label allocation)) - (let ((tail-slots (cdr (iota (1+ (length args)))))) - (for-each maybe-load-constant tail-slots args)) - (emit-tail-call asm (1+ (length args)))) - (($ $callk k proc args) - (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) - (lookup-parallel-moves label allocation)) - (let ((tail-slots (cdr (iota (1+ (length args)))))) - (for-each maybe-load-constant tail-slots args)) - (emit-tail-call-label asm (1+ (length args)) k)) - (($ $values ()) - (emit-reset-frame asm 1) - (emit-return-values asm)) - (($ $values (arg)) - (if (maybe-slot arg) - (emit-return asm (slot arg)) - (begin - (emit-load-constant asm 1 (constant arg)) - (emit-return asm 1)))) - (($ $values args) - (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) - (lookup-parallel-moves label allocation)) - (let ((tail-slots (cdr (iota (1+ (length args)))))) - (for-each maybe-load-constant tail-slots args)) - (emit-reset-frame asm (1+ (length args))) - (emit-return-values asm)) - (($ $primcall 'return (arg)) - (emit-return asm (slot arg))))) - - (define (compile-value label exp dst nlocals) - (match exp - (($ $values (arg)) - (or (maybe-load-constant dst arg) - (maybe-mov dst (slot arg)))) - (($ $const exp) - (emit-load-constant asm dst exp)) - (($ $closure k 0) - (emit-load-static-procedure asm dst k)) - (($ $closure k nfree) - (emit-make-closure asm dst k nfree)) - (($ $primcall 'current-module) - (emit-current-module asm dst)) - (($ $primcall 'cached-toplevel-box (scope name bound?)) - (emit-cached-toplevel-box asm dst (constant scope) (constant name) - (constant bound?))) - (($ $primcall 'cached-module-box (mod name public? bound?)) - (emit-cached-module-box asm dst (constant mod) (constant name) - (constant public?) (constant bound?))) - (($ $primcall 'resolve (name bound?)) - (emit-resolve asm dst (constant bound?) (slot name))) - (($ $primcall 'free-ref (closure idx)) - (emit-free-ref asm dst (slot closure) (constant idx))) - (($ $primcall 'vector-ref (vector index)) - (emit-vector-ref asm dst (slot vector) (slot index))) - (($ $primcall 'make-vector (length init)) - (emit-make-vector asm dst (slot length) (slot init))) - (($ $primcall 'make-vector/immediate (length init)) - (emit-make-vector/immediate asm dst (constant length) (slot init))) - (($ $primcall 'vector-ref/immediate (vector index)) - (emit-vector-ref/immediate asm dst (slot vector) (constant index))) - (($ $primcall 'allocate-struct (vtable nfields)) - (emit-allocate-struct asm dst (slot vtable) (slot nfields))) - (($ $primcall 'allocate-struct/immediate (vtable nfields)) - (emit-allocate-struct/immediate asm dst (slot vtable) (constant nfields))) - (($ $primcall 'struct-ref (struct n)) - (emit-struct-ref asm dst (slot struct) (slot n))) - (($ $primcall 'struct-ref/immediate (struct n)) - (emit-struct-ref/immediate asm dst (slot struct) (constant n))) - (($ $primcall 'builtin-ref (name)) - (emit-builtin-ref asm dst (constant name))) - (($ $primcall 'bv-u8-ref (bv idx)) - (emit-bv-u8-ref asm dst (slot bv) (slot idx))) - (($ $primcall 'bv-s8-ref (bv idx)) - (emit-bv-s8-ref asm dst (slot bv) (slot idx))) - (($ $primcall 'bv-u16-ref (bv idx)) - (emit-bv-u16-ref asm dst (slot bv) (slot idx))) - (($ $primcall 'bv-s16-ref (bv idx)) - (emit-bv-s16-ref asm dst (slot bv) (slot idx))) - (($ $primcall 'bv-u32-ref (bv idx val)) - (emit-bv-u32-ref asm dst (slot bv) (slot idx))) - (($ $primcall 'bv-s32-ref (bv idx val)) - (emit-bv-s32-ref asm dst (slot bv) (slot idx))) - (($ $primcall 'bv-u64-ref (bv idx val)) - (emit-bv-u64-ref asm dst (slot bv) (slot idx))) - (($ $primcall 'bv-s64-ref (bv idx val)) - (emit-bv-s64-ref asm dst (slot bv) (slot idx))) - (($ $primcall 'bv-f32-ref (bv idx val)) - (emit-bv-f32-ref asm dst (slot bv) (slot idx))) - (($ $primcall 'bv-f64-ref (bv idx val)) - (emit-bv-f64-ref asm dst (slot bv) (slot idx))) - (($ $primcall name args) - ;; FIXME: Inline all the cases. - (let ((inst (prim-instruction name))) - (emit-text asm `((,inst ,dst ,@(map slot args)))))))) - - (define (compile-effect label exp k nlocals) - (match exp - (($ $values ()) #f) - (($ $prompt escape? tag handler) - (match (lookup-cont handler dfg) - (($ $kreceive ($ $arity req () rest () #f) khandler-body) - (let ((receive-args (gensym "handler")) - (nreq (length req)) - (proc-slot (lookup-call-proc-slot handler allocation))) - (emit-prompt asm (slot tag) escape? proc-slot receive-args) - (emit-br asm k) - (emit-label asm receive-args) - (unless (and rest (zero? nreq)) - (emit-receive-values asm proc-slot (->bool rest) nreq)) - (when (and rest - (match (lookup-cont khandler-body dfg) - (($ $kargs names (_ ... rest)) - (maybe-slot rest)))) - (emit-bind-rest asm (+ proc-slot 1 nreq))) - (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) - (lookup-parallel-moves handler allocation)) - (emit-reset-frame asm nlocals) - (emit-br asm khandler-body))))) - (($ $primcall 'cache-current-module! (sym scope)) - (emit-cache-current-module! asm (slot sym) (constant scope))) - (($ $primcall 'free-set! (closure idx value)) - (emit-free-set! asm (slot closure) (slot value) (constant idx))) - (($ $primcall 'box-set! (box value)) - (emit-box-set! asm (slot box) (slot value))) - (($ $primcall 'struct-set! (struct index value)) - (emit-struct-set! asm (slot struct) (slot index) (slot value))) - (($ $primcall 'struct-set!/immediate (struct index value)) - (emit-struct-set!/immediate asm (slot struct) (constant index) (slot value))) - (($ $primcall 'vector-set! (vector index value)) - (emit-vector-set! asm (slot vector) (slot index) (slot value))) - (($ $primcall 'vector-set!/immediate (vector index value)) - (emit-vector-set!/immediate asm (slot vector) (constant index) - (slot value))) - (($ $primcall 'set-car! (pair value)) - (emit-set-car! asm (slot pair) (slot value))) - (($ $primcall 'set-cdr! (pair value)) - (emit-set-cdr! asm (slot pair) (slot value))) - (($ $primcall 'define! (sym value)) - (emit-define! asm (slot sym) (slot value))) - (($ $primcall 'push-fluid (fluid val)) - (emit-push-fluid asm (slot fluid) (slot val))) - (($ $primcall 'pop-fluid ()) - (emit-pop-fluid asm)) - (($ $primcall 'wind (winder unwinder)) - (emit-wind asm (slot winder) (slot unwinder))) - (($ $primcall 'bv-u8-set! (bv idx val)) - (emit-bv-u8-set! asm (slot bv) (slot idx) (slot val))) - (($ $primcall 'bv-s8-set! (bv idx val)) - (emit-bv-s8-set! asm (slot bv) (slot idx) (slot val))) - (($ $primcall 'bv-u16-set! (bv idx val)) - (emit-bv-u16-set! asm (slot bv) (slot idx) (slot val))) - (($ $primcall 'bv-s16-set! (bv idx val)) - (emit-bv-s16-set! asm (slot bv) (slot idx) (slot val))) - (($ $primcall 'bv-u32-set! (bv idx val)) - (emit-bv-u32-set! asm (slot bv) (slot idx) (slot val))) - (($ $primcall 'bv-s32-set! (bv idx val)) - (emit-bv-s32-set! asm (slot bv) (slot idx) (slot val))) - (($ $primcall 'bv-u64-set! (bv idx val)) - (emit-bv-u64-set! asm (slot bv) (slot idx) (slot val))) - (($ $primcall 'bv-s64-set! (bv idx val)) - (emit-bv-s64-set! asm (slot bv) (slot idx) (slot val))) - (($ $primcall 'bv-f32-set! (bv idx val)) - (emit-bv-f32-set! asm (slot bv) (slot idx) (slot val))) - (($ $primcall 'bv-f64-set! (bv idx val)) - (emit-bv-f64-set! asm (slot bv) (slot idx) (slot val))) - (($ $primcall 'unwind ()) - (emit-unwind asm)))) - - (define (compile-values label exp syms) - (match exp - (($ $values args) - (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) - (lookup-parallel-moves label allocation)) - (for-each maybe-load-constant (map slot syms) args)))) - - (define (compile-test label exp kt kf next-label) - (define (unary op sym) - (cond - ((eq? kt next-label) - (op asm (slot sym) #t kf)) - (else - (op asm (slot sym) #f kt) - (unless (eq? kf next-label) - (emit-br asm kf))))) - (define (binary op a b) - (cond - ((eq? kt next-label) - (op asm (slot a) (slot b) #t kf)) - (else - (op asm (slot a) (slot b) #f kt) - (unless (eq? kf next-label) - (emit-br asm kf))))) - (match exp - (($ $values (sym)) - (call-with-values (lambda () - (lookup-maybe-constant-value sym allocation)) - (lambda (has-const? val) - (if has-const? - (if val - (unless (eq? kt next-label) - (emit-br asm kt)) - (unless (eq? kf next-label) - (emit-br asm kf))) - (unary emit-br-if-true sym))))) - (($ $primcall 'null? (a)) (unary emit-br-if-null a)) - (($ $primcall 'nil? (a)) (unary emit-br-if-nil a)) - (($ $primcall 'pair? (a)) (unary emit-br-if-pair a)) - (($ $primcall 'struct? (a)) (unary emit-br-if-struct a)) - (($ $primcall 'char? (a)) (unary emit-br-if-char a)) - (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a)) - (($ $primcall 'variable? (a)) (unary emit-br-if-variable a)) - (($ $primcall 'vector? (a)) (unary emit-br-if-vector a)) - (($ $primcall 'string? (a)) (unary emit-br-if-string a)) - (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a)) - (($ $primcall 'bitvector? (a)) (unary emit-br-if-bitvector a)) - (($ $primcall 'keyword? (a)) (unary emit-br-if-keyword a)) - ;; Add more TC7 tests here. Keep in sync with - ;; *branching-primcall-arities* in (language cps primitives) and - ;; the set of macro-instructions in assembly.scm. - (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b)) - (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b)) - (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b)) - (($ $primcall '< (a b)) (binary emit-br-if-< a b)) - (($ $primcall '<= (a b)) (binary emit-br-if-<= a b)) - (($ $primcall '= (a b)) (binary emit-br-if-= a b)) - (($ $primcall '>= (a b)) (binary emit-br-if-<= b a)) - (($ $primcall '> (a b)) (binary emit-br-if-< b a)) - (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b)))) - - (define (compile-trunc label k exp nreq rest-var nlocals) - (define (do-call proc args emit-call) - (let* ((proc-slot (lookup-call-proc-slot label allocation)) - (nargs (1+ (length args))) - (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs)))) - (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) - (lookup-parallel-moves label allocation)) - (for-each maybe-load-constant arg-slots (cons proc args)) - (emit-call asm proc-slot nargs) - (emit-dead-slot-map asm proc-slot - (lookup-dead-slot-map label allocation)) - (cond - ((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var)) - (match (lookup-parallel-moves k allocation) - ((((? (lambda (src) (= src (1+ proc-slot))) src) - . dst)) dst) - (_ #f))) - ;; The usual case: one required live return value, ignoring - ;; any additional values. - => (lambda (dst) - (emit-receive asm dst proc-slot nlocals))) - (else - (unless (and (zero? nreq) rest-var) - (emit-receive-values asm proc-slot (->bool rest-var) nreq)) - (when (and rest-var (maybe-slot rest-var)) - (emit-bind-rest asm (+ proc-slot 1 nreq))) - (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) - (lookup-parallel-moves k allocation)) - (emit-reset-frame asm nlocals))))) - (match exp - (($ $call proc args) - (do-call proc args - (lambda (asm proc-slot nargs) - (emit-call asm proc-slot nargs)))) - (($ $callk k proc args) - (do-call proc args - (lambda (asm proc-slot nargs) - (emit-call-label asm proc-slot nargs k)))))) - - (match f - (($ $cont k ($ $kfun src meta self tail clause)) - (compile-entry))))) - -(define (compile-bytecode exp env opts) - (let* ((exp (renumber exp)) - (asm (make-assembler))) - (match exp - (($ $program funs) - (for-each (lambda (fun) (compile-fun fun asm)) - funs))) - (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f)) - env - env))) diff --git a/module/language/cps/dfg.scm b/module/language/cps/dfg.scm deleted file mode 100644 index 22bc15900..000000000 --- a/module/language/cps/dfg.scm +++ /dev/null @@ -1,904 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; Many passes rely on a local or global static analysis of a function. -;;; This module implements a simple data-flow graph (DFG) analysis, -;;; tracking the definitions and uses of variables and continuations. -;;; It also builds a table of continuations and scope links, to be able -;;; to easily determine if one continuation is in the scope of another, -;;; and to get to the expression inside a continuation. -;;; -;;; Note that the data-flow graph of continuation labels is a -;;; control-flow graph. -;;; -;;; We currently don't expose details of the DFG type outside this -;;; module, preferring to only expose accessors. That may change in the -;;; future but it seems to work for now. -;;; -;;; Code: - -(define-module (language cps dfg) - #:use-module (ice-9 match) - #:use-module (ice-9 format) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-26) - #:use-module (language cps) - #:use-module (language cps intset) - #:export (build-cont-table - lookup-cont - - compute-dfg - dfg-cont-table - dfg-min-label - dfg-label-count - dfg-min-var - dfg-var-count - with-fresh-name-state-from-dfg - lookup-def - lookup-uses - lookup-predecessors - lookup-successors - lookup-block-scope - find-call - call-expression - find-expression - find-defining-expression - find-constant-value - continuation-bound-in? - variable-free-in? - constant-needs-allocation? - control-point? - lookup-bound-syms - - compute-idoms - compute-dom-edges - - ;; Data flow analysis. - compute-live-variables - dfa-k-idx dfa-k-sym dfa-k-count dfa-k-in dfa-k-out - dfa-var-idx dfa-var-sym dfa-var-count - print-dfa)) - -;; These definitions are here because currently we don't do cross-module -;; inlining. They can be removed once that restriction is gone. -(define-inlinable (for-each f l) - (unless (list? l) - (scm-error 'wrong-type-arg "for-each" "Not a list: ~S" (list l) #f)) - (let for-each1 ((l l)) - (unless (null? l) - (f (car l)) - (for-each1 (cdr l))))) - -(define-inlinable (for-each/2 f l1 l2) - (unless (= (length l1) (length l2)) - (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S" - (list l2) #f)) - (let for-each2 ((l1 l1) (l2 l2)) - (unless (null? l1) - (f (car l1) (car l2)) - (for-each2 (cdr l1) (cdr l2))))) - -(define (build-cont-table fun) - (let ((max-k (fold-conts (lambda (k cont max-k) (max k max-k)) - -1 fun))) - (fold-conts (lambda (k cont table) - (vector-set! table k cont) - table) - (make-vector (1+ max-k) #f) - fun))) - -;; Data-flow graph for CPS: both for values and continuations. -(define-record-type $dfg - (make-dfg conts preds defs uses scopes scope-levels - min-label max-label label-count - min-var max-var var-count) - dfg? - ;; vector of label -> $kargs, etc - (conts dfg-cont-table) - ;; vector of label -> (pred-label ...) - (preds dfg-preds) - ;; vector of var -> def-label - (defs dfg-defs) - ;; vector of var -> (use-label ...) - (uses dfg-uses) - ;; vector of label -> label - (scopes dfg-scopes) - ;; vector of label -> int - (scope-levels dfg-scope-levels) - - (min-label dfg-min-label) - (max-label dfg-max-label) - (label-count dfg-label-count) - - (min-var dfg-min-var) - (max-var dfg-max-var) - (var-count dfg-var-count)) - -(define-inlinable (vector-push! vec idx val) - (let ((v vec) (i idx)) - (vector-set! v i (cons val (vector-ref v i))))) - -(define (compute-reachable dfg min-label label-count) - "Compute and return the continuations that may be reached if flow -reaches a continuation N. Returns a vector of intsets, whose first -index corresponds to MIN-LABEL, and so on." - (let (;; Vector of intsets, indicating that continuation N can - ;; reach a set M... - (reachable (make-vector label-count #f))) - - (define (label->idx label) (- label min-label)) - - ;; Iterate labels backwards, to converge quickly. - (let lp ((label (+ min-label label-count)) (changed? #f)) - (cond - ((= label min-label) - (if changed? - (lp (+ min-label label-count) #f) - reachable)) - (else - (let* ((label (1- label)) - (idx (label->idx label)) - (old (vector-ref reachable idx)) - (new (fold (lambda (succ set) - (cond - ((vector-ref reachable (label->idx succ)) - => (lambda (succ-set) - (intset-union set succ-set))) - (else set))) - (or (vector-ref reachable idx) - (intset-add empty-intset label)) - (visit-cont-successors list - (lookup-cont label dfg))))) - (cond - ((eq? old new) - (lp label changed?)) - (else - (vector-set! reachable idx new) - (lp label #t))))))))) - -(define (find-prompts dfg min-label label-count) - "Find the prompts in DFG between MIN-LABEL and MIN-LABEL + -LABEL-COUNT, and return them as a list of PROMPT-LABEL, HANDLER-LABEL -pairs." - (let lp ((label min-label) (prompts '())) - (cond - ((= label (+ min-label label-count)) - (reverse prompts)) - (else - (match (lookup-cont label dfg) - (($ $kargs names syms body) - (match (find-expression body) - (($ $prompt escape? tag handler) - (lp (1+ label) (acons label handler prompts))) - (_ (lp (1+ label) prompts)))) - (_ (lp (1+ label) prompts))))))) - -(define (compute-interval reachable min-label label-count start end) - "Compute and return the set of continuations that may be reached from -START, inclusive, but not reached by END, exclusive. Returns an -intset." - (intset-subtract (vector-ref reachable (- start min-label)) - (vector-ref reachable (- end min-label)))) - -(define (find-prompt-bodies dfg min-label label-count) - "Find all the prompts in DFG from the LABEL-COUNT continuations -starting at MIN-LABEL, and compute the set of continuations that is -reachable from the prompt bodies but not from the corresponding handler. -Returns a list of PROMPT, HANDLER, BODY lists, where the BODY is an -intset." - (match (find-prompts dfg min-label label-count) - (() '()) - (((prompt . handler) ...) - (let ((reachable (compute-reachable dfg min-label label-count))) - (map (lambda (prompt handler) - ;; FIXME: It isn't correct to use all continuations - ;; reachable from the prompt, because that includes - ;; continuations outside the prompt body. This point is - ;; moot if the handler's control flow joins with the the - ;; body, as is usually but not always the case. - ;; - ;; One counter-example is when the handler contifies an - ;; infinite loop; in that case we compute a too-large - ;; prompt body. This error is currently innocuous, but we - ;; should fix it at some point. - ;; - ;; The fix is to end the body at the corresponding "pop" - ;; primcall, if any. - (let ((body (compute-interval reachable min-label label-count - prompt handler))) - (list prompt handler body))) - prompt handler))))) - -(define* (visit-prompt-control-flow dfg min-label label-count f #:key complete?) - "For all prompts in DFG in the range [MIN-LABEL, MIN-LABEL + -LABEL-COUNT), invoke F with arguments PROMPT, HANDLER, and BODY for each -body continuation in the prompt." - (define (label->idx label) (- label min-label)) - (define (idx->label idx) (+ idx min-label)) - (for-each - (match-lambda - ((prompt handler body) - (define (out-or-back-edge? label) - ;; Most uses of visit-prompt-control-flow don't need every body - ;; continuation, and would be happy getting called only for - ;; continuations that postdominate the rest of the body. Unless - ;; you pass #:complete? #t, we only invoke F on continuations - ;; that can leave the body, or on back-edges in loops. - ;; - ;; You would think that looking for the final "pop" primcall - ;; would be sufficient, but that is incorrect; it's possible for - ;; a loop in the prompt body to be contified, and that loop need - ;; not continue to the pop if it never terminates. The pop could - ;; even be removed by DCE, in that case. - (or-map (lambda (succ) - (or (not (intset-ref body succ)) - (<= succ label))) - (lookup-successors label dfg))) - (let lp ((label min-label)) - (let ((label (intset-next body label))) - (when label - (when (or complete? (out-or-back-edge? label)) - (f prompt handler label)) - (lp (1+ label))))))) - (find-prompt-bodies dfg min-label label-count))) - -(define (analyze-reverse-control-flow fun dfg min-label label-count) - (define (compute-reverse-control-flow-order ktail dfg) - (let ((label-map (make-vector label-count #f)) - (next -1)) - (define (label->idx label) (- label min-label)) - (define (idx->label idx) (+ idx min-label)) - - (let visit ((k ktail)) - ;; Mark this label as visited. - (vector-set! label-map (label->idx k) #t) - (for-each (lambda (k) - ;; Visit predecessors unless they are already visited. - (unless (vector-ref label-map (label->idx k)) - (visit k))) - (lookup-predecessors k dfg)) - ;; Add to reverse post-order chain. - (vector-set! label-map (label->idx k) next) - (set! next k)) - - (let lp ((n 0) (head next)) - (if (< head 0) - ;; Add nodes that are not reachable from the tail. - (let lp ((n n) (m label-count)) - (unless (= n label-count) - (let find-unvisited ((m (1- m))) - (if (vector-ref label-map m) - (find-unvisited (1- m)) - (begin - (vector-set! label-map m n) - (lp (1+ n) m)))))) - ;; Pop the head off the chain, give it its - ;; reverse-post-order numbering, and continue. - (let ((next (vector-ref label-map (label->idx head)))) - (vector-set! label-map (label->idx head) n) - (lp (1+ n) next)))) - - label-map)) - - (define (convert-successors k-map) - (define (idx->label idx) (+ idx min-label)) - (define (renumber label) - (vector-ref k-map (- label min-label))) - (let ((succs (make-vector (vector-length k-map) #f))) - (let lp ((n 0)) - (when (< n (vector-length succs)) - (vector-set! succs (vector-ref k-map n) - (map renumber - (lookup-successors (idx->label n) dfg))) - (lp (1+ n)))) - succs)) - - (match fun - (($ $cont kfun ($ $kfun src meta self ($ $cont ktail tail))) - (let* ((k-map (compute-reverse-control-flow-order ktail dfg)) - (succs (convert-successors k-map))) - ;; Any expression in the prompt body could cause an abort to - ;; the handler. This code adds links from every block in the - ;; prompt body to the handler. This causes all values used - ;; by the handler to be seen as live in the prompt body, as - ;; indeed they are. - (visit-prompt-control-flow - dfg min-label label-count - (lambda (prompt handler body) - (define (renumber label) - (vector-ref k-map (- label min-label))) - (vector-push! succs (renumber body) (renumber handler)))) - - (values k-map succs))))) - -(define (compute-idoms dfg min-label label-count) - (define preds (dfg-preds dfg)) - (define (label->idx label) (- label min-label)) - (define (idx->label idx) (+ idx min-label)) - (define (idx->dfg-idx idx) (- (idx->label idx) (dfg-min-label dfg))) - (let ((idoms (make-vector label-count #f))) - (define (common-idom d0 d1) - ;; We exploit the fact that a reverse post-order is a topological - ;; sort, and so the idom of a node is always numerically less than - ;; the node itself. - (cond - ((= d0 d1) d0) - ((< d0 d1) (common-idom d0 (vector-ref idoms (label->idx d1)))) - (else (common-idom (vector-ref idoms (label->idx d0)) d1)))) - (define (compute-idom preds) - (define (has-idom? pred) - (vector-ref idoms (label->idx pred))) - (match preds - (() min-label) - ((pred . preds) - (if (has-idom? pred) - (let lp ((idom pred) (preds preds)) - (match preds - (() idom) - ((pred . preds) - (lp (if (has-idom? pred) - (common-idom idom pred) - idom) - preds)))) - (compute-idom preds))))) - ;; This is the iterative O(n^2) fixpoint algorithm, originally from - ;; Allen and Cocke ("Graph-theoretic constructs for program flow - ;; analysis", 1972). See the discussion in Cooper, Harvey, and - ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001. - (let iterate ((n 0) (changed? #f)) - (cond - ((< n label-count) - (let ((idom (vector-ref idoms n)) - (idom* (compute-idom (vector-ref preds (idx->dfg-idx n))))) - (cond - ((eqv? idom idom*) - (iterate (1+ n) changed?)) - (else - (vector-set! idoms n idom*) - (iterate (1+ n) #t))))) - (changed? - (iterate 0 #f)) - (else idoms))))) - -;; Compute a vector containing, for each node, a list of the nodes that -;; it immediately dominates. These are the "D" edges in the DJ tree. -(define (compute-dom-edges idoms min-label) - (define (label->idx label) (- label min-label)) - (define (idx->label idx) (+ idx min-label)) - (let ((doms (make-vector (vector-length idoms) '()))) - (let lp ((n 0)) - (when (< n (vector-length idoms)) - (let ((idom (vector-ref idoms n))) - (vector-push! doms (label->idx idom) (idx->label n))) - (lp (1+ n)))) - doms)) - -;; There used to be some loop detection code here, but it bitrotted. -;; We'll need it again eventually but for now it can be found in the git -;; history. - -;; Data-flow analysis. -(define-record-type $dfa - (make-dfa min-label min-var var-count in out) - dfa? - ;; Minimum label in this function. - (min-label dfa-min-label) - ;; Minimum var in this function. - (min-var dfa-min-var) - ;; Var count in this function. - (var-count dfa-var-count) - ;; Vector of k-idx -> intset - (in dfa-in) - ;; Vector of k-idx -> intset - (out dfa-out)) - -(define (dfa-k-idx dfa k) - (- k (dfa-min-label dfa))) - -(define (dfa-k-sym dfa idx) - (+ idx (dfa-min-label dfa))) - -(define (dfa-k-count dfa) - (vector-length (dfa-in dfa))) - -(define (dfa-var-idx dfa var) - (let ((idx (- var (dfa-min-var dfa)))) - (unless (< -1 idx (dfa-var-count dfa)) - (error "var out of range" var)) - idx)) - -(define (dfa-var-sym dfa idx) - (unless (< -1 idx (dfa-var-count dfa)) - (error "idx out of range" idx)) - (+ idx (dfa-min-var dfa))) - -(define (dfa-k-in dfa idx) - (vector-ref (dfa-in dfa) idx)) - -(define (dfa-k-out dfa idx) - (vector-ref (dfa-out dfa) idx)) - -(define (compute-live-variables fun dfg) - ;; Compute the maximum fixed point of the data-flow constraint problem. - ;; - ;; This always completes, as the graph is finite and the in and out sets - ;; are complete semi-lattices. If the graph is reducible and the blocks - ;; are sorted in reverse post-order, this completes in a maximum of LC + - ;; 2 iterations, where LC is the loop connectedness number. See Hecht - ;; and Ullman, "Analysis of a simple algorithm for global flow - ;; problems", POPL 1973, or the recent summary in "Notes on graph - ;; algorithms used in optimizing compilers", Offner 2013. - (define (compute-maximum-fixed-point preds inv outv killv genv) - (define (fold f seed l) - (if (null? l) seed (fold f (f (car l) seed) (cdr l)))) - (let lp ((n 0) (changed? #f)) - (cond - ((< n (vector-length preds)) - (let* ((in (vector-ref inv n)) - (in* (or - (fold (lambda (pred set) - (cond - ((vector-ref outv pred) - => (lambda (out) - (if set - (intset-union set out) - out))) - (else set))) - in - (vector-ref preds n)) - empty-intset))) - (if (eq? in in*) - (lp (1+ n) changed?) - (let ((out* (fold (lambda (gen set) - (intset-add set gen)) - (fold (lambda (kill set) - (intset-remove set kill)) - in* - (vector-ref killv n)) - (vector-ref genv n)))) - (vector-set! inv n in*) - (vector-set! outv n out*) - (lp (1+ n) #t))))) - (changed? - (lp 0 #f))))) - - (unless (and (= (vector-length (dfg-uses dfg)) (dfg-var-count dfg)) - (= (vector-length (dfg-cont-table dfg)) (dfg-label-count dfg))) - (error "function needs renumbering")) - (let* ((min-label (dfg-min-label dfg)) - (nlabels (dfg-label-count dfg)) - (min-var (dfg-min-var dfg)) - (nvars (dfg-var-count dfg)) - (usev (make-vector nlabels '())) - (defv (make-vector nlabels '())) - (live-in (make-vector nlabels #f)) - (live-out (make-vector nlabels #f))) - (call-with-values - (lambda () - (analyze-reverse-control-flow fun dfg min-label nlabels)) - (lambda (k-map succs) - (define (var->idx var) (- var min-var)) - (define (idx->var idx) (+ idx min-var)) - (define (label->idx label) - (vector-ref k-map (- label min-label))) - - ;; Initialize defv and usev. - (let ((defs (dfg-defs dfg)) - (uses (dfg-uses dfg))) - (let lp ((n 0)) - (when (< n (vector-length defs)) - (let ((def (vector-ref defs n))) - (unless def - (error "internal error -- var array not packed")) - (for-each (lambda (def) - (vector-push! defv (label->idx def) n)) - (lookup-predecessors def dfg)) - (for-each (lambda (use) - (vector-push! usev (label->idx use) n)) - (vector-ref uses n)) - (lp (1+ n)))))) - - ;; Liveness is a reverse data-flow problem, so we give - ;; compute-maximum-fixed-point a reversed graph, swapping in for - ;; out, usev for defv, and using successors instead of - ;; predecessors. Continuation 0 is ktail. - (compute-maximum-fixed-point succs live-out live-in defv usev) - - ;; Now rewrite the live-in and live-out sets to be indexed by - ;; (LABEL - MIN-LABEL). - (let ((live-in* (make-vector nlabels #f)) - (live-out* (make-vector nlabels #f))) - (let lp ((idx 0)) - (when (< idx nlabels) - (let ((dfa-idx (vector-ref k-map idx))) - (vector-set! live-in* idx (vector-ref live-in dfa-idx)) - (vector-set! live-out* idx (vector-ref live-out dfa-idx)) - (lp (1+ idx))))) - - (make-dfa min-label min-var nvars live-in* live-out*)))))) - -(define (print-dfa dfa) - (match dfa - (($ $dfa min-label min-var var-count in out) - (define (print-var-set bv) - (let lp ((n 0)) - (let ((n (intset-next bv n))) - (when n - (format #t " ~A" (+ n min-var)) - (lp (1+ n)))))) - (let lp ((n 0)) - (when (< n (vector-length in)) - (format #t "~A:\n" (+ n min-label)) - (format #t " in:") - (print-var-set (vector-ref in n)) - (newline) - (format #t " out:") - (print-var-set (vector-ref out n)) - (newline) - (lp (1+ n))))))) - -(define (compute-label-and-var-ranges fun global?) - (define (min* a b) - (if b (min a b) a)) - (define-syntax-rule (do-fold make-cont-folder) - ((make-cont-folder min-label max-label label-count - min-var max-var var-count) - (lambda (label cont - min-label max-label label-count - min-var max-var var-count) - (let ((min-label (min* label min-label)) - (max-label (max label max-label))) - (match cont - (($ $kargs names vars body) - (values min-label max-label (1+ label-count) - (cond (min-var (fold min min-var vars)) - ((pair? vars) (fold min (car vars) (cdr vars))) - (else min-var)) - (fold max max-var vars) - (+ var-count (length vars)))) - (($ $kfun src meta self) - (values min-label max-label (1+ label-count) - (min* self min-var) (max self max-var) (1+ var-count))) - (_ (values min-label max-label (1+ label-count) - min-var max-var var-count))))) - fun - #f -1 0 #f -1 0)) - (if global? - (do-fold make-global-cont-folder) - (do-fold make-local-cont-folder))) - -(define* (compute-dfg fun #:key (global? #t)) - (call-with-values (lambda () (compute-label-and-var-ranges fun global?)) - (lambda (min-label max-label label-count min-var max-var var-count) - (when (or (zero? label-count) (zero? var-count)) - (error "internal error (no vars or labels for fun?)")) - (let* ((nlabels (- (1+ max-label) min-label)) - (nvars (- (1+ max-var) min-var)) - (conts (make-vector nlabels #f)) - (preds (make-vector nlabels '())) - (defs (make-vector nvars #f)) - (uses (make-vector nvars '())) - (scopes (make-vector nlabels #f)) - (scope-levels (make-vector nlabels #f))) - (define (var->idx var) (- var min-var)) - (define (label->idx label) (- label min-label)) - - (define (add-def! var def-k) - (vector-set! defs (var->idx var) def-k)) - (define (add-use! var use-k) - (vector-push! uses (var->idx var) use-k)) - - (define* (declare-block! label cont parent - #:optional (level - (1+ (vector-ref - scope-levels - (label->idx parent))))) - (vector-set! conts (label->idx label) cont) - (vector-set! scopes (label->idx label) parent) - (vector-set! scope-levels (label->idx label) level)) - - (define (link-blocks! pred succ) - (vector-push! preds (label->idx succ) pred)) - - (define (visit-cont cont label) - (match cont - (($ $kargs names syms body) - (for-each (cut add-def! <> label) syms) - (visit-term body label)) - (($ $kreceive arity k) - (link-blocks! label k)))) - - (define (visit-term term label) - (match term - (($ $letk (($ $cont k cont) ...) body) - ;; Set up recursive environment before visiting cont bodies. - (for-each/2 (lambda (cont k) - (declare-block! k cont label)) - cont k) - (for-each/2 visit-cont cont k) - (visit-term body label)) - (($ $continue k src exp) - (link-blocks! label k) - (visit-exp exp label)))) - - (define (visit-exp exp label) - (define (use! sym) - (add-use! sym label)) - (match exp - ((or ($ $const) ($ $prim) ($ $closure)) #f) - (($ $call proc args) - (use! proc) - (for-each use! args)) - (($ $callk k proc args) - (use! proc) - (for-each use! args)) - (($ $primcall name args) - (for-each use! args)) - (($ $branch kt exp) - (link-blocks! label kt) - (visit-exp exp label)) - (($ $values args) - (for-each use! args)) - (($ $prompt escape? tag handler) - (use! tag) - (link-blocks! label handler)) - (($ $fun body) - (when global? - (visit-fun body))) - (($ $rec names syms funs) - (unless global? - (error "$rec should not be present when building a local DFG")) - (for-each (lambda (fun) - (match fun - (($ $fun body) - (visit-fun body)))) - funs)))) - - (define (visit-clause clause kfun) - (match clause - (#f #t) - (($ $cont kclause - (and clause ($ $kclause arity ($ $cont kbody body) - alternate))) - (declare-block! kclause clause kfun) - (link-blocks! kfun kclause) - - (declare-block! kbody body kclause) - (link-blocks! kclause kbody) - - (visit-cont body kbody) - (visit-clause alternate kfun)))) - - (define (visit-fun fun) - (match fun - (($ $cont kfun - (and cont - ($ $kfun src meta self ($ $cont ktail tail) clause))) - (declare-block! kfun cont #f 0) - (add-def! self kfun) - (declare-block! ktail tail kfun) - (visit-clause clause kfun)))) - - (visit-fun fun) - - (make-dfg conts preds defs uses scopes scope-levels - min-label max-label label-count - min-var max-var var-count))))) - -(define* (dump-dfg dfg #:optional (port (current-output-port))) - (let ((min-label (dfg-min-label dfg)) - (min-var (dfg-min-var dfg))) - (define (label->idx label) (- label min-label)) - (define (idx->label idx) (+ idx min-label)) - (define (var->idx var) (- var min-var)) - (define (idx->var idx) (+ idx min-var)) - - (let lp ((label (dfg-min-label dfg))) - (when (<= label (dfg-max-label dfg)) - (let ((cont (vector-ref (dfg-cont-table dfg) (label->idx label)))) - (when cont - (unless (equal? (lookup-predecessors label dfg) (list (1- label))) - (newline port)) - (format port "k~a:~8t" label) - (match cont - (($ $kreceive arity k) - (format port "$kreceive ~a k~a\n" arity k)) - (($ $kfun src meta self tail clause) - (format port "$kfun ~a ~a v~a\n" src meta self)) - (($ $ktail) - (format port "$ktail\n")) - (($ $kclause arity ($ $cont kbody) alternate) - (format port "$kclause ~a k~a" arity kbody) - (match alternate - (#f #f) - (($ $cont kalt) (format port " -> k~a" kalt))) - (newline port)) - (($ $kargs names vars term) - (unless (null? vars) - (format port "v~a[~a]~:{ v~a[~a]~}: " - (car vars) (car names) (map list (cdr vars) (cdr names)))) - (match (find-call term) - (($ $continue kf src ($ $branch kt exp)) - (format port "if ") - (match exp - (($ $primcall name args) - (format port "(~a~{ v~a~})" name args)) - (($ $values (arg)) - (format port "v~a" arg))) - (format port " k~a k~a\n" kt kf)) - (($ $continue k src exp) - (match exp - (($ $const val) (format port "const ~@y" val)) - (($ $prim name) (format port "prim ~a" name)) - (($ $fun ($ $cont kbody)) (format port "fun k~a" kbody)) - (($ $rec names syms funs) (format port "rec~{ v~a~}" syms)) - (($ $closure label nfree) (format port "closure k~a (~a free)" label nfree)) - (($ $call proc args) (format port "call~{ v~a~}" (cons proc args))) - (($ $callk k proc args) (format port "callk k~a~{ v~a~}" k (cons proc args))) - (($ $primcall name args) (format port "~a~{ v~a~}" name args)) - (($ $values args) (format port "values~{ v~a~}" args)) - (($ $prompt escape? tag handler) (format port "prompt ~a v~a k~a" escape? tag handler))) - (unless (= k (1+ label)) - (format port " -> k~a" k)) - (newline port)))))) - (lp (1+ label))))))) - -(define-syntax-rule (with-fresh-name-state-from-dfg dfg body ...) - (parameterize ((label-counter (1+ (dfg-max-label dfg))) - (var-counter (1+ (dfg-max-var dfg)))) - body ...)) - -(define (lookup-cont label dfg) - (let ((res (vector-ref (dfg-cont-table dfg) (- label (dfg-min-label dfg))))) - (unless res - (error "Unknown continuation!" label)) - res)) - -(define (lookup-predecessors k dfg) - (vector-ref (dfg-preds dfg) (- k (dfg-min-label dfg)))) - -(define (lookup-successors k dfg) - (let ((cont (vector-ref (dfg-cont-table dfg) (- k (dfg-min-label dfg))))) - (visit-cont-successors list cont))) - -(define (lookup-def var dfg) - (vector-ref (dfg-defs dfg) (- var (dfg-min-var dfg)))) - -(define (lookup-uses var dfg) - (vector-ref (dfg-uses dfg) (- var (dfg-min-var dfg)))) - -(define (lookup-block-scope k dfg) - (vector-ref (dfg-scopes dfg) (- k (dfg-min-label dfg)))) - -(define (lookup-scope-level k dfg) - (vector-ref (dfg-scope-levels dfg) (- k (dfg-min-label dfg)))) - -(define (find-defining-term sym dfg) - (match (lookup-predecessors (lookup-def sym dfg) dfg) - ((def-exp-k) - (lookup-cont def-exp-k dfg)) - (else #f))) - -(define (find-call term) - (match term - (($ $kargs names syms body) (find-call body)) - (($ $letk conts body) (find-call body)) - (($ $continue) term))) - -(define (call-expression call) - (match call - (($ $continue k src exp) exp))) - -(define (find-expression term) - (call-expression (find-call term))) - -(define (find-defining-expression sym dfg) - (match (find-defining-term sym dfg) - (#f #f) - (($ $kreceive) #f) - (($ $kclause) #f) - (term (find-expression term)))) - -(define (find-constant-value sym dfg) - (match (find-defining-expression sym dfg) - (($ $const val) - (values #t val)) - (else - (values #f #f)))) - -(define (constant-needs-allocation? var val dfg) - (define (immediate-u8? val) - (and (integer? val) (exact? val) (<= 0 val 255))) - - (define (find-exp term) - (match term - (($ $kargs names vars body) (find-exp body)) - (($ $letk conts body) (find-exp body)) - (else term))) - - (or-map - (lambda (use) - (match (find-expression (lookup-cont use dfg)) - (($ $call) #f) - (($ $callk) #f) - (($ $values) #f) - (($ $primcall 'free-ref (closure slot)) - (eq? var closure)) - (($ $primcall 'free-set! (closure slot value)) - (or (eq? var closure) (eq? var value))) - (($ $primcall 'cache-current-module! (mod . _)) - (eq? var mod)) - (($ $primcall 'cached-toplevel-box _) - #f) - (($ $primcall 'cached-module-box _) - #f) - (($ $primcall 'resolve (name bound?)) - (eq? var name)) - (($ $primcall 'make-vector/immediate (len init)) - (eq? var init)) - (($ $primcall 'vector-ref/immediate (v i)) - (eq? var v)) - (($ $primcall 'vector-set!/immediate (v i x)) - (or (eq? var v) (eq? var x))) - (($ $primcall 'allocate-struct/immediate (vtable nfields)) - (eq? var vtable)) - (($ $primcall 'struct-ref/immediate (s n)) - (eq? var s)) - (($ $primcall 'struct-set!/immediate (s n x)) - (or (eq? var s) (eq? var x))) - (($ $primcall 'builtin-ref (idx)) - #f) - (_ #t))) - (vector-ref (dfg-uses dfg) (- var (dfg-min-var dfg))))) - -(define (continuation-scope-contains? scope-k k dfg) - (let ((scope-level (lookup-scope-level scope-k dfg))) - (let lp ((k k)) - (or (eq? scope-k k) - (and (< scope-level (lookup-scope-level k dfg)) - (lp (lookup-block-scope k dfg))))))) - -(define (continuation-bound-in? k use-k dfg) - (continuation-scope-contains? (lookup-block-scope k dfg) use-k dfg)) - -(define (variable-free-in? var k dfg) - (or-map (lambda (use) - (continuation-scope-contains? k use dfg)) - (lookup-uses var dfg))) - -;; A continuation is a control point if it has multiple predecessors, or -;; if its single predecessor does not have a single successor. -(define (control-point? k dfg) - (match (lookup-predecessors k dfg) - ((pred) - (let ((cont (vector-ref (dfg-cont-table dfg) - (- pred (dfg-min-label dfg))))) - (visit-cont-successors (case-lambda - (() #t) - ((succ0) #f) - ((succ1 succ2) #t)) - cont))) - (_ #t))) - -(define (lookup-bound-syms k dfg) - (match (lookup-cont k dfg) - (($ $kargs names syms body) - syms))) diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm deleted file mode 100644 index 8a1c7a0f2..000000000 --- a/module/language/cps/renumber.scm +++ /dev/null @@ -1,343 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; A pass to renumber variables and continuation labels so that they -;;; are contiguous within each function and, in the case of labels, -;;; topologically sorted. -;;; -;;; Code: - -(define-module (language cps renumber) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (language cps) - #:export (renumber)) - -;; Topologically sort the continuation tree starting at k0, using -;; reverse post-order numbering. -(define (sort-conts k0 conts new-k0 path-lengths) - (let ((next -1)) - (let visit ((k k0)) - (define (maybe-visit k) - (let ((entry (vector-ref conts k))) - ;; Visit the successor if it has not been - ;; visited yet. - (when (and entry (not (exact-integer? entry))) - (visit k)))) - - (let ((cont (vector-ref conts k))) - ;; Clear the cont table entry to mark this continuation as - ;; visited. - (vector-set! conts k #f) - - (match cont - (($ $kargs names syms body) - (let lp ((body body)) - (match body - (($ $letk conts body) (lp body)) - (($ $continue k src exp) - (match exp - (($ $prompt escape? tag handler) - (maybe-visit handler) - (maybe-visit k)) - (($ $branch kt) - ;; Visit the successor with the shortest path length - ;; to the tail first, so that if the branches are - ;; unsorted, the longer path length will appear - ;; first. This will move a loop exit out of a loop. - (let ((k-len (vector-ref path-lengths k)) - (kt-len (vector-ref path-lengths kt))) - (cond - ((if kt-len - (or (not k-len) - (< k-len kt-len) - ;; If the path lengths are the - ;; same, preserve original order - ;; to avoid squirreliness. - (and (= k-len kt-len) (< kt k))) - (if k-len #f (< kt k))) - (maybe-visit k) - (maybe-visit kt)) - (else - (maybe-visit kt) - (maybe-visit k))))) - (_ - (maybe-visit k))))))) - (($ $kreceive arity k) (maybe-visit k)) - (($ $kclause arity ($ $cont kbody) alt) - (match alt - (($ $cont kalt) (maybe-visit kalt)) - (_ #f)) - (maybe-visit kbody)) - (($ $kfun src meta self tail clause) - (match clause - (($ $cont kclause) (maybe-visit kclause)) - (_ #f))) - (_ #f)) - - ;; Chain this label to the label that will follow it in the sort - ;; order, and record this label as the new head of the order. - (vector-set! conts k next) - (set! next k))) - - ;; Finally traverse the label chain, giving each label its final - ;; name. - (let lp ((n new-k0) (head next)) - (if (< head 0) - n - (let ((next (vector-ref conts head))) - (vector-set! conts head n) - (lp (1+ n) next)))))) - -(define (compute-tail-path-lengths preds ktail path-lengths) - (let visit ((k ktail) (length-in 0)) - (let ((length (vector-ref path-lengths k))) - (unless (and length (<= length length-in)) - (vector-set! path-lengths k length-in) - (let lp ((preds (vector-ref preds k))) - (match preds - (() #t) - ((pred . preds) - (visit pred (1+ length-in)) - (lp preds)))))))) - -(define (compute-new-labels-and-vars fun) - (call-with-values (lambda () (compute-max-label-and-var fun)) - (lambda (max-label max-var) - (let ((labels (make-vector (1+ max-label) #f)) - (next-label 0) - (vars (make-vector (1+ max-var) #f)) - (next-var 0) - (preds (make-vector (1+ max-label) '())) - (path-lengths (make-vector (1+ max-label) #f))) - (define (add-predecessor! pred succ) - (vector-set! preds succ (cons pred (vector-ref preds succ)))) - (define (rename! var) - (vector-set! vars var next-var) - (set! next-var (1+ next-var))) - - (define (collect-conts fun) - (define (visit-cont cont) - (match cont - (($ $cont label cont) - (vector-set! labels label cont) - (match cont - (($ $kargs names vars body) - (visit-term body label)) - (($ $kfun src meta self tail clause) - (visit-cont tail) - (match clause - (($ $cont kclause) - (add-predecessor! label kclause) - (visit-cont clause)) - (#f #f))) - (($ $kclause arity (and body ($ $cont kbody)) alternate) - (add-predecessor! label kbody) - (visit-cont body) - (match alternate - (($ $cont kalt) - (add-predecessor! label kalt) - (visit-cont alternate)) - (#f #f))) - (($ $kreceive arity kargs) - (add-predecessor! label kargs)) - (($ $ktail) #f))))) - (define (visit-term term label) - (match term - (($ $letk conts body) - (let lp ((conts conts)) - (unless (null? conts) - (visit-cont (car conts)) - (lp (cdr conts)))) - (visit-term body label)) - (($ $continue k src exp) - (add-predecessor! label k) - (match exp - (($ $branch kt) - (add-predecessor! label kt)) - (($ $prompt escape? tag handler) - (add-predecessor! label handler)) - (_ #f))))) - (visit-cont fun)) - - (define (compute-names-in-fun fun) - (define queue '()) - (define (visit-cont cont) - (match cont - (($ $cont label cont) - (let ((reachable? (exact-integer? (vector-ref labels label)))) - ;; This cont is reachable if it was given a number. - ;; Otherwise the cont table entry still contains the - ;; cont itself; clear it out to indicate that the cont - ;; should not be residualized. - (unless reachable? - (vector-set! labels label #f)) - (match cont - (($ $kargs names vars body) - (when reachable? - (for-each rename! vars)) - (visit-term body reachable?)) - (($ $kfun src meta self tail clause) - (unless reachable? (error "entry should be reachable")) - (rename! self) - (visit-cont tail) - (when clause - (visit-cont clause))) - (($ $kclause arity body alternate) - (unless reachable? (error "clause should be reachable")) - (visit-cont body) - (when alternate - (visit-cont alternate))) - (($ $ktail) - (unless reachable? - ;; It's possible for the tail to be unreachable, - ;; if all paths contify to infinite loops. Make - ;; sure we mark as reachable. - (vector-set! labels label next-label) - (set! next-label (1+ next-label)))) - (($ $kreceive) - #f)))))) - (define (visit-term term reachable?) - (match term - (($ $letk conts body) - (for-each visit-cont conts) - (visit-term body reachable?)) - (($ $continue k src ($ $fun body)) - (when reachable? - (set! queue (cons body queue)))) - (($ $continue k src ($ $rec names syms funs)) - (when reachable? - (set! queue (fold (lambda (fun queue) - (match fun - (($ $fun body) - (cons body queue)))) - queue - funs)))) - (($ $continue) #f))) - - (match fun - (($ $cont kfun ($ $kfun src meta self ($ $cont ktail))) - (collect-conts fun) - (compute-tail-path-lengths preds ktail path-lengths) - (set! next-label (sort-conts kfun labels next-label path-lengths)) - (visit-cont fun) - (for-each compute-names-in-fun (reverse queue))) - (($ $program conts) - (for-each compute-names-in-fun conts)))) - - (compute-names-in-fun fun) - (values labels vars next-label next-var))))) - -(define (apply-renumbering term labels vars) - (define (relabel label) (vector-ref labels label)) - (define (rename var) (vector-ref vars var)) - (define (rename-kw-arity arity) - (match arity - (($ $arity req opt rest kw aok?) - (make-$arity req opt rest - (map (match-lambda - ((kw kw-name kw-var) - (list kw kw-name (rename kw-var)))) - kw) - aok?)))) - (define (must-visit-cont cont) - (or (visit-cont cont) - (error "internal error -- failed to visit cont"))) - (define (visit-conts conts) - (match conts - (() '()) - ((cont . conts) - (cond - ((visit-cont cont) - => (lambda (cont) - (cons cont (visit-conts conts)))) - (else (visit-conts conts)))))) - (define (visit-cont cont) - (match cont - (($ $cont label cont) - (let ((label (relabel label))) - (and - label - (rewrite-cps-cont cont - (($ $kargs names vars body) - (label ($kargs names (map rename vars) ,(visit-term body)))) - (($ $kfun src meta self tail clause) - (label - ($kfun src meta (rename self) ,(must-visit-cont tail) - ,(and clause (must-visit-cont clause))))) - (($ $ktail) - (label ($ktail))) - (($ $kclause arity body alternate) - (label - ($kclause ,(rename-kw-arity arity) ,(must-visit-cont body) - ,(and alternate (must-visit-cont alternate))))) - (($ $kreceive ($ $arity req () rest () #f) kargs) - (label ($kreceive req rest (relabel kargs)))))))))) - (define (visit-term term) - (rewrite-cps-term term - (($ $letk conts body) - ,(match (visit-conts conts) - (() (visit-term body)) - (conts (build-cps-term ($letk ,conts ,(visit-term body)))))) - (($ $continue k src exp) - ($continue (relabel k) src ,(visit-exp exp))))) - (define (visit-exp exp) - (match exp - ((or ($ $const) ($ $prim)) - exp) - (($ $closure k nfree) - (build-cps-exp ($closure (relabel k) nfree))) - (($ $fun) - (visit-fun exp)) - (($ $rec names vars funs) - (build-cps-exp ($rec names (map rename vars) (map visit-fun funs)))) - (($ $values args) - (let ((args (map rename args))) - (build-cps-exp ($values args)))) - (($ $call proc args) - (let ((args (map rename args))) - (build-cps-exp ($call (rename proc) args)))) - (($ $callk k proc args) - (let ((args (map rename args))) - (build-cps-exp ($callk (relabel k) (rename proc) args)))) - (($ $branch kt exp) - (build-cps-exp ($branch (relabel kt) ,(visit-exp exp)))) - (($ $primcall name args) - (let ((args (map rename args))) - (build-cps-exp ($primcall name args)))) - (($ $prompt escape? tag handler) - (build-cps-exp - ($prompt escape? (rename tag) (relabel handler)))))) - (define (visit-fun fun) - (rewrite-cps-exp fun - (($ $fun body) - ($fun ,(must-visit-cont body))))) - - (match term - (($ $cont) - (must-visit-cont term)) - (($ $program conts) - (build-cps-term - ($program ,(map must-visit-cont conts)))))) - -(define (renumber term) - (call-with-values (lambda () (compute-new-labels-and-vars term)) - (lambda (labels vars nlabels nvars) - (values (apply-renumbering term labels vars) nlabels nvars)))) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm deleted file mode 100644 index c60f0f22f..000000000 --- a/module/language/cps/slot-allocation.scm +++ /dev/null @@ -1,689 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; A module to assign stack slots to variables in a CPS term. -;;; -;;; Code: - -(define-module (language cps slot-allocation) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-26) - #:use-module (language cps) - #:use-module (language cps dfg) - #:use-module (language cps intset) - #:export (allocate-slots - lookup-slot - lookup-maybe-slot - lookup-constant-value - lookup-maybe-constant-value - lookup-nlocals - lookup-call-proc-slot - lookup-parallel-moves - lookup-dead-slot-map)) - -(define-record-type $allocation - (make-allocation dfa slots - has-constv constant-values - call-allocations - nlocals) - allocation? - - ;; A DFA records all variables bound in a function, and assigns them - ;; indices. The slot in which a variable is stored at runtime can be - ;; had by indexing into the SLOTS vector with the variable's index. - ;; - (dfa allocation-dfa) - (slots allocation-slots) - - ;; Not all variables have slots allocated. Variables that are - ;; constant and that are only used by primcalls that can accept - ;; constants directly are not allocated to slots, and their SLOT value - ;; is false. Likewise constants that are only used by calls are not - ;; allocated into slots, to avoid needless copying. If a variable is - ;; constant, its constant value is set in the CONSTANT-VALUES vector - ;; and the corresponding bit in the HAS-CONSTV bitvector is set. - ;; - (has-constv allocation-has-constv) - (constant-values allocation-constant-values) - - ;; Some continuations have additional associated information. This - ;; addition information is a /call allocation/. Call allocations - ;; record the way that functions are passed values, and how their - ;; return values are rebound to local variables. - ;; - ;; A call allocation contains three pieces of information: the call's - ;; /proc slot/, a set of /parallel moves/, and a /dead slot map/. The - ;; proc slot indicates the slot of a procedure in a procedure call, or - ;; where the procedure would be in a multiple-value return. The - ;; parallel moves shuffle locals into position for a call, or shuffle - ;; returned values back into place. Though they use the same slot, - ;; moves for a call are called "call moves", and moves to handle a - ;; return are "return moves". The dead slot map indicates, for a - ;; call, what slots should be ignored by GC when marking the frame. - ;; - ;; $kreceive continuations record a proc slot and a set of return moves - ;; to adapt multiple values from the stack to local variables. - ;; - ;; Tail calls record arg moves, but no proc slot. - ;; - ;; Non-tail calls record arg moves, a call slot, and a dead slot map. - ;; Multiple-valued returns will have an associated $kreceive - ;; continuation, which records the same proc slot, but has return - ;; moves and no dead slot map. - ;; - ;; $prompt handlers are $kreceive continuations like any other. - ;; - ;; $values expressions with more than 1 value record moves but have no - ;; proc slot or dead slot map. - ;; - ;; A set of moves is expressed as an ordered list of (SRC . DST) - ;; moves, where SRC and DST are slots. This may involve a temporary - ;; variable. A dead slot map is a bitfield, as an integer. - ;; - (call-allocations allocation-call-allocations) - - ;; The number of locals for a $kclause. - ;; - (nlocals allocation-nlocals)) - -(define-record-type $call-allocation - (make-call-allocation proc-slot moves dead-slot-map) - call-allocation? - (proc-slot call-allocation-proc-slot) - (moves call-allocation-moves) - (dead-slot-map call-allocation-dead-slot-map)) - -(define (find-first-zero n) - ;; Naive implementation. - (let lp ((slot 0)) - (if (logbit? slot n) - (lp (1+ slot)) - slot))) - -(define (find-first-trailing-zero n) - (let lp ((slot (let lp ((count 2)) - (if (< n (ash 1 (1- count))) - count - ;; Grow upper bound slower than factor 2 to avoid - ;; needless bignum allocation on 32-bit systems - ;; when there are more than 16 locals. - (lp (+ count (ash count -1))))))) - (if (or (zero? slot) (logbit? (1- slot) n)) - slot - (lp (1- slot))))) - -(define (lookup-maybe-slot sym allocation) - (match allocation - (($ $allocation dfa slots) - (vector-ref slots (dfa-var-idx dfa sym))))) - -(define (lookup-slot sym allocation) - (or (lookup-maybe-slot sym allocation) - (error "Variable not allocated to a slot" sym))) - -(define (lookup-constant-value sym allocation) - (match allocation - (($ $allocation dfa slots has-constv constant-values) - (let ((idx (dfa-var-idx dfa sym))) - (if (bitvector-ref has-constv idx) - (vector-ref constant-values idx) - (error "Variable does not have constant value" sym)))))) - -(define (lookup-maybe-constant-value sym allocation) - (match allocation - (($ $allocation dfa slots has-constv constant-values) - (let ((idx (dfa-var-idx dfa sym))) - (values (bitvector-ref has-constv idx) - (vector-ref constant-values idx)))))) - -(define (lookup-call-allocation k allocation) - (or (hashq-ref (allocation-call-allocations allocation) k) - (error "Continuation not a call" k))) - -(define (lookup-call-proc-slot k allocation) - (or (call-allocation-proc-slot (lookup-call-allocation k allocation)) - (error "Call has no proc slot" k))) - -(define (lookup-parallel-moves k allocation) - (or (call-allocation-moves (lookup-call-allocation k allocation)) - (error "Call has no use parallel moves slot" k))) - -(define (lookup-dead-slot-map k allocation) - (or (call-allocation-dead-slot-map (lookup-call-allocation k allocation)) - (error "Call has no dead slot map" k))) - -(define (lookup-nlocals k allocation) - (or (hashq-ref (allocation-nlocals allocation) k) - (error "Not a clause continuation" k))) - -(define (solve-parallel-move src dst tmp) - "Solve the parallel move problem between src and dst slot lists, which -are comparable with eqv?. A tmp slot may be used." - - ;; This algorithm is taken from: "Tilting at windmills with Coq: - ;; formal verification of a compilation algorithm for parallel moves" - ;; by Laurence Rideau, Bernard Paul Serpette, and Xavier Leroy - ;; - - (define (split-move moves reg) - (let loop ((revhead '()) (tail moves)) - (match tail - (((and s+d (s . d)) . rest) - (if (eqv? s reg) - (cons d (append-reverse revhead rest)) - (loop (cons s+d revhead) rest))) - (_ #f)))) - - (define (replace-last-source reg moves) - (match moves - ((moves ... (s . d)) - (append moves (list (cons reg d)))))) - - (let loop ((to-move (map cons src dst)) - (being-moved '()) - (moved '()) - (last-source #f)) - ;; 'last-source' should always be equivalent to: - ;; (and (pair? being-moved) (car (last being-moved))) - (match being-moved - (() (match to-move - (() (reverse moved)) - (((and s+d (s . d)) . t1) - (if (or (eqv? s d) ; idempotent - (not s)) ; src is a constant and can be loaded directly - (loop t1 '() moved #f) - (loop t1 (list s+d) moved s))))) - (((and s+d (s . d)) . b) - (match (split-move to-move d) - ((r . t1) (loop t1 (acons d r being-moved) moved last-source)) - (#f (match b - (() (loop to-move '() (cons s+d moved) #f)) - (_ (if (eqv? d last-source) - (loop to-move - (replace-last-source tmp b) - (cons s+d (acons d tmp moved)) - tmp) - (loop to-move b (cons s+d moved) last-source)))))))))) - -(define (dead-after-def? k-idx v-idx dfa) - (not (intset-ref (dfa-k-in dfa k-idx) v-idx))) - -(define (dead-after-use? k-idx v-idx dfa) - (not (intset-ref (dfa-k-out dfa k-idx) v-idx))) - -(define (allocate-slots fun dfg) - (let* ((dfa (compute-live-variables fun dfg)) - (min-label (dfg-min-label dfg)) - (label-count (dfg-label-count dfg)) - (usev (make-vector label-count '())) - (defv (make-vector label-count '())) - (slots (make-vector (dfa-var-count dfa) #f)) - (constant-values (make-vector (dfa-var-count dfa) #f)) - (has-constv (make-bitvector (dfa-var-count dfa) #f)) - (has-slotv (make-bitvector (dfa-var-count dfa) #t)) - (needs-slotv (make-bitvector (dfa-var-count dfa) #t)) - (needs-hintv (make-bitvector (dfa-var-count dfa) #f)) - (call-allocations (make-hash-table)) - (nlocals 0) ; Mutable. It pains me. - (nlocals-table (make-hash-table))) - - (define (label->idx label) (- label min-label)) - (define (idx->label idx) (+ idx min-label)) - - (define (bump-nlocals! nlocals*) - (when (< nlocals nlocals*) - (set! nlocals nlocals*))) - - (define (empty-live-slots) - #b0) - - (define (add-live-slot slot live-slots) - (logior live-slots (ash 1 slot))) - - (define (kill-dead-slot slot live-slots) - (logand live-slots (lognot (ash 1 slot)))) - - (define (compute-slot live-slots hint) - ;; Slots 253-255 are reserved for shuffling; see comments in - ;; assembler.scm. - (if (and hint (not (logbit? hint live-slots)) - (or (< hint 253) (> hint 255))) - hint - (let ((slot (find-first-zero live-slots))) - (if (or (< slot 253) (> slot 255)) - slot - (+ 256 (find-first-zero (ash live-slots -256))))))) - - (define (compute-call-proc-slot live-slots) - (+ 2 (find-first-trailing-zero live-slots))) - - (define (compute-prompt-handler-proc-slot live-slots) - (if (zero? live-slots) - 0 - (1- (find-first-trailing-zero live-slots)))) - - (define (recompute-live-slots k) - (let ((in (dfa-k-in dfa (label->idx k)))) - (let lp ((v 0) (live-slots 0)) - (let ((v (intset-next in v))) - (if v - (let ((slot (vector-ref slots v))) - (lp (1+ v) - (if slot - (add-live-slot slot live-slots) - live-slots))) - live-slots))))) - - (define* (allocate! var-idx hint live) - (cond - ((not (bitvector-ref needs-slotv var-idx)) live) - ((vector-ref slots var-idx) => (cut add-live-slot <> live)) - ((and (not hint) (bitvector-ref needs-hintv var-idx)) live) - (else - (let ((slot (compute-slot live hint))) - (bump-nlocals! (1+ slot)) - (vector-set! slots var-idx slot) - (add-live-slot slot live))))) - - ;; Although some parallel moves may proceed without a temporary - ;; slot, in general one is needed. That temporary slot must not be - ;; part of the source or destination sets, and that slot should not - ;; correspond to a live variable. Usually the source and - ;; destination sets are a subset of the union of the live sets - ;; before and after the move. However for stack slots that don't - ;; have names -- those slots that correspond to function arguments - ;; or to function return values -- it could be that they are out of - ;; the computed live set. In that case they need to be adjoined to - ;; the live set, used when choosing a temporary slot. - ;; - ;; Note that although we reserve slots 253-255 for shuffling - ;; operands that address less than the full 24-bit range of locals, - ;; that reservation doesn't apply here, because this temporary - ;; itself is used while doing parallel assignment via "mov", and - ;; "mov" does not need shuffling. - (define (compute-tmp-slot live stack-slots) - (find-first-zero (fold add-live-slot live stack-slots))) - - (define (parallel-move src-slots dst-slots tmp-slot) - (let ((moves (solve-parallel-move src-slots dst-slots tmp-slot))) - (when (assv tmp-slot moves) - (bump-nlocals! (1+ tmp-slot))) - moves)) - - ;; Find variables that are actually constant, and determine which - ;; of those can avoid slot allocation. - (define (compute-constants!) - (let lp ((n 0)) - (when (< n (vector-length constant-values)) - (let ((sym (dfa-var-sym dfa n))) - (call-with-values (lambda () (find-constant-value sym dfg)) - (lambda (has-const? const) - (when has-const? - (bitvector-set! has-constv n has-const?) - (vector-set! constant-values n const) - (when (not (constant-needs-allocation? sym const dfg)) - (bitvector-set! needs-slotv n #f))) - (lp (1+ n)))))))) - - ;; Record uses and defs, as lists of variable indexes, indexed by - ;; label index. - (define (compute-uses-and-defs!) - (let lp ((n 0)) - (when (< n (vector-length usev)) - (match (lookup-cont (idx->label n) dfg) - (($ $kfun src meta self) - (vector-set! defv n (list (dfa-var-idx dfa self)))) - (($ $kargs names syms body) - (vector-set! defv n (map (cut dfa-var-idx dfa <>) syms)) - (vector-set! usev n - (map (cut dfa-var-idx dfa <>) - (match (find-expression body) - (($ $call proc args) - (cons proc args)) - (($ $callk k proc args) - (cons proc args)) - (($ $primcall name args) - args) - (($ $branch kt ($ $primcall name args)) - args) - (($ $branch kt ($ $values args)) - args) - (($ $values args) - args) - (($ $prompt escape? tag handler) - (list tag)) - (_ '()))))) - (_ #f)) - (lp (1+ n))))) - - ;; Results of function calls that are not used don't need to be - ;; allocated to slots. - (define (compute-unused-results!) - (define (kreceive-get-kargs kreceive) - (match (lookup-cont kreceive dfg) - (($ $kreceive arity kargs) kargs) - (_ #f))) - (let ((candidates (make-bitvector label-count #f))) - ;; Find all $kargs that are the successors of $kreceive nodes. - (let lp ((n 0)) - (when (< n label-count) - (and=> (kreceive-get-kargs (idx->label n)) - (lambda (kargs) - (bitvector-set! candidates (label->idx kargs) #t))) - (lp (1+ n)))) - ;; For $kargs that only have $kreceive predecessors, remove unused - ;; variables from the needs-slotv set. - (let lp ((n 0)) - (let ((n (bit-position #t candidates n))) - (when n - (match (lookup-predecessors (idx->label n) dfg) - ;; At least one kreceive is in the predecessor set, so we - ;; only need to do the check for nodes with >1 - ;; predecessor. - ((or (_) ((? kreceive-get-kargs) ...)) - (for-each (lambda (var) - (when (dead-after-def? n var dfa) - (bitvector-set! needs-slotv var #f))) - (vector-ref defv n))) - (_ #f)) - (lp (1+ n))))))) - - ;; Compute the set of variables whose allocation should be delayed - ;; until a "hint" is known about where to allocate them. This is - ;; the case for some procedure arguments. - ;; - ;; This algorithm used is a conservative approximation of what - ;; really should happen, which would be eager allocation of call - ;; frames as soon as it's known that a call will happen. It would - ;; be nice to recast this as a proper data-flow problem. - (define (compute-needs-hint!) - (define (live-before n) - (dfa-k-in dfa n)) - (define (live-after n) - (dfa-k-out dfa n)) - (define needs-slot - (bitvector->intset needs-slotv)) - - ;; Walk backwards. At a call, compute the set of variables that - ;; have allocated slots and are live before but not after. This - ;; set contains candidates for needs-hintv. - (define (scan-for-call n) - (when (<= 0 n) - (match (lookup-cont (idx->label n) dfg) - (($ $kargs names syms body) - (match (find-expression body) - ((or ($ $call) ($ $callk)) - (let* ((args (intset-subtract (live-before n) (live-after n))) - (args-needing-slots (intset-intersect args needs-slot))) - (if (intset-next args-needing-slots #f) - (scan-for-hints (1- n) args-needing-slots) - (scan-for-call (1- n))))) - (_ (scan-for-call (1- n))))) - (_ (scan-for-call (1- n)))))) - - ;; Walk backwards in the current basic block. Stop when the block - ;; ends, we reach a call, or when an expression kills a value. - (define (scan-for-hints n args) - (when (< 0 n) - (match (lookup-cont (idx->label n) dfg) - (($ $kargs names syms body) - (match (lookup-predecessors (idx->label (1+ n)) dfg) - (((? (cut eqv? <> (idx->label n)))) - ;; If we are indeed in the same basic block, then if we - ;; are finished with the scan, we kill uses of the - ;; terminator, but leave its definitions. - (match (find-expression body) - ((or ($ $const) ($ $prim) ($ $closure) - ($ $primcall) ($ $prompt) - ;; If $values has more than one argument, it may - ;; use a temporary, which would invalidate our - ;; assumptions that slots not allocated are not - ;; used. - ($ $values (or () (_)))) - (define (intset-empty? intset) (not (intset-next intset))) - (let ((killed (intset-subtract (live-before n) (live-after n)))) - ;; If the expression kills no values needing slots, - ;; and defines no value needing a slot that's not - ;; in our args, then we keep on trucking. - (if (intset-empty? (intset-intersect - (fold (lambda (def clobber) - (if (intset-ref args def) - clobber - (intset-add clobber def))) - killed - (vector-ref defv n)) - needs-slot)) - (scan-for-hints (1- n) args) - (finish-hints n (live-before n) args)))) - ((or ($ $call) ($ $callk) ($ $values) ($ $branch)) - (finish-hints n (live-before n) args)))) - ;; Otherwise we kill uses of the block entry. - (_ (finish-hints n (live-before (1+ n)) args)))) - (_ (finish-hints n (live-before (1+ n)) args))))) - - ;; Add definitions ARGS minus KILL to NEED-HINTS, and go back to - ;; looking for calls. - (define (finish-hints n kill args) - (let ((new-hints (intset-subtract args kill))) - (let lp ((n 0)) - (let ((n (intset-next new-hints n))) - (when n - (bitvector-set! needs-hintv n #t) - (lp (1+ n)))))) - (scan-for-call n)) - - (scan-for-call (1- label-count))) - - (define (allocate-call label k uses pre-live post-live) - (match (lookup-cont k dfg) - (($ $ktail) - (let* ((tail-nlocals (length uses)) - (tail-slots (iota tail-nlocals)) - (pre-live (fold allocate! pre-live uses tail-slots)) - (moves (parallel-move (map (cut vector-ref slots <>) uses) - tail-slots - (compute-tmp-slot pre-live tail-slots)))) - (bump-nlocals! tail-nlocals) - (hashq-set! call-allocations label - (make-call-allocation #f moves #f)))) - (($ $kreceive arity kargs) - (let* ((proc-slot (compute-call-proc-slot post-live)) - (call-slots (map (cut + proc-slot <>) (iota (length uses)))) - (pre-live (fold allocate! pre-live uses call-slots)) - (arg-moves (parallel-move (map (cut vector-ref slots <>) uses) - call-slots - (compute-tmp-slot pre-live - call-slots))) - (result-vars (vector-ref defv (label->idx kargs))) - (value-slots (map (cut + proc-slot 1 <>) - (iota (length result-vars)))) - ;; Shuffle the first result down to the lowest slot, and - ;; leave any remaining results where they are. This - ;; strikes a balance between avoiding shuffling, - ;; especially for unused extra values, and avoiding - ;; frame size growth due to sparse locals. - (result-live (match (cons result-vars value-slots) - ((() . ()) post-live) - (((var . vars) . (slot . slots)) - (fold allocate! - (allocate! var #f post-live) - vars slots)))) - (result-slots (map (cut vector-ref slots <>) result-vars)) - ;; Filter out unused results. - (value-slots (filter-map (lambda (val result) (and result val)) - value-slots result-slots)) - (result-slots (filter (lambda (x) x) result-slots)) - (result-moves (parallel-move value-slots - result-slots - (compute-tmp-slot result-live - value-slots))) - (dead-slot-map (logand (1- (ash 1 (- proc-slot 2))) - (lognot post-live)))) - (bump-nlocals! (+ proc-slot (length uses))) - (hashq-set! call-allocations label - (make-call-allocation proc-slot arg-moves dead-slot-map)) - (hashq-set! call-allocations k - (make-call-allocation proc-slot result-moves #f)))))) - - (define (allocate-values label k uses pre-live post-live) - (match (lookup-cont k dfg) - (($ $ktail) - (let* ((src-slots (map (cut vector-ref slots <>) uses)) - (tail-nlocals (1+ (length uses))) - (dst-slots (cdr (iota tail-nlocals))) - (moves (parallel-move src-slots dst-slots - (compute-tmp-slot pre-live dst-slots)))) - (bump-nlocals! tail-nlocals) - (hashq-set! call-allocations label - (make-call-allocation #f moves #f)))) - (($ $kargs (_) (_)) - ;; When there is only one value in play, we allow the dst to be - ;; hinted (see scan-for-hints). If the src doesn't have a - ;; slot, then the actual slot for the dst would end up being - ;; decided by the call that uses it. Because we don't know the - ;; slot, we can't really compute the parallel moves in that - ;; case, so just bail and rely on the bytecode emitter to - ;; handle the one-value case specially. - (match (cons uses (vector-ref defv (label->idx k))) - (((src) . (dst)) - (allocate! dst (vector-ref slots src) post-live)))) - (($ $kargs) - (let* ((src-slots (map (cut vector-ref slots <>) uses)) - (dst-vars (vector-ref defv (label->idx k))) - (result-live (fold allocate! post-live dst-vars src-slots)) - (dst-slots (map (cut vector-ref slots <>) dst-vars)) - (moves (parallel-move src-slots dst-slots - (compute-tmp-slot (logior pre-live result-live) - '())))) - (hashq-set! call-allocations label - (make-call-allocation #f moves #f)))))) - - (define (allocate-prompt label k handler) - (match (lookup-cont handler dfg) - (($ $kreceive arity kargs) - (let* ((handler-live (recompute-live-slots handler)) - (proc-slot (compute-prompt-handler-proc-slot handler-live)) - (result-vars (vector-ref defv (label->idx kargs))) - (value-slots (map (cut + proc-slot 1 <>) - (iota (length result-vars)))) - (result-live (fold allocate! - handler-live result-vars value-slots)) - (result-slots (map (cut vector-ref slots <>) result-vars)) - ;; Filter out unused results. - (value-slots (filter-map (lambda (val result) (and result val)) - value-slots result-slots)) - (result-slots (filter (lambda (x) x) result-slots)) - (moves (parallel-move value-slots - result-slots - (compute-tmp-slot result-live - value-slots)))) - (bump-nlocals! (+ proc-slot 1 (length result-vars))) - (hashq-set! call-allocations handler - (make-call-allocation proc-slot moves #f)))))) - - (define (allocate-defs! n live) - (fold (cut allocate! <> #f <>) live (vector-ref defv n))) - - ;; This traversal will visit definitions before uses, as - ;; definitions dominate uses and a block's dominator will appear - ;; before it, in reverse post-order. - (define (visit-clause n live) - (let lp ((n n) (live (recompute-live-slots (idx->label n)))) - (define (kill-dead live vars-by-label-idx pred) - (fold (lambda (v live) - (let ((slot (vector-ref slots v))) - (if (and slot (pred n v dfa)) - (kill-dead-slot slot live) - live))) - live - (vector-ref vars-by-label-idx n))) - (define (kill-dead-defs live) - (kill-dead live defv dead-after-def?)) - (define (kill-dead-uses live) - (kill-dead live usev dead-after-use?)) - (if (= n label-count) - n - (let* ((label (idx->label n)) - (live (if (control-point? label dfg) - (recompute-live-slots label) - live)) - (live (kill-dead-defs (allocate-defs! n live))) - (post-live (kill-dead-uses live))) - ;; LIVE are the live slots coming into the term. - ;; POST-LIVE is the subset that is still live after the - ;; term uses its inputs. - (match (lookup-cont (idx->label n) dfg) - (($ $kclause) n) - (($ $kargs names syms body) - (define (compute-k-live k) - (match (lookup-predecessors k dfg) - ((_) post-live) - (_ (recompute-live-slots k)))) - (let ((uses (vector-ref usev n))) - (match (find-call body) - (($ $continue k src (or ($ $call) ($ $callk))) - (allocate-call label k uses live (compute-k-live k))) - (($ $continue k src ($ $primcall)) #t) - (($ $continue k src ($ $values)) - (allocate-values label k uses live (compute-k-live k))) - (($ $continue k src ($ $prompt escape? tag handler)) - (allocate-prompt label k handler)) - (_ #f))) - (lp (1+ n) post-live)) - ((or ($ $kreceive) ($ $ktail)) - (lp (1+ n) post-live))))))) - - (define (visit-entry) - (define (visit-clauses n live) - (unless (eqv? live (add-live-slot 0 (empty-live-slots))) - (error "Unexpected clause live set")) - (set! nlocals 1) - (match (lookup-cont (idx->label n) dfg) - (($ $kclause arity ($ $cont kbody ($ $kargs names)) alternate) - (unless (eq? (idx->label (1+ n)) kbody) - (error "Unexpected label order")) - (let* ((nargs (length names)) - (next (visit-clause (1+ n) - (fold allocate! live - (vector-ref defv (1+ n)) - (cdr (iota (1+ nargs))))))) - (hashq-set! nlocals-table (idx->label n) nlocals) - (when (< next label-count) - (match alternate - (($ $cont kalt) - (unless (eq? kalt (idx->label next)) - (error "Unexpected clause order")))) - (visit-clauses next live)))))) - (match (lookup-cont (idx->label 0) dfg) - (($ $kfun src meta self) - (visit-clauses 1 (allocate-defs! 0 (empty-live-slots)))))) - - (compute-constants!) - (compute-uses-and-defs!) - (compute-unused-results!) - (compute-needs-hint!) - (visit-entry) - - (make-allocation dfa slots - has-constv constant-values - call-allocations - nlocals-table))) diff --git a/module/language/cps/spec.scm b/module/language/cps/spec.scm deleted file mode 100644 index f1255afeb..000000000 --- a/module/language/cps/spec.scm +++ /dev/null @@ -1,37 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Code: - -(define-module (language cps spec) - #:use-module (system base language) - #:use-module (language cps) - #:use-module (language cps compile-bytecode) - #:export (cps)) - -(define* (write-cps exp #:optional (port (current-output-port))) - (write (unparse-cps exp) port)) - -(define-language cps - #:title "CPS Intermediate Language" - #:reader (lambda (port env) (read port)) - #:printer write-cps - #:parser parse-cps - #:compilers `((bytecode . ,compile-bytecode)) - #:for-humans? #f - ) diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm deleted file mode 100644 index 6c2310737..000000000 --- a/module/language/cps/verify.scm +++ /dev/null @@ -1,195 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; -;;; Code: - -(define-module (language cps verify) - #:use-module (ice-9 match) - #:use-module (srfi srfi-26) - #:use-module (language cps) - #:export (verify-cps)) - -(define (verify-cps fun) - (define seen-labels (make-hash-table)) - (define seen-vars (make-hash-table)) - - (define (add sym seen env) - (when (hashq-ref seen sym) - (error "duplicate gensym" sym)) - (hashq-set! seen sym #t) - (cons sym env)) - - (define (add-env new seen env) - (if (null? new) - env - (add-env (cdr new) seen (add (car new) seen env)))) - - (define (add-vars new env) - (unless (and-map exact-integer? new) - (error "bad vars" new)) - (add-env new seen-vars env)) - - (define (add-labels new env) - (unless (and-map exact-integer? new) - (error "bad labels" new)) - (add-env new seen-labels env)) - - (define (check-ref sym seen env) - (cond - ((not (hashq-ref seen sym)) - (error "unbound lexical" sym)) - ((not (memq sym env)) - (error "displaced lexical" sym)))) - - (define (check-label sym env) - (check-ref sym seen-labels env)) - - (define (check-var sym env) - (check-ref sym seen-vars env)) - - (define (check-src src) - (if (and src (not (and (list? src) (and-map pair? src) - (and-map symbol? (map car src))))) - (error "bad src"))) - - (define (visit-cont-body cont k-env v-env) - (match cont - (($ $kreceive ($ $arity ((? symbol?) ...) () (or #f (? symbol?)) () #f) k) - (check-label k k-env)) - (($ $kargs (name ...) (sym ...) body) - (unless (= (length name) (length sym)) - (error "name and sym lengths don't match" name sym)) - (visit-term body k-env (add-vars sym v-env))) - (_ - ;; $kclause, $kfun, and $ktail are only ever seen in $fun. - (error "unexpected cont body" cont)))) - - (define (visit-clause clause k-env v-env) - (match clause - (($ $cont kclause - ($ $kclause - ($ $arity - ((? symbol? req) ...) - ((? symbol? opt) ...) - (and rest (or #f (? symbol?))) - (((? keyword? kw) (? symbol? kwname) kwsym) ...) - (or #f #t)) - ($ $cont kbody (and body ($ $kargs names syms _))) - alternate)) - (for-each (lambda (sym) - (unless (memq sym syms) - (error "bad keyword sym" sym))) - kwsym) - ;; FIXME: It is technically possible for kw syms to alias other - ;; syms. - (unless (equal? (append req opt (if rest (list rest) '()) kwname) - names) - (error "clause body names do not match arity names" exp)) - (let ((k-env (add-labels (list kclause kbody) k-env))) - (visit-cont-body body k-env v-env)) - (when alternate - (visit-clause alternate k-env v-env))) - (_ - (error "unexpected clause" clause)))) - - (define (visit-entry entry k-env v-env) - (match entry - (($ $cont kbody - ($ $kfun src meta self ($ $cont ktail ($ $ktail)) clause)) - (when (and meta (not (and (list? meta) (and-map pair? meta)))) - (error "meta should be alist" meta)) - (check-src src) - ;; Reset the continuation environment, because Guile's - ;; continuations are local. - (let ((v-env (add-vars (list self) v-env)) - (k-env (add-labels (list ktail) '()))) - (when clause - (visit-clause clause k-env v-env)))) - (_ (error "unexpected $kfun" entry)))) - - (define (visit-fun fun k-env v-env) - (match fun - (($ $fun entry) - (visit-entry entry '() v-env)) - (_ - (error "unexpected $fun" fun)))) - - (define (visit-expression exp k-env v-env) - (match exp - (($ $const val) - #t) - (($ $prim (? symbol? name)) - #t) - (($ $closure kfun n) - #t) - (($ $fun) - (visit-fun exp k-env v-env)) - (($ $rec (name ...) (sym ...) (fun ...)) - (unless (= (length name) (length sym) (length fun)) - (error "letrec syms, names, and funs not same length" term)) - ;; FIXME: syms added in two places (here in $rec versus also in - ;; target $kargs) - (let ((v-env (add-vars sym v-env))) - (for-each (cut visit-fun <> k-env v-env) fun))) - (($ $call proc (arg ...)) - (check-var proc v-env) - (for-each (cut check-var <> v-env) arg)) - (($ $callk k* proc (arg ...)) - ;; We don't check that k* is in scope; it's actually inside some - ;; other function, probably. We rely on the transformation that - ;; introduces the $callk to be correct, and the linker to resolve - ;; the reference. - (check-var proc v-env) - (for-each (cut check-var <> v-env) arg)) - (($ $branch kt ($ $primcall (? symbol? name) (arg ...))) - (check-var kt k-env) - (for-each (cut check-var <> v-env) arg)) - (($ $branch kt ($ $values (arg ...))) - (check-var kt k-env) - (for-each (cut check-var <> v-env) arg)) - (($ $primcall (? symbol? name) (arg ...)) - (for-each (cut check-var <> v-env) arg)) - (($ $values (arg ...)) - (for-each (cut check-var <> v-env) arg)) - (($ $prompt escape? tag handler) - (unless (boolean? escape?) (error "escape? should be boolean" escape?)) - (check-var tag v-env) - (check-label handler k-env)) - (_ - (error "unexpected expression" exp)))) - - (define (visit-term term k-env v-env) - (match term - (($ $letk (($ $cont k cont) ...) body) - (let ((k-env (add-labels k k-env))) - (for-each (cut visit-cont-body <> k-env v-env) cont) - (visit-term body k-env v-env))) - - (($ $continue k src exp) - (check-label k k-env) - (check-src src) - (visit-expression exp k-env v-env)) - - (_ - (error "unexpected term" term)))) - - (visit-entry fun '() '()) - fun) diff --git a/module/language/cps2/compile-cps.scm b/module/language/cps2/compile-cps.scm deleted file mode 100644 index ee6e3d5bb..000000000 --- a/module/language/cps2/compile-cps.scm +++ /dev/null @@ -1,129 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; Compiling CPS2 to CPS. When/if CPS2 replaces CPS, this module will be removed. -;;; -;;; Code: - -(define-module (language cps2 compile-cps) - #:use-module (ice-9 match) - #:use-module (language cps2) - #:use-module ((language cps) #:prefix cps:) - #:use-module (language cps2 utils) - #:use-module (language cps2 closure-conversion) - #:use-module (language cps2 optimize) - #:use-module (language cps2 reify-primitives) - #:use-module (language cps2 renumber) - #:use-module (language cps intmap) - #:export (compile-cps)) - -;; Precondition: For each function in CONTS, the continuation names are -;; topologically sorted. -(define* (conts->fun conts #:optional (kfun 0)) - (define (convert-fun kfun) - (let ((doms (compute-dom-edges (compute-idoms conts kfun)))) - (define (visit-cont label) - (cps:rewrite-cps-cont (intmap-ref conts label) - (($ $kargs names syms body) - (label (cps:$kargs names syms ,(redominate label (visit-term body))))) - (($ $ktail) - (label (cps:$ktail))) - (($ $kreceive ($ $arity req () rest () #f) kargs) - (label (cps:$kreceive req rest kargs))))) - (define (visit-clause label) - (and label - (cps:rewrite-cps-cont (intmap-ref conts label) - (($ $kclause ($ $arity req opt rest kw aok?) kbody kalt) - (label (cps:$kclause (req opt rest kw aok?) - ,(visit-cont kbody) - ,(visit-clause kalt))))))) - (define (redominate label term) - (define (visit-dom-conts label) - (match (intmap-ref conts label) - (($ $ktail) '()) - (($ $kargs) (list (visit-cont label))) - (else - (cons (visit-cont label) - (visit-dom-conts* (intmap-ref doms label)))))) - (define (visit-dom-conts* labels) - (match labels - (() '()) - ((label . labels) - (append (visit-dom-conts label) - (visit-dom-conts* labels))))) - (cps:rewrite-cps-term (visit-dom-conts* (intmap-ref doms label)) - (() ,term) - (conts (cps:$letk ,conts ,term)))) - (define (visit-term term) - (cps:rewrite-cps-term term - (($ $continue k src (and ($ $fun) fun)) - (cps:$continue k src ,(visit-fun fun))) - (($ $continue k src ($ $rec names syms funs)) - (cps:$continue k src (cps:$rec names syms (map visit-fun funs)))) - (($ $continue k src exp) - (cps:$continue k src ,(visit-exp exp))))) - (define (visit-exp exp) - (cps:rewrite-cps-exp exp - (($ $const val) (cps:$const val)) - (($ $prim name) (cps:$prim name)) - (($ $closure k nfree) (cps:$closure k nfree)) - (($ $call proc args) (cps:$call proc args)) - (($ $callk k proc args) (cps:$callk k proc args)) - (($ $primcall name args) (cps:$primcall name args)) - (($ $branch k exp) (cps:$branch k ,(visit-exp exp))) - (($ $values args) (cps:$values args)) - (($ $prompt escape? tag handler) (cps:$prompt escape? tag handler)))) - (define (visit-fun fun) - (cps:rewrite-cps-exp fun - (($ $fun body) - (cps:$fun ,(convert-fun body))))) - - (cps:rewrite-cps-cont (intmap-ref conts kfun) - (($ $kfun src meta self tail clause) - (kfun (cps:$kfun src meta self (tail (cps:$ktail)) - ,(visit-clause clause))))))) - (convert-fun kfun)) - -(define (conts->fun* conts) - (cps:build-cps-term - (cps:$program - ,(intmap-fold-right (lambda (label cont out) - (match cont - (($ $kfun) - (cons (conts->fun conts label) out)) - (_ out))) - conts - '())))) - -(define (kw-arg-ref args kw default) - (match (memq kw args) - ((_ val . _) val) - (_ default))) - -(define (compile-cps exp env opts) - ;; Use set! to save memory at bootstrap-time. (The interpreter holds - ;; onto all free variables locally bound in a function, so if we used - ;; let*, we'd hold onto earlier copies of the term.) - (set! exp (optimize-higher-order-cps exp opts)) - (set! exp (convert-closures exp)) - (set! exp (optimize-first-order-cps exp opts)) - (set! exp (reify-primitives exp)) - (set! exp (renumber exp)) - (values (conts->fun* exp) env env)) From aa7f0e25ac8ea8340745f6aa337a9f0c64f00881 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 22 Jul 2015 17:18:30 +0200 Subject: [PATCH 032/865] Rename CPS2 to CPS --- module/Makefile.am | 57 +- module/language/cps2.scm | 362 ----- module/language/cps2/closure-conversion.scm | 824 ---------- module/language/cps2/compile-bytecode.scm | 433 ----- module/language/cps2/constructors.scm | 98 -- module/language/cps2/contification.scm | 475 ------ module/language/cps2/cse.scm | 449 ------ module/language/cps2/dce.scm | 399 ----- module/language/cps2/effects-analysis.scm | 484 ------ module/language/cps2/elide-values.scm | 88 -- module/language/cps2/optimize.scm | 106 -- module/language/cps2/prune-bailouts.scm | 86 - .../language/cps2/prune-top-level-scopes.scm | 63 - module/language/cps2/reify-primitives.scm | 167 -- module/language/cps2/renumber.scm | 217 --- module/language/cps2/self-references.scm | 79 - module/language/cps2/simplify.scm | 267 ---- module/language/cps2/slot-allocation.scm | 995 ------------ module/language/cps2/spec.scm | 37 - module/language/cps2/specialize-primcalls.scm | 59 - module/language/cps2/split-rec.scm | 174 -- module/language/cps2/type-fold.scm | 425 ----- module/language/cps2/types.scm | 1408 ----------------- module/language/cps2/utils.scm | 477 ------ module/language/cps2/verify.scm | 306 ---- module/language/cps2/with-cps.scm | 145 -- .../{compile-cps2.scm => compile-cps.scm} | 12 +- module/language/tree-il/spec.scm | 6 +- 28 files changed, 36 insertions(+), 8662 deletions(-) delete mode 100644 module/language/cps2.scm delete mode 100644 module/language/cps2/closure-conversion.scm delete mode 100644 module/language/cps2/compile-bytecode.scm delete mode 100644 module/language/cps2/constructors.scm delete mode 100644 module/language/cps2/contification.scm delete mode 100644 module/language/cps2/cse.scm delete mode 100644 module/language/cps2/dce.scm delete mode 100644 module/language/cps2/effects-analysis.scm delete mode 100644 module/language/cps2/elide-values.scm delete mode 100644 module/language/cps2/optimize.scm delete mode 100644 module/language/cps2/prune-bailouts.scm delete mode 100644 module/language/cps2/prune-top-level-scopes.scm delete mode 100644 module/language/cps2/reify-primitives.scm delete mode 100644 module/language/cps2/renumber.scm delete mode 100644 module/language/cps2/self-references.scm delete mode 100644 module/language/cps2/simplify.scm delete mode 100644 module/language/cps2/slot-allocation.scm delete mode 100644 module/language/cps2/spec.scm delete mode 100644 module/language/cps2/specialize-primcalls.scm delete mode 100644 module/language/cps2/split-rec.scm delete mode 100644 module/language/cps2/type-fold.scm delete mode 100644 module/language/cps2/types.scm delete mode 100644 module/language/cps2/utils.scm delete mode 100644 module/language/cps2/verify.scm delete mode 100644 module/language/cps2/with-cps.scm rename module/language/tree-il/{compile-cps2.scm => compile-cps.scm} (99%) diff --git a/module/Makefile.am b/module/Makefile.am index c53f9e466..b29a4bf00 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -60,7 +60,6 @@ SOURCES = \ \ language/tree-il.scm \ $(TREE_IL_LANG_SOURCES) \ - $(CPS2_LANG_SOURCES) \ $(CPS_LANG_SOURCES) \ $(BYTECODE_LANG_SOURCES) \ $(VALUE_LANG_SOURCES) \ @@ -117,39 +116,37 @@ TREE_IL_LANG_SOURCES = \ language/tree-il/canonicalize.scm \ language/tree-il/analyze.scm \ language/tree-il/inline.scm \ - language/tree-il/compile-cps2.scm \ + language/tree-il/compile-cps.scm \ language/tree-il/debug.scm \ language/tree-il/spec.scm CPS_LANG_SOURCES = \ - language/cps/primitives.scm - -CPS2_LANG_SOURCES = \ - language/cps2.scm \ - language/cps2/closure-conversion.scm \ - language/cps2/compile-bytecode.scm \ - language/cps2/constructors.scm \ - language/cps2/contification.scm \ - language/cps2/cse.scm \ - language/cps2/dce.scm \ - language/cps2/effects-analysis.scm \ - language/cps2/elide-values.scm \ - language/cps2/prune-bailouts.scm \ - language/cps2/prune-top-level-scopes.scm \ - language/cps2/reify-primitives.scm \ - language/cps2/renumber.scm \ - language/cps2/optimize.scm \ - language/cps2/simplify.scm \ - language/cps2/self-references.scm \ - language/cps2/slot-allocation.scm \ - language/cps2/spec.scm \ - language/cps2/specialize-primcalls.scm \ - language/cps2/split-rec.scm \ - language/cps2/type-fold.scm \ - language/cps2/types.scm \ - language/cps2/utils.scm \ - language/cps2/verify.scm \ - language/cps2/with-cps.scm + language/cps.scm \ + language/cps/closure-conversion.scm \ + language/cps/compile-bytecode.scm \ + language/cps/constructors.scm \ + language/cps/contification.scm \ + language/cps/cse.scm \ + language/cps/dce.scm \ + language/cps/effects-analysis.scm \ + language/cps/elide-values.scm \ + language/cps/primitives.scm \ + language/cps/prune-bailouts.scm \ + language/cps/prune-top-level-scopes.scm \ + language/cps/reify-primitives.scm \ + language/cps/renumber.scm \ + language/cps/optimize.scm \ + language/cps/simplify.scm \ + language/cps/self-references.scm \ + language/cps/slot-allocation.scm \ + language/cps/spec.scm \ + language/cps/specialize-primcalls.scm \ + language/cps/split-rec.scm \ + language/cps/type-fold.scm \ + language/cps/types.scm \ + language/cps/utils.scm \ + language/cps/verify.scm \ + language/cps/with-cps.scm BYTECODE_LANG_SOURCES = \ language/bytecode.scm \ diff --git a/module/language/cps2.scm b/module/language/cps2.scm deleted file mode 100644 index 76219f376..000000000 --- a/module/language/cps2.scm +++ /dev/null @@ -1,362 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; [Transitional note: CPS2 is a new version of CPS, and is a bit of an -;;; experiment. All of the comments in this file pretend that CPS2 will -;;; replace CPS, and will be named CPS.] -;;; -;;; This is the continuation-passing style (CPS) intermediate language -;;; (IL) for Guile. -;;; -;;; In CPS, a term is a labelled expression that calls a continuation. -;;; A function is a collection of terms. No term belongs to more than -;;; one function. The function is identified by the label of its entry -;;; term, and its body is composed of those terms that are reachable -;;; from the entry term. A program is a collection of functions, -;;; identified by the entry label of the entry function. -;;; -;;; Terms are themselves wrapped in continuations, which specify how -;;; predecessors may continue to them. For example, a $kargs -;;; continuation specifies that the term may be called with a specific -;;; number of values, and that those values will then be bound to -;;; lexical variables. $kreceive specifies that some number of values -;;; will be passed on the stack, as from a multiple-value return. Those -;;; values will be passed to a $kargs, if the number of values is -;;; compatible with the $kreceive's arity. $kfun is an entry point to a -;;; function, and receives arguments according to a well-known calling -;;; convention (currently, on the stack) and the stack before -;;; dispatching to a $kclause. A $kclause is a case-lambda clause, and -;;; only appears within a $kfun; it checks the incoming values for the -;;; correct arity and dispatches to a $kargs, or to the next clause. -;;; Finally, $ktail is the tail continuation for a function, and -;;; contains no term. -;;; -;;; Each continuation has a label that is unique in the program. As an -;;; implementation detail, the labels are integers, which allows us to -;;; easily sort them topologically. A program is a map from integers to -;;; continuations, where continuation 0 in the map is the entry point -;;; for the program, and is a $kfun of no arguments. -;;; -;;; $continue nodes call continuations. The expression contained in the -;;; $continue node determines the value or values that are passed to the -;;; target continuation: $const to pass a constant value, $values to -;;; pass multiple named values, etc. $continue nodes also record the -;;; source location corresponding to the expression. -;;; -;;; As mentioned above, a $kargs continuation can bind variables, if it -;;; receives incoming values. $kfun also binds a value, corresponding -;;; to the closure being called. A traditional CPS implementation will -;;; nest terms in each other, binding them in "let" forms, ensuring that -;;; continuations are declared and bound within the scope of the values -;;; that they may use. In this way, the scope tree is a proof that -;;; variables are defined before they are used. However, this proof is -;;; conservative; it is possible for a variable to always be defined -;;; before it is used, but not to be in scope: -;;; -;;; (letrec ((k1 (lambda (v1) (k2))) -;;; (k2 (lambda () v1))) -;;; (k1 0)) -;;; -;;; This example is invalid, as v1 is used outside its scope. However -;;; it would be perfectly fine for k2 to use v1 if k2 were nested inside -;;; k1: -;;; -;;; (letrec ((k1 (lambda (v1) -;;; (letrec ((k2 (lambda () v1))) -;;; (k2)))) -;;; (k1 0)) -;;; -;;; Because program transformation usually uses flow-based analysis, -;;; having to update the scope tree to manifestly prove a transformation -;;; that has already proven correct is needless overhead, and in the -;;; worst case can prevent optimizations from occuring. For that -;;; reason, Guile's CPS language does not nest terms. Instead, we use -;;; the invariant that definitions must dominate uses. To check the -;;; validity of a CPS program is thus more involved than checking for a -;;; well-scoped tree; you have to do flow analysis to determine a -;;; dominator tree. However the flexibility that this grants us is -;;; worth the cost of throwing away the embedded proof of the scope -;;; tree. -;;; -;;; This particular formulation of CPS was inspired by Andrew Kennedy's -;;; 2007 paper, "Compiling with Continuations, Continued". All Guile -;;; hackers should read that excellent paper! As in Kennedy's paper, -;;; continuations are second-class, and may be thought of as basic block -;;; labels. All values are bound to variables using continuation calls: -;;; even constants! -;;; -;;; Finally, note that there are two flavors of CPS: higher-order and -;;; first-order. By "higher-order", we mean that variables may be free -;;; across function boundaries. Higher-order CPS contains $fun and $rec -;;; expressions that declare functions in the scope of their term. -;;; Closure conversion results in first-order CPS, where closure -;;; representations have been explicitly chosen, and all variables used -;;; in a function are bound. Higher-order CPS is good for -;;; interprocedural optimizations like contification and beta reduction, -;;; while first-order CPS is better for instruction selection, register -;;; allocation, and code generation. -;;; -;;; See (language tree-il compile-cps) for details on how Tree-IL -;;; converts to CPS. -;;; -;;; Code: - -(define-module (language cps2) - #:use-module (ice-9 match) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-9 gnu) - #:use-module (srfi srfi-11) - #:export (;; Helper. - $arity - make-$arity - - ;; Continuations. - $kreceive $kargs $kfun $ktail $kclause - - ;; Terms. - $continue - - ;; Expressions. - $const $prim $fun $rec $closure $branch - $call $callk $primcall $values $prompt - - ;; Building macros. - build-cont build-term build-exp - rewrite-cont rewrite-term rewrite-exp - - ;; External representation. - parse-cps unparse-cps)) - -;; FIXME: Use SRFI-99, when Guile adds it. -(define-syntax define-record-type* - (lambda (x) - (define (id-append ctx . syms) - (datum->syntax ctx (apply symbol-append (map syntax->datum syms)))) - (syntax-case x () - ((_ name field ...) - (and (identifier? #'name) (and-map identifier? #'(field ...))) - (with-syntax ((cons (id-append #'name #'make- #'name)) - (pred (id-append #'name #'name #'?)) - ((getter ...) (map (lambda (f) - (id-append f #'name #'- f)) - #'(field ...)))) - #'(define-record-type name - (cons field ...) - pred - (field getter) - ...)))))) - -(define-syntax-rule (define-cps-type name field ...) - (begin - (define-record-type* name field ...) - (set-record-type-printer! name print-cps))) - -(define (print-cps exp port) - (format port "#" (unparse-cps exp))) - -;; Helper. -(define-record-type* $arity req opt rest kw allow-other-keys?) - -;; Continuations -(define-cps-type $kreceive arity kbody) -(define-cps-type $kargs names syms term) -(define-cps-type $kfun src meta self ktail kclause) -(define-cps-type $ktail) -(define-cps-type $kclause arity kbody kalternate) - -;; Terms. -(define-cps-type $continue k src exp) - -;; Expressions. -(define-cps-type $const val) -(define-cps-type $prim name) -(define-cps-type $fun body) ; Higher-order. -(define-cps-type $rec names syms funs) ; Higher-order. -(define-cps-type $closure label nfree) ; First-order. -(define-cps-type $branch kt exp) -(define-cps-type $call proc args) -(define-cps-type $callk k proc args) ; First-order. -(define-cps-type $primcall name args) -(define-cps-type $values args) -(define-cps-type $prompt escape? tag handler) - -(define-syntax build-arity - (syntax-rules (unquote) - ((_ (unquote exp)) exp) - ((_ (req opt rest kw allow-other-keys?)) - (make-$arity req opt rest kw allow-other-keys?)))) - -(define-syntax build-cont - (syntax-rules (unquote $kreceive $kargs $kfun $ktail $kclause) - ((_ (unquote exp)) - exp) - ((_ ($kreceive req rest kargs)) - (make-$kreceive (make-$arity req '() rest '() #f) kargs)) - ((_ ($kargs (name ...) (unquote syms) body)) - (make-$kargs (list name ...) syms (build-term body))) - ((_ ($kargs (name ...) (sym ...) body)) - (make-$kargs (list name ...) (list sym ...) (build-term body))) - ((_ ($kargs names syms body)) - (make-$kargs names syms (build-term body))) - ((_ ($kfun src meta self ktail kclause)) - (make-$kfun src meta self ktail kclause)) - ((_ ($ktail)) - (make-$ktail)) - ((_ ($kclause arity kbody kalternate)) - (make-$kclause (build-arity arity) kbody kalternate)))) - -(define-syntax build-term - (syntax-rules (unquote $rec $continue) - ((_ (unquote exp)) - exp) - ((_ ($continue k src exp)) - (make-$continue k src (build-exp exp))))) - -(define-syntax build-exp - (syntax-rules (unquote - $const $prim $fun $rec $closure $branch - $call $callk $primcall $values $prompt) - ((_ (unquote exp)) exp) - ((_ ($const val)) (make-$const val)) - ((_ ($prim name)) (make-$prim name)) - ((_ ($fun kentry)) (make-$fun kentry)) - ((_ ($rec names gensyms funs)) (make-$rec names gensyms funs)) - ((_ ($closure k nfree)) (make-$closure k nfree)) - ((_ ($call proc (unquote args))) (make-$call proc args)) - ((_ ($call proc (arg ...))) (make-$call proc (list arg ...))) - ((_ ($call proc args)) (make-$call proc args)) - ((_ ($callk k proc (unquote args))) (make-$callk k proc args)) - ((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...))) - ((_ ($callk k proc args)) (make-$callk k proc args)) - ((_ ($primcall name (unquote args))) (make-$primcall name args)) - ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...))) - ((_ ($primcall name args)) (make-$primcall name args)) - ((_ ($values (unquote args))) (make-$values args)) - ((_ ($values (arg ...))) (make-$values (list arg ...))) - ((_ ($values args)) (make-$values args)) - ((_ ($branch kt exp)) (make-$branch kt (build-exp exp))) - ((_ ($prompt escape? tag handler)) - (make-$prompt escape? tag handler)))) - -(define-syntax-rule (rewrite-cont x (pat cont) ...) - (match x - (pat (build-cont cont)) ...)) -(define-syntax-rule (rewrite-term x (pat term) ...) - (match x - (pat (build-term term)) ...)) -(define-syntax-rule (rewrite-exp x (pat body) ...) - (match x - (pat (build-exp body)) ...)) - -(define (parse-cps exp) - (define (src exp) - (let ((props (source-properties exp))) - (and (pair? props) props))) - (match exp - ;; Continuations. - (('kreceive req rest k) - (build-cont ($kreceive req rest k))) - (('kargs names syms body) - (build-cont ($kargs names syms ,(parse-cps body)))) - (('kfun src meta self ktail kclause) - (build-cont ($kfun (src exp) meta self ktail kclause))) - (('ktail) - (build-cont ($ktail))) - (('kclause (req opt rest kw allow-other-keys?) kbody) - (build-cont ($kclause (req opt rest kw allow-other-keys?) kbody #f))) - (('kclause (req opt rest kw allow-other-keys?) kbody kalt) - (build-cont ($kclause (req opt rest kw allow-other-keys?) kbody kalt))) - - ;; Calls. - (('continue k exp) - (build-term ($continue k (src exp) ,(parse-cps exp)))) - (('unspecified) - (build-exp ($const *unspecified*))) - (('const exp) - (build-exp ($const exp))) - (('prim name) - (build-exp ($prim name))) - (('fun kbody) - (build-exp ($fun kbody))) - (('closure k nfree) - (build-exp ($closure k nfree))) - (('rec (name sym fun) ...) - (build-exp ($rec name sym (map parse-cps fun)))) - (('call proc arg ...) - (build-exp ($call proc arg))) - (('callk k proc arg ...) - (build-exp ($callk k proc arg))) - (('primcall name arg ...) - (build-exp ($primcall name arg))) - (('branch k exp) - (build-exp ($branch k ,(parse-cps exp)))) - (('values arg ...) - (build-exp ($values arg))) - (('prompt escape? tag handler) - (build-exp ($prompt escape? tag handler))) - (_ - (error "unexpected cps" exp)))) - -(define (unparse-cps exp) - (match exp - ;; Continuations. - (($ $kreceive ($ $arity req () rest () #f) k) - `(kreceive ,req ,rest ,k)) - (($ $kargs names syms body) - `(kargs ,names ,syms ,(unparse-cps body))) - (($ $kfun src meta self ktail kclause) - `(kfun ,meta ,self ,ktail ,kclause)) - (($ $ktail) - `(ktail)) - (($ $kclause ($ $arity req opt rest kw allow-other-keys?) kbody kalternate) - `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,kbody - . ,(if kalternate (list kalternate) '()))) - - ;; Calls. - (($ $continue k src exp) - `(continue ,k ,(unparse-cps exp))) - (($ $const val) - (if (unspecified? val) - '(unspecified) - `(const ,val))) - (($ $prim name) - `(prim ,name)) - (($ $fun kbody) - `(fun ,kbody)) - (($ $closure k nfree) - `(closure ,k ,nfree)) - (($ $rec names syms funs) - `(rec ,@(map (lambda (name sym fun) - (list name sym (unparse-cps fun))) - names syms funs))) - (($ $call proc args) - `(call ,proc ,@args)) - (($ $callk k proc args) - `(callk ,k ,proc ,@args)) - (($ $primcall name args) - `(primcall ,name ,@args)) - (($ $branch k exp) - `(branch ,k ,(unparse-cps exp))) - (($ $values args) - `(values ,@args)) - (($ $prompt escape? tag handler) - `(prompt ,escape? ,tag ,handler)) - (_ - (error "unexpected cps" exp)))) diff --git a/module/language/cps2/closure-conversion.scm b/module/language/cps2/closure-conversion.scm deleted file mode 100644 index 7de34482f..000000000 --- a/module/language/cps2/closure-conversion.scm +++ /dev/null @@ -1,824 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; This pass converts a CPS term in such a way that no function has any -;;; free variables. Instead, closures are built explicitly with -;;; make-closure primcalls, and free variables are referenced through -;;; the closure. -;;; -;;; Closure conversion also removes any $rec expressions that -;;; contification did not handle. See (language cps) for a further -;;; discussion of $rec. -;;; -;;; Code: - -(define-module (language cps2 closure-conversion) - #:use-module (ice-9 match) - #:use-module ((srfi srfi-1) #:select (fold - filter-map - )) - #:use-module (srfi srfi-11) - #:use-module (language cps2) - #:use-module (language cps2 utils) - #:use-module (language cps2 with-cps) - #:use-module (language cps intmap) - #:use-module (language cps intset) - #:export (convert-closures)) - -(define (compute-function-bodies conts kfun) - "Compute a map from FUN-LABEL->BODY-LABEL... for all $fun instances in -conts." - (let visit-fun ((kfun kfun) (out empty-intmap)) - (let ((body (compute-function-body conts kfun))) - (intset-fold - (lambda (label out) - (match (intmap-ref conts label) - (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun))) - (visit-fun kfun out)) - (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfun) ...)))) - (fold visit-fun out kfun)) - (_ out))) - body - (intmap-add out kfun body))))) - -(define (compute-program-body functions) - (intmap-fold (lambda (label body out) (intset-union body out)) - functions - empty-intset)) - -(define (filter-reachable conts functions) - (let ((reachable (compute-program-body functions))) - (intmap-fold - (lambda (label cont out) - (if (intset-ref reachable label) - out - (intmap-remove out label))) - conts conts))) - -(define (compute-non-operator-uses conts) - (persistent-intset - (intmap-fold - (lambda (label cont uses) - (define (add-use var uses) (intset-add! uses var)) - (define (add-uses vars uses) - (match vars - (() uses) - ((var . vars) (add-uses vars (add-use var uses))))) - (match cont - (($ $kargs _ _ ($ $continue _ _ exp)) - (match exp - ((or ($ $const) ($ $prim) ($ $fun) ($ $rec)) uses) - (($ $values args) - (add-uses args uses)) - (($ $call proc args) - (add-uses args uses)) - (($ $branch kt ($ $values (arg))) - (add-use arg uses)) - (($ $branch kt ($ $primcall name args)) - (add-uses args uses)) - (($ $primcall name args) - (add-uses args uses)) - (($ $prompt escape? tag handler) - (add-use tag uses)))) - (_ uses))) - conts - empty-intset))) - -(define (compute-singly-referenced-labels conts body) - (define (add-ref label single multiple) - (define (ref k single multiple) - (if (intset-ref single k) - (values single (intset-add! multiple k)) - (values (intset-add! single k) multiple))) - (define (ref0) (values single multiple)) - (define (ref1 k) (ref k single multiple)) - (define (ref2 k k*) - (if k* - (let-values (((single multiple) (ref k single multiple))) - (ref k* single multiple)) - (ref1 k))) - (match (intmap-ref conts label) - (($ $kreceive arity k) (ref1 k)) - (($ $kfun src meta self ktail kclause) (ref2 ktail kclause)) - (($ $ktail) (ref0)) - (($ $kclause arity kbody kalt) (ref2 kbody kalt)) - (($ $kargs names syms ($ $continue k src exp)) - (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f)))))) - (let*-values (((single multiple) (values empty-intset empty-intset)) - ((single multiple) (intset-fold add-ref body single multiple))) - (intset-subtract (persistent-intset single) - (persistent-intset multiple)))) - -(define (compute-function-names conts functions) - "Compute a map of FUN-LABEL->BOUND-VAR... for each labelled function -whose bound vars we know." - (define (add-named-fun var kfun out) - (let ((self (match (intmap-ref conts kfun) - (($ $kfun src meta self) self)))) - (intmap-add out kfun (intset var self)))) - (intmap-fold - (lambda (label body out) - (let ((single (compute-singly-referenced-labels conts body))) - (intset-fold - (lambda (label out) - (match (intmap-ref conts label) - (($ $kargs _ _ ($ $continue k _ ($ $fun kfun))) - (if (intset-ref single k) - (match (intmap-ref conts k) - (($ $kargs (_) (var)) (add-named-fun var kfun out)) - (_ out)) - out)) - (($ $kargs _ _ ($ $continue k _ ($ $rec _ vars (($ $fun kfun) ...)))) - (unless (intset-ref single k) - (error "$rec continuation has multiple predecessors??")) - (fold add-named-fun out vars kfun)) - (_ out))) - body - out))) - functions - empty-intmap)) - -(define (compute-well-known-functions conts bound->label) - "Compute a set of labels indicating the well-known functions in -@var{conts}. A well-known function is a function whose bound names we -know and which is never used in a non-operator position." - (intset-subtract - (persistent-intset - (intmap-fold (lambda (bound label candidates) - (intset-add! candidates label)) - bound->label - empty-intset)) - (persistent-intset - (intset-fold (lambda (var not-well-known) - (match (intmap-ref bound->label var (lambda (_) #f)) - (#f not-well-known) - (label (intset-add! not-well-known label)))) - (compute-non-operator-uses conts) - empty-intset)))) - -(define (intset-cons i set) - (intset-add set i)) - -(define (compute-shared-closures conts well-known) - "Compute a map LABEL->VAR indicating the sets of functions that will -share a closure. If a functions's label is in the map, it is shared. -The entries indicate the var of the shared closure, which will be one of -the bound vars of the closure." - (intmap-fold - (lambda (label cont out) - (match cont - (($ $kargs _ _ - ($ $continue _ _ ($ $rec names vars (($ $fun kfuns) ...)))) - ;; The split-rec pass should have ensured that this $rec forms a - ;; strongly-connected component, so the free variables from all of - ;; the functions will be alive as long as one of the closures is - ;; alive. For that reason we can consider storing all free - ;; variables in one closure and sharing it. - (let* ((kfuns-set (fold intset-cons empty-intset kfuns)) - (unknown-kfuns (intset-subtract kfuns-set well-known))) - (cond - ((or (eq? empty-intset kfuns-set) (trivial-intset kfuns-set)) - ;; There is only zero or one function bound here. Trivially - ;; shared already. - out) - ((eq? empty-intset unknown-kfuns) - ;; All functions are well-known; we can share a closure. Use - ;; the first bound variable. - (let ((closure (car vars))) - (intset-fold (lambda (kfun out) - (intmap-add out kfun closure)) - kfuns-set out))) - ((trivial-intset unknown-kfuns) - => (lambda (unknown-kfun) - ;; Only one function is not-well-known. Use that - ;; function's closure as the shared closure. - (let ((closure (assq-ref (map cons kfuns vars) unknown-kfun))) - (intset-fold (lambda (kfun out) - (intmap-add out kfun closure)) - kfuns-set out)))) - (else - ;; More than one not-well-known function means we need more - ;; than one proper closure, so we can't share. - out)))) - (_ out))) - conts - empty-intmap)) - -(define* (rewrite-shared-closure-calls cps functions label->bound shared kfun) - "Rewrite CPS such that every call to a function with a shared closure -instead is a $callk to that label, but passing the shared closure as the -proc argument. For recursive calls, use the appropriate 'self' -variable, if possible. Also rewrite uses of the non-well-known but -shared closures to use the appropriate 'self' variable, if possible." - ;; env := var -> (var . label) - (define (rewrite-fun kfun cps env) - (define (subst var) - (match (intmap-ref env var (lambda (_) #f)) - (#f var) - ((var . label) var))) - - (define (rename-exp label cps names vars k src exp) - (intmap-replace! - cps label - (build-cont - ($kargs names vars - ($continue k src - ,(rewrite-exp exp - ((or ($ $const) ($ $prim)) ,exp) - (($ $call proc args) - ,(let ((args (map subst args))) - (rewrite-exp (intmap-ref env proc (lambda (_) #f)) - (#f ($call proc ,args)) - ((closure . label) ($callk label closure ,args))))) - (($ $primcall name args) - ($primcall name ,(map subst args))) - (($ $branch k ($ $values (arg))) - ($branch k ($values ((subst arg))))) - (($ $branch k ($ $primcall name args)) - ($branch k ($primcall name ,(map subst args)))) - (($ $values args) - ($values ,(map subst args))) - (($ $prompt escape? tag handler) - ($prompt escape? (subst tag) handler)))))))) - - (define (visit-exp label cps names vars k src exp) - (define (compute-env label bound self rec-bound rec-labels env) - (define (add-bound-var bound label env) - (intmap-add env bound (cons self label) (lambda (old new) new))) - (if (intmap-ref shared label (lambda (_) #f)) - ;; Within a function with a shared closure, rewrite - ;; references to bound vars to use the "self" var. - (fold add-bound-var env rec-bound rec-labels) - ;; Otherwise be sure to use "self" references in any - ;; closure. - (add-bound-var bound label env))) - (match exp - (($ $fun label) - (rewrite-fun label cps env)) - (($ $rec names vars (($ $fun labels) ...)) - (fold (lambda (label var cps) - (match (intmap-ref cps label) - (($ $kfun src meta self) - (rewrite-fun label cps - (compute-env label var self vars labels - env))))) - cps labels vars)) - (_ (rename-exp label cps names vars k src exp)))) - - (define (rewrite-cont label cps) - (match (intmap-ref cps label) - (($ $kargs names vars ($ $continue k src exp)) - (visit-exp label cps names vars k src exp)) - (_ cps))) - - (intset-fold rewrite-cont (intmap-ref functions kfun) cps)) - - ;; Initial environment is bound-var -> (shared-var . label) map for - ;; functions with shared closures. - (let ((env (intmap-fold (lambda (label shared env) - (intset-fold (lambda (bound env) - (intmap-add env bound - (cons shared label))) - (intset-remove - (intmap-ref label->bound label) - (match (intmap-ref cps label) - (($ $kfun src meta self) self))) - env)) - shared - empty-intmap))) - (persistent-intmap (rewrite-fun kfun cps env)))) - -(define (compute-free-vars conts kfun shared) - "Compute a FUN-LABEL->FREE-VAR... map describing all free variable -references." - (define (add-def var defs) (intset-add! defs var)) - (define (add-defs vars defs) - (match vars - (() defs) - ((var . vars) (add-defs vars (add-def var defs))))) - (define (add-use var uses) - (intset-add! uses var)) - (define (add-uses vars uses) - (match vars - (() uses) - ((var . vars) (add-uses vars (add-use var uses))))) - (define (visit-nested-funs body) - (intset-fold - (lambda (label out) - (match (intmap-ref conts label) - (($ $kargs _ _ ($ $continue _ _ - ($ $fun kfun))) - (intmap-union out (visit-fun kfun))) - (($ $kargs _ _ ($ $continue _ _ - ($ $rec _ _ (($ $fun labels) ...)))) - (let* ((out (fold (lambda (kfun out) - (intmap-union out (visit-fun kfun))) - out labels)) - (free (fold (lambda (kfun free) - (intset-union free (intmap-ref out kfun))) - empty-intset labels))) - (fold (lambda (kfun out) - ;; For functions that share a closure, the free - ;; variables for one will be the union of the free - ;; variables for all. - (if (intmap-ref shared kfun (lambda (_) #f)) - (intmap-replace out kfun free) - out)) - out - labels))) - (_ out))) - body - empty-intmap)) - (define (visit-fun kfun) - (let* ((body (compute-function-body conts kfun)) - (free (visit-nested-funs body))) - (call-with-values - (lambda () - (intset-fold - (lambda (label defs uses) - (match (intmap-ref conts label) - (($ $kargs names vars ($ $continue k src exp)) - (values - (add-defs vars defs) - (match exp - ((or ($ $const) ($ $prim)) uses) - (($ $fun kfun) - (intset-union (persistent-intset uses) - (intmap-ref free kfun))) - (($ $rec names vars (($ $fun kfun) ...)) - (fold (lambda (kfun uses) - (intset-union (persistent-intset uses) - (intmap-ref free kfun))) - uses kfun)) - (($ $values args) - (add-uses args uses)) - (($ $call proc args) - (add-use proc (add-uses args uses))) - (($ $callk label proc args) - (add-use proc (add-uses args uses))) - (($ $branch kt ($ $values (arg))) - (add-use arg uses)) - (($ $branch kt ($ $primcall name args)) - (add-uses args uses)) - (($ $primcall name args) - (add-uses args uses)) - (($ $prompt escape? tag handler) - (add-use tag uses))))) - (($ $kfun src meta self) - (values (add-def self defs) uses)) - (_ (values defs uses)))) - body empty-intset empty-intset)) - (lambda (defs uses) - (intmap-add free kfun (intset-subtract - (persistent-intset uses) - (persistent-intset defs))))))) - (visit-fun kfun)) - -(define (eliminate-closure? label free-vars) - (eq? (intmap-ref free-vars label) empty-intset)) - -(define (closure-label label shared bound->label) - (cond - ((intmap-ref shared label (lambda (_) #f)) - => (lambda (closure) - (intmap-ref bound->label closure))) - (else label))) - -(define (closure-alias label well-known free-vars) - (and (intset-ref well-known label) - (trivial-intset (intmap-ref free-vars label)))) - -(define (prune-free-vars free-vars bound->label well-known shared) - "Given the label->bound-var map @var{free-vars}, remove free variables -that are known functions with zero free variables, and replace -references to well-known functions with one free variable with that free -variable, until we reach a fixed point on the free-vars map." - (define (prune-free in-label free free-vars) - (intset-fold (lambda (var free) - (match (intmap-ref bound->label var (lambda (_) #f)) - (#f free) - (label - (cond - ((eliminate-closure? label free-vars) - (intset-remove free var)) - ((closure-alias (closure-label label shared bound->label) - well-known free-vars) - => (lambda (alias) - ;; If VAR is free in LABEL, then ALIAS must - ;; also be free because its definition must - ;; precede VAR's definition. - (intset-add (intset-remove free var) alias))) - (else free))))) - free free)) - (fixpoint (lambda (free-vars) - (intmap-fold (lambda (label free free-vars) - (intmap-replace free-vars label - (prune-free label free free-vars))) - free-vars - free-vars)) - free-vars)) - -(define (intset-find set i) - (let lp ((idx 0) (start #f)) - (let ((start (intset-next set start))) - (cond - ((not start) (error "not found" set i)) - ((= start i) idx) - (else (lp (1+ idx) (1+ start))))))) - -(define (intset-count set) - (intset-fold (lambda (_ count) (1+ count)) set 0)) - -(define (convert-one cps label body free-vars bound->label well-known shared) - (define (well-known? label) - (intset-ref well-known label)) - - (let* ((free (intmap-ref free-vars label)) - (nfree (intset-count free)) - (self-known? (well-known? (closure-label label shared bound->label))) - (self (match (intmap-ref cps label) (($ $kfun _ _ self) self)))) - (define (convert-arg cps var k) - "Convert one possibly free variable reference to a bound reference. - -If @var{var} is free, it is replaced by a closure reference via a -@code{free-ref} primcall, and @var{k} is called with the new var. -Otherwise @var{var} is bound, so @var{k} is called with @var{var}." - ;; We know that var is not the name of a well-known function. - (cond - ((and=> (intmap-ref bound->label var (lambda (_) #f)) - (lambda (kfun) - (and (eq? empty-intset (intmap-ref free-vars kfun)) - kfun))) - ;; A not-well-known function with zero free vars. Copy as a - ;; constant, relying on the linker to reify just one copy. - => (lambda (kfun) - (with-cps cps - (letv var*) - (let$ body (k var*)) - (letk k* ($kargs (#f) (var*) ,body)) - (build-term ($continue k* #f ($closure kfun 0)))))) - ((intset-ref free var) - (match (vector self-known? nfree) - (#(#t 1) - ;; A reference to the one free var of a well-known function. - (with-cps cps - ($ (k self)))) - (#(#t 2) - ;; A reference to one of the two free vars in a well-known - ;; function. - (let ((op (if (= var (intset-next free)) 'car 'cdr))) - (with-cps cps - (letv var*) - (let$ body (k var*)) - (letk k* ($kargs (#f) (var*) ,body)) - (build-term ($continue k* #f ($primcall op (self))))))) - (_ - (let* ((idx (intset-find free var)) - (op (cond - ((not self-known?) 'free-ref) - ((<= idx #xff) 'vector-ref/immediate) - (else 'vector-ref)))) - (with-cps cps - (letv var*) - (let$ body (k var*)) - (letk k* ($kargs (#f) (var*) ,body)) - ($ (with-cps-constants ((idx idx)) - (build-term - ($continue k* #f ($primcall op (self idx))))))))))) - (else - (with-cps cps - ($ (k var)))))) - - (define (convert-args cps vars k) - "Convert a number of possibly free references to bound references. -@var{k} is called with the bound references, and should return the -term." - (match vars - (() - (with-cps cps - ($ (k '())))) - ((var . vars) - (convert-arg cps var - (lambda (cps var) - (convert-args cps vars - (lambda (cps vars) - (with-cps cps - ($ (k (cons var vars))))))))))) - - (define (allocate-closure cps k src label known? nfree) - "Allocate a new closure, and pass it to $var{k}." - (match (vector known? nfree) - (#(#f nfree) - ;; The call sites cannot be enumerated; allocate a closure. - (with-cps cps - (build-term ($continue k src ($closure label nfree))))) - (#(#t 2) - ;; Well-known closure with two free variables; the closure is a - ;; pair. - (with-cps cps - ($ (with-cps-constants ((false #f)) - (build-term - ($continue k src ($primcall 'cons (false false)))))))) - ;; Well-known callee with more than two free variables; the closure - ;; is a vector. - (#(#t nfree) - (unless (> nfree 2) - (error "unexpected well-known nullary, unary, or binary closure")) - (let ((op (if (<= nfree #xff) 'make-vector/immediate 'make-vector))) - (with-cps cps - ($ (with-cps-constants ((nfree nfree) - (false #f)) - (build-term - ($continue k src ($primcall op (nfree false))))))))))) - - (define (init-closure cps k src var known? free) - "Initialize the free variables @var{closure-free} in a closure -bound to @var{var}, and continue to @var{k}." - (match (vector known? (intset-count free)) - ;; Well-known callee with zero or one free variables; no - ;; initialization necessary. - (#(#t (or 0 1)) - (with-cps cps - (build-term ($continue k src ($values ()))))) - ;; Well-known callee with two free variables; do a set-car! and - ;; set-cdr!. - (#(#t 2) - (let* ((free0 (intset-next free)) - (free1 (intset-next free (1+ free0)))) - (convert-arg cps free0 - (lambda (cps v0) - (with-cps cps - (let$ body - (convert-arg free1 - (lambda (cps v1) - (with-cps cps - (build-term - ($continue k src - ($primcall 'set-cdr! (var v1)))))))) - (letk kcdr ($kargs () () ,body)) - (build-term - ($continue kcdr src ($primcall 'set-car! (var v0))))))))) - ;; Otherwise residualize a sequence of vector-set! or free-set!, - ;; depending on whether the callee is well-known or not. - (_ - (let lp ((cps cps) (prev #f) (idx 0)) - (match (intset-next free prev) - (#f (with-cps cps - (build-term ($continue k src ($values ()))))) - (v (with-cps cps - (let$ body (lp (1+ v) (1+ idx))) - (letk k ($kargs () () ,body)) - ($ (convert-arg v - (lambda (cps v) - (with-cps cps - ($ (with-cps-constants ((idx idx)) - (let ((op (cond - ((not known?) 'free-set!) - ((<= idx #xff) 'vector-set!/immediate) - (else 'vector-set!)))) - (build-term - ($continue k src - ($primcall op (var idx v)))))))))))))))))) - - (define (make-single-closure cps k src kfun) - (let ((free (intmap-ref free-vars kfun))) - (match (vector (well-known? kfun) (intset-count free)) - (#(#f 0) - (with-cps cps - (build-term ($continue k src ($closure kfun 0))))) - (#(#t 0) - (with-cps cps - (build-term ($continue k src ($const #f))))) - (#(#t 1) - ;; A well-known closure of one free variable is replaced - ;; at each use with the free variable itself, so we don't - ;; need a binding at all; and yet, the continuation - ;; expects one value, so give it something. DCE should - ;; clean up later. - (with-cps cps - (build-term ($continue k src ($const #f))))) - (#(well-known? nfree) - ;; A bit of a mess, but beta conversion should remove the - ;; final $values if possible. - (with-cps cps - (letv closure) - (letk k* ($kargs () () ($continue k src ($values (closure))))) - (let$ init (init-closure k* src closure well-known? free)) - (letk knew ($kargs (#f) (closure) ,init)) - ($ (allocate-closure knew src kfun well-known? nfree))))))) - - ;; The callee is known, but not necessarily well-known. - (define (convert-known-proc-call cps k src label closure args) - (define (have-closure cps closure) - (convert-args cps args - (lambda (cps args) - (with-cps cps - (build-term - ($continue k src ($callk label closure args))))))) - (cond - ((eq? (intmap-ref free-vars label) empty-intset) - ;; Known call, no free variables; no closure needed. - ;; Pass #f as closure argument. - (with-cps cps - ($ (with-cps-constants ((false #f)) - ($ (have-closure false)))))) - ((and (well-known? (closure-label label shared bound->label)) - (trivial-intset (intmap-ref free-vars label))) - ;; Well-known closures with one free variable are - ;; replaced at their use sites by uses of the one free - ;; variable. - => (lambda (var) - (convert-arg cps var have-closure))) - (else - ;; Otherwise just load the proc. - (convert-arg cps closure have-closure)))) - - (define (visit-term cps term) - (match term - (($ $continue k src (or ($ $const) ($ $prim))) - (with-cps cps - term)) - - (($ $continue k src ($ $fun kfun)) - (with-cps cps - ($ (make-single-closure k src kfun)))) - - ;; Remove letrec. - (($ $continue k src ($ $rec names vars (($ $fun kfuns) ...))) - (match (vector names vars kfuns) - (#(() () ()) - ;; Trivial empty case. - (with-cps cps - (build-term ($continue k src ($values ()))))) - (#((name) (var) (kfun)) - ;; Trivial single case. We have already proven that K has - ;; only LABEL as its predecessor, so we have been able - ;; already to rewrite free references to the bound name with - ;; the self name. - (with-cps cps - ($ (make-single-closure k src kfun)))) - (#(_ _ (kfun0 . _)) - ;; A non-trivial strongly-connected component. Does it have - ;; a shared closure? - (match (intmap-ref shared kfun0 (lambda (_) #f)) - (#f - ;; Nope. Allocate closures for each function. - (let lp ((cps (match (intmap-ref cps k) - ;; Steal declarations from the continuation. - (($ $kargs names vals body) - (intmap-replace cps k - (build-cont - ($kargs () () ,body)))))) - (in (map vector names vars kfuns)) - (init (lambda (cps) - (with-cps cps - (build-term - ($continue k src ($values ()))))))) - (match in - (() (init cps)) - ((#(name var kfun) . in) - (let* ((known? (well-known? kfun)) - (free (intmap-ref free-vars kfun)) - (nfree (intset-count free))) - (define (next-init cps) - (with-cps cps - (let$ body (init)) - (letk k ($kargs () () ,body)) - ($ (init-closure k src var known? free)))) - (with-cps cps - (let$ body (lp in next-init)) - (letk k ($kargs (name) (var) ,body)) - ($ (allocate-closure k src kfun known? nfree)))))))) - (shared - ;; If shared is in the bound->var map, that means one of - ;; the functions is not well-known. Otherwise use kfun0 - ;; as the function label, but just so make-single-closure - ;; can find the free vars, not for embedding in the - ;; closure. - (let* ((kfun (intmap-ref bound->label shared (lambda (_) kfun0))) - (cps (match (intmap-ref cps k) - ;; Make continuation declare only the shared - ;; closure. - (($ $kargs names vals body) - (intmap-replace cps k - (build-cont - ($kargs (#f) (shared) ,body))))))) - (with-cps cps - ($ (make-single-closure k src kfun))))))))) - - (($ $continue k src ($ $call proc args)) - (match (intmap-ref bound->label proc (lambda (_) #f)) - (#f - (convert-arg cps proc - (lambda (cps proc) - (convert-args cps args - (lambda (cps args) - (with-cps cps - (build-term - ($continue k src ($call proc args))))))))) - (label - (convert-known-proc-call cps k src label proc args)))) - - (($ $continue k src ($ $callk label proc args)) - (convert-known-proc-call cps k src label proc args)) - - (($ $continue k src ($ $primcall name args)) - (convert-args cps args - (lambda (cps args) - (with-cps cps - (build-term - ($continue k src ($primcall name args))))))) - - (($ $continue k src ($ $branch kt ($ $primcall name args))) - (convert-args cps args - (lambda (cps args) - (with-cps cps - (build-term - ($continue k src - ($branch kt ($primcall name args)))))))) - - (($ $continue k src ($ $branch kt ($ $values (arg)))) - (convert-arg cps arg - (lambda (cps arg) - (with-cps cps - (build-term - ($continue k src - ($branch kt ($values (arg))))))))) - - (($ $continue k src ($ $values args)) - (convert-args cps args - (lambda (cps args) - (with-cps cps - (build-term - ($continue k src ($values args))))))) - - (($ $continue k src ($ $prompt escape? tag handler)) - (convert-arg cps tag - (lambda (cps tag) - (with-cps cps - (build-term - ($continue k src - ($prompt escape? tag handler))))))))) - - (intset-fold (lambda (label cps) - (match (intmap-ref cps label (lambda (_) #f)) - (($ $kargs names vars term) - (with-cps cps - (let$ term (visit-term term)) - (setk label ($kargs names vars ,term)))) - (_ cps))) - body - cps))) - -(define (convert-closures cps) - "Convert free reference in @var{cps} to primcalls to @code{free-ref}, -and allocate and initialize flat closures." - (let* ((kfun 0) ;; Ass-u-me. - ;; label -> body-label... - (functions (compute-function-bodies cps kfun)) - (cps (filter-reachable cps functions)) - ;; label -> bound-var... - (label->bound (compute-function-names cps functions)) - ;; bound-var -> label - (bound->label (invert-partition label->bound)) - ;; label... - (well-known (compute-well-known-functions cps bound->label)) - ;; label -> closure-var - (shared (compute-shared-closures cps well-known)) - (cps (rewrite-shared-closure-calls cps functions label->bound shared - kfun)) - ;; label -> free-var... - (free-vars (compute-free-vars cps kfun shared)) - (free-vars (prune-free-vars free-vars bound->label well-known shared))) - (let ((free-in-program (intmap-ref free-vars kfun))) - (unless (eq? empty-intset free-in-program) - (error "Expected no free vars in program" free-in-program))) - (with-fresh-name-state cps - (persistent-intmap - (intmap-fold - (lambda (label body cps) - (convert-one cps label body free-vars bound->label well-known shared)) - functions - cps))))) - -;;; Local Variables: -;;; eval: (put 'convert-arg 'scheme-indent-function 2) -;;; eval: (put 'convert-args 'scheme-indent-function 2) -;;; End: diff --git a/module/language/cps2/compile-bytecode.scm b/module/language/cps2/compile-bytecode.scm deleted file mode 100644 index a39c9f222..000000000 --- a/module/language/cps2/compile-bytecode.scm +++ /dev/null @@ -1,433 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; Compiling CPS to bytecode. The result is in the bytecode language, -;;; which happens to be an ELF image as a bytecode. -;;; -;;; Code: - -(define-module (language cps2 compile-bytecode) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (language cps2) - #:use-module (language cps primitives) - #:use-module (language cps2 slot-allocation) - #:use-module (language cps2 utils) - #:use-module (language cps2 closure-conversion) - #:use-module (language cps2 optimize) - #:use-module (language cps2 reify-primitives) - #:use-module (language cps2 renumber) - #:use-module (language cps intmap) - #:use-module (language cps intset) - #:use-module (system vm assembler) - #:export (compile-bytecode)) - -(define (kw-arg-ref args kw default) - (match (memq kw args) - ((_ val . _) val) - (_ default))) - -(define (intmap-for-each f map) - (intmap-fold (lambda (k v seed) (f k v) seed) map *unspecified*)) - -(define (intmap-select map set) - (persistent-intmap - (intset-fold - (lambda (k out) - (intmap-add! out k (intmap-ref map k))) - set - empty-intmap))) - -(define (compile-function cps asm) - (let ((allocation (allocate-slots cps)) - (frame-size #f)) - (define (maybe-slot sym) - (lookup-maybe-slot sym allocation)) - - (define (slot sym) - (lookup-slot sym allocation)) - - (define (constant sym) - (lookup-constant-value sym allocation)) - - (define (maybe-mov dst src) - (unless (= dst src) - (emit-mov asm dst src))) - - (define (compile-tail label exp) - ;; There are only three kinds of expressions in tail position: - ;; tail calls, multiple-value returns, and single-value returns. - (match exp - (($ $call proc args) - (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) - (lookup-parallel-moves label allocation)) - (emit-tail-call asm (1+ (length args)))) - (($ $callk k proc args) - (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) - (lookup-parallel-moves label allocation)) - (emit-tail-call-label asm (1+ (length args)) k)) - (($ $values ()) - (emit-reset-frame asm 1) - (emit-return-values asm)) - (($ $values (arg)) - (if (maybe-slot arg) - (emit-return asm (slot arg)) - (begin - (emit-load-constant asm 1 (constant arg)) - (emit-return asm 1)))) - (($ $values args) - (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) - (lookup-parallel-moves label allocation)) - (emit-reset-frame asm (1+ (length args))) - (emit-return-values asm)) - (($ $primcall 'return (arg)) - (emit-return asm (slot arg))))) - - (define (compile-value label exp dst) - (match exp - (($ $values (arg)) - (maybe-mov dst (slot arg))) - (($ $const exp) - (emit-load-constant asm dst exp)) - (($ $closure k 0) - (emit-load-static-procedure asm dst k)) - (($ $closure k nfree) - (emit-make-closure asm dst k nfree)) - (($ $primcall 'current-module) - (emit-current-module asm dst)) - (($ $primcall 'cached-toplevel-box (scope name bound?)) - (emit-cached-toplevel-box asm dst (constant scope) (constant name) - (constant bound?))) - (($ $primcall 'cached-module-box (mod name public? bound?)) - (emit-cached-module-box asm dst (constant mod) (constant name) - (constant public?) (constant bound?))) - (($ $primcall 'resolve (name bound?)) - (emit-resolve asm dst (constant bound?) (slot name))) - (($ $primcall 'free-ref (closure idx)) - (emit-free-ref asm dst (slot closure) (constant idx))) - (($ $primcall 'vector-ref (vector index)) - (emit-vector-ref asm dst (slot vector) (slot index))) - (($ $primcall 'make-vector (length init)) - (emit-make-vector asm dst (slot length) (slot init))) - (($ $primcall 'make-vector/immediate (length init)) - (emit-make-vector/immediate asm dst (constant length) (slot init))) - (($ $primcall 'vector-ref/immediate (vector index)) - (emit-vector-ref/immediate asm dst (slot vector) (constant index))) - (($ $primcall 'allocate-struct (vtable nfields)) - (emit-allocate-struct asm dst (slot vtable) (slot nfields))) - (($ $primcall 'allocate-struct/immediate (vtable nfields)) - (emit-allocate-struct/immediate asm dst (slot vtable) (constant nfields))) - (($ $primcall 'struct-ref (struct n)) - (emit-struct-ref asm dst (slot struct) (slot n))) - (($ $primcall 'struct-ref/immediate (struct n)) - (emit-struct-ref/immediate asm dst (slot struct) (constant n))) - (($ $primcall 'builtin-ref (name)) - (emit-builtin-ref asm dst (constant name))) - (($ $primcall 'bv-u8-ref (bv idx)) - (emit-bv-u8-ref asm dst (slot bv) (slot idx))) - (($ $primcall 'bv-s8-ref (bv idx)) - (emit-bv-s8-ref asm dst (slot bv) (slot idx))) - (($ $primcall 'bv-u16-ref (bv idx)) - (emit-bv-u16-ref asm dst (slot bv) (slot idx))) - (($ $primcall 'bv-s16-ref (bv idx)) - (emit-bv-s16-ref asm dst (slot bv) (slot idx))) - (($ $primcall 'bv-u32-ref (bv idx val)) - (emit-bv-u32-ref asm dst (slot bv) (slot idx))) - (($ $primcall 'bv-s32-ref (bv idx val)) - (emit-bv-s32-ref asm dst (slot bv) (slot idx))) - (($ $primcall 'bv-u64-ref (bv idx val)) - (emit-bv-u64-ref asm dst (slot bv) (slot idx))) - (($ $primcall 'bv-s64-ref (bv idx val)) - (emit-bv-s64-ref asm dst (slot bv) (slot idx))) - (($ $primcall 'bv-f32-ref (bv idx val)) - (emit-bv-f32-ref asm dst (slot bv) (slot idx))) - (($ $primcall 'bv-f64-ref (bv idx val)) - (emit-bv-f64-ref asm dst (slot bv) (slot idx))) - (($ $primcall name args) - ;; FIXME: Inline all the cases. - (let ((inst (prim-instruction name))) - (emit-text asm `((,inst ,dst ,@(map slot args)))))))) - - (define (compile-effect label exp k) - (match exp - (($ $values ()) #f) - (($ $prompt escape? tag handler) - (match (intmap-ref cps handler) - (($ $kreceive ($ $arity req () rest () #f) khandler-body) - (let ((receive-args (gensym "handler")) - (nreq (length req)) - (proc-slot (lookup-call-proc-slot label allocation))) - (emit-prompt asm (slot tag) escape? proc-slot receive-args) - (emit-br asm k) - (emit-label asm receive-args) - (unless (and rest (zero? nreq)) - (emit-receive-values asm proc-slot (->bool rest) nreq)) - (when (and rest - (match (intmap-ref cps khandler-body) - (($ $kargs names (_ ... rest)) - (maybe-slot rest)))) - (emit-bind-rest asm (+ proc-slot 1 nreq))) - (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) - (lookup-parallel-moves handler allocation)) - (emit-reset-frame asm frame-size) - (emit-br asm khandler-body))))) - (($ $primcall 'cache-current-module! (sym scope)) - (emit-cache-current-module! asm (slot sym) (constant scope))) - (($ $primcall 'free-set! (closure idx value)) - (emit-free-set! asm (slot closure) (slot value) (constant idx))) - (($ $primcall 'box-set! (box value)) - (emit-box-set! asm (slot box) (slot value))) - (($ $primcall 'struct-set! (struct index value)) - (emit-struct-set! asm (slot struct) (slot index) (slot value))) - (($ $primcall 'struct-set!/immediate (struct index value)) - (emit-struct-set!/immediate asm (slot struct) (constant index) (slot value))) - (($ $primcall 'vector-set! (vector index value)) - (emit-vector-set! asm (slot vector) (slot index) (slot value))) - (($ $primcall 'vector-set!/immediate (vector index value)) - (emit-vector-set!/immediate asm (slot vector) (constant index) - (slot value))) - (($ $primcall 'set-car! (pair value)) - (emit-set-car! asm (slot pair) (slot value))) - (($ $primcall 'set-cdr! (pair value)) - (emit-set-cdr! asm (slot pair) (slot value))) - (($ $primcall 'define! (sym value)) - (emit-define! asm (slot sym) (slot value))) - (($ $primcall 'push-fluid (fluid val)) - (emit-push-fluid asm (slot fluid) (slot val))) - (($ $primcall 'pop-fluid ()) - (emit-pop-fluid asm)) - (($ $primcall 'wind (winder unwinder)) - (emit-wind asm (slot winder) (slot unwinder))) - (($ $primcall 'bv-u8-set! (bv idx val)) - (emit-bv-u8-set! asm (slot bv) (slot idx) (slot val))) - (($ $primcall 'bv-s8-set! (bv idx val)) - (emit-bv-s8-set! asm (slot bv) (slot idx) (slot val))) - (($ $primcall 'bv-u16-set! (bv idx val)) - (emit-bv-u16-set! asm (slot bv) (slot idx) (slot val))) - (($ $primcall 'bv-s16-set! (bv idx val)) - (emit-bv-s16-set! asm (slot bv) (slot idx) (slot val))) - (($ $primcall 'bv-u32-set! (bv idx val)) - (emit-bv-u32-set! asm (slot bv) (slot idx) (slot val))) - (($ $primcall 'bv-s32-set! (bv idx val)) - (emit-bv-s32-set! asm (slot bv) (slot idx) (slot val))) - (($ $primcall 'bv-u64-set! (bv idx val)) - (emit-bv-u64-set! asm (slot bv) (slot idx) (slot val))) - (($ $primcall 'bv-s64-set! (bv idx val)) - (emit-bv-s64-set! asm (slot bv) (slot idx) (slot val))) - (($ $primcall 'bv-f32-set! (bv idx val)) - (emit-bv-f32-set! asm (slot bv) (slot idx) (slot val))) - (($ $primcall 'bv-f64-set! (bv idx val)) - (emit-bv-f64-set! asm (slot bv) (slot idx) (slot val))) - (($ $primcall 'unwind ()) - (emit-unwind asm)))) - - (define (compile-values label exp syms) - (match exp - (($ $values args) - (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) - (lookup-parallel-moves label allocation))))) - - (define (compile-test label exp kt kf next-label) - (define (unary op sym) - (cond - ((eq? kt next-label) - (op asm (slot sym) #t kf)) - (else - (op asm (slot sym) #f kt) - (unless (eq? kf next-label) - (emit-br asm kf))))) - (define (binary op a b) - (cond - ((eq? kt next-label) - (op asm (slot a) (slot b) #t kf)) - (else - (op asm (slot a) (slot b) #f kt) - (unless (eq? kf next-label) - (emit-br asm kf))))) - (match exp - (($ $values (sym)) - (call-with-values (lambda () - (lookup-maybe-constant-value sym allocation)) - (lambda (has-const? val) - (if has-const? - (if val - (unless (eq? kt next-label) - (emit-br asm kt)) - (unless (eq? kf next-label) - (emit-br asm kf))) - (unary emit-br-if-true sym))))) - (($ $primcall 'null? (a)) (unary emit-br-if-null a)) - (($ $primcall 'nil? (a)) (unary emit-br-if-nil a)) - (($ $primcall 'pair? (a)) (unary emit-br-if-pair a)) - (($ $primcall 'struct? (a)) (unary emit-br-if-struct a)) - (($ $primcall 'char? (a)) (unary emit-br-if-char a)) - (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a)) - (($ $primcall 'variable? (a)) (unary emit-br-if-variable a)) - (($ $primcall 'vector? (a)) (unary emit-br-if-vector a)) - (($ $primcall 'string? (a)) (unary emit-br-if-string a)) - (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a)) - (($ $primcall 'bitvector? (a)) (unary emit-br-if-bitvector a)) - (($ $primcall 'keyword? (a)) (unary emit-br-if-keyword a)) - ;; Add more TC7 tests here. Keep in sync with - ;; *branching-primcall-arities* in (language cps primitives) and - ;; the set of macro-instructions in assembly.scm. - (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b)) - (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b)) - (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b)) - (($ $primcall '< (a b)) (binary emit-br-if-< a b)) - (($ $primcall '<= (a b)) (binary emit-br-if-<= a b)) - (($ $primcall '= (a b)) (binary emit-br-if-= a b)) - (($ $primcall '>= (a b)) (binary emit-br-if-<= b a)) - (($ $primcall '> (a b)) (binary emit-br-if-< b a)) - (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b)))) - - (define (compile-trunc label k exp nreq rest-var) - (define (do-call proc args emit-call) - (let* ((proc-slot (lookup-call-proc-slot label allocation)) - (nargs (1+ (length args))) - (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs)))) - (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) - (lookup-parallel-moves label allocation)) - (emit-call asm proc-slot nargs) - (emit-dead-slot-map asm proc-slot - (lookup-dead-slot-map label allocation)) - (cond - ((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var)) - (match (lookup-parallel-moves k allocation) - ((((? (lambda (src) (= src (1+ proc-slot))) src) - . dst)) dst) - (_ #f))) - ;; The usual case: one required live return value, ignoring - ;; any additional values. - => (lambda (dst) - (emit-receive asm dst proc-slot frame-size))) - (else - (unless (and (zero? nreq) rest-var) - (emit-receive-values asm proc-slot (->bool rest-var) nreq)) - (when (and rest-var (maybe-slot rest-var)) - (emit-bind-rest asm (+ proc-slot 1 nreq))) - (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) - (lookup-parallel-moves k allocation)) - (emit-reset-frame asm frame-size))))) - (match exp - (($ $call proc args) - (do-call proc args - (lambda (asm proc-slot nargs) - (emit-call asm proc-slot nargs)))) - (($ $callk k proc args) - (do-call proc args - (lambda (asm proc-slot nargs) - (emit-call-label asm proc-slot nargs k)))))) - - (define (compile-expression label k exp) - (let* ((fallthrough? (= k (1+ label)))) - (define (maybe-emit-jump) - (unless fallthrough? - (emit-br asm k))) - (match (intmap-ref cps k) - (($ $ktail) - (compile-tail label exp)) - (($ $kargs (name) (sym)) - (let ((dst (maybe-slot sym))) - (when dst - (compile-value label exp dst))) - (maybe-emit-jump)) - (($ $kargs () ()) - (match exp - (($ $branch kt exp) - (compile-test label exp kt k (1+ label))) - (_ - (compile-effect label exp k) - (maybe-emit-jump)))) - (($ $kargs names syms) - (compile-values label exp syms) - (maybe-emit-jump)) - (($ $kreceive ($ $arity req () rest () #f) kargs) - (compile-trunc label k exp (length req) - (and rest - (match (intmap-ref cps kargs) - (($ $kargs names (_ ... rest)) rest)))) - (unless (and fallthrough? (= kargs (1+ k))) - (emit-br asm kargs)))))) - - (define (compile-cont label cont) - (match cont - (($ $kfun src meta self tail clause) - (when src - (emit-source asm src)) - (emit-begin-program asm label meta)) - (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alt) - (let ((first? (match (intmap-ref cps (1- label)) - (($ $kfun) #t) - (_ #f))) - (kw-indices (map (match-lambda - ((key name sym) - (cons key (lookup-slot sym allocation)))) - kw))) - (unless first? - (emit-end-arity asm)) - (emit-label asm label) - (set! frame-size (lookup-nlocals label allocation)) - (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys? - frame-size alt))) - (($ $kargs names vars ($ $continue k src exp)) - (emit-label asm label) - (for-each (lambda (name var) - (let ((slot (maybe-slot var))) - (when slot - (emit-definition asm name slot)))) - names vars) - (when src - (emit-source asm src)) - (compile-expression label k exp)) - (($ $kreceive arity kargs) - (emit-label asm label)) - (($ $ktail) - (emit-end-arity asm) - (emit-end-program asm)))) - - (intmap-for-each compile-cont cps))) - -(define (emit-bytecode exp env opts) - (let ((asm (make-assembler))) - (intmap-for-each (lambda (kfun body) - (compile-function (intmap-select exp body) asm)) - (compute-reachable-functions exp 0)) - (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f)) - env - env))) - -(define (lower-cps exp opts) - (set! exp (optimize-higher-order-cps exp opts)) - (set! exp (convert-closures exp)) - (set! exp (optimize-first-order-cps exp opts)) - (set! exp (reify-primitives exp)) - (renumber exp)) - -(define (compile-bytecode exp env opts) - (set! exp (lower-cps exp opts)) - (emit-bytecode exp env opts)) diff --git a/module/language/cps2/constructors.scm b/module/language/cps2/constructors.scm deleted file mode 100644 index e4973f2b7..000000000 --- a/module/language/cps2/constructors.scm +++ /dev/null @@ -1,98 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; Constructor inlining turns "list" primcalls into a series of conses, -;;; and does similar transformations for "vector". -;;; -;;; Code: - -(define-module (language cps2 constructors) - #:use-module (ice-9 match) - #:use-module (language cps2) - #:use-module (language cps2 utils) - #:use-module (language cps2 with-cps) - #:use-module (language cps intmap) - #:export (inline-constructors)) - -(define (inline-list out k src args) - (define (build-list out args k) - (match args - (() - (with-cps out - (build-term ($continue k src ($const '()))))) - ((arg . args) - (with-cps out - (letv tail) - (letk ktail ($kargs ('tail) (tail) - ($continue k src - ($primcall 'cons (arg tail))))) - ($ (build-list args ktail)))))) - (with-cps out - (letv val) - (letk kvalues ($kargs ('val) (val) - ($continue k src - ($primcall 'values (val))))) - ($ (build-list args kvalues)))) - -(define (inline-vector out k src args) - (define (initialize out vec args n) - (match args - (() - (with-cps out - (build-term ($continue k src ($primcall 'values (vec)))))) - ((arg . args) - (with-cps out - (let$ next (initialize vec args (1+ n))) - (letk knext ($kargs () () ,next)) - ($ (with-cps-constants ((idx n)) - (build-term ($continue knext src - ($primcall 'vector-set! (vec idx arg)))))))))) - (with-cps out - (letv vec) - (let$ body (initialize vec args 0)) - (letk kalloc ($kargs ('vec) (vec) ,body)) - ($ (with-cps-constants ((len (length args)) - (init #f)) - (build-term ($continue kalloc src - ($primcall 'make-vector (len init)))))))) - -(define (find-constructor-inliner name) - (match name - ('list inline-list) - ('vector inline-vector) - (_ #f))) - -(define (inline-constructors conts) - (with-fresh-name-state conts - (persistent-intmap - (intmap-fold - (lambda (label cont out) - (match cont - (($ $kargs names vars ($ $continue k src ($ $primcall name args))) - (let ((inline (find-constructor-inliner name))) - (if inline - (call-with-values (lambda () (inline out k src args)) - (lambda (out term) - (intmap-replace! out label - (build-cont ($kargs names vars ,term))))) - out))) - (_ out))) - conts - conts)))) diff --git a/module/language/cps2/contification.scm b/module/language/cps2/contification.scm deleted file mode 100644 index e15544af2..000000000 --- a/module/language/cps2/contification.scm +++ /dev/null @@ -1,475 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; Contification is a pass that turns $fun instances into $cont -;;; instances if all calls to the $fun return to the same continuation. -;;; This is a more rigorous variant of our old "fixpoint labels -;;; allocation" optimization. -;;; -;;; See Kennedy's "Compiling with Continuations, Continued", and Fluet -;;; and Weeks's "Contification using Dominators". -;;; -;;; Code: - -(define-module (language cps2 contification) - #:use-module (ice-9 match) - #:use-module (srfi srfi-11) - #:use-module ((srfi srfi-1) #:select (fold)) - #:use-module (language cps2) - #:use-module (language cps2 renumber) - #:use-module (language cps2 utils) - #:use-module (language cps intmap) - #:use-module (language cps intset) - #:export (contify)) - -(define (compute-singly-referenced-labels conts) - "Compute the set of labels in CONTS that have exactly one -predecessor." - (define (add-ref label cont single multiple) - (define (ref k single multiple) - (if (intset-ref single k) - (values single (intset-add! multiple k)) - (values (intset-add! single k) multiple))) - (define (ref0) (values single multiple)) - (define (ref1 k) (ref k single multiple)) - (define (ref2 k k*) - (if k* - (let-values (((single multiple) (ref k single multiple))) - (ref k* single multiple)) - (ref1 k))) - (match cont - (($ $kreceive arity k) (ref1 k)) - (($ $kfun src meta self ktail kclause) (ref2 ktail kclause)) - (($ $ktail) (ref0)) - (($ $kclause arity kbody kalt) (ref2 kbody kalt)) - (($ $kargs names syms ($ $continue k src exp)) - (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f)))))) - (let*-values (((single multiple) (values empty-intset empty-intset)) - ((single multiple) (intmap-fold add-ref conts single multiple))) - (intset-subtract (persistent-intset single) - (persistent-intset multiple)))) - -(define (compute-functions conts) - "Compute a map from $kfun label to bound variable names for all -functions in CONTS. Functions have two bound variable names: their self -binding, and the name they are given in their continuation. If their -continuation has more than one predecessor, then the bound variable name -doesn't uniquely identify the function, so we exclude that function from -the set." - (define (function-self label) - (match (intmap-ref conts label) - (($ $kfun src meta self) self))) - (let ((single (compute-singly-referenced-labels conts))) - (intmap-fold (lambda (label cont functions) - (match cont - (($ $kargs _ _ ($ $continue k src ($ $fun kfun))) - (if (intset-ref single k) - (match (intmap-ref conts k) - (($ $kargs (name) (var)) - (intmap-add functions kfun - (intset var (function-self kfun))))) - functions)) - (($ $kargs _ _ ($ $continue k src - ($ $rec _ vars (($ $fun kfuns) ...)))) - (if (intset-ref single k) - (fold (lambda (var kfun functions) - (intmap-add functions kfun - (intset var (function-self kfun)))) - functions vars kfuns) - functions)) - (_ functions))) - conts - empty-intmap))) - -(define (compute-multi-clause conts) - "Compute an set containing all labels that are part of a multi-clause -case-lambda. See the note in compute-contification-candidates." - (define (multi-clause? clause) - (and clause - (match (intmap-ref conts clause) - (($ $kclause arity body alt) - alt)))) - (intmap-fold (lambda (label cont multi) - (match cont - (($ $kfun src meta self tail clause) - (if (multi-clause? clause) - (intset-union multi (compute-function-body conts label)) - multi)) - (_ multi))) - conts - empty-intset)) - -(define (compute-arities conts functions) - "Given the map FUNCTIONS whose keys are $kfun labels, return a map -from label to arities." - (define (clause-arities clause) - (if clause - (match (intmap-ref conts clause) - (($ $kclause arity body alt) - (cons arity (clause-arities alt)))) - '())) - (intmap-map (lambda (label vars) - (match (intmap-ref conts label) - (($ $kfun src meta self tail clause) - (clause-arities clause)))) - functions)) - -;; For now, we don't contify functions with optional, keyword, or rest -;; arguments. -(define (contifiable-arity? arity) - (match arity - (($ $arity req () #f () aok?) - #t) - (_ - #f))) - -(define (arity-matches? arity nargs) - (match arity - (($ $arity req () #f () aok?) - (= nargs (length req))) - (_ - #f))) - -(define (compute-contification-candidates conts) - "Compute and return a label -> (variable ...) map describing all -functions with known uses that are only ever used as the operator of a -$call, and are always called with a compatible arity." - (let* ((functions (compute-functions conts)) - (multi-clause (compute-multi-clause conts)) - (vars (intmap-fold (lambda (label vars out) - (intset-fold (lambda (var out) - (intmap-add out var label)) - vars out)) - functions - empty-intmap)) - (arities (compute-arities conts functions))) - (define (restrict-arity functions proc nargs) - (match (intmap-ref vars proc (lambda (_) #f)) - (#f functions) - (label - (let lp ((arities (intmap-ref arities label))) - (match arities - (() (intmap-remove functions label)) - ((arity . arities) - (cond - ((not (contifiable-arity? arity)) (lp '())) - ((arity-matches? arity nargs) functions) - (else (lp arities))))))))) - (define (visit-cont label cont functions) - (define (exclude-var functions var) - (match (intmap-ref vars var (lambda (_) #f)) - (#f functions) - (label (intmap-remove functions label)))) - (define (exclude-vars functions vars) - (match vars - (() functions) - ((var . vars) - (exclude-vars (exclude-var functions var) vars)))) - (match cont - (($ $kargs _ _ ($ $continue _ _ exp)) - (match exp - ((or ($ $const) ($ $prim) ($ $closure) ($ $fun) ($ $rec)) - functions) - (($ $values args) - (exclude-vars functions args)) - (($ $call proc args) - (let ((functions (exclude-vars functions args))) - ;; This contification algorithm is happy to contify the - ;; `lp' in this example into a shared tail between clauses: - ;; - ;; (letrec ((lp (lambda () (lp)))) - ;; (case-lambda - ;; ((a) (lp)) - ;; ((a b) (lp)))) - ;; - ;; However because the current compilation pipeline has to - ;; re-nest continuations into old CPS, there would be no - ;; scope in which the tail would be valid. So, until the - ;; old compilation pipeline is completely replaced, - ;; conservatively exclude contifiable fucntions called - ;; from multi-clause procedures. - (if (intset-ref multi-clause label) - (exclude-var functions proc) - (restrict-arity functions proc (length args))))) - (($ $callk k proc args) - (exclude-vars functions (cons proc args))) - (($ $branch kt ($ $primcall name args)) - (exclude-vars functions args)) - (($ $branch kt ($ $values (arg))) - (exclude-var functions arg)) - (($ $primcall name args) - (exclude-vars functions args)) - (($ $prompt escape? tag handler) - (exclude-var functions tag)))) - (_ functions))) - (intmap-fold visit-cont conts functions))) - -(define (compute-call-graph conts labels vars) - "Given the set of contifiable functions LABELS and associated bound -variables VARS, compute and return two values: a map -LABEL->LABEL... indicating the contifiable functions called by a -function, and a map LABEL->LABEL... indicating the return continuations -for a function. The first return value also has an entry -0->LABEL... indicating all contifiable functions called by -non-contifiable functions. We assume that 0 is not in the contifiable -function set." - (let ((bodies - ;; label -> fun-label for all labels in bodies of contifiable - ;; functions - (intset-fold (lambda (fun-label bodies) - (intset-fold (lambda (label bodies) - (intmap-add bodies label fun-label)) - (compute-function-body conts fun-label) - bodies)) - labels - empty-intmap))) - (when (intset-ref labels 0) - (error "internal error: label 0 should not be contifiable")) - (intmap-fold - (lambda (label cont calls returns) - (match cont - (($ $kargs _ _ ($ $continue k src ($ $call proc))) - (match (intmap-ref vars proc (lambda (_) #f)) - (#f (values calls returns)) - (callee - (let ((caller (intmap-ref bodies label (lambda (_) 0)))) - (values (intmap-add calls caller callee intset-add) - (intmap-add returns callee k intset-add)))))) - (_ (values calls returns)))) - conts - (intset->intmap (lambda (label) empty-intset) (intset-add labels 0)) - (intset->intmap (lambda (label) empty-intset) labels)))) - -(define (tail-label conts label) - (match (intmap-ref conts label) - (($ $kfun src meta self tail body) - tail))) - -(define (compute-return-labels labels tails returns return-substs) - (define (subst k) - (match (intmap-ref return-substs k (lambda (_) #f)) - (#f k) - (k (subst k)))) - ;; Compute all return labels, then subtract tail labels of the - ;; functions in question. - (intset-subtract - ;; Return labels for all calls to these labels. - (intset-fold (lambda (label out) - (intset-fold (lambda (k out) - (intset-add out (subst k))) - (intmap-ref returns label) - out)) - labels - empty-intset) - (intset-fold (lambda (label out) - (intset-add out (intmap-ref tails label))) - labels - empty-intset))) - -(define (intmap->intset map) - (define (add-key label cont labels) - (intset-add labels label)) - (intmap-fold add-key map empty-intset)) - -(define (filter-contifiable contified groups) - (intmap-fold (lambda (id labels groups) - (let ((labels (intset-subtract labels contified))) - (if (eq? empty-intset labels) - groups - (intmap-add groups id labels)))) - groups - empty-intmap)) - -(define (trivial-set set) - (let ((first (intset-next set))) - (and first - (not (intset-next set (1+ first))) - first))) - -(define (compute-contification conts) - (let*-values - (;; label -> (var ...) - ((candidates) (compute-contification-candidates conts)) - ((labels) (intmap->intset candidates)) - ;; var -> label - ((vars) (intmap-fold (lambda (label vars out) - (intset-fold (lambda (var out) - (intmap-add out var label)) - vars out)) - candidates - empty-intmap)) - ;; caller-label -> callee-label..., callee-label -> return-label... - ((calls returns) (compute-call-graph conts labels vars)) - ;; callee-label -> tail-label - ((tails) (intset-fold - (lambda (label tails) - (intmap-add tails label (tail-label conts label))) - labels - empty-intmap)) - ;; Strongly connected components, allowing us to contify mutually - ;; tail-recursive functions. Since `compute-call-graph' added on - ;; a synthetic 0->LABEL... entry for contifiable functions called - ;; by non-contifiable functions, we need to remove that entry - ;; from the partition. It will be in its own component, as it - ;; has no predecessors. - ;; - ;; id -> label... - ((groups) (intmap-remove - (compute-strongly-connected-components calls 0) - 0))) - ;; todo: thread groups through contification - (define (attempt-contification labels contified return-substs) - (let ((returns (compute-return-labels labels tails returns - return-substs))) - (cond - ((trivial-set returns) - => (lambda (k) - ;; Success! - (values (intset-union contified labels) - (intset-fold (lambda (label return-substs) - (let ((tail (intmap-ref tails label))) - (intmap-add return-substs tail k))) - labels return-substs)))) - ((trivial-set labels) - ;; Single-label SCC failed to contify. - (values contified return-substs)) - (else - ;; Multi-label SCC failed to contify. Try instead to contify - ;; each one. - (intset-fold - (lambda (label contified return-substs) - (let ((labels (intset-add empty-intset label))) - (attempt-contification labels contified return-substs))) - labels contified return-substs))))) - (call-with-values - (lambda () - (fixpoint - (lambda (contified return-substs) - (intmap-fold - (lambda (id group contified return-substs) - (attempt-contification group contified return-substs)) - (filter-contifiable contified groups) - contified - return-substs)) - empty-intset - empty-intmap)) - (lambda (contified return-substs) - (values (intset-fold (lambda (label call-substs) - (intset-fold - (lambda (var call-substs) - (intmap-add call-substs var label)) - (intmap-ref candidates label) - call-substs)) - contified - empty-intmap) - return-substs))))) - -(define (apply-contification conts call-substs return-substs) - (define (call-subst proc) - (intmap-ref call-substs proc (lambda (_) #f))) - (define (return-subst k) - (intmap-ref return-substs k (lambda (_) #f))) - (define (find-body kfun nargs) - (match (intmap-ref conts kfun) - (($ $kfun src meta self tail clause) - (let lp ((clause clause)) - (match (intmap-ref conts clause) - (($ $kclause arity body alt) - (if (arity-matches? arity nargs) - body - (lp alt)))))))) - (define (continue k src exp) - (define (lookup-return-cont k) - (match (return-subst k) - (#f k) - (k (lookup-return-cont k)))) - (let ((k* (lookup-return-cont k))) - (if (eq? k k*) - (build-term ($continue k src ,exp)) - ;; We are contifying this return. It must be a call, a - ;; $values expression, or a return primcall. k* will be - ;; either a $ktail or a $kreceive continuation. CPS2 has this - ;; thing though where $kreceive can't be the target of a - ;; $values expression, and "return" can only continue to a - ;; tail continuation, so we might have to rewrite to a - ;; "values" primcall. - (build-term - ($continue k* src - ,(match (intmap-ref conts k*) - (($ $kreceive) - (match exp - (($ $primcall 'return (val)) - (build-exp ($primcall 'values (val)))) - (($ $call) exp) - ;; Except for 'return, a primcall that can continue - ;; to $ktail can also continue to $kreceive. TODO: - ;; replace 'return with 'values, for consistency. - (($ $primcall) exp) - (($ $values vals) - (build-exp ($primcall 'values vals))))) - (($ $ktail) exp))))))) - (define (visit-exp k src exp) - (match exp - (($ $call proc args) - ;; If proc is contifiable, replace call with jump. - (match (call-subst proc) - (#f (continue k src exp)) - (kfun - (let ((body (find-body kfun (length args)))) - (build-term ($continue body src ($values args))))))) - (($ $fun kfun) - ;; If the function's tail continuation has been - ;; substituted, that means it has been contified. - (if (return-subst (tail-label conts kfun)) - (continue k src (build-exp ($values ()))) - (continue k src exp))) - (($ $rec names vars funs) - (match (filter (match-lambda ((n v f) (not (call-subst v)))) - (map list names vars funs)) - (() (continue k src (build-exp ($values ())))) - (((names vars funs) ...) - (continue k src (build-exp ($rec names vars funs)))))) - (_ (continue k src exp)))) - - ;; Renumbering is not strictly necessary but some passes may not be - ;; equipped to deal with stale $kfun nodes whose bodies have been - ;; wired into other functions. - (renumber - (intmap-map - (lambda (label cont) - (match cont - (($ $kargs names vars ($ $continue k src exp)) - ;; Remove bindings for functions that have been contified. - (match (filter (match-lambda ((name var) (not (call-subst var)))) - (map list names vars)) - (((names vars) ...) - (build-cont - ($kargs names vars ,(visit-exp k src exp)))))) - (_ cont))) - conts))) - -(define (contify conts) - ;; FIXME: Renumbering isn't really needed but dead continuations may - ;; cause compute-singly-referenced-labels to spuriously mark some - ;; conts as irreducible. For now we punt and renumber so that there - ;; are only live conts. - (let ((conts (renumber conts))) - (let-values (((call-substs return-substs) (compute-contification conts))) - (apply-contification conts call-substs return-substs)))) diff --git a/module/language/cps2/cse.scm b/module/language/cps2/cse.scm deleted file mode 100644 index b5ac14d31..000000000 --- a/module/language/cps2/cse.scm +++ /dev/null @@ -1,449 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; Common subexpression elimination for CPS. -;;; -;;; Code: - -(define-module (language cps2 cse) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) - #:use-module (language cps2) - #:use-module (language cps2 utils) - #:use-module (language cps2 effects-analysis) - #:use-module (language cps intmap) - #:use-module (language cps intset) - #:export (eliminate-common-subexpressions)) - -(define (intset-pop set) - (match (intset-next set) - (#f (values set #f)) - (i (values (intset-remove set i) i)))) - -(define-syntax-rule (make-worklist-folder* seed ...) - (lambda (f worklist seed ...) - (let lp ((worklist worklist) (seed seed) ...) - (call-with-values (lambda () (intset-pop worklist)) - (lambda (worklist i) - (if i - (call-with-values (lambda () (f i seed ...)) - (lambda (i* seed ...) - (let add ((i* i*) (worklist worklist)) - (match i* - (() (lp worklist seed ...)) - ((i . i*) (add i* (intset-add worklist i))))))) - (values seed ...))))))) - -(define worklist-fold* - (case-lambda - ((f worklist seed) - ((make-worklist-folder* seed) f worklist seed)))) - -(define (compute-available-expressions conts kfun effects) - "Compute and return a map of LABEL->ANCESTOR..., where ANCESTOR... is -an intset containing ancestor labels whose value is available at LABEL." - (define (propagate avail succ out) - (let* ((in (intmap-ref avail succ (lambda (_) #f))) - (in* (if in (intset-intersect in out) out))) - (if (eq? in in*) - (values '() avail) - (values (list succ) - (intmap-add avail succ in* (lambda (old new) new)))))) - - (define (clobber label in) - (let ((fx (intmap-ref effects label))) - (cond - ((not (causes-effect? fx &write)) - ;; Fast-path if this expression clobbers nothing. - in) - (else - ;; Kill clobbered expressions. FIXME: there is no need to check - ;; on any label before than the last dominating label that - ;; clobbered everything. Another way to speed things up would - ;; be to compute a clobber set per-effect, which we could - ;; subtract from "in". - (let lp ((label 0) (in in)) - (cond - ((intset-next in label) - => (lambda (label) - (if (effect-clobbers? fx (intmap-ref effects label)) - (lp (1+ label) (intset-remove in label)) - (lp (1+ label) in)))) - (else in))))))) - - (define (visit-cont label avail) - (let* ((in (intmap-ref avail label)) - (out (intset-add (clobber label in) label))) - (define (propagate0) - (values '() avail)) - (define (propagate1 succ) - (propagate avail succ out)) - (define (propagate2 succ0 succ1) - (let*-values (((changed0 avail) (propagate avail succ0 out)) - ((changed1 avail) (propagate avail succ1 out))) - (values (append changed0 changed1) avail))) - - (match (intmap-ref conts label) - (($ $kargs names vars ($ $continue k src exp)) - (match exp - (($ $branch kt) (propagate2 k kt)) - (($ $prompt escape? tag handler) (propagate2 k handler)) - (_ (propagate1 k)))) - (($ $kreceive arity k) - (propagate1 k)) - (($ $kfun src meta self tail clause) - (if clause - (propagate1 clause) - (propagate0))) - (($ $kclause arity kbody kalt) - (if kalt - (propagate2 kbody kalt) - (propagate1 kbody))) - (($ $ktail) (propagate0))))) - - (worklist-fold* visit-cont - (intset kfun) - (intmap-add empty-intmap kfun empty-intset))) - -(define (compute-truthy-expressions conts kfun boolv) - "Compute a \"truth map\", indicating which expressions can be shown to -be true and/or false at each label in the function starting at KFUN.. -Returns an intmap of intsets. The even elements of the intset indicate -labels that may be true, and the odd ones indicate those that may be -false. It could be that both true and false proofs are available." - (define (true-idx label) (ash label 1)) - (define (false-idx label) (1+ (ash label 1))) - - (define (propagate boolv succ out) - (let* ((in (intmap-ref boolv succ (lambda (_) #f))) - (in* (if in (intset-intersect in out) out))) - (if (eq? in in*) - (values '() boolv) - (values (list succ) - (intmap-add boolv succ in* (lambda (old new) new)))))) - - (define (visit-cont label boolv) - (let ((in (intmap-ref boolv label))) - (define (propagate0) - (values '() boolv)) - (define (propagate1 succ) - (propagate boolv succ in)) - (define (propagate2 succ0 succ1) - (let*-values (((changed0 boolv) (propagate boolv succ0 in)) - ((changed1 boolv) (propagate boolv succ1 in))) - (values (append changed0 changed1) boolv))) - (define (propagate-branch succ0 succ1) - (let*-values (((changed0 boolv) - (propagate boolv succ0 - (intset-add in (false-idx label)))) - ((changed1 boolv) - (propagate boolv succ1 - (intset-add in (true-idx label))))) - (values (append changed0 changed1) boolv))) - - (match (intmap-ref conts label) - (($ $kargs names vars ($ $continue k src exp)) - (match exp - (($ $branch kt) (propagate-branch k kt)) - (($ $prompt escape? tag handler) (propagate2 k handler)) - (_ (propagate1 k)))) - (($ $kreceive arity k) - (propagate1 k)) - (($ $kfun src meta self tail clause) - (if clause - (propagate1 clause) - (propagate0))) - (($ $kclause arity kbody kalt) - (if kalt - (propagate2 kbody kalt) - (propagate1 kbody))) - (($ $ktail) (propagate0))))) - - (let ((boolv (worklist-fold* visit-cont - (intset kfun) - (intmap-add boolv kfun empty-intset)))) - ;; Now visit nested functions. We don't do this in the worklist - ;; folder because that would be exponential. - (define (recurse kfun boolv) - (compute-truthy-expressions conts kfun boolv)) - (intset-fold - (lambda (label boolv) - (match (intmap-ref conts label) - (($ $kargs _ _ ($ $continue _ _ exp)) - (match exp - (($ $fun kfun) (recurse kfun boolv)) - (($ $rec _ _ (($ $fun kfun) ...)) (fold recurse boolv kfun)) - (_ boolv))) - (_ boolv))) - (compute-function-body conts kfun) - boolv))) - -(define (intset-map f set) - (persistent-intmap - (intset-fold (lambda (i out) (intmap-add! out i (f i))) - set - empty-intmap))) - -;; Returns a map of label-idx -> (var-idx ...) indicating the variables -;; defined by a given labelled expression. -(define (compute-defs conts kfun) - (intset-map (lambda (label) - (match (intmap-ref conts label) - (($ $kfun src meta self tail clause) - (list self)) - (($ $kclause arity body alt) - (match (intmap-ref conts body) - (($ $kargs names vars) vars))) - (($ $kreceive arity kargs) - (match (intmap-ref conts kargs) - (($ $kargs names vars) vars))) - (($ $ktail) - '()) - (($ $kargs names vars ($ $continue k)) - (match (intmap-ref conts k) - (($ $kargs names vars) vars) - (_ #f))))) - (compute-function-body conts kfun))) - -(define (compute-singly-referenced succs) - (define (visit label succs single multiple) - (intset-fold (lambda (label single multiple) - (if (intset-ref single label) - (values single (intset-add! multiple label)) - (values (intset-add! single label) multiple))) - succs single multiple)) - (call-with-values (lambda () - (intmap-fold visit succs empty-intset empty-intset)) - (lambda (single multiple) - (intset-subtract (persistent-intset single) - (persistent-intset multiple))))) - -(define (compute-equivalent-subexpressions conts kfun effects - equiv-labels var-substs) - (let* ((succs (compute-successors conts kfun)) - (singly-referenced (compute-singly-referenced succs)) - (avail (compute-available-expressions conts kfun effects)) - (defs (compute-defs conts kfun)) - (equiv-set (make-hash-table))) - (define (subst-var var-substs var) - (intmap-ref var-substs var (lambda (var) var))) - (define (subst-vars var-substs vars) - (let lp ((vars vars)) - (match vars - (() '()) - ((var . vars) (cons (subst-var var-substs var) (lp vars)))))) - - (define (compute-exp-key var-substs exp) - (match exp - (($ $const val) (cons 'const val)) - (($ $prim name) (cons 'prim name)) - (($ $fun body) #f) - (($ $rec names syms funs) #f) - (($ $call proc args) #f) - (($ $callk k proc args) #f) - (($ $primcall name args) - (cons* 'primcall name (subst-vars var-substs args))) - (($ $branch _ ($ $primcall name args)) - (cons* 'primcall name (subst-vars var-substs args))) - (($ $branch) #f) - (($ $values args) #f) - (($ $prompt escape? tag handler) #f))) - - (define (add-auxiliary-definitions! label var-substs exp-key) - (define (subst var) - (subst-var var-substs var)) - (let ((defs (intmap-ref defs label))) - (define (add-def! aux-key var) - (let ((equiv (hash-ref equiv-set aux-key '()))) - (hash-set! equiv-set aux-key - (acons label (list var) equiv)))) - (match exp-key - (('primcall 'box val) - (match defs - ((box) - (add-def! `(primcall box-ref ,(subst box)) val)))) - (('primcall 'box-set! box val) - (add-def! `(primcall box-ref ,box) val)) - (('primcall 'cons car cdr) - (match defs - ((pair) - (add-def! `(primcall car ,(subst pair)) car) - (add-def! `(primcall cdr ,(subst pair)) cdr)))) - (('primcall 'set-car! pair car) - (add-def! `(primcall car ,pair) car)) - (('primcall 'set-cdr! pair cdr) - (add-def! `(primcall cdr ,pair) cdr)) - (('primcall (or 'make-vector 'make-vector/immediate) len fill) - (match defs - ((vec) - (add-def! `(primcall vector-length ,(subst vec)) len)))) - (('primcall 'vector-set! vec idx val) - (add-def! `(primcall vector-ref ,vec ,idx) val)) - (('primcall 'vector-set!/immediate vec idx val) - (add-def! `(primcall vector-ref/immediate ,vec ,idx) val)) - (('primcall (or 'allocate-struct 'allocate-struct/immediate) - vtable size) - (match defs - ((struct) - (add-def! `(primcall struct-vtable ,(subst struct)) - vtable)))) - (('primcall 'struct-set! struct n val) - (add-def! `(primcall struct-ref ,struct ,n) val)) - (('primcall 'struct-set!/immediate struct n val) - (add-def! `(primcall struct-ref/immediate ,struct ,n) val)) - (_ #t)))) - - (define (visit-label label equiv-labels var-substs) - (match (intmap-ref conts label) - (($ $kargs names vars ($ $continue k src exp)) - (let* ((exp-key (compute-exp-key var-substs exp)) - (equiv (hash-ref equiv-set exp-key '())) - (fx (intmap-ref effects label)) - (avail (intmap-ref avail label))) - (define (finish equiv-labels var-substs) - (define (recurse kfun equiv-labels var-substs) - (compute-equivalent-subexpressions conts kfun effects - equiv-labels var-substs)) - ;; If this expression defines auxiliary definitions, - ;; as `cons' does for the results of `car' and `cdr', - ;; define those. Do so after finding equivalent - ;; expressions, so that we can take advantage of - ;; subst'd output vars. - (add-auxiliary-definitions! label var-substs exp-key) - (match exp - ;; If we see a $fun, recurse to add to the result. - (($ $fun kfun) - (recurse kfun equiv-labels var-substs)) - (($ $rec names vars (($ $fun kfun) ...)) - (fold2 recurse kfun equiv-labels var-substs)) - (_ - (values equiv-labels var-substs)))) - (let lp ((candidates equiv)) - (match candidates - (() - ;; No matching expressions. Add our expression - ;; to the equivalence set, if appropriate. Note - ;; that expressions that allocate a fresh object - ;; or change the current fluid environment can't - ;; be eliminated by CSE (though DCE might do it - ;; if the value proves to be unused, in the - ;; allocation case). - (when (and exp-key - (not (causes-effect? fx &allocation)) - (not (effect-clobbers? fx (&read-object &fluid)))) - (let ((defs (and (intset-ref singly-referenced k) - (intmap-ref defs label)))) - (when defs - (hash-set! equiv-set exp-key - (acons label defs equiv))))) - (finish equiv-labels var-substs)) - (((and head (candidate . vars)) . candidates) - (cond - ((not (intset-ref avail candidate)) - ;; This expression isn't available here; try - ;; the next one. - (lp candidates)) - (else - ;; Yay, a match. Mark expression as equivalent. If - ;; we provide the definitions for the successor, mark - ;; the vars for substitution. - (finish (intmap-add equiv-labels label head) - (let ((defs (and (intset-ref singly-referenced k) - (intmap-ref defs label)))) - (if defs - (fold (lambda (def var var-substs) - (intmap-add var-substs def var)) - var-substs defs vars) - var-substs)))))))))) - (_ (values equiv-labels var-substs)))) - - ;; Traverse the labels in fun in reverse post-order, which will - ;; visit definitions before uses first. - (fold2 visit-label - (compute-reverse-post-order succs kfun) - equiv-labels - var-substs))) - -(define (apply-cse conts equiv-labels var-substs truthy-labels) - (define (true-idx idx) (ash idx 1)) - (define (false-idx idx) (1+ (ash idx 1))) - - (define (subst-var var) - (intmap-ref var-substs var (lambda (var) var))) - - (define (visit-exp exp) - (rewrite-exp exp - ((or ($ $const) ($ $prim) ($ $fun) ($ $rec)) ,exp) - (($ $call proc args) - ($call (subst-var proc) ,(map subst-var args))) - (($ $callk k proc args) - ($callk k (subst-var proc) ,(map subst-var args))) - (($ $primcall name args) - ($primcall name ,(map subst-var args))) - (($ $branch k exp) - ($branch k ,(visit-exp exp))) - (($ $values args) - ($values ,(map subst-var args))) - (($ $prompt escape? tag handler) - ($prompt escape? (subst-var tag) handler)))) - - (intmap-map - (lambda (label cont) - (match cont - (($ $kargs names vars ($ $continue k src exp)) - (build-cont - ($kargs names vars - ,(match (intmap-ref equiv-labels label (lambda (_) #f)) - ((equiv . vars) - (match exp - (($ $branch kt exp) - (let* ((bool (intmap-ref truthy-labels label)) - (t (intset-ref bool (true-idx equiv))) - (f (intset-ref bool (false-idx equiv)))) - (if (eqv? t f) - (build-term - ($continue k src - ($branch kt ,(visit-exp exp)))) - (build-term - ($continue (if t kt k) src ($values ())))))) - (_ - ;; For better or for worse, we only replace primcalls - ;; if they have an associated VM op, which allows - ;; them to continue to $kargs and thus we know their - ;; defs and can use a $values expression instead of a - ;; values primcall. - (build-term - ($continue k src ($values vars)))))) - (#f - (build-term - ($continue k src ,(visit-exp exp)))))))) - (_ cont))) - conts)) - -(define (eliminate-common-subexpressions conts) - (call-with-values - (lambda () - (let ((effects (synthesize-definition-effects (compute-effects conts)))) - (compute-equivalent-subexpressions conts 0 effects - empty-intmap empty-intmap))) - (lambda (equiv-labels var-substs) - (let ((truthy-labels (compute-truthy-expressions conts 0 empty-intmap))) - (apply-cse conts equiv-labels var-substs truthy-labels))))) diff --git a/module/language/cps2/dce.scm b/module/language/cps2/dce.scm deleted file mode 100644 index e743bc4a6..000000000 --- a/module/language/cps2/dce.scm +++ /dev/null @@ -1,399 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; This pass kills dead expressions: code that has no side effects, and -;;; whose value is unused. It does so by marking all live values, and -;;; then discarding other values as dead. This happens recursively -;;; through procedures, so it should be possible to elide dead -;;; procedures as well. -;;; -;;; Code: - -(define-module (language cps2 dce) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (language cps2) - #:use-module (language cps2 effects-analysis) - #:use-module (language cps2 renumber) - #:use-module (language cps2 types) - #:use-module (language cps2 utils) - #:use-module (language cps intmap) - #:use-module (language cps intset) - #:export (eliminate-dead-code)) - -(define (elide-type-checks conts kfun effects) - "Elide &type-check effects from EFFECTS for the function starting at -KFUN where we can prove that no assertion will be raised at run-time." - (let ((types (infer-types conts kfun))) - (define (visit-primcall effects fx label name args) - (if (primcall-types-check? types label name args) - (intmap-replace! effects label (logand fx (lognot &type-check))) - effects)) - (persistent-intmap - (intmap-fold (lambda (label types effects) - (let ((fx (intmap-ref effects label))) - (cond - ((causes-all-effects? fx) effects) - ((causes-effect? fx &type-check) - (match (intmap-ref conts label) - (($ $kargs _ _ exp) - (match exp - (($ $continue k src ($ $primcall name args)) - (visit-primcall effects fx label name args)) - (($ $continue k src - ($ $branch _ ($primcall name args))) - (visit-primcall effects fx label name args)) - (_ effects))) - (_ effects))) - (else effects)))) - types - effects)))) - -(define (compute-effects/elide-type-checks conts) - (intmap-fold (lambda (label cont effects) - (match cont - (($ $kfun) (elide-type-checks conts label effects)) - (_ effects))) - conts - (compute-effects conts))) - -(define (fold-local-conts proc conts label seed) - (match (intmap-ref conts label) - (($ $kfun src meta self tail clause) - (let lp ((label label) (seed seed)) - (if (<= label tail) - (lp (1+ label) (proc label (intmap-ref conts label) seed)) - seed))))) - -(define (postorder-fold-local-conts2 proc conts label seed0 seed1) - (match (intmap-ref conts label) - (($ $kfun src meta self tail clause) - (let ((start label)) - (let lp ((label tail) (seed0 seed0) (seed1 seed1)) - (if (<= start label) - (let ((cont (intmap-ref conts label))) - (call-with-values (lambda () (proc label cont seed0 seed1)) - (lambda (seed0 seed1) - (lp (1- label) seed0 seed1)))) - (values seed0 seed1))))))) - -(define (compute-known-allocations conts effects) - "Compute the variables bound in CONTS that have known allocation -sites." - ;; Compute the set of conts that are called with freshly allocated - ;; values, and subtract from that set the conts that might be called - ;; with values with unknown allocation sites. Then convert that set - ;; of conts into a set of bound variables. - (call-with-values - (lambda () - (intmap-fold (lambda (label cont known unknown) - ;; Note that we only need to add labels to the - ;; known/unknown sets if the labels can bind - ;; values. So there's no need to add tail, - ;; clause, branch alternate, or prompt handler - ;; labels, as they bind no values. - (match cont - (($ $kargs _ _ ($ $continue k)) - (let ((fx (intmap-ref effects label))) - (if (and (not (causes-all-effects? fx)) - (causes-effect? fx &allocation)) - (values (intset-add! known k) unknown) - (values known (intset-add! unknown k))))) - (($ $kreceive arity kargs) - (values known (intset-add! unknown kargs))) - (($ $kfun src meta self tail clause) - (values known unknown)) - (($ $kclause arity body alt) - (values known (intset-add! unknown body))) - (($ $ktail) - (values known unknown)))) - conts - empty-intset - empty-intset)) - (lambda (known unknown) - (persistent-intset - (intset-fold (lambda (label vars) - (match (intmap-ref conts label) - (($ $kargs (_) (var)) (intset-add! vars var)) - (_ vars))) - (intset-subtract (persistent-intset known) - (persistent-intset unknown)) - empty-intset))))) - -(define (compute-live-code conts) - (let* ((effects (compute-effects/elide-type-checks conts)) - (known-allocations (compute-known-allocations conts effects))) - (define (adjoin-var var set) - (intset-add set var)) - (define (adjoin-vars vars set) - (match vars - (() set) - ((var . vars) (adjoin-vars vars (adjoin-var var set))))) - (define (var-live? var live-vars) - (intset-ref live-vars var)) - (define (any-var-live? vars live-vars) - (match vars - (() #f) - ((var . vars) - (or (var-live? var live-vars) - (any-var-live? vars live-vars))))) - (define (cont-defs k) - (match (intmap-ref conts k) - (($ $kargs _ vars) vars) - (_ #f))) - - (define (visit-live-exp label k exp live-labels live-vars) - (match exp - ((or ($ $const) ($ $prim)) - (values live-labels live-vars)) - (($ $fun body) - (values (intset-add live-labels body) live-vars)) - (($ $closure body) - (values (intset-add live-labels body) live-vars)) - (($ $rec names vars (($ $fun kfuns) ...)) - (let lp ((vars vars) (kfuns kfuns) - (live-labels live-labels) (live-vars live-vars)) - (match (vector vars kfuns) - (#(() ()) (values live-labels live-vars)) - (#((var . vars) (kfun . kfuns)) - (lp vars kfuns - (if (var-live? var live-vars) - (intset-add live-labels kfun) - live-labels) - live-vars))))) - (($ $prompt escape? tag handler) - (values live-labels (adjoin-var tag live-vars))) - (($ $call proc args) - (values live-labels (adjoin-vars args (adjoin-var proc live-vars)))) - (($ $callk kfun proc args) - (values (intset-add live-labels kfun) - (adjoin-vars args (adjoin-var proc live-vars)))) - (($ $primcall name args) - (values live-labels (adjoin-vars args live-vars))) - (($ $branch k ($ $primcall name args)) - (values live-labels (adjoin-vars args live-vars))) - (($ $branch k ($ $values (arg))) - (values live-labels (adjoin-var arg live-vars))) - (($ $values args) - (values live-labels - (match (cont-defs k) - (#f (adjoin-vars args live-vars)) - (defs (fold (lambda (use def live-vars) - (if (var-live? def live-vars) - (adjoin-var use live-vars) - live-vars)) - live-vars args defs))))))) - - (define (visit-exp label k exp live-labels live-vars) - (cond - ((intset-ref live-labels label) - ;; Expression live already. - (visit-live-exp label k exp live-labels live-vars)) - ((let ((defs (cont-defs k)) - (fx (intmap-ref effects label))) - (or - ;; No defs; perhaps continuation is $ktail. - (not defs) - ;; We don't remove branches. - (match exp (($ $branch) #t) (_ #f)) - ;; Do we have a live def? - (any-var-live? defs live-vars) - ;; Does this expression cause all effects? If so, it's - ;; definitely live. - (causes-all-effects? fx) - ;; Does it cause a type check, but we weren't able to prove - ;; that the types check? - (causes-effect? fx &type-check) - ;; We might have a setter. If the object being assigned to - ;; is live or was not created by us, then this expression is - ;; live. Otherwise the value is still dead. - (and (causes-effect? fx &write) - (match exp - (($ $primcall - (or 'vector-set! 'vector-set!/immediate - 'set-car! 'set-cdr! - 'box-set!) - (obj . _)) - (or (var-live? obj live-vars) - (not (intset-ref known-allocations obj)))) - (_ #t))))) - ;; Mark expression as live and visit. - (visit-live-exp label k exp (intset-add live-labels label) live-vars)) - (else - ;; Still dead. - (values live-labels live-vars)))) - - (define (visit-fun label live-labels live-vars) - ;; Visit uses before definitions. - (postorder-fold-local-conts2 - (lambda (label cont live-labels live-vars) - (match cont - (($ $kargs _ _ ($ $continue k src exp)) - (visit-exp label k exp live-labels live-vars)) - (($ $kreceive arity kargs) - (values live-labels live-vars)) - (($ $kclause arity kargs kalt) - (values live-labels (adjoin-vars (cont-defs kargs) live-vars))) - (($ $kfun src meta self) - (values live-labels (adjoin-var self live-vars))) - (($ $ktail) - (values live-labels live-vars)))) - conts label live-labels live-vars)) - - (fixpoint (lambda (live-labels live-vars) - (let lp ((label 0) - (live-labels live-labels) - (live-vars live-vars)) - (match (intset-next live-labels label) - (#f (values live-labels live-vars)) - (label - (call-with-values - (lambda () - (match (intmap-ref conts label) - (($ $kfun) - (visit-fun label live-labels live-vars)) - (_ (values live-labels live-vars)))) - (lambda (live-labels live-vars) - (lp (1+ label) live-labels live-vars))))))) - (intset 0) - empty-intset))) - -(define-syntax adjoin-conts - (syntax-rules () - ((_ (exp ...) clause ...) - (let ((cps (exp ...))) - (adjoin-conts cps clause ...))) - ((_ cps (label cont) clause ...) - (adjoin-conts (intmap-add! cps label (build-cont cont)) - clause ...)) - ((_ cps) - cps))) - -(define (process-eliminations conts live-labels live-vars) - (define (label-live? label) - (intset-ref live-labels label)) - (define (value-live? var) - (intset-ref live-vars var)) - (define (make-adaptor k src defs) - (let* ((names (map (lambda (_) 'tmp) defs)) - (vars (map (lambda (_) (fresh-var)) defs)) - (live (filter-map (lambda (def var) - (and (value-live? def) var)) - defs vars))) - (build-cont - ($kargs names vars - ($continue k src ($values live)))))) - (define (visit-term label term cps) - (match term - (($ $continue k src exp) - (if (label-live? label) - (match exp - (($ $fun body) - (values cps - term)) - (($ $closure body nfree) - (values cps - term)) - (($ $rec names vars funs) - (match (filter-map (lambda (name var fun) - (and (value-live? var) - (list name var fun))) - names vars funs) - (() - (values cps - (build-term ($continue k src ($values ()))))) - (((names vars funs) ...) - (values cps - (build-term ($continue k src - ($rec names vars funs))))))) - (_ - (match (intmap-ref conts k) - (($ $kargs ()) - (values cps term)) - (($ $kargs names ((? value-live?) ...)) - (values cps term)) - (($ $kargs names vars) - (match exp - (($ $values args) - (let ((args (filter-map (lambda (use def) - (and (value-live? def) use)) - args vars))) - (values cps - (build-term - ($continue k src ($values args)))))) - (_ - (let-fresh (adapt) () - (values (adjoin-conts cps - (adapt ,(make-adaptor k src vars))) - (build-term - ($continue adapt src ,exp))))))) - (_ - (values cps term))))) - (values cps - (build-term - ($continue k src ($values ())))))))) - (define (visit-cont label cont cps) - (match cont - (($ $kargs names vars term) - (match (filter-map (lambda (name var) - (and (value-live? var) - (cons name var))) - names vars) - (((names . vars) ...) - (call-with-values (lambda () (visit-term label term cps)) - (lambda (cps term) - (adjoin-conts cps - (label ($kargs names vars ,term)))))))) - (($ $kreceive ($ $arity req () rest () #f) kargs) - (let ((defs (match (intmap-ref conts kargs) - (($ $kargs names vars) vars)))) - (if (and-map value-live? defs) - (adjoin-conts cps (label ,cont)) - (let-fresh (adapt) () - (adjoin-conts cps - (adapt ,(make-adaptor kargs #f defs)) - (label ($kreceive req rest adapt))))))) - (_ - (adjoin-conts cps (label ,cont))))) - (with-fresh-name-state conts - (persistent-intmap - (intmap-fold (lambda (label cont cps) - (match cont - (($ $kfun) - (if (label-live? label) - (fold-local-conts visit-cont conts label cps) - cps)) - (_ cps))) - conts - empty-intmap)))) - -(define (eliminate-dead-code conts) - ;; We work on a renumbered program so that we can easily visit uses - ;; before definitions just by visiting higher-numbered labels before - ;; lower-numbered labels. Renumbering is also a precondition for type - ;; inference. - (let ((conts (renumber conts))) - (call-with-values (lambda () (compute-live-code conts)) - (lambda (live-labels live-vars) - (process-eliminations conts live-labels live-vars))))) - -;;; Local Variables: -;;; eval: (put 'adjoin-conts 'scheme-indent-function 1) -;;; End: diff --git a/module/language/cps2/effects-analysis.scm b/module/language/cps2/effects-analysis.scm deleted file mode 100644 index ef5d8c8e9..000000000 --- a/module/language/cps2/effects-analysis.scm +++ /dev/null @@ -1,484 +0,0 @@ -;;; Effects analysis on CPS - -;; Copyright (C) 2011, 2012, 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; A helper module to compute the set of effects caused by an -;;; expression. This information is useful when writing algorithms that -;;; move code around, while preserving the semantics of an input -;;; program. -;;; -;;; The effects set is represented as an integer with three parts. The -;;; low 4 bits indicate effects caused by an expression, as a bitfield. -;;; The next 4 bits indicate the kind of memory accessed by the -;;; expression, if it accesses mutable memory. Finally the rest of the -;;; bits indicate the field in the object being accessed, if known, or -;;; -1 for unknown. -;;; -;;; In this way we embed a coarse type-based alias analysis in the -;;; effects analysis. For example, a "car" call is modelled as causing -;;; a read to field 0 on a &pair, and causing a &type-check effect. If -;;; any intervening code sets the car of any pair, that will block -;;; motion of the "car" call, because any write to field 0 of a pair is -;;; seen by effects analysis as being a write to field 0 of all pairs. -;;; -;;; Code: - -(define-module (language cps2 effects-analysis) - #:use-module (language cps2) - #:use-module (language cps2 utils) - #:use-module (language cps intmap) - #:use-module (ice-9 match) - #:export (expression-effects - compute-effects - synthesize-definition-effects - - &allocation - &type-check - &read - &write - - &fluid - &prompt - &car - &cdr - &vector - &box - &module - &struct - &string - &bytevector - - &object - &field - - &allocate - &read-object - &read-field - &write-object - &write-field - - &no-effects - &all-effects - - exclude-effects - effect-free? - constant? - causes-effect? - causes-all-effects? - effect-clobbers?)) - -(define-syntax define-flags - (lambda (x) - (syntax-case x () - ((_ all shift name ...) - (let ((count (length #'(name ...)))) - (with-syntax (((n ...) (iota count)) - (count count)) - #'(begin - (define-syntax name (identifier-syntax (ash 1 n))) - ... - (define-syntax all (identifier-syntax (1- (ash 1 count)))) - (define-syntax shift (identifier-syntax count))))))))) - -(define-syntax define-enumeration - (lambda (x) - (define (count-bits n) - (let lp ((out 1)) - (if (< n (ash 1 (1- out))) - out - (lp (1+ out))))) - (syntax-case x () - ((_ mask shift name ...) - (let* ((len (length #'(name ...))) - (bits (count-bits len))) - (with-syntax (((n ...) (iota len)) - (bits bits)) - #'(begin - (define-syntax name (identifier-syntax n)) - ... - (define-syntax mask (identifier-syntax (1- (ash 1 bits)))) - (define-syntax shift (identifier-syntax bits))))))))) - -(define-flags &all-effect-kinds &effect-kind-bits - ;; Indicates that an expression may cause a type check. A type check, - ;; for the purposes of this analysis, is the possibility of throwing - ;; an exception the first time an expression is evaluated. If the - ;; expression did not cause an exception to be thrown, users can - ;; assume that evaluating the expression again will not cause an - ;; exception to be thrown. - ;; - ;; For example, (+ x y) might throw if X or Y are not numbers. But if - ;; it doesn't throw, it should be safe to elide a dominated, common - ;; subexpression (+ x y). - &type-check - - ;; Indicates that an expression may return a fresh object. The kind - ;; of object is indicated in the object kind field. - &allocation - - ;; Indicates that an expression may cause a read from memory. The - ;; kind of memory is given in the object kind field. Some object - ;; kinds have finer-grained fields; those are expressed in the "field" - ;; part of the effects value. -1 indicates "the whole object". - &read - - ;; Indicates that an expression may cause a write to memory. - &write) - -(define-enumeration &memory-kind-mask &memory-kind-bits - ;; Indicates than an expression may access unknown kinds of memory. - &unknown-memory-kinds - - ;; Indicates that an expression depends on the value of a fluid - ;; variable, or on the current fluid environment. - &fluid - - ;; Indicates that an expression depends on the current prompt - ;; stack. - &prompt - - ;; Indicates that an expression depends on the value of the car or cdr - ;; of a pair. - &pair - - ;; Indicates that an expression depends on the value of a vector - ;; field. The effect field indicates the specific field, or zero for - ;; an unknown field. - &vector - - ;; Indicates that an expression depends on the value of a variable - ;; cell. - &box - - ;; Indicates that an expression depends on the current module. - &module - - ;; Indicates that an expression depends on the value of a struct - ;; field. The effect field indicates the specific field, or zero for - ;; an unknown field. - &struct - - ;; Indicates that an expression depends on the contents of a string. - &string - - ;; Indicates that an expression depends on the contents of a - ;; bytevector. We cannot be more precise, as bytevectors may alias - ;; other bytevectors. - &bytevector) - -(define-inlinable (&field kind field) - (ash (logior (ash field &memory-kind-bits) kind) &effect-kind-bits)) -(define-inlinable (&object kind) - (&field kind -1)) - -(define-inlinable (&allocate kind) - (logior &allocation (&object kind))) -(define-inlinable (&read-field kind field) - (logior &read (&field kind field))) -(define-inlinable (&read-object kind) - (logior &read (&object kind))) -(define-inlinable (&write-field kind field) - (logior &write (&field kind field))) -(define-inlinable (&write-object kind) - (logior &write (&object kind))) - -(define-syntax &no-effects (identifier-syntax 0)) -(define-syntax &all-effects - (identifier-syntax - (logior &all-effect-kinds (&object &unknown-memory-kinds)))) - -(define-inlinable (constant? effects) - (zero? effects)) - -(define-inlinable (causes-effect? x effects) - (not (zero? (logand x effects)))) - -(define-inlinable (causes-all-effects? x) - (eqv? x &all-effects)) - -(define (effect-clobbers? a b) - "Return true if A clobbers B. This is the case if A is a write, and B -is or might be a read or a write to the same location as A." - (define (locations-same?) - (let ((a (ash a (- &effect-kind-bits))) - (b (ash b (- &effect-kind-bits)))) - (or (eqv? &unknown-memory-kinds (logand a &memory-kind-mask)) - (eqv? &unknown-memory-kinds (logand b &memory-kind-mask)) - (and (eqv? (logand a &memory-kind-mask) (logand b &memory-kind-mask)) - ;; A negative field indicates "the whole object". - ;; Non-negative fields indicate only part of the object. - (or (< a 0) (< b 0) (= a b)))))) - (and (not (zero? (logand a &write))) - (not (zero? (logand b (logior &read &write)))) - (locations-same?))) - -(define-inlinable (indexed-field kind var constants) - (let ((val (intmap-ref constants var (lambda (_) #f)))) - (if (and (exact-integer? val) (<= 0 val)) - (&field kind val) - (&object kind)))) - -(define *primitive-effects* (make-hash-table)) - -(define-syntax-rule (define-primitive-effects* constants - ((name . args) effects ...) - ...) - (begin - (hashq-set! *primitive-effects* 'name - (case-lambda* - ((constants . args) (logior effects ...)) - (_ &all-effects))) - ...)) - -(define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...) - (define-primitive-effects* constants ((name . args) effects ...) ...)) - -;; Miscellaneous. -(define-primitive-effects - ((values . _))) - -;; Generic effect-free predicates. -(define-primitive-effects - ((eq? . _)) - ((eqv? . _)) - ((equal? . _)) - ((pair? arg)) - ((null? arg)) - ((nil? arg )) - ((symbol? arg)) - ((variable? arg)) - ((vector? arg)) - ((struct? arg)) - ((string? arg)) - ((number? arg)) - ((char? arg)) - ((bytevector? arg)) - ((keyword? arg)) - ((bitvector? arg)) - ((procedure? arg)) - ((thunk? arg))) - -;; Fluids. -(define-primitive-effects - ((fluid-ref f) (&read-object &fluid) &type-check) - ((fluid-set! f v) (&write-object &fluid) &type-check) - ((push-fluid f v) (&write-object &fluid) &type-check) - ((pop-fluid) (&write-object &fluid) &type-check)) - -;; Prompts. -(define-primitive-effects - ((make-prompt-tag #:optional arg) (&allocate &unknown-memory-kinds))) - -;; Pairs. -(define-primitive-effects - ((cons a b) (&allocate &pair)) - ((list . _) (&allocate &pair)) - ((car x) (&read-field &pair 0) &type-check) - ((set-car! x y) (&write-field &pair 0) &type-check) - ((cdr x) (&read-field &pair 1) &type-check) - ((set-cdr! x y) (&write-field &pair 1) &type-check) - ((memq x y) (&read-object &pair) &type-check) - ((memv x y) (&read-object &pair) &type-check) - ((list? arg) (&read-field &pair 1)) - ((length l) (&read-field &pair 1) &type-check)) - -;; Variables. -(define-primitive-effects - ((box v) (&allocate &box)) - ((box-ref v) (&read-object &box) &type-check) - ((box-set! v x) (&write-object &box) &type-check)) - -;; Vectors. -(define (vector-field n constants) - (indexed-field &vector n constants)) -(define (read-vector-field n constants) - (logior &read (vector-field n constants))) -(define (write-vector-field n constants) - (logior &write (vector-field n constants))) -(define-primitive-effects* constants - ((vector . _) (&allocate &vector)) - ((make-vector n init) (&allocate &vector) &type-check) - ((make-vector/immediate n init) (&allocate &vector)) - ((vector-ref v n) (read-vector-field n constants) &type-check) - ((vector-ref/immediate v n) (read-vector-field n constants) &type-check) - ((vector-set! v n x) (write-vector-field n constants) &type-check) - ((vector-set!/immediate v n x) (write-vector-field n constants) &type-check) - ((vector-length v) &type-check)) - -;; Structs. -(define (struct-field n constants) - (indexed-field &struct n constants)) -(define (read-struct-field n constants) - (logior &read (struct-field n constants))) -(define (write-struct-field n constants) - (logior &write (struct-field n constants))) -(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) - ((struct-set! s n x) (write-struct-field n constants) &type-check) - ((struct-set!/immediate s n x) (write-struct-field n constants) &type-check) - ((struct-vtable s) &type-check)) - -;; Strings. -(define-primitive-effects - ((string-ref s n) (&read-object &string) &type-check) - ((string-set! s n c) (&write-object &string) &type-check) - ((number->string _) (&allocate &string) &type-check) - ((string->number _) (&read-object &string) &type-check) - ((string-length s) &type-check)) - -;; Bytevectors. -(define-primitive-effects - ((bytevector-length _) &type-check) - - ((bv-u8-ref bv n) (&read-object &bytevector) &type-check) - ((bv-s8-ref bv n) (&read-object &bytevector) &type-check) - ((bv-u16-ref bv n) (&read-object &bytevector) &type-check) - ((bv-s16-ref bv n) (&read-object &bytevector) &type-check) - ((bv-u32-ref bv n) (&read-object &bytevector) &type-check) - ((bv-s32-ref bv n) (&read-object &bytevector) &type-check) - ((bv-u64-ref bv n) (&read-object &bytevector) &type-check) - ((bv-s64-ref bv n) (&read-object &bytevector) &type-check) - ((bv-f32-ref bv n) (&read-object &bytevector) &type-check) - ((bv-f64-ref bv n) (&read-object &bytevector) &type-check) - - ((bv-u8-set! bv n x) (&write-object &bytevector) &type-check) - ((bv-s8-set! bv n x) (&write-object &bytevector) &type-check) - ((bv-u16-set! bv n x) (&write-object &bytevector) &type-check) - ((bv-s16-set! bv n x) (&write-object &bytevector) &type-check) - ((bv-u32-set! bv n x) (&write-object &bytevector) &type-check) - ((bv-s32-set! bv n x) (&write-object &bytevector) &type-check) - ((bv-u64-set! bv n x) (&write-object &bytevector) &type-check) - ((bv-s64-set! bv n x) (&write-object &bytevector) &type-check) - ((bv-f32-set! bv n x) (&write-object &bytevector) &type-check) - ((bv-f64-set! bv n x) (&write-object &bytevector) &type-check)) - -;; Modules. -(define-primitive-effects - ((current-module) (&read-object &module)) - ((cache-current-module! m scope) (&write-object &box)) - ((resolve name bound?) (&read-object &module) &type-check) - ((cached-toplevel-box scope name bound?) &type-check) - ((cached-module-box mod name public? bound?) &type-check) - ((define! name val) (&read-object &module) (&write-object &box))) - -;; Numbers. -(define-primitive-effects - ((= . _) &type-check) - ((< . _) &type-check) - ((> . _) &type-check) - ((<= . _) &type-check) - ((>= . _) &type-check) - ((zero? . _) &type-check) - ((add . _) &type-check) - ((mul . _) &type-check) - ((sub . _) &type-check) - ((div . _) &type-check) - ((sub1 . _) &type-check) - ((add1 . _) &type-check) - ((quo . _) &type-check) - ((rem . _) &type-check) - ((mod . _) &type-check) - ((complex? _) &type-check) - ((real? _) &type-check) - ((rational? _) &type-check) - ((inf? _) &type-check) - ((nan? _) &type-check) - ((integer? _) &type-check) - ((exact? _) &type-check) - ((inexact? _) &type-check) - ((even? _) &type-check) - ((odd? _) &type-check) - ((ash n m) &type-check) - ((logand . _) &type-check) - ((logior . _) &type-check) - ((logxor . _) &type-check) - ((lognot . _) &type-check) - ((logtest a b) &type-check) - ((logbit? a b) &type-check) - ((sqrt _) &type-check) - ((abs _) &type-check)) - -;; Characters. -(define-primitive-effects - ((char=? . _) &type-check) - ((char>? . _) &type-check) - ((integer->char _) &type-check) - ((char->integer _) &type-check)) - -(define (primitive-effects constants name args) - (let ((proc (hashq-ref *primitive-effects* name))) - (if proc - (apply proc constants args) - &all-effects))) - -(define (expression-effects exp constants) - (match exp - ((or ($ $const) ($ $prim) ($ $values)) - &no-effects) - ((or ($ $fun) ($ $rec) ($ $closure)) - (&allocate &unknown-memory-kinds)) - (($ $prompt) - (&write-object &prompt)) - ((or ($ $call) ($ $callk)) - &all-effects) - (($ $branch k exp) - (expression-effects exp constants)) - (($ $primcall name args) - (primitive-effects constants name args)))) - -(define (compute-effects conts) - (let ((constants (compute-constant-values conts))) - (intmap-map - (lambda (label cont) - (match cont - (($ $kargs names syms ($ $continue k src exp)) - (expression-effects exp constants)) - (($ $kreceive arity kargs) - (match arity - (($ $arity _ () #f () #f) &type-check) - (($ $arity () () _ () #f) (&allocate &pair)) - (($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check)))) - (($ $kfun) &type-check) - (($ $kclause) &type-check) - (($ $ktail) &no-effects))) - conts))) - -;; There is a way to abuse effects analysis in CSE to also do scalar -;; replacement, effectively adding `car' and `cdr' expressions to `cons' -;; expressions, and likewise with other constructors and setters. This -;; routine adds appropriate effects to `cons' and `set-car!' and the -;; like. -;; -;; This doesn't affect CSE's ability to eliminate expressions, given -;; that allocations aren't eliminated anyway, and the new effects will -;; just cause the allocations not to commute with e.g. set-car! which -;; is what we want anyway. -(define (synthesize-definition-effects effects) - (intmap-map (lambda (label fx) - (if (logtest (logior &write &allocation) fx) - (logior fx &read) - fx)) - effects)) diff --git a/module/language/cps2/elide-values.scm b/module/language/cps2/elide-values.scm deleted file mode 100644 index ff04789fb..000000000 --- a/module/language/cps2/elide-values.scm +++ /dev/null @@ -1,88 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; Primcalls that don't correspond to VM instructions are treated as if -;;; they are calls, and indeed the later reify-primitives pass turns -;;; them into calls. Because no return arity checking is done for these -;;; primitives, if a later optimization pass simplifies the primcall to -;;; a VM operation, the tail of the simplification has to be a -;;; primcall to 'values. Most of these primcalls can be elided, and -;;; that is the job of this pass. -;;; -;;; Code: - -(define-module (language cps2 elide-values) - #:use-module (ice-9 match) - #:use-module (language cps2) - #:use-module (language cps2 utils) - #:use-module (language cps2 with-cps) - #:use-module (language cps intmap) - #:export (elide-values)) - -(define (inline-values cps k src args) - (match (intmap-ref cps k) - (($ $ktail) - (with-cps cps - (build-term - ($continue k src ($values args))))) - (($ $kreceive ($ $arity req () rest () #f) kargs) - (cond - ((and (not rest) (= (length args) (length req))) - (with-cps cps - (build-term - ($continue kargs src ($values args))))) - ((and rest (>= (length args) (length req))) - (let () - (define (build-rest cps k tail) - (match tail - (() - (with-cps cps - (build-term ($continue k src ($const '()))))) - ((v . tail) - (with-cps cps - (letv rest) - (letk krest ($kargs ('rest) (rest) - ($continue k src ($primcall 'cons (v rest))))) - ($ (build-rest krest tail)))))) - (with-cps cps - (letv rest) - (letk krest ($kargs ('rest) (rest) - ($continue kargs src - ($values ,(append (list-head args (length req)) - (list rest)))))) - ($ (build-rest krest (list-tail args (length req))))))) - (else (with-cps cps #f)))))) - -(define (elide-values conts) - (with-fresh-name-state conts - (persistent-intmap - (intmap-fold - (lambda (label cont out) - (match cont - (($ $kargs names vars ($ $continue k src ($ $primcall 'values args))) - (call-with-values (lambda () (inline-values out k src args)) - (lambda (out term) - (if term - (let ((cont (build-cont ($kargs names vars ,term)))) - (intmap-replace! out label cont)) - out)))) - (_ out))) - conts - conts)))) diff --git a/module/language/cps2/optimize.scm b/module/language/cps2/optimize.scm deleted file mode 100644 index 9e877b918..000000000 --- a/module/language/cps2/optimize.scm +++ /dev/null @@ -1,106 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; Optimizations on CPS2. -;;; -;;; Code: - -(define-module (language cps2 optimize) - #:use-module (ice-9 match) - #:use-module (language cps2 constructors) - #:use-module (language cps2 contification) - #:use-module (language cps2 cse) - #:use-module (language cps2 dce) - #:use-module (language cps2 elide-values) - #:use-module (language cps2 prune-top-level-scopes) - #:use-module (language cps2 prune-bailouts) - #:use-module (language cps2 self-references) - #:use-module (language cps2 simplify) - #:use-module (language cps2 specialize-primcalls) - #:use-module (language cps2 split-rec) - #:use-module (language cps2 type-fold) - #:use-module (language cps2 verify) - #:export (optimize-higher-order-cps - optimize-first-order-cps)) - -(define (kw-arg-ref args kw default) - (match (memq kw args) - ((_ val . _) val) - (_ default))) - -(define *debug?* #f) - -(define (maybe-verify program) - (if *debug?* - (verify program) - program)) - -(define-syntax-rule (define-optimizer optimize (pass kw default) ...) - (define* (optimize program #:optional (opts '())) - ;; This series of assignments to `program' used to be a series of - ;; let* bindings of `program', as you would imagine. In compiled - ;; code this is fine because the compiler is able to allocate all - ;; let*-bound variable to the same slot, which also means that the - ;; garbage collector doesn't have to retain so many copies of the - ;; term being optimized. However during bootstrap, the interpreter - ;; doesn't do this optimization, leading to excessive data retention - ;; as the terms are rewritten. To marginally improve bootstrap - ;; memory usage, here we use set! instead. The compiler should - ;; produce the same code in any case, though currently it does not - ;; because it doesn't do escape analysis on the box created for the - ;; set!. - (maybe-verify program) - (set! program - (if (kw-arg-ref opts kw default) - (maybe-verify (pass program)) - program)) - ... - (verify program) - program)) - -;; Passes that are needed: -;; -;; * Abort contification: turning abort primcalls into continuation -;; calls, and eliding prompts if possible. -;; -;; * Loop peeling. Unrolls the first round through a loop if the -;; loop has effects that CSE can work on. Requires effects -;; analysis. When run before CSE, loop peeling is the equivalent -;; of loop-invariant code motion (LICM). -;; -(define-optimizer optimize-higher-order-cps - (split-rec #:split-rec? #t) - (eliminate-dead-code #:eliminate-dead-code? #t) - (prune-top-level-scopes #:prune-top-level-scopes? #t) - (simplify #:simplify? #t) - (contify #:contify? #t) - (inline-constructors #:inline-constructors? #t) - (specialize-primcalls #:specialize-primcalls? #t) - (elide-values #:elide-values? #t) - (prune-bailouts #:prune-bailouts? #t) - (eliminate-common-subexpressions #:cse? #t) - (type-fold #:type-fold? #t) - (resolve-self-references #:resolve-self-references? #t) - (eliminate-dead-code #:eliminate-dead-code? #t) - (simplify #:simplify? #t)) - -(define-optimizer optimize-first-order-cps - (eliminate-dead-code #:eliminate-dead-code? #t) - (simplify #:simplify? #t)) diff --git a/module/language/cps2/prune-bailouts.scm b/module/language/cps2/prune-bailouts.scm deleted file mode 100644 index f33d2aeb4..000000000 --- a/module/language/cps2/prune-bailouts.scm +++ /dev/null @@ -1,86 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; A pass that prunes successors of expressions that bail out. -;;; -;;; Code: - -(define-module (language cps2 prune-bailouts) - #:use-module (ice-9 match) - #:use-module (language cps2) - #:use-module (language cps2 utils) - #:use-module (language cps2 with-cps) - #:use-module (language cps intmap) - #:use-module (language cps intset) - #:export (prune-bailouts)) - -(define (compute-tails conts) - "For each LABEL->CONT entry in the intmap CONTS, compute a -LABEL->TAIL-LABEL indicating the tail continuation of each expression's -containing function. In some cases TAIL-LABEL might not be available, -for example if there is a stale $kfun pointing at a body, or for -unreferenced terms. In that case TAIL-LABEL is either absent or #f." - (intmap-fold - (lambda (label cont out) - (match cont - (($ $kfun src meta self tail clause) - (intset-fold (lambda (label out) - (intmap-add out label tail (lambda (old new) #f))) - (compute-function-body conts label) - out)) - (_ out))) - conts - empty-intmap)) - -(define (prune-bailout out tails k src exp) - (match (intmap-ref out k) - (($ $ktail) - (with-cps out #f)) - (_ - (match (intmap-ref tails k (lambda (_) #f)) - (#f - (with-cps out #f)) - (ktail - (with-cps out - (letv prim rest) - (letk kresult ($kargs ('rest) (rest) - ($continue ktail src ($values ())))) - (letk kreceive ($kreceive '() 'rest kresult)) - (build-term ($continue kreceive src ,exp)))))))) - -(define (prune-bailouts conts) - (let ((tails (compute-tails conts))) - (with-fresh-name-state conts - (persistent-intmap - (intmap-fold - (lambda (label cont out) - (match cont - (($ $kargs names vars - ($ $continue k src - (and exp ($ $primcall (or 'error 'scm-error 'throw))))) - (call-with-values (lambda () (prune-bailout out tails k src exp)) - (lambda (out term) - (if term - (let ((cont (build-cont ($kargs names vars ,term)))) - (intmap-replace! out label cont)) - out)))) - (_ out))) - conts - conts))))) diff --git a/module/language/cps2/prune-top-level-scopes.scm b/module/language/cps2/prune-top-level-scopes.scm deleted file mode 100644 index c737534b0..000000000 --- a/module/language/cps2/prune-top-level-scopes.scm +++ /dev/null @@ -1,63 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; A simple pass to prune unneeded top-level scopes. -;;; -;;; Code: - -(define-module (language cps2 prune-top-level-scopes) - #:use-module (ice-9 match) - #:use-module (language cps2) - #:use-module (language cps2 utils) - #:use-module (language cps intmap) - #:use-module (language cps intset) - #:export (prune-top-level-scopes)) - -(define (compute-used-scopes conts constants) - (persistent-intset - (intmap-fold - (lambda (label cont used-scopes) - (match cont - (($ $kargs _ _ - ($ $continue k src - ($ $primcall 'cached-toplevel-box (scope name bound?)))) - (intset-add! used-scopes (intmap-ref constants scope))) - (_ - used-scopes))) - conts - empty-intset))) - -(define (prune-top-level-scopes conts) - (let* ((constants (compute-constant-values conts)) - (used-scopes (compute-used-scopes conts constants))) - (intmap-map - (lambda (label cont) - (match cont - (($ $kargs names vars - ($ $continue k src - ($ $primcall 'cache-current-module! - (module (? (lambda (scope) - (let ((val (intmap-ref constants scope))) - (not (intset-ref used-scopes val))))))))) - (build-cont ($kargs names vars - ($continue k src ($values ()))))) - (_ - cont))) - conts))) diff --git a/module/language/cps2/reify-primitives.scm b/module/language/cps2/reify-primitives.scm deleted file mode 100644 index 55409bfc1..000000000 --- a/module/language/cps2/reify-primitives.scm +++ /dev/null @@ -1,167 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; A pass to reify lone $prim's that were never folded into a -;;; $primcall, and $primcall's to primitives that don't have a -;;; corresponding VM op. -;;; -;;; Code: - -(define-module (language cps2 reify-primitives) - #:use-module (ice-9 match) - #:use-module (language cps2) - #:use-module (language cps2 utils) - #:use-module (language cps2 with-cps) - #:use-module (language cps primitives) - #:use-module (language cps intmap) - #:use-module (language bytecode) - #:export (reify-primitives)) - -(define (module-box cps src module name public? bound? val-proc) - (with-cps cps - (letv box) - (let$ body (val-proc box)) - (letk kbox ($kargs ('box) (box) ,body)) - ($ (with-cps-constants ((module module) - (name name) - (public? public?) - (bound? bound?)) - (build-term ($continue kbox src - ($primcall 'cached-module-box - (module name public? bound?)))))))) - -(define (primitive-module name) - (case name - ((bytevector? - bytevector-length - - bytevector-u8-ref bytevector-u8-set! - bytevector-s8-ref bytevector-s8-set! - - bytevector-u16-ref bytevector-u16-set! - bytevector-u16-native-ref bytevector-u16-native-set! - bytevector-s16-ref bytevector-s16-set! - bytevector-s16-native-ref bytevector-s16-native-set! - - bytevector-u32-ref bytevector-u32-set! - bytevector-u32-native-ref bytevector-u32-native-set! - bytevector-s32-ref bytevector-s32-set! - bytevector-s32-native-ref bytevector-s32-native-set! - - bytevector-u64-ref bytevector-u64-set! - bytevector-u64-native-ref bytevector-u64-native-set! - bytevector-s64-ref bytevector-s64-set! - bytevector-s64-native-ref bytevector-s64-native-set! - - bytevector-ieee-single-ref bytevector-ieee-single-set! - bytevector-ieee-single-native-ref bytevector-ieee-single-native-set! - bytevector-ieee-double-ref bytevector-ieee-double-set! - bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!) - '(rnrs bytevectors)) - ((class-of) '(oop goops)) - (else '(guile)))) - -(define (primitive-ref cps name k src) - (module-box cps src (primitive-module name) name #f #t - (lambda (cps box) - (with-cps cps - (build-term - ($continue k src ($primcall 'box-ref (box)))))))) - -(define (builtin-ref cps idx k src) - (with-cps cps - ($ (with-cps-constants ((idx idx)) - (build-term - ($continue k src ($primcall 'builtin-ref (idx)))))))) - -(define (reify-clause cps ktail) - (with-cps cps - (letv throw) - (let$ throw-body - (with-cps-constants ((wna 'wrong-number-of-args) - (false #f) - (str "Wrong number of arguments") - (eol '())) - (build-term - ($continue ktail #f - ($call throw (wna false str eol false)))))) - (letk kthrow ($kargs ('throw) (throw) ,throw-body)) - (let$ body (primitive-ref 'throw kthrow #f)) - (letk kbody ($kargs () () ,body)) - (letk kclause ($kclause ('() '() #f '() #f) kbody #f)) - kclause)) - -;; A $kreceive continuation should have only one predecessor. -(define (uniquify-receive cps k) - (match (intmap-ref cps k) - (($ $kreceive ($ $arity req () rest () #f) kargs) - (with-cps cps - (letk k ($kreceive req rest kargs)) - k)) - (_ - (with-cps cps k)))) - -(define (reify-primitives cps) - (define (visit-cont label cont cps) - (define (resolve-prim cps name k src) - (cond - ((builtin-name->index name) - => (lambda (idx) (builtin-ref cps idx k src))) - (else - (primitive-ref cps name k src)))) - (match cont - (($ $kfun src meta self tail #f) - (with-cps cps - (let$ clause (reify-clause tail)) - (setk label ($kfun src meta self tail clause)))) - (($ $kargs names vars ($ $continue k src ($ $prim name))) - (with-cps cps - (let$ k (uniquify-receive k)) - (let$ body (resolve-prim name k src)) - (setk label ($kargs names vars ,body)))) - (($ $kargs names vars - ($ $continue k src ($ $primcall 'call-thunk/no-inline (proc)))) - (with-cps cps - (setk label ($kargs names vars ($continue k src ($call proc ())))))) - (($ $kargs names vars ($ $continue k src ($ $primcall name args))) - (if (or (prim-instruction name) (branching-primitive? name)) - ;; Assume arities are correct. - cps - (with-cps cps - (letv proc) - (let$ k (uniquify-receive k)) - (letk kproc ($kargs ('proc) (proc) - ($continue k src ($call proc args)))) - (let$ body (resolve-prim name kproc src)) - (setk label ($kargs names vars ,body))))) - (($ $kargs names vars ($ $continue k src ($ $call proc args))) - (with-cps cps - (let$ k (uniquify-receive k)) - (setk label ($kargs names vars - ($continue k src ($call proc args)))))) - (($ $kargs names vars ($ $continue k src ($ $callk k* proc args))) - (with-cps cps - (let$ k (uniquify-receive k)) - (setk label ($kargs names vars - ($continue k src ($callk k* proc args)))))) - (_ cps))) - - (with-fresh-name-state cps - (persistent-intmap (intmap-fold visit-cont cps cps)))) diff --git a/module/language/cps2/renumber.scm b/module/language/cps2/renumber.scm deleted file mode 100644 index 16ed29ced..000000000 --- a/module/language/cps2/renumber.scm +++ /dev/null @@ -1,217 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; A pass to renumber variables and continuation labels so that they -;;; are contiguous within each function and, in the case of labels, -;;; topologically sorted. -;;; -;;; Code: - -(define-module (language cps2 renumber) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) - #:use-module (language cps2) - #:use-module (language cps2 utils) - #:use-module (language cps intset) - #:use-module (language cps intmap) - #:export (renumber)) - -(define* (compute-tail-path-lengths conts kfun preds) - (define (add-lengths labels lengths length) - (intset-fold (lambda (label lengths) - (intmap-add! lengths label length)) - labels - lengths)) - (define (compute-next labels lengths) - (intset-fold (lambda (label labels) - (fold1 (lambda (pred labels) - (if (intmap-ref lengths pred (lambda (_) #f)) - labels - (intset-add! labels pred))) - (intmap-ref preds label) - labels)) - labels - empty-intset)) - (define (visit labels lengths length) - (let ((lengths (add-lengths labels lengths length))) - (values (compute-next labels lengths) lengths (1+ length)))) - (match (intmap-ref conts kfun) - (($ $kfun src meta self tail clause) - (worklist-fold visit (intset-add empty-intset tail) empty-intmap 0)))) - -;; Topologically sort the continuation tree starting at k0, using -;; reverse post-order numbering. -(define (sort-labels-locally conts k0 path-lengths) - (define (visit-kf-first? kf kt) - ;; Visit the successor of a branch with the shortest path length to - ;; the tail first, so that if the branches are unsorted, the longer - ;; path length will appear first. This will move a loop exit out of - ;; a loop. - (let ((kf-len (intmap-ref path-lengths kf (lambda (_) #f))) - (kt-len (intmap-ref path-lengths kt (lambda (_) #f)))) - (if kt-len - (or (not kf-len) (< kf-len kt-len) - ;; If the path lengths are the same, preserve original - ;; order to avoid squirreliness. - (and (= kf-len kt-len) (< kt kf))) - (if kf-len #f (< kt kf))))) - (let ((order '()) - (visited empty-intset)) - (let visit ((k k0) (order '()) (visited empty-intset)) - (define (visit2 k0 k1 order visited) - (let-values (((order visited) (visit k0 order visited))) - (visit k1 order visited))) - (if (intset-ref visited k) - (values order visited) - (let ((visited (intset-add visited k))) - (call-with-values - (lambda () - (match (intmap-ref conts k) - (($ $kargs names syms ($ $continue k src exp)) - (match exp - (($ $prompt escape? tag handler) - (visit2 k handler order visited)) - (($ $branch kt) - (if (visit-kf-first? k kt) - (visit2 k kt order visited) - (visit2 kt k order visited))) - (_ - (visit k order visited)))) - (($ $kreceive arity k) (visit k order visited)) - (($ $kclause arity kbody kalt) - (if kalt - (visit2 kalt kbody order visited) - (visit kbody order visited))) - (($ $kfun src meta self tail clause) - (if clause - (visit2 tail clause order visited) - (visit tail order visited))) - (($ $ktail) (values order visited)))) - (lambda (order visited) - ;; Add k to the reverse post-order. - (values (cons k order) visited)))))))) - -(define (compute-renaming conts kfun) - ;; labels := old -> new - ;; vars := old -> new - (define *next-label* -1) - (define *next-var* -1) - (define (rename-label label labels) - (set! *next-label* (1+ *next-label*)) - (intmap-add! labels label *next-label*)) - (define (rename-var sym vars) - (set! *next-var* (1+ *next-var*)) - (intmap-add! vars sym *next-var*)) - (define (rename label labels vars) - (values (rename-label label labels) - (match (intmap-ref conts label) - (($ $kargs names syms exp) - (fold1 rename-var syms vars)) - (($ $kfun src meta self tail clause) - (rename-var self vars)) - (_ vars)))) - (define (maybe-visit-fun kfun labels vars) - (if (intmap-ref labels kfun (lambda (_) #f)) - (values labels vars) - (visit-fun kfun labels vars))) - (define (visit-nested-funs k labels vars) - (match (intmap-ref conts k) - (($ $kargs names syms ($ $continue k src ($ $fun kfun))) - (visit-fun kfun labels vars)) - (($ $kargs names syms ($ $continue k src ($ $rec names* syms* - (($ $fun kfun) ...)))) - (fold2 visit-fun kfun labels vars)) - (($ $kargs names syms ($ $continue k src ($ $closure kfun nfree))) - ;; Closures with zero free vars get copy-propagated so it's - ;; possible to already have visited them. - (maybe-visit-fun kfun labels vars)) - (($ $kargs names syms ($ $continue k src ($ $callk kfun))) - ;; Well-known functions never have a $closure created for them - ;; and are only referenced by their $callk call sites. - (maybe-visit-fun kfun labels vars)) - (_ (values labels vars)))) - (define (visit-fun kfun labels vars) - (let* ((preds (compute-predecessors conts kfun)) - (path-lengths (compute-tail-path-lengths conts kfun preds)) - (order (sort-labels-locally conts kfun path-lengths))) - ;; First rename locally, then recurse on nested functions. - (let-values (((labels vars) (fold2 rename order labels vars))) - (fold2 visit-nested-funs order labels vars)))) - (let-values (((labels vars) (visit-fun kfun empty-intmap empty-intmap))) - (values (persistent-intmap labels) (persistent-intmap vars)))) - -(define* (renumber conts #:optional (kfun 0)) - (let-values (((label-map var-map) (compute-renaming conts kfun))) - (define (rename-label label) (intmap-ref label-map label)) - (define (rename-var var) (intmap-ref var-map var)) - (define (rename-exp exp) - (rewrite-exp exp - ((or ($ $const) ($ $prim)) ,exp) - (($ $closure k nfree) - ($closure (rename-label k) nfree)) - (($ $fun body) - ($fun (rename-label body))) - (($ $rec names vars funs) - ($rec names (map rename-var vars) (map rename-exp funs))) - (($ $values args) - ($values ,(map rename-var args))) - (($ $call proc args) - ($call (rename-var proc) ,(map rename-var args))) - (($ $callk k proc args) - ($callk (rename-label k) (rename-var proc) ,(map rename-var args))) - (($ $branch kt exp) - ($branch (rename-label kt) ,(rename-exp exp))) - (($ $primcall name args) - ($primcall name ,(map rename-var args))) - (($ $prompt escape? tag handler) - ($prompt escape? (rename-var tag) (rename-label handler))))) - (define (rename-arity arity) - (match arity - (($ $arity req opt rest () aok?) - arity) - (($ $arity req opt rest kw aok?) - (match kw - (() arity) - (((kw kw-name kw-var) ...) - (let ((kw (map list kw kw-name (map rename-var kw-var)))) - (make-$arity req opt rest kw aok?))))))) - (persistent-intmap - (intmap-fold - (lambda (old-k new-k out) - (intmap-add! - out - new-k - (rewrite-cont (intmap-ref conts old-k) - (($ $kargs names syms ($ $continue k src exp)) - ($kargs names (map rename-var syms) - ($continue (rename-label k) src ,(rename-exp exp)))) - (($ $kreceive ($ $arity req () rest () #f) k) - ($kreceive req rest (rename-label k))) - (($ $ktail) - ($ktail)) - (($ $kfun src meta self tail clause) - ($kfun src meta (rename-var self) (rename-label tail) - (and clause (rename-label clause)))) - (($ $kclause arity body alternate) - ($kclause ,(rename-arity arity) (rename-label body) - (and alternate (rename-label alternate))))))) - label-map - empty-intmap)))) diff --git a/module/language/cps2/self-references.scm b/module/language/cps2/self-references.scm deleted file mode 100644 index 20ac56f39..000000000 --- a/module/language/cps2/self-references.scm +++ /dev/null @@ -1,79 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; A pass that replaces free references to recursive functions with -;;; bound references. -;;; -;;; Code: - -(define-module (language cps2 self-references) - #:use-module (ice-9 match) - #:use-module ((srfi srfi-1) #:select (fold)) - #:use-module (language cps2) - #:use-module (language cps2 utils) - #:use-module (language cps intmap) - #:use-module (language cps intset) - #:export (resolve-self-references)) - -(define* (resolve-self-references cps #:optional (label 0) (env empty-intmap)) - (define (subst var) - (intmap-ref env var (lambda (var) var))) - - (define (rename-exp label cps names vars k src exp) - (let ((exp (rewrite-exp exp - ((or ($ $const) ($ $prim)) ,exp) - (($ $call proc args) - ($call (subst proc) ,(map subst args))) - (($ $callk k proc args) - ($callk k (subst proc) ,(map subst args))) - (($ $primcall name args) - ($primcall name ,(map subst args))) - (($ $branch k ($ $values (arg))) - ($branch k ($values ((subst arg))))) - (($ $branch k ($ $primcall name args)) - ($branch k ($primcall name ,(map subst args)))) - (($ $values args) - ($values ,(map subst args))) - (($ $prompt escape? tag handler) - ($prompt escape? (subst tag) handler))))) - (intmap-replace! cps label - (build-cont - ($kargs names vars ($continue k src ,exp)))))) - - (define (visit-exp cps label names vars k src exp) - (match exp - (($ $fun label) - (resolve-self-references cps label env)) - (($ $rec names vars (($ $fun labels) ...)) - (fold (lambda (label var cps) - (match (intmap-ref cps label) - (($ $kfun src meta self) - (resolve-self-references cps label - (intmap-add env var self))))) - cps labels vars)) - (_ (rename-exp label cps names vars k src exp)))) - - (intset-fold (lambda (label cps) - (match (intmap-ref cps label) - (($ $kargs names vars ($ $continue k src exp)) - (visit-exp cps label names vars k src exp)) - (_ cps))) - (compute-function-body cps label) - cps)) diff --git a/module/language/cps2/simplify.scm b/module/language/cps2/simplify.scm deleted file mode 100644 index 19d7a1799..000000000 --- a/module/language/cps2/simplify.scm +++ /dev/null @@ -1,267 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; The fundamental lambda calculus reductions, like beta and eta -;;; reduction and so on. Pretty lame currently. -;;; -;;; Code: - -(define-module (language cps2 simplify) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) - #:use-module (language cps2) - #:use-module (language cps2 utils) - #:use-module (language cps intset) - #:use-module (language cps intmap) - #:export (simplify)) - -(define (intset-maybe-add! set k add?) - (if add? (intset-add! set k) set)) - -(define (intset-add* set k*) - (let lp ((set set) (k* k*)) - (match k* - ((k . k*) (lp (intset-add set k) k*)) - (() set)))) - -(define (intset-add*! set k*) - (fold1 (lambda (k set) (intset-add! set k)) k* set)) - -(define (fold2* f l1 l2 seed) - (let lp ((l1 l1) (l2 l2) (seed seed)) - (match (cons l1 l2) - ((() . ()) seed) - (((x1 . l1) . (x2 . l2)) (lp l1 l2 (f x1 x2 seed)))))) - -(define (transform-conts f conts) - (persistent-intmap - (intmap-fold (lambda (k v out) - (let ((v* (f k v))) - (cond - ((equal? v v*) out) - (v* (intmap-replace! out k v*)) - (else (intmap-remove out k))))) - conts - conts))) - -(define (compute-singly-referenced-vars conts) - (define (visit label cont single multiple) - (define (add-ref var single multiple) - (if (intset-ref single var) - (values single (intset-add! multiple var)) - (values (intset-add! single var) multiple))) - (define (ref var) (add-ref var single multiple)) - (define (ref* vars) (fold2 add-ref vars single multiple)) - (match cont - (($ $kargs _ _ ($ $continue _ _ exp)) - (match exp - ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure)) - (values single multiple)) - (($ $call proc args) - (ref* (cons proc args))) - (($ $callk k proc args) - (ref* (cons proc args))) - (($ $primcall name args) - (ref* args)) - (($ $values args) - (ref* args)) - (($ $branch kt ($ $values (var))) - (ref var)) - (($ $branch kt ($ $primcall name args)) - (ref* args)) - (($ $prompt escape? tag handler) - (ref tag)))) - (_ - (values single multiple)))) - (let*-values (((single multiple) (values empty-intset empty-intset)) - ((single multiple) (intmap-fold visit conts single multiple))) - (intset-subtract (persistent-intset single) - (persistent-intset multiple)))) - -;;; Continuations whose values are simply forwarded to another and not -;;; used in any other way may be elided via eta reduction over labels. -;;; -;;; There is an exception however: we must exclude strongly-connected -;;; components (SCCs). The only kind of SCC we can build out of $values -;;; expressions are infinite loops. -;;; -;;; Condition A below excludes single-node SCCs. Single-node SCCs -;;; cannot be reduced. -;;; -;;; Condition B conservatively excludes edges to labels already marked -;;; as candidates. This prevents back-edges and so breaks SCCs, and is -;;; optimal if labels are sorted. If the labels aren't sorted it's -;;; suboptimal but cheap. -(define (compute-eta-reductions conts kfun) - (let ((singly-used (compute-singly-referenced-vars conts))) - (define (singly-used? vars) - (match vars - (() #t) - ((var . vars) - (and (intset-ref singly-used var) (singly-used? vars))))) - (define (visit-fun kfun body eta) - (define (visit-cont label eta) - (match (intmap-ref conts label) - (($ $kargs names vars ($ $continue k src ($ $values vars))) - (intset-maybe-add! eta label - (match (intmap-ref conts k) - (($ $kargs) - (and (not (eqv? label k)) ; A - (not (intset-ref eta label)) ; B - (singly-used? vars))) - (_ #f)))) - (_ - eta))) - (intset-fold visit-cont body eta)) - (persistent-intset - (intmap-fold visit-fun - (compute-reachable-functions conts kfun) - empty-intset)))) - -(define (eta-reduce conts kfun) - (let ((label-set (compute-eta-reductions conts kfun))) - ;; Replace any continuation to a label in LABEL-SET with the label's - ;; continuation. The label will denote a $kargs continuation, so - ;; only terms that can continue to $kargs need be taken into - ;; account. - (define (subst label) - (if (intset-ref label-set label) - (match (intmap-ref conts label) - (($ $kargs _ _ ($ $continue k)) (subst k))) - label)) - (transform-conts - (lambda (label cont) - (and (not (intset-ref label-set label)) - (rewrite-cont cont - (($ $kargs names syms ($ $continue kf src ($ $branch kt exp))) - ($kargs names syms - ($continue (subst kf) src ($branch (subst kt) ,exp)))) - (($ $kargs names syms ($ $continue k src exp)) - ($kargs names syms - ($continue (subst k) src ,exp))) - (($ $kreceive ($ $arity req () rest () #f) k) - ($kreceive req rest (subst k))) - (($ $kclause arity body alt) - ($kclause ,arity (subst body) alt)) - (_ ,cont)))) - conts))) - -(define (compute-singly-referenced-labels conts body) - (define (add-ref label single multiple) - (define (ref k single multiple) - (if (intset-ref single k) - (values single (intset-add! multiple k)) - (values (intset-add! single k) multiple))) - (define (ref0) (values single multiple)) - (define (ref1 k) (ref k single multiple)) - (define (ref2 k k*) - (if k* - (let-values (((single multiple) (ref k single multiple))) - (ref k* single multiple)) - (ref1 k))) - (match (intmap-ref conts label) - (($ $kreceive arity k) (ref1 k)) - (($ $kfun src meta self ktail kclause) (ref2 ktail kclause)) - (($ $ktail) (ref0)) - (($ $kclause arity kbody kalt) (ref2 kbody kalt)) - (($ $kargs names syms ($ $continue k src exp)) - (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f)))))) - (let*-values (((single multiple) (values empty-intset empty-intset)) - ((single multiple) (intset-fold add-ref body single multiple))) - (intset-subtract (persistent-intset single) - (persistent-intset multiple)))) - -(define (compute-beta-reductions conts kfun) - (define (visit-fun kfun body beta) - (let ((single (compute-singly-referenced-labels conts body))) - (define (visit-cont label beta) - (match (intmap-ref conts label) - ;; A continuation's body can be inlined in place of a $values - ;; expression if the continuation is a $kargs. It should only - ;; be inlined if it is used only once, and not recursively. - (($ $kargs _ _ ($ $continue k src ($ $values))) - (intset-maybe-add! beta label - (and (intset-ref single k) - (match (intmap-ref conts k) - (($ $kargs) #t) - (_ #f))))) - (_ - beta))) - (intset-fold visit-cont body beta))) - (persistent-intset - (intmap-fold visit-fun - (compute-reachable-functions conts kfun) - empty-intset))) - -(define (compute-beta-var-substitutions conts label-set) - (define (add-var-substs label var-map) - (match (intmap-ref conts label) - (($ $kargs _ _ ($ $continue k _ ($ $values vals))) - (match (intmap-ref conts k) - (($ $kargs names vars) - (fold2* (lambda (var val var-map) - (intmap-add! var-map var val)) - vars vals var-map)))))) - (intset-fold add-var-substs label-set empty-intmap)) - -(define (beta-reduce conts kfun) - (let* ((label-set (compute-beta-reductions conts kfun)) - (var-map (compute-beta-var-substitutions conts label-set))) - (define (subst var) - (match (intmap-ref var-map var (lambda (_) #f)) - (#f var) - (val (subst val)))) - (define (transform-exp label k src exp) - (if (intset-ref label-set label) - (match (intmap-ref conts k) - (($ $kargs _ _ ($ $continue k* src* exp*)) - (transform-exp k k* src* exp*))) - (build-term - ($continue k src - ,(rewrite-exp exp - ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure)) - ,exp) - (($ $call proc args) - ($call (subst proc) ,(map subst args))) - (($ $callk k proc args) - ($callk k (subst proc) ,(map subst args))) - (($ $primcall name args) - ($primcall name ,(map subst args))) - (($ $values args) - ($values ,(map subst args))) - (($ $branch kt ($ $values (var))) - ($branch kt ($values ((subst var))))) - (($ $branch kt ($ $primcall name args)) - ($branch kt ($primcall name ,(map subst args)))) - (($ $prompt escape? tag handler) - ($prompt escape? (subst tag) handler))))))) - (transform-conts - (lambda (label cont) - (match cont - (($ $kargs names syms ($ $continue k src exp)) - (build-cont - ($kargs names syms ,(transform-exp label k src exp)))) - (_ cont))) - conts))) - -(define (simplify conts) - (eta-reduce (beta-reduce conts 0) 0)) diff --git a/module/language/cps2/slot-allocation.scm b/module/language/cps2/slot-allocation.scm deleted file mode 100644 index 48f5a1fd3..000000000 --- a/module/language/cps2/slot-allocation.scm +++ /dev/null @@ -1,995 +0,0 @@ -;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; A module to assign stack slots to variables in a CPS term. -;;; -;;; Code: - -(define-module (language cps2 slot-allocation) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) - #:use-module (language cps2) - #:use-module (language cps2 utils) - #:use-module (language cps intmap) - #:use-module (language cps intset) - #:export (allocate-slots - lookup-slot - lookup-maybe-slot - lookup-constant-value - lookup-maybe-constant-value - lookup-nlocals - lookup-call-proc-slot - lookup-parallel-moves - lookup-dead-slot-map)) - -(define-record-type $allocation - (make-allocation slots constant-values call-allocs shuffles frame-sizes) - allocation? - - ;; A map of VAR to slot allocation. A slot allocation is an integer, - ;; if the variable has been assigned a slot. - ;; - (slots allocation-slots) - - ;; A map of VAR to constant value, for variables with constant values. - ;; - (constant-values allocation-constant-values) - - ;; A map of LABEL to /call allocs/, for expressions that continue to - ;; $kreceive continuations: non-tail calls and $prompt expressions. - ;; - ;; A call alloc contains two pieces of information: the call's /proc - ;; slot/ and a /dead slot map/. The proc slot indicates the slot of a - ;; procedure in a procedure call, or where the procedure would be in a - ;; multiple-value return. - ;; - ;; The dead slot map indicates, what slots should be ignored by GC - ;; when marking the frame. A dead slot map is a bitfield, as an - ;; integer. - ;; - (call-allocs allocation-call-allocs) - - ;; A map of LABEL to /parallel moves/. Parallel moves shuffle locals - ;; into position for a $call, $callk, or $values, or shuffle returned - ;; values back into place in a $kreceive. - ;; - ;; A set of moves is expressed as an ordered list of (SRC . DST) - ;; moves, where SRC and DST are slots. This may involve a temporary - ;; variable. - ;; - (shuffles allocation-shuffles) - - ;; The number of locals for a $kclause. - ;; - (frame-sizes allocation-frame-sizes)) - -(define-record-type $call-alloc - (make-call-alloc proc-slot dead-slot-map) - call-alloc? - (proc-slot call-alloc-proc-slot) - (dead-slot-map call-alloc-dead-slot-map)) - -(define (lookup-maybe-slot var allocation) - (intmap-ref (allocation-slots allocation) var (lambda (_) #f))) - -(define (lookup-slot var allocation) - (intmap-ref (allocation-slots allocation) var)) - -(define *absent* (list 'absent)) - -(define (lookup-constant-value var allocation) - (let ((value (intmap-ref (allocation-constant-values allocation) var - (lambda (_) *absent*)))) - (when (eq? value *absent*) - (error "Variable does not have constant value" var)) - value)) - -(define (lookup-maybe-constant-value var allocation) - (let ((value (intmap-ref (allocation-constant-values allocation) var - (lambda (_) *absent*)))) - (if (eq? value *absent*) - (values #f #f) - (values #t value)))) - -(define (lookup-call-alloc k allocation) - (intmap-ref (allocation-call-allocs allocation) k)) - -(define (lookup-call-proc-slot k allocation) - (or (call-alloc-proc-slot (lookup-call-alloc k allocation)) - (error "Call has no proc slot" k))) - -(define (lookup-parallel-moves k allocation) - (intmap-ref (allocation-shuffles allocation) k)) - -(define (lookup-dead-slot-map k allocation) - (or (call-alloc-dead-slot-map (lookup-call-alloc k allocation)) - (error "Call has no dead slot map" k))) - -(define (lookup-nlocals k allocation) - (intmap-ref (allocation-frame-sizes allocation) k)) - -(define (intset-pop set) - (match (intset-next set) - (#f (values set #f)) - (i (values (intset-remove set i) i)))) - -(define (solve-flow-equations succs in out kill gen subtract add meet) - "Find a fixed point for flow equations for SUCCS, where IN and OUT are -the initial conditions as intmaps with one key for every node in SUCCS. -KILL and GEN are intmaps indicating the state that is killed or defined -at every node, and SUBTRACT, ADD, and MEET operates on that state." - (define (visit label in out) - (let* ((in-1 (intmap-ref in label)) - (kill-1 (intmap-ref kill label)) - (gen-1 (intmap-ref gen label)) - (out-1 (intmap-ref out label)) - (out-1* (add (subtract in-1 kill-1) gen-1))) - (if (eq? out-1 out-1*) - (values empty-intset in out) - (let ((out (intmap-replace! out label out-1*))) - (call-with-values - (lambda () - (intset-fold (lambda (succ in changed) - (let* ((in-1 (intmap-ref in succ)) - (in-1* (meet in-1 out-1*))) - (if (eq? in-1 in-1*) - (values in changed) - (values (intmap-replace! in succ in-1*) - (intset-add changed succ))))) - (intmap-ref succs label) in empty-intset)) - (lambda (in changed) - (values changed in out))))))) - - (let run ((worklist (intmap-keys succs)) (in in) (out out)) - (call-with-values (lambda () (intset-pop worklist)) - (lambda (worklist popped) - (if popped - (call-with-values (lambda () (visit popped in out)) - (lambda (changed in out) - (run (intset-union worklist changed) in out))) - (values (persistent-intmap in) - (persistent-intmap out))))))) - -(define-syntax-rule (persistent-intmap2 exp) - (call-with-values (lambda () exp) - (lambda (a b) - (values (persistent-intmap a) (persistent-intmap b))))) - -(define (compute-defs-and-uses cps) - "Return two LABEL->VAR... maps indicating values defined at and used -by a label, respectively." - (define (vars->intset vars) - (fold (lambda (var set) (intset-add set var)) empty-intset vars)) - (persistent-intmap2 - (intmap-fold - (lambda (label cont defs uses) - (define (get-defs k) - (match (intmap-ref cps k) - (($ $kargs names vars) (vars->intset vars)) - (_ empty-intset))) - (define (return d u) - (values (intmap-add! defs label d) - (intmap-add! uses label u))) - (match cont - (($ $kfun src meta self) - (return (intset self) empty-intset)) - (($ $kargs _ _ ($ $continue k src exp)) - (match exp - ((or ($ $const) ($ $closure)) - (return (get-defs k) empty-intset)) - (($ $call proc args) - (return (get-defs k) (intset-add (vars->intset args) proc))) - (($ $callk _ proc args) - (return (get-defs k) (intset-add (vars->intset args) proc))) - (($ $primcall name args) - (return (get-defs k) (vars->intset args))) - (($ $branch kt ($ $primcall name args)) - (return empty-intset (vars->intset args))) - (($ $branch kt ($ $values args)) - (return empty-intset (vars->intset args))) - (($ $values args) - (return (get-defs k) (vars->intset args))) - (($ $prompt escape? tag handler) - (return empty-intset (intset tag))))) - (($ $kclause arity body alt) - (return (get-defs body) empty-intset)) - (($ $kreceive arity kargs) - (return (get-defs kargs) empty-intset)) - (($ $ktail) - (return empty-intset empty-intset)))) - cps - empty-intmap - empty-intmap))) - -(define (compute-reverse-control-flow-order preds) - "Return a LABEL->ORDER bijection where ORDER is a contiguous set of -integers starting from 0 and incrementing in sort order." - ;; This is more involved than forward control flow because not all - ;; live labels are reachable from the tail. - (persistent-intmap - (fold2 (lambda (component order n) - (intset-fold (lambda (label order n) - (values (intmap-add! order label n) - (1+ n))) - component order n)) - (reverse (compute-sorted-strongly-connected-components preds)) - empty-intmap 0))) - -(define* (add-prompt-control-flow-edges conts succs #:key complete?) - "For all prompts in DFG in the range [MIN-LABEL, MIN-LABEL + -LABEL-COUNT), invoke F with arguments PROMPT, HANDLER, and BODY for each -body continuation in the prompt." - (define (intset-filter pred set) - (intset-fold (lambda (i set) - (if (pred i) set (intset-remove set i))) - set - set)) - (define (intset-any pred set) - (intset-fold (lambda (i res) - (if (or res (pred i)) #t res)) - set - #f)) - (define (visit-prompt label handler succs) - ;; FIXME: It isn't correct to use all continuations reachable from - ;; the prompt, because that includes continuations outside the - ;; prompt body. This point is moot if the handler's control flow - ;; joins with the the body, as is usually but not always the case. - ;; - ;; One counter-example is when the handler contifies an infinite - ;; loop; in that case we compute a too-large prompt body. This - ;; error is currently innocuous, but we should fix it at some point. - ;; - ;; The fix is to end the body at the corresponding "pop" primcall, - ;; if any. - (let ((body (intset-subtract (compute-function-body conts label) - (compute-function-body conts handler)))) - (define (out-or-back-edge? label) - ;; Most uses of visit-prompt-control-flow don't need every body - ;; continuation, and would be happy getting called only for - ;; continuations that postdominate the rest of the body. Unless - ;; you pass #:complete? #t, we only invoke F on continuations - ;; that can leave the body, or on back-edges in loops. - ;; - ;; You would think that looking for the final "pop" primcall - ;; would be sufficient, but that is incorrect; it's possible for - ;; a loop in the prompt body to be contified, and that loop need - ;; not continue to the pop if it never terminates. The pop could - ;; even be removed by DCE, in that case. - (intset-any (lambda (succ) - (or (not (intset-ref body succ)) - (<= succ label))) - (intmap-ref succs label))) - (intset-fold (lambda (pred succs) - (intmap-replace succs pred handler intset-add)) - (if complete? body (intset-filter out-or-back-edge? body)) - succs))) - (intmap-fold - (lambda (label cont succs) - (match cont - (($ $kargs _ _ - ($ $continue _ _ ($ $prompt escape? tag handler))) - (visit-prompt label handler succs)) - (_ succs))) - conts - succs)) - -(define (rename-keys map old->new) - (persistent-intmap - (intmap-fold (lambda (k v out) - (intmap-add! out (intmap-ref old->new k) v)) - map - empty-intmap))) - -(define (rename-intset set old->new) - (intset-fold (lambda (old set) (intset-add set (intmap-ref old->new old))) - set empty-intset)) - -(define (rename-graph graph old->new) - (persistent-intmap - (intmap-fold (lambda (pred succs out) - (intmap-add! out - (intmap-ref old->new pred) - (rename-intset succs old->new))) - graph - empty-intmap))) - -(define (compute-live-variables cps defs uses) - "Compute and return two values mapping LABEL->VAR..., where VAR... are -the definitions that are live before and after LABEL, as intsets." - (let* ((succs (add-prompt-control-flow-edges cps (compute-successors cps))) - (preds (invert-graph succs)) - (old->new (compute-reverse-control-flow-order preds))) - (call-with-values - (lambda () - (let ((init (rename-keys - (intmap-map (lambda (k v) empty-intset) preds) - old->new))) - (solve-flow-equations (rename-graph preds old->new) - init init - (rename-keys defs old->new) - (rename-keys uses old->new) - intset-subtract intset-union intset-union))) - (lambda (in out) - ;; As a reverse control-flow problem, the values flowing into a - ;; node are actually the live values after the node executes. - ;; Funny, innit? So we return them in the reverse order. - (let ((new->old (invert-bijection old->new))) - (values (rename-keys out new->old) - (rename-keys in new->old))))))) - -(define (compute-needs-slot cps defs uses) - (define (get-defs k) (intmap-ref defs k)) - (define (get-uses label) (intmap-ref uses label)) - (intmap-fold - (lambda (label cont needs-slot) - (intset-union - needs-slot - (match cont - (($ $kargs _ _ ($ $continue k src exp)) - (let ((defs (get-defs label))) - (define (defs+* uses) - (intset-union defs uses)) - (define (defs+ use) - (intset-add defs use)) - (match exp - (($ $const) - empty-intset) - (($ $primcall 'free-ref (closure slot)) - (defs+ closure)) - (($ $primcall 'free-set! (closure slot value)) - (defs+* (intset closure value))) - (($ $primcall 'cache-current-module! (mod . _)) - (defs+ mod)) - (($ $primcall 'cached-toplevel-box _) - defs) - (($ $primcall 'cached-module-box _) - defs) - (($ $primcall 'resolve (name bound?)) - (defs+ name)) - (($ $primcall 'make-vector/immediate (len init)) - (defs+ init)) - (($ $primcall 'vector-ref/immediate (v i)) - (defs+ v)) - (($ $primcall 'vector-set!/immediate (v i x)) - (defs+* (intset v x))) - (($ $primcall 'allocate-struct/immediate (vtable nfields)) - (defs+ vtable)) - (($ $primcall 'struct-ref/immediate (s n)) - (defs+ s)) - (($ $primcall 'struct-set!/immediate (s n x)) - (defs+* (intset s x))) - (($ $primcall 'builtin-ref (idx)) - defs) - (_ - (defs+* (get-uses label)))))) - (($ $kreceive arity k) - ;; Only allocate results of function calls to slots if they are - ;; used. - empty-intset) - (($ $kclause arity body alternate) - (get-defs label)) - (($ $kfun src meta self) - (intset self)) - (($ $ktail) - empty-intset)))) - cps - empty-intset)) - -(define (compute-lazy-vars cps live-in live-out defs needs-slot) - "Compute and return a set of vars whose allocation can be delayed -until their use is seen. These are \"lazy\" vars. A var is lazy if its -uses are calls, it is always dead after the calls, and if the uses flow -to the definition. A flow continues across a node iff the node kills no -values that need slots, and defines only lazy vars. Calls also kill -flows; there's no sense in trying to juggle a pending frame while there -is an active call." - (define (list->intset list) - (persistent-intset - (fold (lambda (i set) (intset-add! set i)) empty-intset list))) - - (let* ((succs (compute-successors cps)) - (gens (intmap-map - (lambda (label cont) - (match cont - (($ $kargs _ _ ($ $continue _ _ ($ $call proc args))) - (intset-subtract (intset-add (list->intset args) proc) - (intmap-ref live-out label))) - (($ $kargs _ _ ($ $continue _ _ ($ $callk _ proc args))) - (intset-subtract (intset-add (list->intset args) proc) - (intmap-ref live-out label))) - (_ #f))) - cps)) - (kills (intmap-map - (lambda (label in) - (let* ((out (intmap-ref live-out label)) - (killed (intset-subtract in out)) - (killed-slots (intset-intersect killed needs-slot))) - (and (eq? killed-slots empty-intset) - ;; Kill output variables that need slots. - (intset-intersect (intmap-ref defs label) - needs-slot)))) - live-in)) - (preds (invert-graph succs)) - (old->new (compute-reverse-control-flow-order preds))) - (define (subtract lazy kill) - (cond - ((eq? lazy empty-intset) - lazy) - ((not kill) - empty-intset) - ((and lazy (eq? empty-intset (intset-subtract kill lazy))) - (intset-subtract lazy kill)) - (else - empty-intset))) - (define (add live gen) (or gen live)) - (define (meet in out) - ;; Initial in is #f. - (if in (intset-intersect in out) out)) - (call-with-values - (lambda () - (let ((succs (rename-graph preds old->new)) - (in (rename-keys (intmap-map (lambda (k v) #f) preds) old->new)) - (out (rename-keys (intmap-map (lambda (k v) #f) preds) old->new)) - ;(out (rename-keys gens old->new)) - (kills (rename-keys kills old->new)) - (gens (rename-keys gens old->new))) - (solve-flow-equations succs in out kills gens subtract add meet))) - (lambda (in out) - ;; A variable is lazy if its uses reach its definition. - (intmap-fold (lambda (label out lazy) - (match (intmap-ref cps label) - (($ $kargs names vars) - (let ((defs (list->intset vars))) - (intset-union lazy (intset-intersect out defs)))) - (_ lazy))) - (rename-keys out (invert-bijection old->new)) - empty-intset))))) - -(define (find-first-zero n) - ;; Naive implementation. - (let lp ((slot 0)) - (if (logbit? slot n) - (lp (1+ slot)) - slot))) - -(define (find-first-trailing-zero n) - (let lp ((slot (let lp ((count 2)) - (if (< n (ash 1 (1- count))) - count - ;; Grow upper bound slower than factor 2 to avoid - ;; needless bignum allocation on 32-bit systems - ;; when there are more than 16 locals. - (lp (+ count (ash count -1))))))) - (if (or (zero? slot) (logbit? (1- slot) n)) - slot - (lp (1- slot))))) - -(define (integers from count) - (if (zero? count) - '() - (cons from (integers (1+ from) (1- count))))) - -(define (solve-parallel-move src dst tmp) - "Solve the parallel move problem between src and dst slot lists, which -are comparable with eqv?. A tmp slot may be used." - - ;; This algorithm is taken from: "Tilting at windmills with Coq: - ;; formal verification of a compilation algorithm for parallel moves" - ;; by Laurence Rideau, Bernard Paul Serpette, and Xavier Leroy - ;; - - (define (split-move moves reg) - (let loop ((revhead '()) (tail moves)) - (match tail - (((and s+d (s . d)) . rest) - (if (eqv? s reg) - (cons d (append-reverse revhead rest)) - (loop (cons s+d revhead) rest))) - (_ #f)))) - - (define (replace-last-source reg moves) - (match moves - ((moves ... (s . d)) - (append moves (list (cons reg d)))))) - - (let loop ((to-move (map cons src dst)) - (being-moved '()) - (moved '()) - (last-source #f)) - ;; 'last-source' should always be equivalent to: - ;; (and (pair? being-moved) (car (last being-moved))) - (match being-moved - (() (match to-move - (() (reverse moved)) - (((and s+d (s . d)) . t1) - (if (or (eqv? s d) ; idempotent - (not s)) ; src is a constant and can be loaded directly - (loop t1 '() moved #f) - (loop t1 (list s+d) moved s))))) - (((and s+d (s . d)) . b) - (match (split-move to-move d) - ((r . t1) (loop t1 (acons d r being-moved) moved last-source)) - (#f (match b - (() (loop to-move '() (cons s+d moved) #f)) - (_ (if (eqv? d last-source) - (loop to-move - (replace-last-source tmp b) - (cons s+d (acons d tmp moved)) - tmp) - (loop to-move b (cons s+d moved) last-source)))))))))) - -(define (compute-shuffles cps slots call-allocs live-in) - (define (add-live-slot slot live-slots) - (logior live-slots (ash 1 slot))) - - (define (get-cont label) - (intmap-ref cps label)) - - (define (get-slot var) - (intmap-ref slots var (lambda (_) #f))) - - (define (get-slots vars) - (let lp ((vars vars)) - (match vars - ((var . vars) (cons (get-slot var) (lp vars))) - (_ '())))) - - (define (get-proc-slot label) - (call-alloc-proc-slot (intmap-ref call-allocs label))) - - (define (compute-live-slots label) - (intset-fold (lambda (var live) - (match (get-slot var) - (#f live) - (slot (add-live-slot slot live)))) - (intmap-ref live-in label) - 0)) - - ;; Although some parallel moves may proceed without a temporary slot, - ;; in general one is needed. That temporary slot must not be part of - ;; the source or destination sets, and that slot should not correspond - ;; to a live variable. Usually the source and destination sets are a - ;; subset of the union of the live sets before and after the move. - ;; However for stack slots that don't have names -- those slots that - ;; correspond to function arguments or to function return values -- it - ;; could be that they are out of the computed live set. In that case - ;; they need to be adjoined to the live set, used when choosing a - ;; temporary slot. - ;; - ;; Note that although we reserve slots 253-255 for shuffling operands - ;; that address less than the full 24-bit range of locals, that - ;; reservation doesn't apply here, because this temporary itself is - ;; used while doing parallel assignment via "mov", and "mov" does not - ;; need shuffling. - (define (compute-tmp-slot live stack-slots) - (find-first-zero (fold add-live-slot live stack-slots))) - - (define (parallel-move src-slots dst-slots tmp-slot) - (solve-parallel-move src-slots dst-slots tmp-slot)) - - (define (compute-receive-shuffles label proc-slot) - (match (get-cont label) - (($ $kreceive arity kargs) - (let* ((results (match (get-cont kargs) - (($ $kargs names vars) vars))) - (value-slots (integers (1+ proc-slot) (length results))) - (result-slots (get-slots results)) - ;; Filter out unused results. - (value-slots (filter-map (lambda (val result) (and result val)) - value-slots result-slots)) - (result-slots (filter (lambda (x) x) result-slots)) - (live (compute-live-slots kargs))) - (parallel-move value-slots - result-slots - (compute-tmp-slot live value-slots)))))) - - (define (add-call-shuffles label k args shuffles) - (match (get-cont k) - (($ $ktail) - (let* ((live (compute-live-slots label)) - (tail-slots (integers 0 (length args))) - (moves (parallel-move (get-slots args) - tail-slots - (compute-tmp-slot live tail-slots)))) - (intmap-add! shuffles label moves))) - (($ $kreceive) - (let* ((live (compute-live-slots label)) - (proc-slot (get-proc-slot label)) - (call-slots (integers proc-slot (length args))) - (arg-moves (parallel-move (get-slots args) - call-slots - (compute-tmp-slot live call-slots)))) - (intmap-add! (intmap-add! shuffles label arg-moves) - k (compute-receive-shuffles k proc-slot)))))) - - (define (add-values-shuffles label k args shuffles) - (match (get-cont k) - (($ $ktail) - (let* ((live (compute-live-slots label)) - (src-slots (get-slots args)) - (dst-slots (integers 1 (length args))) - (moves (parallel-move src-slots dst-slots - (compute-tmp-slot live dst-slots)))) - (intmap-add! shuffles label moves))) - (($ $kargs _ dst-vars) - (let* ((live (logior (compute-live-slots label) - (compute-live-slots k))) - (src-slots (get-slots args)) - (dst-slots (get-slots dst-vars)) - (moves (parallel-move src-slots dst-slots - (compute-tmp-slot live '())))) - (intmap-add! shuffles label moves))))) - - (define (add-prompt-shuffles label k handler shuffles) - (intmap-add! shuffles handler - (compute-receive-shuffles handler (get-proc-slot label)))) - - (define (compute-shuffles label cont shuffles) - (match cont - (($ $kargs names vars ($ $continue k src exp)) - (match exp - (($ $call proc args) - (add-call-shuffles label k (cons proc args) shuffles)) - (($ $callk _ proc args) - (add-call-shuffles label k (cons proc args) shuffles)) - (($ $values args) - (add-values-shuffles label k args shuffles)) - (($ $prompt escape? tag handler) - (add-prompt-shuffles label k handler shuffles)) - (_ shuffles))) - (_ shuffles))) - - (persistent-intmap - (intmap-fold compute-shuffles cps empty-intmap))) - -(define (compute-frame-sizes cps slots call-allocs shuffles) - ;; Minimum frame has one slot: the closure. - (define minimum-frame-size 1) - (define (get-shuffles label) - (intmap-ref shuffles label)) - (define (get-proc-slot label) - (match (intmap-ref call-allocs label (lambda (_) #f)) - (#f 0) ;; Tail call. - (($ $call-alloc proc-slot) proc-slot))) - (define (max-size var size) - (match (intmap-ref slots var (lambda (_) #f)) - (#f size) - (slot (max size (1+ slot))))) - (define (max-size* vars size) - (fold max-size size vars)) - (define (shuffle-size moves size) - (match moves - (() size) - (((src . dst) . moves) - (shuffle-size moves (max size (1+ src) (1+ dst)))))) - (define (call-size label nargs size) - (shuffle-size (get-shuffles label) - (max (+ (get-proc-slot label) nargs) size))) - (define (measure-cont label cont frame-sizes clause size) - (match cont - (($ $kfun) - (values #f #f #f)) - (($ $kclause) - (let ((frame-sizes (if clause - (intmap-add! frame-sizes clause size) - empty-intmap))) - (values frame-sizes label minimum-frame-size))) - (($ $kargs names vars ($ $continue k src exp)) - (values frame-sizes clause - (let ((size (max-size* vars size))) - (match exp - (($ $call proc args) - (call-size label (1+ (length args)) size)) - (($ $callk _ proc args) - (call-size label (1+ (length args)) size)) - (($ $values args) - (shuffle-size (get-shuffles label) size)) - (_ size))))) - (($ $kreceive) - (values frame-sizes clause - (shuffle-size (get-shuffles label) size))) - (($ $ktail) - (values (intmap-add! frame-sizes clause size) #f #f)))) - - (persistent-intmap (intmap-fold measure-cont cps #f #f #f))) - -(define (allocate-args cps) - (intmap-fold (lambda (label cont slots) - (match cont - (($ $kfun src meta self) - (intmap-add! slots self 0)) - (($ $kclause arity body alt) - (match (intmap-ref cps body) - (($ $kargs names vars) - (let lp ((vars vars) (slots slots) (n 1)) - (match vars - (() slots) - ((var . vars) - (let ((n (if (<= 253 n 255) 256 n))) - (lp vars - (intmap-add! slots var n) - (1+ n))))))))) - (_ slots))) - cps empty-intmap)) - -(define-inlinable (add-live-slot slot live-slots) - (logior live-slots (ash 1 slot))) - -(define-inlinable (kill-dead-slot slot live-slots) - (logand live-slots (lognot (ash 1 slot)))) - -(define-inlinable (compute-slot live-slots hint) - ;; Slots 253-255 are reserved for shuffling; see comments in - ;; assembler.scm. - (if (and hint (not (logbit? hint live-slots)) - (or (< hint 253) (> hint 255))) - hint - (let ((slot (find-first-zero live-slots))) - (if (or (< slot 253) (> slot 255)) - slot - (+ 256 (find-first-zero (ash live-slots -256))))))) - -(define (allocate-lazy-vars cps slots call-allocs live-in lazy) - (define (compute-live-slots slots label) - (intset-fold (lambda (var live) - (match (intmap-ref slots var (lambda (_) #f)) - (#f live) - (slot (add-live-slot slot live)))) - (intmap-ref live-in label) - 0)) - - (define (allocate var hint slots live) - (match (and hint (intmap-ref slots var (lambda (_) #f))) - (#f (if (intset-ref lazy var) - (let ((slot (compute-slot live hint))) - (values (intmap-add! slots var slot) - (add-live-slot slot live))) - (values slots live))) - (slot (values slots (add-live-slot slot live))))) - - (define (allocate* vars hints slots live) - (match (vector vars hints) - (#(() ()) slots) - (#((var . vars) (hint . hints)) - (let-values (((slots live) (allocate var hint slots live))) - (allocate* vars hints slots live))))) - - (define (get-proc-slot label) - (match (intmap-ref call-allocs label (lambda (_) #f)) - (#f 0) - (call (call-alloc-proc-slot call)))) - - (define (allocate-call label args slots) - (allocate* args (integers (get-proc-slot label) (length args)) - slots (compute-live-slots slots label))) - - (define (allocate-values label k args slots) - (match (intmap-ref cps k) - (($ $ktail) - (allocate* args (integers 1 (length args)) - slots (compute-live-slots slots label))) - (($ $kargs names vars) - (allocate* args - (map (cut intmap-ref slots <> (lambda (_) #f)) vars) - slots (compute-live-slots slots label))))) - - (define (allocate-lazy label cont slots) - (match cont - (($ $kargs names vars ($ $continue k src exp)) - (match exp - (($ $call proc args) - (allocate-call label (cons proc args) slots)) - (($ $callk _ proc args) - (allocate-call label (cons proc args) slots)) - (($ $values args) - (allocate-values label k args slots)) - (_ slots))) - (_ - slots))) - - ;; Sweep right to left to visit uses before definitions. - (persistent-intmap - (intmap-fold-right allocate-lazy cps slots))) - -(define (allocate-slots cps) - (let*-values (((defs uses) (compute-defs-and-uses cps)) - ((live-in live-out) (compute-live-variables cps defs uses)) - ((constants) (compute-constant-values cps)) - ((needs-slot) (compute-needs-slot cps defs uses)) - ((lazy) (compute-lazy-vars cps live-in live-out defs - needs-slot))) - - (define (empty-live-slots) - #b0) - - (define (compute-call-proc-slot live-slots) - (+ 2 (find-first-trailing-zero live-slots))) - - (define (compute-prompt-handler-proc-slot live-slots) - (if (zero? live-slots) - 0 - (1- (find-first-trailing-zero live-slots)))) - - (define (get-cont label) - (intmap-ref cps label)) - - (define (get-slot slots var) - (intmap-ref slots var (lambda (_) #f))) - - (define (get-slots slots vars) - (let lp ((vars vars)) - (match vars - ((var . vars) (cons (get-slot slots var) (lp vars))) - (_ '())))) - - (define (compute-live-slots* slots label live-vars) - (intset-fold (lambda (var live) - (match (get-slot slots var) - (#f live) - (slot (add-live-slot slot live)))) - (intmap-ref live-vars label) - 0)) - - (define (compute-live-in-slots slots label) - (compute-live-slots* slots label live-in)) - - (define (compute-live-out-slots slots label) - (compute-live-slots* slots label live-out)) - - (define (allocate var hint slots live) - (cond - ((not (intset-ref needs-slot var)) - (values slots live)) - ((get-slot slots var) - => (lambda (slot) - (values slots (add-live-slot slot live)))) - ((and (not hint) (intset-ref lazy var)) - (values slots live)) - (else - (let ((slot (compute-slot live hint))) - (values (intmap-add! slots var slot) - (add-live-slot slot live)))))) - - (define (allocate* vars hints slots live) - (match (vector vars hints) - (#(() ()) (values slots live)) - (#((var . vars) (hint . hints)) - (call-with-values (lambda () (allocate var hint slots live)) - (lambda (slots live) - (allocate* vars hints slots live)))))) - - (define (allocate-defs label vars slots) - (let ((live (compute-live-in-slots slots label)) - (live-vars (intmap-ref live-in label))) - (let lp ((vars vars) (slots slots) (live live)) - (match vars - (() (values slots live)) - ((var . vars) - (call-with-values (lambda () (allocate var #f slots live)) - (lambda (slots live) - (lp vars slots - (let ((slot (get-slot slots var))) - (if (and slot (not (intset-ref live-vars var))) - (kill-dead-slot slot live) - live)))))))))) - - ;; PRE-LIVE are the live slots coming into the term. POST-LIVE - ;; is the subset of PRE-LIVE that is still live after the term - ;; uses its inputs. - (define (allocate-call label k args slots call-allocs pre-live) - (match (get-cont k) - (($ $ktail) - (let ((tail-slots (integers 0 (length args)))) - (values (allocate* args tail-slots slots pre-live) - call-allocs))) - (($ $kreceive arity kargs) - (let*-values - (((post-live) (compute-live-out-slots slots label)) - ((proc-slot) (compute-call-proc-slot post-live)) - ((call-slots) (integers proc-slot (length args))) - ((slots pre-live) (allocate* args call-slots slots pre-live)) - ;; Allow the first result to be hinted by its use, but - ;; hint the remaining results to stay in place. This - ;; strikes a balance between avoiding shuffling, - ;; especially for unused extra values, and avoiding frame - ;; size growth due to sparse locals. - ((slots result-live) - (match (get-cont kargs) - (($ $kargs () ()) - (values slots post-live)) - (($ $kargs (_ . _) (_ . results)) - (let ((result-slots (integers (+ proc-slot 2) - (length results)))) - (allocate* results result-slots slots post-live))))) - ((dead-slot-map) (logand (1- (ash 1 (- proc-slot 2))) - (lognot post-live))) - ((call) (make-call-alloc proc-slot dead-slot-map))) - (values slots - (intmap-add! call-allocs label call)))))) - - (define (allocate-values label k args slots call-allocs) - (match (get-cont k) - (($ $ktail) - (values slots call-allocs)) - (($ $kargs (_) (dst)) - ;; When there is only one value in play, we allow the dst to be - ;; hinted (see compute-lazy-vars). If the src doesn't have a - ;; slot, then the actual slot for the dst would end up being - ;; decided by the call that args it. Because we don't know the - ;; slot, we can't really compute the parallel moves in that - ;; case, so just bail and rely on the bytecode emitter to - ;; handle the one-value case specially. - (match args - ((src) - (let ((post-live (compute-live-out-slots slots label))) - (values (allocate dst (get-slot slots src) slots post-live) - call-allocs))))) - (($ $kargs _ dst-vars) - (let ((src-slots (get-slots slots args)) - (post-live (compute-live-out-slots slots label))) - (values (allocate* dst-vars src-slots slots post-live) - call-allocs))))) - - (define (allocate-prompt label k handler slots call-allocs) - (match (get-cont handler) - (($ $kreceive arity kargs) - (let*-values - (((handler-live) (compute-live-in-slots slots handler)) - ((proc-slot) (compute-prompt-handler-proc-slot handler-live)) - ((dead-slot-map) (logand (1- (ash 1 (- proc-slot 2))) - (lognot handler-live))) - ((result-vars) (match (get-cont kargs) - (($ $kargs names vars) vars))) - ((value-slots) (integers (1+ proc-slot) (length result-vars))) - ((slots result-live) (allocate* result-vars value-slots - slots handler-live))) - (values slots - (intmap-add! call-allocs label - (make-call-alloc proc-slot dead-slot-map))))))) - - (define (allocate-cont label cont slots call-allocs) - (match cont - (($ $kargs names vars ($ $continue k src exp)) - (let-values (((slots live) (allocate-defs label vars slots))) - (match exp - (($ $call proc args) - (allocate-call label k (cons proc args) slots call-allocs live)) - (($ $callk _ proc args) - (allocate-call label k (cons proc args) slots call-allocs live)) - (($ $values args) - (allocate-values label k args slots call-allocs)) - (($ $prompt escape? tag handler) - (allocate-prompt label k handler slots call-allocs)) - (_ - (values slots call-allocs))))) - (_ - (values slots call-allocs)))) - - (call-with-values (lambda () - (let ((slots (allocate-args cps))) - (intmap-fold allocate-cont cps slots empty-intmap))) - (lambda (slots calls) - (let* ((slots (allocate-lazy-vars cps slots calls live-in lazy)) - (shuffles (compute-shuffles cps slots calls live-in)) - (frame-sizes (compute-frame-sizes cps slots calls shuffles))) - (make-allocation slots constants calls shuffles frame-sizes)))))) diff --git a/module/language/cps2/spec.scm b/module/language/cps2/spec.scm deleted file mode 100644 index ac8f06439..000000000 --- a/module/language/cps2/spec.scm +++ /dev/null @@ -1,37 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Code: - -(define-module (language cps2 spec) - #:use-module (system base language) - #:use-module (language cps2) - #:use-module (language cps2 compile-bytecode) - #:export (cps2)) - -(define* (write-cps exp #:optional (port (current-output-port))) - (write (unparse-cps exp) port)) - -(define-language cps2 - #:title "CPS2 Intermediate Language" - #:reader (lambda (port env) (read port)) - #:printer write-cps - #:parser parse-cps - #:compilers `((bytecode . ,compile-bytecode)) - #:for-humans? #f - ) diff --git a/module/language/cps2/specialize-primcalls.scm b/module/language/cps2/specialize-primcalls.scm deleted file mode 100644 index 00d2149d7..000000000 --- a/module/language/cps2/specialize-primcalls.scm +++ /dev/null @@ -1,59 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; Some bytecode operations can encode an immediate as an operand. -;;; This pass tranforms generic primcalls to these specialized -;;; primcalls, if possible. -;;; -;;; Code: - -(define-module (language cps2 specialize-primcalls) - #:use-module (ice-9 match) - #:use-module (language cps2) - #:use-module (language cps2 utils) - #:use-module (language cps intmap) - #:export (specialize-primcalls)) - -(define (specialize-primcalls conts) - (let ((constants (compute-constant-values conts))) - (define (immediate-u8? var) - (let ((val (intmap-ref constants var (lambda (_) #f)))) - (and (exact-integer? val) (<= 0 val 255)))) - (define (specialize-primcall name args) - (match (cons name args) - (('make-vector (? immediate-u8? n) init) 'make-vector/immediate) - (('vector-ref v (? immediate-u8? n)) 'vector-ref/immediate) - (('vector-set! v (? immediate-u8? n) x) 'vector-set!/immediate) - (('allocate-struct v (? immediate-u8? n)) 'allocate-struct/immediate) - (('struct-ref s (? immediate-u8? n)) 'struct-ref/immediate) - (('struct-set! s (? immediate-u8? n) x) 'struct-set!/immediate) - (_ #f))) - (intmap-map - (lambda (label cont) - (match cont - (($ $kargs names vars ($ $continue k src ($ $primcall name args))) - (let ((name* (specialize-primcall name args))) - (if name* - (build-cont - ($kargs names vars - ($continue k src ($primcall name* args)))) - cont))) - (_ cont))) - conts))) diff --git a/module/language/cps2/split-rec.scm b/module/language/cps2/split-rec.scm deleted file mode 100644 index aeb1c6397..000000000 --- a/module/language/cps2/split-rec.scm +++ /dev/null @@ -1,174 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; Split functions bound in $rec expressions into strongly-connected -;;; components. The result will be that each $rec binds a -;;; strongly-connected component of mutually recursive functions. -;;; -;;; Code: - -(define-module (language cps2 split-rec) - #:use-module (ice-9 match) - #:use-module ((srfi srfi-1) #:select (fold)) - #:use-module (language cps2) - #:use-module (language cps2 utils) - #:use-module (language cps2 with-cps) - #:use-module (language cps intmap) - #:use-module (language cps intset) - #:export (split-rec)) - -(define (compute-free-vars conts kfun) - "Compute a FUN-LABEL->FREE-VAR... map describing all free variable -references." - (define (add-def var defs) (intset-add! defs var)) - (define (add-defs vars defs) - (match vars - (() defs) - ((var . vars) (add-defs vars (add-def var defs))))) - (define (add-use var uses) (intset-add! uses var)) - (define (add-uses vars uses) - (match vars - (() uses) - ((var . vars) (add-uses vars (add-use var uses))))) - (define (visit-nested-funs body) - (intset-fold - (lambda (label out) - (match (intmap-ref conts label) - (($ $kargs _ _ ($ $continue _ _ - ($ $fun kfun))) - (intmap-union out (visit-fun kfun))) - (($ $kargs _ _ ($ $continue _ _ - ($ $rec _ _ (($ $fun kfun) ...)))) - (fold (lambda (kfun out) - (intmap-union out (visit-fun kfun))) - out kfun)) - (_ out))) - body - empty-intmap)) - (define (visit-fun kfun) - (let* ((body (compute-function-body conts kfun)) - (free (visit-nested-funs body))) - (call-with-values - (lambda () - (intset-fold - (lambda (label defs uses) - (match (intmap-ref conts label) - (($ $kargs names vars ($ $continue k src exp)) - (values - (add-defs vars defs) - (match exp - ((or ($ $const) ($ $prim)) uses) - (($ $fun kfun) - (intset-union (persistent-intset uses) - (intmap-ref free kfun))) - (($ $rec names vars (($ $fun kfun) ...)) - (fold (lambda (kfun uses) - (intset-union (persistent-intset uses) - (intmap-ref free kfun))) - uses kfun)) - (($ $values args) - (add-uses args uses)) - (($ $call proc args) - (add-use proc (add-uses args uses))) - (($ $branch kt ($ $values (arg))) - (add-use arg uses)) - (($ $branch kt ($ $primcall name args)) - (add-uses args uses)) - (($ $primcall name args) - (add-uses args uses)) - (($ $prompt escape? tag handler) - (add-use tag uses))))) - (($ $kfun src meta self) - (values (add-def self defs) uses)) - (_ (values defs uses)))) - body empty-intset empty-intset)) - (lambda (defs uses) - (intmap-add free kfun (intset-subtract - (persistent-intset uses) - (persistent-intset defs))))))) - (visit-fun kfun)) - -(define (compute-split fns free-vars) - (define (get-free kfun) - ;; It's possible for a fun to have been skipped by - ;; compute-free-vars, if the fun isn't reachable. Fall back to - ;; empty-intset for the fun's free vars, in that case. - (intmap-ref free-vars kfun (lambda (_) empty-intset))) - (let* ((vars (intmap-keys fns)) - (edges (intmap-map - (lambda (var kfun) - (intset-intersect (get-free kfun) vars)) - fns))) - (compute-sorted-strongly-connected-components edges))) - -(define (intmap-acons k v map) - (intmap-add map k v)) - -(define (split-rec conts) - (let ((free (compute-free-vars conts 0))) - (with-fresh-name-state conts - (persistent-intmap - (intmap-fold - (lambda (label cont out) - (match cont - (($ $kargs cont-names cont-vars - ($ $continue k src ($ $rec names vars (($ $fun kfuns) ...)))) - (let ((fns (fold intmap-acons empty-intmap vars kfuns)) - (fn-names (fold intmap-acons empty-intmap vars names))) - (match (compute-split fns free) - (() - ;; Remove trivial $rec. - (with-cps out - (setk label ($kargs cont-names cont-vars - ($continue k src ($values ())))))) - ((_) - ;; Bound functions already form a strongly-connected - ;; component. - out) - (components - ;; Multiple components. Split them into separate $rec - ;; expressions. - (define (build-body out components) - (match components - (() - (match (intmap-ref out k) - (($ $kargs names vars term) - (with-cps (intmap-remove out k) - term)))) - ((vars . components) - (match (intset-fold - (lambda (var out) - (let ((name (intmap-ref fn-names var)) - (fun (build-exp - ($fun (intmap-ref fns var))))) - (cons (list name var fun) out))) - vars '()) - (((name var fun) ...) - (with-cps out - (let$ body (build-body components)) - (letk kbody ($kargs name var ,body)) - (build-term - ($continue kbody src ($rec name var fun))))))))) - (with-cps out - (let$ body (build-body components)) - (setk label ($kargs cont-names cont-vars ,body))))))) - (_ out))) - conts - conts))))) diff --git a/module/language/cps2/type-fold.scm b/module/language/cps2/type-fold.scm deleted file mode 100644 index d1bc1aaa3..000000000 --- a/module/language/cps2/type-fold.scm +++ /dev/null @@ -1,425 +0,0 @@ -;;; Abstract constant folding on CPS -;;; Copyright (C) 2014, 2015 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 License as -;;; published by the Free Software Foundation, either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; This library is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with this program. If not, see -;;; . - -;;; Commentary: -;;; -;;; This pass uses the abstract interpretation provided by type analysis -;;; to fold constant values and type predicates. It is most profitably -;;; run after CSE, to take advantage of scalar replacement. -;;; -;;; Code: - -(define-module (language cps2 type-fold) - #:use-module (ice-9 match) - #:use-module (language cps2) - #:use-module (language cps2 utils) - #:use-module (language cps2 renumber) - #:use-module (language cps2 types) - #:use-module (language cps2 with-cps) - #:use-module (language cps intmap) - #:use-module (language cps intset) - #:use-module (system base target) - #:export (type-fold)) - - - - -;; Branch folders. - -(define &scalar-types - (logior &exact-integer &flonum &char &unspecified &false &true &nil &null)) - -(define *branch-folders* (make-hash-table)) - -(define-syntax-rule (define-branch-folder name f) - (hashq-set! *branch-folders* 'name f)) - -(define-syntax-rule (define-branch-folder-alias to from) - (hashq-set! *branch-folders* 'to (hashq-ref *branch-folders* 'from))) - -(define-syntax-rule (define-unary-branch-folder (name arg min max) body ...) - (define-branch-folder name (lambda (arg min max) body ...))) - -(define-syntax-rule (define-binary-branch-folder (name arg0 min0 max0 - arg1 min1 max1) - body ...) - (define-branch-folder name (lambda (arg0 min0 max0 arg1 min1 max1) body ...))) - -(define-syntax-rule (define-unary-type-predicate-folder name &type) - (define-unary-branch-folder (name type min max) - (let ((type* (logand type &type))) - (cond - ((zero? type*) (values #t #f)) - ((eqv? type type*) (values #t #t)) - (else (values #f #f)))))) - -;; All the cases that are in compile-bytecode. -(define-unary-type-predicate-folder pair? &pair) -(define-unary-type-predicate-folder null? &null) -(define-unary-type-predicate-folder nil? &nil) -(define-unary-type-predicate-folder symbol? &symbol) -(define-unary-type-predicate-folder variable? &box) -(define-unary-type-predicate-folder vector? &vector) -(define-unary-type-predicate-folder struct? &struct) -(define-unary-type-predicate-folder string? &string) -(define-unary-type-predicate-folder number? &number) -(define-unary-type-predicate-folder char? &char) - -(define-binary-branch-folder (eq? type0 min0 max0 type1 min1 max1) - (cond - ((or (zero? (logand type0 type1)) (< max0 min1) (< max1 min0)) - (values #t #f)) - ((and (eqv? type0 type1) - (eqv? min0 min1 max0 max1) - (zero? (logand type0 (1- type0))) - (not (zero? (logand type0 &scalar-types)))) - (values #t #t)) - (else - (values #f #f)))) -(define-branch-folder-alias eqv? eq?) -(define-branch-folder-alias equal? eq?) - -(define (compare-ranges type0 min0 max0 type1 min1 max1) - (and (zero? (logand (logior type0 type1) (lognot &real))) - (cond ((< max0 min1) '<) - ((> min0 max1) '>) - ((= min0 max0 min1 max1) '=) - ((<= max0 min1) '<=) - ((>= min0 max1) '>=) - (else #f)))) - -(define-binary-branch-folder (< type0 min0 max0 type1 min1 max1) - (case (compare-ranges type0 min0 max0 type1 min1 max1) - ((<) (values #t #t)) - ((= >= >) (values #t #f)) - (else (values #f #f)))) - -(define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1) - (case (compare-ranges type0 min0 max0 type1 min1 max1) - ((< <= =) (values #t #t)) - ((>) (values #t #f)) - (else (values #f #f)))) - -(define-binary-branch-folder (= type0 min0 max0 type1 min1 max1) - (case (compare-ranges type0 min0 max0 type1 min1 max1) - ((=) (values #t #t)) - ((< >) (values #t #f)) - (else (values #f #f)))) - -(define-binary-branch-folder (>= type0 min0 max0 type1 min1 max1) - (case (compare-ranges type0 min0 max0 type1 min1 max1) - ((> >= =) (values #t #t)) - ((<) (values #t #f)) - (else (values #f #f)))) - -(define-binary-branch-folder (> type0 min0 max0 type1 min1 max1) - (case (compare-ranges type0 min0 max0 type1 min1 max1) - ((>) (values #t #t)) - ((= <= <) (values #t #f)) - (else (values #f #f)))) - -(define-binary-branch-folder (logtest type0 min0 max0 type1 min1 max1) - (define (logand-min a b) - (if (< a b 0) - (min a b) - 0)) - (define (logand-max a b) - (if (< a b 0) - 0 - (max a b))) - (if (and (= min0 max0) (= min1 max1) (eqv? type0 type1 &exact-integer)) - (values #t (logtest min0 min1)) - (values #f #f))) - - - - -;; Strength reduction. - -(define *primcall-reducers* (make-hash-table)) - -(define-syntax-rule (define-primcall-reducer name f) - (hashq-set! *primcall-reducers* 'name f)) - -(define-syntax-rule (define-unary-primcall-reducer (name cps k src - arg type min max) - body ...) - (define-primcall-reducer name - (lambda (cps k src arg type min max) - body ...))) - -(define-syntax-rule (define-binary-primcall-reducer (name cps k src - arg0 type0 min0 max0 - arg1 type1 min1 max1) - body ...) - (define-primcall-reducer name - (lambda (cps k src arg0 type0 min0 max0 arg1 type1 min1 max1) - body ...))) - -(define-binary-primcall-reducer (mul cps k src - arg0 type0 min0 max0 - arg1 type1 min1 max1) - (define (fail) (with-cps cps #f)) - (define (negate arg) - (with-cps cps - ($ (with-cps-constants ((zero 0)) - (build-term - ($continue k src ($primcall 'sub (zero arg)))))))) - (define (zero) - (with-cps cps - (build-term ($continue k src ($const 0))))) - (define (identity arg) - (with-cps cps - (build-term ($continue k src ($values (arg)))))) - (define (double arg) - (with-cps cps - (build-term ($continue k src ($primcall 'add (arg arg)))))) - (define (power-of-two constant arg) - (let ((n (let lp ((bits 0) (constant constant)) - (if (= constant 1) bits (lp (1+ bits) (ash constant -1)))))) - (with-cps cps - ($ (with-cps-constants ((bits n)) - (build-term ($continue k src ($primcall 'ash (arg bits))))))))) - (define (mul/constant constant constant-type arg arg-type) - (cond - ((not (or (= constant-type &exact-integer) (= constant-type arg-type))) - (fail)) - ((eqv? constant -1) - ;; (* arg -1) -> (- 0 arg) - (negate arg)) - ((eqv? constant 0) - ;; (* arg 0) -> 0 if arg is not a flonum or complex - (and (= constant-type &exact-integer) - (zero? (logand arg-type - (lognot (logior &flonum &complex)))) - (zero))) - ((eqv? constant 1) - ;; (* arg 1) -> arg - (identity arg)) - ((eqv? constant 2) - ;; (* arg 2) -> (+ arg arg) - (double arg)) - ((and (= constant-type arg-type &exact-integer) - (positive? constant) - (zero? (logand constant (1- constant)))) - ;; (* arg power-of-2) -> (ash arg (log2 power-of-2 - (power-of-two constant arg)) - (else - (fail)))) - (cond - ((logtest (logior type0 type1) (lognot &number)) (fail)) - ((= min0 max0) (mul/constant min0 type0 arg1 type1)) - ((= min1 max1) (mul/constant min1 type1 arg0 type0)) - (else (fail)))) - -(define-binary-primcall-reducer (logbit? cps k src - arg0 type0 min0 max0 - arg1 type1 min1 max1) - (define (convert-to-logtest cps kbool) - (define (compute-mask cps kmask src) - (if (eq? min0 max0) - (with-cps cps - (build-term - ($continue kmask src ($const (ash 1 min0))))) - (with-cps cps - ($ (with-cps-constants ((one 1)) - (build-term - ($continue kmask src ($primcall 'ash (one arg0))))))))) - (with-cps cps - (letv mask) - (letk kt ($kargs () () - ($continue kbool src ($const #t)))) - (letk kf ($kargs () () - ($continue kbool src ($const #f)))) - (letk kmask ($kargs (#f) (mask) - ($continue kf src - ($branch kt ($primcall 'logtest (mask arg1)))))) - ($ (compute-mask kmask src)))) - ;; Hairiness because we are converting from a primcall with unknown - ;; arity to a branching primcall. - (let ((positive-fixnum-bits (- (* (target-word-size) 8) 3))) - (if (and (= type0 &exact-integer) - (<= 0 min0 positive-fixnum-bits) - (<= 0 max0 positive-fixnum-bits)) - (match (intmap-ref cps k) - (($ $kreceive arity kargs) - (match arity - (($ $arity (_) () (not #f) () #f) - (with-cps cps - (letv bool) - (let$ body (with-cps-constants ((nil '())) - (build-term - ($continue kargs src ($values (bool nil)))))) - (letk kbool ($kargs (#f) (bool) ,body)) - ($ (convert-to-logtest kbool)))) - (_ - (with-cps cps - (letv bool) - (letk kbool ($kargs (#f) (bool) - ($continue k src ($primcall 'values (bool))))) - ($ (convert-to-logtest kbool)))))) - (($ $ktail) - (with-cps cps - (letv bool) - (letk kbool ($kargs (#f) (bool) - ($continue k src ($primcall 'return (bool))))) - ($ (convert-to-logtest kbool))))) - (with-cps cps #f)))) - - - - -;; - -(define (local-type-fold start end cps) - (define (scalar-value type val) - (cond - ((eqv? type &exact-integer) val) - ((eqv? type &flonum) (exact->inexact val)) - ((eqv? type &char) (integer->char val)) - ((eqv? type &unspecified) *unspecified*) - ((eqv? type &false) #f) - ((eqv? type &true) #t) - ((eqv? type &nil) #nil) - ((eqv? type &null) '()) - (else (error "unhandled type" type val)))) - (let ((types (infer-types cps start))) - (define (fold-primcall cps label names vars k src name args def) - (call-with-values (lambda () (lookup-post-type types label def 0)) - (lambda (type min max) - (and (not (zero? type)) - (zero? (logand type (1- type))) - (zero? (logand type (lognot &scalar-types))) - (eqv? min max) - (let ((val (scalar-value type min))) - ;; (pk 'folded src name args val) - (with-cps cps - (letv v*) - (letk k* ($kargs (#f) (v*) - ($continue k src ($const val)))) - ;; Rely on DCE to elide this expression, if - ;; possible. - (setk label - ($kargs names vars - ($continue k* src ($primcall name args)))))))))) - (define (reduce-primcall cps label names vars k src name args) - (and=> - (hashq-ref *primcall-reducers* name) - (lambda (reducer) - (match args - ((arg0) - (call-with-values (lambda () (lookup-pre-type types label arg0)) - (lambda (type0 min0 max0) - (call-with-values (lambda () - (reducer cps k src arg0 type0 min0 max0)) - (lambda (cps term) - (and term - (with-cps cps - (setk label ($kargs names vars ,term))))))))) - ((arg0 arg1) - (call-with-values (lambda () (lookup-pre-type types label arg0)) - (lambda (type0 min0 max0) - (call-with-values (lambda () (lookup-pre-type types label arg1)) - (lambda (type1 min1 max1) - (call-with-values (lambda () - (reducer cps k src arg0 type0 min0 max0 - arg1 type1 min1 max1)) - (lambda (cps term) - (and term - (with-cps cps - (setk label ($kargs names vars ,term))))))))))) - (_ #f))))) - (define (fold-unary-branch cps label names vars kf kt src name arg) - (and=> - (hashq-ref *branch-folders* name) - (lambda (folder) - (call-with-values (lambda () (lookup-pre-type types label arg)) - (lambda (type min max) - (call-with-values (lambda () (folder type min max)) - (lambda (f? v) - ;; (when f? (pk 'folded-unary-branch label name arg v)) - (and f? - (with-cps cps - (setk label - ($kargs names vars - ($continue (if v kt kf) src - ($values ()))))))))))))) - (define (fold-binary-branch cps label names vars kf kt src name arg0 arg1) - (and=> - (hashq-ref *branch-folders* name) - (lambda (folder) - (call-with-values (lambda () (lookup-pre-type types label arg0)) - (lambda (type0 min0 max0) - (call-with-values (lambda () (lookup-pre-type types label arg1)) - (lambda (type1 min1 max1) - (call-with-values (lambda () - (folder type0 min0 max0 type1 min1 max1)) - (lambda (f? v) - ;; (when f? (pk 'folded-binary-branch label name arg0 arg1 v)) - (and f? - (with-cps cps - (setk label - ($kargs names vars - ($continue (if v kt kf) src - ($values ()))))))))))))))) - (define (visit-expression cps label names vars k src exp) - (match exp - (($ $primcall name args) - ;; We might be able to fold primcalls that define a value. - (match (intmap-ref cps k) - (($ $kargs (_) (def)) - (or (fold-primcall cps label names vars k src name args def) - (reduce-primcall cps label names vars k src name args) - cps)) - (_ - (or (reduce-primcall cps label names vars k src name args) - cps)))) - (($ $branch kt ($ $primcall name args)) - ;; We might be able to fold primcalls that branch. - (match args - ((x) - (or (fold-unary-branch cps label names vars k kt src name x) - cps)) - ((x y) - (or (fold-binary-branch cps label names vars k kt src name x y) - cps)))) - (_ cps))) - (let lp ((label start) (cps cps)) - (if (<= label end) - (lp (1+ label) - (match (intmap-ref cps label) - (($ $kargs names vars ($ $continue k src exp)) - (visit-expression cps label names vars k src exp)) - (_ cps))) - cps)))) - -(define (fold-functions-in-renumbered-program f conts seed) - (let* ((conts (persistent-intmap conts)) - (end (1+ (intmap-prev conts)))) - (let lp ((label 0) (seed seed)) - (if (eqv? label end) - seed - (match (intmap-ref conts label) - (($ $kfun src meta self tail clause) - (lp (1+ tail) (f label tail seed)))))))) - -(define (type-fold conts) - ;; Type analysis wants a program whose labels are sorted. - (let ((conts (renumber conts))) - (with-fresh-name-state conts - (persistent-intmap - (fold-functions-in-renumbered-program local-type-fold conts conts))))) diff --git a/module/language/cps2/types.scm b/module/language/cps2/types.scm deleted file mode 100644 index 07da3d6a0..000000000 --- a/module/language/cps2/types.scm +++ /dev/null @@ -1,1408 +0,0 @@ -;;; Type analysis on CPS -;;; Copyright (C) 2014, 2015 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 License as -;;; published by the Free Software Foundation, either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; This library is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with this program. If not, see -;;; . - -;;; Commentary: -;;; -;;; Type analysis computes the possible types and ranges that values may -;;; have at all program positions. This analysis can help to prove that -;;; a primcall has no side-effects, if its arguments have the -;;; appropriate type and range. It can also enable constant folding of -;;; type predicates and, in the future, enable the compiler to choose -;;; untagged, unboxed representations for numbers. -;;; -;;; For the purposes of this analysis, a "type" is an aspect of a value -;;; that will not change. Guile's CPS intermediate language does not -;;; carry manifest type information that asserts properties about given -;;; values; instead, we recover this information via flow analysis, -;;; garnering properties from type predicates, constant literals, -;;; primcall results, and primcalls that assert that their arguments are -;;; of particular types. -;;; -;;; A range denotes a subset of the set of values in a type, bounded by -;;; a minimum and a maximum. The precise meaning of a range depends on -;;; the type. For real numbers, the range indicates an inclusive lower -;;; and upper bound on the integer value of a type. For vectors, the -;;; range indicates the length of the vector. The range is limited to a -;;; signed 32-bit value, with the smallest and largest values indicating -;;; -inf.0 and +inf.0, respectively. For some types, like pairs, the -;;; concept of "range" makes no sense. In these cases we consider the -;;; range to be -inf.0 to +inf.0. -;;; -;;; Types are represented as a bitfield. Fewer bits means a more precise -;;; type. Although normally only values that have a single type will -;;; have an associated range, this is not enforced. The range applies -;;; to all types in the bitfield. When control flow meets, the types and -;;; ranges meet with the union operator. -;;; -;;; It is not practical to precisely compute value ranges in all cases. -;;; For example, in the following case: -;;; -;;; (let lp ((n 0)) (when (foo) (lp (1+ n)))) -;;; -;;; The first time that range analysis visits the program, N is -;;; determined to be the exact integer 0. The second time, it is an -;;; exact integer in the range [0, 1]; the third, [0, 2]; and so on. -;;; This analysis will terminate, but only after the positive half of -;;; the 32-bit range has been fully explored and we decide that the -;;; range of N is [0, +inf.0]. At the same time, we want to do range -;;; analysis and type analysis at the same time, as there are -;;; interactions between them, notably in the case of `sqrt' which -;;; returns a complex number if its argument cannot be proven to be -;;; non-negative. So what we do instead is to precisely propagate types -;;; and ranges when propagating forward, but after the first backwards -;;; branch is seen, we cause backward branches that would expand the -;;; range of a value to saturate that range towards positive or negative -;;; infinity (as appropriate). -;;; -;;; A naive approach to type analysis would build up a table that has -;;; entries for all variables at all program points, but this has -;;; N-squared complexity and quickly grows unmanageable. Instead, we -;;; use _intmaps_ from (language cps intmap) to share state between -;;; connected program points. -;;; -;;; Code: - -(define-module (language cps2 types) - #:use-module (ice-9 match) - #:use-module (language cps2) - #:use-module (language cps2 utils) - #:use-module (language cps intmap) - #:use-module (language cps intset) - #:use-module (rnrs bytevectors) - #:use-module (srfi srfi-11) - #:export (;; Specific types. - &exact-integer - &flonum - &complex - &fraction - - &char - &unspecified - &unbound - &false - &true - &nil - &null - &symbol - &keyword - - &procedure - - &pointer - &fluid - &pair - &vector - &box - &struct - &string - &bytevector - &bitvector - &array - &hash-table - - ;; Union types. - &number &real - - infer-types - lookup-pre-type - lookup-post-type - primcall-types-check?)) - -(define-syntax define-flags - (lambda (x) - (syntax-case x () - ((_ all shift name ...) - (let ((count (length #'(name ...)))) - (with-syntax (((n ...) (iota count)) - (count count)) - #'(begin - (define-syntax name (identifier-syntax (ash 1 n))) - ... - (define-syntax all (identifier-syntax (1- (ash 1 count)))) - (define-syntax shift (identifier-syntax count))))))))) - -;; More precise types have fewer bits. -(define-flags &all-types &type-bits - &exact-integer - &flonum - &complex - &fraction - - &char - &unspecified - &unbound - &false - &true - &nil - &null - &symbol - &keyword - - &procedure - - &pointer - &fluid - &pair - &vector - &box - &struct - &string - &bytevector - &bitvector - &array - &hash-table) - -(define-syntax &no-type (identifier-syntax 0)) - -(define-syntax &number - (identifier-syntax (logior &exact-integer &flonum &complex &fraction))) -(define-syntax &real - (identifier-syntax (logior &exact-integer &flonum &fraction))) - -(define-syntax *max-s32* (identifier-syntax (- (ash 1 31) 1))) -(define-syntax *min-s32* (identifier-syntax (- 0 (ash 1 31)))) - -;; Versions of min and max that do not coerce exact numbers to become -;; inexact. -(define min - (case-lambda - ((a b) (if (< a b) a b)) - ((a b c) (min (min a b) c)) - ((a b c d) (min (min a b) c d)))) -(define max - (case-lambda - ((a b) (if (> a b) a b)) - ((a b c) (max (max a b) c)) - ((a b c d) (max (max a b) c d)))) - - - -(define-syntax-rule (define-compile-time-value name val) - (define-syntax name - (make-variable-transformer - (lambda (x) - (syntax-case x (set!) - (var (identifier? #'var) - (datum->syntax #'var val))))))) - -(define-compile-time-value min-fixnum most-negative-fixnum) -(define-compile-time-value max-fixnum most-positive-fixnum) - -(define-inlinable (make-unclamped-type-entry type min max) - (vector type min max)) -(define-inlinable (type-entry-type tentry) - (vector-ref tentry 0)) -(define-inlinable (type-entry-clamped-min tentry) - (vector-ref tentry 1)) -(define-inlinable (type-entry-clamped-max tentry) - (vector-ref tentry 2)) - -(define-syntax-rule (clamp-range val) - (cond - ((< val min-fixnum) min-fixnum) - ((< max-fixnum val) max-fixnum) - (else val))) - -(define-inlinable (make-type-entry type min max) - (vector type (clamp-range min) (clamp-range max))) -(define-inlinable (type-entry-min tentry) - (let ((min (type-entry-clamped-min tentry))) - (if (eq? min min-fixnum) -inf.0 min))) -(define-inlinable (type-entry-max tentry) - (let ((max (type-entry-clamped-max tentry))) - (if (eq? max max-fixnum) +inf.0 max))) - -(define all-types-entry (make-type-entry &all-types -inf.0 +inf.0)) - -(define* (var-type-entry typeset var #:optional (default all-types-entry)) - (intmap-ref typeset var (lambda (_) default))) - -(define (var-type typeset var) - (type-entry-type (var-type-entry typeset var))) -(define (var-min typeset var) - (type-entry-min (var-type-entry typeset var))) -(define (var-max typeset var) - (type-entry-max (var-type-entry typeset var))) - -;; Is the type entry A contained entirely within B? -(define (type-entry<=? a b) - (match (cons a b) - ((#(a-type a-min a-max) . #(b-type b-min b-max)) - (and (eqv? b-type (logior a-type b-type)) - (<= b-min a-min) - (>= b-max a-max))))) - -(define (type-entry-union a b) - (cond - ((type-entry<=? b a) a) - ((type-entry<=? a b) b) - (else (make-type-entry - (logior (type-entry-type a) (type-entry-type b)) - (min (type-entry-clamped-min a) (type-entry-clamped-min b)) - (max (type-entry-clamped-max a) (type-entry-clamped-max b)))))) - -(define (type-entry-saturating-union a b) - (cond - ((type-entry<=? b a) a) - (else - (make-type-entry - (logior (type-entry-type a) (type-entry-type b)) - (let ((a-min (type-entry-clamped-min a)) - (b-min (type-entry-clamped-min b))) - (if (< b-min a-min) min-fixnum a-min)) - (let ((a-max (type-entry-clamped-max a)) - (b-max (type-entry-clamped-max b))) - (if (> b-max a-max) max-fixnum a-max)))))) - -(define (type-entry-intersection a b) - (cond - ((type-entry<=? a b) a) - ((type-entry<=? b a) b) - (else (make-type-entry - (logand (type-entry-type a) (type-entry-type b)) - (max (type-entry-clamped-min a) (type-entry-clamped-min b)) - (min (type-entry-clamped-max a) (type-entry-clamped-max b)))))) - -(define (adjoin-var typeset var entry) - (intmap-add typeset var entry type-entry-union)) - -(define (restrict-var typeset var entry) - (intmap-add typeset var entry type-entry-intersection)) - -(define (constant-type val) - "Compute the type and range of VAL. Return three values: the type, -minimum, and maximum." - (define (return type val) - (if val - (make-type-entry type val val) - (make-type-entry type -inf.0 +inf.0))) - (cond - ((number? val) - (cond - ((exact-integer? val) (return &exact-integer val)) - ((eqv? (imag-part val) 0) - (if (nan? val) - (make-type-entry &flonum -inf.0 +inf.0) - (make-type-entry - (if (exact? val) &fraction &flonum) - (if (rational? val) (inexact->exact (floor val)) val) - (if (rational? val) (inexact->exact (ceiling val)) val)))) - (else (return &complex #f)))) - ((eq? val '()) (return &null #f)) - ((eq? val #nil) (return &nil #f)) - ((eq? val #t) (return &true #f)) - ((eq? val #f) (return &false #f)) - ((char? val) (return &char (char->integer val))) - ((eqv? val *unspecified*) (return &unspecified #f)) - ((symbol? val) (return &symbol #f)) - ((keyword? val) (return &keyword #f)) - ((pair? val) (return &pair #f)) - ((vector? val) (return &vector (vector-length val))) - ((string? val) (return &string (string-length val))) - ((bytevector? val) (return &bytevector (bytevector-length val))) - ((bitvector? val) (return &bitvector (bitvector-length val))) - ((array? val) (return &array (array-rank val))) - ((not (variable-bound? (make-variable val))) (return &unbound #f)) - - (else (error "unhandled constant" val)))) - -(define *type-checkers* (make-hash-table)) -(define *type-inferrers* (make-hash-table)) - -(define-syntax-rule (define-type-helper name) - (define-syntax-parameter name - (lambda (stx) - (syntax-violation 'name - "macro used outside of define-type" - stx)))) -(define-type-helper define!) -(define-type-helper restrict!) -(define-type-helper &type) -(define-type-helper &min) -(define-type-helper &max) - -(define-syntax-rule (define-type-checker (name arg ...) body ...) - (hashq-set! - *type-checkers* - 'name - (lambda (typeset arg ...) - (syntax-parameterize - ((&type (syntax-rules () ((_ val) (var-type typeset val)))) - (&min (syntax-rules () ((_ val) (var-min typeset val)))) - (&max (syntax-rules () ((_ val) (var-max typeset val))))) - body ...)))) - -(define-syntax-rule (check-type arg type min max) - ;; If the arg is negative, it is a closure variable. - (and (>= arg 0) - (zero? (logand (lognot type) (&type arg))) - (<= min (&min arg)) - (<= (&max arg) max))) - -(define-syntax-rule (define-type-inferrer* (name succ var ...) body ...) - (hashq-set! - *type-inferrers* - 'name - (lambda (in succ var ...) - (let ((out in)) - (syntax-parameterize - ((define! - (syntax-rules () - ((_ val type min max) - (set! out (adjoin-var out val - (make-type-entry type min max)))))) - (restrict! - (syntax-rules () - ((_ val type min max) - (set! out (restrict-var out val - (make-type-entry type min max)))))) - (&type (syntax-rules () ((_ val) (var-type in val)))) - (&min (syntax-rules () ((_ val) (var-min in val)))) - (&max (syntax-rules () ((_ val) (var-max in val))))) - body ... - out))))) - -(define-syntax-rule (define-type-inferrer (name arg ...) body ...) - (define-type-inferrer* (name succ arg ...) body ...)) - -(define-syntax-rule (define-predicate-inferrer (name arg ... true?) body ...) - (define-type-inferrer* (name succ arg ...) - (let ((true? (not (zero? succ)))) - body ...))) - -(define-syntax define-simple-type-checker - (lambda (x) - (define (parse-spec l) - (syntax-case l () - (() '()) - (((type min max) . l) (cons #'(type min max) (parse-spec #'l))) - (((type min+max) . l) (cons #'(type min+max min+max) (parse-spec #'l))) - ((type . l) (cons #'(type -inf.0 +inf.0) (parse-spec #'l))))) - (syntax-case x () - ((_ (name arg-spec ...) result-spec ...) - (with-syntax - (((arg ...) (generate-temporaries #'(arg-spec ...))) - (((arg-type arg-min arg-max) ...) (parse-spec #'(arg-spec ...)))) - #'(define-type-checker (name arg ...) - (and (check-type arg arg-type arg-min arg-max) - ...))))))) - -(define-syntax define-simple-type-inferrer - (lambda (x) - (define (parse-spec l) - (syntax-case l () - (() '()) - (((type min max) . l) (cons #'(type min max) (parse-spec #'l))) - (((type min+max) . l) (cons #'(type min+max min+max) (parse-spec #'l))) - ((type . l) (cons #'(type -inf.0 +inf.0) (parse-spec #'l))))) - (syntax-case x () - ((_ (name arg-spec ...) result-spec ...) - (with-syntax - (((arg ...) (generate-temporaries #'(arg-spec ...))) - (((arg-type arg-min arg-max) ...) (parse-spec #'(arg-spec ...))) - ((res ...) (generate-temporaries #'(result-spec ...))) - (((res-type res-min res-max) ...) (parse-spec #'(result-spec ...)))) - #'(define-type-inferrer (name arg ... res ...) - (restrict! arg arg-type arg-min arg-max) - ... - (define! res res-type res-min res-max) - ...)))))) - -(define-syntax-rule (define-simple-type (name arg-spec ...) result-spec ...) - (begin - (define-simple-type-checker (name arg-spec ...)) - (define-simple-type-inferrer (name arg-spec ...) result-spec ...))) - -(define-syntax-rule (define-simple-types - ((name arg-spec ...) result-spec ...) - ...) - (begin - (define-simple-type (name arg-spec ...) result-spec ...) - ...)) - -(define-syntax-rule (define-type-checker-aliases orig alias ...) - (let ((check (hashq-ref *type-checkers* 'orig))) - (hashq-set! *type-checkers* 'alias check) - ...)) -(define-syntax-rule (define-type-inferrer-aliases orig alias ...) - (let ((check (hashq-ref *type-inferrers* 'orig))) - (hashq-set! *type-inferrers* 'alias check) - ...)) -(define-syntax-rule (define-type-aliases orig alias ...) - (begin - (define-type-checker-aliases orig alias ...) - (define-type-inferrer-aliases orig alias ...))) - - - - -;;; This list of primcall type definitions follows the order of -;;; effects-analysis.scm; please keep it in a similar order. -;;; -;;; There is no need to add checker definitions for expressions that do -;;; not exhibit the &type-check effect, as callers should not ask if -;;; such an expression does or does not type-check. For those that do -;;; exhibit &type-check, you should define a type inferrer unless the -;;; primcall will never typecheck. -;;; -;;; Likewise there is no need to define inferrers for primcalls which -;;; return &all-types values and which never raise exceptions from which -;;; we can infer the types of incoming values. - - - - -;;; -;;; Generic effect-free predicates. -;;; - -(define-predicate-inferrer (eq? a b true?) - ;; We can only propagate information down the true leg. - (when true? - (let ((type (logand (&type a) (&type b))) - (min (max (&min a) (&min b))) - (max (min (&max a) (&max b)))) - (restrict! a type min max) - (restrict! b type min max)))) -(define-type-inferrer-aliases eq? eqv? equal?) - -(define-syntax-rule (define-simple-predicate-inferrer predicate type) - (define-predicate-inferrer (predicate val true?) - (let ((type (if true? - type - (logand (&type val) (lognot type))))) - (restrict! val type -inf.0 +inf.0)))) -(define-simple-predicate-inferrer pair? &pair) -(define-simple-predicate-inferrer null? &null) -(define-simple-predicate-inferrer nil? &nil) -(define-simple-predicate-inferrer symbol? &symbol) -(define-simple-predicate-inferrer variable? &box) -(define-simple-predicate-inferrer vector? &vector) -(define-simple-predicate-inferrer struct? &struct) -(define-simple-predicate-inferrer string? &string) -(define-simple-predicate-inferrer bytevector? &bytevector) -(define-simple-predicate-inferrer bitvector? &bitvector) -(define-simple-predicate-inferrer keyword? &keyword) -(define-simple-predicate-inferrer number? &number) -(define-simple-predicate-inferrer char? &char) -(define-simple-predicate-inferrer procedure? &procedure) -(define-simple-predicate-inferrer thunk? &procedure) - - - -;;; -;;; Fluids. Note that we can't track bound-ness of fluids, as pop-fluid -;;; can change boundness. -;;; - -(define-simple-types - ((fluid-ref (&fluid 1)) &all-types) - ((fluid-set! (&fluid 0 1) &all-types)) - ((push-fluid (&fluid 0 1) &all-types)) - ((pop-fluid))) - - - - -;;; -;;; Prompts. (Nothing to do.) -;;; - - - - -;;; -;;; Pairs. -;;; - -(define-simple-types - ((cons &all-types &all-types) &pair) - ((car &pair) &all-types) - ((set-car! &pair &all-types)) - ((cdr &pair) &all-types) - ((set-cdr! &pair &all-types))) - - - - -;;; -;;; Variables. -;;; - -(define-simple-types - ((box &all-types) (&box 1)) - ((box-ref (&box 1)) &all-types)) - -(define-simple-type-checker (box-set! (&box 0 1) &all-types)) -(define-type-inferrer (box-set! box val) - (restrict! box &box 1 1)) - - - - -;;; -;;; Vectors. -;;; - -;; This max-vector-len computation is a hack. -(define *max-vector-len* (ash most-positive-fixnum -5)) - -(define-simple-type-checker (make-vector (&exact-integer 0 *max-vector-len*) - &all-types)) -(define-type-inferrer (make-vector size init result) - (restrict! size &exact-integer 0 *max-vector-len*) - (define! result &vector (max (&min size) 0) (&max size))) - -(define-type-checker (vector-ref v idx) - (and (check-type v &vector 0 *max-vector-len*) - (check-type idx &exact-integer 0 (1- (&min v))))) -(define-type-inferrer (vector-ref v idx result) - (restrict! v &vector (1+ (&min idx)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max v))) - (define! result &all-types -inf.0 +inf.0)) - -(define-type-checker (vector-set! v idx val) - (and (check-type v &vector 0 *max-vector-len*) - (check-type idx &exact-integer 0 (1- (&min v))))) -(define-type-inferrer (vector-set! v idx val) - (restrict! v &vector (1+ (&min idx)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max v)))) - -(define-type-aliases make-vector make-vector/immediate) -(define-type-aliases vector-ref vector-ref/immediate) -(define-type-aliases vector-set! vector-set!/immediate) - -(define-simple-type-checker (vector-length &vector)) -(define-type-inferrer (vector-length v result) - (restrict! v &vector 0 *max-vector-len*) - (define! result &exact-integer (max (&min v) 0) - (min (&max v) *max-vector-len*))) - - - - -;;; -;;; Structs. -;;; - -;; No type-checker for allocate-struct, as we can't currently check that -;; vt is actually a vtable. -(define-type-inferrer (allocate-struct vt size result) - (restrict! vt &struct vtable-offset-user +inf.0) - (restrict! size &exact-integer 0 +inf.0) - (define! result &struct (max (&min size) 0) (&max size))) - -(define-type-checker (struct-ref s idx) - (and (check-type s &struct 0 +inf.0) - (check-type idx &exact-integer 0 +inf.0) - ;; FIXME: is the field readable? - (< (&max idx) (&min s)))) -(define-type-inferrer (struct-ref s idx result) - (restrict! s &struct (1+ (&min idx)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max s))) - (define! result &all-types -inf.0 +inf.0)) - -(define-type-checker (struct-set! s idx val) - (and (check-type s &struct 0 +inf.0) - (check-type idx &exact-integer 0 +inf.0) - ;; FIXME: is the field writable? - (< (&max idx) (&min s)))) -(define-type-inferrer (struct-set! s idx val) - (restrict! s &struct (1+ (&min idx)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max s)))) - -(define-type-aliases allocate-struct allocate-struct/immediate) -(define-type-aliases struct-ref struct-ref/immediate) -(define-type-aliases struct-set! struct-set!/immediate) - -(define-simple-type (struct-vtable (&struct 0 +inf.0)) - (&struct vtable-offset-user +inf.0)) - - - - -;;; -;;; Strings. -;;; - -(define *max-char* (1- (ash 1 24))) - -(define-type-checker (string-ref s idx) - (and (check-type s &string 0 +inf.0) - (check-type idx &exact-integer 0 +inf.0) - (< (&max idx) (&min s)))) -(define-type-inferrer (string-ref s idx result) - (restrict! s &string (1+ (&min idx)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max s))) - (define! result &char 0 *max-char*)) - -(define-type-checker (string-set! s idx val) - (and (check-type s &string 0 +inf.0) - (check-type idx &exact-integer 0 +inf.0) - (check-type val &char 0 *max-char*) - (< (&max idx) (&min s)))) -(define-type-inferrer (string-set! s idx val) - (restrict! s &string (1+ (&min idx)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max s))) - (restrict! val &char 0 *max-char*)) - -(define-simple-type-checker (string-length &string)) -(define-type-inferrer (string-length s result) - (restrict! s &string 0 +inf.0) - (define! result &exact-integer (max (&min s) 0) (&max s))) - -(define-simple-type (number->string &number) (&string 0 +inf.0)) -(define-simple-type (string->number (&string 0 +inf.0)) - ((logior &number &false) -inf.0 +inf.0)) - - - - -;;; -;;; Bytevectors. -;;; - -(define-simple-type-checker (bytevector-length &bytevector)) -(define-type-inferrer (bytevector-length bv result) - (restrict! bv &bytevector 0 +inf.0) - (define! result &exact-integer (max (&min bv) 0) (&max bv))) - -(define-syntax-rule (define-bytevector-accessors ref set type size min max) - (begin - (define-type-checker (ref bv idx) - (and (check-type bv &bytevector 0 +inf.0) - (check-type idx &exact-integer 0 +inf.0) - (< (&max idx) (- (&min bv) size)))) - (define-type-inferrer (ref bv idx result) - (restrict! bv &bytevector (+ (&min idx) size) +inf.0) - (restrict! idx &exact-integer 0 (- (&max bv) size)) - (define! result type min max)) - (define-type-checker (set bv idx val) - (and (check-type bv &bytevector 0 +inf.0) - (check-type idx &exact-integer 0 +inf.0) - (check-type val type min max) - (< (&max idx) (- (&min bv) size)))) - (define-type-inferrer (set! bv idx val) - (restrict! bv &bytevector (+ (&min idx) size) +inf.0) - (restrict! idx &exact-integer 0 (- (&max bv) size)) - (restrict! val type min max)))) - -(define-syntax-rule (define-short-bytevector-accessors ref set size signed?) - (define-bytevector-accessors ref set &exact-integer size - (if signed? (- (ash 1 (1- (* size 8)))) 0) - (1- (ash 1 (if signed? (1- (* size 8)) (* size 8)))))) - -(define-short-bytevector-accessors bv-u8-ref bv-u8-set! 1 #f) -(define-short-bytevector-accessors bv-s8-ref bv-s8-set! 1 #t) -(define-short-bytevector-accessors bv-u16-ref bv-u16-set! 2 #f) -(define-short-bytevector-accessors bv-s16-ref bv-s16-set! 2 #t) - -;; The range analysis only works on signed 32-bit values, so some limits -;; are out of range. -(define-bytevector-accessors bv-u32-ref bv-u32-set! &exact-integer 4 0 +inf.0) -(define-bytevector-accessors bv-s32-ref bv-s32-set! &exact-integer 4 -inf.0 +inf.0) -(define-bytevector-accessors bv-u64-ref bv-u64-set! &exact-integer 8 0 +inf.0) -(define-bytevector-accessors bv-s64-ref bv-s64-set! &exact-integer 8 -inf.0 +inf.0) -(define-bytevector-accessors bv-f32-ref bv-f32-set! &real 4 -inf.0 +inf.0) -(define-bytevector-accessors bv-f64-ref bv-f64-set! &real 8 -inf.0 +inf.0) - - - - -;;; -;;; Numbers. -;;; - -;; First, branching primitives with no results. -(define-simple-type-checker (= &number &number)) -(define-predicate-inferrer (= a b true?) - (when (and true? - (zero? (logand (logior (&type a) (&type b)) (lognot &number)))) - (let ((min (max (&min a) (&min b))) - (max (min (&max a) (&max b)))) - (restrict! a &number min max) - (restrict! b &number min max)))) - -(define (restricted-comparison-ranges op type0 min0 max0 type1 min1 max1) - (define (infer-integer-ranges) - (match op - ('< (values min0 (min max0 (1- max1)) (max (1+ min0) min1) max1)) - ('<= (values min0 (min max0 max1) (max min0 min1) max1)) - ('>= (values (max min0 min1) max0 min1 (min max0 max1))) - ('> (values (max min0 (1+ min1)) max0 min1 (min (1- max0) max1))))) - (define (infer-real-ranges) - (match op - ((or '< '<=) (values min0 (min max0 max1) (max min0 min1) max1)) - ((or '> '>=) (values (max min0 min1) max0 min1 (min max0 max1))))) - (if (= (logior type0 type1) &exact-integer) - (infer-integer-ranges) - (infer-real-ranges))) - -(define-syntax-rule (define-comparison-inferrer (op inverse)) - (define-predicate-inferrer (op a b true?) - (when (zero? (logand (logior (&type a) (&type b)) (lognot &number))) - (call-with-values - (lambda () - (restricted-comparison-ranges (if true? 'op 'inverse) - (&type a) (&min a) (&max a) - (&type b) (&min b) (&max b))) - (lambda (min0 max0 min1 max1) - (restrict! a &real min0 max0) - (restrict! b &real min1 max1)))))) - -(define-simple-type-checker (< &real &real)) -(define-comparison-inferrer (< >=)) - -(define-simple-type-checker (<= &real &real)) -(define-comparison-inferrer (<= >)) - -(define-simple-type-checker (>= &real &real)) -(define-comparison-inferrer (>= <)) - -(define-simple-type-checker (> &real &real)) -(define-comparison-inferrer (> <=)) - -;; Arithmetic. -(define-syntax-rule (define-unary-result! a result min max) - (let ((min* min) - (max* max) - (type (logand (&type a) &number))) - (cond - ((not (= type (&type a))) - ;; Not a number. Punt and do nothing. - (define! result &all-types -inf.0 +inf.0)) - ;; Complex numbers don't have a range. - ((eqv? type &complex) - (define! result &complex -inf.0 +inf.0)) - (else - (define! result type min* max*))))) - -(define-syntax-rule (define-binary-result! a b result closed? min max) - (let ((min* min) - (max* max) - (a-type (logand (&type a) &number)) - (b-type (logand (&type b) &number))) - (cond - ((or (not (= a-type (&type a))) (not (= b-type (&type b)))) - ;; One input not a number. Perhaps we end up dispatching to - ;; GOOPS. - (define! result &all-types -inf.0 +inf.0)) - ;; Complex and floating-point numbers are contagious. - ((or (eqv? a-type &complex) (eqv? b-type &complex)) - (define! result &complex -inf.0 +inf.0)) - ((or (eqv? a-type &flonum) (eqv? b-type &flonum)) - (define! result &flonum min* max*)) - ;; Exact integers are closed under some operations. - ((and closed? (eqv? a-type &exact-integer) (eqv? b-type &exact-integer)) - (define! result &exact-integer min* max*)) - (else - ;; Fractions may become integers. - (let ((type (logior a-type b-type))) - (define! result - (if (zero? (logand type &fraction)) - type - (logior type &exact-integer)) - min* max*)))))) - -(define-simple-type-checker (add &number &number)) -(define-type-inferrer (add a b result) - (define-binary-result! a b result #t - (+ (&min a) (&min b)) - (+ (&max a) (&max b)))) - -(define-simple-type-checker (sub &number &number)) -(define-type-inferrer (sub a b result) - (define-binary-result! a b result #t - (- (&min a) (&max b)) - (- (&max a) (&min b)))) - -(define-simple-type-checker (mul &number &number)) -(define-type-inferrer (mul a b result) - (let ((min-a (&min a)) (max-a (&max a)) - (min-b (&min b)) (max-b (&max b)) - ;; We only really get +inf.0 at runtime for flonums and - ;; compnums. If we have inferred that the arguments are not - ;; flonums and not compnums, then the result of (* +inf.0 0) at - ;; range inference time is 0 and not +nan.0. - (nan-impossible? (not (logtest (logior (&type a) (&type b)) - (logior &flonum &complex))))) - (define (nan* a b) - (if (and (or (and (inf? a) (zero? b)) - (and (zero? a) (inf? b))) - nan-impossible?) - 0 - (* a b))) - (let ((-- (nan* min-a min-b)) - (-+ (nan* min-a max-b)) - (++ (nan* max-a max-b)) - (+- (nan* max-a min-b))) - (let ((has-nan? (or (nan? --) (nan? -+) (nan? ++) (nan? +-)))) - (define-binary-result! a b result #t - (cond - ((eqv? a b) 0) - (has-nan? -inf.0) - (else (min -- -+ ++ +-))) - (if has-nan? - +inf.0 - (max -- -+ ++ +-))))))) - -(define-type-checker (div a b) - (and (check-type a &number -inf.0 +inf.0) - (check-type b &number -inf.0 +inf.0) - ;; We only know that there will not be an exception if b is not - ;; zero. - (not (<= (&min b) 0 (&max b))))) -(define-type-inferrer (div a b result) - (let ((min-a (&min a)) (max-a (&max a)) - (min-b (&min b)) (max-b (&max b))) - (call-with-values - (lambda () - (if (<= min-b 0 max-b) - ;; If the range of the divisor crosses 0, the result spans - ;; the whole range. - (values -inf.0 +inf.0) - ;; Otherwise min-b and max-b have the same sign, and cannot both - ;; be infinity. - (let ((--- (if (inf? min-b) 0 (floor/ min-a min-b))) - (-+- (if (inf? max-b) 0 (floor/ min-a max-b))) - (++- (if (inf? max-b) 0 (floor/ max-a max-b))) - (+-- (if (inf? min-b) 0 (floor/ max-a min-b))) - (--+ (if (inf? min-b) 0 (ceiling/ min-a min-b))) - (-++ (if (inf? max-b) 0 (ceiling/ min-a max-b))) - (+++ (if (inf? max-b) 0 (ceiling/ max-a max-b))) - (+-+ (if (inf? min-b) 0 (ceiling/ max-a min-b)))) - (values (min (min --- -+- ++- +--) - (min --+ -++ +++ +-+)) - (max (max --- -+- ++- +--) - (max --+ -++ +++ +-+)))))) - (lambda (min max) - (define-binary-result! a b result #f min max))))) - -(define-simple-type-checker (add1 &number)) -(define-type-inferrer (add1 a result) - (define-unary-result! a result (1+ (&min a)) (1+ (&max a)))) - -(define-simple-type-checker (sub1 &number)) -(define-type-inferrer (sub1 a result) - (define-unary-result! a result (1- (&min a)) (1- (&max a)))) - -(define-type-checker (quo a b) - (and (check-type a &exact-integer -inf.0 +inf.0) - (check-type b &exact-integer -inf.0 +inf.0) - ;; We only know that there will not be an exception if b is not - ;; zero. - (not (<= (&min b) 0 (&max b))))) -(define-type-inferrer (quo a b result) - (restrict! a &exact-integer -inf.0 +inf.0) - (restrict! b &exact-integer -inf.0 +inf.0) - (define! result &exact-integer -inf.0 +inf.0)) - -(define-type-checker-aliases quo rem) -(define-type-inferrer (rem a b result) - (restrict! a &exact-integer -inf.0 +inf.0) - (restrict! b &exact-integer -inf.0 +inf.0) - ;; Same sign as A. - (let ((max-abs-rem (1- (max (abs (&min b)) (abs (&max b)))))) - (cond - ((< (&min a) 0) - (if (< 0 (&max a)) - (define! result &exact-integer (- max-abs-rem) max-abs-rem) - (define! result &exact-integer (- max-abs-rem) 0))) - (else - (define! result &exact-integer 0 max-abs-rem))))) - -(define-type-checker-aliases quo mod) -(define-type-inferrer (mod a b result) - (restrict! a &exact-integer -inf.0 +inf.0) - (restrict! b &exact-integer -inf.0 +inf.0) - ;; Same sign as B. - (let ((max-abs-mod (1- (max (abs (&min b)) (abs (&max b)))))) - (cond - ((< (&min b) 0) - (if (< 0 (&max b)) - (define! result &exact-integer (- max-abs-mod) max-abs-mod) - (define! result &exact-integer (- max-abs-mod) 0))) - (else - (define! result &exact-integer 0 max-abs-mod))))) - -;; Predicates. -(define-syntax-rule (define-number-kind-predicate-inferrer name type) - (define-type-inferrer (name val result) - (cond - ((zero? (logand (&type val) type)) - (define! result &false 0 0)) - ((zero? (logand (&type val) (lognot type))) - (define! result &true 0 0)) - (else - (define! result (logior &true &false) 0 0))))) -(define-number-kind-predicate-inferrer complex? &number) -(define-number-kind-predicate-inferrer real? &real) -(define-number-kind-predicate-inferrer rational? - (logior &exact-integer &fraction)) -(define-number-kind-predicate-inferrer integer? - (logior &exact-integer &flonum)) -(define-number-kind-predicate-inferrer exact-integer? - &exact-integer) - -(define-simple-type-checker (exact? &number)) -(define-type-inferrer (exact? val result) - (restrict! val &number -inf.0 +inf.0) - (cond - ((zero? (logand (&type val) (logior &exact-integer &fraction))) - (define! result &false 0 0)) - ((zero? (logand (&type val) (lognot (logior &exact-integer &fraction)))) - (define! result &true 0 0)) - (else - (define! result (logior &true &false) 0 0)))) - -(define-simple-type-checker (inexact? &number)) -(define-type-inferrer (inexact? val result) - (restrict! val &number -inf.0 +inf.0) - (cond - ((zero? (logand (&type val) (logior &flonum &complex))) - (define! result &false 0 0)) - ((zero? (logand (&type val) (logand &number - (lognot (logior &flonum &complex))))) - (define! result &true 0 0)) - (else - (define! result (logior &true &false) 0 0)))) - -(define-simple-type-checker (inf? &real)) -(define-type-inferrer (inf? val result) - (restrict! val &real -inf.0 +inf.0) - (cond - ((or (zero? (logand (&type val) (logior &flonum &complex))) - (and (not (inf? (&min val))) (not (inf? (&max val))))) - (define! result &false 0 0)) - (else - (define! result (logior &true &false) 0 0)))) - -(define-type-aliases inf? nan?) - -(define-simple-type (even? &exact-integer) - ((logior &true &false) 0 0)) -(define-type-aliases even? odd?) - -;; Bit operations. -(define-simple-type-checker (ash &exact-integer &exact-integer)) -(define-type-inferrer (ash val count result) - (define (ash* val count) - ;; As we can only represent a 32-bit range, don't bother inferring - ;; shifts that might exceed that range. - (cond - ((inf? val) val) ; Preserves sign. - ((< -32 count 32) (ash val count)) - ((zero? val) 0) - ((positive? val) +inf.0) - (else -inf.0))) - (restrict! val &exact-integer -inf.0 +inf.0) - (restrict! count &exact-integer -inf.0 +inf.0) - (let ((-- (ash* (&min val) (&min count))) - (-+ (ash* (&min val) (&max count))) - (++ (ash* (&max val) (&max count))) - (+- (ash* (&max val) (&min count)))) - (define! result &exact-integer - (min -- -+ ++ +-) - (max -- -+ ++ +-)))) - -(define (next-power-of-two n) - (let lp ((out 1)) - (if (< n out) - out - (lp (ash out 1))))) - -(define-simple-type-checker (logand &exact-integer &exact-integer)) -(define-type-inferrer (logand a b result) - (define (logand-min a b) - (if (and (negative? a) (negative? b)) - (min a b) - 0)) - (define (logand-max a b) - (if (and (positive? a) (positive? b)) - (min a b) - 0)) - (restrict! a &exact-integer -inf.0 +inf.0) - (restrict! b &exact-integer -inf.0 +inf.0) - (define! result &exact-integer - (logand-min (&min a) (&min b)) - (logand-max (&max a) (&max b)))) - -(define-simple-type-checker (logior &exact-integer &exact-integer)) -(define-type-inferrer (logior a b result) - ;; Saturate all bits of val. - (define (saturate val) - (1- (next-power-of-two val))) - (define (logior-min a b) - (cond ((and (< a 0) (<= 0 b)) a) - ((and (< b 0) (<= 0 a)) b) - (else (max a b)))) - (define (logior-max a b) - ;; If either operand is negative, just assume the max is -1. - (cond - ((or (< a 0) (< b 0)) -1) - ((or (inf? a) (inf? b)) +inf.0) - (else (saturate (logior a b))))) - (restrict! a &exact-integer -inf.0 +inf.0) - (restrict! b &exact-integer -inf.0 +inf.0) - (define! result &exact-integer - (logior-min (&min a) (&min b)) - (logior-max (&max a) (&max b)))) - -;; For our purposes, treat logxor the same as logior. -(define-type-aliases logior logxor) - -(define-simple-type-checker (lognot &exact-integer)) -(define-type-inferrer (lognot a result) - (restrict! a &exact-integer -inf.0 +inf.0) - (define! result &exact-integer - (- -1 (&max a)) - (- -1 (&min a)))) - -(define-simple-type-checker (logtest &exact-integer &exact-integer)) -(define-predicate-inferrer (logtest a b true?) - (restrict! a &exact-integer -inf.0 +inf.0) - (restrict! b &exact-integer -inf.0 +inf.0)) - -(define-simple-type-checker (logbit? (&exact-integer 0 +inf.0) &exact-integer)) -(define-type-inferrer (logbit? a b result) - (let ((a-min (&min a)) - (a-max (&max a)) - (b-min (&min b)) - (b-max (&max b))) - (if (and (eqv? a-min a-max) (>= a-min 0) (not (inf? a-min)) - (eqv? b-min b-max) (>= b-min 0) (not (inf? b-min))) - (let ((type (if (logbit? a-min b-min) &true &false))) - (define! result type 0 0)) - (define! result (logior &true &false) 0 0)))) - -;; Flonums. -(define-simple-type-checker (sqrt &number)) -(define-type-inferrer (sqrt x result) - (let ((type (&type x))) - (cond - ((and (zero? (logand type &complex)) (<= 0 (&min x))) - (define! result - (logior type &flonum) - (inexact->exact (floor (sqrt (&min x)))) - (if (inf? (&max x)) - +inf.0 - (inexact->exact (ceiling (sqrt (&max x))))))) - (else - (define! result (logior type &flonum &complex) -inf.0 +inf.0))))) - -(define-simple-type-checker (abs &real)) -(define-type-inferrer (abs x result) - (let ((type (&type x))) - (cond - ((eqv? type (logand type &number)) - (restrict! x &real -inf.0 +inf.0) - (define! result (logand type &real) - (min (abs (&min x)) (abs (&max x))) - (max (abs (&min x)) (abs (&max x))))) - (else - (define! result (logior (logand (&type x) (lognot &number)) - (logand (&type x) &real)) - (max (&min x) 0) - (max (abs (&min x)) (abs (&max x)))))))) - - - - -;;; -;;; Characters. -;;; - -(define-simple-type (char=? char>?) - -(define-simple-type-checker (integer->char (&exact-integer 0 #x10ffff))) -(define-type-inferrer (integer->char i result) - (restrict! i &exact-integer 0 #x10ffff) - (define! result &char (max (&min i) 0) (min (&max i) #x10ffff))) - -(define-simple-type-checker (char->integer &char)) -(define-type-inferrer (char->integer c result) - (restrict! c &char 0 #x10ffff) - (define! result &exact-integer (max (&min c) 0) (min (&max c) #x10ffff))) - - - - -;;; -;;; Type flow analysis: the meet (ahem) of the algorithm. -;;; - -(define (successor-count cont) - (match cont - (($ $kargs _ _ ($ $continue k src exp)) - (match exp - ((or ($ $branch) ($ $prompt)) 2) - (_ 1))) - (($ $kfun src meta self tail clause) (if clause 1 0)) - (($ $kclause arity body alt) (if alt 2 1)) - (($ $kreceive) 1) - (($ $ktail) 0))) - -(define (intset-pop set) - (match (intset-next set) - (#f (values set #f)) - (i (values (intset-remove set i) i)))) - -(define-syntax-rule (make-worklist-folder* seed ...) - (lambda (f worklist seed ...) - (let lp ((worklist worklist) (seed seed) ...) - (call-with-values (lambda () (intset-pop worklist)) - (lambda (worklist i) - (if i - (call-with-values (lambda () (f i seed ...)) - (lambda (i* seed ...) - (let add ((i* i*) (worklist worklist)) - (match i* - (() (lp worklist seed ...)) - ((i . i*) (add i* (intset-add worklist i))))))) - (values seed ...))))))) - -(define worklist-fold* - (case-lambda - ((f worklist seed) - ((make-worklist-folder* seed) f worklist seed)))) - -(define intmap-ensure - (let* ((*absent* (list 'absent)) - (not-found (lambda (i) *absent*))) - (lambda (map i ensure) - (let ((val (intmap-ref map i not-found))) - (if (eq? val *absent*) - (let ((val (ensure i))) - (values (intmap-add map i val) val)) - (values map val)))))) - -;; For best results, the labels in the function starting should be -;; topologically sorted (renumbered). Otherwise the backward branch -;; detection mentioned in the module commentary will trigger for -;; ordinary forward branches. -(define (infer-types conts kfun) - "Compute types for all variables bound in the function labelled -@var{kfun}, from @var{conts}. Returns an intmap mapping labels to type -entries. - -A type entry is a vector that describes the types of the values that -flow into and out of a labelled expressoin. The first slot in the type -entry vector corresponds to the types that flow in, and the rest of the -slots correspond to the types that flow out. Each element of the type -entry vector is an intmap mapping variable name to the variable's -inferred type. An inferred type is a 3-vector of type, minimum, and -maximum, where type is a bitset as a fixnum." - (define (get-entry typev label) (intmap-ref typev label)) - (define (entry-not-found label) - (make-vector (1+ (successor-count (intmap-ref conts label))) #f)) - (define (ensure-entry typev label) - (intmap-ensure typev label entry-not-found)) - - (define (compute-initial-state) - (let ((entry (entry-not-found kfun))) - ;; Nothing flows in to the first label. - (vector-set! entry 0 empty-intmap) - (intmap-add empty-intmap kfun entry))) - - (define (adjoin-vars types vars entry) - (match vars - (() types) - ((var . vars) - (adjoin-vars (adjoin-var types var entry) vars entry)))) - - (define (infer-primcall types succ name args result) - (cond - ((hashq-ref *type-inferrers* name) - => (lambda (inferrer) - ;; FIXME: remove the apply? - ;; (pk 'primcall name args result) - (apply inferrer types succ - (if result - (append args (list result)) - args)))) - (result - (adjoin-var types result all-types-entry)) - (else - types))) - - (define (vector-replace vec idx val) - (let ((vec (vector-copy vec))) - (vector-set! vec idx val) - vec)) - - (define (update-out-types label typev types succ-idx) - (let* ((entry (get-entry typev label)) - (old-types (vector-ref entry (1+ succ-idx)))) - (if (eq? types old-types) - (values typev #f) - (let ((entry (vector-replace entry (1+ succ-idx) types)) - (first? (not old-types))) - (values (intmap-replace typev label entry) first?))))) - - (define (update-in-types label typev types saturate?) - (let*-values (((typev entry) (ensure-entry typev label)) - ((old-types) (vector-ref entry 0)) - ;; TODO: If the label has only one predecessor, we can - ;; avoid the meet. - ((types) (if (not old-types) - types - (let ((meet (if saturate? - type-entry-saturating-union - type-entry-union))) - (intmap-intersect old-types types meet))))) - (if (eq? old-types types) - (values typev #f) - (let ((entry (vector-replace entry 0 types))) - (values (intmap-replace typev label entry) #t))))) - - (define (propagate-types label typev succ-idx succ-label types) - (let*-values - (((typev first?) (update-out-types label typev types succ-idx)) - ((saturate?) (and (not first?) (<= succ-label label))) - ((typev changed?) (update-in-types succ-label typev types saturate?))) - (values (if changed? (list succ-label) '()) typev))) - - (define (visit-exp label typev k types exp) - (define (propagate1 succ-label types) - (propagate-types label typev 0 succ-label types)) - (define (propagate2 succ0-label types0 succ1-label types1) - (let*-values (((changed0 typev) - (propagate-types label typev 0 succ0-label types0)) - ((changed1 typev) - (propagate-types label typev 1 succ1-label types1))) - (values (append changed0 changed1) typev))) - ;; Each of these branches must propagate to its successors. - (match exp - (($ $branch kt ($ $values (arg))) - ;; The "normal" continuation is the #f branch. - (let ((kf-types (restrict-var types arg - (make-type-entry (logior &false &nil) - 0 - 0))) - (kt-types (restrict-var types arg - (make-type-entry - (logand &all-types - (lognot (logior &false &nil))) - -inf.0 +inf.0)))) - (propagate2 k kf-types kt kt-types))) - (($ $branch kt ($ $primcall name args)) - ;; The "normal" continuation is the #f branch. - (let ((kf-types (infer-primcall types 0 name args #f)) - (kt-types (infer-primcall types 1 name args #f))) - (propagate2 k kf-types kt kt-types))) - (($ $prompt escape? tag handler) - ;; The "normal" continuation enters the prompt. - (propagate2 k types handler types)) - (($ $primcall name args) - (propagate1 k - (match (intmap-ref conts k) - (($ $kargs _ defs) - (infer-primcall types 0 name args - (match defs ((var) var) (() #f)))) - (_ - ;; (pk 'warning-no-restrictions name) - types)))) - (($ $values args) - (match (intmap-ref conts k) - (($ $kargs _ defs) - (let ((in types)) - (let lp ((defs defs) (args args) (out types)) - (match (cons defs args) - ((() . ()) - (propagate1 k out)) - (((def . defs) . (arg . args)) - (lp defs args - (adjoin-var out def (var-type-entry in arg)))))))) - (_ - (propagate1 k types)))) - ((or ($ $call) ($ $callk)) - (propagate1 k types)) - (($ $rec names vars funs) - (let ((proc-type (make-type-entry &procedure -inf.0 +inf.0))) - (propagate1 k (adjoin-vars types vars proc-type)))) - (_ - (match (intmap-ref conts k) - (($ $kargs (_) (var)) - (let ((entry (match exp - (($ $const val) - (constant-type val)) - ((or ($ $prim) ($ $fun) ($ $closure)) - ;; Could be more precise here. - (make-type-entry &procedure -inf.0 +inf.0))))) - (propagate1 k (adjoin-var types var entry)))))))) - - (define (visit-cont label typev) - (let ((types (vector-ref (intmap-ref typev label) 0))) - (define (propagate0) - (values '() typev)) - (define (propagate1 succ-label types) - (propagate-types label typev 0 succ-label types)) - (define (propagate2 succ0-label types0 succ1-label types1) - (let*-values (((changed0 typev) - (propagate-types label typev 0 succ0-label types0)) - ((changed1 typev) - (propagate-types label typev 1 succ1-label types1))) - (values (append changed0 changed1) typev))) - - ;; Add types for new definitions, and restrict types of - ;; existing variables due to side effects. - (match (intmap-ref conts label) - (($ $kargs names vars ($ $continue k src exp)) - (visit-exp label typev k types exp)) - (($ $kreceive arity k) - (match (intmap-ref conts k) - (($ $kargs names vars) - (propagate1 k (adjoin-vars types vars all-types-entry))))) - (($ $kfun src meta self tail clause) - (if clause - (propagate1 clause (adjoin-var types self all-types-entry)) - (propagate0))) - (($ $kclause arity kbody kalt) - (match (intmap-ref conts kbody) - (($ $kargs _ defs) - (let ((body-types (adjoin-vars types defs all-types-entry))) - (if kalt - (propagate2 kbody body-types kalt types) - (propagate1 kbody body-types)))))) - (($ $ktail) (propagate0))))) - - (worklist-fold* visit-cont - (intset-add empty-intset kfun) - (compute-initial-state))) - -(define (lookup-pre-type types label def) - (let* ((entry (intmap-ref types label)) - (tentry (var-type-entry (vector-ref entry 0) def))) - (values (type-entry-type tentry) - (type-entry-min tentry) - (type-entry-max tentry)))) - -(define (lookup-post-type types label def succ-idx) - (let* ((entry (intmap-ref types label)) - (tentry (var-type-entry (vector-ref entry (1+ succ-idx)) def))) - (values (type-entry-type tentry) - (type-entry-min tentry) - (type-entry-max tentry)))) - -(define (primcall-types-check? types label name args) - (match (hashq-ref *type-checkers* name) - (#f #f) - (checker - (let ((entry (intmap-ref types label))) - (apply checker (vector-ref entry 0) args))))) diff --git a/module/language/cps2/utils.scm b/module/language/cps2/utils.scm deleted file mode 100644 index eae6b69c6..000000000 --- a/module/language/cps2/utils.scm +++ /dev/null @@ -1,477 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; Helper facilities for working with CPS. -;;; -;;; Code: - -(define-module (language cps2 utils) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) - #:use-module (language cps2) - #:use-module (language cps intset) - #:use-module (language cps intmap) - #:export (;; Fresh names. - label-counter var-counter - fresh-label fresh-var - with-fresh-name-state compute-max-label-and-var - let-fresh - - ;; Various utilities. - fold1 fold2 - trivial-intset - intmap-map - intmap-keys - invert-bijection invert-partition - intset->intmap - worklist-fold - fixpoint - - ;; Flow analysis. - compute-constant-values - compute-function-body - compute-reachable-functions - compute-successors - invert-graph - compute-predecessors - compute-reverse-post-order - compute-strongly-connected-components - compute-sorted-strongly-connected-components - compute-idoms - compute-dom-edges - )) - -(define label-counter (make-parameter #f)) -(define var-counter (make-parameter #f)) - -(define (fresh-label) - (let ((count (or (label-counter) - (error "fresh-label outside with-fresh-name-state")))) - (label-counter (1+ count)) - count)) - -(define (fresh-var) - (let ((count (or (var-counter) - (error "fresh-var outside with-fresh-name-state")))) - (var-counter (1+ count)) - count)) - -(define-syntax-rule (let-fresh (label ...) (var ...) body ...) - (let* ((label (fresh-label)) ... - (var (fresh-var)) ...) - body ...)) - -(define-syntax-rule (with-fresh-name-state fun body ...) - (call-with-values (lambda () (compute-max-label-and-var fun)) - (lambda (max-label max-var) - (parameterize ((label-counter (1+ max-label)) - (var-counter (1+ max-var))) - body ...)))) - -(define (compute-max-label-and-var conts) - (values (or (intmap-prev conts) -1) - (intmap-fold (lambda (k cont max-var) - (match cont - (($ $kargs names syms body) - (apply max max-var syms)) - (($ $kfun src meta self) - (max max-var self)) - (_ max-var))) - conts - -1))) - -(define-inlinable (fold1 f l s0) - (let lp ((l l) (s0 s0)) - (match l - (() s0) - ((elt . l) (lp l (f elt s0)))))) - -(define-inlinable (fold2 f l s0 s1) - (let lp ((l l) (s0 s0) (s1 s1)) - (match l - (() (values s0 s1)) - ((elt . l) - (call-with-values (lambda () (f elt s0 s1)) - (lambda (s0 s1) - (lp l s0 s1))))))) - -(define (trivial-intset set) - "Returns the sole member of @var{set}, if @var{set} has exactly one -member, or @code{#f} otherwise." - (let ((first (intset-next set))) - (and first - (not (intset-next set (1+ first))) - first))) - -(define (intmap-map proc map) - (persistent-intmap - (intmap-fold (lambda (k v out) (intmap-replace! out k (proc k v))) - map - map))) - -(define (intmap-keys map) - "Return an intset of the keys in @var{map}." - (persistent-intset - (intmap-fold (lambda (k v keys) (intset-add! keys k)) map empty-intset))) - -(define (invert-bijection map) - "Assuming the values of @var{map} are integers and are unique, compute -a map in which each value maps to its key. If the values are not -unique, an error will be signalled." - (intmap-fold (lambda (k v out) (intmap-add out v k)) map empty-intmap)) - -(define (invert-partition map) - "Assuming the values of @var{map} are disjoint intsets, compute a map -in which each member of each set maps to its key. If the values are not -disjoint, an error will be signalled." - (intmap-fold (lambda (k v* out) - (intset-fold (lambda (v out) (intmap-add out v k)) v* out)) - map empty-intmap)) - -(define (intset->intmap f set) - (persistent-intmap - (intset-fold (lambda (label preds) - (intmap-add! preds label (f label))) - set empty-intmap))) - -(define worklist-fold - (case-lambda - ((f in out) - (let lp ((in in) (out out)) - (if (eq? in empty-intset) - out - (call-with-values (lambda () (f in out)) lp)))) - ((f in out0 out1) - (let lp ((in in) (out0 out0) (out1 out1)) - (if (eq? in empty-intset) - (values out0 out1) - (call-with-values (lambda () (f in out0 out1)) lp)))))) - -(define fixpoint - (case-lambda - ((f x) - (let lp ((x x)) - (let ((x* (f x))) - (if (eq? x x*) x* (lp x*))))) - ((f x0 x1) - (let lp ((x0 x0) (x1 x1)) - (call-with-values (lambda () (f x0 x1)) - (lambda (x0* x1*) - (if (and (eq? x0 x0*) (eq? x1 x1*)) - (values x0* x1*) - (lp x0* x1*)))))))) - -(define (compute-defining-expressions conts) - (define (meet-defining-expressions old new) - ;; If there are multiple definitions, punt and - ;; record #f. - #f) - (persistent-intmap - (intmap-fold (lambda (label cont defs) - (match cont - (($ $kargs _ _ ($ $continue k src exp)) - (match (intmap-ref conts k) - (($ $kargs (_) (var)) - (intmap-add! defs var exp meet-defining-expressions)) - (_ defs))) - (_ defs))) - conts - empty-intmap))) - -(define (compute-constant-values conts) - (persistent-intmap - (intmap-fold (lambda (var exp out) - (match exp - (($ $const val) - (intmap-add! out var val)) - (_ out))) - (compute-defining-expressions conts) - empty-intmap))) - -(define (compute-function-body conts kfun) - (persistent-intset - (let visit-cont ((label kfun) (labels empty-intset)) - (cond - ((intset-ref labels label) labels) - (else - (let ((labels (intset-add! labels label))) - (match (intmap-ref conts label) - (($ $kreceive arity k) (visit-cont k labels)) - (($ $kfun src meta self ktail kclause) - (let ((labels (visit-cont ktail labels))) - (if kclause - (visit-cont kclause labels) - labels))) - (($ $ktail) labels) - (($ $kclause arity kbody kalt) - (if kalt - (visit-cont kalt (visit-cont kbody labels)) - (visit-cont kbody labels))) - (($ $kargs names syms ($ $continue k src exp)) - (visit-cont k (match exp - (($ $branch k) - (visit-cont k labels)) - (($ $prompt escape? tag k) - (visit-cont k labels)) - (_ labels))))))))))) - -(define (compute-reachable-functions conts kfun) - "Compute a mapping LABEL->LABEL..., where each key is a reachable -$kfun and each associated value is the body of the function, as an -intset." - (define (intset-cons i set) (intset-add set i)) - (define (visit-fun kfun body to-visit) - (intset-fold - (lambda (label to-visit) - (define (return kfun*) (fold intset-cons to-visit kfun*)) - (define (return1 kfun) (intset-add to-visit kfun)) - (define (return0) to-visit) - (match (intmap-ref conts label) - (($ $kargs _ _ ($ $continue _ _ exp)) - (match exp - (($ $fun label) (return1 label)) - (($ $rec _ _ (($ $fun labels) ...)) (return labels)) - (($ $closure label nfree) (return1 label)) - (($ $callk label) (return1 label)) - (_ (return0)))) - (_ (return0)))) - body - to-visit)) - (let lp ((to-visit (intset kfun)) (visited empty-intmap)) - (let ((to-visit (intset-subtract to-visit (intmap-keys visited)))) - (if (eq? to-visit empty-intset) - visited - (call-with-values - (lambda () - (intset-fold - (lambda (kfun to-visit visited) - (let ((body (compute-function-body conts kfun))) - (values (visit-fun kfun body to-visit) - (intmap-add visited kfun body)))) - to-visit - empty-intset - visited)) - lp))))) - -(define* (compute-successors conts #:optional (kfun (intmap-next conts))) - (define (visit label succs) - (let visit ((label kfun) (succs empty-intmap)) - (define (propagate0) - (intmap-add! succs label empty-intset)) - (define (propagate1 succ) - (visit succ (intmap-add! succs label (intset succ)))) - (define (propagate2 succ0 succ1) - (let ((succs (intmap-add! succs label (intset succ0 succ1)))) - (visit succ1 (visit succ0 succs)))) - (if (intmap-ref succs label (lambda (_) #f)) - succs - (match (intmap-ref conts label) - (($ $kargs names vars ($ $continue k src exp)) - (match exp - (($ $branch kt) (propagate2 k kt)) - (($ $prompt escape? tag handler) (propagate2 k handler)) - (_ (propagate1 k)))) - (($ $kreceive arity k) - (propagate1 k)) - (($ $kfun src meta self tail clause) - (if clause - (propagate2 clause tail) - (propagate1 tail))) - (($ $kclause arity kbody kalt) - (if kalt - (propagate2 kbody kalt) - (propagate1 kbody))) - (($ $ktail) (propagate0)))))) - (persistent-intmap (visit kfun empty-intmap))) - -(define* (compute-predecessors conts kfun #:key - (labels (compute-function-body conts kfun))) - (define (meet cdr car) - (cons car cdr)) - (define (add-preds label preds) - (define (add-pred k preds) - (intmap-add! preds k label meet)) - (match (intmap-ref conts label) - (($ $kreceive arity k) - (add-pred k preds)) - (($ $kfun src meta self ktail kclause) - (add-pred ktail (if kclause (add-pred kclause preds) preds))) - (($ $ktail) - preds) - (($ $kclause arity kbody kalt) - (add-pred kbody (if kalt (add-pred kalt preds) preds))) - (($ $kargs names syms ($ $continue k src exp)) - (add-pred k - (match exp - (($ $branch k) (add-pred k preds)) - (($ $prompt _ _ k) (add-pred k preds)) - (_ preds)))))) - (persistent-intmap - (intset-fold add-preds labels - (intset->intmap (lambda (label) '()) labels)))) - -(define (compute-reverse-post-order succs start) - "Compute a reverse post-order numbering for a depth-first walk over -nodes reachable from the start node." - (let visit ((label start) (order '()) (visited empty-intset)) - (call-with-values - (lambda () - (intset-fold (lambda (succ order visited) - (if (intset-ref visited succ) - (values order visited) - (visit succ order visited))) - (intmap-ref succs label) - order - (intset-add! visited label))) - (lambda (order visited) - ;; After visiting successors, add label to the reverse post-order. - (values (cons label order) visited))))) - -(define (invert-graph succs) - "Given a graph PRED->SUCC..., where PRED is a label and SUCC... is an -intset of successors, return a graph SUCC->PRED...." - (intmap-fold (lambda (pred succs preds) - (intset-fold - (lambda (succ preds) - (intmap-add preds succ pred intset-add)) - succs - preds)) - succs - (intmap-map (lambda (label _) empty-intset) succs))) - -(define (compute-strongly-connected-components succs start) - "Given a LABEL->SUCCESSOR... graph, compute a SCC->LABEL... map -partitioning the labels into strongly connected components (SCCs)." - (let ((preds (invert-graph succs))) - (define (visit-scc scc sccs-by-label) - (let visit ((label scc) (sccs-by-label sccs-by-label)) - (if (intmap-ref sccs-by-label label (lambda (_) #f)) - sccs-by-label - (intset-fold visit - (intmap-ref preds label) - (intmap-add sccs-by-label label scc))))) - (intmap-fold - (lambda (label scc sccs) - (let ((labels (intset-add empty-intset label))) - (intmap-add sccs scc labels intset-union))) - (fold visit-scc empty-intmap (compute-reverse-post-order succs start)) - empty-intmap))) - -(define (compute-sorted-strongly-connected-components edges) - "Given a LABEL->SUCCESSOR... graph, return a list of strongly -connected components in sorted order." - (define nodes - (intmap-keys edges)) - ;; Add a "start" node that links to all nodes in the graph, and then - ;; remove it from the result. - (define start - (if (eq? nodes empty-intset) - 0 - (1+ (intset-prev nodes)))) - (define components - (intmap-remove - (compute-strongly-connected-components (intmap-add edges start nodes) - start) - start)) - (define node-components - (intmap-fold (lambda (id nodes out) - (intset-fold (lambda (node out) (intmap-add out node id)) - nodes out)) - components - empty-intmap)) - (define (node-component node) - (intmap-ref node-components node)) - (define (component-successors id nodes) - (intset-remove - (intset-fold (lambda (node out) - (intset-fold - (lambda (successor out) - (intset-add out (node-component successor))) - (intmap-ref edges node) - out)) - nodes - empty-intset) - id)) - (define component-edges - (intmap-map component-successors components)) - (define preds - (invert-graph component-edges)) - (define roots - (intmap-fold (lambda (id succs out) - (if (eq? empty-intset succs) - (intset-add out id) - out)) - component-edges - empty-intset)) - ;; As above, add a "start" node that links to the roots, and remove it - ;; from the result. - (match (compute-reverse-post-order (intmap-add preds start roots) start) - (((? (lambda (id) (eqv? id start))) . ids) - (map (lambda (id) (intmap-ref components id)) ids)))) - -;; Precondition: For each function in CONTS, the continuation names are -;; topologically sorted. -(define (compute-idoms conts kfun) - ;; This is the iterative O(n^2) fixpoint algorithm, originally from - ;; Allen and Cocke ("Graph-theoretic constructs for program flow - ;; analysis", 1972). See the discussion in Cooper, Harvey, and - ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001. - (let ((preds-map (compute-predecessors conts kfun))) - (define (compute-idom idoms preds) - (define (idom-ref label) - (intmap-ref idoms label (lambda (_) #f))) - (match preds - (() -1) - ((pred) pred) ; Shortcut. - ((pred . preds) - (define (common-idom d0 d1) - ;; We exploit the fact that a reverse post-order is a - ;; topological sort, and so the idom of a node is always - ;; numerically less than the node itself. - (let lp ((d0 d0) (d1 d1)) - (cond - ;; d0 or d1 can be false on the first iteration. - ((not d0) d1) - ((not d1) d0) - ((= d0 d1) d0) - ((< d0 d1) (lp d0 (idom-ref d1))) - (else (lp (idom-ref d0) d1))))) - (fold1 common-idom preds pred)))) - (define (adjoin-idom label preds idoms) - (let ((idom (compute-idom idoms preds))) - ;; Don't use intmap-add! here. - (intmap-add idoms label idom (lambda (old new) new)))) - (fixpoint (lambda (idoms) - (intmap-fold adjoin-idom preds-map idoms)) - empty-intmap))) - -;; Compute a vector containing, for each node, a list of the nodes that -;; it immediately dominates. These are the "D" edges in the DJ tree. -(define (compute-dom-edges idoms) - (define (snoc cdr car) (cons car cdr)) - (persistent-intmap - (intmap-fold (lambda (label idom doms) - (let ((doms (intmap-add! doms label '()))) - (cond - ((< idom 0) doms) ;; No edge to entry. - (else (intmap-add! doms idom label snoc))))) - idoms - empty-intmap))) diff --git a/module/language/cps2/verify.scm b/module/language/cps2/verify.scm deleted file mode 100644 index 79b43f4fd..000000000 --- a/module/language/cps2/verify.scm +++ /dev/null @@ -1,306 +0,0 @@ -;;; Diagnostic checker for CPS -;;; Copyright (C) 2014, 2015 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 License as -;;; published by the Free Software Foundation, either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; This library is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with this program. If not, see -;;; . - -;;; Commentary: -;;; -;;; A routine to detect invalid CPS. -;;; -;;; Code: - -(define-module (language cps2 verify) - #:use-module (ice-9 match) - #:use-module (language cps2) - #:use-module (language cps2 utils) - #:use-module (language cps intmap) - #:use-module (language cps intset) - #:use-module (language cps primitives) - #:use-module (srfi srfi-11) - #:export (verify)) - -(define (intset-pop set) - (match (intset-next set) - (#f (values set #f)) - (i (values (intset-remove set i) i)))) - -(define-syntax-rule (make-worklist-folder* seed ...) - (lambda (f worklist seed ...) - (let lp ((worklist worklist) (seed seed) ...) - (call-with-values (lambda () (intset-pop worklist)) - (lambda (worklist i) - (if i - (call-with-values (lambda () (f i seed ...)) - (lambda (i* seed ...) - (let add ((i* i*) (worklist worklist)) - (match i* - (() (lp worklist seed ...)) - ((i . i*) (add i* (intset-add worklist i))))))) - (values seed ...))))))) - -(define worklist-fold* - (case-lambda - ((f worklist seed) - ((make-worklist-folder* seed) f worklist seed)))) - -(define (check-distinct-vars conts) - (define (adjoin-def var seen) - (when (intset-ref seen var) - (error "duplicate var name" seen var)) - (intset-add seen var)) - (intmap-fold - (lambda (label cont seen) - (match (intmap-ref conts label) - (($ $kargs names vars ($ $continue k src exp)) - (fold1 adjoin-def vars seen)) - (($ $kfun src meta self tail clause) - (adjoin-def self seen)) - (_ seen)) - ) - conts - empty-intset)) - -(define (compute-available-definitions conts kfun) - "Compute and return a map of LABEL->VAR..., where VAR... are the -definitions that are available at LABEL." - (define (adjoin-def var defs) - (when (intset-ref defs var) - (error "var already present in defs" defs var)) - (intset-add defs var)) - - (define (propagate defs succ out) - (let* ((in (intmap-ref defs succ (lambda (_) #f))) - (in* (if in (intset-intersect in out) out))) - (if (eq? in in*) - (values '() defs) - (values (list succ) - (intmap-add defs succ in* (lambda (old new) new)))))) - - (define (visit-cont label defs) - (let ((in (intmap-ref defs label))) - (define (propagate0 out) - (values '() defs)) - (define (propagate1 succ out) - (propagate defs succ out)) - (define (propagate2 succ0 succ1 out) - (let*-values (((changed0 defs) (propagate defs succ0 out)) - ((changed1 defs) (propagate defs succ1 out))) - (values (append changed0 changed1) defs))) - - (match (intmap-ref conts label) - (($ $kargs names vars ($ $continue k src exp)) - (let ((out (fold1 adjoin-def vars in))) - (match exp - (($ $branch kt) (propagate2 k kt out)) - (($ $prompt escape? tag handler) (propagate2 k handler out)) - (_ (propagate1 k out))))) - (($ $kreceive arity k) - (propagate1 k in)) - (($ $kfun src meta self tail clause) - (let ((out (adjoin-def self in))) - (if clause - (propagate1 clause out) - (propagate0 out)))) - (($ $kclause arity kbody kalt) - (if kalt - (propagate2 kbody kalt in) - (propagate1 kbody in))) - (($ $ktail) (propagate0 in))))) - - (worklist-fold* visit-cont - (intset kfun) - (intmap-add empty-intmap kfun empty-intset))) - -(define (intmap-for-each f map) - (intmap-fold (lambda (k v seed) (f k v) seed) map *unspecified*)) - -(define (check-valid-var-uses conts kfun) - (define (adjoin-def var defs) (intset-add defs var)) - (let visit-fun ((kfun kfun) (free empty-intset) (first-order empty-intset)) - (define (visit-exp exp bound first-order) - (define (check-use var) - (unless (intset-ref bound var) - (error "unbound var" var))) - (define (visit-first-order kfun) - (if (intset-ref first-order kfun) - first-order - (visit-fun kfun empty-intset (intset-add first-order kfun)))) - (match exp - ((or ($ $const) ($ $prim)) first-order) - ;; todo: $closure - (($ $fun kfun) - (visit-fun kfun bound first-order)) - (($ $closure kfun) - (visit-first-order kfun)) - (($ $rec names vars (($ $fun kfuns) ...)) - (let ((bound (fold1 adjoin-def vars bound))) - (fold1 (lambda (kfun first-order) - (visit-fun kfun bound first-order)) - kfuns first-order))) - (($ $values args) - (for-each check-use args) - first-order) - (($ $call proc args) - (check-use proc) - (for-each check-use args) - first-order) - (($ $callk kfun proc args) - (check-use proc) - (for-each check-use args) - (visit-first-order kfun)) - (($ $branch kt ($ $values (arg))) - (check-use arg) - first-order) - (($ $branch kt ($ $primcall name args)) - (for-each check-use args) - first-order) - (($ $primcall name args) - (for-each check-use args) - first-order) - (($ $prompt escape? tag handler) - (check-use tag) - first-order))) - (intmap-fold - (lambda (label bound first-order) - (let ((bound (intset-union free bound))) - (match (intmap-ref conts label) - (($ $kargs names vars ($ $continue k src exp)) - (visit-exp exp (fold1 adjoin-def vars bound) first-order)) - (_ first-order)))) - (compute-available-definitions conts kfun) - first-order))) - -(define (check-label-partition conts kfun) - ;; A continuation can only belong to one function. - (intmap-fold - (lambda (kfun body seen) - (intset-fold - (lambda (label seen) - (intmap-add seen label kfun - (lambda (old new) - (error "label used by two functions" label old new)))) - body - seen)) - (compute-reachable-functions conts kfun) - empty-intmap)) - -(define (compute-reachable-labels conts kfun) - (intmap-fold (lambda (kfun body seen) (intset-union seen body)) - (compute-reachable-functions conts kfun) - empty-intset)) - -(define (check-arities conts kfun) - (define (check-arity exp cont) - (define (assert-unary) - (match cont - (($ $kargs (_) (_)) #t) - (_ (error "expected unary continuation" cont)))) - (define (assert-nullary) - (match cont - (($ $kargs () ()) #t) - (_ (error "expected unary continuation" cont)))) - (define (assert-n-ary n) - (match cont - (($ $kargs names vars) - (unless (= (length vars) n) - (error "expected n-ary continuation" n cont))) - (_ (error "expected $kargs continuation" cont)))) - (define (assert-kreceive-or-ktail) - (match cont - ((or ($ $kreceive) ($ $ktail)) #t) - (_ (error "expected $kreceive or $ktail continuation" cont)))) - (match exp - ((or ($ $const) ($ $prim) ($ $closure) ($ $fun)) - (assert-unary)) - (($ $rec names vars funs) - (unless (= (length names) (length vars) (length funs)) - (error "invalid $rec" exp)) - (assert-n-ary (length names)) - (match cont - (($ $kargs names vars*) - (unless (equal? vars* vars) - (error "bound variable mismatch" vars vars*))))) - (($ $values args) - (match cont - (($ $ktail) #t) - (_ (assert-n-ary (length args))))) - (($ $call proc args) - (assert-kreceive-or-ktail)) - (($ $callk k proc args) - (assert-kreceive-or-ktail)) - (($ $branch kt exp) - (assert-nullary) - (match (intmap-ref conts kt) - (($ $kargs () ()) #t) - (cont (error "bad kt" cont)))) - (($ $primcall name args) - (match cont - (($ $kargs names) - (match (prim-arity name) - ((out . in) - (unless (= in (length args)) - (error "bad arity to primcall" name args in)) - (unless (= out (length names)) - (error "bad return arity from primcall" name names out))))) - (($ $kreceive) - (when (false-if-exception (prim-arity name)) - (error "primitive should continue to $kargs, not $kreceive" name))) - (($ $ktail) - (unless (eq? name 'return) - (when (false-if-exception (prim-arity name)) - (error "primitive should continue to $kargs, not $ktail" name)))))) - (($ $prompt escape? tag handler) - (assert-nullary) - (match (intmap-ref conts handler) - (($ $kreceive) #t) - (cont (error "bad handler" cont)))))) - (let ((reachable (compute-reachable-labels conts kfun))) - (intmap-for-each - (lambda (label cont) - (when (intset-ref reachable label) - (match cont - (($ $kargs names vars ($ $continue k src exp)) - (unless (= (length names) (length vars)) - (error "broken $kargs" label names vars)) - (check-arity exp (intmap-ref conts k))) - (_ #t)))) - conts))) - -(define (check-functions-bound-once conts kfun) - (let ((reachable (compute-reachable-labels conts kfun))) - (define (add-fun fun functions) - (when (intset-ref functions fun) - (error "function already bound" fun)) - (intset-add functions fun)) - (intmap-fold - (lambda (label cont functions) - (if (intset-ref reachable label) - (match cont - (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun))) - (add-fun kfun functions)) - (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfuns) ...)))) - (fold1 add-fun kfuns functions)) - (_ functions)) - functions)) - conts - empty-intset))) - -(define (verify conts) - (check-distinct-vars conts) - (check-label-partition conts 0) - (check-valid-var-uses conts 0) - (check-arities conts 0) - (check-functions-bound-once conts 0) - conts) diff --git a/module/language/cps2/with-cps.scm b/module/language/cps2/with-cps.scm deleted file mode 100644 index f14eb93c9..000000000 --- a/module/language/cps2/with-cps.scm +++ /dev/null @@ -1,145 +0,0 @@ -;;; Continuation-passing style (CPS) intermediate language (IL) - -;; Copyright (C) 2013, 2014, 2015 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: -;;; -;;; Guile's CPS language is a label->cont mapping, which seems simple -;;; enough. However it's often cumbersome to thread around the output -;;; CPS program when doing non-trivial transformations, or when building -;;; a CPS program from scratch. For example, when visiting an -;;; expression during CPS conversion, we usually already know the label -;;; and the $kargs wrapper for the cont, and just need to know the body -;;; of that cont. However when building the body of that possibly -;;; nested Tree-IL expression we will also need to add conts to the -;;; result, so really it's a process that takes an incoming program, -;;; adds conts to that program, and returns the result program and the -;;; result term. -;;; -;;; It's a bit treacherous to do in a functional style as once you start -;;; adding to a program, you shouldn't add to previous versions of that -;;; program. Getting that right in the context of this program seed -;;; that is threaded through the conversion requires the use of a -;;; pattern, with-cps. -;;; -;;; with-cps goes like this: -;;; -;;; (with-cps cps clause ... tail-clause) -;;; -;;; Valid clause kinds are: -;;; -;;; (letk LABEL CONT) -;;; (setk LABEL CONT) -;;; (letv VAR ...) -;;; (let$ X (PROC ARG ...)) -;;; -;;; letk and letv create fresh CPS labels and variable names, -;;; respectively. Labels and vars bound by letk and letv are in scope -;;; from their point of definition onward. letv just creates fresh -;;; variable names for use in other parts of with-cps, while letk binds -;;; fresh labels to values and adds them to the resulting program. The -;;; right-hand-side of letk, CONT, is passed to build-cont, so it should -;;; be a valid production of that language. setk is like letk but it -;;; doesn't create a fresh label name. -;;; -;;; let$ delegates processing to a sub-computation. The form (PROC ARG -;;; ...) is syntactically altered to be (PROC CPS ARG ...), where CPS is -;;; the value of the program being built, at that point in the -;;; left-to-right with-cps execution. That form is is expected to -;;; evaluate to two values: the new CPS term, and the value to bind to -;;; X. X is in scope for the following with-cps clauses. The name was -;;; chosen because the $ is reminiscent of the $ in CPS data types. -;;; -;;; The result of the with-cps form is determined by the tail clause, -;;; which may be of these kinds: -;;; -;;; ($ (PROC ARG ...)) -;;; (setk LABEL CONT) -;;; EXP -;;; -;;; $ is like let$, but in tail position. If the tail clause is setk, -;;; then only one value is returned, the resulting CPS program. -;;; Otherwise EXP is any kind of expression, which should not add to the -;;; resulting program. Ending the with-cps with EXP is equivalant to -;;; returning (values CPS EXP). -;;; -;;; It's a bit of a monad, innit? Don't tell anyone though! -;;; -;;; Sometimes you need to just bind some constants to CPS values. -;;; with-cps-constants is there for you. For example: -;;; -;;; (with-cps-constants cps ((foo 34)) -;;; (build-term ($values (foo)))) -;;; -;;; The body of with-cps-constants is a with-cps clause, or a sequence -;;; of such clauses. But usually you will want with-cps-constants -;;; inside a with-cps, so it usually looks like this: -;;; -;;; (with-cps cps -;;; ... -;;; ($ (with-cps-constants ((foo 34)) -;;; (build-term ($values (foo)))))) -;;; -;;; which is to say that the $ or the let$ adds the CPS argument for us. -;;; -;;; Code: - -(define-module (language cps2 with-cps) - #:use-module (language cps2) - #:use-module (language cps2 utils) - #:use-module (language cps intmap) - #:export (with-cps with-cps-constants)) - -(define-syntax with-cps - (syntax-rules (letk setk letv let$ $) - ((_ (exp ...) clause ...) - (let ((cps (exp ...))) - (with-cps cps clause ...))) - ((_ cps (letk label cont) clause ...) - (let-fresh (label) () - (with-cps (intmap-add! cps label (build-cont cont)) - clause ...))) - ((_ cps (setk label cont)) - (intmap-add! cps label (build-cont cont) - (lambda (old new) new))) - ((_ cps (setk label cont) clause ...) - (with-cps (with-cps cps (setk label cont)) - clause ...)) - ((_ cps (letv v ...) clause ...) - (let-fresh () (v ...) - (with-cps cps clause ...))) - ((_ cps (let$ var (proc arg ...)) clause ...) - (call-with-values (lambda () (proc cps arg ...)) - (lambda (cps var) - (with-cps cps clause ...)))) - ((_ cps ($ (proc arg ...))) - (proc cps arg ...)) - ((_ cps exp) - (values cps exp)))) - -(define-syntax with-cps-constants - (syntax-rules () - ((_ cps () clause ...) - (with-cps cps clause ...)) - ((_ cps ((var val) (var* val*) ...) clause ...) - (let ((x val)) - (with-cps cps - (letv var) - (let$ body (with-cps-constants ((var* val*) ...) - clause ...)) - (letk label ($kargs ('var) (var) ,body)) - (build-term ($continue label #f ($const x)))))))) diff --git a/module/language/tree-il/compile-cps2.scm b/module/language/tree-il/compile-cps.scm similarity index 99% rename from module/language/tree-il/compile-cps2.scm rename to module/language/tree-il/compile-cps.scm index 932a49d27..59d2d7d90 100644 --- a/module/language/tree-il/compile-cps2.scm +++ b/module/language/tree-il/compile-cps.scm @@ -49,20 +49,20 @@ ;;; ;;; Code: -(define-module (language tree-il compile-cps2) +(define-module (language tree-il compile-cps) #:use-module (ice-9 match) #:use-module ((srfi srfi-1) #:select (fold filter-map)) #:use-module (srfi srfi-26) #:use-module ((system foreign) #:select (make-pointer pointer->scm)) - #:use-module (language cps2) - #:use-module (language cps2 utils) - #:use-module (language cps2 with-cps) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps with-cps) #:use-module (language cps primitives) #:use-module (language tree-il analyze) #:use-module (language tree-il optimize) #:use-module (language tree-il) #:use-module (language cps intmap) - #:export (compile-cps2)) + #:export (compile-cps)) ;;; Guile's semantics are that a toplevel lambda captures a reference on ;;; the current module, and that all contained lambdas use that module @@ -931,7 +931,7 @@ integer." (_ exp))) exp)) -(define (compile-cps2 exp env opts) +(define (compile-cps exp env opts) (values (cps-convert/thunk (canonicalize (optimize-tree-il exp env opts))) env diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm index d1c7326fc..10c20a010 100644 --- a/module/language/tree-il/spec.scm +++ b/module/language/tree-il/spec.scm @@ -1,6 +1,6 @@ ;;; Tree Intermediate Language -;; Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc. +;; Copyright (C) 2009, 2010, 2011, 2013, 2015 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 @@ -22,7 +22,7 @@ #:use-module (system base language) #:use-module (system base pmatch) #:use-module (language tree-il) - #:use-module (language tree-il compile-cps2) + #:use-module (language tree-il compile-cps) #:export (tree-il)) (define (write-tree-il exp . port) @@ -42,5 +42,5 @@ #:printer write-tree-il #:parser parse-tree-il #:joiner join - #:compilers `((cps2 . ,compile-cps2)) + #:compilers `((cps . ,compile-cps)) #:for-humans? #f) From 4aabc205cc488a5440a637a7ec4d842ea8647be6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 22 Jul 2015 18:27:37 +0200 Subject: [PATCH 033/865] Add missing files Last commit meant to rename files, not delete them. Whoops! --- module/language/cps.scm | 358 +++++ module/language/cps/closure-conversion.scm | 824 ++++++++++ module/language/cps/compile-bytecode.scm | 433 +++++ module/language/cps/constructors.scm | 98 ++ module/language/cps/contification.scm | 475 ++++++ module/language/cps/cse.scm | 449 ++++++ module/language/cps/dce.scm | 399 +++++ module/language/cps/effects-analysis.scm | 484 ++++++ module/language/cps/elide-values.scm | 88 ++ module/language/cps/optimize.scm | 106 ++ module/language/cps/prune-bailouts.scm | 86 + .../language/cps/prune-top-level-scopes.scm | 63 + module/language/cps/reify-primitives.scm | 167 ++ module/language/cps/renumber.scm | 217 +++ module/language/cps/self-references.scm | 79 + module/language/cps/simplify.scm | 267 ++++ module/language/cps/slot-allocation.scm | 995 ++++++++++++ module/language/cps/spec.scm | 37 + module/language/cps/specialize-primcalls.scm | 59 + module/language/cps/split-rec.scm | 174 ++ module/language/cps/type-fold.scm | 425 +++++ module/language/cps/types.scm | 1408 +++++++++++++++++ module/language/cps/utils.scm | 477 ++++++ module/language/cps/verify.scm | 306 ++++ module/language/cps/with-cps.scm | 145 ++ 25 files changed, 8619 insertions(+) create mode 100644 module/language/cps.scm create mode 100644 module/language/cps/closure-conversion.scm create mode 100644 module/language/cps/compile-bytecode.scm create mode 100644 module/language/cps/constructors.scm create mode 100644 module/language/cps/contification.scm create mode 100644 module/language/cps/cse.scm create mode 100644 module/language/cps/dce.scm create mode 100644 module/language/cps/effects-analysis.scm create mode 100644 module/language/cps/elide-values.scm create mode 100644 module/language/cps/optimize.scm create mode 100644 module/language/cps/prune-bailouts.scm create mode 100644 module/language/cps/prune-top-level-scopes.scm create mode 100644 module/language/cps/reify-primitives.scm create mode 100644 module/language/cps/renumber.scm create mode 100644 module/language/cps/self-references.scm create mode 100644 module/language/cps/simplify.scm create mode 100644 module/language/cps/slot-allocation.scm create mode 100644 module/language/cps/spec.scm create mode 100644 module/language/cps/specialize-primcalls.scm create mode 100644 module/language/cps/split-rec.scm create mode 100644 module/language/cps/type-fold.scm create mode 100644 module/language/cps/types.scm create mode 100644 module/language/cps/utils.scm create mode 100644 module/language/cps/verify.scm create mode 100644 module/language/cps/with-cps.scm diff --git a/module/language/cps.scm b/module/language/cps.scm new file mode 100644 index 000000000..b66bc38c0 --- /dev/null +++ b/module/language/cps.scm @@ -0,0 +1,358 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; This is the continuation-passing style (CPS) intermediate language +;;; (IL) for Guile. +;;; +;;; In CPS, a term is a labelled expression that calls a continuation. +;;; A function is a collection of terms. No term belongs to more than +;;; one function. The function is identified by the label of its entry +;;; term, and its body is composed of those terms that are reachable +;;; from the entry term. A program is a collection of functions, +;;; identified by the entry label of the entry function. +;;; +;;; Terms are themselves wrapped in continuations, which specify how +;;; predecessors may continue to them. For example, a $kargs +;;; continuation specifies that the term may be called with a specific +;;; number of values, and that those values will then be bound to +;;; lexical variables. $kreceive specifies that some number of values +;;; will be passed on the stack, as from a multiple-value return. Those +;;; values will be passed to a $kargs, if the number of values is +;;; compatible with the $kreceive's arity. $kfun is an entry point to a +;;; function, and receives arguments according to a well-known calling +;;; convention (currently, on the stack) and the stack before +;;; dispatching to a $kclause. A $kclause is a case-lambda clause, and +;;; only appears within a $kfun; it checks the incoming values for the +;;; correct arity and dispatches to a $kargs, or to the next clause. +;;; Finally, $ktail is the tail continuation for a function, and +;;; contains no term. +;;; +;;; Each continuation has a label that is unique in the program. As an +;;; implementation detail, the labels are integers, which allows us to +;;; easily sort them topologically. A program is a map from integers to +;;; continuations, where continuation 0 in the map is the entry point +;;; for the program, and is a $kfun of no arguments. +;;; +;;; $continue nodes call continuations. The expression contained in the +;;; $continue node determines the value or values that are passed to the +;;; target continuation: $const to pass a constant value, $values to +;;; pass multiple named values, etc. $continue nodes also record the +;;; source location corresponding to the expression. +;;; +;;; As mentioned above, a $kargs continuation can bind variables, if it +;;; receives incoming values. $kfun also binds a value, corresponding +;;; to the closure being called. A traditional CPS implementation will +;;; nest terms in each other, binding them in "let" forms, ensuring that +;;; continuations are declared and bound within the scope of the values +;;; that they may use. In this way, the scope tree is a proof that +;;; variables are defined before they are used. However, this proof is +;;; conservative; it is possible for a variable to always be defined +;;; before it is used, but not to be in scope: +;;; +;;; (letrec ((k1 (lambda (v1) (k2))) +;;; (k2 (lambda () v1))) +;;; (k1 0)) +;;; +;;; This example is invalid, as v1 is used outside its scope. However +;;; it would be perfectly fine for k2 to use v1 if k2 were nested inside +;;; k1: +;;; +;;; (letrec ((k1 (lambda (v1) +;;; (letrec ((k2 (lambda () v1))) +;;; (k2)))) +;;; (k1 0)) +;;; +;;; Because program transformation usually uses flow-based analysis, +;;; having to update the scope tree to manifestly prove a transformation +;;; that has already proven correct is needless overhead, and in the +;;; worst case can prevent optimizations from occuring. For that +;;; reason, Guile's CPS language does not nest terms. Instead, we use +;;; the invariant that definitions must dominate uses. To check the +;;; validity of a CPS program is thus more involved than checking for a +;;; well-scoped tree; you have to do flow analysis to determine a +;;; dominator tree. However the flexibility that this grants us is +;;; worth the cost of throwing away the embedded proof of the scope +;;; tree. +;;; +;;; This particular formulation of CPS was inspired by Andrew Kennedy's +;;; 2007 paper, "Compiling with Continuations, Continued". All Guile +;;; hackers should read that excellent paper! As in Kennedy's paper, +;;; continuations are second-class, and may be thought of as basic block +;;; labels. All values are bound to variables using continuation calls: +;;; even constants! +;;; +;;; Finally, note that there are two flavors of CPS: higher-order and +;;; first-order. By "higher-order", we mean that variables may be free +;;; across function boundaries. Higher-order CPS contains $fun and $rec +;;; expressions that declare functions in the scope of their term. +;;; Closure conversion results in first-order CPS, where closure +;;; representations have been explicitly chosen, and all variables used +;;; in a function are bound. Higher-order CPS is good for +;;; interprocedural optimizations like contification and beta reduction, +;;; while first-order CPS is better for instruction selection, register +;;; allocation, and code generation. +;;; +;;; See (language tree-il compile-cps) for details on how Tree-IL +;;; converts to CPS. +;;; +;;; Code: + +(define-module (language cps) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-11) + #:export (;; Helper. + $arity + make-$arity + + ;; Continuations. + $kreceive $kargs $kfun $ktail $kclause + + ;; Terms. + $continue + + ;; Expressions. + $const $prim $fun $rec $closure $branch + $call $callk $primcall $values $prompt + + ;; Building macros. + build-cont build-term build-exp + rewrite-cont rewrite-term rewrite-exp + + ;; External representation. + parse-cps unparse-cps)) + +;; FIXME: Use SRFI-99, when Guile adds it. +(define-syntax define-record-type* + (lambda (x) + (define (id-append ctx . syms) + (datum->syntax ctx (apply symbol-append (map syntax->datum syms)))) + (syntax-case x () + ((_ name field ...) + (and (identifier? #'name) (and-map identifier? #'(field ...))) + (with-syntax ((cons (id-append #'name #'make- #'name)) + (pred (id-append #'name #'name #'?)) + ((getter ...) (map (lambda (f) + (id-append f #'name #'- f)) + #'(field ...)))) + #'(define-record-type name + (cons field ...) + pred + (field getter) + ...)))))) + +(define-syntax-rule (define-cps-type name field ...) + (begin + (define-record-type* name field ...) + (set-record-type-printer! name print-cps))) + +(define (print-cps exp port) + (format port "#" (unparse-cps exp))) + +;; Helper. +(define-record-type* $arity req opt rest kw allow-other-keys?) + +;; Continuations +(define-cps-type $kreceive arity kbody) +(define-cps-type $kargs names syms term) +(define-cps-type $kfun src meta self ktail kclause) +(define-cps-type $ktail) +(define-cps-type $kclause arity kbody kalternate) + +;; Terms. +(define-cps-type $continue k src exp) + +;; Expressions. +(define-cps-type $const val) +(define-cps-type $prim name) +(define-cps-type $fun body) ; Higher-order. +(define-cps-type $rec names syms funs) ; Higher-order. +(define-cps-type $closure label nfree) ; First-order. +(define-cps-type $branch kt exp) +(define-cps-type $call proc args) +(define-cps-type $callk k proc args) ; First-order. +(define-cps-type $primcall name args) +(define-cps-type $values args) +(define-cps-type $prompt escape? tag handler) + +(define-syntax build-arity + (syntax-rules (unquote) + ((_ (unquote exp)) exp) + ((_ (req opt rest kw allow-other-keys?)) + (make-$arity req opt rest kw allow-other-keys?)))) + +(define-syntax build-cont + (syntax-rules (unquote $kreceive $kargs $kfun $ktail $kclause) + ((_ (unquote exp)) + exp) + ((_ ($kreceive req rest kargs)) + (make-$kreceive (make-$arity req '() rest '() #f) kargs)) + ((_ ($kargs (name ...) (unquote syms) body)) + (make-$kargs (list name ...) syms (build-term body))) + ((_ ($kargs (name ...) (sym ...) body)) + (make-$kargs (list name ...) (list sym ...) (build-term body))) + ((_ ($kargs names syms body)) + (make-$kargs names syms (build-term body))) + ((_ ($kfun src meta self ktail kclause)) + (make-$kfun src meta self ktail kclause)) + ((_ ($ktail)) + (make-$ktail)) + ((_ ($kclause arity kbody kalternate)) + (make-$kclause (build-arity arity) kbody kalternate)))) + +(define-syntax build-term + (syntax-rules (unquote $rec $continue) + ((_ (unquote exp)) + exp) + ((_ ($continue k src exp)) + (make-$continue k src (build-exp exp))))) + +(define-syntax build-exp + (syntax-rules (unquote + $const $prim $fun $rec $closure $branch + $call $callk $primcall $values $prompt) + ((_ (unquote exp)) exp) + ((_ ($const val)) (make-$const val)) + ((_ ($prim name)) (make-$prim name)) + ((_ ($fun kentry)) (make-$fun kentry)) + ((_ ($rec names gensyms funs)) (make-$rec names gensyms funs)) + ((_ ($closure k nfree)) (make-$closure k nfree)) + ((_ ($call proc (unquote args))) (make-$call proc args)) + ((_ ($call proc (arg ...))) (make-$call proc (list arg ...))) + ((_ ($call proc args)) (make-$call proc args)) + ((_ ($callk k proc (unquote args))) (make-$callk k proc args)) + ((_ ($callk k proc (arg ...))) (make-$callk k proc (list arg ...))) + ((_ ($callk k proc args)) (make-$callk k proc args)) + ((_ ($primcall name (unquote args))) (make-$primcall name args)) + ((_ ($primcall name (arg ...))) (make-$primcall name (list arg ...))) + ((_ ($primcall name args)) (make-$primcall name args)) + ((_ ($values (unquote args))) (make-$values args)) + ((_ ($values (arg ...))) (make-$values (list arg ...))) + ((_ ($values args)) (make-$values args)) + ((_ ($branch kt exp)) (make-$branch kt (build-exp exp))) + ((_ ($prompt escape? tag handler)) + (make-$prompt escape? tag handler)))) + +(define-syntax-rule (rewrite-cont x (pat cont) ...) + (match x + (pat (build-cont cont)) ...)) +(define-syntax-rule (rewrite-term x (pat term) ...) + (match x + (pat (build-term term)) ...)) +(define-syntax-rule (rewrite-exp x (pat body) ...) + (match x + (pat (build-exp body)) ...)) + +(define (parse-cps exp) + (define (src exp) + (let ((props (source-properties exp))) + (and (pair? props) props))) + (match exp + ;; Continuations. + (('kreceive req rest k) + (build-cont ($kreceive req rest k))) + (('kargs names syms body) + (build-cont ($kargs names syms ,(parse-cps body)))) + (('kfun src meta self ktail kclause) + (build-cont ($kfun (src exp) meta self ktail kclause))) + (('ktail) + (build-cont ($ktail))) + (('kclause (req opt rest kw allow-other-keys?) kbody) + (build-cont ($kclause (req opt rest kw allow-other-keys?) kbody #f))) + (('kclause (req opt rest kw allow-other-keys?) kbody kalt) + (build-cont ($kclause (req opt rest kw allow-other-keys?) kbody kalt))) + + ;; Calls. + (('continue k exp) + (build-term ($continue k (src exp) ,(parse-cps exp)))) + (('unspecified) + (build-exp ($const *unspecified*))) + (('const exp) + (build-exp ($const exp))) + (('prim name) + (build-exp ($prim name))) + (('fun kbody) + (build-exp ($fun kbody))) + (('closure k nfree) + (build-exp ($closure k nfree))) + (('rec (name sym fun) ...) + (build-exp ($rec name sym (map parse-cps fun)))) + (('call proc arg ...) + (build-exp ($call proc arg))) + (('callk k proc arg ...) + (build-exp ($callk k proc arg))) + (('primcall name arg ...) + (build-exp ($primcall name arg))) + (('branch k exp) + (build-exp ($branch k ,(parse-cps exp)))) + (('values arg ...) + (build-exp ($values arg))) + (('prompt escape? tag handler) + (build-exp ($prompt escape? tag handler))) + (_ + (error "unexpected cps" exp)))) + +(define (unparse-cps exp) + (match exp + ;; Continuations. + (($ $kreceive ($ $arity req () rest () #f) k) + `(kreceive ,req ,rest ,k)) + (($ $kargs names syms body) + `(kargs ,names ,syms ,(unparse-cps body))) + (($ $kfun src meta self ktail kclause) + `(kfun ,meta ,self ,ktail ,kclause)) + (($ $ktail) + `(ktail)) + (($ $kclause ($ $arity req opt rest kw allow-other-keys?) kbody kalternate) + `(kclause (,req ,opt ,rest ,kw ,allow-other-keys?) ,kbody + . ,(if kalternate (list kalternate) '()))) + + ;; Calls. + (($ $continue k src exp) + `(continue ,k ,(unparse-cps exp))) + (($ $const val) + (if (unspecified? val) + '(unspecified) + `(const ,val))) + (($ $prim name) + `(prim ,name)) + (($ $fun kbody) + `(fun ,kbody)) + (($ $closure k nfree) + `(closure ,k ,nfree)) + (($ $rec names syms funs) + `(rec ,@(map (lambda (name sym fun) + (list name sym (unparse-cps fun))) + names syms funs))) + (($ $call proc args) + `(call ,proc ,@args)) + (($ $callk k proc args) + `(callk ,k ,proc ,@args)) + (($ $primcall name args) + `(primcall ,name ,@args)) + (($ $branch k exp) + `(branch ,k ,(unparse-cps exp))) + (($ $values args) + `(values ,@args)) + (($ $prompt escape? tag handler) + `(prompt ,escape? ,tag ,handler)) + (_ + (error "unexpected cps" exp)))) diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm new file mode 100644 index 000000000..29577a99c --- /dev/null +++ b/module/language/cps/closure-conversion.scm @@ -0,0 +1,824 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; This pass converts a CPS term in such a way that no function has any +;;; free variables. Instead, closures are built explicitly with +;;; make-closure primcalls, and free variables are referenced through +;;; the closure. +;;; +;;; Closure conversion also removes any $rec expressions that +;;; contification did not handle. See (language cps) for a further +;;; discussion of $rec. +;;; +;;; Code: + +(define-module (language cps closure-conversion) + #:use-module (ice-9 match) + #:use-module ((srfi srfi-1) #:select (fold + filter-map + )) + #:use-module (srfi srfi-11) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps with-cps) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (convert-closures)) + +(define (compute-function-bodies conts kfun) + "Compute a map from FUN-LABEL->BODY-LABEL... for all $fun instances in +conts." + (let visit-fun ((kfun kfun) (out empty-intmap)) + (let ((body (compute-function-body conts kfun))) + (intset-fold + (lambda (label out) + (match (intmap-ref conts label) + (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun))) + (visit-fun kfun out)) + (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfun) ...)))) + (fold visit-fun out kfun)) + (_ out))) + body + (intmap-add out kfun body))))) + +(define (compute-program-body functions) + (intmap-fold (lambda (label body out) (intset-union body out)) + functions + empty-intset)) + +(define (filter-reachable conts functions) + (let ((reachable (compute-program-body functions))) + (intmap-fold + (lambda (label cont out) + (if (intset-ref reachable label) + out + (intmap-remove out label))) + conts conts))) + +(define (compute-non-operator-uses conts) + (persistent-intset + (intmap-fold + (lambda (label cont uses) + (define (add-use var uses) (intset-add! uses var)) + (define (add-uses vars uses) + (match vars + (() uses) + ((var . vars) (add-uses vars (add-use var uses))))) + (match cont + (($ $kargs _ _ ($ $continue _ _ exp)) + (match exp + ((or ($ $const) ($ $prim) ($ $fun) ($ $rec)) uses) + (($ $values args) + (add-uses args uses)) + (($ $call proc args) + (add-uses args uses)) + (($ $branch kt ($ $values (arg))) + (add-use arg uses)) + (($ $branch kt ($ $primcall name args)) + (add-uses args uses)) + (($ $primcall name args) + (add-uses args uses)) + (($ $prompt escape? tag handler) + (add-use tag uses)))) + (_ uses))) + conts + empty-intset))) + +(define (compute-singly-referenced-labels conts body) + (define (add-ref label single multiple) + (define (ref k single multiple) + (if (intset-ref single k) + (values single (intset-add! multiple k)) + (values (intset-add! single k) multiple))) + (define (ref0) (values single multiple)) + (define (ref1 k) (ref k single multiple)) + (define (ref2 k k*) + (if k* + (let-values (((single multiple) (ref k single multiple))) + (ref k* single multiple)) + (ref1 k))) + (match (intmap-ref conts label) + (($ $kreceive arity k) (ref1 k)) + (($ $kfun src meta self ktail kclause) (ref2 ktail kclause)) + (($ $ktail) (ref0)) + (($ $kclause arity kbody kalt) (ref2 kbody kalt)) + (($ $kargs names syms ($ $continue k src exp)) + (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f)))))) + (let*-values (((single multiple) (values empty-intset empty-intset)) + ((single multiple) (intset-fold add-ref body single multiple))) + (intset-subtract (persistent-intset single) + (persistent-intset multiple)))) + +(define (compute-function-names conts functions) + "Compute a map of FUN-LABEL->BOUND-VAR... for each labelled function +whose bound vars we know." + (define (add-named-fun var kfun out) + (let ((self (match (intmap-ref conts kfun) + (($ $kfun src meta self) self)))) + (intmap-add out kfun (intset var self)))) + (intmap-fold + (lambda (label body out) + (let ((single (compute-singly-referenced-labels conts body))) + (intset-fold + (lambda (label out) + (match (intmap-ref conts label) + (($ $kargs _ _ ($ $continue k _ ($ $fun kfun))) + (if (intset-ref single k) + (match (intmap-ref conts k) + (($ $kargs (_) (var)) (add-named-fun var kfun out)) + (_ out)) + out)) + (($ $kargs _ _ ($ $continue k _ ($ $rec _ vars (($ $fun kfun) ...)))) + (unless (intset-ref single k) + (error "$rec continuation has multiple predecessors??")) + (fold add-named-fun out vars kfun)) + (_ out))) + body + out))) + functions + empty-intmap)) + +(define (compute-well-known-functions conts bound->label) + "Compute a set of labels indicating the well-known functions in +@var{conts}. A well-known function is a function whose bound names we +know and which is never used in a non-operator position." + (intset-subtract + (persistent-intset + (intmap-fold (lambda (bound label candidates) + (intset-add! candidates label)) + bound->label + empty-intset)) + (persistent-intset + (intset-fold (lambda (var not-well-known) + (match (intmap-ref bound->label var (lambda (_) #f)) + (#f not-well-known) + (label (intset-add! not-well-known label)))) + (compute-non-operator-uses conts) + empty-intset)))) + +(define (intset-cons i set) + (intset-add set i)) + +(define (compute-shared-closures conts well-known) + "Compute a map LABEL->VAR indicating the sets of functions that will +share a closure. If a functions's label is in the map, it is shared. +The entries indicate the var of the shared closure, which will be one of +the bound vars of the closure." + (intmap-fold + (lambda (label cont out) + (match cont + (($ $kargs _ _ + ($ $continue _ _ ($ $rec names vars (($ $fun kfuns) ...)))) + ;; The split-rec pass should have ensured that this $rec forms a + ;; strongly-connected component, so the free variables from all of + ;; the functions will be alive as long as one of the closures is + ;; alive. For that reason we can consider storing all free + ;; variables in one closure and sharing it. + (let* ((kfuns-set (fold intset-cons empty-intset kfuns)) + (unknown-kfuns (intset-subtract kfuns-set well-known))) + (cond + ((or (eq? empty-intset kfuns-set) (trivial-intset kfuns-set)) + ;; There is only zero or one function bound here. Trivially + ;; shared already. + out) + ((eq? empty-intset unknown-kfuns) + ;; All functions are well-known; we can share a closure. Use + ;; the first bound variable. + (let ((closure (car vars))) + (intset-fold (lambda (kfun out) + (intmap-add out kfun closure)) + kfuns-set out))) + ((trivial-intset unknown-kfuns) + => (lambda (unknown-kfun) + ;; Only one function is not-well-known. Use that + ;; function's closure as the shared closure. + (let ((closure (assq-ref (map cons kfuns vars) unknown-kfun))) + (intset-fold (lambda (kfun out) + (intmap-add out kfun closure)) + kfuns-set out)))) + (else + ;; More than one not-well-known function means we need more + ;; than one proper closure, so we can't share. + out)))) + (_ out))) + conts + empty-intmap)) + +(define* (rewrite-shared-closure-calls cps functions label->bound shared kfun) + "Rewrite CPS such that every call to a function with a shared closure +instead is a $callk to that label, but passing the shared closure as the +proc argument. For recursive calls, use the appropriate 'self' +variable, if possible. Also rewrite uses of the non-well-known but +shared closures to use the appropriate 'self' variable, if possible." + ;; env := var -> (var . label) + (define (rewrite-fun kfun cps env) + (define (subst var) + (match (intmap-ref env var (lambda (_) #f)) + (#f var) + ((var . label) var))) + + (define (rename-exp label cps names vars k src exp) + (intmap-replace! + cps label + (build-cont + ($kargs names vars + ($continue k src + ,(rewrite-exp exp + ((or ($ $const) ($ $prim)) ,exp) + (($ $call proc args) + ,(let ((args (map subst args))) + (rewrite-exp (intmap-ref env proc (lambda (_) #f)) + (#f ($call proc ,args)) + ((closure . label) ($callk label closure ,args))))) + (($ $primcall name args) + ($primcall name ,(map subst args))) + (($ $branch k ($ $values (arg))) + ($branch k ($values ((subst arg))))) + (($ $branch k ($ $primcall name args)) + ($branch k ($primcall name ,(map subst args)))) + (($ $values args) + ($values ,(map subst args))) + (($ $prompt escape? tag handler) + ($prompt escape? (subst tag) handler)))))))) + + (define (visit-exp label cps names vars k src exp) + (define (compute-env label bound self rec-bound rec-labels env) + (define (add-bound-var bound label env) + (intmap-add env bound (cons self label) (lambda (old new) new))) + (if (intmap-ref shared label (lambda (_) #f)) + ;; Within a function with a shared closure, rewrite + ;; references to bound vars to use the "self" var. + (fold add-bound-var env rec-bound rec-labels) + ;; Otherwise be sure to use "self" references in any + ;; closure. + (add-bound-var bound label env))) + (match exp + (($ $fun label) + (rewrite-fun label cps env)) + (($ $rec names vars (($ $fun labels) ...)) + (fold (lambda (label var cps) + (match (intmap-ref cps label) + (($ $kfun src meta self) + (rewrite-fun label cps + (compute-env label var self vars labels + env))))) + cps labels vars)) + (_ (rename-exp label cps names vars k src exp)))) + + (define (rewrite-cont label cps) + (match (intmap-ref cps label) + (($ $kargs names vars ($ $continue k src exp)) + (visit-exp label cps names vars k src exp)) + (_ cps))) + + (intset-fold rewrite-cont (intmap-ref functions kfun) cps)) + + ;; Initial environment is bound-var -> (shared-var . label) map for + ;; functions with shared closures. + (let ((env (intmap-fold (lambda (label shared env) + (intset-fold (lambda (bound env) + (intmap-add env bound + (cons shared label))) + (intset-remove + (intmap-ref label->bound label) + (match (intmap-ref cps label) + (($ $kfun src meta self) self))) + env)) + shared + empty-intmap))) + (persistent-intmap (rewrite-fun kfun cps env)))) + +(define (compute-free-vars conts kfun shared) + "Compute a FUN-LABEL->FREE-VAR... map describing all free variable +references." + (define (add-def var defs) (intset-add! defs var)) + (define (add-defs vars defs) + (match vars + (() defs) + ((var . vars) (add-defs vars (add-def var defs))))) + (define (add-use var uses) + (intset-add! uses var)) + (define (add-uses vars uses) + (match vars + (() uses) + ((var . vars) (add-uses vars (add-use var uses))))) + (define (visit-nested-funs body) + (intset-fold + (lambda (label out) + (match (intmap-ref conts label) + (($ $kargs _ _ ($ $continue _ _ + ($ $fun kfun))) + (intmap-union out (visit-fun kfun))) + (($ $kargs _ _ ($ $continue _ _ + ($ $rec _ _ (($ $fun labels) ...)))) + (let* ((out (fold (lambda (kfun out) + (intmap-union out (visit-fun kfun))) + out labels)) + (free (fold (lambda (kfun free) + (intset-union free (intmap-ref out kfun))) + empty-intset labels))) + (fold (lambda (kfun out) + ;; For functions that share a closure, the free + ;; variables for one will be the union of the free + ;; variables for all. + (if (intmap-ref shared kfun (lambda (_) #f)) + (intmap-replace out kfun free) + out)) + out + labels))) + (_ out))) + body + empty-intmap)) + (define (visit-fun kfun) + (let* ((body (compute-function-body conts kfun)) + (free (visit-nested-funs body))) + (call-with-values + (lambda () + (intset-fold + (lambda (label defs uses) + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src exp)) + (values + (add-defs vars defs) + (match exp + ((or ($ $const) ($ $prim)) uses) + (($ $fun kfun) + (intset-union (persistent-intset uses) + (intmap-ref free kfun))) + (($ $rec names vars (($ $fun kfun) ...)) + (fold (lambda (kfun uses) + (intset-union (persistent-intset uses) + (intmap-ref free kfun))) + uses kfun)) + (($ $values args) + (add-uses args uses)) + (($ $call proc args) + (add-use proc (add-uses args uses))) + (($ $callk label proc args) + (add-use proc (add-uses args uses))) + (($ $branch kt ($ $values (arg))) + (add-use arg uses)) + (($ $branch kt ($ $primcall name args)) + (add-uses args uses)) + (($ $primcall name args) + (add-uses args uses)) + (($ $prompt escape? tag handler) + (add-use tag uses))))) + (($ $kfun src meta self) + (values (add-def self defs) uses)) + (_ (values defs uses)))) + body empty-intset empty-intset)) + (lambda (defs uses) + (intmap-add free kfun (intset-subtract + (persistent-intset uses) + (persistent-intset defs))))))) + (visit-fun kfun)) + +(define (eliminate-closure? label free-vars) + (eq? (intmap-ref free-vars label) empty-intset)) + +(define (closure-label label shared bound->label) + (cond + ((intmap-ref shared label (lambda (_) #f)) + => (lambda (closure) + (intmap-ref bound->label closure))) + (else label))) + +(define (closure-alias label well-known free-vars) + (and (intset-ref well-known label) + (trivial-intset (intmap-ref free-vars label)))) + +(define (prune-free-vars free-vars bound->label well-known shared) + "Given the label->bound-var map @var{free-vars}, remove free variables +that are known functions with zero free variables, and replace +references to well-known functions with one free variable with that free +variable, until we reach a fixed point on the free-vars map." + (define (prune-free in-label free free-vars) + (intset-fold (lambda (var free) + (match (intmap-ref bound->label var (lambda (_) #f)) + (#f free) + (label + (cond + ((eliminate-closure? label free-vars) + (intset-remove free var)) + ((closure-alias (closure-label label shared bound->label) + well-known free-vars) + => (lambda (alias) + ;; If VAR is free in LABEL, then ALIAS must + ;; also be free because its definition must + ;; precede VAR's definition. + (intset-add (intset-remove free var) alias))) + (else free))))) + free free)) + (fixpoint (lambda (free-vars) + (intmap-fold (lambda (label free free-vars) + (intmap-replace free-vars label + (prune-free label free free-vars))) + free-vars + free-vars)) + free-vars)) + +(define (intset-find set i) + (let lp ((idx 0) (start #f)) + (let ((start (intset-next set start))) + (cond + ((not start) (error "not found" set i)) + ((= start i) idx) + (else (lp (1+ idx) (1+ start))))))) + +(define (intset-count set) + (intset-fold (lambda (_ count) (1+ count)) set 0)) + +(define (convert-one cps label body free-vars bound->label well-known shared) + (define (well-known? label) + (intset-ref well-known label)) + + (let* ((free (intmap-ref free-vars label)) + (nfree (intset-count free)) + (self-known? (well-known? (closure-label label shared bound->label))) + (self (match (intmap-ref cps label) (($ $kfun _ _ self) self)))) + (define (convert-arg cps var k) + "Convert one possibly free variable reference to a bound reference. + +If @var{var} is free, it is replaced by a closure reference via a +@code{free-ref} primcall, and @var{k} is called with the new var. +Otherwise @var{var} is bound, so @var{k} is called with @var{var}." + ;; We know that var is not the name of a well-known function. + (cond + ((and=> (intmap-ref bound->label var (lambda (_) #f)) + (lambda (kfun) + (and (eq? empty-intset (intmap-ref free-vars kfun)) + kfun))) + ;; A not-well-known function with zero free vars. Copy as a + ;; constant, relying on the linker to reify just one copy. + => (lambda (kfun) + (with-cps cps + (letv var*) + (let$ body (k var*)) + (letk k* ($kargs (#f) (var*) ,body)) + (build-term ($continue k* #f ($closure kfun 0)))))) + ((intset-ref free var) + (match (vector self-known? nfree) + (#(#t 1) + ;; A reference to the one free var of a well-known function. + (with-cps cps + ($ (k self)))) + (#(#t 2) + ;; A reference to one of the two free vars in a well-known + ;; function. + (let ((op (if (= var (intset-next free)) 'car 'cdr))) + (with-cps cps + (letv var*) + (let$ body (k var*)) + (letk k* ($kargs (#f) (var*) ,body)) + (build-term ($continue k* #f ($primcall op (self))))))) + (_ + (let* ((idx (intset-find free var)) + (op (cond + ((not self-known?) 'free-ref) + ((<= idx #xff) 'vector-ref/immediate) + (else 'vector-ref)))) + (with-cps cps + (letv var*) + (let$ body (k var*)) + (letk k* ($kargs (#f) (var*) ,body)) + ($ (with-cps-constants ((idx idx)) + (build-term + ($continue k* #f ($primcall op (self idx))))))))))) + (else + (with-cps cps + ($ (k var)))))) + + (define (convert-args cps vars k) + "Convert a number of possibly free references to bound references. +@var{k} is called with the bound references, and should return the +term." + (match vars + (() + (with-cps cps + ($ (k '())))) + ((var . vars) + (convert-arg cps var + (lambda (cps var) + (convert-args cps vars + (lambda (cps vars) + (with-cps cps + ($ (k (cons var vars))))))))))) + + (define (allocate-closure cps k src label known? nfree) + "Allocate a new closure, and pass it to $var{k}." + (match (vector known? nfree) + (#(#f nfree) + ;; The call sites cannot be enumerated; allocate a closure. + (with-cps cps + (build-term ($continue k src ($closure label nfree))))) + (#(#t 2) + ;; Well-known closure with two free variables; the closure is a + ;; pair. + (with-cps cps + ($ (with-cps-constants ((false #f)) + (build-term + ($continue k src ($primcall 'cons (false false)))))))) + ;; Well-known callee with more than two free variables; the closure + ;; is a vector. + (#(#t nfree) + (unless (> nfree 2) + (error "unexpected well-known nullary, unary, or binary closure")) + (let ((op (if (<= nfree #xff) 'make-vector/immediate 'make-vector))) + (with-cps cps + ($ (with-cps-constants ((nfree nfree) + (false #f)) + (build-term + ($continue k src ($primcall op (nfree false))))))))))) + + (define (init-closure cps k src var known? free) + "Initialize the free variables @var{closure-free} in a closure +bound to @var{var}, and continue to @var{k}." + (match (vector known? (intset-count free)) + ;; Well-known callee with zero or one free variables; no + ;; initialization necessary. + (#(#t (or 0 1)) + (with-cps cps + (build-term ($continue k src ($values ()))))) + ;; Well-known callee with two free variables; do a set-car! and + ;; set-cdr!. + (#(#t 2) + (let* ((free0 (intset-next free)) + (free1 (intset-next free (1+ free0)))) + (convert-arg cps free0 + (lambda (cps v0) + (with-cps cps + (let$ body + (convert-arg free1 + (lambda (cps v1) + (with-cps cps + (build-term + ($continue k src + ($primcall 'set-cdr! (var v1)))))))) + (letk kcdr ($kargs () () ,body)) + (build-term + ($continue kcdr src ($primcall 'set-car! (var v0))))))))) + ;; Otherwise residualize a sequence of vector-set! or free-set!, + ;; depending on whether the callee is well-known or not. + (_ + (let lp ((cps cps) (prev #f) (idx 0)) + (match (intset-next free prev) + (#f (with-cps cps + (build-term ($continue k src ($values ()))))) + (v (with-cps cps + (let$ body (lp (1+ v) (1+ idx))) + (letk k ($kargs () () ,body)) + ($ (convert-arg v + (lambda (cps v) + (with-cps cps + ($ (with-cps-constants ((idx idx)) + (let ((op (cond + ((not known?) 'free-set!) + ((<= idx #xff) 'vector-set!/immediate) + (else 'vector-set!)))) + (build-term + ($continue k src + ($primcall op (var idx v)))))))))))))))))) + + (define (make-single-closure cps k src kfun) + (let ((free (intmap-ref free-vars kfun))) + (match (vector (well-known? kfun) (intset-count free)) + (#(#f 0) + (with-cps cps + (build-term ($continue k src ($closure kfun 0))))) + (#(#t 0) + (with-cps cps + (build-term ($continue k src ($const #f))))) + (#(#t 1) + ;; A well-known closure of one free variable is replaced + ;; at each use with the free variable itself, so we don't + ;; need a binding at all; and yet, the continuation + ;; expects one value, so give it something. DCE should + ;; clean up later. + (with-cps cps + (build-term ($continue k src ($const #f))))) + (#(well-known? nfree) + ;; A bit of a mess, but beta conversion should remove the + ;; final $values if possible. + (with-cps cps + (letv closure) + (letk k* ($kargs () () ($continue k src ($values (closure))))) + (let$ init (init-closure k* src closure well-known? free)) + (letk knew ($kargs (#f) (closure) ,init)) + ($ (allocate-closure knew src kfun well-known? nfree))))))) + + ;; The callee is known, but not necessarily well-known. + (define (convert-known-proc-call cps k src label closure args) + (define (have-closure cps closure) + (convert-args cps args + (lambda (cps args) + (with-cps cps + (build-term + ($continue k src ($callk label closure args))))))) + (cond + ((eq? (intmap-ref free-vars label) empty-intset) + ;; Known call, no free variables; no closure needed. + ;; Pass #f as closure argument. + (with-cps cps + ($ (with-cps-constants ((false #f)) + ($ (have-closure false)))))) + ((and (well-known? (closure-label label shared bound->label)) + (trivial-intset (intmap-ref free-vars label))) + ;; Well-known closures with one free variable are + ;; replaced at their use sites by uses of the one free + ;; variable. + => (lambda (var) + (convert-arg cps var have-closure))) + (else + ;; Otherwise just load the proc. + (convert-arg cps closure have-closure)))) + + (define (visit-term cps term) + (match term + (($ $continue k src (or ($ $const) ($ $prim))) + (with-cps cps + term)) + + (($ $continue k src ($ $fun kfun)) + (with-cps cps + ($ (make-single-closure k src kfun)))) + + ;; Remove letrec. + (($ $continue k src ($ $rec names vars (($ $fun kfuns) ...))) + (match (vector names vars kfuns) + (#(() () ()) + ;; Trivial empty case. + (with-cps cps + (build-term ($continue k src ($values ()))))) + (#((name) (var) (kfun)) + ;; Trivial single case. We have already proven that K has + ;; only LABEL as its predecessor, so we have been able + ;; already to rewrite free references to the bound name with + ;; the self name. + (with-cps cps + ($ (make-single-closure k src kfun)))) + (#(_ _ (kfun0 . _)) + ;; A non-trivial strongly-connected component. Does it have + ;; a shared closure? + (match (intmap-ref shared kfun0 (lambda (_) #f)) + (#f + ;; Nope. Allocate closures for each function. + (let lp ((cps (match (intmap-ref cps k) + ;; Steal declarations from the continuation. + (($ $kargs names vals body) + (intmap-replace cps k + (build-cont + ($kargs () () ,body)))))) + (in (map vector names vars kfuns)) + (init (lambda (cps) + (with-cps cps + (build-term + ($continue k src ($values ()))))))) + (match in + (() (init cps)) + ((#(name var kfun) . in) + (let* ((known? (well-known? kfun)) + (free (intmap-ref free-vars kfun)) + (nfree (intset-count free))) + (define (next-init cps) + (with-cps cps + (let$ body (init)) + (letk k ($kargs () () ,body)) + ($ (init-closure k src var known? free)))) + (with-cps cps + (let$ body (lp in next-init)) + (letk k ($kargs (name) (var) ,body)) + ($ (allocate-closure k src kfun known? nfree)))))))) + (shared + ;; If shared is in the bound->var map, that means one of + ;; the functions is not well-known. Otherwise use kfun0 + ;; as the function label, but just so make-single-closure + ;; can find the free vars, not for embedding in the + ;; closure. + (let* ((kfun (intmap-ref bound->label shared (lambda (_) kfun0))) + (cps (match (intmap-ref cps k) + ;; Make continuation declare only the shared + ;; closure. + (($ $kargs names vals body) + (intmap-replace cps k + (build-cont + ($kargs (#f) (shared) ,body))))))) + (with-cps cps + ($ (make-single-closure k src kfun))))))))) + + (($ $continue k src ($ $call proc args)) + (match (intmap-ref bound->label proc (lambda (_) #f)) + (#f + (convert-arg cps proc + (lambda (cps proc) + (convert-args cps args + (lambda (cps args) + (with-cps cps + (build-term + ($continue k src ($call proc args))))))))) + (label + (convert-known-proc-call cps k src label proc args)))) + + (($ $continue k src ($ $callk label proc args)) + (convert-known-proc-call cps k src label proc args)) + + (($ $continue k src ($ $primcall name args)) + (convert-args cps args + (lambda (cps args) + (with-cps cps + (build-term + ($continue k src ($primcall name args))))))) + + (($ $continue k src ($ $branch kt ($ $primcall name args))) + (convert-args cps args + (lambda (cps args) + (with-cps cps + (build-term + ($continue k src + ($branch kt ($primcall name args)))))))) + + (($ $continue k src ($ $branch kt ($ $values (arg)))) + (convert-arg cps arg + (lambda (cps arg) + (with-cps cps + (build-term + ($continue k src + ($branch kt ($values (arg))))))))) + + (($ $continue k src ($ $values args)) + (convert-args cps args + (lambda (cps args) + (with-cps cps + (build-term + ($continue k src ($values args))))))) + + (($ $continue k src ($ $prompt escape? tag handler)) + (convert-arg cps tag + (lambda (cps tag) + (with-cps cps + (build-term + ($continue k src + ($prompt escape? tag handler))))))))) + + (intset-fold (lambda (label cps) + (match (intmap-ref cps label (lambda (_) #f)) + (($ $kargs names vars term) + (with-cps cps + (let$ term (visit-term term)) + (setk label ($kargs names vars ,term)))) + (_ cps))) + body + cps))) + +(define (convert-closures cps) + "Convert free reference in @var{cps} to primcalls to @code{free-ref}, +and allocate and initialize flat closures." + (let* ((kfun 0) ;; Ass-u-me. + ;; label -> body-label... + (functions (compute-function-bodies cps kfun)) + (cps (filter-reachable cps functions)) + ;; label -> bound-var... + (label->bound (compute-function-names cps functions)) + ;; bound-var -> label + (bound->label (invert-partition label->bound)) + ;; label... + (well-known (compute-well-known-functions cps bound->label)) + ;; label -> closure-var + (shared (compute-shared-closures cps well-known)) + (cps (rewrite-shared-closure-calls cps functions label->bound shared + kfun)) + ;; label -> free-var... + (free-vars (compute-free-vars cps kfun shared)) + (free-vars (prune-free-vars free-vars bound->label well-known shared))) + (let ((free-in-program (intmap-ref free-vars kfun))) + (unless (eq? empty-intset free-in-program) + (error "Expected no free vars in program" free-in-program))) + (with-fresh-name-state cps + (persistent-intmap + (intmap-fold + (lambda (label body cps) + (convert-one cps label body free-vars bound->label well-known shared)) + functions + cps))))) + +;;; Local Variables: +;;; eval: (put 'convert-arg 'scheme-indent-function 2) +;;; eval: (put 'convert-args 'scheme-indent-function 2) +;;; End: diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm new file mode 100644 index 000000000..61f1e0781 --- /dev/null +++ b/module/language/cps/compile-bytecode.scm @@ -0,0 +1,433 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Compiling CPS to bytecode. The result is in the bytecode language, +;;; which happens to be an ELF image as a bytecode. +;;; +;;; Code: + +(define-module (language cps compile-bytecode) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (language cps) + #:use-module (language cps primitives) + #:use-module (language cps slot-allocation) + #:use-module (language cps utils) + #:use-module (language cps closure-conversion) + #:use-module (language cps optimize) + #:use-module (language cps reify-primitives) + #:use-module (language cps renumber) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:use-module (system vm assembler) + #:export (compile-bytecode)) + +(define (kw-arg-ref args kw default) + (match (memq kw args) + ((_ val . _) val) + (_ default))) + +(define (intmap-for-each f map) + (intmap-fold (lambda (k v seed) (f k v) seed) map *unspecified*)) + +(define (intmap-select map set) + (persistent-intmap + (intset-fold + (lambda (k out) + (intmap-add! out k (intmap-ref map k))) + set + empty-intmap))) + +(define (compile-function cps asm) + (let ((allocation (allocate-slots cps)) + (frame-size #f)) + (define (maybe-slot sym) + (lookup-maybe-slot sym allocation)) + + (define (slot sym) + (lookup-slot sym allocation)) + + (define (constant sym) + (lookup-constant-value sym allocation)) + + (define (maybe-mov dst src) + (unless (= dst src) + (emit-mov asm dst src))) + + (define (compile-tail label exp) + ;; There are only three kinds of expressions in tail position: + ;; tail calls, multiple-value returns, and single-value returns. + (match exp + (($ $call proc args) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation)) + (emit-tail-call asm (1+ (length args)))) + (($ $callk k proc args) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation)) + (emit-tail-call-label asm (1+ (length args)) k)) + (($ $values ()) + (emit-reset-frame asm 1) + (emit-return-values asm)) + (($ $values (arg)) + (if (maybe-slot arg) + (emit-return asm (slot arg)) + (begin + (emit-load-constant asm 1 (constant arg)) + (emit-return asm 1)))) + (($ $values args) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation)) + (emit-reset-frame asm (1+ (length args))) + (emit-return-values asm)) + (($ $primcall 'return (arg)) + (emit-return asm (slot arg))))) + + (define (compile-value label exp dst) + (match exp + (($ $values (arg)) + (maybe-mov dst (slot arg))) + (($ $const exp) + (emit-load-constant asm dst exp)) + (($ $closure k 0) + (emit-load-static-procedure asm dst k)) + (($ $closure k nfree) + (emit-make-closure asm dst k nfree)) + (($ $primcall 'current-module) + (emit-current-module asm dst)) + (($ $primcall 'cached-toplevel-box (scope name bound?)) + (emit-cached-toplevel-box asm dst (constant scope) (constant name) + (constant bound?))) + (($ $primcall 'cached-module-box (mod name public? bound?)) + (emit-cached-module-box asm dst (constant mod) (constant name) + (constant public?) (constant bound?))) + (($ $primcall 'resolve (name bound?)) + (emit-resolve asm dst (constant bound?) (slot name))) + (($ $primcall 'free-ref (closure idx)) + (emit-free-ref asm dst (slot closure) (constant idx))) + (($ $primcall 'vector-ref (vector index)) + (emit-vector-ref asm dst (slot vector) (slot index))) + (($ $primcall 'make-vector (length init)) + (emit-make-vector asm dst (slot length) (slot init))) + (($ $primcall 'make-vector/immediate (length init)) + (emit-make-vector/immediate asm dst (constant length) (slot init))) + (($ $primcall 'vector-ref/immediate (vector index)) + (emit-vector-ref/immediate asm dst (slot vector) (constant index))) + (($ $primcall 'allocate-struct (vtable nfields)) + (emit-allocate-struct asm dst (slot vtable) (slot nfields))) + (($ $primcall 'allocate-struct/immediate (vtable nfields)) + (emit-allocate-struct/immediate asm dst (slot vtable) (constant nfields))) + (($ $primcall 'struct-ref (struct n)) + (emit-struct-ref asm dst (slot struct) (slot n))) + (($ $primcall 'struct-ref/immediate (struct n)) + (emit-struct-ref/immediate asm dst (slot struct) (constant n))) + (($ $primcall 'builtin-ref (name)) + (emit-builtin-ref asm dst (constant name))) + (($ $primcall 'bv-u8-ref (bv idx)) + (emit-bv-u8-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-s8-ref (bv idx)) + (emit-bv-s8-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-u16-ref (bv idx)) + (emit-bv-u16-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-s16-ref (bv idx)) + (emit-bv-s16-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-u32-ref (bv idx val)) + (emit-bv-u32-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-s32-ref (bv idx val)) + (emit-bv-s32-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-u64-ref (bv idx val)) + (emit-bv-u64-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-s64-ref (bv idx val)) + (emit-bv-s64-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-f32-ref (bv idx val)) + (emit-bv-f32-ref asm dst (slot bv) (slot idx))) + (($ $primcall 'bv-f64-ref (bv idx val)) + (emit-bv-f64-ref asm dst (slot bv) (slot idx))) + (($ $primcall name args) + ;; FIXME: Inline all the cases. + (let ((inst (prim-instruction name))) + (emit-text asm `((,inst ,dst ,@(map slot args)))))))) + + (define (compile-effect label exp k) + (match exp + (($ $values ()) #f) + (($ $prompt escape? tag handler) + (match (intmap-ref cps handler) + (($ $kreceive ($ $arity req () rest () #f) khandler-body) + (let ((receive-args (gensym "handler")) + (nreq (length req)) + (proc-slot (lookup-call-proc-slot label allocation))) + (emit-prompt asm (slot tag) escape? proc-slot receive-args) + (emit-br asm k) + (emit-label asm receive-args) + (unless (and rest (zero? nreq)) + (emit-receive-values asm proc-slot (->bool rest) nreq)) + (when (and rest + (match (intmap-ref cps khandler-body) + (($ $kargs names (_ ... rest)) + (maybe-slot rest)))) + (emit-bind-rest asm (+ proc-slot 1 nreq))) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves handler allocation)) + (emit-reset-frame asm frame-size) + (emit-br asm khandler-body))))) + (($ $primcall 'cache-current-module! (sym scope)) + (emit-cache-current-module! asm (slot sym) (constant scope))) + (($ $primcall 'free-set! (closure idx value)) + (emit-free-set! asm (slot closure) (slot value) (constant idx))) + (($ $primcall 'box-set! (box value)) + (emit-box-set! asm (slot box) (slot value))) + (($ $primcall 'struct-set! (struct index value)) + (emit-struct-set! asm (slot struct) (slot index) (slot value))) + (($ $primcall 'struct-set!/immediate (struct index value)) + (emit-struct-set!/immediate asm (slot struct) (constant index) (slot value))) + (($ $primcall 'vector-set! (vector index value)) + (emit-vector-set! asm (slot vector) (slot index) (slot value))) + (($ $primcall 'vector-set!/immediate (vector index value)) + (emit-vector-set!/immediate asm (slot vector) (constant index) + (slot value))) + (($ $primcall 'set-car! (pair value)) + (emit-set-car! asm (slot pair) (slot value))) + (($ $primcall 'set-cdr! (pair value)) + (emit-set-cdr! asm (slot pair) (slot value))) + (($ $primcall 'define! (sym value)) + (emit-define! asm (slot sym) (slot value))) + (($ $primcall 'push-fluid (fluid val)) + (emit-push-fluid asm (slot fluid) (slot val))) + (($ $primcall 'pop-fluid ()) + (emit-pop-fluid asm)) + (($ $primcall 'wind (winder unwinder)) + (emit-wind asm (slot winder) (slot unwinder))) + (($ $primcall 'bv-u8-set! (bv idx val)) + (emit-bv-u8-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-s8-set! (bv idx val)) + (emit-bv-s8-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-u16-set! (bv idx val)) + (emit-bv-u16-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-s16-set! (bv idx val)) + (emit-bv-s16-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-u32-set! (bv idx val)) + (emit-bv-u32-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-s32-set! (bv idx val)) + (emit-bv-s32-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-u64-set! (bv idx val)) + (emit-bv-u64-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-s64-set! (bv idx val)) + (emit-bv-s64-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-f32-set! (bv idx val)) + (emit-bv-f32-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'bv-f64-set! (bv idx val)) + (emit-bv-f64-set! asm (slot bv) (slot idx) (slot val))) + (($ $primcall 'unwind ()) + (emit-unwind asm)))) + + (define (compile-values label exp syms) + (match exp + (($ $values args) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation))))) + + (define (compile-test label exp kt kf next-label) + (define (unary op sym) + (cond + ((eq? kt next-label) + (op asm (slot sym) #t kf)) + (else + (op asm (slot sym) #f kt) + (unless (eq? kf next-label) + (emit-br asm kf))))) + (define (binary op a b) + (cond + ((eq? kt next-label) + (op asm (slot a) (slot b) #t kf)) + (else + (op asm (slot a) (slot b) #f kt) + (unless (eq? kf next-label) + (emit-br asm kf))))) + (match exp + (($ $values (sym)) + (call-with-values (lambda () + (lookup-maybe-constant-value sym allocation)) + (lambda (has-const? val) + (if has-const? + (if val + (unless (eq? kt next-label) + (emit-br asm kt)) + (unless (eq? kf next-label) + (emit-br asm kf))) + (unary emit-br-if-true sym))))) + (($ $primcall 'null? (a)) (unary emit-br-if-null a)) + (($ $primcall 'nil? (a)) (unary emit-br-if-nil a)) + (($ $primcall 'pair? (a)) (unary emit-br-if-pair a)) + (($ $primcall 'struct? (a)) (unary emit-br-if-struct a)) + (($ $primcall 'char? (a)) (unary emit-br-if-char a)) + (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a)) + (($ $primcall 'variable? (a)) (unary emit-br-if-variable a)) + (($ $primcall 'vector? (a)) (unary emit-br-if-vector a)) + (($ $primcall 'string? (a)) (unary emit-br-if-string a)) + (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a)) + (($ $primcall 'bitvector? (a)) (unary emit-br-if-bitvector a)) + (($ $primcall 'keyword? (a)) (unary emit-br-if-keyword a)) + ;; Add more TC7 tests here. Keep in sync with + ;; *branching-primcall-arities* in (language cps primitives) and + ;; the set of macro-instructions in assembly.scm. + (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b)) + (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b)) + (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b)) + (($ $primcall '< (a b)) (binary emit-br-if-< a b)) + (($ $primcall '<= (a b)) (binary emit-br-if-<= a b)) + (($ $primcall '= (a b)) (binary emit-br-if-= a b)) + (($ $primcall '>= (a b)) (binary emit-br-if-<= b a)) + (($ $primcall '> (a b)) (binary emit-br-if-< b a)) + (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b)))) + + (define (compile-trunc label k exp nreq rest-var) + (define (do-call proc args emit-call) + (let* ((proc-slot (lookup-call-proc-slot label allocation)) + (nargs (1+ (length args))) + (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs)))) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves label allocation)) + (emit-call asm proc-slot nargs) + (emit-dead-slot-map asm proc-slot + (lookup-dead-slot-map label allocation)) + (cond + ((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var)) + (match (lookup-parallel-moves k allocation) + ((((? (lambda (src) (= src (1+ proc-slot))) src) + . dst)) dst) + (_ #f))) + ;; The usual case: one required live return value, ignoring + ;; any additional values. + => (lambda (dst) + (emit-receive asm dst proc-slot frame-size))) + (else + (unless (and (zero? nreq) rest-var) + (emit-receive-values asm proc-slot (->bool rest-var) nreq)) + (when (and rest-var (maybe-slot rest-var)) + (emit-bind-rest asm (+ proc-slot 1 nreq))) + (for-each (match-lambda + ((src . dst) (emit-mov asm dst src))) + (lookup-parallel-moves k allocation)) + (emit-reset-frame asm frame-size))))) + (match exp + (($ $call proc args) + (do-call proc args + (lambda (asm proc-slot nargs) + (emit-call asm proc-slot nargs)))) + (($ $callk k proc args) + (do-call proc args + (lambda (asm proc-slot nargs) + (emit-call-label asm proc-slot nargs k)))))) + + (define (compile-expression label k exp) + (let* ((fallthrough? (= k (1+ label)))) + (define (maybe-emit-jump) + (unless fallthrough? + (emit-br asm k))) + (match (intmap-ref cps k) + (($ $ktail) + (compile-tail label exp)) + (($ $kargs (name) (sym)) + (let ((dst (maybe-slot sym))) + (when dst + (compile-value label exp dst))) + (maybe-emit-jump)) + (($ $kargs () ()) + (match exp + (($ $branch kt exp) + (compile-test label exp kt k (1+ label))) + (_ + (compile-effect label exp k) + (maybe-emit-jump)))) + (($ $kargs names syms) + (compile-values label exp syms) + (maybe-emit-jump)) + (($ $kreceive ($ $arity req () rest () #f) kargs) + (compile-trunc label k exp (length req) + (and rest + (match (intmap-ref cps kargs) + (($ $kargs names (_ ... rest)) rest)))) + (unless (and fallthrough? (= kargs (1+ k))) + (emit-br asm kargs)))))) + + (define (compile-cont label cont) + (match cont + (($ $kfun src meta self tail clause) + (when src + (emit-source asm src)) + (emit-begin-program asm label meta)) + (($ $kclause ($ $arity req opt rest kw allow-other-keys?) body alt) + (let ((first? (match (intmap-ref cps (1- label)) + (($ $kfun) #t) + (_ #f))) + (kw-indices (map (match-lambda + ((key name sym) + (cons key (lookup-slot sym allocation)))) + kw))) + (unless first? + (emit-end-arity asm)) + (emit-label asm label) + (set! frame-size (lookup-nlocals label allocation)) + (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys? + frame-size alt))) + (($ $kargs names vars ($ $continue k src exp)) + (emit-label asm label) + (for-each (lambda (name var) + (let ((slot (maybe-slot var))) + (when slot + (emit-definition asm name slot)))) + names vars) + (when src + (emit-source asm src)) + (compile-expression label k exp)) + (($ $kreceive arity kargs) + (emit-label asm label)) + (($ $ktail) + (emit-end-arity asm) + (emit-end-program asm)))) + + (intmap-for-each compile-cont cps))) + +(define (emit-bytecode exp env opts) + (let ((asm (make-assembler))) + (intmap-for-each (lambda (kfun body) + (compile-function (intmap-select exp body) asm)) + (compute-reachable-functions exp 0)) + (values (link-assembly asm #:page-aligned? (kw-arg-ref opts #:to-file? #f)) + env + env))) + +(define (lower-cps exp opts) + (set! exp (optimize-higher-order-cps exp opts)) + (set! exp (convert-closures exp)) + (set! exp (optimize-first-order-cps exp opts)) + (set! exp (reify-primitives exp)) + (renumber exp)) + +(define (compile-bytecode exp env opts) + (set! exp (lower-cps exp opts)) + (emit-bytecode exp env opts)) diff --git a/module/language/cps/constructors.scm b/module/language/cps/constructors.scm new file mode 100644 index 000000000..f86095198 --- /dev/null +++ b/module/language/cps/constructors.scm @@ -0,0 +1,98 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Constructor inlining turns "list" primcalls into a series of conses, +;;; and does similar transformations for "vector". +;;; +;;; Code: + +(define-module (language cps constructors) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps with-cps) + #:use-module (language cps intmap) + #:export (inline-constructors)) + +(define (inline-list out k src args) + (define (build-list out args k) + (match args + (() + (with-cps out + (build-term ($continue k src ($const '()))))) + ((arg . args) + (with-cps out + (letv tail) + (letk ktail ($kargs ('tail) (tail) + ($continue k src + ($primcall 'cons (arg tail))))) + ($ (build-list args ktail)))))) + (with-cps out + (letv val) + (letk kvalues ($kargs ('val) (val) + ($continue k src + ($primcall 'values (val))))) + ($ (build-list args kvalues)))) + +(define (inline-vector out k src args) + (define (initialize out vec args n) + (match args + (() + (with-cps out + (build-term ($continue k src ($primcall 'values (vec)))))) + ((arg . args) + (with-cps out + (let$ next (initialize vec args (1+ n))) + (letk knext ($kargs () () ,next)) + ($ (with-cps-constants ((idx n)) + (build-term ($continue knext src + ($primcall 'vector-set! (vec idx arg)))))))))) + (with-cps out + (letv vec) + (let$ body (initialize vec args 0)) + (letk kalloc ($kargs ('vec) (vec) ,body)) + ($ (with-cps-constants ((len (length args)) + (init #f)) + (build-term ($continue kalloc src + ($primcall 'make-vector (len init)))))))) + +(define (find-constructor-inliner name) + (match name + ('list inline-list) + ('vector inline-vector) + (_ #f))) + +(define (inline-constructors conts) + (with-fresh-name-state conts + (persistent-intmap + (intmap-fold + (lambda (label cont out) + (match cont + (($ $kargs names vars ($ $continue k src ($ $primcall name args))) + (let ((inline (find-constructor-inliner name))) + (if inline + (call-with-values (lambda () (inline out k src args)) + (lambda (out term) + (intmap-replace! out label + (build-cont ($kargs names vars ,term))))) + out))) + (_ out))) + conts + conts)))) diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm new file mode 100644 index 000000000..4a398d7e5 --- /dev/null +++ b/module/language/cps/contification.scm @@ -0,0 +1,475 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Contification is a pass that turns $fun instances into $cont +;;; instances if all calls to the $fun return to the same continuation. +;;; This is a more rigorous variant of our old "fixpoint labels +;;; allocation" optimization. +;;; +;;; See Kennedy's "Compiling with Continuations, Continued", and Fluet +;;; and Weeks's "Contification using Dominators". +;;; +;;; Code: + +(define-module (language cps contification) + #:use-module (ice-9 match) + #:use-module (srfi srfi-11) + #:use-module ((srfi srfi-1) #:select (fold)) + #:use-module (language cps) + #:use-module (language cps renumber) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (contify)) + +(define (compute-singly-referenced-labels conts) + "Compute the set of labels in CONTS that have exactly one +predecessor." + (define (add-ref label cont single multiple) + (define (ref k single multiple) + (if (intset-ref single k) + (values single (intset-add! multiple k)) + (values (intset-add! single k) multiple))) + (define (ref0) (values single multiple)) + (define (ref1 k) (ref k single multiple)) + (define (ref2 k k*) + (if k* + (let-values (((single multiple) (ref k single multiple))) + (ref k* single multiple)) + (ref1 k))) + (match cont + (($ $kreceive arity k) (ref1 k)) + (($ $kfun src meta self ktail kclause) (ref2 ktail kclause)) + (($ $ktail) (ref0)) + (($ $kclause arity kbody kalt) (ref2 kbody kalt)) + (($ $kargs names syms ($ $continue k src exp)) + (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f)))))) + (let*-values (((single multiple) (values empty-intset empty-intset)) + ((single multiple) (intmap-fold add-ref conts single multiple))) + (intset-subtract (persistent-intset single) + (persistent-intset multiple)))) + +(define (compute-functions conts) + "Compute a map from $kfun label to bound variable names for all +functions in CONTS. Functions have two bound variable names: their self +binding, and the name they are given in their continuation. If their +continuation has more than one predecessor, then the bound variable name +doesn't uniquely identify the function, so we exclude that function from +the set." + (define (function-self label) + (match (intmap-ref conts label) + (($ $kfun src meta self) self))) + (let ((single (compute-singly-referenced-labels conts))) + (intmap-fold (lambda (label cont functions) + (match cont + (($ $kargs _ _ ($ $continue k src ($ $fun kfun))) + (if (intset-ref single k) + (match (intmap-ref conts k) + (($ $kargs (name) (var)) + (intmap-add functions kfun + (intset var (function-self kfun))))) + functions)) + (($ $kargs _ _ ($ $continue k src + ($ $rec _ vars (($ $fun kfuns) ...)))) + (if (intset-ref single k) + (fold (lambda (var kfun functions) + (intmap-add functions kfun + (intset var (function-self kfun)))) + functions vars kfuns) + functions)) + (_ functions))) + conts + empty-intmap))) + +(define (compute-multi-clause conts) + "Compute an set containing all labels that are part of a multi-clause +case-lambda. See the note in compute-contification-candidates." + (define (multi-clause? clause) + (and clause + (match (intmap-ref conts clause) + (($ $kclause arity body alt) + alt)))) + (intmap-fold (lambda (label cont multi) + (match cont + (($ $kfun src meta self tail clause) + (if (multi-clause? clause) + (intset-union multi (compute-function-body conts label)) + multi)) + (_ multi))) + conts + empty-intset)) + +(define (compute-arities conts functions) + "Given the map FUNCTIONS whose keys are $kfun labels, return a map +from label to arities." + (define (clause-arities clause) + (if clause + (match (intmap-ref conts clause) + (($ $kclause arity body alt) + (cons arity (clause-arities alt)))) + '())) + (intmap-map (lambda (label vars) + (match (intmap-ref conts label) + (($ $kfun src meta self tail clause) + (clause-arities clause)))) + functions)) + +;; For now, we don't contify functions with optional, keyword, or rest +;; arguments. +(define (contifiable-arity? arity) + (match arity + (($ $arity req () #f () aok?) + #t) + (_ + #f))) + +(define (arity-matches? arity nargs) + (match arity + (($ $arity req () #f () aok?) + (= nargs (length req))) + (_ + #f))) + +(define (compute-contification-candidates conts) + "Compute and return a label -> (variable ...) map describing all +functions with known uses that are only ever used as the operator of a +$call, and are always called with a compatible arity." + (let* ((functions (compute-functions conts)) + (multi-clause (compute-multi-clause conts)) + (vars (intmap-fold (lambda (label vars out) + (intset-fold (lambda (var out) + (intmap-add out var label)) + vars out)) + functions + empty-intmap)) + (arities (compute-arities conts functions))) + (define (restrict-arity functions proc nargs) + (match (intmap-ref vars proc (lambda (_) #f)) + (#f functions) + (label + (let lp ((arities (intmap-ref arities label))) + (match arities + (() (intmap-remove functions label)) + ((arity . arities) + (cond + ((not (contifiable-arity? arity)) (lp '())) + ((arity-matches? arity nargs) functions) + (else (lp arities))))))))) + (define (visit-cont label cont functions) + (define (exclude-var functions var) + (match (intmap-ref vars var (lambda (_) #f)) + (#f functions) + (label (intmap-remove functions label)))) + (define (exclude-vars functions vars) + (match vars + (() functions) + ((var . vars) + (exclude-vars (exclude-var functions var) vars)))) + (match cont + (($ $kargs _ _ ($ $continue _ _ exp)) + (match exp + ((or ($ $const) ($ $prim) ($ $closure) ($ $fun) ($ $rec)) + functions) + (($ $values args) + (exclude-vars functions args)) + (($ $call proc args) + (let ((functions (exclude-vars functions args))) + ;; This contification algorithm is happy to contify the + ;; `lp' in this example into a shared tail between clauses: + ;; + ;; (letrec ((lp (lambda () (lp)))) + ;; (case-lambda + ;; ((a) (lp)) + ;; ((a b) (lp)))) + ;; + ;; However because the current compilation pipeline has to + ;; re-nest continuations into old CPS, there would be no + ;; scope in which the tail would be valid. So, until the + ;; old compilation pipeline is completely replaced, + ;; conservatively exclude contifiable fucntions called + ;; from multi-clause procedures. + (if (intset-ref multi-clause label) + (exclude-var functions proc) + (restrict-arity functions proc (length args))))) + (($ $callk k proc args) + (exclude-vars functions (cons proc args))) + (($ $branch kt ($ $primcall name args)) + (exclude-vars functions args)) + (($ $branch kt ($ $values (arg))) + (exclude-var functions arg)) + (($ $primcall name args) + (exclude-vars functions args)) + (($ $prompt escape? tag handler) + (exclude-var functions tag)))) + (_ functions))) + (intmap-fold visit-cont conts functions))) + +(define (compute-call-graph conts labels vars) + "Given the set of contifiable functions LABELS and associated bound +variables VARS, compute and return two values: a map +LABEL->LABEL... indicating the contifiable functions called by a +function, and a map LABEL->LABEL... indicating the return continuations +for a function. The first return value also has an entry +0->LABEL... indicating all contifiable functions called by +non-contifiable functions. We assume that 0 is not in the contifiable +function set." + (let ((bodies + ;; label -> fun-label for all labels in bodies of contifiable + ;; functions + (intset-fold (lambda (fun-label bodies) + (intset-fold (lambda (label bodies) + (intmap-add bodies label fun-label)) + (compute-function-body conts fun-label) + bodies)) + labels + empty-intmap))) + (when (intset-ref labels 0) + (error "internal error: label 0 should not be contifiable")) + (intmap-fold + (lambda (label cont calls returns) + (match cont + (($ $kargs _ _ ($ $continue k src ($ $call proc))) + (match (intmap-ref vars proc (lambda (_) #f)) + (#f (values calls returns)) + (callee + (let ((caller (intmap-ref bodies label (lambda (_) 0)))) + (values (intmap-add calls caller callee intset-add) + (intmap-add returns callee k intset-add)))))) + (_ (values calls returns)))) + conts + (intset->intmap (lambda (label) empty-intset) (intset-add labels 0)) + (intset->intmap (lambda (label) empty-intset) labels)))) + +(define (tail-label conts label) + (match (intmap-ref conts label) + (($ $kfun src meta self tail body) + tail))) + +(define (compute-return-labels labels tails returns return-substs) + (define (subst k) + (match (intmap-ref return-substs k (lambda (_) #f)) + (#f k) + (k (subst k)))) + ;; Compute all return labels, then subtract tail labels of the + ;; functions in question. + (intset-subtract + ;; Return labels for all calls to these labels. + (intset-fold (lambda (label out) + (intset-fold (lambda (k out) + (intset-add out (subst k))) + (intmap-ref returns label) + out)) + labels + empty-intset) + (intset-fold (lambda (label out) + (intset-add out (intmap-ref tails label))) + labels + empty-intset))) + +(define (intmap->intset map) + (define (add-key label cont labels) + (intset-add labels label)) + (intmap-fold add-key map empty-intset)) + +(define (filter-contifiable contified groups) + (intmap-fold (lambda (id labels groups) + (let ((labels (intset-subtract labels contified))) + (if (eq? empty-intset labels) + groups + (intmap-add groups id labels)))) + groups + empty-intmap)) + +(define (trivial-set set) + (let ((first (intset-next set))) + (and first + (not (intset-next set (1+ first))) + first))) + +(define (compute-contification conts) + (let*-values + (;; label -> (var ...) + ((candidates) (compute-contification-candidates conts)) + ((labels) (intmap->intset candidates)) + ;; var -> label + ((vars) (intmap-fold (lambda (label vars out) + (intset-fold (lambda (var out) + (intmap-add out var label)) + vars out)) + candidates + empty-intmap)) + ;; caller-label -> callee-label..., callee-label -> return-label... + ((calls returns) (compute-call-graph conts labels vars)) + ;; callee-label -> tail-label + ((tails) (intset-fold + (lambda (label tails) + (intmap-add tails label (tail-label conts label))) + labels + empty-intmap)) + ;; Strongly connected components, allowing us to contify mutually + ;; tail-recursive functions. Since `compute-call-graph' added on + ;; a synthetic 0->LABEL... entry for contifiable functions called + ;; by non-contifiable functions, we need to remove that entry + ;; from the partition. It will be in its own component, as it + ;; has no predecessors. + ;; + ;; id -> label... + ((groups) (intmap-remove + (compute-strongly-connected-components calls 0) + 0))) + ;; todo: thread groups through contification + (define (attempt-contification labels contified return-substs) + (let ((returns (compute-return-labels labels tails returns + return-substs))) + (cond + ((trivial-set returns) + => (lambda (k) + ;; Success! + (values (intset-union contified labels) + (intset-fold (lambda (label return-substs) + (let ((tail (intmap-ref tails label))) + (intmap-add return-substs tail k))) + labels return-substs)))) + ((trivial-set labels) + ;; Single-label SCC failed to contify. + (values contified return-substs)) + (else + ;; Multi-label SCC failed to contify. Try instead to contify + ;; each one. + (intset-fold + (lambda (label contified return-substs) + (let ((labels (intset-add empty-intset label))) + (attempt-contification labels contified return-substs))) + labels contified return-substs))))) + (call-with-values + (lambda () + (fixpoint + (lambda (contified return-substs) + (intmap-fold + (lambda (id group contified return-substs) + (attempt-contification group contified return-substs)) + (filter-contifiable contified groups) + contified + return-substs)) + empty-intset + empty-intmap)) + (lambda (contified return-substs) + (values (intset-fold (lambda (label call-substs) + (intset-fold + (lambda (var call-substs) + (intmap-add call-substs var label)) + (intmap-ref candidates label) + call-substs)) + contified + empty-intmap) + return-substs))))) + +(define (apply-contification conts call-substs return-substs) + (define (call-subst proc) + (intmap-ref call-substs proc (lambda (_) #f))) + (define (return-subst k) + (intmap-ref return-substs k (lambda (_) #f))) + (define (find-body kfun nargs) + (match (intmap-ref conts kfun) + (($ $kfun src meta self tail clause) + (let lp ((clause clause)) + (match (intmap-ref conts clause) + (($ $kclause arity body alt) + (if (arity-matches? arity nargs) + body + (lp alt)))))))) + (define (continue k src exp) + (define (lookup-return-cont k) + (match (return-subst k) + (#f k) + (k (lookup-return-cont k)))) + (let ((k* (lookup-return-cont k))) + (if (eq? k k*) + (build-term ($continue k src ,exp)) + ;; We are contifying this return. It must be a call, a + ;; $values expression, or a return primcall. k* will be + ;; either a $ktail or a $kreceive continuation. CPS has this + ;; thing though where $kreceive can't be the target of a + ;; $values expression, and "return" can only continue to a + ;; tail continuation, so we might have to rewrite to a + ;; "values" primcall. + (build-term + ($continue k* src + ,(match (intmap-ref conts k*) + (($ $kreceive) + (match exp + (($ $primcall 'return (val)) + (build-exp ($primcall 'values (val)))) + (($ $call) exp) + ;; Except for 'return, a primcall that can continue + ;; to $ktail can also continue to $kreceive. TODO: + ;; replace 'return with 'values, for consistency. + (($ $primcall) exp) + (($ $values vals) + (build-exp ($primcall 'values vals))))) + (($ $ktail) exp))))))) + (define (visit-exp k src exp) + (match exp + (($ $call proc args) + ;; If proc is contifiable, replace call with jump. + (match (call-subst proc) + (#f (continue k src exp)) + (kfun + (let ((body (find-body kfun (length args)))) + (build-term ($continue body src ($values args))))))) + (($ $fun kfun) + ;; If the function's tail continuation has been + ;; substituted, that means it has been contified. + (if (return-subst (tail-label conts kfun)) + (continue k src (build-exp ($values ()))) + (continue k src exp))) + (($ $rec names vars funs) + (match (filter (match-lambda ((n v f) (not (call-subst v)))) + (map list names vars funs)) + (() (continue k src (build-exp ($values ())))) + (((names vars funs) ...) + (continue k src (build-exp ($rec names vars funs)))))) + (_ (continue k src exp)))) + + ;; Renumbering is not strictly necessary but some passes may not be + ;; equipped to deal with stale $kfun nodes whose bodies have been + ;; wired into other functions. + (renumber + (intmap-map + (lambda (label cont) + (match cont + (($ $kargs names vars ($ $continue k src exp)) + ;; Remove bindings for functions that have been contified. + (match (filter (match-lambda ((name var) (not (call-subst var)))) + (map list names vars)) + (((names vars) ...) + (build-cont + ($kargs names vars ,(visit-exp k src exp)))))) + (_ cont))) + conts))) + +(define (contify conts) + ;; FIXME: Renumbering isn't really needed but dead continuations may + ;; cause compute-singly-referenced-labels to spuriously mark some + ;; conts as irreducible. For now we punt and renumber so that there + ;; are only live conts. + (let ((conts (renumber conts))) + (let-values (((call-substs return-substs) (compute-contification conts))) + (apply-contification conts call-substs return-substs)))) diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm new file mode 100644 index 000000000..def542063 --- /dev/null +++ b/module/language/cps/cse.scm @@ -0,0 +1,449 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Common subexpression elimination for CPS. +;;; +;;; Code: + +(define-module (language cps cse) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps effects-analysis) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (eliminate-common-subexpressions)) + +(define (intset-pop set) + (match (intset-next set) + (#f (values set #f)) + (i (values (intset-remove set i) i)))) + +(define-syntax-rule (make-worklist-folder* seed ...) + (lambda (f worklist seed ...) + (let lp ((worklist worklist) (seed seed) ...) + (call-with-values (lambda () (intset-pop worklist)) + (lambda (worklist i) + (if i + (call-with-values (lambda () (f i seed ...)) + (lambda (i* seed ...) + (let add ((i* i*) (worklist worklist)) + (match i* + (() (lp worklist seed ...)) + ((i . i*) (add i* (intset-add worklist i))))))) + (values seed ...))))))) + +(define worklist-fold* + (case-lambda + ((f worklist seed) + ((make-worklist-folder* seed) f worklist seed)))) + +(define (compute-available-expressions conts kfun effects) + "Compute and return a map of LABEL->ANCESTOR..., where ANCESTOR... is +an intset containing ancestor labels whose value is available at LABEL." + (define (propagate avail succ out) + (let* ((in (intmap-ref avail succ (lambda (_) #f))) + (in* (if in (intset-intersect in out) out))) + (if (eq? in in*) + (values '() avail) + (values (list succ) + (intmap-add avail succ in* (lambda (old new) new)))))) + + (define (clobber label in) + (let ((fx (intmap-ref effects label))) + (cond + ((not (causes-effect? fx &write)) + ;; Fast-path if this expression clobbers nothing. + in) + (else + ;; Kill clobbered expressions. FIXME: there is no need to check + ;; on any label before than the last dominating label that + ;; clobbered everything. Another way to speed things up would + ;; be to compute a clobber set per-effect, which we could + ;; subtract from "in". + (let lp ((label 0) (in in)) + (cond + ((intset-next in label) + => (lambda (label) + (if (effect-clobbers? fx (intmap-ref effects label)) + (lp (1+ label) (intset-remove in label)) + (lp (1+ label) in)))) + (else in))))))) + + (define (visit-cont label avail) + (let* ((in (intmap-ref avail label)) + (out (intset-add (clobber label in) label))) + (define (propagate0) + (values '() avail)) + (define (propagate1 succ) + (propagate avail succ out)) + (define (propagate2 succ0 succ1) + (let*-values (((changed0 avail) (propagate avail succ0 out)) + ((changed1 avail) (propagate avail succ1 out))) + (values (append changed0 changed1) avail))) + + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src exp)) + (match exp + (($ $branch kt) (propagate2 k kt)) + (($ $prompt escape? tag handler) (propagate2 k handler)) + (_ (propagate1 k)))) + (($ $kreceive arity k) + (propagate1 k)) + (($ $kfun src meta self tail clause) + (if clause + (propagate1 clause) + (propagate0))) + (($ $kclause arity kbody kalt) + (if kalt + (propagate2 kbody kalt) + (propagate1 kbody))) + (($ $ktail) (propagate0))))) + + (worklist-fold* visit-cont + (intset kfun) + (intmap-add empty-intmap kfun empty-intset))) + +(define (compute-truthy-expressions conts kfun boolv) + "Compute a \"truth map\", indicating which expressions can be shown to +be true and/or false at each label in the function starting at KFUN.. +Returns an intmap of intsets. The even elements of the intset indicate +labels that may be true, and the odd ones indicate those that may be +false. It could be that both true and false proofs are available." + (define (true-idx label) (ash label 1)) + (define (false-idx label) (1+ (ash label 1))) + + (define (propagate boolv succ out) + (let* ((in (intmap-ref boolv succ (lambda (_) #f))) + (in* (if in (intset-intersect in out) out))) + (if (eq? in in*) + (values '() boolv) + (values (list succ) + (intmap-add boolv succ in* (lambda (old new) new)))))) + + (define (visit-cont label boolv) + (let ((in (intmap-ref boolv label))) + (define (propagate0) + (values '() boolv)) + (define (propagate1 succ) + (propagate boolv succ in)) + (define (propagate2 succ0 succ1) + (let*-values (((changed0 boolv) (propagate boolv succ0 in)) + ((changed1 boolv) (propagate boolv succ1 in))) + (values (append changed0 changed1) boolv))) + (define (propagate-branch succ0 succ1) + (let*-values (((changed0 boolv) + (propagate boolv succ0 + (intset-add in (false-idx label)))) + ((changed1 boolv) + (propagate boolv succ1 + (intset-add in (true-idx label))))) + (values (append changed0 changed1) boolv))) + + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src exp)) + (match exp + (($ $branch kt) (propagate-branch k kt)) + (($ $prompt escape? tag handler) (propagate2 k handler)) + (_ (propagate1 k)))) + (($ $kreceive arity k) + (propagate1 k)) + (($ $kfun src meta self tail clause) + (if clause + (propagate1 clause) + (propagate0))) + (($ $kclause arity kbody kalt) + (if kalt + (propagate2 kbody kalt) + (propagate1 kbody))) + (($ $ktail) (propagate0))))) + + (let ((boolv (worklist-fold* visit-cont + (intset kfun) + (intmap-add boolv kfun empty-intset)))) + ;; Now visit nested functions. We don't do this in the worklist + ;; folder because that would be exponential. + (define (recurse kfun boolv) + (compute-truthy-expressions conts kfun boolv)) + (intset-fold + (lambda (label boolv) + (match (intmap-ref conts label) + (($ $kargs _ _ ($ $continue _ _ exp)) + (match exp + (($ $fun kfun) (recurse kfun boolv)) + (($ $rec _ _ (($ $fun kfun) ...)) (fold recurse boolv kfun)) + (_ boolv))) + (_ boolv))) + (compute-function-body conts kfun) + boolv))) + +(define (intset-map f set) + (persistent-intmap + (intset-fold (lambda (i out) (intmap-add! out i (f i))) + set + empty-intmap))) + +;; Returns a map of label-idx -> (var-idx ...) indicating the variables +;; defined by a given labelled expression. +(define (compute-defs conts kfun) + (intset-map (lambda (label) + (match (intmap-ref conts label) + (($ $kfun src meta self tail clause) + (list self)) + (($ $kclause arity body alt) + (match (intmap-ref conts body) + (($ $kargs names vars) vars))) + (($ $kreceive arity kargs) + (match (intmap-ref conts kargs) + (($ $kargs names vars) vars))) + (($ $ktail) + '()) + (($ $kargs names vars ($ $continue k)) + (match (intmap-ref conts k) + (($ $kargs names vars) vars) + (_ #f))))) + (compute-function-body conts kfun))) + +(define (compute-singly-referenced succs) + (define (visit label succs single multiple) + (intset-fold (lambda (label single multiple) + (if (intset-ref single label) + (values single (intset-add! multiple label)) + (values (intset-add! single label) multiple))) + succs single multiple)) + (call-with-values (lambda () + (intmap-fold visit succs empty-intset empty-intset)) + (lambda (single multiple) + (intset-subtract (persistent-intset single) + (persistent-intset multiple))))) + +(define (compute-equivalent-subexpressions conts kfun effects + equiv-labels var-substs) + (let* ((succs (compute-successors conts kfun)) + (singly-referenced (compute-singly-referenced succs)) + (avail (compute-available-expressions conts kfun effects)) + (defs (compute-defs conts kfun)) + (equiv-set (make-hash-table))) + (define (subst-var var-substs var) + (intmap-ref var-substs var (lambda (var) var))) + (define (subst-vars var-substs vars) + (let lp ((vars vars)) + (match vars + (() '()) + ((var . vars) (cons (subst-var var-substs var) (lp vars)))))) + + (define (compute-exp-key var-substs exp) + (match exp + (($ $const val) (cons 'const val)) + (($ $prim name) (cons 'prim name)) + (($ $fun body) #f) + (($ $rec names syms funs) #f) + (($ $call proc args) #f) + (($ $callk k proc args) #f) + (($ $primcall name args) + (cons* 'primcall name (subst-vars var-substs args))) + (($ $branch _ ($ $primcall name args)) + (cons* 'primcall name (subst-vars var-substs args))) + (($ $branch) #f) + (($ $values args) #f) + (($ $prompt escape? tag handler) #f))) + + (define (add-auxiliary-definitions! label var-substs exp-key) + (define (subst var) + (subst-var var-substs var)) + (let ((defs (intmap-ref defs label))) + (define (add-def! aux-key var) + (let ((equiv (hash-ref equiv-set aux-key '()))) + (hash-set! equiv-set aux-key + (acons label (list var) equiv)))) + (match exp-key + (('primcall 'box val) + (match defs + ((box) + (add-def! `(primcall box-ref ,(subst box)) val)))) + (('primcall 'box-set! box val) + (add-def! `(primcall box-ref ,box) val)) + (('primcall 'cons car cdr) + (match defs + ((pair) + (add-def! `(primcall car ,(subst pair)) car) + (add-def! `(primcall cdr ,(subst pair)) cdr)))) + (('primcall 'set-car! pair car) + (add-def! `(primcall car ,pair) car)) + (('primcall 'set-cdr! pair cdr) + (add-def! `(primcall cdr ,pair) cdr)) + (('primcall (or 'make-vector 'make-vector/immediate) len fill) + (match defs + ((vec) + (add-def! `(primcall vector-length ,(subst vec)) len)))) + (('primcall 'vector-set! vec idx val) + (add-def! `(primcall vector-ref ,vec ,idx) val)) + (('primcall 'vector-set!/immediate vec idx val) + (add-def! `(primcall vector-ref/immediate ,vec ,idx) val)) + (('primcall (or 'allocate-struct 'allocate-struct/immediate) + vtable size) + (match defs + ((struct) + (add-def! `(primcall struct-vtable ,(subst struct)) + vtable)))) + (('primcall 'struct-set! struct n val) + (add-def! `(primcall struct-ref ,struct ,n) val)) + (('primcall 'struct-set!/immediate struct n val) + (add-def! `(primcall struct-ref/immediate ,struct ,n) val)) + (_ #t)))) + + (define (visit-label label equiv-labels var-substs) + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src exp)) + (let* ((exp-key (compute-exp-key var-substs exp)) + (equiv (hash-ref equiv-set exp-key '())) + (fx (intmap-ref effects label)) + (avail (intmap-ref avail label))) + (define (finish equiv-labels var-substs) + (define (recurse kfun equiv-labels var-substs) + (compute-equivalent-subexpressions conts kfun effects + equiv-labels var-substs)) + ;; If this expression defines auxiliary definitions, + ;; as `cons' does for the results of `car' and `cdr', + ;; define those. Do so after finding equivalent + ;; expressions, so that we can take advantage of + ;; subst'd output vars. + (add-auxiliary-definitions! label var-substs exp-key) + (match exp + ;; If we see a $fun, recurse to add to the result. + (($ $fun kfun) + (recurse kfun equiv-labels var-substs)) + (($ $rec names vars (($ $fun kfun) ...)) + (fold2 recurse kfun equiv-labels var-substs)) + (_ + (values equiv-labels var-substs)))) + (let lp ((candidates equiv)) + (match candidates + (() + ;; No matching expressions. Add our expression + ;; to the equivalence set, if appropriate. Note + ;; that expressions that allocate a fresh object + ;; or change the current fluid environment can't + ;; be eliminated by CSE (though DCE might do it + ;; if the value proves to be unused, in the + ;; allocation case). + (when (and exp-key + (not (causes-effect? fx &allocation)) + (not (effect-clobbers? fx (&read-object &fluid)))) + (let ((defs (and (intset-ref singly-referenced k) + (intmap-ref defs label)))) + (when defs + (hash-set! equiv-set exp-key + (acons label defs equiv))))) + (finish equiv-labels var-substs)) + (((and head (candidate . vars)) . candidates) + (cond + ((not (intset-ref avail candidate)) + ;; This expression isn't available here; try + ;; the next one. + (lp candidates)) + (else + ;; Yay, a match. Mark expression as equivalent. If + ;; we provide the definitions for the successor, mark + ;; the vars for substitution. + (finish (intmap-add equiv-labels label head) + (let ((defs (and (intset-ref singly-referenced k) + (intmap-ref defs label)))) + (if defs + (fold (lambda (def var var-substs) + (intmap-add var-substs def var)) + var-substs defs vars) + var-substs)))))))))) + (_ (values equiv-labels var-substs)))) + + ;; Traverse the labels in fun in reverse post-order, which will + ;; visit definitions before uses first. + (fold2 visit-label + (compute-reverse-post-order succs kfun) + equiv-labels + var-substs))) + +(define (apply-cse conts equiv-labels var-substs truthy-labels) + (define (true-idx idx) (ash idx 1)) + (define (false-idx idx) (1+ (ash idx 1))) + + (define (subst-var var) + (intmap-ref var-substs var (lambda (var) var))) + + (define (visit-exp exp) + (rewrite-exp exp + ((or ($ $const) ($ $prim) ($ $fun) ($ $rec)) ,exp) + (($ $call proc args) + ($call (subst-var proc) ,(map subst-var args))) + (($ $callk k proc args) + ($callk k (subst-var proc) ,(map subst-var args))) + (($ $primcall name args) + ($primcall name ,(map subst-var args))) + (($ $branch k exp) + ($branch k ,(visit-exp exp))) + (($ $values args) + ($values ,(map subst-var args))) + (($ $prompt escape? tag handler) + ($prompt escape? (subst-var tag) handler)))) + + (intmap-map + (lambda (label cont) + (match cont + (($ $kargs names vars ($ $continue k src exp)) + (build-cont + ($kargs names vars + ,(match (intmap-ref equiv-labels label (lambda (_) #f)) + ((equiv . vars) + (match exp + (($ $branch kt exp) + (let* ((bool (intmap-ref truthy-labels label)) + (t (intset-ref bool (true-idx equiv))) + (f (intset-ref bool (false-idx equiv)))) + (if (eqv? t f) + (build-term + ($continue k src + ($branch kt ,(visit-exp exp)))) + (build-term + ($continue (if t kt k) src ($values ())))))) + (_ + ;; For better or for worse, we only replace primcalls + ;; if they have an associated VM op, which allows + ;; them to continue to $kargs and thus we know their + ;; defs and can use a $values expression instead of a + ;; values primcall. + (build-term + ($continue k src ($values vars)))))) + (#f + (build-term + ($continue k src ,(visit-exp exp)))))))) + (_ cont))) + conts)) + +(define (eliminate-common-subexpressions conts) + (call-with-values + (lambda () + (let ((effects (synthesize-definition-effects (compute-effects conts)))) + (compute-equivalent-subexpressions conts 0 effects + empty-intmap empty-intmap))) + (lambda (equiv-labels var-substs) + (let ((truthy-labels (compute-truthy-expressions conts 0 empty-intmap))) + (apply-cse conts equiv-labels var-substs truthy-labels))))) diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm new file mode 100644 index 000000000..5463f5b1e --- /dev/null +++ b/module/language/cps/dce.scm @@ -0,0 +1,399 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; This pass kills dead expressions: code that has no side effects, and +;;; whose value is unused. It does so by marking all live values, and +;;; then discarding other values as dead. This happens recursively +;;; through procedures, so it should be possible to elide dead +;;; procedures as well. +;;; +;;; Code: + +(define-module (language cps dce) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (language cps) + #:use-module (language cps effects-analysis) + #:use-module (language cps renumber) + #:use-module (language cps types) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (eliminate-dead-code)) + +(define (elide-type-checks conts kfun effects) + "Elide &type-check effects from EFFECTS for the function starting at +KFUN where we can prove that no assertion will be raised at run-time." + (let ((types (infer-types conts kfun))) + (define (visit-primcall effects fx label name args) + (if (primcall-types-check? types label name args) + (intmap-replace! effects label (logand fx (lognot &type-check))) + effects)) + (persistent-intmap + (intmap-fold (lambda (label types effects) + (let ((fx (intmap-ref effects label))) + (cond + ((causes-all-effects? fx) effects) + ((causes-effect? fx &type-check) + (match (intmap-ref conts label) + (($ $kargs _ _ exp) + (match exp + (($ $continue k src ($ $primcall name args)) + (visit-primcall effects fx label name args)) + (($ $continue k src + ($ $branch _ ($primcall name args))) + (visit-primcall effects fx label name args)) + (_ effects))) + (_ effects))) + (else effects)))) + types + effects)))) + +(define (compute-effects/elide-type-checks conts) + (intmap-fold (lambda (label cont effects) + (match cont + (($ $kfun) (elide-type-checks conts label effects)) + (_ effects))) + conts + (compute-effects conts))) + +(define (fold-local-conts proc conts label seed) + (match (intmap-ref conts label) + (($ $kfun src meta self tail clause) + (let lp ((label label) (seed seed)) + (if (<= label tail) + (lp (1+ label) (proc label (intmap-ref conts label) seed)) + seed))))) + +(define (postorder-fold-local-conts2 proc conts label seed0 seed1) + (match (intmap-ref conts label) + (($ $kfun src meta self tail clause) + (let ((start label)) + (let lp ((label tail) (seed0 seed0) (seed1 seed1)) + (if (<= start label) + (let ((cont (intmap-ref conts label))) + (call-with-values (lambda () (proc label cont seed0 seed1)) + (lambda (seed0 seed1) + (lp (1- label) seed0 seed1)))) + (values seed0 seed1))))))) + +(define (compute-known-allocations conts effects) + "Compute the variables bound in CONTS that have known allocation +sites." + ;; Compute the set of conts that are called with freshly allocated + ;; values, and subtract from that set the conts that might be called + ;; with values with unknown allocation sites. Then convert that set + ;; of conts into a set of bound variables. + (call-with-values + (lambda () + (intmap-fold (lambda (label cont known unknown) + ;; Note that we only need to add labels to the + ;; known/unknown sets if the labels can bind + ;; values. So there's no need to add tail, + ;; clause, branch alternate, or prompt handler + ;; labels, as they bind no values. + (match cont + (($ $kargs _ _ ($ $continue k)) + (let ((fx (intmap-ref effects label))) + (if (and (not (causes-all-effects? fx)) + (causes-effect? fx &allocation)) + (values (intset-add! known k) unknown) + (values known (intset-add! unknown k))))) + (($ $kreceive arity kargs) + (values known (intset-add! unknown kargs))) + (($ $kfun src meta self tail clause) + (values known unknown)) + (($ $kclause arity body alt) + (values known (intset-add! unknown body))) + (($ $ktail) + (values known unknown)))) + conts + empty-intset + empty-intset)) + (lambda (known unknown) + (persistent-intset + (intset-fold (lambda (label vars) + (match (intmap-ref conts label) + (($ $kargs (_) (var)) (intset-add! vars var)) + (_ vars))) + (intset-subtract (persistent-intset known) + (persistent-intset unknown)) + empty-intset))))) + +(define (compute-live-code conts) + (let* ((effects (compute-effects/elide-type-checks conts)) + (known-allocations (compute-known-allocations conts effects))) + (define (adjoin-var var set) + (intset-add set var)) + (define (adjoin-vars vars set) + (match vars + (() set) + ((var . vars) (adjoin-vars vars (adjoin-var var set))))) + (define (var-live? var live-vars) + (intset-ref live-vars var)) + (define (any-var-live? vars live-vars) + (match vars + (() #f) + ((var . vars) + (or (var-live? var live-vars) + (any-var-live? vars live-vars))))) + (define (cont-defs k) + (match (intmap-ref conts k) + (($ $kargs _ vars) vars) + (_ #f))) + + (define (visit-live-exp label k exp live-labels live-vars) + (match exp + ((or ($ $const) ($ $prim)) + (values live-labels live-vars)) + (($ $fun body) + (values (intset-add live-labels body) live-vars)) + (($ $closure body) + (values (intset-add live-labels body) live-vars)) + (($ $rec names vars (($ $fun kfuns) ...)) + (let lp ((vars vars) (kfuns kfuns) + (live-labels live-labels) (live-vars live-vars)) + (match (vector vars kfuns) + (#(() ()) (values live-labels live-vars)) + (#((var . vars) (kfun . kfuns)) + (lp vars kfuns + (if (var-live? var live-vars) + (intset-add live-labels kfun) + live-labels) + live-vars))))) + (($ $prompt escape? tag handler) + (values live-labels (adjoin-var tag live-vars))) + (($ $call proc args) + (values live-labels (adjoin-vars args (adjoin-var proc live-vars)))) + (($ $callk kfun proc args) + (values (intset-add live-labels kfun) + (adjoin-vars args (adjoin-var proc live-vars)))) + (($ $primcall name args) + (values live-labels (adjoin-vars args live-vars))) + (($ $branch k ($ $primcall name args)) + (values live-labels (adjoin-vars args live-vars))) + (($ $branch k ($ $values (arg))) + (values live-labels (adjoin-var arg live-vars))) + (($ $values args) + (values live-labels + (match (cont-defs k) + (#f (adjoin-vars args live-vars)) + (defs (fold (lambda (use def live-vars) + (if (var-live? def live-vars) + (adjoin-var use live-vars) + live-vars)) + live-vars args defs))))))) + + (define (visit-exp label k exp live-labels live-vars) + (cond + ((intset-ref live-labels label) + ;; Expression live already. + (visit-live-exp label k exp live-labels live-vars)) + ((let ((defs (cont-defs k)) + (fx (intmap-ref effects label))) + (or + ;; No defs; perhaps continuation is $ktail. + (not defs) + ;; We don't remove branches. + (match exp (($ $branch) #t) (_ #f)) + ;; Do we have a live def? + (any-var-live? defs live-vars) + ;; Does this expression cause all effects? If so, it's + ;; definitely live. + (causes-all-effects? fx) + ;; Does it cause a type check, but we weren't able to prove + ;; that the types check? + (causes-effect? fx &type-check) + ;; We might have a setter. If the object being assigned to + ;; is live or was not created by us, then this expression is + ;; live. Otherwise the value is still dead. + (and (causes-effect? fx &write) + (match exp + (($ $primcall + (or 'vector-set! 'vector-set!/immediate + 'set-car! 'set-cdr! + 'box-set!) + (obj . _)) + (or (var-live? obj live-vars) + (not (intset-ref known-allocations obj)))) + (_ #t))))) + ;; Mark expression as live and visit. + (visit-live-exp label k exp (intset-add live-labels label) live-vars)) + (else + ;; Still dead. + (values live-labels live-vars)))) + + (define (visit-fun label live-labels live-vars) + ;; Visit uses before definitions. + (postorder-fold-local-conts2 + (lambda (label cont live-labels live-vars) + (match cont + (($ $kargs _ _ ($ $continue k src exp)) + (visit-exp label k exp live-labels live-vars)) + (($ $kreceive arity kargs) + (values live-labels live-vars)) + (($ $kclause arity kargs kalt) + (values live-labels (adjoin-vars (cont-defs kargs) live-vars))) + (($ $kfun src meta self) + (values live-labels (adjoin-var self live-vars))) + (($ $ktail) + (values live-labels live-vars)))) + conts label live-labels live-vars)) + + (fixpoint (lambda (live-labels live-vars) + (let lp ((label 0) + (live-labels live-labels) + (live-vars live-vars)) + (match (intset-next live-labels label) + (#f (values live-labels live-vars)) + (label + (call-with-values + (lambda () + (match (intmap-ref conts label) + (($ $kfun) + (visit-fun label live-labels live-vars)) + (_ (values live-labels live-vars)))) + (lambda (live-labels live-vars) + (lp (1+ label) live-labels live-vars))))))) + (intset 0) + empty-intset))) + +(define-syntax adjoin-conts + (syntax-rules () + ((_ (exp ...) clause ...) + (let ((cps (exp ...))) + (adjoin-conts cps clause ...))) + ((_ cps (label cont) clause ...) + (adjoin-conts (intmap-add! cps label (build-cont cont)) + clause ...)) + ((_ cps) + cps))) + +(define (process-eliminations conts live-labels live-vars) + (define (label-live? label) + (intset-ref live-labels label)) + (define (value-live? var) + (intset-ref live-vars var)) + (define (make-adaptor k src defs) + (let* ((names (map (lambda (_) 'tmp) defs)) + (vars (map (lambda (_) (fresh-var)) defs)) + (live (filter-map (lambda (def var) + (and (value-live? def) var)) + defs vars))) + (build-cont + ($kargs names vars + ($continue k src ($values live)))))) + (define (visit-term label term cps) + (match term + (($ $continue k src exp) + (if (label-live? label) + (match exp + (($ $fun body) + (values cps + term)) + (($ $closure body nfree) + (values cps + term)) + (($ $rec names vars funs) + (match (filter-map (lambda (name var fun) + (and (value-live? var) + (list name var fun))) + names vars funs) + (() + (values cps + (build-term ($continue k src ($values ()))))) + (((names vars funs) ...) + (values cps + (build-term ($continue k src + ($rec names vars funs))))))) + (_ + (match (intmap-ref conts k) + (($ $kargs ()) + (values cps term)) + (($ $kargs names ((? value-live?) ...)) + (values cps term)) + (($ $kargs names vars) + (match exp + (($ $values args) + (let ((args (filter-map (lambda (use def) + (and (value-live? def) use)) + args vars))) + (values cps + (build-term + ($continue k src ($values args)))))) + (_ + (let-fresh (adapt) () + (values (adjoin-conts cps + (adapt ,(make-adaptor k src vars))) + (build-term + ($continue adapt src ,exp))))))) + (_ + (values cps term))))) + (values cps + (build-term + ($continue k src ($values ())))))))) + (define (visit-cont label cont cps) + (match cont + (($ $kargs names vars term) + (match (filter-map (lambda (name var) + (and (value-live? var) + (cons name var))) + names vars) + (((names . vars) ...) + (call-with-values (lambda () (visit-term label term cps)) + (lambda (cps term) + (adjoin-conts cps + (label ($kargs names vars ,term)))))))) + (($ $kreceive ($ $arity req () rest () #f) kargs) + (let ((defs (match (intmap-ref conts kargs) + (($ $kargs names vars) vars)))) + (if (and-map value-live? defs) + (adjoin-conts cps (label ,cont)) + (let-fresh (adapt) () + (adjoin-conts cps + (adapt ,(make-adaptor kargs #f defs)) + (label ($kreceive req rest adapt))))))) + (_ + (adjoin-conts cps (label ,cont))))) + (with-fresh-name-state conts + (persistent-intmap + (intmap-fold (lambda (label cont cps) + (match cont + (($ $kfun) + (if (label-live? label) + (fold-local-conts visit-cont conts label cps) + cps)) + (_ cps))) + conts + empty-intmap)))) + +(define (eliminate-dead-code conts) + ;; We work on a renumbered program so that we can easily visit uses + ;; before definitions just by visiting higher-numbered labels before + ;; lower-numbered labels. Renumbering is also a precondition for type + ;; inference. + (let ((conts (renumber conts))) + (call-with-values (lambda () (compute-live-code conts)) + (lambda (live-labels live-vars) + (process-eliminations conts live-labels live-vars))))) + +;;; Local Variables: +;;; eval: (put 'adjoin-conts 'scheme-indent-function 1) +;;; End: diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm new file mode 100644 index 000000000..874eb7829 --- /dev/null +++ b/module/language/cps/effects-analysis.scm @@ -0,0 +1,484 @@ +;;; Effects analysis on CPS + +;; Copyright (C) 2011, 2012, 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; A helper module to compute the set of effects caused by an +;;; expression. This information is useful when writing algorithms that +;;; move code around, while preserving the semantics of an input +;;; program. +;;; +;;; The effects set is represented as an integer with three parts. The +;;; low 4 bits indicate effects caused by an expression, as a bitfield. +;;; The next 4 bits indicate the kind of memory accessed by the +;;; expression, if it accesses mutable memory. Finally the rest of the +;;; bits indicate the field in the object being accessed, if known, or +;;; -1 for unknown. +;;; +;;; In this way we embed a coarse type-based alias analysis in the +;;; effects analysis. For example, a "car" call is modelled as causing +;;; a read to field 0 on a &pair, and causing a &type-check effect. If +;;; any intervening code sets the car of any pair, that will block +;;; motion of the "car" call, because any write to field 0 of a pair is +;;; seen by effects analysis as being a write to field 0 of all pairs. +;;; +;;; Code: + +(define-module (language cps effects-analysis) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:use-module (ice-9 match) + #:export (expression-effects + compute-effects + synthesize-definition-effects + + &allocation + &type-check + &read + &write + + &fluid + &prompt + &car + &cdr + &vector + &box + &module + &struct + &string + &bytevector + + &object + &field + + &allocate + &read-object + &read-field + &write-object + &write-field + + &no-effects + &all-effects + + exclude-effects + effect-free? + constant? + causes-effect? + causes-all-effects? + effect-clobbers?)) + +(define-syntax define-flags + (lambda (x) + (syntax-case x () + ((_ all shift name ...) + (let ((count (length #'(name ...)))) + (with-syntax (((n ...) (iota count)) + (count count)) + #'(begin + (define-syntax name (identifier-syntax (ash 1 n))) + ... + (define-syntax all (identifier-syntax (1- (ash 1 count)))) + (define-syntax shift (identifier-syntax count))))))))) + +(define-syntax define-enumeration + (lambda (x) + (define (count-bits n) + (let lp ((out 1)) + (if (< n (ash 1 (1- out))) + out + (lp (1+ out))))) + (syntax-case x () + ((_ mask shift name ...) + (let* ((len (length #'(name ...))) + (bits (count-bits len))) + (with-syntax (((n ...) (iota len)) + (bits bits)) + #'(begin + (define-syntax name (identifier-syntax n)) + ... + (define-syntax mask (identifier-syntax (1- (ash 1 bits)))) + (define-syntax shift (identifier-syntax bits))))))))) + +(define-flags &all-effect-kinds &effect-kind-bits + ;; Indicates that an expression may cause a type check. A type check, + ;; for the purposes of this analysis, is the possibility of throwing + ;; an exception the first time an expression is evaluated. If the + ;; expression did not cause an exception to be thrown, users can + ;; assume that evaluating the expression again will not cause an + ;; exception to be thrown. + ;; + ;; For example, (+ x y) might throw if X or Y are not numbers. But if + ;; it doesn't throw, it should be safe to elide a dominated, common + ;; subexpression (+ x y). + &type-check + + ;; Indicates that an expression may return a fresh object. The kind + ;; of object is indicated in the object kind field. + &allocation + + ;; Indicates that an expression may cause a read from memory. The + ;; kind of memory is given in the object kind field. Some object + ;; kinds have finer-grained fields; those are expressed in the "field" + ;; part of the effects value. -1 indicates "the whole object". + &read + + ;; Indicates that an expression may cause a write to memory. + &write) + +(define-enumeration &memory-kind-mask &memory-kind-bits + ;; Indicates than an expression may access unknown kinds of memory. + &unknown-memory-kinds + + ;; Indicates that an expression depends on the value of a fluid + ;; variable, or on the current fluid environment. + &fluid + + ;; Indicates that an expression depends on the current prompt + ;; stack. + &prompt + + ;; Indicates that an expression depends on the value of the car or cdr + ;; of a pair. + &pair + + ;; Indicates that an expression depends on the value of a vector + ;; field. The effect field indicates the specific field, or zero for + ;; an unknown field. + &vector + + ;; Indicates that an expression depends on the value of a variable + ;; cell. + &box + + ;; Indicates that an expression depends on the current module. + &module + + ;; Indicates that an expression depends on the value of a struct + ;; field. The effect field indicates the specific field, or zero for + ;; an unknown field. + &struct + + ;; Indicates that an expression depends on the contents of a string. + &string + + ;; Indicates that an expression depends on the contents of a + ;; bytevector. We cannot be more precise, as bytevectors may alias + ;; other bytevectors. + &bytevector) + +(define-inlinable (&field kind field) + (ash (logior (ash field &memory-kind-bits) kind) &effect-kind-bits)) +(define-inlinable (&object kind) + (&field kind -1)) + +(define-inlinable (&allocate kind) + (logior &allocation (&object kind))) +(define-inlinable (&read-field kind field) + (logior &read (&field kind field))) +(define-inlinable (&read-object kind) + (logior &read (&object kind))) +(define-inlinable (&write-field kind field) + (logior &write (&field kind field))) +(define-inlinable (&write-object kind) + (logior &write (&object kind))) + +(define-syntax &no-effects (identifier-syntax 0)) +(define-syntax &all-effects + (identifier-syntax + (logior &all-effect-kinds (&object &unknown-memory-kinds)))) + +(define-inlinable (constant? effects) + (zero? effects)) + +(define-inlinable (causes-effect? x effects) + (not (zero? (logand x effects)))) + +(define-inlinable (causes-all-effects? x) + (eqv? x &all-effects)) + +(define (effect-clobbers? a b) + "Return true if A clobbers B. This is the case if A is a write, and B +is or might be a read or a write to the same location as A." + (define (locations-same?) + (let ((a (ash a (- &effect-kind-bits))) + (b (ash b (- &effect-kind-bits)))) + (or (eqv? &unknown-memory-kinds (logand a &memory-kind-mask)) + (eqv? &unknown-memory-kinds (logand b &memory-kind-mask)) + (and (eqv? (logand a &memory-kind-mask) (logand b &memory-kind-mask)) + ;; A negative field indicates "the whole object". + ;; Non-negative fields indicate only part of the object. + (or (< a 0) (< b 0) (= a b)))))) + (and (not (zero? (logand a &write))) + (not (zero? (logand b (logior &read &write)))) + (locations-same?))) + +(define-inlinable (indexed-field kind var constants) + (let ((val (intmap-ref constants var (lambda (_) #f)))) + (if (and (exact-integer? val) (<= 0 val)) + (&field kind val) + (&object kind)))) + +(define *primitive-effects* (make-hash-table)) + +(define-syntax-rule (define-primitive-effects* constants + ((name . args) effects ...) + ...) + (begin + (hashq-set! *primitive-effects* 'name + (case-lambda* + ((constants . args) (logior effects ...)) + (_ &all-effects))) + ...)) + +(define-syntax-rule (define-primitive-effects ((name . args) effects ...) ...) + (define-primitive-effects* constants ((name . args) effects ...) ...)) + +;; Miscellaneous. +(define-primitive-effects + ((values . _))) + +;; Generic effect-free predicates. +(define-primitive-effects + ((eq? . _)) + ((eqv? . _)) + ((equal? . _)) + ((pair? arg)) + ((null? arg)) + ((nil? arg )) + ((symbol? arg)) + ((variable? arg)) + ((vector? arg)) + ((struct? arg)) + ((string? arg)) + ((number? arg)) + ((char? arg)) + ((bytevector? arg)) + ((keyword? arg)) + ((bitvector? arg)) + ((procedure? arg)) + ((thunk? arg))) + +;; Fluids. +(define-primitive-effects + ((fluid-ref f) (&read-object &fluid) &type-check) + ((fluid-set! f v) (&write-object &fluid) &type-check) + ((push-fluid f v) (&write-object &fluid) &type-check) + ((pop-fluid) (&write-object &fluid) &type-check)) + +;; Prompts. +(define-primitive-effects + ((make-prompt-tag #:optional arg) (&allocate &unknown-memory-kinds))) + +;; Pairs. +(define-primitive-effects + ((cons a b) (&allocate &pair)) + ((list . _) (&allocate &pair)) + ((car x) (&read-field &pair 0) &type-check) + ((set-car! x y) (&write-field &pair 0) &type-check) + ((cdr x) (&read-field &pair 1) &type-check) + ((set-cdr! x y) (&write-field &pair 1) &type-check) + ((memq x y) (&read-object &pair) &type-check) + ((memv x y) (&read-object &pair) &type-check) + ((list? arg) (&read-field &pair 1)) + ((length l) (&read-field &pair 1) &type-check)) + +;; Variables. +(define-primitive-effects + ((box v) (&allocate &box)) + ((box-ref v) (&read-object &box) &type-check) + ((box-set! v x) (&write-object &box) &type-check)) + +;; Vectors. +(define (vector-field n constants) + (indexed-field &vector n constants)) +(define (read-vector-field n constants) + (logior &read (vector-field n constants))) +(define (write-vector-field n constants) + (logior &write (vector-field n constants))) +(define-primitive-effects* constants + ((vector . _) (&allocate &vector)) + ((make-vector n init) (&allocate &vector) &type-check) + ((make-vector/immediate n init) (&allocate &vector)) + ((vector-ref v n) (read-vector-field n constants) &type-check) + ((vector-ref/immediate v n) (read-vector-field n constants) &type-check) + ((vector-set! v n x) (write-vector-field n constants) &type-check) + ((vector-set!/immediate v n x) (write-vector-field n constants) &type-check) + ((vector-length v) &type-check)) + +;; Structs. +(define (struct-field n constants) + (indexed-field &struct n constants)) +(define (read-struct-field n constants) + (logior &read (struct-field n constants))) +(define (write-struct-field n constants) + (logior &write (struct-field n constants))) +(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) + ((struct-set! s n x) (write-struct-field n constants) &type-check) + ((struct-set!/immediate s n x) (write-struct-field n constants) &type-check) + ((struct-vtable s) &type-check)) + +;; Strings. +(define-primitive-effects + ((string-ref s n) (&read-object &string) &type-check) + ((string-set! s n c) (&write-object &string) &type-check) + ((number->string _) (&allocate &string) &type-check) + ((string->number _) (&read-object &string) &type-check) + ((string-length s) &type-check)) + +;; Bytevectors. +(define-primitive-effects + ((bytevector-length _) &type-check) + + ((bv-u8-ref bv n) (&read-object &bytevector) &type-check) + ((bv-s8-ref bv n) (&read-object &bytevector) &type-check) + ((bv-u16-ref bv n) (&read-object &bytevector) &type-check) + ((bv-s16-ref bv n) (&read-object &bytevector) &type-check) + ((bv-u32-ref bv n) (&read-object &bytevector) &type-check) + ((bv-s32-ref bv n) (&read-object &bytevector) &type-check) + ((bv-u64-ref bv n) (&read-object &bytevector) &type-check) + ((bv-s64-ref bv n) (&read-object &bytevector) &type-check) + ((bv-f32-ref bv n) (&read-object &bytevector) &type-check) + ((bv-f64-ref bv n) (&read-object &bytevector) &type-check) + + ((bv-u8-set! bv n x) (&write-object &bytevector) &type-check) + ((bv-s8-set! bv n x) (&write-object &bytevector) &type-check) + ((bv-u16-set! bv n x) (&write-object &bytevector) &type-check) + ((bv-s16-set! bv n x) (&write-object &bytevector) &type-check) + ((bv-u32-set! bv n x) (&write-object &bytevector) &type-check) + ((bv-s32-set! bv n x) (&write-object &bytevector) &type-check) + ((bv-u64-set! bv n x) (&write-object &bytevector) &type-check) + ((bv-s64-set! bv n x) (&write-object &bytevector) &type-check) + ((bv-f32-set! bv n x) (&write-object &bytevector) &type-check) + ((bv-f64-set! bv n x) (&write-object &bytevector) &type-check)) + +;; Modules. +(define-primitive-effects + ((current-module) (&read-object &module)) + ((cache-current-module! m scope) (&write-object &box)) + ((resolve name bound?) (&read-object &module) &type-check) + ((cached-toplevel-box scope name bound?) &type-check) + ((cached-module-box mod name public? bound?) &type-check) + ((define! name val) (&read-object &module) (&write-object &box))) + +;; Numbers. +(define-primitive-effects + ((= . _) &type-check) + ((< . _) &type-check) + ((> . _) &type-check) + ((<= . _) &type-check) + ((>= . _) &type-check) + ((zero? . _) &type-check) + ((add . _) &type-check) + ((mul . _) &type-check) + ((sub . _) &type-check) + ((div . _) &type-check) + ((sub1 . _) &type-check) + ((add1 . _) &type-check) + ((quo . _) &type-check) + ((rem . _) &type-check) + ((mod . _) &type-check) + ((complex? _) &type-check) + ((real? _) &type-check) + ((rational? _) &type-check) + ((inf? _) &type-check) + ((nan? _) &type-check) + ((integer? _) &type-check) + ((exact? _) &type-check) + ((inexact? _) &type-check) + ((even? _) &type-check) + ((odd? _) &type-check) + ((ash n m) &type-check) + ((logand . _) &type-check) + ((logior . _) &type-check) + ((logxor . _) &type-check) + ((lognot . _) &type-check) + ((logtest a b) &type-check) + ((logbit? a b) &type-check) + ((sqrt _) &type-check) + ((abs _) &type-check)) + +;; Characters. +(define-primitive-effects + ((char=? . _) &type-check) + ((char>? . _) &type-check) + ((integer->char _) &type-check) + ((char->integer _) &type-check)) + +(define (primitive-effects constants name args) + (let ((proc (hashq-ref *primitive-effects* name))) + (if proc + (apply proc constants args) + &all-effects))) + +(define (expression-effects exp constants) + (match exp + ((or ($ $const) ($ $prim) ($ $values)) + &no-effects) + ((or ($ $fun) ($ $rec) ($ $closure)) + (&allocate &unknown-memory-kinds)) + (($ $prompt) + (&write-object &prompt)) + ((or ($ $call) ($ $callk)) + &all-effects) + (($ $branch k exp) + (expression-effects exp constants)) + (($ $primcall name args) + (primitive-effects constants name args)))) + +(define (compute-effects conts) + (let ((constants (compute-constant-values conts))) + (intmap-map + (lambda (label cont) + (match cont + (($ $kargs names syms ($ $continue k src exp)) + (expression-effects exp constants)) + (($ $kreceive arity kargs) + (match arity + (($ $arity _ () #f () #f) &type-check) + (($ $arity () () _ () #f) (&allocate &pair)) + (($ $arity _ () _ () #f) (logior (&allocate &pair) &type-check)))) + (($ $kfun) &type-check) + (($ $kclause) &type-check) + (($ $ktail) &no-effects))) + conts))) + +;; There is a way to abuse effects analysis in CSE to also do scalar +;; replacement, effectively adding `car' and `cdr' expressions to `cons' +;; expressions, and likewise with other constructors and setters. This +;; routine adds appropriate effects to `cons' and `set-car!' and the +;; like. +;; +;; This doesn't affect CSE's ability to eliminate expressions, given +;; that allocations aren't eliminated anyway, and the new effects will +;; just cause the allocations not to commute with e.g. set-car! which +;; is what we want anyway. +(define (synthesize-definition-effects effects) + (intmap-map (lambda (label fx) + (if (logtest (logior &write &allocation) fx) + (logior fx &read) + fx)) + effects)) diff --git a/module/language/cps/elide-values.scm b/module/language/cps/elide-values.scm new file mode 100644 index 000000000..81ccfc200 --- /dev/null +++ b/module/language/cps/elide-values.scm @@ -0,0 +1,88 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Primcalls that don't correspond to VM instructions are treated as if +;;; they are calls, and indeed the later reify-primitives pass turns +;;; them into calls. Because no return arity checking is done for these +;;; primitives, if a later optimization pass simplifies the primcall to +;;; a VM operation, the tail of the simplification has to be a +;;; primcall to 'values. Most of these primcalls can be elided, and +;;; that is the job of this pass. +;;; +;;; Code: + +(define-module (language cps elide-values) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps with-cps) + #:use-module (language cps intmap) + #:export (elide-values)) + +(define (inline-values cps k src args) + (match (intmap-ref cps k) + (($ $ktail) + (with-cps cps + (build-term + ($continue k src ($values args))))) + (($ $kreceive ($ $arity req () rest () #f) kargs) + (cond + ((and (not rest) (= (length args) (length req))) + (with-cps cps + (build-term + ($continue kargs src ($values args))))) + ((and rest (>= (length args) (length req))) + (let () + (define (build-rest cps k tail) + (match tail + (() + (with-cps cps + (build-term ($continue k src ($const '()))))) + ((v . tail) + (with-cps cps + (letv rest) + (letk krest ($kargs ('rest) (rest) + ($continue k src ($primcall 'cons (v rest))))) + ($ (build-rest krest tail)))))) + (with-cps cps + (letv rest) + (letk krest ($kargs ('rest) (rest) + ($continue kargs src + ($values ,(append (list-head args (length req)) + (list rest)))))) + ($ (build-rest krest (list-tail args (length req))))))) + (else (with-cps cps #f)))))) + +(define (elide-values conts) + (with-fresh-name-state conts + (persistent-intmap + (intmap-fold + (lambda (label cont out) + (match cont + (($ $kargs names vars ($ $continue k src ($ $primcall 'values args))) + (call-with-values (lambda () (inline-values out k src args)) + (lambda (out term) + (if term + (let ((cont (build-cont ($kargs names vars ,term)))) + (intmap-replace! out label cont)) + out)))) + (_ out))) + conts + conts)))) diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm new file mode 100644 index 000000000..83a3f2dfe --- /dev/null +++ b/module/language/cps/optimize.scm @@ -0,0 +1,106 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Optimizations on CPS. +;;; +;;; Code: + +(define-module (language cps optimize) + #:use-module (ice-9 match) + #:use-module (language cps constructors) + #:use-module (language cps contification) + #:use-module (language cps cse) + #:use-module (language cps dce) + #:use-module (language cps elide-values) + #:use-module (language cps prune-top-level-scopes) + #:use-module (language cps prune-bailouts) + #:use-module (language cps self-references) + #:use-module (language cps simplify) + #:use-module (language cps specialize-primcalls) + #:use-module (language cps split-rec) + #:use-module (language cps type-fold) + #:use-module (language cps verify) + #:export (optimize-higher-order-cps + optimize-first-order-cps)) + +(define (kw-arg-ref args kw default) + (match (memq kw args) + ((_ val . _) val) + (_ default))) + +(define *debug?* #f) + +(define (maybe-verify program) + (if *debug?* + (verify program) + program)) + +(define-syntax-rule (define-optimizer optimize (pass kw default) ...) + (define* (optimize program #:optional (opts '())) + ;; This series of assignments to `program' used to be a series of + ;; let* bindings of `program', as you would imagine. In compiled + ;; code this is fine because the compiler is able to allocate all + ;; let*-bound variable to the same slot, which also means that the + ;; garbage collector doesn't have to retain so many copies of the + ;; term being optimized. However during bootstrap, the interpreter + ;; doesn't do this optimization, leading to excessive data retention + ;; as the terms are rewritten. To marginally improve bootstrap + ;; memory usage, here we use set! instead. The compiler should + ;; produce the same code in any case, though currently it does not + ;; because it doesn't do escape analysis on the box created for the + ;; set!. + (maybe-verify program) + (set! program + (if (kw-arg-ref opts kw default) + (maybe-verify (pass program)) + program)) + ... + (verify program) + program)) + +;; Passes that are needed: +;; +;; * Abort contification: turning abort primcalls into continuation +;; calls, and eliding prompts if possible. +;; +;; * Loop peeling. Unrolls the first round through a loop if the +;; loop has effects that CSE can work on. Requires effects +;; analysis. When run before CSE, loop peeling is the equivalent +;; of loop-invariant code motion (LICM). +;; +(define-optimizer optimize-higher-order-cps + (split-rec #:split-rec? #t) + (eliminate-dead-code #:eliminate-dead-code? #t) + (prune-top-level-scopes #:prune-top-level-scopes? #t) + (simplify #:simplify? #t) + (contify #:contify? #t) + (inline-constructors #:inline-constructors? #t) + (specialize-primcalls #:specialize-primcalls? #t) + (elide-values #:elide-values? #t) + (prune-bailouts #:prune-bailouts? #t) + (eliminate-common-subexpressions #:cse? #t) + (type-fold #:type-fold? #t) + (resolve-self-references #:resolve-self-references? #t) + (eliminate-dead-code #:eliminate-dead-code? #t) + (simplify #:simplify? #t)) + +(define-optimizer optimize-first-order-cps + (eliminate-dead-code #:eliminate-dead-code? #t) + (simplify #:simplify? #t)) diff --git a/module/language/cps/prune-bailouts.scm b/module/language/cps/prune-bailouts.scm new file mode 100644 index 000000000..7c10319e8 --- /dev/null +++ b/module/language/cps/prune-bailouts.scm @@ -0,0 +1,86 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; A pass that prunes successors of expressions that bail out. +;;; +;;; Code: + +(define-module (language cps prune-bailouts) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps with-cps) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (prune-bailouts)) + +(define (compute-tails conts) + "For each LABEL->CONT entry in the intmap CONTS, compute a +LABEL->TAIL-LABEL indicating the tail continuation of each expression's +containing function. In some cases TAIL-LABEL might not be available, +for example if there is a stale $kfun pointing at a body, or for +unreferenced terms. In that case TAIL-LABEL is either absent or #f." + (intmap-fold + (lambda (label cont out) + (match cont + (($ $kfun src meta self tail clause) + (intset-fold (lambda (label out) + (intmap-add out label tail (lambda (old new) #f))) + (compute-function-body conts label) + out)) + (_ out))) + conts + empty-intmap)) + +(define (prune-bailout out tails k src exp) + (match (intmap-ref out k) + (($ $ktail) + (with-cps out #f)) + (_ + (match (intmap-ref tails k (lambda (_) #f)) + (#f + (with-cps out #f)) + (ktail + (with-cps out + (letv prim rest) + (letk kresult ($kargs ('rest) (rest) + ($continue ktail src ($values ())))) + (letk kreceive ($kreceive '() 'rest kresult)) + (build-term ($continue kreceive src ,exp)))))))) + +(define (prune-bailouts conts) + (let ((tails (compute-tails conts))) + (with-fresh-name-state conts + (persistent-intmap + (intmap-fold + (lambda (label cont out) + (match cont + (($ $kargs names vars + ($ $continue k src + (and exp ($ $primcall (or 'error 'scm-error 'throw))))) + (call-with-values (lambda () (prune-bailout out tails k src exp)) + (lambda (out term) + (if term + (let ((cont (build-cont ($kargs names vars ,term)))) + (intmap-replace! out label cont)) + out)))) + (_ out))) + conts + conts))))) diff --git a/module/language/cps/prune-top-level-scopes.scm b/module/language/cps/prune-top-level-scopes.scm new file mode 100644 index 000000000..1970d1bc3 --- /dev/null +++ b/module/language/cps/prune-top-level-scopes.scm @@ -0,0 +1,63 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; A simple pass to prune unneeded top-level scopes. +;;; +;;; Code: + +(define-module (language cps prune-top-level-scopes) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (prune-top-level-scopes)) + +(define (compute-used-scopes conts constants) + (persistent-intset + (intmap-fold + (lambda (label cont used-scopes) + (match cont + (($ $kargs _ _ + ($ $continue k src + ($ $primcall 'cached-toplevel-box (scope name bound?)))) + (intset-add! used-scopes (intmap-ref constants scope))) + (_ + used-scopes))) + conts + empty-intset))) + +(define (prune-top-level-scopes conts) + (let* ((constants (compute-constant-values conts)) + (used-scopes (compute-used-scopes conts constants))) + (intmap-map + (lambda (label cont) + (match cont + (($ $kargs names vars + ($ $continue k src + ($ $primcall 'cache-current-module! + (module (? (lambda (scope) + (let ((val (intmap-ref constants scope))) + (not (intset-ref used-scopes val))))))))) + (build-cont ($kargs names vars + ($continue k src ($values ()))))) + (_ + cont))) + conts))) diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm new file mode 100644 index 000000000..014593a9a --- /dev/null +++ b/module/language/cps/reify-primitives.scm @@ -0,0 +1,167 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; A pass to reify lone $prim's that were never folded into a +;;; $primcall, and $primcall's to primitives that don't have a +;;; corresponding VM op. +;;; +;;; Code: + +(define-module (language cps reify-primitives) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps with-cps) + #:use-module (language cps primitives) + #:use-module (language cps intmap) + #:use-module (language bytecode) + #:export (reify-primitives)) + +(define (module-box cps src module name public? bound? val-proc) + (with-cps cps + (letv box) + (let$ body (val-proc box)) + (letk kbox ($kargs ('box) (box) ,body)) + ($ (with-cps-constants ((module module) + (name name) + (public? public?) + (bound? bound?)) + (build-term ($continue kbox src + ($primcall 'cached-module-box + (module name public? bound?)))))))) + +(define (primitive-module name) + (case name + ((bytevector? + bytevector-length + + bytevector-u8-ref bytevector-u8-set! + bytevector-s8-ref bytevector-s8-set! + + bytevector-u16-ref bytevector-u16-set! + bytevector-u16-native-ref bytevector-u16-native-set! + bytevector-s16-ref bytevector-s16-set! + bytevector-s16-native-ref bytevector-s16-native-set! + + bytevector-u32-ref bytevector-u32-set! + bytevector-u32-native-ref bytevector-u32-native-set! + bytevector-s32-ref bytevector-s32-set! + bytevector-s32-native-ref bytevector-s32-native-set! + + bytevector-u64-ref bytevector-u64-set! + bytevector-u64-native-ref bytevector-u64-native-set! + bytevector-s64-ref bytevector-s64-set! + bytevector-s64-native-ref bytevector-s64-native-set! + + bytevector-ieee-single-ref bytevector-ieee-single-set! + bytevector-ieee-single-native-ref bytevector-ieee-single-native-set! + bytevector-ieee-double-ref bytevector-ieee-double-set! + bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!) + '(rnrs bytevectors)) + ((class-of) '(oop goops)) + (else '(guile)))) + +(define (primitive-ref cps name k src) + (module-box cps src (primitive-module name) name #f #t + (lambda (cps box) + (with-cps cps + (build-term + ($continue k src ($primcall 'box-ref (box)))))))) + +(define (builtin-ref cps idx k src) + (with-cps cps + ($ (with-cps-constants ((idx idx)) + (build-term + ($continue k src ($primcall 'builtin-ref (idx)))))))) + +(define (reify-clause cps ktail) + (with-cps cps + (letv throw) + (let$ throw-body + (with-cps-constants ((wna 'wrong-number-of-args) + (false #f) + (str "Wrong number of arguments") + (eol '())) + (build-term + ($continue ktail #f + ($call throw (wna false str eol false)))))) + (letk kthrow ($kargs ('throw) (throw) ,throw-body)) + (let$ body (primitive-ref 'throw kthrow #f)) + (letk kbody ($kargs () () ,body)) + (letk kclause ($kclause ('() '() #f '() #f) kbody #f)) + kclause)) + +;; A $kreceive continuation should have only one predecessor. +(define (uniquify-receive cps k) + (match (intmap-ref cps k) + (($ $kreceive ($ $arity req () rest () #f) kargs) + (with-cps cps + (letk k ($kreceive req rest kargs)) + k)) + (_ + (with-cps cps k)))) + +(define (reify-primitives cps) + (define (visit-cont label cont cps) + (define (resolve-prim cps name k src) + (cond + ((builtin-name->index name) + => (lambda (idx) (builtin-ref cps idx k src))) + (else + (primitive-ref cps name k src)))) + (match cont + (($ $kfun src meta self tail #f) + (with-cps cps + (let$ clause (reify-clause tail)) + (setk label ($kfun src meta self tail clause)))) + (($ $kargs names vars ($ $continue k src ($ $prim name))) + (with-cps cps + (let$ k (uniquify-receive k)) + (let$ body (resolve-prim name k src)) + (setk label ($kargs names vars ,body)))) + (($ $kargs names vars + ($ $continue k src ($ $primcall 'call-thunk/no-inline (proc)))) + (with-cps cps + (setk label ($kargs names vars ($continue k src ($call proc ())))))) + (($ $kargs names vars ($ $continue k src ($ $primcall name args))) + (if (or (prim-instruction name) (branching-primitive? name)) + ;; Assume arities are correct. + cps + (with-cps cps + (letv proc) + (let$ k (uniquify-receive k)) + (letk kproc ($kargs ('proc) (proc) + ($continue k src ($call proc args)))) + (let$ body (resolve-prim name kproc src)) + (setk label ($kargs names vars ,body))))) + (($ $kargs names vars ($ $continue k src ($ $call proc args))) + (with-cps cps + (let$ k (uniquify-receive k)) + (setk label ($kargs names vars + ($continue k src ($call proc args)))))) + (($ $kargs names vars ($ $continue k src ($ $callk k* proc args))) + (with-cps cps + (let$ k (uniquify-receive k)) + (setk label ($kargs names vars + ($continue k src ($callk k* proc args)))))) + (_ cps))) + + (with-fresh-name-state cps + (persistent-intmap (intmap-fold visit-cont cps cps)))) diff --git a/module/language/cps/renumber.scm b/module/language/cps/renumber.scm new file mode 100644 index 000000000..8bab8634d --- /dev/null +++ b/module/language/cps/renumber.scm @@ -0,0 +1,217 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; A pass to renumber variables and continuation labels so that they +;;; are contiguous within each function and, in the case of labels, +;;; topologically sorted. +;;; +;;; Code: + +(define-module (language cps renumber) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intset) + #:use-module (language cps intmap) + #:export (renumber)) + +(define* (compute-tail-path-lengths conts kfun preds) + (define (add-lengths labels lengths length) + (intset-fold (lambda (label lengths) + (intmap-add! lengths label length)) + labels + lengths)) + (define (compute-next labels lengths) + (intset-fold (lambda (label labels) + (fold1 (lambda (pred labels) + (if (intmap-ref lengths pred (lambda (_) #f)) + labels + (intset-add! labels pred))) + (intmap-ref preds label) + labels)) + labels + empty-intset)) + (define (visit labels lengths length) + (let ((lengths (add-lengths labels lengths length))) + (values (compute-next labels lengths) lengths (1+ length)))) + (match (intmap-ref conts kfun) + (($ $kfun src meta self tail clause) + (worklist-fold visit (intset-add empty-intset tail) empty-intmap 0)))) + +;; Topologically sort the continuation tree starting at k0, using +;; reverse post-order numbering. +(define (sort-labels-locally conts k0 path-lengths) + (define (visit-kf-first? kf kt) + ;; Visit the successor of a branch with the shortest path length to + ;; the tail first, so that if the branches are unsorted, the longer + ;; path length will appear first. This will move a loop exit out of + ;; a loop. + (let ((kf-len (intmap-ref path-lengths kf (lambda (_) #f))) + (kt-len (intmap-ref path-lengths kt (lambda (_) #f)))) + (if kt-len + (or (not kf-len) (< kf-len kt-len) + ;; If the path lengths are the same, preserve original + ;; order to avoid squirreliness. + (and (= kf-len kt-len) (< kt kf))) + (if kf-len #f (< kt kf))))) + (let ((order '()) + (visited empty-intset)) + (let visit ((k k0) (order '()) (visited empty-intset)) + (define (visit2 k0 k1 order visited) + (let-values (((order visited) (visit k0 order visited))) + (visit k1 order visited))) + (if (intset-ref visited k) + (values order visited) + (let ((visited (intset-add visited k))) + (call-with-values + (lambda () + (match (intmap-ref conts k) + (($ $kargs names syms ($ $continue k src exp)) + (match exp + (($ $prompt escape? tag handler) + (visit2 k handler order visited)) + (($ $branch kt) + (if (visit-kf-first? k kt) + (visit2 k kt order visited) + (visit2 kt k order visited))) + (_ + (visit k order visited)))) + (($ $kreceive arity k) (visit k order visited)) + (($ $kclause arity kbody kalt) + (if kalt + (visit2 kalt kbody order visited) + (visit kbody order visited))) + (($ $kfun src meta self tail clause) + (if clause + (visit2 tail clause order visited) + (visit tail order visited))) + (($ $ktail) (values order visited)))) + (lambda (order visited) + ;; Add k to the reverse post-order. + (values (cons k order) visited)))))))) + +(define (compute-renaming conts kfun) + ;; labels := old -> new + ;; vars := old -> new + (define *next-label* -1) + (define *next-var* -1) + (define (rename-label label labels) + (set! *next-label* (1+ *next-label*)) + (intmap-add! labels label *next-label*)) + (define (rename-var sym vars) + (set! *next-var* (1+ *next-var*)) + (intmap-add! vars sym *next-var*)) + (define (rename label labels vars) + (values (rename-label label labels) + (match (intmap-ref conts label) + (($ $kargs names syms exp) + (fold1 rename-var syms vars)) + (($ $kfun src meta self tail clause) + (rename-var self vars)) + (_ vars)))) + (define (maybe-visit-fun kfun labels vars) + (if (intmap-ref labels kfun (lambda (_) #f)) + (values labels vars) + (visit-fun kfun labels vars))) + (define (visit-nested-funs k labels vars) + (match (intmap-ref conts k) + (($ $kargs names syms ($ $continue k src ($ $fun kfun))) + (visit-fun kfun labels vars)) + (($ $kargs names syms ($ $continue k src ($ $rec names* syms* + (($ $fun kfun) ...)))) + (fold2 visit-fun kfun labels vars)) + (($ $kargs names syms ($ $continue k src ($ $closure kfun nfree))) + ;; Closures with zero free vars get copy-propagated so it's + ;; possible to already have visited them. + (maybe-visit-fun kfun labels vars)) + (($ $kargs names syms ($ $continue k src ($ $callk kfun))) + ;; Well-known functions never have a $closure created for them + ;; and are only referenced by their $callk call sites. + (maybe-visit-fun kfun labels vars)) + (_ (values labels vars)))) + (define (visit-fun kfun labels vars) + (let* ((preds (compute-predecessors conts kfun)) + (path-lengths (compute-tail-path-lengths conts kfun preds)) + (order (sort-labels-locally conts kfun path-lengths))) + ;; First rename locally, then recurse on nested functions. + (let-values (((labels vars) (fold2 rename order labels vars))) + (fold2 visit-nested-funs order labels vars)))) + (let-values (((labels vars) (visit-fun kfun empty-intmap empty-intmap))) + (values (persistent-intmap labels) (persistent-intmap vars)))) + +(define* (renumber conts #:optional (kfun 0)) + (let-values (((label-map var-map) (compute-renaming conts kfun))) + (define (rename-label label) (intmap-ref label-map label)) + (define (rename-var var) (intmap-ref var-map var)) + (define (rename-exp exp) + (rewrite-exp exp + ((or ($ $const) ($ $prim)) ,exp) + (($ $closure k nfree) + ($closure (rename-label k) nfree)) + (($ $fun body) + ($fun (rename-label body))) + (($ $rec names vars funs) + ($rec names (map rename-var vars) (map rename-exp funs))) + (($ $values args) + ($values ,(map rename-var args))) + (($ $call proc args) + ($call (rename-var proc) ,(map rename-var args))) + (($ $callk k proc args) + ($callk (rename-label k) (rename-var proc) ,(map rename-var args))) + (($ $branch kt exp) + ($branch (rename-label kt) ,(rename-exp exp))) + (($ $primcall name args) + ($primcall name ,(map rename-var args))) + (($ $prompt escape? tag handler) + ($prompt escape? (rename-var tag) (rename-label handler))))) + (define (rename-arity arity) + (match arity + (($ $arity req opt rest () aok?) + arity) + (($ $arity req opt rest kw aok?) + (match kw + (() arity) + (((kw kw-name kw-var) ...) + (let ((kw (map list kw kw-name (map rename-var kw-var)))) + (make-$arity req opt rest kw aok?))))))) + (persistent-intmap + (intmap-fold + (lambda (old-k new-k out) + (intmap-add! + out + new-k + (rewrite-cont (intmap-ref conts old-k) + (($ $kargs names syms ($ $continue k src exp)) + ($kargs names (map rename-var syms) + ($continue (rename-label k) src ,(rename-exp exp)))) + (($ $kreceive ($ $arity req () rest () #f) k) + ($kreceive req rest (rename-label k))) + (($ $ktail) + ($ktail)) + (($ $kfun src meta self tail clause) + ($kfun src meta (rename-var self) (rename-label tail) + (and clause (rename-label clause)))) + (($ $kclause arity body alternate) + ($kclause ,(rename-arity arity) (rename-label body) + (and alternate (rename-label alternate))))))) + label-map + empty-intmap)))) diff --git a/module/language/cps/self-references.scm b/module/language/cps/self-references.scm new file mode 100644 index 000000000..cbdaaa107 --- /dev/null +++ b/module/language/cps/self-references.scm @@ -0,0 +1,79 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; A pass that replaces free references to recursive functions with +;;; bound references. +;;; +;;; Code: + +(define-module (language cps self-references) + #:use-module (ice-9 match) + #:use-module ((srfi srfi-1) #:select (fold)) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (resolve-self-references)) + +(define* (resolve-self-references cps #:optional (label 0) (env empty-intmap)) + (define (subst var) + (intmap-ref env var (lambda (var) var))) + + (define (rename-exp label cps names vars k src exp) + (let ((exp (rewrite-exp exp + ((or ($ $const) ($ $prim)) ,exp) + (($ $call proc args) + ($call (subst proc) ,(map subst args))) + (($ $callk k proc args) + ($callk k (subst proc) ,(map subst args))) + (($ $primcall name args) + ($primcall name ,(map subst args))) + (($ $branch k ($ $values (arg))) + ($branch k ($values ((subst arg))))) + (($ $branch k ($ $primcall name args)) + ($branch k ($primcall name ,(map subst args)))) + (($ $values args) + ($values ,(map subst args))) + (($ $prompt escape? tag handler) + ($prompt escape? (subst tag) handler))))) + (intmap-replace! cps label + (build-cont + ($kargs names vars ($continue k src ,exp)))))) + + (define (visit-exp cps label names vars k src exp) + (match exp + (($ $fun label) + (resolve-self-references cps label env)) + (($ $rec names vars (($ $fun labels) ...)) + (fold (lambda (label var cps) + (match (intmap-ref cps label) + (($ $kfun src meta self) + (resolve-self-references cps label + (intmap-add env var self))))) + cps labels vars)) + (_ (rename-exp label cps names vars k src exp)))) + + (intset-fold (lambda (label cps) + (match (intmap-ref cps label) + (($ $kargs names vars ($ $continue k src exp)) + (visit-exp cps label names vars k src exp)) + (_ cps))) + (compute-function-body cps label) + cps)) diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm new file mode 100644 index 000000000..a53bdbff6 --- /dev/null +++ b/module/language/cps/simplify.scm @@ -0,0 +1,267 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; The fundamental lambda calculus reductions, like beta and eta +;;; reduction and so on. Pretty lame currently. +;;; +;;; Code: + +(define-module (language cps simplify) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intset) + #:use-module (language cps intmap) + #:export (simplify)) + +(define (intset-maybe-add! set k add?) + (if add? (intset-add! set k) set)) + +(define (intset-add* set k*) + (let lp ((set set) (k* k*)) + (match k* + ((k . k*) (lp (intset-add set k) k*)) + (() set)))) + +(define (intset-add*! set k*) + (fold1 (lambda (k set) (intset-add! set k)) k* set)) + +(define (fold2* f l1 l2 seed) + (let lp ((l1 l1) (l2 l2) (seed seed)) + (match (cons l1 l2) + ((() . ()) seed) + (((x1 . l1) . (x2 . l2)) (lp l1 l2 (f x1 x2 seed)))))) + +(define (transform-conts f conts) + (persistent-intmap + (intmap-fold (lambda (k v out) + (let ((v* (f k v))) + (cond + ((equal? v v*) out) + (v* (intmap-replace! out k v*)) + (else (intmap-remove out k))))) + conts + conts))) + +(define (compute-singly-referenced-vars conts) + (define (visit label cont single multiple) + (define (add-ref var single multiple) + (if (intset-ref single var) + (values single (intset-add! multiple var)) + (values (intset-add! single var) multiple))) + (define (ref var) (add-ref var single multiple)) + (define (ref* vars) (fold2 add-ref vars single multiple)) + (match cont + (($ $kargs _ _ ($ $continue _ _ exp)) + (match exp + ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure)) + (values single multiple)) + (($ $call proc args) + (ref* (cons proc args))) + (($ $callk k proc args) + (ref* (cons proc args))) + (($ $primcall name args) + (ref* args)) + (($ $values args) + (ref* args)) + (($ $branch kt ($ $values (var))) + (ref var)) + (($ $branch kt ($ $primcall name args)) + (ref* args)) + (($ $prompt escape? tag handler) + (ref tag)))) + (_ + (values single multiple)))) + (let*-values (((single multiple) (values empty-intset empty-intset)) + ((single multiple) (intmap-fold visit conts single multiple))) + (intset-subtract (persistent-intset single) + (persistent-intset multiple)))) + +;;; Continuations whose values are simply forwarded to another and not +;;; used in any other way may be elided via eta reduction over labels. +;;; +;;; There is an exception however: we must exclude strongly-connected +;;; components (SCCs). The only kind of SCC we can build out of $values +;;; expressions are infinite loops. +;;; +;;; Condition A below excludes single-node SCCs. Single-node SCCs +;;; cannot be reduced. +;;; +;;; Condition B conservatively excludes edges to labels already marked +;;; as candidates. This prevents back-edges and so breaks SCCs, and is +;;; optimal if labels are sorted. If the labels aren't sorted it's +;;; suboptimal but cheap. +(define (compute-eta-reductions conts kfun) + (let ((singly-used (compute-singly-referenced-vars conts))) + (define (singly-used? vars) + (match vars + (() #t) + ((var . vars) + (and (intset-ref singly-used var) (singly-used? vars))))) + (define (visit-fun kfun body eta) + (define (visit-cont label eta) + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src ($ $values vars))) + (intset-maybe-add! eta label + (match (intmap-ref conts k) + (($ $kargs) + (and (not (eqv? label k)) ; A + (not (intset-ref eta label)) ; B + (singly-used? vars))) + (_ #f)))) + (_ + eta))) + (intset-fold visit-cont body eta)) + (persistent-intset + (intmap-fold visit-fun + (compute-reachable-functions conts kfun) + empty-intset)))) + +(define (eta-reduce conts kfun) + (let ((label-set (compute-eta-reductions conts kfun))) + ;; Replace any continuation to a label in LABEL-SET with the label's + ;; continuation. The label will denote a $kargs continuation, so + ;; only terms that can continue to $kargs need be taken into + ;; account. + (define (subst label) + (if (intset-ref label-set label) + (match (intmap-ref conts label) + (($ $kargs _ _ ($ $continue k)) (subst k))) + label)) + (transform-conts + (lambda (label cont) + (and (not (intset-ref label-set label)) + (rewrite-cont cont + (($ $kargs names syms ($ $continue kf src ($ $branch kt exp))) + ($kargs names syms + ($continue (subst kf) src ($branch (subst kt) ,exp)))) + (($ $kargs names syms ($ $continue k src exp)) + ($kargs names syms + ($continue (subst k) src ,exp))) + (($ $kreceive ($ $arity req () rest () #f) k) + ($kreceive req rest (subst k))) + (($ $kclause arity body alt) + ($kclause ,arity (subst body) alt)) + (_ ,cont)))) + conts))) + +(define (compute-singly-referenced-labels conts body) + (define (add-ref label single multiple) + (define (ref k single multiple) + (if (intset-ref single k) + (values single (intset-add! multiple k)) + (values (intset-add! single k) multiple))) + (define (ref0) (values single multiple)) + (define (ref1 k) (ref k single multiple)) + (define (ref2 k k*) + (if k* + (let-values (((single multiple) (ref k single multiple))) + (ref k* single multiple)) + (ref1 k))) + (match (intmap-ref conts label) + (($ $kreceive arity k) (ref1 k)) + (($ $kfun src meta self ktail kclause) (ref2 ktail kclause)) + (($ $ktail) (ref0)) + (($ $kclause arity kbody kalt) (ref2 kbody kalt)) + (($ $kargs names syms ($ $continue k src exp)) + (ref2 k (match exp (($ $branch k) k) (($ $prompt _ _ k) k) (_ #f)))))) + (let*-values (((single multiple) (values empty-intset empty-intset)) + ((single multiple) (intset-fold add-ref body single multiple))) + (intset-subtract (persistent-intset single) + (persistent-intset multiple)))) + +(define (compute-beta-reductions conts kfun) + (define (visit-fun kfun body beta) + (let ((single (compute-singly-referenced-labels conts body))) + (define (visit-cont label beta) + (match (intmap-ref conts label) + ;; A continuation's body can be inlined in place of a $values + ;; expression if the continuation is a $kargs. It should only + ;; be inlined if it is used only once, and not recursively. + (($ $kargs _ _ ($ $continue k src ($ $values))) + (intset-maybe-add! beta label + (and (intset-ref single k) + (match (intmap-ref conts k) + (($ $kargs) #t) + (_ #f))))) + (_ + beta))) + (intset-fold visit-cont body beta))) + (persistent-intset + (intmap-fold visit-fun + (compute-reachable-functions conts kfun) + empty-intset))) + +(define (compute-beta-var-substitutions conts label-set) + (define (add-var-substs label var-map) + (match (intmap-ref conts label) + (($ $kargs _ _ ($ $continue k _ ($ $values vals))) + (match (intmap-ref conts k) + (($ $kargs names vars) + (fold2* (lambda (var val var-map) + (intmap-add! var-map var val)) + vars vals var-map)))))) + (intset-fold add-var-substs label-set empty-intmap)) + +(define (beta-reduce conts kfun) + (let* ((label-set (compute-beta-reductions conts kfun)) + (var-map (compute-beta-var-substitutions conts label-set))) + (define (subst var) + (match (intmap-ref var-map var (lambda (_) #f)) + (#f var) + (val (subst val)))) + (define (transform-exp label k src exp) + (if (intset-ref label-set label) + (match (intmap-ref conts k) + (($ $kargs _ _ ($ $continue k* src* exp*)) + (transform-exp k k* src* exp*))) + (build-term + ($continue k src + ,(rewrite-exp exp + ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure)) + ,exp) + (($ $call proc args) + ($call (subst proc) ,(map subst args))) + (($ $callk k proc args) + ($callk k (subst proc) ,(map subst args))) + (($ $primcall name args) + ($primcall name ,(map subst args))) + (($ $values args) + ($values ,(map subst args))) + (($ $branch kt ($ $values (var))) + ($branch kt ($values ((subst var))))) + (($ $branch kt ($ $primcall name args)) + ($branch kt ($primcall name ,(map subst args)))) + (($ $prompt escape? tag handler) + ($prompt escape? (subst tag) handler))))))) + (transform-conts + (lambda (label cont) + (match cont + (($ $kargs names syms ($ $continue k src exp)) + (build-cont + ($kargs names syms ,(transform-exp label k src exp)))) + (_ cont))) + conts))) + +(define (simplify conts) + (eta-reduce (beta-reduce conts 0) 0)) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm new file mode 100644 index 000000000..74e71c487 --- /dev/null +++ b/module/language/cps/slot-allocation.scm @@ -0,0 +1,995 @@ +;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; A module to assign stack slots to variables in a CPS term. +;;; +;;; Code: + +(define-module (language cps slot-allocation) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (allocate-slots + lookup-slot + lookup-maybe-slot + lookup-constant-value + lookup-maybe-constant-value + lookup-nlocals + lookup-call-proc-slot + lookup-parallel-moves + lookup-dead-slot-map)) + +(define-record-type $allocation + (make-allocation slots constant-values call-allocs shuffles frame-sizes) + allocation? + + ;; A map of VAR to slot allocation. A slot allocation is an integer, + ;; if the variable has been assigned a slot. + ;; + (slots allocation-slots) + + ;; A map of VAR to constant value, for variables with constant values. + ;; + (constant-values allocation-constant-values) + + ;; A map of LABEL to /call allocs/, for expressions that continue to + ;; $kreceive continuations: non-tail calls and $prompt expressions. + ;; + ;; A call alloc contains two pieces of information: the call's /proc + ;; slot/ and a /dead slot map/. The proc slot indicates the slot of a + ;; procedure in a procedure call, or where the procedure would be in a + ;; multiple-value return. + ;; + ;; The dead slot map indicates, what slots should be ignored by GC + ;; when marking the frame. A dead slot map is a bitfield, as an + ;; integer. + ;; + (call-allocs allocation-call-allocs) + + ;; A map of LABEL to /parallel moves/. Parallel moves shuffle locals + ;; into position for a $call, $callk, or $values, or shuffle returned + ;; values back into place in a $kreceive. + ;; + ;; A set of moves is expressed as an ordered list of (SRC . DST) + ;; moves, where SRC and DST are slots. This may involve a temporary + ;; variable. + ;; + (shuffles allocation-shuffles) + + ;; The number of locals for a $kclause. + ;; + (frame-sizes allocation-frame-sizes)) + +(define-record-type $call-alloc + (make-call-alloc proc-slot dead-slot-map) + call-alloc? + (proc-slot call-alloc-proc-slot) + (dead-slot-map call-alloc-dead-slot-map)) + +(define (lookup-maybe-slot var allocation) + (intmap-ref (allocation-slots allocation) var (lambda (_) #f))) + +(define (lookup-slot var allocation) + (intmap-ref (allocation-slots allocation) var)) + +(define *absent* (list 'absent)) + +(define (lookup-constant-value var allocation) + (let ((value (intmap-ref (allocation-constant-values allocation) var + (lambda (_) *absent*)))) + (when (eq? value *absent*) + (error "Variable does not have constant value" var)) + value)) + +(define (lookup-maybe-constant-value var allocation) + (let ((value (intmap-ref (allocation-constant-values allocation) var + (lambda (_) *absent*)))) + (if (eq? value *absent*) + (values #f #f) + (values #t value)))) + +(define (lookup-call-alloc k allocation) + (intmap-ref (allocation-call-allocs allocation) k)) + +(define (lookup-call-proc-slot k allocation) + (or (call-alloc-proc-slot (lookup-call-alloc k allocation)) + (error "Call has no proc slot" k))) + +(define (lookup-parallel-moves k allocation) + (intmap-ref (allocation-shuffles allocation) k)) + +(define (lookup-dead-slot-map k allocation) + (or (call-alloc-dead-slot-map (lookup-call-alloc k allocation)) + (error "Call has no dead slot map" k))) + +(define (lookup-nlocals k allocation) + (intmap-ref (allocation-frame-sizes allocation) k)) + +(define (intset-pop set) + (match (intset-next set) + (#f (values set #f)) + (i (values (intset-remove set i) i)))) + +(define (solve-flow-equations succs in out kill gen subtract add meet) + "Find a fixed point for flow equations for SUCCS, where IN and OUT are +the initial conditions as intmaps with one key for every node in SUCCS. +KILL and GEN are intmaps indicating the state that is killed or defined +at every node, and SUBTRACT, ADD, and MEET operates on that state." + (define (visit label in out) + (let* ((in-1 (intmap-ref in label)) + (kill-1 (intmap-ref kill label)) + (gen-1 (intmap-ref gen label)) + (out-1 (intmap-ref out label)) + (out-1* (add (subtract in-1 kill-1) gen-1))) + (if (eq? out-1 out-1*) + (values empty-intset in out) + (let ((out (intmap-replace! out label out-1*))) + (call-with-values + (lambda () + (intset-fold (lambda (succ in changed) + (let* ((in-1 (intmap-ref in succ)) + (in-1* (meet in-1 out-1*))) + (if (eq? in-1 in-1*) + (values in changed) + (values (intmap-replace! in succ in-1*) + (intset-add changed succ))))) + (intmap-ref succs label) in empty-intset)) + (lambda (in changed) + (values changed in out))))))) + + (let run ((worklist (intmap-keys succs)) (in in) (out out)) + (call-with-values (lambda () (intset-pop worklist)) + (lambda (worklist popped) + (if popped + (call-with-values (lambda () (visit popped in out)) + (lambda (changed in out) + (run (intset-union worklist changed) in out))) + (values (persistent-intmap in) + (persistent-intmap out))))))) + +(define-syntax-rule (persistent-intmap2 exp) + (call-with-values (lambda () exp) + (lambda (a b) + (values (persistent-intmap a) (persistent-intmap b))))) + +(define (compute-defs-and-uses cps) + "Return two LABEL->VAR... maps indicating values defined at and used +by a label, respectively." + (define (vars->intset vars) + (fold (lambda (var set) (intset-add set var)) empty-intset vars)) + (persistent-intmap2 + (intmap-fold + (lambda (label cont defs uses) + (define (get-defs k) + (match (intmap-ref cps k) + (($ $kargs names vars) (vars->intset vars)) + (_ empty-intset))) + (define (return d u) + (values (intmap-add! defs label d) + (intmap-add! uses label u))) + (match cont + (($ $kfun src meta self) + (return (intset self) empty-intset)) + (($ $kargs _ _ ($ $continue k src exp)) + (match exp + ((or ($ $const) ($ $closure)) + (return (get-defs k) empty-intset)) + (($ $call proc args) + (return (get-defs k) (intset-add (vars->intset args) proc))) + (($ $callk _ proc args) + (return (get-defs k) (intset-add (vars->intset args) proc))) + (($ $primcall name args) + (return (get-defs k) (vars->intset args))) + (($ $branch kt ($ $primcall name args)) + (return empty-intset (vars->intset args))) + (($ $branch kt ($ $values args)) + (return empty-intset (vars->intset args))) + (($ $values args) + (return (get-defs k) (vars->intset args))) + (($ $prompt escape? tag handler) + (return empty-intset (intset tag))))) + (($ $kclause arity body alt) + (return (get-defs body) empty-intset)) + (($ $kreceive arity kargs) + (return (get-defs kargs) empty-intset)) + (($ $ktail) + (return empty-intset empty-intset)))) + cps + empty-intmap + empty-intmap))) + +(define (compute-reverse-control-flow-order preds) + "Return a LABEL->ORDER bijection where ORDER is a contiguous set of +integers starting from 0 and incrementing in sort order." + ;; This is more involved than forward control flow because not all + ;; live labels are reachable from the tail. + (persistent-intmap + (fold2 (lambda (component order n) + (intset-fold (lambda (label order n) + (values (intmap-add! order label n) + (1+ n))) + component order n)) + (reverse (compute-sorted-strongly-connected-components preds)) + empty-intmap 0))) + +(define* (add-prompt-control-flow-edges conts succs #:key complete?) + "For all prompts in DFG in the range [MIN-LABEL, MIN-LABEL + +LABEL-COUNT), invoke F with arguments PROMPT, HANDLER, and BODY for each +body continuation in the prompt." + (define (intset-filter pred set) + (intset-fold (lambda (i set) + (if (pred i) set (intset-remove set i))) + set + set)) + (define (intset-any pred set) + (intset-fold (lambda (i res) + (if (or res (pred i)) #t res)) + set + #f)) + (define (visit-prompt label handler succs) + ;; FIXME: It isn't correct to use all continuations reachable from + ;; the prompt, because that includes continuations outside the + ;; prompt body. This point is moot if the handler's control flow + ;; joins with the the body, as is usually but not always the case. + ;; + ;; One counter-example is when the handler contifies an infinite + ;; loop; in that case we compute a too-large prompt body. This + ;; error is currently innocuous, but we should fix it at some point. + ;; + ;; The fix is to end the body at the corresponding "pop" primcall, + ;; if any. + (let ((body (intset-subtract (compute-function-body conts label) + (compute-function-body conts handler)))) + (define (out-or-back-edge? label) + ;; Most uses of visit-prompt-control-flow don't need every body + ;; continuation, and would be happy getting called only for + ;; continuations that postdominate the rest of the body. Unless + ;; you pass #:complete? #t, we only invoke F on continuations + ;; that can leave the body, or on back-edges in loops. + ;; + ;; You would think that looking for the final "pop" primcall + ;; would be sufficient, but that is incorrect; it's possible for + ;; a loop in the prompt body to be contified, and that loop need + ;; not continue to the pop if it never terminates. The pop could + ;; even be removed by DCE, in that case. + (intset-any (lambda (succ) + (or (not (intset-ref body succ)) + (<= succ label))) + (intmap-ref succs label))) + (intset-fold (lambda (pred succs) + (intmap-replace succs pred handler intset-add)) + (if complete? body (intset-filter out-or-back-edge? body)) + succs))) + (intmap-fold + (lambda (label cont succs) + (match cont + (($ $kargs _ _ + ($ $continue _ _ ($ $prompt escape? tag handler))) + (visit-prompt label handler succs)) + (_ succs))) + conts + succs)) + +(define (rename-keys map old->new) + (persistent-intmap + (intmap-fold (lambda (k v out) + (intmap-add! out (intmap-ref old->new k) v)) + map + empty-intmap))) + +(define (rename-intset set old->new) + (intset-fold (lambda (old set) (intset-add set (intmap-ref old->new old))) + set empty-intset)) + +(define (rename-graph graph old->new) + (persistent-intmap + (intmap-fold (lambda (pred succs out) + (intmap-add! out + (intmap-ref old->new pred) + (rename-intset succs old->new))) + graph + empty-intmap))) + +(define (compute-live-variables cps defs uses) + "Compute and return two values mapping LABEL->VAR..., where VAR... are +the definitions that are live before and after LABEL, as intsets." + (let* ((succs (add-prompt-control-flow-edges cps (compute-successors cps))) + (preds (invert-graph succs)) + (old->new (compute-reverse-control-flow-order preds))) + (call-with-values + (lambda () + (let ((init (rename-keys + (intmap-map (lambda (k v) empty-intset) preds) + old->new))) + (solve-flow-equations (rename-graph preds old->new) + init init + (rename-keys defs old->new) + (rename-keys uses old->new) + intset-subtract intset-union intset-union))) + (lambda (in out) + ;; As a reverse control-flow problem, the values flowing into a + ;; node are actually the live values after the node executes. + ;; Funny, innit? So we return them in the reverse order. + (let ((new->old (invert-bijection old->new))) + (values (rename-keys out new->old) + (rename-keys in new->old))))))) + +(define (compute-needs-slot cps defs uses) + (define (get-defs k) (intmap-ref defs k)) + (define (get-uses label) (intmap-ref uses label)) + (intmap-fold + (lambda (label cont needs-slot) + (intset-union + needs-slot + (match cont + (($ $kargs _ _ ($ $continue k src exp)) + (let ((defs (get-defs label))) + (define (defs+* uses) + (intset-union defs uses)) + (define (defs+ use) + (intset-add defs use)) + (match exp + (($ $const) + empty-intset) + (($ $primcall 'free-ref (closure slot)) + (defs+ closure)) + (($ $primcall 'free-set! (closure slot value)) + (defs+* (intset closure value))) + (($ $primcall 'cache-current-module! (mod . _)) + (defs+ mod)) + (($ $primcall 'cached-toplevel-box _) + defs) + (($ $primcall 'cached-module-box _) + defs) + (($ $primcall 'resolve (name bound?)) + (defs+ name)) + (($ $primcall 'make-vector/immediate (len init)) + (defs+ init)) + (($ $primcall 'vector-ref/immediate (v i)) + (defs+ v)) + (($ $primcall 'vector-set!/immediate (v i x)) + (defs+* (intset v x))) + (($ $primcall 'allocate-struct/immediate (vtable nfields)) + (defs+ vtable)) + (($ $primcall 'struct-ref/immediate (s n)) + (defs+ s)) + (($ $primcall 'struct-set!/immediate (s n x)) + (defs+* (intset s x))) + (($ $primcall 'builtin-ref (idx)) + defs) + (_ + (defs+* (get-uses label)))))) + (($ $kreceive arity k) + ;; Only allocate results of function calls to slots if they are + ;; used. + empty-intset) + (($ $kclause arity body alternate) + (get-defs label)) + (($ $kfun src meta self) + (intset self)) + (($ $ktail) + empty-intset)))) + cps + empty-intset)) + +(define (compute-lazy-vars cps live-in live-out defs needs-slot) + "Compute and return a set of vars whose allocation can be delayed +until their use is seen. These are \"lazy\" vars. A var is lazy if its +uses are calls, it is always dead after the calls, and if the uses flow +to the definition. A flow continues across a node iff the node kills no +values that need slots, and defines only lazy vars. Calls also kill +flows; there's no sense in trying to juggle a pending frame while there +is an active call." + (define (list->intset list) + (persistent-intset + (fold (lambda (i set) (intset-add! set i)) empty-intset list))) + + (let* ((succs (compute-successors cps)) + (gens (intmap-map + (lambda (label cont) + (match cont + (($ $kargs _ _ ($ $continue _ _ ($ $call proc args))) + (intset-subtract (intset-add (list->intset args) proc) + (intmap-ref live-out label))) + (($ $kargs _ _ ($ $continue _ _ ($ $callk _ proc args))) + (intset-subtract (intset-add (list->intset args) proc) + (intmap-ref live-out label))) + (_ #f))) + cps)) + (kills (intmap-map + (lambda (label in) + (let* ((out (intmap-ref live-out label)) + (killed (intset-subtract in out)) + (killed-slots (intset-intersect killed needs-slot))) + (and (eq? killed-slots empty-intset) + ;; Kill output variables that need slots. + (intset-intersect (intmap-ref defs label) + needs-slot)))) + live-in)) + (preds (invert-graph succs)) + (old->new (compute-reverse-control-flow-order preds))) + (define (subtract lazy kill) + (cond + ((eq? lazy empty-intset) + lazy) + ((not kill) + empty-intset) + ((and lazy (eq? empty-intset (intset-subtract kill lazy))) + (intset-subtract lazy kill)) + (else + empty-intset))) + (define (add live gen) (or gen live)) + (define (meet in out) + ;; Initial in is #f. + (if in (intset-intersect in out) out)) + (call-with-values + (lambda () + (let ((succs (rename-graph preds old->new)) + (in (rename-keys (intmap-map (lambda (k v) #f) preds) old->new)) + (out (rename-keys (intmap-map (lambda (k v) #f) preds) old->new)) + ;(out (rename-keys gens old->new)) + (kills (rename-keys kills old->new)) + (gens (rename-keys gens old->new))) + (solve-flow-equations succs in out kills gens subtract add meet))) + (lambda (in out) + ;; A variable is lazy if its uses reach its definition. + (intmap-fold (lambda (label out lazy) + (match (intmap-ref cps label) + (($ $kargs names vars) + (let ((defs (list->intset vars))) + (intset-union lazy (intset-intersect out defs)))) + (_ lazy))) + (rename-keys out (invert-bijection old->new)) + empty-intset))))) + +(define (find-first-zero n) + ;; Naive implementation. + (let lp ((slot 0)) + (if (logbit? slot n) + (lp (1+ slot)) + slot))) + +(define (find-first-trailing-zero n) + (let lp ((slot (let lp ((count 2)) + (if (< n (ash 1 (1- count))) + count + ;; Grow upper bound slower than factor 2 to avoid + ;; needless bignum allocation on 32-bit systems + ;; when there are more than 16 locals. + (lp (+ count (ash count -1))))))) + (if (or (zero? slot) (logbit? (1- slot) n)) + slot + (lp (1- slot))))) + +(define (integers from count) + (if (zero? count) + '() + (cons from (integers (1+ from) (1- count))))) + +(define (solve-parallel-move src dst tmp) + "Solve the parallel move problem between src and dst slot lists, which +are comparable with eqv?. A tmp slot may be used." + + ;; This algorithm is taken from: "Tilting at windmills with Coq: + ;; formal verification of a compilation algorithm for parallel moves" + ;; by Laurence Rideau, Bernard Paul Serpette, and Xavier Leroy + ;; + + (define (split-move moves reg) + (let loop ((revhead '()) (tail moves)) + (match tail + (((and s+d (s . d)) . rest) + (if (eqv? s reg) + (cons d (append-reverse revhead rest)) + (loop (cons s+d revhead) rest))) + (_ #f)))) + + (define (replace-last-source reg moves) + (match moves + ((moves ... (s . d)) + (append moves (list (cons reg d)))))) + + (let loop ((to-move (map cons src dst)) + (being-moved '()) + (moved '()) + (last-source #f)) + ;; 'last-source' should always be equivalent to: + ;; (and (pair? being-moved) (car (last being-moved))) + (match being-moved + (() (match to-move + (() (reverse moved)) + (((and s+d (s . d)) . t1) + (if (or (eqv? s d) ; idempotent + (not s)) ; src is a constant and can be loaded directly + (loop t1 '() moved #f) + (loop t1 (list s+d) moved s))))) + (((and s+d (s . d)) . b) + (match (split-move to-move d) + ((r . t1) (loop t1 (acons d r being-moved) moved last-source)) + (#f (match b + (() (loop to-move '() (cons s+d moved) #f)) + (_ (if (eqv? d last-source) + (loop to-move + (replace-last-source tmp b) + (cons s+d (acons d tmp moved)) + tmp) + (loop to-move b (cons s+d moved) last-source)))))))))) + +(define (compute-shuffles cps slots call-allocs live-in) + (define (add-live-slot slot live-slots) + (logior live-slots (ash 1 slot))) + + (define (get-cont label) + (intmap-ref cps label)) + + (define (get-slot var) + (intmap-ref slots var (lambda (_) #f))) + + (define (get-slots vars) + (let lp ((vars vars)) + (match vars + ((var . vars) (cons (get-slot var) (lp vars))) + (_ '())))) + + (define (get-proc-slot label) + (call-alloc-proc-slot (intmap-ref call-allocs label))) + + (define (compute-live-slots label) + (intset-fold (lambda (var live) + (match (get-slot var) + (#f live) + (slot (add-live-slot slot live)))) + (intmap-ref live-in label) + 0)) + + ;; Although some parallel moves may proceed without a temporary slot, + ;; in general one is needed. That temporary slot must not be part of + ;; the source or destination sets, and that slot should not correspond + ;; to a live variable. Usually the source and destination sets are a + ;; subset of the union of the live sets before and after the move. + ;; However for stack slots that don't have names -- those slots that + ;; correspond to function arguments or to function return values -- it + ;; could be that they are out of the computed live set. In that case + ;; they need to be adjoined to the live set, used when choosing a + ;; temporary slot. + ;; + ;; Note that although we reserve slots 253-255 for shuffling operands + ;; that address less than the full 24-bit range of locals, that + ;; reservation doesn't apply here, because this temporary itself is + ;; used while doing parallel assignment via "mov", and "mov" does not + ;; need shuffling. + (define (compute-tmp-slot live stack-slots) + (find-first-zero (fold add-live-slot live stack-slots))) + + (define (parallel-move src-slots dst-slots tmp-slot) + (solve-parallel-move src-slots dst-slots tmp-slot)) + + (define (compute-receive-shuffles label proc-slot) + (match (get-cont label) + (($ $kreceive arity kargs) + (let* ((results (match (get-cont kargs) + (($ $kargs names vars) vars))) + (value-slots (integers (1+ proc-slot) (length results))) + (result-slots (get-slots results)) + ;; Filter out unused results. + (value-slots (filter-map (lambda (val result) (and result val)) + value-slots result-slots)) + (result-slots (filter (lambda (x) x) result-slots)) + (live (compute-live-slots kargs))) + (parallel-move value-slots + result-slots + (compute-tmp-slot live value-slots)))))) + + (define (add-call-shuffles label k args shuffles) + (match (get-cont k) + (($ $ktail) + (let* ((live (compute-live-slots label)) + (tail-slots (integers 0 (length args))) + (moves (parallel-move (get-slots args) + tail-slots + (compute-tmp-slot live tail-slots)))) + (intmap-add! shuffles label moves))) + (($ $kreceive) + (let* ((live (compute-live-slots label)) + (proc-slot (get-proc-slot label)) + (call-slots (integers proc-slot (length args))) + (arg-moves (parallel-move (get-slots args) + call-slots + (compute-tmp-slot live call-slots)))) + (intmap-add! (intmap-add! shuffles label arg-moves) + k (compute-receive-shuffles k proc-slot)))))) + + (define (add-values-shuffles label k args shuffles) + (match (get-cont k) + (($ $ktail) + (let* ((live (compute-live-slots label)) + (src-slots (get-slots args)) + (dst-slots (integers 1 (length args))) + (moves (parallel-move src-slots dst-slots + (compute-tmp-slot live dst-slots)))) + (intmap-add! shuffles label moves))) + (($ $kargs _ dst-vars) + (let* ((live (logior (compute-live-slots label) + (compute-live-slots k))) + (src-slots (get-slots args)) + (dst-slots (get-slots dst-vars)) + (moves (parallel-move src-slots dst-slots + (compute-tmp-slot live '())))) + (intmap-add! shuffles label moves))))) + + (define (add-prompt-shuffles label k handler shuffles) + (intmap-add! shuffles handler + (compute-receive-shuffles handler (get-proc-slot label)))) + + (define (compute-shuffles label cont shuffles) + (match cont + (($ $kargs names vars ($ $continue k src exp)) + (match exp + (($ $call proc args) + (add-call-shuffles label k (cons proc args) shuffles)) + (($ $callk _ proc args) + (add-call-shuffles label k (cons proc args) shuffles)) + (($ $values args) + (add-values-shuffles label k args shuffles)) + (($ $prompt escape? tag handler) + (add-prompt-shuffles label k handler shuffles)) + (_ shuffles))) + (_ shuffles))) + + (persistent-intmap + (intmap-fold compute-shuffles cps empty-intmap))) + +(define (compute-frame-sizes cps slots call-allocs shuffles) + ;; Minimum frame has one slot: the closure. + (define minimum-frame-size 1) + (define (get-shuffles label) + (intmap-ref shuffles label)) + (define (get-proc-slot label) + (match (intmap-ref call-allocs label (lambda (_) #f)) + (#f 0) ;; Tail call. + (($ $call-alloc proc-slot) proc-slot))) + (define (max-size var size) + (match (intmap-ref slots var (lambda (_) #f)) + (#f size) + (slot (max size (1+ slot))))) + (define (max-size* vars size) + (fold max-size size vars)) + (define (shuffle-size moves size) + (match moves + (() size) + (((src . dst) . moves) + (shuffle-size moves (max size (1+ src) (1+ dst)))))) + (define (call-size label nargs size) + (shuffle-size (get-shuffles label) + (max (+ (get-proc-slot label) nargs) size))) + (define (measure-cont label cont frame-sizes clause size) + (match cont + (($ $kfun) + (values #f #f #f)) + (($ $kclause) + (let ((frame-sizes (if clause + (intmap-add! frame-sizes clause size) + empty-intmap))) + (values frame-sizes label minimum-frame-size))) + (($ $kargs names vars ($ $continue k src exp)) + (values frame-sizes clause + (let ((size (max-size* vars size))) + (match exp + (($ $call proc args) + (call-size label (1+ (length args)) size)) + (($ $callk _ proc args) + (call-size label (1+ (length args)) size)) + (($ $values args) + (shuffle-size (get-shuffles label) size)) + (_ size))))) + (($ $kreceive) + (values frame-sizes clause + (shuffle-size (get-shuffles label) size))) + (($ $ktail) + (values (intmap-add! frame-sizes clause size) #f #f)))) + + (persistent-intmap (intmap-fold measure-cont cps #f #f #f))) + +(define (allocate-args cps) + (intmap-fold (lambda (label cont slots) + (match cont + (($ $kfun src meta self) + (intmap-add! slots self 0)) + (($ $kclause arity body alt) + (match (intmap-ref cps body) + (($ $kargs names vars) + (let lp ((vars vars) (slots slots) (n 1)) + (match vars + (() slots) + ((var . vars) + (let ((n (if (<= 253 n 255) 256 n))) + (lp vars + (intmap-add! slots var n) + (1+ n))))))))) + (_ slots))) + cps empty-intmap)) + +(define-inlinable (add-live-slot slot live-slots) + (logior live-slots (ash 1 slot))) + +(define-inlinable (kill-dead-slot slot live-slots) + (logand live-slots (lognot (ash 1 slot)))) + +(define-inlinable (compute-slot live-slots hint) + ;; Slots 253-255 are reserved for shuffling; see comments in + ;; assembler.scm. + (if (and hint (not (logbit? hint live-slots)) + (or (< hint 253) (> hint 255))) + hint + (let ((slot (find-first-zero live-slots))) + (if (or (< slot 253) (> slot 255)) + slot + (+ 256 (find-first-zero (ash live-slots -256))))))) + +(define (allocate-lazy-vars cps slots call-allocs live-in lazy) + (define (compute-live-slots slots label) + (intset-fold (lambda (var live) + (match (intmap-ref slots var (lambda (_) #f)) + (#f live) + (slot (add-live-slot slot live)))) + (intmap-ref live-in label) + 0)) + + (define (allocate var hint slots live) + (match (and hint (intmap-ref slots var (lambda (_) #f))) + (#f (if (intset-ref lazy var) + (let ((slot (compute-slot live hint))) + (values (intmap-add! slots var slot) + (add-live-slot slot live))) + (values slots live))) + (slot (values slots (add-live-slot slot live))))) + + (define (allocate* vars hints slots live) + (match (vector vars hints) + (#(() ()) slots) + (#((var . vars) (hint . hints)) + (let-values (((slots live) (allocate var hint slots live))) + (allocate* vars hints slots live))))) + + (define (get-proc-slot label) + (match (intmap-ref call-allocs label (lambda (_) #f)) + (#f 0) + (call (call-alloc-proc-slot call)))) + + (define (allocate-call label args slots) + (allocate* args (integers (get-proc-slot label) (length args)) + slots (compute-live-slots slots label))) + + (define (allocate-values label k args slots) + (match (intmap-ref cps k) + (($ $ktail) + (allocate* args (integers 1 (length args)) + slots (compute-live-slots slots label))) + (($ $kargs names vars) + (allocate* args + (map (cut intmap-ref slots <> (lambda (_) #f)) vars) + slots (compute-live-slots slots label))))) + + (define (allocate-lazy label cont slots) + (match cont + (($ $kargs names vars ($ $continue k src exp)) + (match exp + (($ $call proc args) + (allocate-call label (cons proc args) slots)) + (($ $callk _ proc args) + (allocate-call label (cons proc args) slots)) + (($ $values args) + (allocate-values label k args slots)) + (_ slots))) + (_ + slots))) + + ;; Sweep right to left to visit uses before definitions. + (persistent-intmap + (intmap-fold-right allocate-lazy cps slots))) + +(define (allocate-slots cps) + (let*-values (((defs uses) (compute-defs-and-uses cps)) + ((live-in live-out) (compute-live-variables cps defs uses)) + ((constants) (compute-constant-values cps)) + ((needs-slot) (compute-needs-slot cps defs uses)) + ((lazy) (compute-lazy-vars cps live-in live-out defs + needs-slot))) + + (define (empty-live-slots) + #b0) + + (define (compute-call-proc-slot live-slots) + (+ 2 (find-first-trailing-zero live-slots))) + + (define (compute-prompt-handler-proc-slot live-slots) + (if (zero? live-slots) + 0 + (1- (find-first-trailing-zero live-slots)))) + + (define (get-cont label) + (intmap-ref cps label)) + + (define (get-slot slots var) + (intmap-ref slots var (lambda (_) #f))) + + (define (get-slots slots vars) + (let lp ((vars vars)) + (match vars + ((var . vars) (cons (get-slot slots var) (lp vars))) + (_ '())))) + + (define (compute-live-slots* slots label live-vars) + (intset-fold (lambda (var live) + (match (get-slot slots var) + (#f live) + (slot (add-live-slot slot live)))) + (intmap-ref live-vars label) + 0)) + + (define (compute-live-in-slots slots label) + (compute-live-slots* slots label live-in)) + + (define (compute-live-out-slots slots label) + (compute-live-slots* slots label live-out)) + + (define (allocate var hint slots live) + (cond + ((not (intset-ref needs-slot var)) + (values slots live)) + ((get-slot slots var) + => (lambda (slot) + (values slots (add-live-slot slot live)))) + ((and (not hint) (intset-ref lazy var)) + (values slots live)) + (else + (let ((slot (compute-slot live hint))) + (values (intmap-add! slots var slot) + (add-live-slot slot live)))))) + + (define (allocate* vars hints slots live) + (match (vector vars hints) + (#(() ()) (values slots live)) + (#((var . vars) (hint . hints)) + (call-with-values (lambda () (allocate var hint slots live)) + (lambda (slots live) + (allocate* vars hints slots live)))))) + + (define (allocate-defs label vars slots) + (let ((live (compute-live-in-slots slots label)) + (live-vars (intmap-ref live-in label))) + (let lp ((vars vars) (slots slots) (live live)) + (match vars + (() (values slots live)) + ((var . vars) + (call-with-values (lambda () (allocate var #f slots live)) + (lambda (slots live) + (lp vars slots + (let ((slot (get-slot slots var))) + (if (and slot (not (intset-ref live-vars var))) + (kill-dead-slot slot live) + live)))))))))) + + ;; PRE-LIVE are the live slots coming into the term. POST-LIVE + ;; is the subset of PRE-LIVE that is still live after the term + ;; uses its inputs. + (define (allocate-call label k args slots call-allocs pre-live) + (match (get-cont k) + (($ $ktail) + (let ((tail-slots (integers 0 (length args)))) + (values (allocate* args tail-slots slots pre-live) + call-allocs))) + (($ $kreceive arity kargs) + (let*-values + (((post-live) (compute-live-out-slots slots label)) + ((proc-slot) (compute-call-proc-slot post-live)) + ((call-slots) (integers proc-slot (length args))) + ((slots pre-live) (allocate* args call-slots slots pre-live)) + ;; Allow the first result to be hinted by its use, but + ;; hint the remaining results to stay in place. This + ;; strikes a balance between avoiding shuffling, + ;; especially for unused extra values, and avoiding frame + ;; size growth due to sparse locals. + ((slots result-live) + (match (get-cont kargs) + (($ $kargs () ()) + (values slots post-live)) + (($ $kargs (_ . _) (_ . results)) + (let ((result-slots (integers (+ proc-slot 2) + (length results)))) + (allocate* results result-slots slots post-live))))) + ((dead-slot-map) (logand (1- (ash 1 (- proc-slot 2))) + (lognot post-live))) + ((call) (make-call-alloc proc-slot dead-slot-map))) + (values slots + (intmap-add! call-allocs label call)))))) + + (define (allocate-values label k args slots call-allocs) + (match (get-cont k) + (($ $ktail) + (values slots call-allocs)) + (($ $kargs (_) (dst)) + ;; When there is only one value in play, we allow the dst to be + ;; hinted (see compute-lazy-vars). If the src doesn't have a + ;; slot, then the actual slot for the dst would end up being + ;; decided by the call that args it. Because we don't know the + ;; slot, we can't really compute the parallel moves in that + ;; case, so just bail and rely on the bytecode emitter to + ;; handle the one-value case specially. + (match args + ((src) + (let ((post-live (compute-live-out-slots slots label))) + (values (allocate dst (get-slot slots src) slots post-live) + call-allocs))))) + (($ $kargs _ dst-vars) + (let ((src-slots (get-slots slots args)) + (post-live (compute-live-out-slots slots label))) + (values (allocate* dst-vars src-slots slots post-live) + call-allocs))))) + + (define (allocate-prompt label k handler slots call-allocs) + (match (get-cont handler) + (($ $kreceive arity kargs) + (let*-values + (((handler-live) (compute-live-in-slots slots handler)) + ((proc-slot) (compute-prompt-handler-proc-slot handler-live)) + ((dead-slot-map) (logand (1- (ash 1 (- proc-slot 2))) + (lognot handler-live))) + ((result-vars) (match (get-cont kargs) + (($ $kargs names vars) vars))) + ((value-slots) (integers (1+ proc-slot) (length result-vars))) + ((slots result-live) (allocate* result-vars value-slots + slots handler-live))) + (values slots + (intmap-add! call-allocs label + (make-call-alloc proc-slot dead-slot-map))))))) + + (define (allocate-cont label cont slots call-allocs) + (match cont + (($ $kargs names vars ($ $continue k src exp)) + (let-values (((slots live) (allocate-defs label vars slots))) + (match exp + (($ $call proc args) + (allocate-call label k (cons proc args) slots call-allocs live)) + (($ $callk _ proc args) + (allocate-call label k (cons proc args) slots call-allocs live)) + (($ $values args) + (allocate-values label k args slots call-allocs)) + (($ $prompt escape? tag handler) + (allocate-prompt label k handler slots call-allocs)) + (_ + (values slots call-allocs))))) + (_ + (values slots call-allocs)))) + + (call-with-values (lambda () + (let ((slots (allocate-args cps))) + (intmap-fold allocate-cont cps slots empty-intmap))) + (lambda (slots calls) + (let* ((slots (allocate-lazy-vars cps slots calls live-in lazy)) + (shuffles (compute-shuffles cps slots calls live-in)) + (frame-sizes (compute-frame-sizes cps slots calls shuffles))) + (make-allocation slots constants calls shuffles frame-sizes)))))) diff --git a/module/language/cps/spec.scm b/module/language/cps/spec.scm new file mode 100644 index 000000000..7330885ab --- /dev/null +++ b/module/language/cps/spec.scm @@ -0,0 +1,37 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (language cps spec) + #:use-module (system base language) + #:use-module (language cps) + #:use-module (language cps compile-bytecode) + #:export (cps)) + +(define* (write-cps exp #:optional (port (current-output-port))) + (write (unparse-cps exp) port)) + +(define-language cps + #:title "CPS Intermediate Language" + #:reader (lambda (port env) (read port)) + #:printer write-cps + #:parser parse-cps + #:compilers `((bytecode . ,compile-bytecode)) + #:for-humans? #f + ) diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm new file mode 100644 index 000000000..c15fbdb3b --- /dev/null +++ b/module/language/cps/specialize-primcalls.scm @@ -0,0 +1,59 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Some bytecode operations can encode an immediate as an operand. +;;; This pass tranforms generic primcalls to these specialized +;;; primcalls, if possible. +;;; +;;; Code: + +(define-module (language cps specialize-primcalls) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:export (specialize-primcalls)) + +(define (specialize-primcalls conts) + (let ((constants (compute-constant-values conts))) + (define (immediate-u8? var) + (let ((val (intmap-ref constants var (lambda (_) #f)))) + (and (exact-integer? val) (<= 0 val 255)))) + (define (specialize-primcall name args) + (match (cons name args) + (('make-vector (? immediate-u8? n) init) 'make-vector/immediate) + (('vector-ref v (? immediate-u8? n)) 'vector-ref/immediate) + (('vector-set! v (? immediate-u8? n) x) 'vector-set!/immediate) + (('allocate-struct v (? immediate-u8? n)) 'allocate-struct/immediate) + (('struct-ref s (? immediate-u8? n)) 'struct-ref/immediate) + (('struct-set! s (? immediate-u8? n) x) 'struct-set!/immediate) + (_ #f))) + (intmap-map + (lambda (label cont) + (match cont + (($ $kargs names vars ($ $continue k src ($ $primcall name args))) + (let ((name* (specialize-primcall name args))) + (if name* + (build-cont + ($kargs names vars + ($continue k src ($primcall name* args)))) + cont))) + (_ cont))) + conts))) diff --git a/module/language/cps/split-rec.scm b/module/language/cps/split-rec.scm new file mode 100644 index 000000000..2551ac643 --- /dev/null +++ b/module/language/cps/split-rec.scm @@ -0,0 +1,174 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Split functions bound in $rec expressions into strongly-connected +;;; components. The result will be that each $rec binds a +;;; strongly-connected component of mutually recursive functions. +;;; +;;; Code: + +(define-module (language cps split-rec) + #:use-module (ice-9 match) + #:use-module ((srfi srfi-1) #:select (fold)) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps with-cps) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (split-rec)) + +(define (compute-free-vars conts kfun) + "Compute a FUN-LABEL->FREE-VAR... map describing all free variable +references." + (define (add-def var defs) (intset-add! defs var)) + (define (add-defs vars defs) + (match vars + (() defs) + ((var . vars) (add-defs vars (add-def var defs))))) + (define (add-use var uses) (intset-add! uses var)) + (define (add-uses vars uses) + (match vars + (() uses) + ((var . vars) (add-uses vars (add-use var uses))))) + (define (visit-nested-funs body) + (intset-fold + (lambda (label out) + (match (intmap-ref conts label) + (($ $kargs _ _ ($ $continue _ _ + ($ $fun kfun))) + (intmap-union out (visit-fun kfun))) + (($ $kargs _ _ ($ $continue _ _ + ($ $rec _ _ (($ $fun kfun) ...)))) + (fold (lambda (kfun out) + (intmap-union out (visit-fun kfun))) + out kfun)) + (_ out))) + body + empty-intmap)) + (define (visit-fun kfun) + (let* ((body (compute-function-body conts kfun)) + (free (visit-nested-funs body))) + (call-with-values + (lambda () + (intset-fold + (lambda (label defs uses) + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src exp)) + (values + (add-defs vars defs) + (match exp + ((or ($ $const) ($ $prim)) uses) + (($ $fun kfun) + (intset-union (persistent-intset uses) + (intmap-ref free kfun))) + (($ $rec names vars (($ $fun kfun) ...)) + (fold (lambda (kfun uses) + (intset-union (persistent-intset uses) + (intmap-ref free kfun))) + uses kfun)) + (($ $values args) + (add-uses args uses)) + (($ $call proc args) + (add-use proc (add-uses args uses))) + (($ $branch kt ($ $values (arg))) + (add-use arg uses)) + (($ $branch kt ($ $primcall name args)) + (add-uses args uses)) + (($ $primcall name args) + (add-uses args uses)) + (($ $prompt escape? tag handler) + (add-use tag uses))))) + (($ $kfun src meta self) + (values (add-def self defs) uses)) + (_ (values defs uses)))) + body empty-intset empty-intset)) + (lambda (defs uses) + (intmap-add free kfun (intset-subtract + (persistent-intset uses) + (persistent-intset defs))))))) + (visit-fun kfun)) + +(define (compute-split fns free-vars) + (define (get-free kfun) + ;; It's possible for a fun to have been skipped by + ;; compute-free-vars, if the fun isn't reachable. Fall back to + ;; empty-intset for the fun's free vars, in that case. + (intmap-ref free-vars kfun (lambda (_) empty-intset))) + (let* ((vars (intmap-keys fns)) + (edges (intmap-map + (lambda (var kfun) + (intset-intersect (get-free kfun) vars)) + fns))) + (compute-sorted-strongly-connected-components edges))) + +(define (intmap-acons k v map) + (intmap-add map k v)) + +(define (split-rec conts) + (let ((free (compute-free-vars conts 0))) + (with-fresh-name-state conts + (persistent-intmap + (intmap-fold + (lambda (label cont out) + (match cont + (($ $kargs cont-names cont-vars + ($ $continue k src ($ $rec names vars (($ $fun kfuns) ...)))) + (let ((fns (fold intmap-acons empty-intmap vars kfuns)) + (fn-names (fold intmap-acons empty-intmap vars names))) + (match (compute-split fns free) + (() + ;; Remove trivial $rec. + (with-cps out + (setk label ($kargs cont-names cont-vars + ($continue k src ($values ())))))) + ((_) + ;; Bound functions already form a strongly-connected + ;; component. + out) + (components + ;; Multiple components. Split them into separate $rec + ;; expressions. + (define (build-body out components) + (match components + (() + (match (intmap-ref out k) + (($ $kargs names vars term) + (with-cps (intmap-remove out k) + term)))) + ((vars . components) + (match (intset-fold + (lambda (var out) + (let ((name (intmap-ref fn-names var)) + (fun (build-exp + ($fun (intmap-ref fns var))))) + (cons (list name var fun) out))) + vars '()) + (((name var fun) ...) + (with-cps out + (let$ body (build-body components)) + (letk kbody ($kargs name var ,body)) + (build-term + ($continue kbody src ($rec name var fun))))))))) + (with-cps out + (let$ body (build-body components)) + (setk label ($kargs cont-names cont-vars ,body))))))) + (_ out))) + conts + conts))))) diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm new file mode 100644 index 000000000..2104b09ef --- /dev/null +++ b/module/language/cps/type-fold.scm @@ -0,0 +1,425 @@ +;;; Abstract constant folding on CPS +;;; Copyright (C) 2014, 2015 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 License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this program. If not, see +;;; . + +;;; Commentary: +;;; +;;; This pass uses the abstract interpretation provided by type analysis +;;; to fold constant values and type predicates. It is most profitably +;;; run after CSE, to take advantage of scalar replacement. +;;; +;;; Code: + +(define-module (language cps type-fold) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps renumber) + #:use-module (language cps types) + #:use-module (language cps with-cps) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:use-module (system base target) + #:export (type-fold)) + + + + +;; Branch folders. + +(define &scalar-types + (logior &exact-integer &flonum &char &unspecified &false &true &nil &null)) + +(define *branch-folders* (make-hash-table)) + +(define-syntax-rule (define-branch-folder name f) + (hashq-set! *branch-folders* 'name f)) + +(define-syntax-rule (define-branch-folder-alias to from) + (hashq-set! *branch-folders* 'to (hashq-ref *branch-folders* 'from))) + +(define-syntax-rule (define-unary-branch-folder (name arg min max) body ...) + (define-branch-folder name (lambda (arg min max) body ...))) + +(define-syntax-rule (define-binary-branch-folder (name arg0 min0 max0 + arg1 min1 max1) + body ...) + (define-branch-folder name (lambda (arg0 min0 max0 arg1 min1 max1) body ...))) + +(define-syntax-rule (define-unary-type-predicate-folder name &type) + (define-unary-branch-folder (name type min max) + (let ((type* (logand type &type))) + (cond + ((zero? type*) (values #t #f)) + ((eqv? type type*) (values #t #t)) + (else (values #f #f)))))) + +;; All the cases that are in compile-bytecode. +(define-unary-type-predicate-folder pair? &pair) +(define-unary-type-predicate-folder null? &null) +(define-unary-type-predicate-folder nil? &nil) +(define-unary-type-predicate-folder symbol? &symbol) +(define-unary-type-predicate-folder variable? &box) +(define-unary-type-predicate-folder vector? &vector) +(define-unary-type-predicate-folder struct? &struct) +(define-unary-type-predicate-folder string? &string) +(define-unary-type-predicate-folder number? &number) +(define-unary-type-predicate-folder char? &char) + +(define-binary-branch-folder (eq? type0 min0 max0 type1 min1 max1) + (cond + ((or (zero? (logand type0 type1)) (< max0 min1) (< max1 min0)) + (values #t #f)) + ((and (eqv? type0 type1) + (eqv? min0 min1 max0 max1) + (zero? (logand type0 (1- type0))) + (not (zero? (logand type0 &scalar-types)))) + (values #t #t)) + (else + (values #f #f)))) +(define-branch-folder-alias eqv? eq?) +(define-branch-folder-alias equal? eq?) + +(define (compare-ranges type0 min0 max0 type1 min1 max1) + (and (zero? (logand (logior type0 type1) (lognot &real))) + (cond ((< max0 min1) '<) + ((> min0 max1) '>) + ((= min0 max0 min1 max1) '=) + ((<= max0 min1) '<=) + ((>= min0 max1) '>=) + (else #f)))) + +(define-binary-branch-folder (< type0 min0 max0 type1 min1 max1) + (case (compare-ranges type0 min0 max0 type1 min1 max1) + ((<) (values #t #t)) + ((= >= >) (values #t #f)) + (else (values #f #f)))) + +(define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1) + (case (compare-ranges type0 min0 max0 type1 min1 max1) + ((< <= =) (values #t #t)) + ((>) (values #t #f)) + (else (values #f #f)))) + +(define-binary-branch-folder (= type0 min0 max0 type1 min1 max1) + (case (compare-ranges type0 min0 max0 type1 min1 max1) + ((=) (values #t #t)) + ((< >) (values #t #f)) + (else (values #f #f)))) + +(define-binary-branch-folder (>= type0 min0 max0 type1 min1 max1) + (case (compare-ranges type0 min0 max0 type1 min1 max1) + ((> >= =) (values #t #t)) + ((<) (values #t #f)) + (else (values #f #f)))) + +(define-binary-branch-folder (> type0 min0 max0 type1 min1 max1) + (case (compare-ranges type0 min0 max0 type1 min1 max1) + ((>) (values #t #t)) + ((= <= <) (values #t #f)) + (else (values #f #f)))) + +(define-binary-branch-folder (logtest type0 min0 max0 type1 min1 max1) + (define (logand-min a b) + (if (< a b 0) + (min a b) + 0)) + (define (logand-max a b) + (if (< a b 0) + 0 + (max a b))) + (if (and (= min0 max0) (= min1 max1) (eqv? type0 type1 &exact-integer)) + (values #t (logtest min0 min1)) + (values #f #f))) + + + + +;; Strength reduction. + +(define *primcall-reducers* (make-hash-table)) + +(define-syntax-rule (define-primcall-reducer name f) + (hashq-set! *primcall-reducers* 'name f)) + +(define-syntax-rule (define-unary-primcall-reducer (name cps k src + arg type min max) + body ...) + (define-primcall-reducer name + (lambda (cps k src arg type min max) + body ...))) + +(define-syntax-rule (define-binary-primcall-reducer (name cps k src + arg0 type0 min0 max0 + arg1 type1 min1 max1) + body ...) + (define-primcall-reducer name + (lambda (cps k src arg0 type0 min0 max0 arg1 type1 min1 max1) + body ...))) + +(define-binary-primcall-reducer (mul cps k src + arg0 type0 min0 max0 + arg1 type1 min1 max1) + (define (fail) (with-cps cps #f)) + (define (negate arg) + (with-cps cps + ($ (with-cps-constants ((zero 0)) + (build-term + ($continue k src ($primcall 'sub (zero arg)))))))) + (define (zero) + (with-cps cps + (build-term ($continue k src ($const 0))))) + (define (identity arg) + (with-cps cps + (build-term ($continue k src ($values (arg)))))) + (define (double arg) + (with-cps cps + (build-term ($continue k src ($primcall 'add (arg arg)))))) + (define (power-of-two constant arg) + (let ((n (let lp ((bits 0) (constant constant)) + (if (= constant 1) bits (lp (1+ bits) (ash constant -1)))))) + (with-cps cps + ($ (with-cps-constants ((bits n)) + (build-term ($continue k src ($primcall 'ash (arg bits))))))))) + (define (mul/constant constant constant-type arg arg-type) + (cond + ((not (or (= constant-type &exact-integer) (= constant-type arg-type))) + (fail)) + ((eqv? constant -1) + ;; (* arg -1) -> (- 0 arg) + (negate arg)) + ((eqv? constant 0) + ;; (* arg 0) -> 0 if arg is not a flonum or complex + (and (= constant-type &exact-integer) + (zero? (logand arg-type + (lognot (logior &flonum &complex)))) + (zero))) + ((eqv? constant 1) + ;; (* arg 1) -> arg + (identity arg)) + ((eqv? constant 2) + ;; (* arg 2) -> (+ arg arg) + (double arg)) + ((and (= constant-type arg-type &exact-integer) + (positive? constant) + (zero? (logand constant (1- constant)))) + ;; (* arg power-of-2) -> (ash arg (log2 power-of-2 + (power-of-two constant arg)) + (else + (fail)))) + (cond + ((logtest (logior type0 type1) (lognot &number)) (fail)) + ((= min0 max0) (mul/constant min0 type0 arg1 type1)) + ((= min1 max1) (mul/constant min1 type1 arg0 type0)) + (else (fail)))) + +(define-binary-primcall-reducer (logbit? cps k src + arg0 type0 min0 max0 + arg1 type1 min1 max1) + (define (convert-to-logtest cps kbool) + (define (compute-mask cps kmask src) + (if (eq? min0 max0) + (with-cps cps + (build-term + ($continue kmask src ($const (ash 1 min0))))) + (with-cps cps + ($ (with-cps-constants ((one 1)) + (build-term + ($continue kmask src ($primcall 'ash (one arg0))))))))) + (with-cps cps + (letv mask) + (letk kt ($kargs () () + ($continue kbool src ($const #t)))) + (letk kf ($kargs () () + ($continue kbool src ($const #f)))) + (letk kmask ($kargs (#f) (mask) + ($continue kf src + ($branch kt ($primcall 'logtest (mask arg1)))))) + ($ (compute-mask kmask src)))) + ;; Hairiness because we are converting from a primcall with unknown + ;; arity to a branching primcall. + (let ((positive-fixnum-bits (- (* (target-word-size) 8) 3))) + (if (and (= type0 &exact-integer) + (<= 0 min0 positive-fixnum-bits) + (<= 0 max0 positive-fixnum-bits)) + (match (intmap-ref cps k) + (($ $kreceive arity kargs) + (match arity + (($ $arity (_) () (not #f) () #f) + (with-cps cps + (letv bool) + (let$ body (with-cps-constants ((nil '())) + (build-term + ($continue kargs src ($values (bool nil)))))) + (letk kbool ($kargs (#f) (bool) ,body)) + ($ (convert-to-logtest kbool)))) + (_ + (with-cps cps + (letv bool) + (letk kbool ($kargs (#f) (bool) + ($continue k src ($primcall 'values (bool))))) + ($ (convert-to-logtest kbool)))))) + (($ $ktail) + (with-cps cps + (letv bool) + (letk kbool ($kargs (#f) (bool) + ($continue k src ($primcall 'return (bool))))) + ($ (convert-to-logtest kbool))))) + (with-cps cps #f)))) + + + + +;; + +(define (local-type-fold start end cps) + (define (scalar-value type val) + (cond + ((eqv? type &exact-integer) val) + ((eqv? type &flonum) (exact->inexact val)) + ((eqv? type &char) (integer->char val)) + ((eqv? type &unspecified) *unspecified*) + ((eqv? type &false) #f) + ((eqv? type &true) #t) + ((eqv? type &nil) #nil) + ((eqv? type &null) '()) + (else (error "unhandled type" type val)))) + (let ((types (infer-types cps start))) + (define (fold-primcall cps label names vars k src name args def) + (call-with-values (lambda () (lookup-post-type types label def 0)) + (lambda (type min max) + (and (not (zero? type)) + (zero? (logand type (1- type))) + (zero? (logand type (lognot &scalar-types))) + (eqv? min max) + (let ((val (scalar-value type min))) + ;; (pk 'folded src name args val) + (with-cps cps + (letv v*) + (letk k* ($kargs (#f) (v*) + ($continue k src ($const val)))) + ;; Rely on DCE to elide this expression, if + ;; possible. + (setk label + ($kargs names vars + ($continue k* src ($primcall name args)))))))))) + (define (reduce-primcall cps label names vars k src name args) + (and=> + (hashq-ref *primcall-reducers* name) + (lambda (reducer) + (match args + ((arg0) + (call-with-values (lambda () (lookup-pre-type types label arg0)) + (lambda (type0 min0 max0) + (call-with-values (lambda () + (reducer cps k src arg0 type0 min0 max0)) + (lambda (cps term) + (and term + (with-cps cps + (setk label ($kargs names vars ,term))))))))) + ((arg0 arg1) + (call-with-values (lambda () (lookup-pre-type types label arg0)) + (lambda (type0 min0 max0) + (call-with-values (lambda () (lookup-pre-type types label arg1)) + (lambda (type1 min1 max1) + (call-with-values (lambda () + (reducer cps k src arg0 type0 min0 max0 + arg1 type1 min1 max1)) + (lambda (cps term) + (and term + (with-cps cps + (setk label ($kargs names vars ,term))))))))))) + (_ #f))))) + (define (fold-unary-branch cps label names vars kf kt src name arg) + (and=> + (hashq-ref *branch-folders* name) + (lambda (folder) + (call-with-values (lambda () (lookup-pre-type types label arg)) + (lambda (type min max) + (call-with-values (lambda () (folder type min max)) + (lambda (f? v) + ;; (when f? (pk 'folded-unary-branch label name arg v)) + (and f? + (with-cps cps + (setk label + ($kargs names vars + ($continue (if v kt kf) src + ($values ()))))))))))))) + (define (fold-binary-branch cps label names vars kf kt src name arg0 arg1) + (and=> + (hashq-ref *branch-folders* name) + (lambda (folder) + (call-with-values (lambda () (lookup-pre-type types label arg0)) + (lambda (type0 min0 max0) + (call-with-values (lambda () (lookup-pre-type types label arg1)) + (lambda (type1 min1 max1) + (call-with-values (lambda () + (folder type0 min0 max0 type1 min1 max1)) + (lambda (f? v) + ;; (when f? (pk 'folded-binary-branch label name arg0 arg1 v)) + (and f? + (with-cps cps + (setk label + ($kargs names vars + ($continue (if v kt kf) src + ($values ()))))))))))))))) + (define (visit-expression cps label names vars k src exp) + (match exp + (($ $primcall name args) + ;; We might be able to fold primcalls that define a value. + (match (intmap-ref cps k) + (($ $kargs (_) (def)) + (or (fold-primcall cps label names vars k src name args def) + (reduce-primcall cps label names vars k src name args) + cps)) + (_ + (or (reduce-primcall cps label names vars k src name args) + cps)))) + (($ $branch kt ($ $primcall name args)) + ;; We might be able to fold primcalls that branch. + (match args + ((x) + (or (fold-unary-branch cps label names vars k kt src name x) + cps)) + ((x y) + (or (fold-binary-branch cps label names vars k kt src name x y) + cps)))) + (_ cps))) + (let lp ((label start) (cps cps)) + (if (<= label end) + (lp (1+ label) + (match (intmap-ref cps label) + (($ $kargs names vars ($ $continue k src exp)) + (visit-expression cps label names vars k src exp)) + (_ cps))) + cps)))) + +(define (fold-functions-in-renumbered-program f conts seed) + (let* ((conts (persistent-intmap conts)) + (end (1+ (intmap-prev conts)))) + (let lp ((label 0) (seed seed)) + (if (eqv? label end) + seed + (match (intmap-ref conts label) + (($ $kfun src meta self tail clause) + (lp (1+ tail) (f label tail seed)))))))) + +(define (type-fold conts) + ;; Type analysis wants a program whose labels are sorted. + (let ((conts (renumber conts))) + (with-fresh-name-state conts + (persistent-intmap + (fold-functions-in-renumbered-program local-type-fold conts conts))))) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm new file mode 100644 index 000000000..55cde2744 --- /dev/null +++ b/module/language/cps/types.scm @@ -0,0 +1,1408 @@ +;;; Type analysis on CPS +;;; Copyright (C) 2014, 2015 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 License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this program. If not, see +;;; . + +;;; Commentary: +;;; +;;; Type analysis computes the possible types and ranges that values may +;;; have at all program positions. This analysis can help to prove that +;;; a primcall has no side-effects, if its arguments have the +;;; appropriate type and range. It can also enable constant folding of +;;; type predicates and, in the future, enable the compiler to choose +;;; untagged, unboxed representations for numbers. +;;; +;;; For the purposes of this analysis, a "type" is an aspect of a value +;;; that will not change. Guile's CPS intermediate language does not +;;; carry manifest type information that asserts properties about given +;;; values; instead, we recover this information via flow analysis, +;;; garnering properties from type predicates, constant literals, +;;; primcall results, and primcalls that assert that their arguments are +;;; of particular types. +;;; +;;; A range denotes a subset of the set of values in a type, bounded by +;;; a minimum and a maximum. The precise meaning of a range depends on +;;; the type. For real numbers, the range indicates an inclusive lower +;;; and upper bound on the integer value of a type. For vectors, the +;;; range indicates the length of the vector. The range is limited to a +;;; signed 32-bit value, with the smallest and largest values indicating +;;; -inf.0 and +inf.0, respectively. For some types, like pairs, the +;;; concept of "range" makes no sense. In these cases we consider the +;;; range to be -inf.0 to +inf.0. +;;; +;;; Types are represented as a bitfield. Fewer bits means a more precise +;;; type. Although normally only values that have a single type will +;;; have an associated range, this is not enforced. The range applies +;;; to all types in the bitfield. When control flow meets, the types and +;;; ranges meet with the union operator. +;;; +;;; It is not practical to precisely compute value ranges in all cases. +;;; For example, in the following case: +;;; +;;; (let lp ((n 0)) (when (foo) (lp (1+ n)))) +;;; +;;; The first time that range analysis visits the program, N is +;;; determined to be the exact integer 0. The second time, it is an +;;; exact integer in the range [0, 1]; the third, [0, 2]; and so on. +;;; This analysis will terminate, but only after the positive half of +;;; the 32-bit range has been fully explored and we decide that the +;;; range of N is [0, +inf.0]. At the same time, we want to do range +;;; analysis and type analysis at the same time, as there are +;;; interactions between them, notably in the case of `sqrt' which +;;; returns a complex number if its argument cannot be proven to be +;;; non-negative. So what we do instead is to precisely propagate types +;;; and ranges when propagating forward, but after the first backwards +;;; branch is seen, we cause backward branches that would expand the +;;; range of a value to saturate that range towards positive or negative +;;; infinity (as appropriate). +;;; +;;; A naive approach to type analysis would build up a table that has +;;; entries for all variables at all program points, but this has +;;; N-squared complexity and quickly grows unmanageable. Instead, we +;;; use _intmaps_ from (language cps intmap) to share state between +;;; connected program points. +;;; +;;; Code: + +(define-module (language cps types) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-11) + #:export (;; Specific types. + &exact-integer + &flonum + &complex + &fraction + + &char + &unspecified + &unbound + &false + &true + &nil + &null + &symbol + &keyword + + &procedure + + &pointer + &fluid + &pair + &vector + &box + &struct + &string + &bytevector + &bitvector + &array + &hash-table + + ;; Union types. + &number &real + + infer-types + lookup-pre-type + lookup-post-type + primcall-types-check?)) + +(define-syntax define-flags + (lambda (x) + (syntax-case x () + ((_ all shift name ...) + (let ((count (length #'(name ...)))) + (with-syntax (((n ...) (iota count)) + (count count)) + #'(begin + (define-syntax name (identifier-syntax (ash 1 n))) + ... + (define-syntax all (identifier-syntax (1- (ash 1 count)))) + (define-syntax shift (identifier-syntax count))))))))) + +;; More precise types have fewer bits. +(define-flags &all-types &type-bits + &exact-integer + &flonum + &complex + &fraction + + &char + &unspecified + &unbound + &false + &true + &nil + &null + &symbol + &keyword + + &procedure + + &pointer + &fluid + &pair + &vector + &box + &struct + &string + &bytevector + &bitvector + &array + &hash-table) + +(define-syntax &no-type (identifier-syntax 0)) + +(define-syntax &number + (identifier-syntax (logior &exact-integer &flonum &complex &fraction))) +(define-syntax &real + (identifier-syntax (logior &exact-integer &flonum &fraction))) + +(define-syntax *max-s32* (identifier-syntax (- (ash 1 31) 1))) +(define-syntax *min-s32* (identifier-syntax (- 0 (ash 1 31)))) + +;; Versions of min and max that do not coerce exact numbers to become +;; inexact. +(define min + (case-lambda + ((a b) (if (< a b) a b)) + ((a b c) (min (min a b) c)) + ((a b c d) (min (min a b) c d)))) +(define max + (case-lambda + ((a b) (if (> a b) a b)) + ((a b c) (max (max a b) c)) + ((a b c d) (max (max a b) c d)))) + + + +(define-syntax-rule (define-compile-time-value name val) + (define-syntax name + (make-variable-transformer + (lambda (x) + (syntax-case x (set!) + (var (identifier? #'var) + (datum->syntax #'var val))))))) + +(define-compile-time-value min-fixnum most-negative-fixnum) +(define-compile-time-value max-fixnum most-positive-fixnum) + +(define-inlinable (make-unclamped-type-entry type min max) + (vector type min max)) +(define-inlinable (type-entry-type tentry) + (vector-ref tentry 0)) +(define-inlinable (type-entry-clamped-min tentry) + (vector-ref tentry 1)) +(define-inlinable (type-entry-clamped-max tentry) + (vector-ref tentry 2)) + +(define-syntax-rule (clamp-range val) + (cond + ((< val min-fixnum) min-fixnum) + ((< max-fixnum val) max-fixnum) + (else val))) + +(define-inlinable (make-type-entry type min max) + (vector type (clamp-range min) (clamp-range max))) +(define-inlinable (type-entry-min tentry) + (let ((min (type-entry-clamped-min tentry))) + (if (eq? min min-fixnum) -inf.0 min))) +(define-inlinable (type-entry-max tentry) + (let ((max (type-entry-clamped-max tentry))) + (if (eq? max max-fixnum) +inf.0 max))) + +(define all-types-entry (make-type-entry &all-types -inf.0 +inf.0)) + +(define* (var-type-entry typeset var #:optional (default all-types-entry)) + (intmap-ref typeset var (lambda (_) default))) + +(define (var-type typeset var) + (type-entry-type (var-type-entry typeset var))) +(define (var-min typeset var) + (type-entry-min (var-type-entry typeset var))) +(define (var-max typeset var) + (type-entry-max (var-type-entry typeset var))) + +;; Is the type entry A contained entirely within B? +(define (type-entry<=? a b) + (match (cons a b) + ((#(a-type a-min a-max) . #(b-type b-min b-max)) + (and (eqv? b-type (logior a-type b-type)) + (<= b-min a-min) + (>= b-max a-max))))) + +(define (type-entry-union a b) + (cond + ((type-entry<=? b a) a) + ((type-entry<=? a b) b) + (else (make-type-entry + (logior (type-entry-type a) (type-entry-type b)) + (min (type-entry-clamped-min a) (type-entry-clamped-min b)) + (max (type-entry-clamped-max a) (type-entry-clamped-max b)))))) + +(define (type-entry-saturating-union a b) + (cond + ((type-entry<=? b a) a) + (else + (make-type-entry + (logior (type-entry-type a) (type-entry-type b)) + (let ((a-min (type-entry-clamped-min a)) + (b-min (type-entry-clamped-min b))) + (if (< b-min a-min) min-fixnum a-min)) + (let ((a-max (type-entry-clamped-max a)) + (b-max (type-entry-clamped-max b))) + (if (> b-max a-max) max-fixnum a-max)))))) + +(define (type-entry-intersection a b) + (cond + ((type-entry<=? a b) a) + ((type-entry<=? b a) b) + (else (make-type-entry + (logand (type-entry-type a) (type-entry-type b)) + (max (type-entry-clamped-min a) (type-entry-clamped-min b)) + (min (type-entry-clamped-max a) (type-entry-clamped-max b)))))) + +(define (adjoin-var typeset var entry) + (intmap-add typeset var entry type-entry-union)) + +(define (restrict-var typeset var entry) + (intmap-add typeset var entry type-entry-intersection)) + +(define (constant-type val) + "Compute the type and range of VAL. Return three values: the type, +minimum, and maximum." + (define (return type val) + (if val + (make-type-entry type val val) + (make-type-entry type -inf.0 +inf.0))) + (cond + ((number? val) + (cond + ((exact-integer? val) (return &exact-integer val)) + ((eqv? (imag-part val) 0) + (if (nan? val) + (make-type-entry &flonum -inf.0 +inf.0) + (make-type-entry + (if (exact? val) &fraction &flonum) + (if (rational? val) (inexact->exact (floor val)) val) + (if (rational? val) (inexact->exact (ceiling val)) val)))) + (else (return &complex #f)))) + ((eq? val '()) (return &null #f)) + ((eq? val #nil) (return &nil #f)) + ((eq? val #t) (return &true #f)) + ((eq? val #f) (return &false #f)) + ((char? val) (return &char (char->integer val))) + ((eqv? val *unspecified*) (return &unspecified #f)) + ((symbol? val) (return &symbol #f)) + ((keyword? val) (return &keyword #f)) + ((pair? val) (return &pair #f)) + ((vector? val) (return &vector (vector-length val))) + ((string? val) (return &string (string-length val))) + ((bytevector? val) (return &bytevector (bytevector-length val))) + ((bitvector? val) (return &bitvector (bitvector-length val))) + ((array? val) (return &array (array-rank val))) + ((not (variable-bound? (make-variable val))) (return &unbound #f)) + + (else (error "unhandled constant" val)))) + +(define *type-checkers* (make-hash-table)) +(define *type-inferrers* (make-hash-table)) + +(define-syntax-rule (define-type-helper name) + (define-syntax-parameter name + (lambda (stx) + (syntax-violation 'name + "macro used outside of define-type" + stx)))) +(define-type-helper define!) +(define-type-helper restrict!) +(define-type-helper &type) +(define-type-helper &min) +(define-type-helper &max) + +(define-syntax-rule (define-type-checker (name arg ...) body ...) + (hashq-set! + *type-checkers* + 'name + (lambda (typeset arg ...) + (syntax-parameterize + ((&type (syntax-rules () ((_ val) (var-type typeset val)))) + (&min (syntax-rules () ((_ val) (var-min typeset val)))) + (&max (syntax-rules () ((_ val) (var-max typeset val))))) + body ...)))) + +(define-syntax-rule (check-type arg type min max) + ;; If the arg is negative, it is a closure variable. + (and (>= arg 0) + (zero? (logand (lognot type) (&type arg))) + (<= min (&min arg)) + (<= (&max arg) max))) + +(define-syntax-rule (define-type-inferrer* (name succ var ...) body ...) + (hashq-set! + *type-inferrers* + 'name + (lambda (in succ var ...) + (let ((out in)) + (syntax-parameterize + ((define! + (syntax-rules () + ((_ val type min max) + (set! out (adjoin-var out val + (make-type-entry type min max)))))) + (restrict! + (syntax-rules () + ((_ val type min max) + (set! out (restrict-var out val + (make-type-entry type min max)))))) + (&type (syntax-rules () ((_ val) (var-type in val)))) + (&min (syntax-rules () ((_ val) (var-min in val)))) + (&max (syntax-rules () ((_ val) (var-max in val))))) + body ... + out))))) + +(define-syntax-rule (define-type-inferrer (name arg ...) body ...) + (define-type-inferrer* (name succ arg ...) body ...)) + +(define-syntax-rule (define-predicate-inferrer (name arg ... true?) body ...) + (define-type-inferrer* (name succ arg ...) + (let ((true? (not (zero? succ)))) + body ...))) + +(define-syntax define-simple-type-checker + (lambda (x) + (define (parse-spec l) + (syntax-case l () + (() '()) + (((type min max) . l) (cons #'(type min max) (parse-spec #'l))) + (((type min+max) . l) (cons #'(type min+max min+max) (parse-spec #'l))) + ((type . l) (cons #'(type -inf.0 +inf.0) (parse-spec #'l))))) + (syntax-case x () + ((_ (name arg-spec ...) result-spec ...) + (with-syntax + (((arg ...) (generate-temporaries #'(arg-spec ...))) + (((arg-type arg-min arg-max) ...) (parse-spec #'(arg-spec ...)))) + #'(define-type-checker (name arg ...) + (and (check-type arg arg-type arg-min arg-max) + ...))))))) + +(define-syntax define-simple-type-inferrer + (lambda (x) + (define (parse-spec l) + (syntax-case l () + (() '()) + (((type min max) . l) (cons #'(type min max) (parse-spec #'l))) + (((type min+max) . l) (cons #'(type min+max min+max) (parse-spec #'l))) + ((type . l) (cons #'(type -inf.0 +inf.0) (parse-spec #'l))))) + (syntax-case x () + ((_ (name arg-spec ...) result-spec ...) + (with-syntax + (((arg ...) (generate-temporaries #'(arg-spec ...))) + (((arg-type arg-min arg-max) ...) (parse-spec #'(arg-spec ...))) + ((res ...) (generate-temporaries #'(result-spec ...))) + (((res-type res-min res-max) ...) (parse-spec #'(result-spec ...)))) + #'(define-type-inferrer (name arg ... res ...) + (restrict! arg arg-type arg-min arg-max) + ... + (define! res res-type res-min res-max) + ...)))))) + +(define-syntax-rule (define-simple-type (name arg-spec ...) result-spec ...) + (begin + (define-simple-type-checker (name arg-spec ...)) + (define-simple-type-inferrer (name arg-spec ...) result-spec ...))) + +(define-syntax-rule (define-simple-types + ((name arg-spec ...) result-spec ...) + ...) + (begin + (define-simple-type (name arg-spec ...) result-spec ...) + ...)) + +(define-syntax-rule (define-type-checker-aliases orig alias ...) + (let ((check (hashq-ref *type-checkers* 'orig))) + (hashq-set! *type-checkers* 'alias check) + ...)) +(define-syntax-rule (define-type-inferrer-aliases orig alias ...) + (let ((check (hashq-ref *type-inferrers* 'orig))) + (hashq-set! *type-inferrers* 'alias check) + ...)) +(define-syntax-rule (define-type-aliases orig alias ...) + (begin + (define-type-checker-aliases orig alias ...) + (define-type-inferrer-aliases orig alias ...))) + + + + +;;; This list of primcall type definitions follows the order of +;;; effects-analysis.scm; please keep it in a similar order. +;;; +;;; There is no need to add checker definitions for expressions that do +;;; not exhibit the &type-check effect, as callers should not ask if +;;; such an expression does or does not type-check. For those that do +;;; exhibit &type-check, you should define a type inferrer unless the +;;; primcall will never typecheck. +;;; +;;; Likewise there is no need to define inferrers for primcalls which +;;; return &all-types values and which never raise exceptions from which +;;; we can infer the types of incoming values. + + + + +;;; +;;; Generic effect-free predicates. +;;; + +(define-predicate-inferrer (eq? a b true?) + ;; We can only propagate information down the true leg. + (when true? + (let ((type (logand (&type a) (&type b))) + (min (max (&min a) (&min b))) + (max (min (&max a) (&max b)))) + (restrict! a type min max) + (restrict! b type min max)))) +(define-type-inferrer-aliases eq? eqv? equal?) + +(define-syntax-rule (define-simple-predicate-inferrer predicate type) + (define-predicate-inferrer (predicate val true?) + (let ((type (if true? + type + (logand (&type val) (lognot type))))) + (restrict! val type -inf.0 +inf.0)))) +(define-simple-predicate-inferrer pair? &pair) +(define-simple-predicate-inferrer null? &null) +(define-simple-predicate-inferrer nil? &nil) +(define-simple-predicate-inferrer symbol? &symbol) +(define-simple-predicate-inferrer variable? &box) +(define-simple-predicate-inferrer vector? &vector) +(define-simple-predicate-inferrer struct? &struct) +(define-simple-predicate-inferrer string? &string) +(define-simple-predicate-inferrer bytevector? &bytevector) +(define-simple-predicate-inferrer bitvector? &bitvector) +(define-simple-predicate-inferrer keyword? &keyword) +(define-simple-predicate-inferrer number? &number) +(define-simple-predicate-inferrer char? &char) +(define-simple-predicate-inferrer procedure? &procedure) +(define-simple-predicate-inferrer thunk? &procedure) + + + +;;; +;;; Fluids. Note that we can't track bound-ness of fluids, as pop-fluid +;;; can change boundness. +;;; + +(define-simple-types + ((fluid-ref (&fluid 1)) &all-types) + ((fluid-set! (&fluid 0 1) &all-types)) + ((push-fluid (&fluid 0 1) &all-types)) + ((pop-fluid))) + + + + +;;; +;;; Prompts. (Nothing to do.) +;;; + + + + +;;; +;;; Pairs. +;;; + +(define-simple-types + ((cons &all-types &all-types) &pair) + ((car &pair) &all-types) + ((set-car! &pair &all-types)) + ((cdr &pair) &all-types) + ((set-cdr! &pair &all-types))) + + + + +;;; +;;; Variables. +;;; + +(define-simple-types + ((box &all-types) (&box 1)) + ((box-ref (&box 1)) &all-types)) + +(define-simple-type-checker (box-set! (&box 0 1) &all-types)) +(define-type-inferrer (box-set! box val) + (restrict! box &box 1 1)) + + + + +;;; +;;; Vectors. +;;; + +;; This max-vector-len computation is a hack. +(define *max-vector-len* (ash most-positive-fixnum -5)) + +(define-simple-type-checker (make-vector (&exact-integer 0 *max-vector-len*) + &all-types)) +(define-type-inferrer (make-vector size init result) + (restrict! size &exact-integer 0 *max-vector-len*) + (define! result &vector (max (&min size) 0) (&max size))) + +(define-type-checker (vector-ref v idx) + (and (check-type v &vector 0 *max-vector-len*) + (check-type idx &exact-integer 0 (1- (&min v))))) +(define-type-inferrer (vector-ref v idx result) + (restrict! v &vector (1+ (&min idx)) +inf.0) + (restrict! idx &exact-integer 0 (1- (&max v))) + (define! result &all-types -inf.0 +inf.0)) + +(define-type-checker (vector-set! v idx val) + (and (check-type v &vector 0 *max-vector-len*) + (check-type idx &exact-integer 0 (1- (&min v))))) +(define-type-inferrer (vector-set! v idx val) + (restrict! v &vector (1+ (&min idx)) +inf.0) + (restrict! idx &exact-integer 0 (1- (&max v)))) + +(define-type-aliases make-vector make-vector/immediate) +(define-type-aliases vector-ref vector-ref/immediate) +(define-type-aliases vector-set! vector-set!/immediate) + +(define-simple-type-checker (vector-length &vector)) +(define-type-inferrer (vector-length v result) + (restrict! v &vector 0 *max-vector-len*) + (define! result &exact-integer (max (&min v) 0) + (min (&max v) *max-vector-len*))) + + + + +;;; +;;; Structs. +;;; + +;; No type-checker for allocate-struct, as we can't currently check that +;; vt is actually a vtable. +(define-type-inferrer (allocate-struct vt size result) + (restrict! vt &struct vtable-offset-user +inf.0) + (restrict! size &exact-integer 0 +inf.0) + (define! result &struct (max (&min size) 0) (&max size))) + +(define-type-checker (struct-ref s idx) + (and (check-type s &struct 0 +inf.0) + (check-type idx &exact-integer 0 +inf.0) + ;; FIXME: is the field readable? + (< (&max idx) (&min s)))) +(define-type-inferrer (struct-ref s idx result) + (restrict! s &struct (1+ (&min idx)) +inf.0) + (restrict! idx &exact-integer 0 (1- (&max s))) + (define! result &all-types -inf.0 +inf.0)) + +(define-type-checker (struct-set! s idx val) + (and (check-type s &struct 0 +inf.0) + (check-type idx &exact-integer 0 +inf.0) + ;; FIXME: is the field writable? + (< (&max idx) (&min s)))) +(define-type-inferrer (struct-set! s idx val) + (restrict! s &struct (1+ (&min idx)) +inf.0) + (restrict! idx &exact-integer 0 (1- (&max s)))) + +(define-type-aliases allocate-struct allocate-struct/immediate) +(define-type-aliases struct-ref struct-ref/immediate) +(define-type-aliases struct-set! struct-set!/immediate) + +(define-simple-type (struct-vtable (&struct 0 +inf.0)) + (&struct vtable-offset-user +inf.0)) + + + + +;;; +;;; Strings. +;;; + +(define *max-char* (1- (ash 1 24))) + +(define-type-checker (string-ref s idx) + (and (check-type s &string 0 +inf.0) + (check-type idx &exact-integer 0 +inf.0) + (< (&max idx) (&min s)))) +(define-type-inferrer (string-ref s idx result) + (restrict! s &string (1+ (&min idx)) +inf.0) + (restrict! idx &exact-integer 0 (1- (&max s))) + (define! result &char 0 *max-char*)) + +(define-type-checker (string-set! s idx val) + (and (check-type s &string 0 +inf.0) + (check-type idx &exact-integer 0 +inf.0) + (check-type val &char 0 *max-char*) + (< (&max idx) (&min s)))) +(define-type-inferrer (string-set! s idx val) + (restrict! s &string (1+ (&min idx)) +inf.0) + (restrict! idx &exact-integer 0 (1- (&max s))) + (restrict! val &char 0 *max-char*)) + +(define-simple-type-checker (string-length &string)) +(define-type-inferrer (string-length s result) + (restrict! s &string 0 +inf.0) + (define! result &exact-integer (max (&min s) 0) (&max s))) + +(define-simple-type (number->string &number) (&string 0 +inf.0)) +(define-simple-type (string->number (&string 0 +inf.0)) + ((logior &number &false) -inf.0 +inf.0)) + + + + +;;; +;;; Bytevectors. +;;; + +(define-simple-type-checker (bytevector-length &bytevector)) +(define-type-inferrer (bytevector-length bv result) + (restrict! bv &bytevector 0 +inf.0) + (define! result &exact-integer (max (&min bv) 0) (&max bv))) + +(define-syntax-rule (define-bytevector-accessors ref set type size min max) + (begin + (define-type-checker (ref bv idx) + (and (check-type bv &bytevector 0 +inf.0) + (check-type idx &exact-integer 0 +inf.0) + (< (&max idx) (- (&min bv) size)))) + (define-type-inferrer (ref bv idx result) + (restrict! bv &bytevector (+ (&min idx) size) +inf.0) + (restrict! idx &exact-integer 0 (- (&max bv) size)) + (define! result type min max)) + (define-type-checker (set bv idx val) + (and (check-type bv &bytevector 0 +inf.0) + (check-type idx &exact-integer 0 +inf.0) + (check-type val type min max) + (< (&max idx) (- (&min bv) size)))) + (define-type-inferrer (set! bv idx val) + (restrict! bv &bytevector (+ (&min idx) size) +inf.0) + (restrict! idx &exact-integer 0 (- (&max bv) size)) + (restrict! val type min max)))) + +(define-syntax-rule (define-short-bytevector-accessors ref set size signed?) + (define-bytevector-accessors ref set &exact-integer size + (if signed? (- (ash 1 (1- (* size 8)))) 0) + (1- (ash 1 (if signed? (1- (* size 8)) (* size 8)))))) + +(define-short-bytevector-accessors bv-u8-ref bv-u8-set! 1 #f) +(define-short-bytevector-accessors bv-s8-ref bv-s8-set! 1 #t) +(define-short-bytevector-accessors bv-u16-ref bv-u16-set! 2 #f) +(define-short-bytevector-accessors bv-s16-ref bv-s16-set! 2 #t) + +;; The range analysis only works on signed 32-bit values, so some limits +;; are out of range. +(define-bytevector-accessors bv-u32-ref bv-u32-set! &exact-integer 4 0 +inf.0) +(define-bytevector-accessors bv-s32-ref bv-s32-set! &exact-integer 4 -inf.0 +inf.0) +(define-bytevector-accessors bv-u64-ref bv-u64-set! &exact-integer 8 0 +inf.0) +(define-bytevector-accessors bv-s64-ref bv-s64-set! &exact-integer 8 -inf.0 +inf.0) +(define-bytevector-accessors bv-f32-ref bv-f32-set! &real 4 -inf.0 +inf.0) +(define-bytevector-accessors bv-f64-ref bv-f64-set! &real 8 -inf.0 +inf.0) + + + + +;;; +;;; Numbers. +;;; + +;; First, branching primitives with no results. +(define-simple-type-checker (= &number &number)) +(define-predicate-inferrer (= a b true?) + (when (and true? + (zero? (logand (logior (&type a) (&type b)) (lognot &number)))) + (let ((min (max (&min a) (&min b))) + (max (min (&max a) (&max b)))) + (restrict! a &number min max) + (restrict! b &number min max)))) + +(define (restricted-comparison-ranges op type0 min0 max0 type1 min1 max1) + (define (infer-integer-ranges) + (match op + ('< (values min0 (min max0 (1- max1)) (max (1+ min0) min1) max1)) + ('<= (values min0 (min max0 max1) (max min0 min1) max1)) + ('>= (values (max min0 min1) max0 min1 (min max0 max1))) + ('> (values (max min0 (1+ min1)) max0 min1 (min (1- max0) max1))))) + (define (infer-real-ranges) + (match op + ((or '< '<=) (values min0 (min max0 max1) (max min0 min1) max1)) + ((or '> '>=) (values (max min0 min1) max0 min1 (min max0 max1))))) + (if (= (logior type0 type1) &exact-integer) + (infer-integer-ranges) + (infer-real-ranges))) + +(define-syntax-rule (define-comparison-inferrer (op inverse)) + (define-predicate-inferrer (op a b true?) + (when (zero? (logand (logior (&type a) (&type b)) (lognot &number))) + (call-with-values + (lambda () + (restricted-comparison-ranges (if true? 'op 'inverse) + (&type a) (&min a) (&max a) + (&type b) (&min b) (&max b))) + (lambda (min0 max0 min1 max1) + (restrict! a &real min0 max0) + (restrict! b &real min1 max1)))))) + +(define-simple-type-checker (< &real &real)) +(define-comparison-inferrer (< >=)) + +(define-simple-type-checker (<= &real &real)) +(define-comparison-inferrer (<= >)) + +(define-simple-type-checker (>= &real &real)) +(define-comparison-inferrer (>= <)) + +(define-simple-type-checker (> &real &real)) +(define-comparison-inferrer (> <=)) + +;; Arithmetic. +(define-syntax-rule (define-unary-result! a result min max) + (let ((min* min) + (max* max) + (type (logand (&type a) &number))) + (cond + ((not (= type (&type a))) + ;; Not a number. Punt and do nothing. + (define! result &all-types -inf.0 +inf.0)) + ;; Complex numbers don't have a range. + ((eqv? type &complex) + (define! result &complex -inf.0 +inf.0)) + (else + (define! result type min* max*))))) + +(define-syntax-rule (define-binary-result! a b result closed? min max) + (let ((min* min) + (max* max) + (a-type (logand (&type a) &number)) + (b-type (logand (&type b) &number))) + (cond + ((or (not (= a-type (&type a))) (not (= b-type (&type b)))) + ;; One input not a number. Perhaps we end up dispatching to + ;; GOOPS. + (define! result &all-types -inf.0 +inf.0)) + ;; Complex and floating-point numbers are contagious. + ((or (eqv? a-type &complex) (eqv? b-type &complex)) + (define! result &complex -inf.0 +inf.0)) + ((or (eqv? a-type &flonum) (eqv? b-type &flonum)) + (define! result &flonum min* max*)) + ;; Exact integers are closed under some operations. + ((and closed? (eqv? a-type &exact-integer) (eqv? b-type &exact-integer)) + (define! result &exact-integer min* max*)) + (else + ;; Fractions may become integers. + (let ((type (logior a-type b-type))) + (define! result + (if (zero? (logand type &fraction)) + type + (logior type &exact-integer)) + min* max*)))))) + +(define-simple-type-checker (add &number &number)) +(define-type-inferrer (add a b result) + (define-binary-result! a b result #t + (+ (&min a) (&min b)) + (+ (&max a) (&max b)))) + +(define-simple-type-checker (sub &number &number)) +(define-type-inferrer (sub a b result) + (define-binary-result! a b result #t + (- (&min a) (&max b)) + (- (&max a) (&min b)))) + +(define-simple-type-checker (mul &number &number)) +(define-type-inferrer (mul a b result) + (let ((min-a (&min a)) (max-a (&max a)) + (min-b (&min b)) (max-b (&max b)) + ;; We only really get +inf.0 at runtime for flonums and + ;; compnums. If we have inferred that the arguments are not + ;; flonums and not compnums, then the result of (* +inf.0 0) at + ;; range inference time is 0 and not +nan.0. + (nan-impossible? (not (logtest (logior (&type a) (&type b)) + (logior &flonum &complex))))) + (define (nan* a b) + (if (and (or (and (inf? a) (zero? b)) + (and (zero? a) (inf? b))) + nan-impossible?) + 0 + (* a b))) + (let ((-- (nan* min-a min-b)) + (-+ (nan* min-a max-b)) + (++ (nan* max-a max-b)) + (+- (nan* max-a min-b))) + (let ((has-nan? (or (nan? --) (nan? -+) (nan? ++) (nan? +-)))) + (define-binary-result! a b result #t + (cond + ((eqv? a b) 0) + (has-nan? -inf.0) + (else (min -- -+ ++ +-))) + (if has-nan? + +inf.0 + (max -- -+ ++ +-))))))) + +(define-type-checker (div a b) + (and (check-type a &number -inf.0 +inf.0) + (check-type b &number -inf.0 +inf.0) + ;; We only know that there will not be an exception if b is not + ;; zero. + (not (<= (&min b) 0 (&max b))))) +(define-type-inferrer (div a b result) + (let ((min-a (&min a)) (max-a (&max a)) + (min-b (&min b)) (max-b (&max b))) + (call-with-values + (lambda () + (if (<= min-b 0 max-b) + ;; If the range of the divisor crosses 0, the result spans + ;; the whole range. + (values -inf.0 +inf.0) + ;; Otherwise min-b and max-b have the same sign, and cannot both + ;; be infinity. + (let ((--- (if (inf? min-b) 0 (floor/ min-a min-b))) + (-+- (if (inf? max-b) 0 (floor/ min-a max-b))) + (++- (if (inf? max-b) 0 (floor/ max-a max-b))) + (+-- (if (inf? min-b) 0 (floor/ max-a min-b))) + (--+ (if (inf? min-b) 0 (ceiling/ min-a min-b))) + (-++ (if (inf? max-b) 0 (ceiling/ min-a max-b))) + (+++ (if (inf? max-b) 0 (ceiling/ max-a max-b))) + (+-+ (if (inf? min-b) 0 (ceiling/ max-a min-b)))) + (values (min (min --- -+- ++- +--) + (min --+ -++ +++ +-+)) + (max (max --- -+- ++- +--) + (max --+ -++ +++ +-+)))))) + (lambda (min max) + (define-binary-result! a b result #f min max))))) + +(define-simple-type-checker (add1 &number)) +(define-type-inferrer (add1 a result) + (define-unary-result! a result (1+ (&min a)) (1+ (&max a)))) + +(define-simple-type-checker (sub1 &number)) +(define-type-inferrer (sub1 a result) + (define-unary-result! a result (1- (&min a)) (1- (&max a)))) + +(define-type-checker (quo a b) + (and (check-type a &exact-integer -inf.0 +inf.0) + (check-type b &exact-integer -inf.0 +inf.0) + ;; We only know that there will not be an exception if b is not + ;; zero. + (not (<= (&min b) 0 (&max b))))) +(define-type-inferrer (quo a b result) + (restrict! a &exact-integer -inf.0 +inf.0) + (restrict! b &exact-integer -inf.0 +inf.0) + (define! result &exact-integer -inf.0 +inf.0)) + +(define-type-checker-aliases quo rem) +(define-type-inferrer (rem a b result) + (restrict! a &exact-integer -inf.0 +inf.0) + (restrict! b &exact-integer -inf.0 +inf.0) + ;; Same sign as A. + (let ((max-abs-rem (1- (max (abs (&min b)) (abs (&max b)))))) + (cond + ((< (&min a) 0) + (if (< 0 (&max a)) + (define! result &exact-integer (- max-abs-rem) max-abs-rem) + (define! result &exact-integer (- max-abs-rem) 0))) + (else + (define! result &exact-integer 0 max-abs-rem))))) + +(define-type-checker-aliases quo mod) +(define-type-inferrer (mod a b result) + (restrict! a &exact-integer -inf.0 +inf.0) + (restrict! b &exact-integer -inf.0 +inf.0) + ;; Same sign as B. + (let ((max-abs-mod (1- (max (abs (&min b)) (abs (&max b)))))) + (cond + ((< (&min b) 0) + (if (< 0 (&max b)) + (define! result &exact-integer (- max-abs-mod) max-abs-mod) + (define! result &exact-integer (- max-abs-mod) 0))) + (else + (define! result &exact-integer 0 max-abs-mod))))) + +;; Predicates. +(define-syntax-rule (define-number-kind-predicate-inferrer name type) + (define-type-inferrer (name val result) + (cond + ((zero? (logand (&type val) type)) + (define! result &false 0 0)) + ((zero? (logand (&type val) (lognot type))) + (define! result &true 0 0)) + (else + (define! result (logior &true &false) 0 0))))) +(define-number-kind-predicate-inferrer complex? &number) +(define-number-kind-predicate-inferrer real? &real) +(define-number-kind-predicate-inferrer rational? + (logior &exact-integer &fraction)) +(define-number-kind-predicate-inferrer integer? + (logior &exact-integer &flonum)) +(define-number-kind-predicate-inferrer exact-integer? + &exact-integer) + +(define-simple-type-checker (exact? &number)) +(define-type-inferrer (exact? val result) + (restrict! val &number -inf.0 +inf.0) + (cond + ((zero? (logand (&type val) (logior &exact-integer &fraction))) + (define! result &false 0 0)) + ((zero? (logand (&type val) (lognot (logior &exact-integer &fraction)))) + (define! result &true 0 0)) + (else + (define! result (logior &true &false) 0 0)))) + +(define-simple-type-checker (inexact? &number)) +(define-type-inferrer (inexact? val result) + (restrict! val &number -inf.0 +inf.0) + (cond + ((zero? (logand (&type val) (logior &flonum &complex))) + (define! result &false 0 0)) + ((zero? (logand (&type val) (logand &number + (lognot (logior &flonum &complex))))) + (define! result &true 0 0)) + (else + (define! result (logior &true &false) 0 0)))) + +(define-simple-type-checker (inf? &real)) +(define-type-inferrer (inf? val result) + (restrict! val &real -inf.0 +inf.0) + (cond + ((or (zero? (logand (&type val) (logior &flonum &complex))) + (and (not (inf? (&min val))) (not (inf? (&max val))))) + (define! result &false 0 0)) + (else + (define! result (logior &true &false) 0 0)))) + +(define-type-aliases inf? nan?) + +(define-simple-type (even? &exact-integer) + ((logior &true &false) 0 0)) +(define-type-aliases even? odd?) + +;; Bit operations. +(define-simple-type-checker (ash &exact-integer &exact-integer)) +(define-type-inferrer (ash val count result) + (define (ash* val count) + ;; As we can only represent a 32-bit range, don't bother inferring + ;; shifts that might exceed that range. + (cond + ((inf? val) val) ; Preserves sign. + ((< -32 count 32) (ash val count)) + ((zero? val) 0) + ((positive? val) +inf.0) + (else -inf.0))) + (restrict! val &exact-integer -inf.0 +inf.0) + (restrict! count &exact-integer -inf.0 +inf.0) + (let ((-- (ash* (&min val) (&min count))) + (-+ (ash* (&min val) (&max count))) + (++ (ash* (&max val) (&max count))) + (+- (ash* (&max val) (&min count)))) + (define! result &exact-integer + (min -- -+ ++ +-) + (max -- -+ ++ +-)))) + +(define (next-power-of-two n) + (let lp ((out 1)) + (if (< n out) + out + (lp (ash out 1))))) + +(define-simple-type-checker (logand &exact-integer &exact-integer)) +(define-type-inferrer (logand a b result) + (define (logand-min a b) + (if (and (negative? a) (negative? b)) + (min a b) + 0)) + (define (logand-max a b) + (if (and (positive? a) (positive? b)) + (min a b) + 0)) + (restrict! a &exact-integer -inf.0 +inf.0) + (restrict! b &exact-integer -inf.0 +inf.0) + (define! result &exact-integer + (logand-min (&min a) (&min b)) + (logand-max (&max a) (&max b)))) + +(define-simple-type-checker (logior &exact-integer &exact-integer)) +(define-type-inferrer (logior a b result) + ;; Saturate all bits of val. + (define (saturate val) + (1- (next-power-of-two val))) + (define (logior-min a b) + (cond ((and (< a 0) (<= 0 b)) a) + ((and (< b 0) (<= 0 a)) b) + (else (max a b)))) + (define (logior-max a b) + ;; If either operand is negative, just assume the max is -1. + (cond + ((or (< a 0) (< b 0)) -1) + ((or (inf? a) (inf? b)) +inf.0) + (else (saturate (logior a b))))) + (restrict! a &exact-integer -inf.0 +inf.0) + (restrict! b &exact-integer -inf.0 +inf.0) + (define! result &exact-integer + (logior-min (&min a) (&min b)) + (logior-max (&max a) (&max b)))) + +;; For our purposes, treat logxor the same as logior. +(define-type-aliases logior logxor) + +(define-simple-type-checker (lognot &exact-integer)) +(define-type-inferrer (lognot a result) + (restrict! a &exact-integer -inf.0 +inf.0) + (define! result &exact-integer + (- -1 (&max a)) + (- -1 (&min a)))) + +(define-simple-type-checker (logtest &exact-integer &exact-integer)) +(define-predicate-inferrer (logtest a b true?) + (restrict! a &exact-integer -inf.0 +inf.0) + (restrict! b &exact-integer -inf.0 +inf.0)) + +(define-simple-type-checker (logbit? (&exact-integer 0 +inf.0) &exact-integer)) +(define-type-inferrer (logbit? a b result) + (let ((a-min (&min a)) + (a-max (&max a)) + (b-min (&min b)) + (b-max (&max b))) + (if (and (eqv? a-min a-max) (>= a-min 0) (not (inf? a-min)) + (eqv? b-min b-max) (>= b-min 0) (not (inf? b-min))) + (let ((type (if (logbit? a-min b-min) &true &false))) + (define! result type 0 0)) + (define! result (logior &true &false) 0 0)))) + +;; Flonums. +(define-simple-type-checker (sqrt &number)) +(define-type-inferrer (sqrt x result) + (let ((type (&type x))) + (cond + ((and (zero? (logand type &complex)) (<= 0 (&min x))) + (define! result + (logior type &flonum) + (inexact->exact (floor (sqrt (&min x)))) + (if (inf? (&max x)) + +inf.0 + (inexact->exact (ceiling (sqrt (&max x))))))) + (else + (define! result (logior type &flonum &complex) -inf.0 +inf.0))))) + +(define-simple-type-checker (abs &real)) +(define-type-inferrer (abs x result) + (let ((type (&type x))) + (cond + ((eqv? type (logand type &number)) + (restrict! x &real -inf.0 +inf.0) + (define! result (logand type &real) + (min (abs (&min x)) (abs (&max x))) + (max (abs (&min x)) (abs (&max x))))) + (else + (define! result (logior (logand (&type x) (lognot &number)) + (logand (&type x) &real)) + (max (&min x) 0) + (max (abs (&min x)) (abs (&max x)))))))) + + + + +;;; +;;; Characters. +;;; + +(define-simple-type (char=? char>?) + +(define-simple-type-checker (integer->char (&exact-integer 0 #x10ffff))) +(define-type-inferrer (integer->char i result) + (restrict! i &exact-integer 0 #x10ffff) + (define! result &char (max (&min i) 0) (min (&max i) #x10ffff))) + +(define-simple-type-checker (char->integer &char)) +(define-type-inferrer (char->integer c result) + (restrict! c &char 0 #x10ffff) + (define! result &exact-integer (max (&min c) 0) (min (&max c) #x10ffff))) + + + + +;;; +;;; Type flow analysis: the meet (ahem) of the algorithm. +;;; + +(define (successor-count cont) + (match cont + (($ $kargs _ _ ($ $continue k src exp)) + (match exp + ((or ($ $branch) ($ $prompt)) 2) + (_ 1))) + (($ $kfun src meta self tail clause) (if clause 1 0)) + (($ $kclause arity body alt) (if alt 2 1)) + (($ $kreceive) 1) + (($ $ktail) 0))) + +(define (intset-pop set) + (match (intset-next set) + (#f (values set #f)) + (i (values (intset-remove set i) i)))) + +(define-syntax-rule (make-worklist-folder* seed ...) + (lambda (f worklist seed ...) + (let lp ((worklist worklist) (seed seed) ...) + (call-with-values (lambda () (intset-pop worklist)) + (lambda (worklist i) + (if i + (call-with-values (lambda () (f i seed ...)) + (lambda (i* seed ...) + (let add ((i* i*) (worklist worklist)) + (match i* + (() (lp worklist seed ...)) + ((i . i*) (add i* (intset-add worklist i))))))) + (values seed ...))))))) + +(define worklist-fold* + (case-lambda + ((f worklist seed) + ((make-worklist-folder* seed) f worklist seed)))) + +(define intmap-ensure + (let* ((*absent* (list 'absent)) + (not-found (lambda (i) *absent*))) + (lambda (map i ensure) + (let ((val (intmap-ref map i not-found))) + (if (eq? val *absent*) + (let ((val (ensure i))) + (values (intmap-add map i val) val)) + (values map val)))))) + +;; For best results, the labels in the function starting should be +;; topologically sorted (renumbered). Otherwise the backward branch +;; detection mentioned in the module commentary will trigger for +;; ordinary forward branches. +(define (infer-types conts kfun) + "Compute types for all variables bound in the function labelled +@var{kfun}, from @var{conts}. Returns an intmap mapping labels to type +entries. + +A type entry is a vector that describes the types of the values that +flow into and out of a labelled expressoin. The first slot in the type +entry vector corresponds to the types that flow in, and the rest of the +slots correspond to the types that flow out. Each element of the type +entry vector is an intmap mapping variable name to the variable's +inferred type. An inferred type is a 3-vector of type, minimum, and +maximum, where type is a bitset as a fixnum." + (define (get-entry typev label) (intmap-ref typev label)) + (define (entry-not-found label) + (make-vector (1+ (successor-count (intmap-ref conts label))) #f)) + (define (ensure-entry typev label) + (intmap-ensure typev label entry-not-found)) + + (define (compute-initial-state) + (let ((entry (entry-not-found kfun))) + ;; Nothing flows in to the first label. + (vector-set! entry 0 empty-intmap) + (intmap-add empty-intmap kfun entry))) + + (define (adjoin-vars types vars entry) + (match vars + (() types) + ((var . vars) + (adjoin-vars (adjoin-var types var entry) vars entry)))) + + (define (infer-primcall types succ name args result) + (cond + ((hashq-ref *type-inferrers* name) + => (lambda (inferrer) + ;; FIXME: remove the apply? + ;; (pk 'primcall name args result) + (apply inferrer types succ + (if result + (append args (list result)) + args)))) + (result + (adjoin-var types result all-types-entry)) + (else + types))) + + (define (vector-replace vec idx val) + (let ((vec (vector-copy vec))) + (vector-set! vec idx val) + vec)) + + (define (update-out-types label typev types succ-idx) + (let* ((entry (get-entry typev label)) + (old-types (vector-ref entry (1+ succ-idx)))) + (if (eq? types old-types) + (values typev #f) + (let ((entry (vector-replace entry (1+ succ-idx) types)) + (first? (not old-types))) + (values (intmap-replace typev label entry) first?))))) + + (define (update-in-types label typev types saturate?) + (let*-values (((typev entry) (ensure-entry typev label)) + ((old-types) (vector-ref entry 0)) + ;; TODO: If the label has only one predecessor, we can + ;; avoid the meet. + ((types) (if (not old-types) + types + (let ((meet (if saturate? + type-entry-saturating-union + type-entry-union))) + (intmap-intersect old-types types meet))))) + (if (eq? old-types types) + (values typev #f) + (let ((entry (vector-replace entry 0 types))) + (values (intmap-replace typev label entry) #t))))) + + (define (propagate-types label typev succ-idx succ-label types) + (let*-values + (((typev first?) (update-out-types label typev types succ-idx)) + ((saturate?) (and (not first?) (<= succ-label label))) + ((typev changed?) (update-in-types succ-label typev types saturate?))) + (values (if changed? (list succ-label) '()) typev))) + + (define (visit-exp label typev k types exp) + (define (propagate1 succ-label types) + (propagate-types label typev 0 succ-label types)) + (define (propagate2 succ0-label types0 succ1-label types1) + (let*-values (((changed0 typev) + (propagate-types label typev 0 succ0-label types0)) + ((changed1 typev) + (propagate-types label typev 1 succ1-label types1))) + (values (append changed0 changed1) typev))) + ;; Each of these branches must propagate to its successors. + (match exp + (($ $branch kt ($ $values (arg))) + ;; The "normal" continuation is the #f branch. + (let ((kf-types (restrict-var types arg + (make-type-entry (logior &false &nil) + 0 + 0))) + (kt-types (restrict-var types arg + (make-type-entry + (logand &all-types + (lognot (logior &false &nil))) + -inf.0 +inf.0)))) + (propagate2 k kf-types kt kt-types))) + (($ $branch kt ($ $primcall name args)) + ;; The "normal" continuation is the #f branch. + (let ((kf-types (infer-primcall types 0 name args #f)) + (kt-types (infer-primcall types 1 name args #f))) + (propagate2 k kf-types kt kt-types))) + (($ $prompt escape? tag handler) + ;; The "normal" continuation enters the prompt. + (propagate2 k types handler types)) + (($ $primcall name args) + (propagate1 k + (match (intmap-ref conts k) + (($ $kargs _ defs) + (infer-primcall types 0 name args + (match defs ((var) var) (() #f)))) + (_ + ;; (pk 'warning-no-restrictions name) + types)))) + (($ $values args) + (match (intmap-ref conts k) + (($ $kargs _ defs) + (let ((in types)) + (let lp ((defs defs) (args args) (out types)) + (match (cons defs args) + ((() . ()) + (propagate1 k out)) + (((def . defs) . (arg . args)) + (lp defs args + (adjoin-var out def (var-type-entry in arg)))))))) + (_ + (propagate1 k types)))) + ((or ($ $call) ($ $callk)) + (propagate1 k types)) + (($ $rec names vars funs) + (let ((proc-type (make-type-entry &procedure -inf.0 +inf.0))) + (propagate1 k (adjoin-vars types vars proc-type)))) + (_ + (match (intmap-ref conts k) + (($ $kargs (_) (var)) + (let ((entry (match exp + (($ $const val) + (constant-type val)) + ((or ($ $prim) ($ $fun) ($ $closure)) + ;; Could be more precise here. + (make-type-entry &procedure -inf.0 +inf.0))))) + (propagate1 k (adjoin-var types var entry)))))))) + + (define (visit-cont label typev) + (let ((types (vector-ref (intmap-ref typev label) 0))) + (define (propagate0) + (values '() typev)) + (define (propagate1 succ-label types) + (propagate-types label typev 0 succ-label types)) + (define (propagate2 succ0-label types0 succ1-label types1) + (let*-values (((changed0 typev) + (propagate-types label typev 0 succ0-label types0)) + ((changed1 typev) + (propagate-types label typev 1 succ1-label types1))) + (values (append changed0 changed1) typev))) + + ;; Add types for new definitions, and restrict types of + ;; existing variables due to side effects. + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src exp)) + (visit-exp label typev k types exp)) + (($ $kreceive arity k) + (match (intmap-ref conts k) + (($ $kargs names vars) + (propagate1 k (adjoin-vars types vars all-types-entry))))) + (($ $kfun src meta self tail clause) + (if clause + (propagate1 clause (adjoin-var types self all-types-entry)) + (propagate0))) + (($ $kclause arity kbody kalt) + (match (intmap-ref conts kbody) + (($ $kargs _ defs) + (let ((body-types (adjoin-vars types defs all-types-entry))) + (if kalt + (propagate2 kbody body-types kalt types) + (propagate1 kbody body-types)))))) + (($ $ktail) (propagate0))))) + + (worklist-fold* visit-cont + (intset-add empty-intset kfun) + (compute-initial-state))) + +(define (lookup-pre-type types label def) + (let* ((entry (intmap-ref types label)) + (tentry (var-type-entry (vector-ref entry 0) def))) + (values (type-entry-type tentry) + (type-entry-min tentry) + (type-entry-max tentry)))) + +(define (lookup-post-type types label def succ-idx) + (let* ((entry (intmap-ref types label)) + (tentry (var-type-entry (vector-ref entry (1+ succ-idx)) def))) + (values (type-entry-type tentry) + (type-entry-min tentry) + (type-entry-max tentry)))) + +(define (primcall-types-check? types label name args) + (match (hashq-ref *type-checkers* name) + (#f #f) + (checker + (let ((entry (intmap-ref types label))) + (apply checker (vector-ref entry 0) args))))) diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm new file mode 100644 index 000000000..fa4673c4e --- /dev/null +++ b/module/language/cps/utils.scm @@ -0,0 +1,477 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Helper facilities for working with CPS. +;;; +;;; Code: + +(define-module (language cps utils) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (language cps) + #:use-module (language cps intset) + #:use-module (language cps intmap) + #:export (;; Fresh names. + label-counter var-counter + fresh-label fresh-var + with-fresh-name-state compute-max-label-and-var + let-fresh + + ;; Various utilities. + fold1 fold2 + trivial-intset + intmap-map + intmap-keys + invert-bijection invert-partition + intset->intmap + worklist-fold + fixpoint + + ;; Flow analysis. + compute-constant-values + compute-function-body + compute-reachable-functions + compute-successors + invert-graph + compute-predecessors + compute-reverse-post-order + compute-strongly-connected-components + compute-sorted-strongly-connected-components + compute-idoms + compute-dom-edges + )) + +(define label-counter (make-parameter #f)) +(define var-counter (make-parameter #f)) + +(define (fresh-label) + (let ((count (or (label-counter) + (error "fresh-label outside with-fresh-name-state")))) + (label-counter (1+ count)) + count)) + +(define (fresh-var) + (let ((count (or (var-counter) + (error "fresh-var outside with-fresh-name-state")))) + (var-counter (1+ count)) + count)) + +(define-syntax-rule (let-fresh (label ...) (var ...) body ...) + (let* ((label (fresh-label)) ... + (var (fresh-var)) ...) + body ...)) + +(define-syntax-rule (with-fresh-name-state fun body ...) + (call-with-values (lambda () (compute-max-label-and-var fun)) + (lambda (max-label max-var) + (parameterize ((label-counter (1+ max-label)) + (var-counter (1+ max-var))) + body ...)))) + +(define (compute-max-label-and-var conts) + (values (or (intmap-prev conts) -1) + (intmap-fold (lambda (k cont max-var) + (match cont + (($ $kargs names syms body) + (apply max max-var syms)) + (($ $kfun src meta self) + (max max-var self)) + (_ max-var))) + conts + -1))) + +(define-inlinable (fold1 f l s0) + (let lp ((l l) (s0 s0)) + (match l + (() s0) + ((elt . l) (lp l (f elt s0)))))) + +(define-inlinable (fold2 f l s0 s1) + (let lp ((l l) (s0 s0) (s1 s1)) + (match l + (() (values s0 s1)) + ((elt . l) + (call-with-values (lambda () (f elt s0 s1)) + (lambda (s0 s1) + (lp l s0 s1))))))) + +(define (trivial-intset set) + "Returns the sole member of @var{set}, if @var{set} has exactly one +member, or @code{#f} otherwise." + (let ((first (intset-next set))) + (and first + (not (intset-next set (1+ first))) + first))) + +(define (intmap-map proc map) + (persistent-intmap + (intmap-fold (lambda (k v out) (intmap-replace! out k (proc k v))) + map + map))) + +(define (intmap-keys map) + "Return an intset of the keys in @var{map}." + (persistent-intset + (intmap-fold (lambda (k v keys) (intset-add! keys k)) map empty-intset))) + +(define (invert-bijection map) + "Assuming the values of @var{map} are integers and are unique, compute +a map in which each value maps to its key. If the values are not +unique, an error will be signalled." + (intmap-fold (lambda (k v out) (intmap-add out v k)) map empty-intmap)) + +(define (invert-partition map) + "Assuming the values of @var{map} are disjoint intsets, compute a map +in which each member of each set maps to its key. If the values are not +disjoint, an error will be signalled." + (intmap-fold (lambda (k v* out) + (intset-fold (lambda (v out) (intmap-add out v k)) v* out)) + map empty-intmap)) + +(define (intset->intmap f set) + (persistent-intmap + (intset-fold (lambda (label preds) + (intmap-add! preds label (f label))) + set empty-intmap))) + +(define worklist-fold + (case-lambda + ((f in out) + (let lp ((in in) (out out)) + (if (eq? in empty-intset) + out + (call-with-values (lambda () (f in out)) lp)))) + ((f in out0 out1) + (let lp ((in in) (out0 out0) (out1 out1)) + (if (eq? in empty-intset) + (values out0 out1) + (call-with-values (lambda () (f in out0 out1)) lp)))))) + +(define fixpoint + (case-lambda + ((f x) + (let lp ((x x)) + (let ((x* (f x))) + (if (eq? x x*) x* (lp x*))))) + ((f x0 x1) + (let lp ((x0 x0) (x1 x1)) + (call-with-values (lambda () (f x0 x1)) + (lambda (x0* x1*) + (if (and (eq? x0 x0*) (eq? x1 x1*)) + (values x0* x1*) + (lp x0* x1*)))))))) + +(define (compute-defining-expressions conts) + (define (meet-defining-expressions old new) + ;; If there are multiple definitions, punt and + ;; record #f. + #f) + (persistent-intmap + (intmap-fold (lambda (label cont defs) + (match cont + (($ $kargs _ _ ($ $continue k src exp)) + (match (intmap-ref conts k) + (($ $kargs (_) (var)) + (intmap-add! defs var exp meet-defining-expressions)) + (_ defs))) + (_ defs))) + conts + empty-intmap))) + +(define (compute-constant-values conts) + (persistent-intmap + (intmap-fold (lambda (var exp out) + (match exp + (($ $const val) + (intmap-add! out var val)) + (_ out))) + (compute-defining-expressions conts) + empty-intmap))) + +(define (compute-function-body conts kfun) + (persistent-intset + (let visit-cont ((label kfun) (labels empty-intset)) + (cond + ((intset-ref labels label) labels) + (else + (let ((labels (intset-add! labels label))) + (match (intmap-ref conts label) + (($ $kreceive arity k) (visit-cont k labels)) + (($ $kfun src meta self ktail kclause) + (let ((labels (visit-cont ktail labels))) + (if kclause + (visit-cont kclause labels) + labels))) + (($ $ktail) labels) + (($ $kclause arity kbody kalt) + (if kalt + (visit-cont kalt (visit-cont kbody labels)) + (visit-cont kbody labels))) + (($ $kargs names syms ($ $continue k src exp)) + (visit-cont k (match exp + (($ $branch k) + (visit-cont k labels)) + (($ $prompt escape? tag k) + (visit-cont k labels)) + (_ labels))))))))))) + +(define (compute-reachable-functions conts kfun) + "Compute a mapping LABEL->LABEL..., where each key is a reachable +$kfun and each associated value is the body of the function, as an +intset." + (define (intset-cons i set) (intset-add set i)) + (define (visit-fun kfun body to-visit) + (intset-fold + (lambda (label to-visit) + (define (return kfun*) (fold intset-cons to-visit kfun*)) + (define (return1 kfun) (intset-add to-visit kfun)) + (define (return0) to-visit) + (match (intmap-ref conts label) + (($ $kargs _ _ ($ $continue _ _ exp)) + (match exp + (($ $fun label) (return1 label)) + (($ $rec _ _ (($ $fun labels) ...)) (return labels)) + (($ $closure label nfree) (return1 label)) + (($ $callk label) (return1 label)) + (_ (return0)))) + (_ (return0)))) + body + to-visit)) + (let lp ((to-visit (intset kfun)) (visited empty-intmap)) + (let ((to-visit (intset-subtract to-visit (intmap-keys visited)))) + (if (eq? to-visit empty-intset) + visited + (call-with-values + (lambda () + (intset-fold + (lambda (kfun to-visit visited) + (let ((body (compute-function-body conts kfun))) + (values (visit-fun kfun body to-visit) + (intmap-add visited kfun body)))) + to-visit + empty-intset + visited)) + lp))))) + +(define* (compute-successors conts #:optional (kfun (intmap-next conts))) + (define (visit label succs) + (let visit ((label kfun) (succs empty-intmap)) + (define (propagate0) + (intmap-add! succs label empty-intset)) + (define (propagate1 succ) + (visit succ (intmap-add! succs label (intset succ)))) + (define (propagate2 succ0 succ1) + (let ((succs (intmap-add! succs label (intset succ0 succ1)))) + (visit succ1 (visit succ0 succs)))) + (if (intmap-ref succs label (lambda (_) #f)) + succs + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src exp)) + (match exp + (($ $branch kt) (propagate2 k kt)) + (($ $prompt escape? tag handler) (propagate2 k handler)) + (_ (propagate1 k)))) + (($ $kreceive arity k) + (propagate1 k)) + (($ $kfun src meta self tail clause) + (if clause + (propagate2 clause tail) + (propagate1 tail))) + (($ $kclause arity kbody kalt) + (if kalt + (propagate2 kbody kalt) + (propagate1 kbody))) + (($ $ktail) (propagate0)))))) + (persistent-intmap (visit kfun empty-intmap))) + +(define* (compute-predecessors conts kfun #:key + (labels (compute-function-body conts kfun))) + (define (meet cdr car) + (cons car cdr)) + (define (add-preds label preds) + (define (add-pred k preds) + (intmap-add! preds k label meet)) + (match (intmap-ref conts label) + (($ $kreceive arity k) + (add-pred k preds)) + (($ $kfun src meta self ktail kclause) + (add-pred ktail (if kclause (add-pred kclause preds) preds))) + (($ $ktail) + preds) + (($ $kclause arity kbody kalt) + (add-pred kbody (if kalt (add-pred kalt preds) preds))) + (($ $kargs names syms ($ $continue k src exp)) + (add-pred k + (match exp + (($ $branch k) (add-pred k preds)) + (($ $prompt _ _ k) (add-pred k preds)) + (_ preds)))))) + (persistent-intmap + (intset-fold add-preds labels + (intset->intmap (lambda (label) '()) labels)))) + +(define (compute-reverse-post-order succs start) + "Compute a reverse post-order numbering for a depth-first walk over +nodes reachable from the start node." + (let visit ((label start) (order '()) (visited empty-intset)) + (call-with-values + (lambda () + (intset-fold (lambda (succ order visited) + (if (intset-ref visited succ) + (values order visited) + (visit succ order visited))) + (intmap-ref succs label) + order + (intset-add! visited label))) + (lambda (order visited) + ;; After visiting successors, add label to the reverse post-order. + (values (cons label order) visited))))) + +(define (invert-graph succs) + "Given a graph PRED->SUCC..., where PRED is a label and SUCC... is an +intset of successors, return a graph SUCC->PRED...." + (intmap-fold (lambda (pred succs preds) + (intset-fold + (lambda (succ preds) + (intmap-add preds succ pred intset-add)) + succs + preds)) + succs + (intmap-map (lambda (label _) empty-intset) succs))) + +(define (compute-strongly-connected-components succs start) + "Given a LABEL->SUCCESSOR... graph, compute a SCC->LABEL... map +partitioning the labels into strongly connected components (SCCs)." + (let ((preds (invert-graph succs))) + (define (visit-scc scc sccs-by-label) + (let visit ((label scc) (sccs-by-label sccs-by-label)) + (if (intmap-ref sccs-by-label label (lambda (_) #f)) + sccs-by-label + (intset-fold visit + (intmap-ref preds label) + (intmap-add sccs-by-label label scc))))) + (intmap-fold + (lambda (label scc sccs) + (let ((labels (intset-add empty-intset label))) + (intmap-add sccs scc labels intset-union))) + (fold visit-scc empty-intmap (compute-reverse-post-order succs start)) + empty-intmap))) + +(define (compute-sorted-strongly-connected-components edges) + "Given a LABEL->SUCCESSOR... graph, return a list of strongly +connected components in sorted order." + (define nodes + (intmap-keys edges)) + ;; Add a "start" node that links to all nodes in the graph, and then + ;; remove it from the result. + (define start + (if (eq? nodes empty-intset) + 0 + (1+ (intset-prev nodes)))) + (define components + (intmap-remove + (compute-strongly-connected-components (intmap-add edges start nodes) + start) + start)) + (define node-components + (intmap-fold (lambda (id nodes out) + (intset-fold (lambda (node out) (intmap-add out node id)) + nodes out)) + components + empty-intmap)) + (define (node-component node) + (intmap-ref node-components node)) + (define (component-successors id nodes) + (intset-remove + (intset-fold (lambda (node out) + (intset-fold + (lambda (successor out) + (intset-add out (node-component successor))) + (intmap-ref edges node) + out)) + nodes + empty-intset) + id)) + (define component-edges + (intmap-map component-successors components)) + (define preds + (invert-graph component-edges)) + (define roots + (intmap-fold (lambda (id succs out) + (if (eq? empty-intset succs) + (intset-add out id) + out)) + component-edges + empty-intset)) + ;; As above, add a "start" node that links to the roots, and remove it + ;; from the result. + (match (compute-reverse-post-order (intmap-add preds start roots) start) + (((? (lambda (id) (eqv? id start))) . ids) + (map (lambda (id) (intmap-ref components id)) ids)))) + +;; Precondition: For each function in CONTS, the continuation names are +;; topologically sorted. +(define (compute-idoms conts kfun) + ;; This is the iterative O(n^2) fixpoint algorithm, originally from + ;; Allen and Cocke ("Graph-theoretic constructs for program flow + ;; analysis", 1972). See the discussion in Cooper, Harvey, and + ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001. + (let ((preds-map (compute-predecessors conts kfun))) + (define (compute-idom idoms preds) + (define (idom-ref label) + (intmap-ref idoms label (lambda (_) #f))) + (match preds + (() -1) + ((pred) pred) ; Shortcut. + ((pred . preds) + (define (common-idom d0 d1) + ;; We exploit the fact that a reverse post-order is a + ;; topological sort, and so the idom of a node is always + ;; numerically less than the node itself. + (let lp ((d0 d0) (d1 d1)) + (cond + ;; d0 or d1 can be false on the first iteration. + ((not d0) d1) + ((not d1) d0) + ((= d0 d1) d0) + ((< d0 d1) (lp d0 (idom-ref d1))) + (else (lp (idom-ref d0) d1))))) + (fold1 common-idom preds pred)))) + (define (adjoin-idom label preds idoms) + (let ((idom (compute-idom idoms preds))) + ;; Don't use intmap-add! here. + (intmap-add idoms label idom (lambda (old new) new)))) + (fixpoint (lambda (idoms) + (intmap-fold adjoin-idom preds-map idoms)) + empty-intmap))) + +;; Compute a vector containing, for each node, a list of the nodes that +;; it immediately dominates. These are the "D" edges in the DJ tree. +(define (compute-dom-edges idoms) + (define (snoc cdr car) (cons car cdr)) + (persistent-intmap + (intmap-fold (lambda (label idom doms) + (let ((doms (intmap-add! doms label '()))) + (cond + ((< idom 0) doms) ;; No edge to entry. + (else (intmap-add! doms idom label snoc))))) + idoms + empty-intmap))) diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm new file mode 100644 index 000000000..f4413af0d --- /dev/null +++ b/module/language/cps/verify.scm @@ -0,0 +1,306 @@ +;;; Diagnostic checker for CPS +;;; Copyright (C) 2014, 2015 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 License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this program. If not, see +;;; . + +;;; Commentary: +;;; +;;; A routine to detect invalid CPS. +;;; +;;; Code: + +(define-module (language cps verify) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:use-module (language cps primitives) + #:use-module (srfi srfi-11) + #:export (verify)) + +(define (intset-pop set) + (match (intset-next set) + (#f (values set #f)) + (i (values (intset-remove set i) i)))) + +(define-syntax-rule (make-worklist-folder* seed ...) + (lambda (f worklist seed ...) + (let lp ((worklist worklist) (seed seed) ...) + (call-with-values (lambda () (intset-pop worklist)) + (lambda (worklist i) + (if i + (call-with-values (lambda () (f i seed ...)) + (lambda (i* seed ...) + (let add ((i* i*) (worklist worklist)) + (match i* + (() (lp worklist seed ...)) + ((i . i*) (add i* (intset-add worklist i))))))) + (values seed ...))))))) + +(define worklist-fold* + (case-lambda + ((f worklist seed) + ((make-worklist-folder* seed) f worklist seed)))) + +(define (check-distinct-vars conts) + (define (adjoin-def var seen) + (when (intset-ref seen var) + (error "duplicate var name" seen var)) + (intset-add seen var)) + (intmap-fold + (lambda (label cont seen) + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src exp)) + (fold1 adjoin-def vars seen)) + (($ $kfun src meta self tail clause) + (adjoin-def self seen)) + (_ seen)) + ) + conts + empty-intset)) + +(define (compute-available-definitions conts kfun) + "Compute and return a map of LABEL->VAR..., where VAR... are the +definitions that are available at LABEL." + (define (adjoin-def var defs) + (when (intset-ref defs var) + (error "var already present in defs" defs var)) + (intset-add defs var)) + + (define (propagate defs succ out) + (let* ((in (intmap-ref defs succ (lambda (_) #f))) + (in* (if in (intset-intersect in out) out))) + (if (eq? in in*) + (values '() defs) + (values (list succ) + (intmap-add defs succ in* (lambda (old new) new)))))) + + (define (visit-cont label defs) + (let ((in (intmap-ref defs label))) + (define (propagate0 out) + (values '() defs)) + (define (propagate1 succ out) + (propagate defs succ out)) + (define (propagate2 succ0 succ1 out) + (let*-values (((changed0 defs) (propagate defs succ0 out)) + ((changed1 defs) (propagate defs succ1 out))) + (values (append changed0 changed1) defs))) + + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src exp)) + (let ((out (fold1 adjoin-def vars in))) + (match exp + (($ $branch kt) (propagate2 k kt out)) + (($ $prompt escape? tag handler) (propagate2 k handler out)) + (_ (propagate1 k out))))) + (($ $kreceive arity k) + (propagate1 k in)) + (($ $kfun src meta self tail clause) + (let ((out (adjoin-def self in))) + (if clause + (propagate1 clause out) + (propagate0 out)))) + (($ $kclause arity kbody kalt) + (if kalt + (propagate2 kbody kalt in) + (propagate1 kbody in))) + (($ $ktail) (propagate0 in))))) + + (worklist-fold* visit-cont + (intset kfun) + (intmap-add empty-intmap kfun empty-intset))) + +(define (intmap-for-each f map) + (intmap-fold (lambda (k v seed) (f k v) seed) map *unspecified*)) + +(define (check-valid-var-uses conts kfun) + (define (adjoin-def var defs) (intset-add defs var)) + (let visit-fun ((kfun kfun) (free empty-intset) (first-order empty-intset)) + (define (visit-exp exp bound first-order) + (define (check-use var) + (unless (intset-ref bound var) + (error "unbound var" var))) + (define (visit-first-order kfun) + (if (intset-ref first-order kfun) + first-order + (visit-fun kfun empty-intset (intset-add first-order kfun)))) + (match exp + ((or ($ $const) ($ $prim)) first-order) + ;; todo: $closure + (($ $fun kfun) + (visit-fun kfun bound first-order)) + (($ $closure kfun) + (visit-first-order kfun)) + (($ $rec names vars (($ $fun kfuns) ...)) + (let ((bound (fold1 adjoin-def vars bound))) + (fold1 (lambda (kfun first-order) + (visit-fun kfun bound first-order)) + kfuns first-order))) + (($ $values args) + (for-each check-use args) + first-order) + (($ $call proc args) + (check-use proc) + (for-each check-use args) + first-order) + (($ $callk kfun proc args) + (check-use proc) + (for-each check-use args) + (visit-first-order kfun)) + (($ $branch kt ($ $values (arg))) + (check-use arg) + first-order) + (($ $branch kt ($ $primcall name args)) + (for-each check-use args) + first-order) + (($ $primcall name args) + (for-each check-use args) + first-order) + (($ $prompt escape? tag handler) + (check-use tag) + first-order))) + (intmap-fold + (lambda (label bound first-order) + (let ((bound (intset-union free bound))) + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src exp)) + (visit-exp exp (fold1 adjoin-def vars bound) first-order)) + (_ first-order)))) + (compute-available-definitions conts kfun) + first-order))) + +(define (check-label-partition conts kfun) + ;; A continuation can only belong to one function. + (intmap-fold + (lambda (kfun body seen) + (intset-fold + (lambda (label seen) + (intmap-add seen label kfun + (lambda (old new) + (error "label used by two functions" label old new)))) + body + seen)) + (compute-reachable-functions conts kfun) + empty-intmap)) + +(define (compute-reachable-labels conts kfun) + (intmap-fold (lambda (kfun body seen) (intset-union seen body)) + (compute-reachable-functions conts kfun) + empty-intset)) + +(define (check-arities conts kfun) + (define (check-arity exp cont) + (define (assert-unary) + (match cont + (($ $kargs (_) (_)) #t) + (_ (error "expected unary continuation" cont)))) + (define (assert-nullary) + (match cont + (($ $kargs () ()) #t) + (_ (error "expected unary continuation" cont)))) + (define (assert-n-ary n) + (match cont + (($ $kargs names vars) + (unless (= (length vars) n) + (error "expected n-ary continuation" n cont))) + (_ (error "expected $kargs continuation" cont)))) + (define (assert-kreceive-or-ktail) + (match cont + ((or ($ $kreceive) ($ $ktail)) #t) + (_ (error "expected $kreceive or $ktail continuation" cont)))) + (match exp + ((or ($ $const) ($ $prim) ($ $closure) ($ $fun)) + (assert-unary)) + (($ $rec names vars funs) + (unless (= (length names) (length vars) (length funs)) + (error "invalid $rec" exp)) + (assert-n-ary (length names)) + (match cont + (($ $kargs names vars*) + (unless (equal? vars* vars) + (error "bound variable mismatch" vars vars*))))) + (($ $values args) + (match cont + (($ $ktail) #t) + (_ (assert-n-ary (length args))))) + (($ $call proc args) + (assert-kreceive-or-ktail)) + (($ $callk k proc args) + (assert-kreceive-or-ktail)) + (($ $branch kt exp) + (assert-nullary) + (match (intmap-ref conts kt) + (($ $kargs () ()) #t) + (cont (error "bad kt" cont)))) + (($ $primcall name args) + (match cont + (($ $kargs names) + (match (prim-arity name) + ((out . in) + (unless (= in (length args)) + (error "bad arity to primcall" name args in)) + (unless (= out (length names)) + (error "bad return arity from primcall" name names out))))) + (($ $kreceive) + (when (false-if-exception (prim-arity name)) + (error "primitive should continue to $kargs, not $kreceive" name))) + (($ $ktail) + (unless (eq? name 'return) + (when (false-if-exception (prim-arity name)) + (error "primitive should continue to $kargs, not $ktail" name)))))) + (($ $prompt escape? tag handler) + (assert-nullary) + (match (intmap-ref conts handler) + (($ $kreceive) #t) + (cont (error "bad handler" cont)))))) + (let ((reachable (compute-reachable-labels conts kfun))) + (intmap-for-each + (lambda (label cont) + (when (intset-ref reachable label) + (match cont + (($ $kargs names vars ($ $continue k src exp)) + (unless (= (length names) (length vars)) + (error "broken $kargs" label names vars)) + (check-arity exp (intmap-ref conts k))) + (_ #t)))) + conts))) + +(define (check-functions-bound-once conts kfun) + (let ((reachable (compute-reachable-labels conts kfun))) + (define (add-fun fun functions) + (when (intset-ref functions fun) + (error "function already bound" fun)) + (intset-add functions fun)) + (intmap-fold + (lambda (label cont functions) + (if (intset-ref reachable label) + (match cont + (($ $kargs _ _ ($ $continue _ _ ($ $fun kfun))) + (add-fun kfun functions)) + (($ $kargs _ _ ($ $continue _ _ ($ $rec _ _ (($ $fun kfuns) ...)))) + (fold1 add-fun kfuns functions)) + (_ functions)) + functions)) + conts + empty-intset))) + +(define (verify conts) + (check-distinct-vars conts) + (check-label-partition conts 0) + (check-valid-var-uses conts 0) + (check-arities conts 0) + (check-functions-bound-once conts 0) + conts) diff --git a/module/language/cps/with-cps.scm b/module/language/cps/with-cps.scm new file mode 100644 index 000000000..45cb9c4fd --- /dev/null +++ b/module/language/cps/with-cps.scm @@ -0,0 +1,145 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Guile's CPS language is a label->cont mapping, which seems simple +;;; enough. However it's often cumbersome to thread around the output +;;; CPS program when doing non-trivial transformations, or when building +;;; a CPS program from scratch. For example, when visiting an +;;; expression during CPS conversion, we usually already know the label +;;; and the $kargs wrapper for the cont, and just need to know the body +;;; of that cont. However when building the body of that possibly +;;; nested Tree-IL expression we will also need to add conts to the +;;; result, so really it's a process that takes an incoming program, +;;; adds conts to that program, and returns the result program and the +;;; result term. +;;; +;;; It's a bit treacherous to do in a functional style as once you start +;;; adding to a program, you shouldn't add to previous versions of that +;;; program. Getting that right in the context of this program seed +;;; that is threaded through the conversion requires the use of a +;;; pattern, with-cps. +;;; +;;; with-cps goes like this: +;;; +;;; (with-cps cps clause ... tail-clause) +;;; +;;; Valid clause kinds are: +;;; +;;; (letk LABEL CONT) +;;; (setk LABEL CONT) +;;; (letv VAR ...) +;;; (let$ X (PROC ARG ...)) +;;; +;;; letk and letv create fresh CPS labels and variable names, +;;; respectively. Labels and vars bound by letk and letv are in scope +;;; from their point of definition onward. letv just creates fresh +;;; variable names for use in other parts of with-cps, while letk binds +;;; fresh labels to values and adds them to the resulting program. The +;;; right-hand-side of letk, CONT, is passed to build-cont, so it should +;;; be a valid production of that language. setk is like letk but it +;;; doesn't create a fresh label name. +;;; +;;; let$ delegates processing to a sub-computation. The form (PROC ARG +;;; ...) is syntactically altered to be (PROC CPS ARG ...), where CPS is +;;; the value of the program being built, at that point in the +;;; left-to-right with-cps execution. That form is is expected to +;;; evaluate to two values: the new CPS term, and the value to bind to +;;; X. X is in scope for the following with-cps clauses. The name was +;;; chosen because the $ is reminiscent of the $ in CPS data types. +;;; +;;; The result of the with-cps form is determined by the tail clause, +;;; which may be of these kinds: +;;; +;;; ($ (PROC ARG ...)) +;;; (setk LABEL CONT) +;;; EXP +;;; +;;; $ is like let$, but in tail position. If the tail clause is setk, +;;; then only one value is returned, the resulting CPS program. +;;; Otherwise EXP is any kind of expression, which should not add to the +;;; resulting program. Ending the with-cps with EXP is equivalant to +;;; returning (values CPS EXP). +;;; +;;; It's a bit of a monad, innit? Don't tell anyone though! +;;; +;;; Sometimes you need to just bind some constants to CPS values. +;;; with-cps-constants is there for you. For example: +;;; +;;; (with-cps-constants cps ((foo 34)) +;;; (build-term ($values (foo)))) +;;; +;;; The body of with-cps-constants is a with-cps clause, or a sequence +;;; of such clauses. But usually you will want with-cps-constants +;;; inside a with-cps, so it usually looks like this: +;;; +;;; (with-cps cps +;;; ... +;;; ($ (with-cps-constants ((foo 34)) +;;; (build-term ($values (foo)))))) +;;; +;;; which is to say that the $ or the let$ adds the CPS argument for us. +;;; +;;; Code: + +(define-module (language cps with-cps) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:export (with-cps with-cps-constants)) + +(define-syntax with-cps + (syntax-rules (letk setk letv let$ $) + ((_ (exp ...) clause ...) + (let ((cps (exp ...))) + (with-cps cps clause ...))) + ((_ cps (letk label cont) clause ...) + (let-fresh (label) () + (with-cps (intmap-add! cps label (build-cont cont)) + clause ...))) + ((_ cps (setk label cont)) + (intmap-add! cps label (build-cont cont) + (lambda (old new) new))) + ((_ cps (setk label cont) clause ...) + (with-cps (with-cps cps (setk label cont)) + clause ...)) + ((_ cps (letv v ...) clause ...) + (let-fresh () (v ...) + (with-cps cps clause ...))) + ((_ cps (let$ var (proc arg ...)) clause ...) + (call-with-values (lambda () (proc cps arg ...)) + (lambda (cps var) + (with-cps cps clause ...)))) + ((_ cps ($ (proc arg ...))) + (proc cps arg ...)) + ((_ cps exp) + (values cps exp)))) + +(define-syntax with-cps-constants + (syntax-rules () + ((_ cps () clause ...) + (with-cps cps clause ...)) + ((_ cps ((var val) (var* val*) ...) clause ...) + (let ((x val)) + (with-cps cps + (letv var) + (let$ body (with-cps-constants ((var* val*) ...) + clause ...)) + (letk label ($kargs ('var) (var) ,body)) + (build-term ($continue label #f ($const x)))))))) From b40fac1e983007e0b5f4312c1717858e966c0198 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jul 2015 11:39:18 +0200 Subject: [PATCH 034/865] Factor out compute-effects/elide-type-checks from dce.scm * module/language/cps/type-checks.scm: New module. * module/language/cps/dce.scm: Use new module. * module/Makefile.am: Add new module. --- module/Makefile.am | 1 + module/language/cps/dce.scm | 38 +-------------- module/language/cps/type-checks.scm | 72 +++++++++++++++++++++++++++++ 3 files changed, 74 insertions(+), 37 deletions(-) create mode 100644 module/language/cps/type-checks.scm diff --git a/module/Makefile.am b/module/Makefile.am index b29a4bf00..e4b088bef 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -142,6 +142,7 @@ CPS_LANG_SOURCES = \ language/cps/spec.scm \ language/cps/specialize-primcalls.scm \ language/cps/split-rec.scm \ + language/cps/type-checks.scm \ language/cps/type-fold.scm \ language/cps/types.scm \ language/cps/utils.scm \ diff --git a/module/language/cps/dce.scm b/module/language/cps/dce.scm index 5463f5b1e..52bd70898 100644 --- a/module/language/cps/dce.scm +++ b/module/language/cps/dce.scm @@ -32,48 +32,12 @@ #:use-module (language cps) #:use-module (language cps effects-analysis) #:use-module (language cps renumber) - #:use-module (language cps types) + #:use-module (language cps type-checks) #:use-module (language cps utils) #:use-module (language cps intmap) #:use-module (language cps intset) #:export (eliminate-dead-code)) -(define (elide-type-checks conts kfun effects) - "Elide &type-check effects from EFFECTS for the function starting at -KFUN where we can prove that no assertion will be raised at run-time." - (let ((types (infer-types conts kfun))) - (define (visit-primcall effects fx label name args) - (if (primcall-types-check? types label name args) - (intmap-replace! effects label (logand fx (lognot &type-check))) - effects)) - (persistent-intmap - (intmap-fold (lambda (label types effects) - (let ((fx (intmap-ref effects label))) - (cond - ((causes-all-effects? fx) effects) - ((causes-effect? fx &type-check) - (match (intmap-ref conts label) - (($ $kargs _ _ exp) - (match exp - (($ $continue k src ($ $primcall name args)) - (visit-primcall effects fx label name args)) - (($ $continue k src - ($ $branch _ ($primcall name args))) - (visit-primcall effects fx label name args)) - (_ effects))) - (_ effects))) - (else effects)))) - types - effects)))) - -(define (compute-effects/elide-type-checks conts) - (intmap-fold (lambda (label cont effects) - (match cont - (($ $kfun) (elide-type-checks conts label effects)) - (_ effects))) - conts - (compute-effects conts))) - (define (fold-local-conts proc conts label seed) (match (intmap-ref conts label) (($ $kfun src meta self tail clause) diff --git a/module/language/cps/type-checks.scm b/module/language/cps/type-checks.scm new file mode 100644 index 000000000..864371d28 --- /dev/null +++ b/module/language/cps/type-checks.scm @@ -0,0 +1,72 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; This pass kills dead expressions: code that has no side effects, and +;;; whose value is unused. It does so by marking all live values, and +;;; then discarding other values as dead. This happens recursively +;;; through procedures, so it should be possible to elide dead +;;; procedures as well. +;;; +;;; Code: + +(define-module (language cps type-checks) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps effects-analysis) + #:use-module (language cps types) + #:use-module (language cps intmap) + #:export (elide-type-checks + compute-effects/elide-type-checks)) + +(define (elide-type-checks conts kfun effects) + "Elide &type-check effects from EFFECTS for the function starting at +KFUN where we can prove that no assertion will be raised at run-time." + (let ((types (infer-types conts kfun))) + (define (visit-primcall effects fx label name args) + (if (primcall-types-check? types label name args) + (intmap-replace! effects label (logand fx (lognot &type-check))) + effects)) + (persistent-intmap + (intmap-fold (lambda (label types effects) + (let ((fx (intmap-ref effects label))) + (cond + ((causes-all-effects? fx) effects) + ((causes-effect? fx &type-check) + (match (intmap-ref conts label) + (($ $kargs _ _ exp) + (match exp + (($ $continue k src ($ $primcall name args)) + (visit-primcall effects fx label name args)) + (($ $continue k src + ($ $branch _ ($primcall name args))) + (visit-primcall effects fx label name args)) + (_ effects))) + (_ effects))) + (else effects)))) + types + effects)))) + +(define (compute-effects/elide-type-checks conts) + (intmap-fold (lambda (label cont effects) + (match cont + (($ $kfun) (elide-type-checks conts label effects)) + (_ effects))) + conts + (compute-effects conts))) From bebc70c8b1f584c9f1e360ffc38094af4a4cee49 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jul 2015 11:40:00 +0200 Subject: [PATCH 035/865] Move solve-flow-equations to utils * module/language/cps/slot-allocation.scm (compute-lazy-vars): (compute-live-variables): Adapt to solve-flow-equations interface change. * module/language/cps/utils.scm (solve-flow-equations): Move here. Use an init value instead of an init map. --- module/language/cps/slot-allocation.scm | 60 +++---------------------- module/language/cps/utils.scm | 46 ++++++++++++++++++- 2 files changed, 51 insertions(+), 55 deletions(-) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 74e71c487..6039214c8 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -128,48 +128,6 @@ (define (lookup-nlocals k allocation) (intmap-ref (allocation-frame-sizes allocation) k)) -(define (intset-pop set) - (match (intset-next set) - (#f (values set #f)) - (i (values (intset-remove set i) i)))) - -(define (solve-flow-equations succs in out kill gen subtract add meet) - "Find a fixed point for flow equations for SUCCS, where IN and OUT are -the initial conditions as intmaps with one key for every node in SUCCS. -KILL and GEN are intmaps indicating the state that is killed or defined -at every node, and SUBTRACT, ADD, and MEET operates on that state." - (define (visit label in out) - (let* ((in-1 (intmap-ref in label)) - (kill-1 (intmap-ref kill label)) - (gen-1 (intmap-ref gen label)) - (out-1 (intmap-ref out label)) - (out-1* (add (subtract in-1 kill-1) gen-1))) - (if (eq? out-1 out-1*) - (values empty-intset in out) - (let ((out (intmap-replace! out label out-1*))) - (call-with-values - (lambda () - (intset-fold (lambda (succ in changed) - (let* ((in-1 (intmap-ref in succ)) - (in-1* (meet in-1 out-1*))) - (if (eq? in-1 in-1*) - (values in changed) - (values (intmap-replace! in succ in-1*) - (intset-add changed succ))))) - (intmap-ref succs label) in empty-intset)) - (lambda (in changed) - (values changed in out))))))) - - (let run ((worklist (intmap-keys succs)) (in in) (out out)) - (call-with-values (lambda () (intset-pop worklist)) - (lambda (worklist popped) - (if popped - (call-with-values (lambda () (visit popped in out)) - (lambda (changed in out) - (run (intset-union worklist changed) in out))) - (values (persistent-intmap in) - (persistent-intmap out))))))) - (define-syntax-rule (persistent-intmap2 exp) (call-with-values (lambda () exp) (lambda (a b) @@ -321,14 +279,11 @@ the definitions that are live before and after LABEL, as intsets." (old->new (compute-reverse-control-flow-order preds))) (call-with-values (lambda () - (let ((init (rename-keys - (intmap-map (lambda (k v) empty-intset) preds) - old->new))) - (solve-flow-equations (rename-graph preds old->new) - init init - (rename-keys defs old->new) - (rename-keys uses old->new) - intset-subtract intset-union intset-union))) + (solve-flow-equations (rename-graph preds old->new) + empty-intset + (rename-keys defs old->new) + (rename-keys uses old->new) + intset-subtract intset-union intset-union)) (lambda (in out) ;; As a reverse control-flow problem, the values flowing into a ;; node are actually the live values after the node executes. @@ -448,12 +403,9 @@ is an active call." (call-with-values (lambda () (let ((succs (rename-graph preds old->new)) - (in (rename-keys (intmap-map (lambda (k v) #f) preds) old->new)) - (out (rename-keys (intmap-map (lambda (k v) #f) preds) old->new)) - ;(out (rename-keys gens old->new)) (kills (rename-keys kills old->new)) (gens (rename-keys gens old->new))) - (solve-flow-equations succs in out kills gens subtract add meet))) + (solve-flow-equations succs #f kills gens subtract add meet))) (lambda (in out) ;; A variable is lazy if its uses reach its definition. (intmap-fold (lambda (label out lazy) diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm index fa4673c4e..9f95e0171 100644 --- a/module/language/cps/utils.scm +++ b/module/language/cps/utils.scm @@ -57,6 +57,7 @@ compute-sorted-strongly-connected-components compute-idoms compute-dom-edges + solve-flow-equations )) (define label-counter (make-parameter #f)) @@ -233,7 +234,7 @@ disjoint, an error will be signalled." (visit-cont k labels)) (_ labels))))))))))) -(define (compute-reachable-functions conts kfun) +(define* (compute-reachable-functions conts #:optional (kfun 0)) "Compute a mapping LABEL->LABEL..., where each key is a reachable $kfun and each associated value is the body of the function, as an intset." @@ -475,3 +476,46 @@ connected components in sorted order." (else (intmap-add! doms idom label snoc))))) idoms empty-intmap))) + +(define (intset-pop set) + (match (intset-next set) + (#f (values set #f)) + (i (values (intset-remove set i) i)))) + +(define (solve-flow-equations succs init kill gen subtract add meet) + "Find a fixed point for flow equations for SUCCS, where INIT is the +initial state at each node in SUCCS. KILL and GEN are intmaps +indicating the state that is killed or defined at every node, and +SUBTRACT, ADD, and MEET operates on that state." + (define (visit label in out) + (let* ((in-1 (intmap-ref in label)) + (kill-1 (intmap-ref kill label)) + (gen-1 (intmap-ref gen label)) + (out-1 (intmap-ref out label)) + (out-1* (add (subtract in-1 kill-1) gen-1))) + (if (eq? out-1 out-1*) + (values empty-intset in out) + (let ((out (intmap-replace! out label out-1*))) + (call-with-values + (lambda () + (intset-fold (lambda (succ in changed) + (let* ((in-1 (intmap-ref in succ)) + (in-1* (meet in-1 out-1*))) + (if (eq? in-1 in-1*) + (values in changed) + (values (intmap-replace! in succ in-1*) + (intset-add changed succ))))) + (intmap-ref succs label) in empty-intset)) + (lambda (in changed) + (values changed in out))))))) + + (let ((init (intmap-map (lambda (k v) init) succs))) + (let run ((worklist (intmap-keys succs)) (in init) (out init)) + (call-with-values (lambda () (intset-pop worklist)) + (lambda (worklist popped) + (if popped + (call-with-values (lambda () (visit popped in out)) + (lambda (changed in out) + (run (intset-union worklist changed) in out))) + (values (persistent-intmap in) + (persistent-intmap out)))))))) From ec9554d138a222d9ba59ecf7ee0b68d5c7ec1dfd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jul 2015 11:42:38 +0200 Subject: [PATCH 036/865] Loop-invariant code motion * module/language/cps/licm.scm: New pass. * module/language/cps/optimize.scm: Wire up new pass. * module/Makefile.am: Add new file. --- module/Makefile.am | 1 + module/language/cps/licm.scm | 308 +++++++++++++++++++++++++++++++ module/language/cps/optimize.scm | 2 + 3 files changed, 311 insertions(+) create mode 100644 module/language/cps/licm.scm diff --git a/module/Makefile.am b/module/Makefile.am index e4b088bef..67671daef 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -130,6 +130,7 @@ CPS_LANG_SOURCES = \ language/cps/dce.scm \ language/cps/effects-analysis.scm \ language/cps/elide-values.scm \ + language/cps/licm.scm \ language/cps/primitives.scm \ language/cps/prune-bailouts.scm \ language/cps/prune-top-level-scopes.scm \ diff --git a/module/language/cps/licm.scm b/module/language/cps/licm.scm new file mode 100644 index 000000000..3b343a66b --- /dev/null +++ b/module/language/cps/licm.scm @@ -0,0 +1,308 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Loop invariant code motion (LICM) hoists terms that don't affect a +;;; loop out of the loop, so that the loop goes faster. +;;; +;;; Code: + +(define-module (language cps licm) + #:use-module (ice-9 match) + #:use-module (srfi srfi-11) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:use-module (language cps effects-analysis) + #:use-module (language cps type-checks) + #:export (hoist-loop-invariant-code)) + +(define (find-exits scc succs) + (intset-fold (lambda (label exits) + (if (eq? empty-intset + (intset-subtract (intmap-ref succs label) scc)) + exits + (intset-add exits label))) + scc + empty-intset)) + +(define (find-entry scc preds) + (trivial-intset (find-exits scc preds))) + +(define (list->intset l) + (persistent-intset + (fold1 (lambda (i set) (intset-add! set i)) l empty-intset))) + +(define (loop-invariant? label exp loop-vars loop-effects always-reached?) + (let ((fx (intmap-ref loop-effects label))) + (and + (not (causes-effect? fx &allocation)) + (or always-reached? + (not (causes-effect? fx &type-check))) + (or (not (causes-effect? fx &write)) + (intmap-fold (lambda (label fx* invariant?) + (and invariant? + (not (effect-clobbers? fx fx*)))) + loop-effects #t)) + (or (not (causes-effect? fx &read)) + (intmap-fold (lambda (label fx* invariant?) + (and invariant? + (not (effect-clobbers? fx* fx)))) + loop-effects #t)) + (match exp + ((or ($ $const) ($ $prim) ($ $closure)) #t) + (($ $prompt) #f) ;; ? + (($ $branch) #f) + (($ $primcall 'values) #f) + (($ $primcall name args) + (and-map (lambda (arg) (not (intset-ref loop-vars arg))) + args)) + (($ $values args) + (and-map (lambda (arg) (not (intset-ref loop-vars arg))) + args)))))) + +(define (hoist-one cps label cont preds + loop-vars loop-effects pre-header-label always-reached?) + (define (filter-loop-vars names vars) + (match (vector names vars) + (#((name . names) (var . vars)) + (if (intset-ref loop-vars var) + (let-values (((names vars) (filter-loop-vars names vars))) + (values (cons name names) (cons var vars))) + (filter-loop-vars names vars))) + (_ (values '() '())))) + (define (adjoin-loop-vars loop-vars vars) + (fold1 (lambda (var loop-vars) (intset-add loop-vars var)) + vars loop-vars)) + (define (hoist-exp src exp def-names def-vars pre-header-label) + (let* ((hoisted-label pre-header-label) + (pre-header-label (fresh-label)) + (hoisted-cont + (rewrite-cont (intmap-ref cps hoisted-label) + (($ $kargs names vars) + ($kargs names vars + ($continue pre-header-label src ,exp))))) + (pre-header-cont + (rewrite-cont (intmap-ref cps hoisted-label) + (($ $kargs _ _ term) + ($kargs def-names def-vars ,term))))) + (values (intmap-add! (intmap-replace! cps hoisted-label hoisted-cont) + pre-header-label pre-header-cont) + pre-header-label))) + (define (hoist-call src exp req rest def-names def-vars pre-header-label) + (let* ((hoisted-label pre-header-label) + (receive-label (fresh-label)) + (pre-header-label (fresh-label)) + (hoisted-cont + (rewrite-cont (intmap-ref cps hoisted-label) + (($ $kargs names vars) + ($kargs names vars + ($continue receive-label src ,exp))))) + (receive-cont + (build-cont + ($kreceive req rest pre-header-label))) + (pre-header-cont + (rewrite-cont (intmap-ref cps hoisted-label) + (($ $kargs _ _ term) + ($kargs def-names def-vars ,term))))) + (values (intmap-add! + (intmap-add! (intmap-replace! cps hoisted-label hoisted-cont) + receive-label receive-cont) + pre-header-label pre-header-cont) + pre-header-label))) + (match cont + (($ $kargs names vars ($ $continue k src exp)) + ;; If k is a loop exit, it will be nullary. + (let-values (((names vars) (filter-loop-vars names vars))) + (match (intmap-ref cps k) + (($ $kargs def-names def-vars) + (cond + ((not (loop-invariant? label exp loop-vars loop-effects + always-reached?)) + (let* ((loop-vars (adjoin-loop-vars loop-vars def-vars)) + (loop-vars (match exp + (($ $prompt escape? tag handler) + (match (intmap-ref cps handler) + (($ $kreceive arity kargs) + (match (intmap-ref cps kargs) + (($ $kargs names vars) + (adjoin-loop-vars loop-vars vars)))))) + (_ loop-vars))) + (cont (build-cont + ($kargs names vars + ($continue k src ,exp)))) + (always-reached? + (and always-reached? + (match exp + (($ $branch) #f) + (_ (not (causes-effect? (intmap-ref loop-effects label) + &type-check))))))) + (values cps cont loop-vars loop-effects + pre-header-label always-reached?))) + ((trivial-intset (intmap-ref preds k)) + (let-values + (((cps pre-header-label) + (hoist-exp src exp def-names def-vars pre-header-label)) + ((cont) (build-cont + ($kargs names vars + ($continue k src ($values ())))))) + (values cps cont loop-vars (intmap-remove loop-effects label) + pre-header-label always-reached?))) + (else + (let*-values + (((def-names def-vars) + (match (intmap-ref cps k) + (($ $kargs names vars) (values names vars)))) + ((loop-vars) (adjoin-loop-vars loop-vars def-vars)) + ((fresh-vars) (map (lambda (_) (fresh-var)) def-vars)) + ((cps pre-header-label) + (hoist-exp src exp def-names fresh-vars pre-header-label)) + ((cont) (build-cont + ($kargs names vars + ($continue k src ($values fresh-vars)))))) + (values cps cont loop-vars (intmap-remove loop-effects label) + pre-header-label always-reached?))))) + (($ $kreceive ($ $arity req () rest) kargs) + (match (intmap-ref cps kargs) + (($ $kargs def-names def-vars) + (cond + ((not (loop-invariant? label exp loop-vars loop-effects + always-reached?)) + (let* ((loop-vars (adjoin-loop-vars loop-vars def-vars)) + (cont (build-cont + ($kargs names vars + ($continue k src ,exp))))) + (values cps cont loop-vars loop-effects pre-header-label #f))) + ((trivial-intset (intmap-ref preds k)) + (let ((loop-effects + (intmap-remove (intmap-remove loop-effects label) k))) + (let-values + (((cps pre-header-label) + (hoist-call src exp req rest def-names def-vars + pre-header-label)) + ((cont) (build-cont + ($kargs names vars + ($continue kargs src ($values ())))))) + (values cps cont loop-vars loop-effects + pre-header-label always-reached?)))) + (else + (let*-values + (((loop-vars) (adjoin-loop-vars loop-vars def-vars)) + ((fresh-vars) (map (lambda (_) (fresh-var)) def-vars)) + ((cps pre-header-label) + (hoist-call src exp req rest def-names fresh-vars + pre-header-label)) + ((cont) (build-cont + ($kargs names vars + ($continue kargs src + ($values fresh-vars)))))) + (values cps cont loop-vars loop-effects + pre-header-label always-reached?)))))))))) + (($ $kreceive ($ $arity req () rest) kargs) + (values cps cont loop-vars loop-effects pre-header-label + always-reached?)))) + +(define (hoist-in-loop cps entry body-labels succs preds effects) + (let* ((interior-succs (intmap-map (lambda (label succs) + (intset-intersect succs body-labels)) + succs)) + (sorted-labels (compute-reverse-post-order interior-succs entry)) + (header-label (fresh-label)) + (header-cont (intmap-ref cps entry)) + (loop-vars (match header-cont + (($ $kargs names vars) (list->intset vars)))) + (loop-effects (persistent-intmap + (intset-fold + (lambda (label loop-effects) + (let ((label* + (if (eqv? label entry) header-label label)) + (fx (intmap-ref effects label))) + (intmap-add! loop-effects label* fx))) + body-labels empty-intmap))) + (pre-header-label entry) + (pre-header-cont (match header-cont + (($ $kargs names vars term) + (let ((vars* (map (lambda (_) (fresh-var)) vars))) + (build-cont + ($kargs names vars* + ($continue header-label #f + ($values vars*)))))))) + (cps (intmap-add! cps header-label header-cont)) + (cps (intmap-replace! cps pre-header-label pre-header-cont)) + (to-visit (match sorted-labels + ((head . tail) + (unless (eqv? head entry) (error "what?")) + (cons header-label tail))))) + (define (rename-back-edges cont) + (define (rename label) (if (eqv? label entry) header-label label)) + (rewrite-cont cont + (($ $kargs names vars ($ $continue kf src ($ $branch kt exp))) + ($kargs names vars + ($continue (rename kf) src ($branch (rename kt) ,exp)))) + (($ $kargs names vars ($ $continue k src exp)) + ($kargs names vars + ($continue (rename k) src ,exp))) + (($ $kreceive ($ $arity req () rest) k) + ($kreceive req rest (rename k))))) + (let lp ((cps cps) (to-visit to-visit) + (loop-vars loop-vars) (loop-effects loop-effects) + (pre-header-label pre-header-label) (always-reached? #t)) + (match to-visit + (() cps) + ((label . to-visit) + (call-with-values + (lambda () + (hoist-one cps label (intmap-ref cps label) preds + loop-vars loop-effects + pre-header-label always-reached?)) + (lambda (cps cont + loop-vars loop-effects pre-header-label always-reached?) + (lp (intmap-replace! cps label (rename-back-edges cont)) to-visit + loop-vars loop-effects pre-header-label always-reached?)))))))) + +(define (hoist-in-function kfun body cps) + (let* ((succs (compute-successors cps kfun)) + (preds (invert-graph succs)) + (loops (intmap-fold + (lambda (id scc loops) + (cond + ((trivial-intset scc) loops) + ((find-entry scc preds) + => (lambda (entry) (intmap-add! loops entry scc))) + (else loops))) + (compute-strongly-connected-components succs kfun) + empty-intmap))) + (if (eq? empty-intset loops) + cps + (let ((effects (compute-effects/elide-type-checks + (intset-fold (lambda (label body-conts) + (intmap-add! body-conts label + (intmap-ref cps label))) + body empty-intmap)))) + (persistent-intmap + (intmap-fold (lambda (entry scc cps) + (hoist-in-loop cps entry scc succs preds effects)) + loops cps)))))) + +(define (hoist-loop-invariant-code cps) + (with-fresh-name-state cps + (intmap-fold hoist-in-function + (compute-reachable-functions cps) + cps))) diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm index 83a3f2dfe..c7545cc42 100644 --- a/module/language/cps/optimize.scm +++ b/module/language/cps/optimize.scm @@ -29,6 +29,7 @@ #:use-module (language cps cse) #:use-module (language cps dce) #:use-module (language cps elide-values) + #:use-module (language cps licm) #:use-module (language cps prune-top-level-scopes) #:use-module (language cps prune-bailouts) #:use-module (language cps self-references) @@ -95,6 +96,7 @@ (specialize-primcalls #:specialize-primcalls? #t) (elide-values #:elide-values? #t) (prune-bailouts #:prune-bailouts? #t) + (hoist-loop-invariant-code #:licm? #t) (eliminate-common-subexpressions #:cse? #t) (type-fold #:type-fold? #t) (resolve-self-references #:resolve-self-references? #t) From bcfa9fe70ec26424ee5c229fbc4bc748f95ce953 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jul 2015 12:21:00 +0200 Subject: [PATCH 037/865] Small expression-effects tweak * module/language/cps/effects-analysis.scm (expression-effects): Closures with zero free vars don't allocate. --- module/language/cps/effects-analysis.scm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 874eb7829..af1a5292e 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -438,6 +438,8 @@ is or might be a read or a write to the same location as A." (match exp ((or ($ $const) ($ $prim) ($ $values)) &no-effects) + (($ $closure _ 0) + &no-effects) ((or ($ $fun) ($ $rec) ($ $closure)) (&allocate &unknown-memory-kinds)) (($ $prompt) From bf6930b3f60a371039542570d6149ea04d3612ea Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jul 2015 15:55:46 +0200 Subject: [PATCH 038/865] Eliminate trampoline gotos when possible in compile-bytecode * module/language/cps/compile-bytecode.scm (compile-function): Eliminate trampoline jumps for conditional branches that don't shuffle. --- module/language/cps/compile-bytecode.scm | 124 +++++++++++++---------- 1 file changed, 71 insertions(+), 53 deletions(-) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 61f1e0781..a57074380 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -242,6 +242,18 @@ (($ $primcall 'unwind ()) (emit-unwind asm)))) + (define (forward-label label seen) + (if (memv label seen) + label + (match (intmap-ref cps label) + (($ $kargs _ _ ($ $continue k _ ($ $values))) + (match (lookup-parallel-moves label allocation) + (() (match (intmap-ref cps k) + (($ $ktail) label) + (_ (forward-label k (cons label seen))))) + (_ label))) + (cont label)))) + (define (compile-values label exp syms) (match exp (($ $values args) @@ -250,58 +262,62 @@ (lookup-parallel-moves label allocation))))) (define (compile-test label exp kt kf next-label) - (define (unary op sym) - (cond - ((eq? kt next-label) - (op asm (slot sym) #t kf)) - (else - (op asm (slot sym) #f kt) - (unless (eq? kf next-label) - (emit-br asm kf))))) - (define (binary op a b) - (cond - ((eq? kt next-label) - (op asm (slot a) (slot b) #t kf)) - (else - (op asm (slot a) (slot b) #f kt) - (unless (eq? kf next-label) - (emit-br asm kf))))) - (match exp - (($ $values (sym)) - (call-with-values (lambda () - (lookup-maybe-constant-value sym allocation)) - (lambda (has-const? val) - (if has-const? - (if val - (unless (eq? kt next-label) - (emit-br asm kt)) - (unless (eq? kf next-label) - (emit-br asm kf))) - (unary emit-br-if-true sym))))) - (($ $primcall 'null? (a)) (unary emit-br-if-null a)) - (($ $primcall 'nil? (a)) (unary emit-br-if-nil a)) - (($ $primcall 'pair? (a)) (unary emit-br-if-pair a)) - (($ $primcall 'struct? (a)) (unary emit-br-if-struct a)) - (($ $primcall 'char? (a)) (unary emit-br-if-char a)) - (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a)) - (($ $primcall 'variable? (a)) (unary emit-br-if-variable a)) - (($ $primcall 'vector? (a)) (unary emit-br-if-vector a)) - (($ $primcall 'string? (a)) (unary emit-br-if-string a)) - (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a)) - (($ $primcall 'bitvector? (a)) (unary emit-br-if-bitvector a)) - (($ $primcall 'keyword? (a)) (unary emit-br-if-keyword a)) - ;; Add more TC7 tests here. Keep in sync with - ;; *branching-primcall-arities* in (language cps primitives) and - ;; the set of macro-instructions in assembly.scm. - (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b)) - (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b)) - (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b)) - (($ $primcall '< (a b)) (binary emit-br-if-< a b)) - (($ $primcall '<= (a b)) (binary emit-br-if-<= a b)) - (($ $primcall '= (a b)) (binary emit-br-if-= a b)) - (($ $primcall '>= (a b)) (binary emit-br-if-<= b a)) - (($ $primcall '> (a b)) (binary emit-br-if-< b a)) - (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b)))) + (let* ((kt (forward-label kt '())) + (kf (forward-label kf '()))) + (define (prefer-true?) + (if (< (max kt kf) label) + ;; Two backwards branches. Prefer + ;; the nearest. + (> kt kf) + ;; Otherwise prefer a backwards + ;; branch or a near jump. + (< kt kf))) + (define (unary op sym) + (cond + ((eq? kt next-label) + (op asm (slot sym) #t kf)) + ((eq? kf next-label) + (op asm (slot sym) #f kt)) + (else + (let ((invert? (not (prefer-true?)))) + (op asm (slot sym) invert? (if invert? kf kt)) + (emit-br asm (if invert? kt kf)))))) + (define (binary op a b) + (cond + ((eq? kt next-label) + (op asm (slot a) (slot b) #t kf)) + ((eq? kf next-label) + (op asm (slot a) (slot b) #f kt)) + (else + (let ((invert? (not (prefer-true?)))) + (op asm (slot a) (slot b) invert? (if invert? kf kt)) + (emit-br asm (if invert? kt kf)))))) + (match exp + (($ $values (sym)) (unary emit-br-if-true sym)) + (($ $primcall 'null? (a)) (unary emit-br-if-null a)) + (($ $primcall 'nil? (a)) (unary emit-br-if-nil a)) + (($ $primcall 'pair? (a)) (unary emit-br-if-pair a)) + (($ $primcall 'struct? (a)) (unary emit-br-if-struct a)) + (($ $primcall 'char? (a)) (unary emit-br-if-char a)) + (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a)) + (($ $primcall 'variable? (a)) (unary emit-br-if-variable a)) + (($ $primcall 'vector? (a)) (unary emit-br-if-vector a)) + (($ $primcall 'string? (a)) (unary emit-br-if-string a)) + (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a)) + (($ $primcall 'bitvector? (a)) (unary emit-br-if-bitvector a)) + (($ $primcall 'keyword? (a)) (unary emit-br-if-keyword a)) + ;; Add more TC7 tests here. Keep in sync with + ;; *branching-primcall-arities* in (language cps primitives) and + ;; the set of macro-instructions in assembly.scm. + (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b)) + (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b)) + (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b)) + (($ $primcall '< (a b)) (binary emit-br-if-< a b)) + (($ $primcall '<= (a b)) (binary emit-br-if-<= a b)) + (($ $primcall '= (a b)) (binary emit-br-if-= a b)) + (($ $primcall '>= (a b)) (binary emit-br-if-<= b a)) + (($ $primcall '> (a b)) (binary emit-br-if-< b a)) + (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b))))) (define (compile-trunc label k exp nreq rest-var) (define (do-call proc args emit-call) @@ -346,7 +362,9 @@ (define (compile-expression label k exp) (let* ((fallthrough? (= k (1+ label)))) (define (maybe-emit-jump) - (unless fallthrough? + (unless (or fallthrough? + (= (forward-label k '()) + (forward-label (1+ label) '()))) (emit-br asm k))) (match (intmap-ref cps k) (($ $ktail) From ee85e2969f623278e095c5facda4430b664a04aa Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jul 2015 16:50:19 +0200 Subject: [PATCH 039/865] Rotate comparisons down to loop back-edges * module/language/cps/rotate-loops.scm: New pass. * module/Makefile.am: * module/language/cps/optimize.scm: Wire up the new pass. --- module/Makefile.am | 1 + module/language/cps/optimize.scm | 2 + module/language/cps/rotate-loops.scm | 217 +++++++++++++++++++++++++++ 3 files changed, 220 insertions(+) create mode 100644 module/language/cps/rotate-loops.scm diff --git a/module/Makefile.am b/module/Makefile.am index 67671daef..a946da36d 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -136,6 +136,7 @@ CPS_LANG_SOURCES = \ language/cps/prune-top-level-scopes.scm \ language/cps/reify-primitives.scm \ language/cps/renumber.scm \ + language/cps/rotate-loops.scm \ language/cps/optimize.scm \ language/cps/simplify.scm \ language/cps/self-references.scm \ diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm index c7545cc42..7721d6385 100644 --- a/module/language/cps/optimize.scm +++ b/module/language/cps/optimize.scm @@ -32,6 +32,7 @@ #:use-module (language cps licm) #:use-module (language cps prune-top-level-scopes) #:use-module (language cps prune-bailouts) + #:use-module (language cps rotate-loops) #:use-module (language cps self-references) #:use-module (language cps simplify) #:use-module (language cps specialize-primcalls) @@ -105,4 +106,5 @@ (define-optimizer optimize-first-order-cps (eliminate-dead-code #:eliminate-dead-code? #t) + (rotate-loops #:rotate-loops? #t) (simplify #:simplify? #t)) diff --git a/module/language/cps/rotate-loops.scm b/module/language/cps/rotate-loops.scm new file mode 100644 index 000000000..19ecf444c --- /dev/null +++ b/module/language/cps/rotate-loops.scm @@ -0,0 +1,217 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Rotate loops so that they end with conditional jumps, if possible. +;;; The result goes from: +;;; +;;; loop: +;;; if x < 5 goto done; +;;; x = x + 1; +;;; goto loop; +;;; done: +;;; +;;; if x < 5 goto done; +;;; loop: +;;; x = x + 1; +;;; if x < 5 goto done; +;;; done: +;;; +;;; It's more code but there are fewer instructions in the body. Note +;;; that this transformation isn't guaranteed to produce a loop that +;;; ends in a conditional jump, because usually your loop has some state +;;; that it's shuffling around and for now that shuffle is reified with +;;; the test, not the loop header. Alack. +;;; +;;; Implementation-wise, things are complicated by values flowing out of +;;; the loop. We actually perform this transformation only on loops +;;; that have a single exit continuation, so that we define values +;;; flowing out in one place. We rename the loop variables in two +;;; places internally: one for the peeled comparison, and another for +;;; the body. The loop variables' original names are then bound in a +;;; join continuation for use by successor code. +;;; +;;; Code: + +(define-module (language cps rotate-loops) + #:use-module (ice-9 match) + #:use-module ((srfi srfi-1) #:select (filter-map)) + #:use-module (srfi srfi-9) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (rotate-loops)) + +(define-record-type $loop + (make-loop entry exits body) + loop? + (entry loop-entry) + (exits loop-exits) + (body loop-body)) + +(define (find-exits scc succs) + (intset-fold (lambda (label exits) + (if (eq? empty-intset + (intset-subtract (intmap-ref succs label) scc)) + exits + (intset-add exits label))) + scc + empty-intset)) + +(define (find-entry scc preds) + (trivial-intset (find-exits scc preds))) + +(define (rotate-loop cps entry-label body-labels succs preds back-edges) + (match (intmap-ref cps entry-label) + ((and entry-cont + ($ $kargs entry-names entry-vars + ($ $continue entry-kf entry-src ($ $branch entry-kt entry-exp)))) + (let* ((exit-if-true? (intset-ref body-labels entry-kf)) + (exit (if exit-if-true? entry-kt entry-kf)) + (new-entry-label (if exit-if-true? entry-kf entry-kt)) + (join-label (fresh-label)) + (join-cont (build-cont + ($kargs entry-names entry-vars + ($continue exit entry-src ($values ()))))) + (cps (intmap-add! cps join-label join-cont))) + (define (make-fresh-vars) + (map (lambda (_) (fresh-var)) entry-vars)) + (define (make-trampoline k src values) + (build-cont ($kargs () () ($continue k src ($values values))))) + (define (replace-exit k trampoline) + (if (eqv? k exit) trampoline k)) + (define (rename-exp exp vars) + (define (rename-var var) + (match (list-index entry-vars var) + (#f var) + (idx (list-ref vars idx)))) + (rewrite-exp exp + ((or ($ $const) ($ $prim) ($ $closure)) ,exp) + (($ $values args) + ($values ,(map rename-var args))) + (($ $call proc args) + ($call (rename-var proc) ,(map rename-var args))) + (($ $callk k proc args) + ($callk k (rename-var proc) ,(map rename-var args))) + (($ $branch kt ($ $values (arg))) + ($branch kt ($values ((rename-var arg))))) + (($ $branch kt ($ $primcall name args)) + ($branch kt ($primcall name ,(map rename-var args)))) + (($ $primcall name args) + ($primcall name ,(map rename-var args))) + (($ $prompt escape? tag handler) + ($prompt escape? (rename-var tag) handler)))) + (define (attach-trampoline label src names vars args) + (let* ((trampoline-out-label (fresh-label)) + (trampoline-out-cont + (make-trampoline join-label src args)) + (trampoline-in-label (fresh-label)) + (trampoline-in-cont + (make-trampoline new-entry-label src args)) + (kf (if exit-if-true? trampoline-in-label trampoline-out-label)) + (kt (if exit-if-true? trampoline-out-label trampoline-in-label)) + (cont (build-cont + ($kargs names vars + ($continue kf entry-src + ($branch kt ,(rename-exp entry-exp args)))))) + (cps (intmap-replace! cps label cont)) + (cps (intmap-add! cps trampoline-in-label trampoline-in-cont))) + (intmap-add! cps trampoline-out-label trampoline-out-cont))) + ;; Rewrite the targets of the entry branch to go to + ;; trampolines. One will pass values out of the loop, and + ;; one will pass values into the loop. + (let* ((pre-header-vars (make-fresh-vars)) + (body-vars (make-fresh-vars)) + (cps (attach-trampoline entry-label entry-src + entry-names pre-header-vars + pre-header-vars)) + (new-entry-cont (build-cont + ($kargs entry-names body-vars + ,(match (intmap-ref cps new-entry-label) + (($ $kargs () () term) term))))) + (cps (intmap-replace! cps new-entry-label new-entry-cont))) + (intset-fold + (lambda (label cps) + (if (intset-ref back-edges label) + (match (intmap-ref cps label) + (($ $kargs names vars ($ $continue _ src exp)) + (match (rename-exp exp body-vars) + (($ $values args) + (attach-trampoline label src names vars args)) + (exp + (let* ((args (make-fresh-vars)) + (bind-label (fresh-label)) + (edge* (build-cont + ($kargs names vars + ($continue bind-label src ,exp)))) + (cps (intmap-replace! cps label edge*)) + ;; attach-trampoline uses intmap-replace!. + (cps (intmap-add! cps bind-label #f))) + (attach-trampoline bind-label src + entry-names args args)))))) + (match (intmap-ref cps label) + (($ $kargs names vars ($ $continue k src exp)) + (let ((cont (build-cont + ($kargs names vars + ($continue k src + ,(rename-exp exp body-vars)))))) + (intmap-replace! cps label cont))) + (($ $kreceive) cps)))) + (intset-remove body-labels entry-label) + cps)))))) + +(define (rotate-loops-in-function kfun body cps) + (define (can-rotate? edges) + (intset-fold (lambda (label rotate?) + (match (intmap-ref cps label) + (($ $kreceive) #f) + (($ $kargs _ _ ($ $continue _ _ exp)) + (match exp + (($ $branch) #f) + (_ rotate?))))) + edges #t)) + (let* ((succs (compute-successors cps kfun)) + (preds (invert-graph succs))) + (intmap-fold + (lambda (id scc cps) + (cond + ((trivial-intset scc) cps) + ((find-entry scc preds) + => (lambda (entry) + (let ((back-edges (intset-intersect scc + (intmap-ref preds entry)))) + (if (and (can-rotate? back-edges) + (eqv? (trivial-intset (find-exits scc succs)) entry)) + ;; Loop header is the only exit. It must be a + ;; conditional branch and only one successor is an + ;; exit. The values flowing out of the loop are the + ;; loop variables. + (rotate-loop cps entry scc succs preds back-edges) + cps)))) + (else cps))) + (compute-strongly-connected-components succs kfun) + cps))) + +(define (rotate-loops cps) + (persistent-intmap + (with-fresh-name-state cps + (intmap-fold rotate-loops-in-function + (compute-reachable-functions cps) + cps)))) From e54fbff185786886b56f0438040c2a1d54363c6a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 25 Jul 2015 11:03:59 +0200 Subject: [PATCH 040/865] Loop inversion with multiple exits * module/language/cps/rotate-loops.scm (rotate-loop): Instead of restricting rotation to loops with just one exit node, restrict to loops with just one exit successor. --- module/language/cps/rotate-loops.scm | 81 ++++++++++++++++++---------- 1 file changed, 54 insertions(+), 27 deletions(-) diff --git a/module/language/cps/rotate-loops.scm b/module/language/cps/rotate-loops.scm index 19ecf444c..c6b68bb32 100644 --- a/module/language/cps/rotate-loops.scm +++ b/module/language/cps/rotate-loops.scm @@ -66,6 +66,12 @@ (exits loop-exits) (body loop-body)) +(define (loop-successors scc succs) + (intset-subtract (intset-fold (lambda (label exits) + (intset-union exits (intmap-ref succs label))) + scc empty-intset) + scc)) + (define (find-exits scc succs) (intset-fold (lambda (label exits) (if (eq? empty-intset @@ -84,6 +90,7 @@ ($ $kargs entry-names entry-vars ($ $continue entry-kf entry-src ($ $branch entry-kt entry-exp)))) (let* ((exit-if-true? (intset-ref body-labels entry-kf)) + (loop-exits (find-exits body-labels succs)) (exit (if exit-if-true? entry-kt entry-kf)) (new-entry-label (if exit-if-true? entry-kf entry-kt)) (join-label (fresh-label)) @@ -149,31 +156,48 @@ (cps (intmap-replace! cps new-entry-label new-entry-cont))) (intset-fold (lambda (label cps) - (if (intset-ref back-edges label) - (match (intmap-ref cps label) - (($ $kargs names vars ($ $continue _ src exp)) - (match (rename-exp exp body-vars) - (($ $values args) - (attach-trampoline label src names vars args)) - (exp - (let* ((args (make-fresh-vars)) - (bind-label (fresh-label)) - (edge* (build-cont - ($kargs names vars - ($continue bind-label src ,exp)))) - (cps (intmap-replace! cps label edge*)) - ;; attach-trampoline uses intmap-replace!. - (cps (intmap-add! cps bind-label #f))) - (attach-trampoline bind-label src - entry-names args args)))))) - (match (intmap-ref cps label) - (($ $kargs names vars ($ $continue k src exp)) - (let ((cont (build-cont - ($kargs names vars - ($continue k src - ,(rename-exp exp body-vars)))))) - (intmap-replace! cps label cont))) - (($ $kreceive) cps)))) + (cond + ((intset-ref back-edges label) + (match (intmap-ref cps label) + (($ $kargs names vars ($ $continue _ src exp)) + (match (rename-exp exp body-vars) + (($ $values args) + (attach-trampoline label src names vars args)) + (exp + (let* ((args (make-fresh-vars)) + (bind-label (fresh-label)) + (edge* (build-cont + ($kargs names vars + ($continue bind-label src ,exp)))) + (cps (intmap-replace! cps label edge*)) + ;; attach-trampoline uses intmap-replace!. + (cps (intmap-add! cps bind-label #f))) + (attach-trampoline bind-label src + entry-names args args))))))) + ((intset-ref loop-exits label) + (match (intmap-ref cps label) + (($ $kargs names vars + ($ $continue kf src ($ $branch kt exp))) + (let* ((trampoline-out-label (fresh-label)) + (trampoline-out-cont + (make-trampoline join-label src body-vars)) + (kf (if (eqv? kf exit) trampoline-out-label kf)) + (kt (if (eqv? kt exit) trampoline-out-label kt)) + (cont (build-cont + ($kargs names vars + ($continue kf src + ($branch kt ,(rename-exp exp body-vars)))))) + (cps (intmap-replace! cps label cont))) + (intmap-add! cps trampoline-out-label trampoline-out-cont))))) + (else + (match (intmap-ref cps label) + (($ $kargs names vars ($ $continue k src exp)) + (let ((cont (build-cont + ($kargs names vars + ($continue k src + ,(rename-exp exp body-vars)))))) + (intmap-replace! cps label cont))) + (($ $kreceive) cps))))) (intset-remove body-labels entry-label) cps)))))) @@ -198,8 +222,11 @@ (let ((back-edges (intset-intersect scc (intmap-ref preds entry)))) (if (and (can-rotate? back-edges) - (eqv? (trivial-intset (find-exits scc succs)) entry)) - ;; Loop header is the only exit. It must be a + (trivial-intset + (intset-subtract (intmap-ref succs entry) scc)) + (trivial-intset (loop-successors scc succs))) + ;; Loop header is an exit, and there is only one + ;; exit continuation. Loop header must then be a ;; conditional branch and only one successor is an ;; exit. The values flowing out of the loop are the ;; loop variables. From ce2888701c02870aeaeba53675e2cc132c9d10dc Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 27 Jul 2015 12:59:09 +0200 Subject: [PATCH 041/865] Simplify rotate-loops.scm * module/language/cps/rotate-loops.scm: Clean up unused code. --- module/language/cps/rotate-loops.scm | 9 --------- 1 file changed, 9 deletions(-) diff --git a/module/language/cps/rotate-loops.scm b/module/language/cps/rotate-loops.scm index c6b68bb32..0fab94f1d 100644 --- a/module/language/cps/rotate-loops.scm +++ b/module/language/cps/rotate-loops.scm @@ -51,21 +51,12 @@ (define-module (language cps rotate-loops) #:use-module (ice-9 match) - #:use-module ((srfi srfi-1) #:select (filter-map)) - #:use-module (srfi srfi-9) #:use-module (language cps) #:use-module (language cps utils) #:use-module (language cps intmap) #:use-module (language cps intset) #:export (rotate-loops)) -(define-record-type $loop - (make-loop entry exits body) - loop? - (entry loop-entry) - (exits loop-exits) - (body loop-body)) - (define (loop-successors scc succs) (intset-subtract (intset-fold (lambda (label exits) (intset-union exits (intmap-ref succs label))) From 4792577ab8c5c6264a48cc8d6592ca7c1103c2c7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 27 Jul 2015 13:25:38 +0200 Subject: [PATCH 042/865] solve-flow-equations tweak * module/language/cps/utils.scm (solve-flow-equations): Revert to take separate in and out maps. Take an optional initial worklist. * module/language/cps/slot-allocation.scm: Adapt to solve-flow-equations change. --- module/language/cps/slot-allocation.scm | 16 +++++++++++++--- module/language/cps/utils.scm | 22 +++++++++++----------- 2 files changed, 24 insertions(+), 14 deletions(-) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 6039214c8..8be36e716 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -276,11 +276,15 @@ body continuation in the prompt." the definitions that are live before and after LABEL, as intsets." (let* ((succs (add-prompt-control-flow-edges cps (compute-successors cps))) (preds (invert-graph succs)) - (old->new (compute-reverse-control-flow-order preds))) + (old->new (compute-reverse-control-flow-order preds)) + (init (persistent-intmap (intmap-fold + (lambda (old new init) + (intmap-add! init new empty-intset)) + old->new empty-intmap)))) (call-with-values (lambda () (solve-flow-equations (rename-graph preds old->new) - empty-intset + init init (rename-keys defs old->new) (rename-keys uses old->new) intset-subtract intset-union intset-union)) @@ -403,9 +407,15 @@ is an active call." (call-with-values (lambda () (let ((succs (rename-graph preds old->new)) + (init (persistent-intmap + (intmap-fold + (lambda (old new in) + (intmap-add! in new #f)) + old->new empty-intmap))) (kills (rename-keys kills old->new)) (gens (rename-keys gens old->new))) - (solve-flow-equations succs #f kills gens subtract add meet))) + (solve-flow-equations succs init init kills gens + subtract add meet))) (lambda (in out) ;; A variable is lazy if its uses reach its definition. (intmap-fold (lambda (label out lazy) diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm index 9f95e0171..fcbda9e76 100644 --- a/module/language/cps/utils.scm +++ b/module/language/cps/utils.scm @@ -482,7 +482,8 @@ connected components in sorted order." (#f (values set #f)) (i (values (intset-remove set i) i)))) -(define (solve-flow-equations succs init kill gen subtract add meet) +(define* (solve-flow-equations succs in out kill gen subtract add meet + #:optional (worklist (intmap-keys succs))) "Find a fixed point for flow equations for SUCCS, where INIT is the initial state at each node in SUCCS. KILL and GEN are intmaps indicating the state that is killed or defined at every node, and @@ -509,13 +510,12 @@ SUBTRACT, ADD, and MEET operates on that state." (lambda (in changed) (values changed in out))))))) - (let ((init (intmap-map (lambda (k v) init) succs))) - (let run ((worklist (intmap-keys succs)) (in init) (out init)) - (call-with-values (lambda () (intset-pop worklist)) - (lambda (worklist popped) - (if popped - (call-with-values (lambda () (visit popped in out)) - (lambda (changed in out) - (run (intset-union worklist changed) in out))) - (values (persistent-intmap in) - (persistent-intmap out)))))))) + (let run ((worklist worklist) (in in) (out out)) + (call-with-values (lambda () (intset-pop worklist)) + (lambda (worklist popped) + (if popped + (call-with-values (lambda () (visit popped in out)) + (lambda (changed in out) + (run (intset-union worklist changed) in out))) + (values (persistent-intmap in) + (persistent-intmap out))))))) From 3b60e79879c91bc5083f7a38db5a38ce4bfb4da8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 27 Jul 2015 13:45:23 +0200 Subject: [PATCH 043/865] Loop peeling * module/language/cps/peel-loops.scm: New pass. Only enabled if the loop has one successor. * module/language/cps/optimize.scm: Peel instead of doing LICM on higher-order CPS, then LICM on first-order CPS. * module/Makefile.am: Wire up new pass. --- module/Makefile.am | 1 + module/language/cps/optimize.scm | 10 +- module/language/cps/peel-loops.scm | 287 +++++++++++++++++++++++++++++ 3 files changed, 292 insertions(+), 6 deletions(-) create mode 100644 module/language/cps/peel-loops.scm diff --git a/module/Makefile.am b/module/Makefile.am index a946da36d..3dc6117d3 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -131,6 +131,7 @@ CPS_LANG_SOURCES = \ language/cps/effects-analysis.scm \ language/cps/elide-values.scm \ language/cps/licm.scm \ + language/cps/peel-loops.scm \ language/cps/primitives.scm \ language/cps/prune-bailouts.scm \ language/cps/prune-top-level-scopes.scm \ diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm index 7721d6385..c6576fc4a 100644 --- a/module/language/cps/optimize.scm +++ b/module/language/cps/optimize.scm @@ -30,6 +30,7 @@ #:use-module (language cps dce) #:use-module (language cps elide-values) #:use-module (language cps licm) + #:use-module (language cps peel-loops) #:use-module (language cps prune-top-level-scopes) #:use-module (language cps prune-bailouts) #:use-module (language cps rotate-loops) @@ -82,11 +83,6 @@ ;; * Abort contification: turning abort primcalls into continuation ;; calls, and eliding prompts if possible. ;; -;; * Loop peeling. Unrolls the first round through a loop if the -;; loop has effects that CSE can work on. Requires effects -;; analysis. When run before CSE, loop peeling is the equivalent -;; of loop-invariant code motion (LICM). -;; (define-optimizer optimize-higher-order-cps (split-rec #:split-rec? #t) (eliminate-dead-code #:eliminate-dead-code? #t) @@ -97,7 +93,7 @@ (specialize-primcalls #:specialize-primcalls? #t) (elide-values #:elide-values? #t) (prune-bailouts #:prune-bailouts? #t) - (hoist-loop-invariant-code #:licm? #t) + (peel-loops #:peel-loops? #t) (eliminate-common-subexpressions #:cse? #t) (type-fold #:type-fold? #t) (resolve-self-references #:resolve-self-references? #t) @@ -105,6 +101,8 @@ (simplify #:simplify? #t)) (define-optimizer optimize-first-order-cps + (hoist-loop-invariant-code #:licm? #t) + ;; FIXME: CSE here to eliminate duplicate free-ref terms. (eliminate-dead-code #:eliminate-dead-code? #t) (rotate-loops #:rotate-loops? #t) (simplify #:simplify? #t)) diff --git a/module/language/cps/peel-loops.scm b/module/language/cps/peel-loops.scm new file mode 100644 index 000000000..a1b04a45b --- /dev/null +++ b/module/language/cps/peel-loops.scm @@ -0,0 +1,287 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2013, 2014, 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Loop peeling "peels off" one iteration of a loop. When followed by +;;; common subexpression elimination, it has the effect of moving terms +;;; to the first peeled iteration, leaving the loop body with fewer +;;; terms. +;;; +;;; Loop peeling is complementary to loop-invariant code motion (LICM). +;;; LICM will hoist invariant terms that have no side effects, like +;;; $const, even if they are in branches that are not always taken. +;;; However LICM won't hoist expressions that might have side effects if +;;; it can't prove that they are reachable on every iteration. Peeling +;;; on the other hand arranges for the body to be dominated by one loop +;;; iteration, so any effect that is reachable on one full iteration can +;;; be hoisted and eliminated, which is a big boon when we consider +;;; &type-check effects. For example: +;;; +;;; x = cached-toplevel-box map +;;; y = box-ref x +;;; z = cached-toplevel-box foo +;;; w = box-ref z +;;; ... +;;; +;;; In this example, LICM could hoist X, possibly Y as well if it can +;;; prove that the body doesn't write to variables, but it won't hoist +;;; Z. In contrast, peeling + CSE will allow Z to be hoisted. +;;; +;;; Peeling does cause code growth. If this becomes a problem we will +;;; need to apply heuristics to limit its applicability. +;;; +;;; Implementation-wise, things are complicated by values flowing out of +;;; the loop. We actually perform this transformation only on loops +;;; that have a single exit continuation, so that we define values +;;; flowing out in one place. We rename the loop variables in two +;;; places internally: one for the peeled iteration, and another for +;;; the body. The loop variables' original names are then bound in a +;;; join continuation for use by successor code. +;;; +;;; Code: + +(define-module (language cps peel-loops) + #:use-module (ice-9 match) + #:use-module ((srfi srfi-1) #:select (fold)) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps intmap) + #:use-module (language cps intset) + #:export (peel-loops)) + +(define (intset-map f set) + (persistent-intmap + (intset-fold (lambda (i out) (intmap-add! out i (f i))) set empty-intmap))) + +(define (loop-successors scc succs) + (intset-subtract (intset-fold (lambda (label exits) + (intset-union exits (intmap-ref succs label))) + scc empty-intset) + scc)) + +(define (find-exits scc succs) + (intset-fold (lambda (label exits) + (if (eq? empty-intset + (intset-subtract (intmap-ref succs label) scc)) + exits + (intset-add exits label))) + scc + empty-intset)) + +(define (find-entry scc preds) + (trivial-intset (find-exits scc preds))) + +(define (list->intset vars) + (persistent-intset + (fold1 (lambda (var set) (intset-add! set var)) vars empty-intset))) + +(define (compute-live-variables cps entry body succs) + (let* ((succs (intset-map (lambda (label) + (intset-intersect (intmap-ref succs label) body)) + body)) + (init (intset-map (lambda (label) #f) body)) + (kill (intset-map (lambda (label) #f) body)) + (gen (intset-map (lambda (label) + (match (intmap-ref cps label) + (($ $kargs names vars) (list->intset vars)) + (_ empty-intset))) + body)) + (in (intmap-replace init entry (intmap-ref gen entry))) + (out init)) + (define (subtract in kill) (or in empty-intset)) + (define (add in gen) (if in (intset-union in gen) gen)) + (define (meet in out) (if in (intset-intersect in out) out)) + (call-with-values (lambda () + (solve-flow-equations succs in out kill gen + subtract add meet + (intset entry))) + (lambda (in out) + out)))) + +(define (compute-out-vars cps entry body succs exit) + (let ((live (compute-live-variables cps entry body succs))) + (intset-fold-right + cons + (intmap-fold (lambda (label succs live-out) + (if (intset-ref succs exit) + (if live-out + (intset-intersect live-out (intmap-ref live label)) + (intmap-ref live label)) + live-out)) + succs #f) + '()))) + +(define (rename-cont cont fresh-labels fresh-vars) + (define (rename-label label) + (intmap-ref fresh-labels label (lambda (label) label))) + (define (rename-var var) + (intmap-ref fresh-vars var (lambda (var) var))) + (define (rename-exp exp) + (rewrite-exp exp + ((or ($ $const) ($ $prim) ($ $closure) ($ $rec ())) ,exp) + (($ $values args) + ($values ,(map rename-var args))) + (($ $call proc args) + ($call (rename-var proc) ,(map rename-var args))) + (($ $callk k proc args) + ($callk k (rename-var proc) ,(map rename-var args))) + (($ $branch kt ($ $values (arg))) + ($branch (rename-label kt) ($values ((rename-var arg))))) + (($ $branch kt ($ $primcall name args)) + ($branch (rename-label kt) ($primcall name ,(map rename-var args)))) + (($ $primcall name args) + ($primcall name ,(map rename-var args))) + (($ $prompt escape? tag handler) + ($prompt escape? (rename-var tag) (rename-label handler))))) + (rewrite-cont cont + (($ $kargs names vars ($ $continue k src exp)) + ($kargs names (map rename-var vars) + ($continue (rename-label k) src ,(rename-exp exp)))) + (($ $kreceive ($ $arity req () rest) kargs) + ($kreceive req rest (rename-label kargs))))) + +(define (compute-var-names conts) + (persistent-intmap + (intmap-fold (lambda (label cont out) + (match cont + (($ $kargs names vars) + (fold (lambda (name var out) + (intmap-add! out var name)) + out names vars)) + (_ out))) + conts empty-intmap))) + +(define (peel-loop cps entry body-labels succs preds) + (let* ((body-conts (intset-map (lambda (label) (intmap-ref cps label)) + body-labels)) + (var-names (compute-var-names body-conts)) + ;; All loop exits branch to this label. + (exit (trivial-intset (loop-successors body-labels succs))) + ;; The variables that flow out of the loop, as a list. + (out-vars (compute-out-vars cps entry body-labels succs exit)) + (out-names (map (lambda (var) (intmap-ref var-names var)) out-vars)) + (join-label (fresh-label)) + (join-cont (build-cont + ($kargs out-names out-vars + ($continue exit #f ($values ()))))) + (trampoline-cont + ;; A $values predecessor for the join, passing the out-vars + ;; using their original names. These will get renamed in + ;; both the peeled iteration and the body. + (build-cont + ($kargs () () + ($continue join-label #f ($values out-vars))))) + (fresh-body-labels + ;; Fresh labels for the body. + (intset-map (lambda (old) (fresh-label)) body-labels)) + (fresh-body-vars + ;; Fresh vars for the body. + (intmap-map (lambda (var name) (fresh-var)) var-names)) + (fresh-body-entry + ;; The name of the entry, but in the body. + (intmap-ref fresh-body-labels entry)) + (fresh-peeled-vars + ;; Fresh names for variables that flow out of the peeled iteration. + (fold1 (lambda (var out) (intmap-add out var (fresh-var))) + out-vars empty-intmap)) + (peeled-trampoline-label + ;; Label for trampoline to pass values out of the peeled + ;; iteration. + (fresh-label)) + (peeled-trampoline-cont + ;; Trampoline for the peeled iteration, ready to adjoin to + ;; CPS. + (rename-cont trampoline-cont empty-intmap fresh-peeled-vars)) + (peeled-labels + ;; Exit goes to trampoline, back edges to body. + (intmap-add (intmap-add empty-intmap exit peeled-trampoline-label) + entry fresh-body-entry)) + (peeled-iteration + ;; The peeled iteration. + (intmap-map (lambda (label cont) + (rename-cont cont peeled-labels fresh-peeled-vars)) + body-conts)) + (body-trampoline-label + ;; Label for trampoline to pass values out of the body. + (fresh-label)) + (body-trampoline-cont + ;; Trampoline for the body, ready to adjoin to CPS. + (rename-cont trampoline-cont empty-intmap fresh-body-vars)) + (fresh-body + ;; The body, renamed. + (let ((label-map (intmap-add fresh-body-labels + exit body-trampoline-label))) + (persistent-intmap + (intmap-fold + (lambda (label new-label out) + (intmap-add! out new-label + (rename-cont (intmap-ref body-conts label) + label-map fresh-body-vars))) + fresh-body-labels empty-intmap))))) + + (let* ((cps (intmap-add! cps join-label join-cont)) + (cps (intmap-add! cps peeled-trampoline-label + peeled-trampoline-cont)) + (cps (intmap-add! cps body-trampoline-label + body-trampoline-cont)) + (cps (intmap-fold (lambda (label cont cps) + (intmap-replace! cps label cont)) + peeled-iteration cps)) + (cps (intmap-fold (lambda (label cont cps) + (intmap-add! cps label cont)) + fresh-body cps))) + cps))) + +(define (peel-loops-in-function kfun body cps) + (let* ((succs (compute-successors cps kfun)) + (preds (invert-graph succs))) + ;; We can peel if there is one successor to the loop, and if the + ;; loop has no nested functions. (Peeling a nested function would + ;; cause exponential code growth.) + (define (can-peel? body) + (and (trivial-intset (loop-successors body succs)) + (intset-fold (lambda (label peel?) + (match (intmap-ref cps label) + (($ $kargs _ _ ($ $continue _ _ exp)) + (match exp + (($ $fun) #f) + (($ $rec (_ . _)) #f) + (_ peel?))) + (_ peel?))) + body #t))) + + (intmap-fold + (lambda (id scc cps) + (cond + ((trivial-intset scc) cps) + ((find-entry scc preds) + => (lambda (entry) + (if (can-peel? scc) + (peel-loop cps entry scc succs preds) + cps))) + (else cps))) + (compute-strongly-connected-components succs kfun) + cps))) + +(define (peel-loops cps) + (persistent-intmap + (with-fresh-name-state cps + (intmap-fold peel-loops-in-function + (compute-reachable-functions cps) + cps)))) From 90c11483e630dd4f1d04feae9d370304237aa6cb Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 27 Jul 2015 14:53:59 +0200 Subject: [PATCH 044/865] Better codegen for $values terms that don't shuffle * module/language/cps/compile-bytecode.scm (compute-forwarding-labels): Analyze forwarding labels before emitting code. This lets us elide conts that cause no shuffles, allowing more fallthrough. --- module/language/cps/compile-bytecode.scm | 186 +++++++++++++---------- 1 file changed, 107 insertions(+), 79 deletions(-) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index a57074380..265189b17 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -55,9 +55,42 @@ set empty-intmap))) +;; Any $values expression that continues to a $kargs and causes no +;; shuffles is a forwarding label. +(define (compute-forwarding-labels cps allocation) + (fixpoint + (lambda (forwarding-map) + (intmap-fold (lambda (label target forwarding-map) + (let ((new-target (intmap-ref forwarding-map target + (lambda (target) target)))) + (if (eqv? target new-target) + forwarding-map + (intmap-replace forwarding-map label new-target)))) + forwarding-map forwarding-map)) + (intmap-fold (lambda (label cont forwarding-labels) + (match cont + (($ $kargs _ _ ($ $continue k _ ($ $values))) + (match (lookup-parallel-moves label allocation) + (() + (match (intmap-ref cps k) + (($ $ktail) forwarding-labels) + (_ (intmap-add forwarding-labels label k)))) + (_ forwarding-labels))) + (_ forwarding-labels))) + cps empty-intmap))) + (define (compile-function cps asm) - (let ((allocation (allocate-slots cps)) - (frame-size #f)) + (let* ((allocation (allocate-slots cps)) + (forwarding-labels (compute-forwarding-labels cps allocation)) + (frame-size #f)) + (define (forward-label k) + (intmap-ref forwarding-labels k (lambda (k) k))) + + (define (elide-cont? label) + (match (intmap-ref forwarding-labels label (lambda (_) #f)) + (#f #f) + (target (not (eqv? label target))))) + (define (maybe-slot sym) (lookup-maybe-slot sym allocation)) @@ -242,18 +275,6 @@ (($ $primcall 'unwind ()) (emit-unwind asm)))) - (define (forward-label label seen) - (if (memv label seen) - label - (match (intmap-ref cps label) - (($ $kargs _ _ ($ $continue k _ ($ $values))) - (match (lookup-parallel-moves label allocation) - (() (match (intmap-ref cps k) - (($ $ktail) label) - (_ (forward-label k (cons label seen))))) - (_ label))) - (cont label)))) - (define (compile-values label exp syms) (match exp (($ $values args) @@ -262,62 +283,60 @@ (lookup-parallel-moves label allocation))))) (define (compile-test label exp kt kf next-label) - (let* ((kt (forward-label kt '())) - (kf (forward-label kf '()))) - (define (prefer-true?) - (if (< (max kt kf) label) - ;; Two backwards branches. Prefer - ;; the nearest. - (> kt kf) - ;; Otherwise prefer a backwards - ;; branch or a near jump. - (< kt kf))) - (define (unary op sym) - (cond - ((eq? kt next-label) - (op asm (slot sym) #t kf)) - ((eq? kf next-label) - (op asm (slot sym) #f kt)) - (else - (let ((invert? (not (prefer-true?)))) - (op asm (slot sym) invert? (if invert? kf kt)) - (emit-br asm (if invert? kt kf)))))) - (define (binary op a b) - (cond - ((eq? kt next-label) - (op asm (slot a) (slot b) #t kf)) - ((eq? kf next-label) - (op asm (slot a) (slot b) #f kt)) - (else - (let ((invert? (not (prefer-true?)))) - (op asm (slot a) (slot b) invert? (if invert? kf kt)) - (emit-br asm (if invert? kt kf)))))) - (match exp - (($ $values (sym)) (unary emit-br-if-true sym)) - (($ $primcall 'null? (a)) (unary emit-br-if-null a)) - (($ $primcall 'nil? (a)) (unary emit-br-if-nil a)) - (($ $primcall 'pair? (a)) (unary emit-br-if-pair a)) - (($ $primcall 'struct? (a)) (unary emit-br-if-struct a)) - (($ $primcall 'char? (a)) (unary emit-br-if-char a)) - (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a)) - (($ $primcall 'variable? (a)) (unary emit-br-if-variable a)) - (($ $primcall 'vector? (a)) (unary emit-br-if-vector a)) - (($ $primcall 'string? (a)) (unary emit-br-if-string a)) - (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a)) - (($ $primcall 'bitvector? (a)) (unary emit-br-if-bitvector a)) - (($ $primcall 'keyword? (a)) (unary emit-br-if-keyword a)) - ;; Add more TC7 tests here. Keep in sync with - ;; *branching-primcall-arities* in (language cps primitives) and - ;; the set of macro-instructions in assembly.scm. - (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b)) - (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b)) - (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b)) - (($ $primcall '< (a b)) (binary emit-br-if-< a b)) - (($ $primcall '<= (a b)) (binary emit-br-if-<= a b)) - (($ $primcall '= (a b)) (binary emit-br-if-= a b)) - (($ $primcall '>= (a b)) (binary emit-br-if-<= b a)) - (($ $primcall '> (a b)) (binary emit-br-if-< b a)) - (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b))))) + (define (prefer-true?) + (if (< (max kt kf) label) + ;; Two backwards branches. Prefer + ;; the nearest. + (> kt kf) + ;; Otherwise prefer a backwards + ;; branch or a near jump. + (< kt kf))) + (define (unary op sym) + (cond + ((eq? kt next-label) + (op asm (slot sym) #t kf)) + ((eq? kf next-label) + (op asm (slot sym) #f kt)) + (else + (let ((invert? (not (prefer-true?)))) + (op asm (slot sym) invert? (if invert? kf kt)) + (emit-br asm (if invert? kt kf)))))) + (define (binary op a b) + (cond + ((eq? kt next-label) + (op asm (slot a) (slot b) #t kf)) + ((eq? kf next-label) + (op asm (slot a) (slot b) #f kt)) + (else + (let ((invert? (not (prefer-true?)))) + (op asm (slot a) (slot b) invert? (if invert? kf kt)) + (emit-br asm (if invert? kt kf)))))) + (match exp + (($ $values (sym)) (unary emit-br-if-true sym)) + (($ $primcall 'null? (a)) (unary emit-br-if-null a)) + (($ $primcall 'nil? (a)) (unary emit-br-if-nil a)) + (($ $primcall 'pair? (a)) (unary emit-br-if-pair a)) + (($ $primcall 'struct? (a)) (unary emit-br-if-struct a)) + (($ $primcall 'char? (a)) (unary emit-br-if-char a)) + (($ $primcall 'symbol? (a)) (unary emit-br-if-symbol a)) + (($ $primcall 'variable? (a)) (unary emit-br-if-variable a)) + (($ $primcall 'vector? (a)) (unary emit-br-if-vector a)) + (($ $primcall 'string? (a)) (unary emit-br-if-string a)) + (($ $primcall 'bytevector? (a)) (unary emit-br-if-bytevector a)) + (($ $primcall 'bitvector? (a)) (unary emit-br-if-bitvector a)) + (($ $primcall 'keyword? (a)) (unary emit-br-if-keyword a)) + ;; Add more TC7 tests here. Keep in sync with + ;; *branching-primcall-arities* in (language cps primitives) and + ;; the set of macro-instructions in assembly.scm. + (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b)) + (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b)) + (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b)) + (($ $primcall '< (a b)) (binary emit-br-if-< a b)) + (($ $primcall '<= (a b)) (binary emit-br-if-<= a b)) + (($ $primcall '= (a b)) (binary emit-br-if-= a b)) + (($ $primcall '>= (a b)) (binary emit-br-if-<= b a)) + (($ $primcall '> (a b)) (binary emit-br-if-< b a)) + (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b)))) (define (compile-trunc label k exp nreq rest-var) (define (do-call proc args emit-call) @@ -359,13 +378,17 @@ (lambda (asm proc-slot nargs) (emit-call-label asm proc-slot nargs k)))))) + (define (skip-elided-conts label) + (if (elide-cont? label) + (skip-elided-conts (1+ label)) + label)) + (define (compile-expression label k exp) - (let* ((fallthrough? (= k (1+ label)))) + (let* ((forwarded-k (forward-label k)) + (fallthrough? (= forwarded-k (skip-elided-conts (1+ label))))) (define (maybe-emit-jump) - (unless (or fallthrough? - (= (forward-label k '()) - (forward-label (1+ label) '()))) - (emit-br asm k))) + (unless fallthrough? + (emit-br asm forwarded-k))) (match (intmap-ref cps k) (($ $ktail) (compile-tail label exp)) @@ -377,7 +400,8 @@ (($ $kargs () ()) (match exp (($ $branch kt exp) - (compile-test label exp kt k (1+ label))) + (compile-test label exp (forward-label kt) forwarded-k + (skip-elided-conts (1+ label)))) (_ (compile-effect label exp k) (maybe-emit-jump)))) @@ -389,8 +413,11 @@ (and rest (match (intmap-ref cps kargs) (($ $kargs names (_ ... rest)) rest)))) - (unless (and fallthrough? (= kargs (1+ k))) - (emit-br asm kargs)))))) + (let* ((kargs (forward-label kargs)) + (fallthrough? (and fallthrough? + (= kargs (skip-elided-conts (1+ k)))))) + (unless fallthrough? + (emit-br asm kargs))))))) (define (compile-cont label cont) (match cont @@ -421,7 +448,8 @@ names vars) (when src (emit-source asm src)) - (compile-expression label k exp)) + (unless (elide-cont? label) + (compile-expression label k exp))) (($ $kreceive arity kargs) (emit-label asm label)) (($ $ktail) From 48412395c6501d0f4f98494cfe20c1c18b14d7a6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 27 Jul 2015 15:11:09 +0200 Subject: [PATCH 045/865] Add closure effects * module/language/cps/effects-analysis.scm: Add closure effects, to enable hoisting/CSE of free-ref/free-set!. --- module/language/cps/effects-analysis.scm | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index af1a5292e..778855de5 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -63,6 +63,7 @@ &struct &string &bytevector + &closure &object &field @@ -180,7 +181,10 @@ ;; Indicates that an expression depends on the contents of a ;; bytevector. We cannot be more precise, as bytevectors may alias ;; other bytevectors. - &bytevector) + &bytevector + + ;; Indicates a dependency on a free variable of a closure. + &closure) (define-inlinable (&field kind field) (ash (logior (ash field &memory-kind-bits) kind) &effect-kind-bits)) @@ -373,6 +377,17 @@ is or might be a read or a write to the same location as A." ((bv-f32-set! bv n x) (&write-object &bytevector) &type-check) ((bv-f64-set! bv n x) (&write-object &bytevector) &type-check)) +;; Closures. +(define (closure-field n constants) + (indexed-field &closure n constants)) +(define (read-closure-field n constants) + (logior &read (closure-field n constants))) +(define (write-closure-field n constants) + (logior &write (closure-field n constants))) +(define-primitive-effects* constants + ((free-ref closure idx) (read-closure-field idx constants)) + ((free-set! closure idx val) (write-closure-field idx constants))) + ;; Modules. (define-primitive-effects ((current-module) (&read-object &module)) From 00884bb79fff41fdf5f22f24a74e366a94a14c9b Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 13 Aug 2015 01:31:36 -0400 Subject: [PATCH 046/865] Allow decoding of UTF-8 containing U+FFFD, the replacement character. * libguile/strings.c (scm_from_utf8_stringn): Use 'u8_mbtoucr' and check for a decoding error by its 'nbytes' return value. Previously we used 'u8_mbtouc' and improperly assumed that a U+FFFD character indicated a decoding error. * libguile/symbols.c (utf8_string_equals_wide_string): Likewise. * test-suite/tests/bytevectors.test (exception:decoding-error): New variable. ("2.9 Operations on Strings"): Add tests. --- libguile/strings.c | 7 ++++--- libguile/symbols.c | 8 ++++---- test-suite/tests/bytevectors.test | 14 +++++++++++++- 3 files changed, 21 insertions(+), 8 deletions(-) diff --git a/libguile/strings.c b/libguile/strings.c index 90dc83a66..ee43e815e 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2004, 2006, + * 2008-2015 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 License @@ -1673,9 +1674,9 @@ scm_from_utf8_stringn (const char *str, size_t len) ascii = 0; - nbytes = u8_mbtouc (&c, ustr + i, len - i); + nbytes = u8_mbtoucr (&c, ustr + i, len - i); - if (c == 0xfffd) + if (nbytes < 0) /* Bad UTF-8. */ decoding_error (__func__, errno, str, len); diff --git a/libguile/symbols.c b/libguile/symbols.c index f93833b9d..71d982730 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -1,5 +1,5 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2003, 2004, - * 2006, 2009, 2011, 2013 Free Software Foundation, Inc. +/* Copyright (C) 1995-1998, 2000, 2001, 2003, 2004, 2006, 2009, 2011, + * 2013, 2015 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 License @@ -164,10 +164,10 @@ utf8_string_equals_wide_string (const scm_t_uint8 *narrow, size_t nlen, ucs4_t c; int nbytes; - nbytes = u8_mbtouc (&c, narrow + byte_idx, nlen - byte_idx); + nbytes = u8_mbtoucr (&c, narrow + byte_idx, nlen - byte_idx); if (nbytes == 0) break; - else if (c == 0xfffd) + else if (nbytes < 0) /* Bad UTF-8. */ return 0; else if (c != wide[char_idx]) diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test index 4cc5b67e0..f8f020a30 100644 --- a/test-suite/tests/bytevectors.test +++ b/test-suite/tests/bytevectors.test @@ -1,6 +1,6 @@ ;;;; bytevectors.test --- R6RS bytevectors. -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2009-2014 Free Software Foundation, Inc. +;;;; Copyright (C) 2009-2015 Free Software Foundation, Inc. ;;;; ;;;; Ludovic Courtès ;;;; @@ -24,6 +24,9 @@ :use-module (rnrs bytevectors) :use-module (srfi srfi-4)) +(define exception:decoding-error + (cons 'decoding-error "input (locale conversion|decoding) error")) + ;;; Some of the tests in here are examples taken from the R6RS Standard ;;; Libraries document. @@ -501,6 +504,15 @@ (= (string-length str) (- (bytevector-length utf8) 2))))) + (pass-if-equal "utf8->string [replacement character]" + '(104 105 65533) + (map char->integer + (string->list (utf8->string #vu8(104 105 239 191 189))))) + + (pass-if-exception "utf8->string [invalid encoding]" + exception:decoding-error + (utf8->string #vu8(104 105 239 191 50))) + (pass-if "utf16->string" (let* ((utf16 (uint-list->bytevector (map char->integer (string->list "hello, world")) From 78fdc3e6731df78022345a2680c5c6a18115388a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 17 Sep 2015 12:45:36 +0200 Subject: [PATCH 047/865] Remove unused (language tree-il inline) module. * module/language/tree-il/inline.scm: Remove. * module/Makefile.am (TREE_IL_LANG_SOURCES): Remove inline.scm. --- module/Makefile.am | 1 - module/language/tree-il/inline.scm | 25 ------------------------- 2 files changed, 26 deletions(-) delete mode 100644 module/language/tree-il/inline.scm diff --git a/module/Makefile.am b/module/Makefile.am index 3dc6117d3..17e663241 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -115,7 +115,6 @@ TREE_IL_LANG_SOURCES = \ language/tree-il/optimize.scm \ language/tree-il/canonicalize.scm \ language/tree-il/analyze.scm \ - language/tree-il/inline.scm \ language/tree-il/compile-cps.scm \ language/tree-il/debug.scm \ language/tree-il/spec.scm diff --git a/module/language/tree-il/inline.scm b/module/language/tree-il/inline.scm deleted file mode 100644 index 5a2d9af55..000000000 --- a/module/language/tree-il/inline.scm +++ /dev/null @@ -1,25 +0,0 @@ -;;; a simple inliner - -;; Copyright (C) 2009, 2010, 2011 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -(define-module (language tree-il inline) - #:export (inline!)) - -(define (inline! x) - (issue-deprecation-warning - "`inline!' is deprecated. Use (language tree-il peval) instead.") - x) From d701e8a3d36cb18096042413bd60b0993845beea Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 17 Sep 2015 20:14:35 +0200 Subject: [PATCH 048/865] Update CPS language documentation * doc/ref/compiler.texi (Continuation-Passing Style): Update to latest CPS language. --- doc/ref/compiler.texi | 507 +++++++++++++++++++++++++++++------------- 1 file changed, 353 insertions(+), 154 deletions(-) diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi index 9743c5357..75fd4e5cb 100644 --- a/doc/ref/compiler.texi +++ b/doc/ref/compiler.texi @@ -513,12 +513,8 @@ Optimization passes performed on Tree-IL currently include: and calls to primitives to primcalls) @item Partial evaluation (comprising inlining, copy propagation, and constant folding) -@item Common subexpression elimination (CSE) @end itemize -In the future, we will move the CSE pass to operate over the lower-level -CPS language. - @node Continuation-Passing Style @subsection Continuation-Passing Style @@ -534,6 +530,7 @@ compiler. * An Introduction to CPS:: * CPS in Guile:: * Building CPS:: +* CPS Soup:: * Compiling CPS:: @end menu @@ -624,12 +621,57 @@ details manifest, and gives them names. @node CPS in Guile @subsubsection CPS in Guile -Guile's CPS language is composed of @dfn{terms}, @dfn{expressions}, -and @dfn{continuations}. +@cindex continuation, CPS +Guile's CPS language is composed of @dfn{continuations}. A continuation +is a labelled program point. If you are used to traditional compilers, +think of a continuation as a trivial basic block. A program is a +``soup'' of continuations, represented as a map from labels to +continuations. -A term can either evaluate an expression and pass the resulting values -to some continuation, or it can declare local continuations and contain -a sub-term in the scope of those continuations. +@cindex term, CPS +@cindex expression, CPS +Like basic blocks, each continuation belongs to only one function. Some +continuations are special, like the continuation corresponding to a +function's entry point, or the continuation that represents the tail of +a function. Others contain a @dfn{term}. A term contains an +@dfn{expression}, which evaluates to zero or more values. The term also +records the continuation to which it will pass its values. Some terms, +like conditional branches, may continue to one of a number of +continuations. + +Continuation labels are small integers. This makes it easy to sort them +and to group them into sets. Whenever a term refers to a continuation, +it does so by name, simply recording the label of the continuation. +Continuation labels are unique among the set of labels in a program. + +Variables are also named by small integers. Variable names are unique +among the set of variables in a program. + +For example, a simple continuation that receives two values and adds +them together can be matched like this, using the @code{match} form from +@code{(ice-9 match)}: + +@smallexample +(match cont + (($ $kargs (x-name y-name) (x-var y-var) + ($ $continue k src ($ $primcall '+ (x-var y-var)))) + (format #t "Add ~a and ~a and pass the result to label ~a" + x-var y-var k))) +@end smallexample + +Here we see the most common kind of continuation, @code{$kargs}, which +binds some number of values to variables and then evaluates a term. + +@deftp {CPS Continuation} $kargs names vars term +Bind the incoming values to the variables @var{vars}, with original +names @var{names}, and then evaluate @var{term}. +@end deftp + +The @var{names} of a @code{$kargs} are just for debugging, and will end +up residualized in the object file for use by the debugger. + +The @var{term} in a @code{$kargs} is always a @code{$continue}, which +evaluates an expression and continues to a continuation. @deftp {CPS Term} $continue k src exp Evaluate the expression @var{exp} and pass the resulting values (if any) @@ -639,44 +681,33 @@ as in @code{source-properties} or is @code{#f} if there is no associated source. @end deftp -@deftp {CPS Term} $letk conts body -Bind @var{conts}, a list of continuations (@code{$cont} instances), in -the scope of the sub-term @var{body}. The continuations are mutually -recursive. +There are a number of expression kinds. Above you see an example of +@code{$primcall}. + +@deftp {CPS Expression} $primcall name args +Perform the primitive operation identified by @code{name}, a well-known +symbol, passing it the arguments @var{args}, and pass all resulting +values to the continuation. The set of available primitives includes +all primitives known to Tree-IL and then some more; see the source code +for details. @end deftp -Additionally, the early stages of CPS allow for a set of mutually -recursive functions to be declared as a term. This @code{$letrec} type -is like Tree-IL's @code{}. The contification pass will attempt to -transform the functions declared in a @code{$letrec} into local -continuations. Any remaining functions are later lowered to @code{$fun} -expressions. - -@deftp {CPS Term} $letrec names syms funs body -Declare the mutually recursive set of functions denoted by @var{names}, -@var{syms}, and @var{funs} within the sub-term @var{body}. @var{names} -and @var{syms} are lists of symbols, and @var{funs} is a list of -@code{$fun} values. @var{syms} are globally unique. -@end deftp - -A higher-order CPS program is a @code{$cont} containing a @code{$kfun} -(see below), and the @code{$kfun} which contains clauses and those -clauses contain terms. A first-order CPS program, on the other hand, is -the result of closure conversion and does not contain nested functions. -Closure conversion lifts code for all functions up to the top, collects -their entry continuations as a list of @code{$cont} @code{$kfun} -instances and binds them in a @code{$program}. - -@deftp {CPS Term} $program funs -A first-order CPS term declaring a recursive scope for first-order -functions in a compilation unit. @var{funs} is a list of @code{$cont} -@code{$kfun} instances. The first entry in the list is the entry -function for the program. -@end deftp +@cindex dominate, CPS +The variables that are used by @code{$primcall}, or indeed by any +expression, must be defined before the expression is evaluated. An +equivalent way of saying this is that predecessor @code{$kargs} +continuation(s) that bind the variables(s) used by the expression must +@dfn{dominate} the continuation that uses the expression: definitions +dominate uses. This condition is trivially satisfied in our example +above, but in general to determine the set of variables that are in +``scope'' for a given term, you need to do a flow analysis to see what +continuations dominate a term. The variables that are in scope are +those variables defined by the continuations that dominate a term. Here is an inventory of the kinds of expressions in Guile's CPS -language. Recall that all expressions are wrapped in a @code{$continue} -term which specifies their continuation. +language, besides @code{$primcall} which has already been described. +Recall that all expressions are wrapped in a @code{$continue} term which +specifies their continuation. @deftp {CPS Expression} $const val Continue with the constant value @var{val}. @@ -687,47 +718,11 @@ Continue with the procedure that implements the primitive operation named by @var{name}. @end deftp -@deftp {CPS Expression} $fun free body -Continue with a procedure. @var{free} is a list of free variables -accessed by the procedure. Early CPS uses an empty list for @var{free}; -only after closure conversion is it correctly populated. Finally, -@var{body} is the @code{$kfun} @code{$cont} of the procedure entry. -@end deftp - -@code{$fun} is part of higher-level CPS. After closure conversion, -@code{$fun} instances are given a concrete representation. By default, -a closure is represented as an object built by a @code{$closure} -expression - -@deftp {CPS Expression} $closure label nfree -Build a closure that joins the code at the continuation named -@var{label} with space for @var{nfree} free variables. The variables -will be initialized later via @code{free-variable-set!} primcalls. -@end deftp - -If the closure can be proven to never escape its scope then other -lighter-weight representations can be chosen. - @deftp {CPS Expression} $call proc args -@deftpx {CPS Expression} $callk label proc args Call @var{proc} with the arguments @var{args}, and pass all values to the continuation. @var{proc} and the elements of the @var{args} list should all be variable names. The continuation identified by the term's @var{k} should be a @code{$kreceive} or a @code{$ktail} instance. - -@code{$callk} is for the case where the call target is known to be in -the same compilation unit. @var{label} should be some continuation -label, though it need not be in scope. In this case the @var{proc} is -simply an additional argument, since it is not used to determine the -call target at run-time. -@end deftp - -@deftp {CPS Expression} $primcall name args -Perform the primitive operation identified by @code{name}, a well-known -symbol, passing it the arguments @var{args}, and pass all resulting -values to the continuation. The set of available primitives includes -all primitives known to Tree-IL and then some more; see the source code -for details. @end deftp @deftp {CPS Expression} $values args @@ -736,7 +731,8 @@ Pass the values named by the list @var{args} to the continuation. @deftp {CPS Expression} $branch kt exp Evaluate the branching expression @var{exp}, and continue to @var{kt} -with zero values if the test evaluates to true. Otherwise, in the false +with zero values if the test evaluates to true. Otherwise continue to +the continuation named in the outer @code{$continue} term. Only certain expressions are valid in a @var{$branch}. Compiling a @code{$branch} avoids allocating space for the test variable, so the @@ -744,9 +740,9 @@ expression should be evaluatable without temporary values. In practice this condition is true for @code{$primcall}s to @code{null?}, @code{=}, and similar primitives that have corresponding @code{br-if-@var{foo}} VM operations; see the source code for full details. When in doubt, bind -the test expression to a variable, and reference the variable in the -@code{$branch} expression. The optimizer should inline the reference if -possible. +the test expression to a variable, and branch on a @code{$values} +expression that references that variable. The optimizer should inline +the reference if possible. @end deftp @deftp {CPS Expression} $prompt escape? tag handler @@ -758,30 +754,73 @@ the continuation labelled @var{handler}, which should be a @code{pop-prompt} primcalls. @end deftp -The remaining element of the CPS language in Guile is the continuation. -In CPS, all continuations have unique labels. Since this aspect is -common to all continuation types, all continuations are contained in a -@code{$cont} instance: +@cindex higher-order CPS +@cindex CPS, higher-order +@cindex first-order CPS +@cindex CPS, first-order +There are two sub-languages of CPS, @dfn{higher-order CPS} and +@dfn{first-order CPS}. The difference is that in higher-order CPS, +there are @code{$fun} and @code{$rec} expressions that bind functions or +mutually-recursive functions in the implicit scope of their use sites. +Guile transforms higher-order CPS into first-order CPS by @dfn{closure +conversion}, which chooses representations for all closures and which +arranges to access free variables through the implicit closure parameter +that is passed to every function call. -@deftp {CPS Continuation Wrapper} $cont k cont -Declare a continuation labelled @var{k}. All references to the -continuation will use this label. +@deftp {CPS Expression} $fun body +Continue with a procedure. @var{body} names the entry point of the +function, which should be a @code{$kfun}. This expression kind is only +valid in higher-order CPS, which is the CPS language before closure +conversion. @end deftp -The most common kind of continuation binds some number of values, and -then evaluates a sub-term. @code{$kargs} is this kind of simple -@code{lambda}. - -@deftp {CPS Continuation} $kargs names syms body -Bind the incoming values to the variables @var{syms}, with original -names @var{names}, and then evaluate the sub-term @var{body}. +@deftp {CPS Expression} $rec names vars funs +Continue with a set of mutually recursive procedures denoted by +@var{names}, @var{vars}, and @var{funs}. @var{names} is a list of +symbols, @var{vars} is a list of variable names (unique integers), and +@var{funs} is a list of @code{$fun} values. Note that the @code{$kargs} +continuation should also define @var{names}/@var{vars} bindings. @end deftp -Variable names (the names in the @var{syms} of a @code{$kargs}) should -be unique among all other variable names. To bind a value to a variable -and then evaluate some term, you would continue with the value to a -@code{$kargs} that declares one variable. The bound value would then be -available for use within the body of the @code{$kargs}. +The contification pass will attempt to transform the functions declared +in a @code{$rec} into local continuations. Any remaining @code{$fun} +instances are later removed by the closure conversion pass. By default, +a closure is represented as an object built by a @code{$closure} +expression. + +@deftp {CPS Expression} $closure label nfree +Build a closure that joins the code at the continuation named +@var{label} with space for @var{nfree} free variables. The variables +will be initialized later via @code{free-set!} primcalls. This +expression kind is part of first-order CPS. +@end deftp + +If the closure can be proven to never escape its scope then other +lighter-weight representations can be chosen. Additionally, if all call +sites are known, closure conversion will hard-wire the calls by lowering +@code{$call} to @code{$callk}. + +@deftp {CPS Expression} $callk label proc args +Like @code{$call}, but for the case where the call target is known to be +in the same compilation unit. @var{label} should denote some +@code{$kfun} continuation in the program. In this case the @var{proc} +is simply an additional argument, since it is not used to determine the +call target at run-time. +@end deftp + +At this point we have described terms, expressions, and the most common +kind of continuation, @code{$kargs}. @code{$kargs} is used when the +predecessors of the continuation can be instructed to pass the values +where the continuation wants them. For example, if a @code{$kargs} +continuation @var{k} binds a variable @var{v}, and the compiler decides +to allocate @var{v} to slot 6, all predecessors of @var{k} should put +the value for @var{v} in slot 6 before jumping to @var{k}. One +situation in which this isn't possible is receiving values from function +calls. Guile has a calling convention for functions which currently +places return values on the stack. A continuation of a call must check +that the number of values returned from a function matches the expected +number of values, and then must shuffle or collect those values to named +variables. @code{$kreceive} denotes this kind of continuation. @deftp {CPS Continuation} $kreceive arity k Receive values on the stack. Parse them according to @var{arity}, and @@ -806,18 +845,18 @@ Note that all of these names with the exception of the @var{var}s in the @var{kw} list are source names, not unique variable names. @end deftp -Additionally, there are three specific kinds of continuations that can -only be declared at function entries. +Additionally, there are three specific kinds of continuations that are +only used in function entries. @deftp {CPS Continuation} $kfun src meta self tail clauses Declare a function entry. @var{src} is the source information for the procedure declaration, and @var{meta} is the metadata alist as described above in Tree-IL's @code{}. @var{self} is a variable bound to the procedure being called, and which may be used for self-references. -@var{tail} declares the @code{$cont} wrapping the @code{$ktail} for this -function, corresponding to the function's tail continuation. -@var{clause} is the first @code{$kclause} @code{$cont} instance for the -first @code{case-lambda} clause in the function, or otherwise @code{#f}. +@var{tail} is the label of the @code{$ktail} for this function, +corresponding to the function's tail continuation. @var{clause} is the +label of the first @code{$kclause} for the first @code{case-lambda} +clause in the function, or otherwise @code{#f}. @end deftp @deftp {CPS Continuation} $ktail @@ -826,10 +865,10 @@ A tail continuation. @deftp {CPS Continuation} $kclause arity cont alternate A clause of a function with a given arity. Applications of a function -with a compatible set of actual arguments will continue to @var{cont}, a -@code{$kargs} @code{$cont} instance representing the clause body. If -the arguments are incompatible, control proceeds to @var{alternate}, -which is a @code{$kclause} @code{$cont} for the next clause, or +with a compatible set of actual arguments will continue to the +continuation labelled @var{cont}, a @code{$kargs} instance representing +the clause body. If the arguments are incompatible, control proceeds to +@var{alternate}, which is a @code{$kclause} for the next clause, or @code{#f} if there is no next clause. @end deftp @@ -842,41 +881,41 @@ constructors or accessors, or instead of S-expression matching. Deconstruction and matching is handled adequately by the @code{match} form from @code{(ice-9 match)}. @xref{Pattern Matching}. Construction -is handled by a set of mutually recursive builder macros: -@code{build-cps-term}, @code{build-cps-cont}, and @code{build-cps-exp}. +is handled by a set of mutually builder macros: +@code{build-term}, @code{build-cont}, and @code{build-exp}. -In the following interface definitions, consider variables containing -@code{cont} to be recursively build by @code{build-cps-cont}, and -likewise for @code{term} and @code{exp}. Consider any other name to be -evaluated as a Scheme expression. Many of these forms recognize -@code{unquote} in some contexts, to splice in a previously-built value; -see the specifications below for full details. +In the following interface definitions, consider @code{term} and +@code{exp} to be built by @code{build-term} or @code{build-exp}, +respectively. Consider any other name to be evaluated as a Scheme +expression. Many of these forms recognize @code{unquote} in some +contexts, to splice in a previously-built value; see the specifications +below for full details. -@deffn {Scheme Syntax} build-cps-term ,val -@deffnx {Scheme Syntax} build-cps-term ($letk (cont ...) term) -@deffnx {Scheme Syntax} build-cps-term ($letrec names syms funs term) -@deffnx {Scheme Syntax} build-cps-term ($continue k src exp) -@deffnx {Scheme Syntax} build-cps-term ($program conts) -@deffnx {Scheme Syntax} build-cps-exp ,val -@deffnx {Scheme Syntax} build-cps-exp ($const val) -@deffnx {Scheme Syntax} build-cps-exp ($prim name) -@deffnx {Scheme Syntax} build-cps-exp ($fun src meta free body) -@deffnx {Scheme Syntax} build-cps-exp ($call proc (arg ...)) -@deffnx {Scheme Syntax} build-cps-exp ($call proc args) -@deffnx {Scheme Syntax} build-cps-exp ($primcall name (arg ...)) -@deffnx {Scheme Syntax} build-cps-exp ($primcall name args) -@deffnx {Scheme Syntax} build-cps-exp ($values (arg ...)) -@deffnx {Scheme Syntax} build-cps-exp ($values args) -@deffnx {Scheme Syntax} build-cps-exp ($prompt escape? tag handler) -@deffnx {Scheme Syntax} build-cps-cont ,val -@deffnx {Scheme Syntax} build-cps-cont (k ($kargs (name ...) (sym ...) term)) -@deffnx {Scheme Syntax} build-cps-cont (k ($kargs names syms term)) -@deffnx {Scheme Syntax} build-cps-cont (k ($kif kt kf)) -@deffnx {Scheme Syntax} build-cps-cont (k ($kreceive req rest kargs)) -@deffnx {Scheme Syntax} build-cps-cont (k ($kentry self tail-cont ,clauses)) -@deffnx {Scheme Syntax} build-cps-cont (k ($kentry self tail-cont (cont ...))) -@deffnx {Scheme Syntax} build-cps-cont (k ($kclause ,arity cont)) -@deffnx {Scheme Syntax} build-cps-cont (k ($kclause (req opt rest kw aok?) cont)) +@deffn {Scheme Syntax} build-term ,val +@deffnx {Scheme Syntax} build-term ($continue k src exp) +@deffnx {Scheme Syntax} build-exp ,val +@deffnx {Scheme Syntax} build-exp ($const val) +@deffnx {Scheme Syntax} build-exp ($prim name) +@deffnx {Scheme Syntax} build-exp ($branch kt exp) +@deffnx {Scheme Syntax} build-exp ($fun kentry) +@deffnx {Scheme Syntax} build-exp ($rec names syms funs) +@deffnx {Scheme Syntax} build-exp ($closure k nfree) +@deffnx {Scheme Syntax} build-exp ($call proc (arg ...)) +@deffnx {Scheme Syntax} build-exp ($call proc args) +@deffnx {Scheme Syntax} build-exp ($callk k proc (arg ...)) +@deffnx {Scheme Syntax} build-exp ($callk k proc args) +@deffnx {Scheme Syntax} build-exp ($primcall name (arg ...)) +@deffnx {Scheme Syntax} build-exp ($primcall name args) +@deffnx {Scheme Syntax} build-exp ($values (arg ...)) +@deffnx {Scheme Syntax} build-exp ($values args) +@deffnx {Scheme Syntax} build-exp ($prompt escape? tag handler) +@deffnx {Scheme Syntax} build-cont ,val +@deffnx {Scheme Syntax} build-cont ($kargs (name ...) (sym ...) term) +@deffnx {Scheme Syntax} build-cont ($kargs names syms term) +@deffnx {Scheme Syntax} build-cont ($kreceive req rest kargs) +@deffnx {Scheme Syntax} build-cont ($kfun src meta self ktail kclause) +@deffnx {Scheme Syntax} build-cont ($kclause ,arity kbody kalt) +@deffnx {Scheme Syntax} build-cont ($kclause (req opt rest kw aok?) kbody) Construct a CPS term, expression, or continuation. @end deffn @@ -886,19 +925,179 @@ There are a few more miscellaneous interfaces as well. A procedural constructor for @code{$arity} objects. @end deffn -@deffn {Scheme Syntax} let-gensyms (sym ...) body ... -Bind @var{sym...} to fresh names, and evaluate @var{body...}. -@end deffn - -@deffn {Scheme Syntax} rewrite-cps-term val (pat term) ... -@deffnx {Scheme Syntax} rewrite-cps-exp val (pat exp) ... -@deffnx {Scheme Syntax} rewrite-cps-cont val (pat cont) ... +@deffn {Scheme Syntax} rewrite-term val (pat term) ... +@deffnx {Scheme Syntax} rewrite-exp val (pat exp) ... +@deffnx {Scheme Syntax} rewrite-cont val (pat cont) ... Match @var{val} against the series of patterns @var{pat...}, using @code{match}. The body of the matching clause should be a template in -the syntax of @code{build-cps-term}, @code{build-cps-exp}, or -@code{build-cps-cont}, respectively. +the syntax of @code{build-term}, @code{build-exp}, or @code{build-cont}, +respectively. @end deffn +@node CPS Soup +@subsubsection CPS Soup + +We describe programs in Guile's CPS language as being a kind of ``soup'' +because all continuations in the program are mixed into the same +``pot'', so to speak. A program in CPS is a map from continuation +labels to continuation values. As discussed in the introduction, a +continuation label is an integer. No label may be negative. + +As a matter of convention, label 0 should map to the @code{$kfun} +continuation of the entry to the program, which should be a function of +no arguments. The body of a function consists of the labelled +continuations that are reachable from the function entry. A program can +refer to other functions, either via @code{$fun} and @code{$rec} in +higher-order CPS, or via @code{$closure} and @code{$callk} in +first-order CPS. The program logically contains all continuations of +all functions reachable from the entry function. A compiler pass may +leave unreachable continuations in a program, but analyses should +usually either apply only to reachable continuations, or should make +translations that are oblivious as to whether a continuation is +reachable or not. + +@cindex intmap +The map itself is implemented as an @dfn{intmap}, a functional +array-mapped trie specialized for integer keys. Currently intmaps are a +private data structure only used by the CPS phase of the compiler. To +work with intmaps, load the @code{(language cps intmap)} module: + +@example +(use-modules (language cps intmap)) +@end example + +Intmaps are functional data structures, so there is no constructor as +such: one can simply start with the empty intmap and add entries to it. + +@example +(intmap? empty-intmap) @result{} #t +(define x (intmap-add empty-intmap 42 "hi")) +(intmap? x) @result{} #t +(intmap-ref x 42) @result{} "hi" +(intmap-ref x 43) @result{} @i{error: 43 not present} +(intmap-ref x 43 (lambda (k) "yo!")) @result{} "yo" +(intmap-add x 42 "hej") @result{} @i{error: 42 already present} +@end example + +@code{intmap-ref} and @code{intmap-add} are the core of the intmap +interface. There is also @code{intmap-replace}, which replaces the +value associated with a given key, requiring that the key was present +already, and @code{intmap-remove}, which removes a key from an intmap. + +Intmaps have a tree-like structure that is well-suited to set operations +such as union and intersection, so there is are also the binary +@code{intmap-union} and @code{intmap-intersect} procedures. If the +result is equivalent to either argument, that argument is returned +as-is; in that way, one can detect whether the set operation produced a +new result simply by checking with @code{eq?}. This makes intmaps +useful when computing fixed points. + +If a key is present in both intmaps and the key is not the same in the +sense of @code{eq?}, the resulting value is determined by a ``meet'' +procedure, which is the optional last argument to @code{intmap-union}, +@code{intmap-intersect}, and also to @code{intmap-add}, +@code{intmap-replace}, and similar functions. The meet procedure will +be called with the two values and should return the intersected or +unioned value in some appropriate way. If no meet procedure is given, +the default meet procedure will raise an error. + +To traverse over the set of values in an intmap, there are the +@code{intmap-next} and @code{intmap-prev} procedures. For example, if +intmap @var{x} has one entry mapping 42 to some value, we would have: + +@example +(intmap-next x) @result{} 42 +(intmap-next x 0) @result{} 42 +(intmap-next x 42) @result{} 42 +(intmap-next x 43) @result{} #f +(intmap-prev x) @result{} 42 +(intmap-prev x 42) @result{} 42 +(intmap-prev x 41) @result{} #f +@end example + +There is also the @code{intmap-fold} procedure, which folds over keys +and values in the intmap from lowest to highest value, and +@code{intmap-fold-right} which does so in the opposite direction. These +procedures may take up to 3 seed values. The number of values that the +fold procedure returns is the number of seed values. + +@example +(define q (intmap-add (intmap-add empty-intmap 1 2) 3 4)) +(intmap-fold acons q '()) @result{} ((3 . 4) (1 . 2)) +(intmap-fold-right acons q '()) @result{} ((1 . 2) (3 . 4)) +@end example + +When an entry in an intmap is updated (removed, added, or changed), a +new intmap is created that shares structure with the original intmap. +This operation ensures that the result of existing computations is not +affected by future computations: no mutation is ever visible to user +code. This is a great property in a compiler data structure, as it lets +us hold a copy of a program before a transformation and use it while we +build a post-transformation program. + +However, the allocation costs are sometimes too much, especially in +cases when we know that we can just update the intmap in place. As an +example, say we have an intmap mapping the integers 1 to 100 to the +integers 42 to 141. Let's say that we want to transform this map by +adding 1 to each value. There is already an efficient @code{intmap-map} +procedure in the @code{(language cps utils}) module, but if we didn't +know about that we might do: + +@example +(define (intmap-increment map) + (let lp ((k 0) (map map)) + (let ((k (intmap-next map k))) + (if k + (let ((v (intmap-ref map k))) + (lp (1+ k) (intmap-replace map k (1+ v)))) + map)))) +@end example + +@cindex intmap, transient +@cindex transient intmaps +Observe that the intermediate values created by @code{intmap-replace} +are completely invisible to the program -- only the last result of +@code{intmap-replace} value is needed. The rest might as well share +state with the last one, and we could update in place. Guile allows +this kind of interface via @dfn{transient intmaps}, inspired by +Clojure's transient interface (@uref{http://clojure.org/transients}). + +The @code{intmap-add!} and @code{intmap-replace!} procedures return +transient intmaps. If one of these in-place procedures is called on a +normal persistent intmap, a new transient intmap is created. This is an +O(1) operation. In all other respects the interface is like their +persistent counterparts, @code{intmap-add} and @code{intmap-replace}. + +If an in-place procedure is called on a transient intmap, the intmap is +mutated in-place and the same value is returned. If a persistent +operation like @code{intmap-add} is called on a transient intmap, the +transient's mutable substructure is then marked as persistent, and +@code{intmap-add} then runs on a new persistent intmap sharing structure +but not state with the original transient. Mutating a transient will +cause enough copying to ensure that it can make its change, but if part +of its substructure is already ``owned'' by it, no more copying is +needed. + +We can use transients to make @code{intmap-increment} more efficient. +The two changed elements have been marked @strong{like this}. + +@example +(define (intmap-increment map) + (let lp ((k 0) (map map)) + (let ((k (intmap-next map k))) + (if k + (let ((v (intmap-ref map k))) + (lp (1+ k) (@strong{intmap-replace!} map k (1+ v)))) + (@strong{persistent-intmap} map))))) +@end example + +Be sure to tag the result as persistent using the +@code{persistent-intmap} procedure to prevent the mutability from +leaking to other parts of the program. For added paranoia, you could +call @code{persistent-intmap} on the incoming map, to ensure that if it +were already transient, that the mutations in the body of +@code{intmap-increment} wouldn't affect the incoming value. + @node Compiling CPS @subsubsection Compiling CPS From 73f6146bd83045dad909f37e42306d05f3bf9d16 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 18 Sep 2015 10:13:35 +0200 Subject: [PATCH 049/865] Minor CPS documentation cleanups * doc/ref/compiler.texi (Continuation-Passing Style): Minor cleanups. --- doc/ref/compiler.texi | 104 +++++++++++++++++++++++------------------- 1 file changed, 57 insertions(+), 47 deletions(-) diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi index 75fd4e5cb..6696360bd 100644 --- a/doc/ref/compiler.texi +++ b/doc/ref/compiler.texi @@ -939,7 +939,8 @@ respectively. We describe programs in Guile's CPS language as being a kind of ``soup'' because all continuations in the program are mixed into the same -``pot'', so to speak. A program in CPS is a map from continuation +``pot'', so to speak, without explicit markers as to what function or +scope a continuation is in. A program in CPS is a map from continuation labels to continuation values. As discussed in the introduction, a continuation label is an integer. No label may be negative. @@ -951,16 +952,18 @@ refer to other functions, either via @code{$fun} and @code{$rec} in higher-order CPS, or via @code{$closure} and @code{$callk} in first-order CPS. The program logically contains all continuations of all functions reachable from the entry function. A compiler pass may -leave unreachable continuations in a program, but analyses should -usually either apply only to reachable continuations, or should make -translations that are oblivious as to whether a continuation is -reachable or not. +leave unreachable continuations in a program; subsequent compiler passes +should ensure that their transformations and analyses only take +reachable continuations into account. It's OK though if transformation +runs over all continuations if including the unreachable continuations +has no effect on the transformations on the live continuations. @cindex intmap -The map itself is implemented as an @dfn{intmap}, a functional -array-mapped trie specialized for integer keys. Currently intmaps are a -private data structure only used by the CPS phase of the compiler. To -work with intmaps, load the @code{(language cps intmap)} module: +The ``soup'' itself is implemented as an @dfn{intmap}, a functional +array-mapped trie specialized for integer keys. Intmaps associate +integers with values of any kind. Currently intmaps are a private data +structure only used by the CPS phase of the compiler. To work with +intmaps, load the @code{(language cps intmap)} module: @example (use-modules (language cps intmap)) @@ -992,14 +995,14 @@ as-is; in that way, one can detect whether the set operation produced a new result simply by checking with @code{eq?}. This makes intmaps useful when computing fixed points. -If a key is present in both intmaps and the key is not the same in the -sense of @code{eq?}, the resulting value is determined by a ``meet'' -procedure, which is the optional last argument to @code{intmap-union}, -@code{intmap-intersect}, and also to @code{intmap-add}, -@code{intmap-replace}, and similar functions. The meet procedure will -be called with the two values and should return the intersected or -unioned value in some appropriate way. If no meet procedure is given, -the default meet procedure will raise an error. +If a key is present in both intmaps and the associated values are not +the same in the sense of @code{eq?}, the resulting value is determined +by a ``meet'' procedure, which is the optional last argument to +@code{intmap-union}, @code{intmap-intersect}, and also to +@code{intmap-add}, @code{intmap-replace}, and similar functions. The +meet procedure will be called with the two values and should return the +intersected or unioned value in some domain-specific way. If no meet +procedure is given, the default meet procedure will raise an error. To traverse over the set of values in an intmap, there are the @code{intmap-next} and @code{intmap-prev} procedures. For example, if @@ -1033,15 +1036,16 @@ This operation ensures that the result of existing computations is not affected by future computations: no mutation is ever visible to user code. This is a great property in a compiler data structure, as it lets us hold a copy of a program before a transformation and use it while we -build a post-transformation program. +build a post-transformation program. Updating an intmap is O(log +@var{n}) in the size of the intmap. -However, the allocation costs are sometimes too much, especially in -cases when we know that we can just update the intmap in place. As an -example, say we have an intmap mapping the integers 1 to 100 to the -integers 42 to 141. Let's say that we want to transform this map by -adding 1 to each value. There is already an efficient @code{intmap-map} -procedure in the @code{(language cps utils}) module, but if we didn't -know about that we might do: +However, the O(log @var{n}) allocation costs are sometimes too much, +especially in cases when we know that we can just update the intmap in +place. As an example, say we have an intmap mapping the integers 1 to +100 to the integers 42 to 141. Let's say that we want to transform this +map by adding 1 to each value. There is already an efficient +@code{intmap-map} procedure in the @code{(language cps utils}) module, +but if we didn't know about that we might do: @example (define (intmap-increment map) @@ -1062,21 +1066,21 @@ state with the last one, and we could update in place. Guile allows this kind of interface via @dfn{transient intmaps}, inspired by Clojure's transient interface (@uref{http://clojure.org/transients}). -The @code{intmap-add!} and @code{intmap-replace!} procedures return -transient intmaps. If one of these in-place procedures is called on a -normal persistent intmap, a new transient intmap is created. This is an -O(1) operation. In all other respects the interface is like their +The in-place @code{intmap-add!} and @code{intmap-replace!} procedures +return transient intmaps. If one of these in-place procedures is called +on a normal persistent intmap, a new transient intmap is created. This +is an O(1) operation. In all other respects the interface is like their persistent counterparts, @code{intmap-add} and @code{intmap-replace}. - If an in-place procedure is called on a transient intmap, the intmap is -mutated in-place and the same value is returned. If a persistent -operation like @code{intmap-add} is called on a transient intmap, the -transient's mutable substructure is then marked as persistent, and -@code{intmap-add} then runs on a new persistent intmap sharing structure -but not state with the original transient. Mutating a transient will -cause enough copying to ensure that it can make its change, but if part -of its substructure is already ``owned'' by it, no more copying is -needed. +mutated in-place and the same value is returned. + +If a persistent operation like @code{intmap-add} is called on a +transient intmap, the transient's mutable substructure is then marked as +persistent, and @code{intmap-add} then runs on a new persistent intmap +sharing structure but not state with the original transient. Mutating a +transient will cause enough copying to ensure that it can make its +change, but if part of its substructure is already ``owned'' by it, no +more copying is needed. We can use transients to make @code{intmap-increment} more efficient. The two changed elements have been marked @strong{like this}. @@ -1098,6 +1102,10 @@ call @code{persistent-intmap} on the incoming map, to ensure that if it were already transient, that the mutations in the body of @code{intmap-increment} wouldn't affect the incoming value. +In summary, programs in CPS are intmaps whose values are continuations. +See the source code of @code{(language cps utils)} for a number of +useful facilities for working with CPS values. + @node Compiling CPS @subsubsection Compiling CPS @@ -1114,16 +1122,18 @@ variables (in Tree-IL, locals that are @code{}) are converted to being boxed values on the heap. @xref{Variables and the VM}. -After CPS conversion, Guile runs some optimization passes. The major -optimization performed on CPS is contification, in which functions that -are always called with the same continuation are incorporated directly -into a function's body. This opens up space for more optimizations, and -turns procedure calls into @code{goto}. It can also make loops out of -recursive function nests. +After CPS conversion, Guile runs some optimization passes over the CPS. +Most optimization in Guile is done on the CPS language. The one major +exception is partial evaluation, which for historic reasons is done on +Tree-IL. -At the time of this writing (2014), most high-level optimization in -Guile is done on Tree-IL. We would like to rewrite many of these passes -to operate on CPS instead, as it is easier to reason about CPS. +The major optimization performed on CPS is contification, in which +functions that are always called with the same continuation are +incorporated directly into a function's body. This opens up space for +more optimizations, and turns procedure calls into @code{goto}. It can +also make loops out of recursive function nests. Guile also does dead +code elimination, common subexpression elimination, loop peeling and +invariant code motion, and range and type inference. The rest of the optimization passes are really cleanups and canonicalizations. CPS spans the gap between high-level languages and From 315adb6347c3e51f4e24fa32ff08458f2aa1b09c Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 6 Oct 2015 10:09:12 -0400 Subject: [PATCH 050/865] Fix typo in CPS conversion. Fixes . Reported by tantalum . * module/language/tree-il/compile-cps.scm (convert): Add missing 'cps' argument to the continuation passed to 'convert-arg'. --- module/language/tree-il/compile-cps.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 59d2d7d90..7f34e6b48 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -460,7 +460,7 @@ (($ src mod name public? exp) (convert-arg cps exp - (lambda (val) + (lambda (cps val) (module-box cps src mod name public? #t (lambda (cps box) From a0a8741608a4094cbd0f4d25d6bfdec1ff9e48eb Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 18 Sep 2015 10:43:06 +0200 Subject: [PATCH 051/865] Minor VM documentation updates * doc/ref/vm.texi (Why a VM?, Variables and the VM): Minor updates. --- doc/ref/vm.texi | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 6616af446..ba31d7ccb 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -80,11 +80,12 @@ but it is not normally used at runtime.) The upside of implementing the interpreter in Scheme is that we preserve tail calls and multiple-value handling between interpreted and compiled -code. The downside is that the interpreter in Guile 2.2 is still slower -than the interpreter in 1.8. We hope the that the compiler's speed makes -up for the loss. In any case, once we have native compilation for -Scheme code, we expect the new self-hosted interpreter to beat the old -hand-tuned C implementation. +code. The downside is that the interpreter in Guile 2.2 is still about +twice as slow as the interpreter in 1.8. Since Scheme users are mostly +running compiled code, the compiler's speed more than makes up for the +loss. In any case, once we have native compilation for Scheme code, we +expect the self-hosted interpreter to handily beat the old hand-tuned C +implementation. Also note that this decision to implement a bytecode compiler does not preclude native compilation. We can compile from bytecode to native @@ -213,8 +214,9 @@ variables are allocated in ``boxes''---actually, in variable cells. variables are indirected through the boxes. Thus perhaps counterintuitively, what would seem ``closer to the -metal'', viz @code{set!}, actually forces an extra memory allocation -and indirection. +metal'', viz @code{set!}, actually forces an extra memory allocation and +indirection. Sometimes Guile's optimizer can remove this allocation, +but not always. Going back to our example, @code{b} may be allocated on the stack, as it is never mutated. From d7199da8c9d287b9602e053d470d0a822b4f7cec Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 18 Oct 2015 13:24:21 +0200 Subject: [PATCH 052/865] Fix prompt miscompilation * module/language/cps/compile-bytecode.scm (compile-function): Fix miscompilation when the handler body is forwarded. --- module/language/cps/compile-bytecode.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 265189b17..498bac9b3 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -224,7 +224,7 @@ ((src . dst) (emit-mov asm dst src))) (lookup-parallel-moves handler allocation)) (emit-reset-frame asm frame-size) - (emit-br asm khandler-body))))) + (emit-br asm (forward-label khandler-body)))))) (($ $primcall 'cache-current-module! (sym scope)) (emit-cache-current-module! asm (slot sym) (constant scope))) (($ $primcall 'free-set! (closure idx value)) From 0007507340b10754cb307763cbc8eeb064853926 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 22 Sep 2015 10:24:30 +0000 Subject: [PATCH 053/865] VM stack grows downward Adapt VM stack to grow downward. This will make native compilation look more like the VM code, as we will be able to use native CALL instructions, taking proper advantage of the return address buffer. * libguile/continuations.c (scm_i_continuation_to_frame): Record offsets from stack top. * libguile/control.c (scm_i_prompt_pop_abort_args_x): Adapt for reversed order of arguments, and instead of relying on the abort to push on the number of arguments, make the caller save the stack depth, which allows us to compute the number of arguments ourselves. (reify_partial_continuation, scm_c_abort): Adapt to reversed stack order. * libguile/dynstack.c (scm_dynstack_wind_prompt): Since we wind the stack in a downward direction, subtract the reloc instead of adding it. * libguile/dynstack.h (SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY): Remove flag; instead rely on prompt-establishing code to save the stack depth. * libguile/eval.c (eval): Remove extraneous "volatile" declarations for variables that are not re-set between the setjmp and any longjmp. Adapt to save stack depth before instating the prompt. * libguile/foreign.c (scm_i_foreign_call): Adapt to receive arguments in reverse order. * libguile/frames.c (frame_stack_top, scm_i_frame_stack_top): Adapt to compute stack top instead of stack bottom. (scm_c_frame_closure): Adapt to stack growth change. (scm_frame_num_locals, scm_frame_local_ref, scm_frame_set_x): Use union data type to access stack. (RELOC): Reformat. (scm_c_frame_previous): Adapt to stack growth change. * libguile/frames.h: Adapt stack diagram to indicate that the stack grows up. (union scm_vm_stack_element): New data type used to access items on the stack. (SCM_FRAME_PREVIOUS_SP) (SCM_FRAME_RETURN_ADDRESS, SCM_FRAME_SET_RETURN_ADDRESS) (SCM_FRAME_DYNAMIC_LINK, SCM_FRAME_SET_DYNAMIC_LINK) (SCM_FRAME_LOCAL, SCM_FRAME_NUM_LOCALS): Adapt to stack representation change. (SCM_FRAME_SLOT): New helper. (SCM_VM_FRAME_FP, SCM_VM_FRAME_SP): Adapt to stack growth change. * libguile/stacks.c (scm_make_stack): Record offsets from top of stack. * libguile/throw.c (catch): Adapt to scm_i_prompt_pop_abort_args_x change. * libguile/vm-engine.c (ALLOC_FRAME, RESET_FRAME): (FRAME_LOCALS_COUNT_FROM): Adapt to stack growth change. (LOCAL_ADDRESS): Use SCM_FRAME_SLOT to get the address as the proper data type. (RETURN_ONE_VALUE, RETURN_VALUE_LIST): Adapt to stack growth change. (apply): Shuffling up the SMOB apply args can cause the stack to expand, so use ALLOC_FRAME instead of RESET_FRAME. (vm_engine): Adapt for stack growth change. * libguile/vm.c (vm_increase_sp, vm_push_sp, vm_restore_sp): Adapt to stack representation change. (scm_i_vm_cont_to_frame): Adapt to take offsets from the top. (scm_i_vm_capture_stack): Adapt to capture from the top. (vm_return_to_continuation_inner): Adapt for data type changes. (vm_return_to_continuation): Likewise, and instead of looping, just splat the saved arguments on with memcpy. (vm_dispatch_hook): Adapt to receive arguments in the reverse order. Adapt callers. (vm_abort): There is never a tail argument. Adapt to stack representation change. (vm_reinstate_partial_continuation) (vm_reinstate_partial_continuation_inner): Adapt to stack growth change. (allocate_stack, free_stack): Adapt to data type change. (expand_stack): Don't try to mremap(), as you can't grow a mapping from the bottom. Without knowing that there's a free mapping space right below the old stack, which there usually isn't on Linux, we have to copy. We can't use MAP_GROWSDOWN because Linux is buggy. (make_vm): Adapt to stack representation changes. (return_unused_stack_to_os): Round down instead of up, as the stack grows down. (scm_i_vm_mark_stack): Adapt to walk up the stack. (scm_i_vm_free_stack): Adapt to scm_vm changes. (vm_expand_stack_inner, reset_stack_limit, vm_expand_stack): Adapt to the stack growing down. (scm_call_n): Adapt to the stack growing down. Don't allow argv to point into the stack. * libguile/vm.h (struct scm_vm, struct scm_vm_cont): Adapt to hold the stack top and bottom. --- libguile/continuations.c | 7 +- libguile/control.c | 63 +++---- libguile/control.h | 3 +- libguile/dynstack.c | 4 +- libguile/dynstack.h | 3 +- libguile/eval.c | 18 +- libguile/foreign.c | 4 +- libguile/foreign.h | 5 +- libguile/frames.c | 62 +++--- libguile/frames.h | 76 ++++---- libguile/stacks.c | 7 +- libguile/throw.c | 9 +- libguile/vm-engine.c | 112 ++++++----- libguile/vm.c | 394 +++++++++++++++++++-------------------- libguile/vm.h | 25 ++- 15 files changed, 400 insertions(+), 392 deletions(-) diff --git a/libguile/continuations.c b/libguile/continuations.c index 8dca62e2d..7cc3cea10 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -180,10 +180,13 @@ scm_i_continuation_to_frame (SCM continuation, struct scm_frame *frame) if (scm_is_true (cont->vm_cont)) { struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont->vm_cont); + union scm_vm_stack_element *stack_top; + /* FIXME vm_cont should hold fp/sp offsets */ + stack_top = data->stack_bottom + data->stack_size; frame->stack_holder = data; - frame->fp_offset = (data->fp + data->reloc) - data->stack_base; - frame->sp_offset = (data->sp + data->reloc) - data->stack_base; + frame->fp_offset = stack_top - (data->fp + data->reloc); + frame->sp_offset = stack_top - (data->sp + data->reloc); frame->ip = data->ra; return 1; diff --git a/libguile/control.c b/libguile/control.c index 347d69715..a3457342b 100644 --- a/libguile/control.c +++ b/libguile/control.c @@ -39,19 +39,22 @@ /* Only to be called if the SCM_I_SETJMP returns 1 */ SCM -scm_i_prompt_pop_abort_args_x (struct scm_vm *vp) +scm_i_prompt_pop_abort_args_x (struct scm_vm *vp, + scm_t_ptrdiff saved_stack_depth) { size_t i, n; + scm_t_ptrdiff stack_depth; SCM vals = SCM_EOL; - n = scm_to_size_t (vp->sp[0]); - for (i = 0; i < n; i++) - vals = scm_cons (vp->sp[-(i + 1)], vals); + stack_depth = vp->stack_top - vp->sp; + if (stack_depth < saved_stack_depth) + abort (); + n = stack_depth - saved_stack_depth; - /* The abort did reset the VM's registers, but then these values - were pushed on; so we need to pop them ourselves. */ - vp->sp -= n + 1; - /* FIXME NULLSTACK */ + for (i = 0; i < n; i++) + vals = scm_cons (vp->sp[i].scm, vals); + + vp->sp += n; return vals; } @@ -79,8 +82,8 @@ make_partial_continuation (SCM vm_cont) static SCM reify_partial_continuation (struct scm_vm *vp, - SCM *saved_fp, - SCM *saved_sp, + union scm_vm_stack_element *saved_fp, + union scm_vm_stack_element *saved_sp, scm_t_uint32 *saved_ip, scm_i_jmp_buf *saved_registers, scm_t_dynstack *dynstack, @@ -88,7 +91,7 @@ reify_partial_continuation (struct scm_vm *vp, { SCM vm_cont; scm_t_uint32 flags; - SCM *bottom_fp; + union scm_vm_stack_element *base_fp; flags = SCM_F_VM_CONT_PARTIAL; /* If we are aborting to a prompt that has the same registers as those @@ -98,24 +101,20 @@ reify_partial_continuation (struct scm_vm *vp, if (saved_registers && saved_registers == current_registers) flags |= SCM_F_VM_CONT_REWINDABLE; - /* Walk the stack down until we find the first frame after saved_fp. - We will save the stack down to that frame. It used to be that we - could determine the stack bottom in O(1) time, but that's no longer + /* Walk the stack until we find the first frame newer than saved_fp. + We will save the stack until that frame. It used to be that we + could determine the stack base in O(1) time, but that's no longer the case, since the thunk application doesn't occur where the prompt is saved. */ - for (bottom_fp = vp->fp; - SCM_FRAME_DYNAMIC_LINK (bottom_fp) > saved_fp; - bottom_fp = SCM_FRAME_DYNAMIC_LINK (bottom_fp)); + for (base_fp = vp->fp; + SCM_FRAME_DYNAMIC_LINK (base_fp) < saved_fp; + base_fp = SCM_FRAME_DYNAMIC_LINK (base_fp)); - if (SCM_FRAME_DYNAMIC_LINK (bottom_fp) != saved_fp) + if (SCM_FRAME_DYNAMIC_LINK (base_fp) != saved_fp) abort(); - /* Capture from the top of the thunk application frame up to the end. */ - vm_cont = scm_i_vm_capture_stack (&SCM_FRAME_LOCAL (bottom_fp, 0), - vp->fp, - vp->sp, - vp->ip, - dynstack, + /* Capture from the base_fp to the top thunk application frame. */ + vm_cont = scm_i_vm_capture_stack (base_fp, vp->fp, vp->sp, vp->ip, dynstack, flags); return make_partial_continuation (vm_cont); @@ -130,7 +129,7 @@ scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv, scm_t_bits *prompt; scm_t_dynstack_prompt_flags flags; scm_t_ptrdiff fp_offset, sp_offset; - SCM *fp, *sp; + union scm_vm_stack_element *fp, *sp; scm_t_uint32 *ip; scm_i_jmp_buf *registers; size_t i; @@ -142,8 +141,8 @@ scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv, if (!prompt) scm_misc_error ("abort", "Abort to unknown prompt", scm_list_1 (tag)); - fp = vp->stack_base + fp_offset; - sp = vp->stack_base + sp_offset; + fp = vp->stack_top - fp_offset; + sp = vp->stack_top - sp_offset; /* Only reify if the continuation referenced in the handler. */ if (flags & SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY) @@ -162,19 +161,17 @@ scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv, /* Restore VM regs */ vp->fp = fp; - vp->sp = sp; + vp->sp = sp - n - 1; vp->ip = ip; /* Since we're jumping down, we should always have enough space. */ - if (vp->sp + n + 1 >= vp->stack_limit) + if (vp->sp < vp->stack_limit) abort (); /* Push vals */ - *(++(vp->sp)) = cont; + vp->sp[n].scm = cont; for (i = 0; i < n; i++) - *(++(vp->sp)) = argv[i]; - if (flags & SCM_F_DYNSTACK_PROMPT_PUSH_NARGS) - *(++(vp->sp)) = scm_from_size_t (n+1); /* +1 for continuation */ + vp->sp[n - i - 1].scm = argv[i]; /* Jump! */ SCM_I_LONGJMP (*registers, 1); diff --git a/libguile/control.h b/libguile/control.h index 4b76591aa..84990ab10 100644 --- a/libguile/control.h +++ b/libguile/control.h @@ -22,7 +22,8 @@ #include "libguile/vm.h" -SCM_INTERNAL SCM scm_i_prompt_pop_abort_args_x (struct scm_vm *vp); +SCM_INTERNAL SCM scm_i_prompt_pop_abort_args_x (struct scm_vm *vp, + scm_t_ptrdiff saved_stack_depth); SCM_INTERNAL void scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv, scm_i_jmp_buf *registers) SCM_NORETURN; diff --git a/libguile/dynstack.c b/libguile/dynstack.c index 9235ec495..bda1a16b5 100644 --- a/libguile/dynstack.c +++ b/libguile/dynstack.c @@ -484,8 +484,8 @@ scm_dynstack_wind_prompt (scm_t_dynstack *dynstack, scm_t_bits *item, scm_dynstack_push_prompt (dynstack, SCM_DYNSTACK_TAG_FLAGS (tag), PROMPT_KEY (item), - PROMPT_FP (item) + reloc, - PROMPT_SP (item) + reloc, + PROMPT_FP (item) - reloc, + PROMPT_SP (item) - reloc, PROMPT_IP (item), registers); } diff --git a/libguile/dynstack.h b/libguile/dynstack.h index 7b31acedf..853f0684d 100644 --- a/libguile/dynstack.h +++ b/libguile/dynstack.h @@ -129,8 +129,7 @@ typedef enum { } scm_t_dynstack_winder_flags; typedef enum { - SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY = (1 << SCM_DYNSTACK_TAG_FLAGS_SHIFT), - SCM_F_DYNSTACK_PROMPT_PUSH_NARGS = (2 << SCM_DYNSTACK_TAG_FLAGS_SHIFT) + SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY = (1 << SCM_DYNSTACK_TAG_FLAGS_SHIFT) } scm_t_dynstack_prompt_flags; typedef void (*scm_t_guard) (void *); diff --git a/libguile/eval.c b/libguile/eval.c index 735e6c0b3..09fa71df4 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -424,23 +424,22 @@ eval (SCM x, SCM env) case SCM_M_CALL_WITH_PROMPT: { struct scm_vm *vp; - SCM k, res; + SCM k, handler, res; scm_i_jmp_buf registers; - /* We need the handler after nonlocal return to the setjmp, so - make sure it is volatile. */ - volatile SCM handler; + scm_t_ptrdiff saved_stack_depth; k = EVAL1 (CAR (mx), env); handler = EVAL1 (CDDR (mx), env); vp = scm_the_vm (); + saved_stack_depth = vp->stack_top - vp->sp; + /* Push the prompt onto the dynamic stack. */ scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack, - SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY - | SCM_F_DYNSTACK_PROMPT_PUSH_NARGS, + SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY, k, - vp->fp - vp->stack_base, - vp->sp - vp->stack_base, + vp->stack_top - vp->fp, + saved_stack_depth, vp->ip, ®isters); @@ -449,8 +448,7 @@ eval (SCM x, SCM env) /* The prompt exited nonlocally. */ scm_gc_after_nonlocal_exit (); proc = handler; - vp = scm_the_vm (); - args = scm_i_prompt_pop_abort_args_x (vp); + args = scm_i_prompt_pop_abort_args_x (vp, saved_stack_depth); goto apply_proc; } diff --git a/libguile/foreign.c b/libguile/foreign.c index 0cab6b8b0..3ac06591d 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -977,7 +977,7 @@ pack (const ffi_type * type, const void *loc, int return_value_p) SCM -scm_i_foreign_call (SCM foreign, const SCM *argv) +scm_i_foreign_call (SCM foreign, const union scm_vm_stack_element *argv) { /* FOREIGN is the pair that cif_to_procedure set as the 0th element of the objtable. */ @@ -1016,7 +1016,7 @@ scm_i_foreign_call (SCM foreign, const SCM *argv) args[i] = (void *) ROUND_UP ((scm_t_uintptr) data + off, cif->arg_types[i]->alignment); assert ((scm_t_uintptr) args[i] % cif->arg_types[i]->alignment == 0); - unpack (cif->arg_types[i], args[i], argv[i], 0); + unpack (cif->arg_types[i], args[i], argv[cif->nargs - i - 1].scm, 0); } /* Prepare space for the return value. On some platforms, such as diff --git a/libguile/foreign.h b/libguile/foreign.h index fbb97640b..53f39d5c7 100644 --- a/libguile/foreign.h +++ b/libguile/foreign.h @@ -93,11 +93,14 @@ SCM_INTERNAL SCM scm_pointer_to_string (SCM pointer, SCM length, SCM encoding); arguments. */ +union scm_vm_stack_element; + SCM_API SCM scm_pointer_to_procedure (SCM return_type, SCM func_ptr, SCM arg_types); SCM_API SCM scm_procedure_to_pointer (SCM return_type, SCM func_ptr, SCM arg_types); -SCM_INTERNAL SCM scm_i_foreign_call (SCM foreign, const SCM *argv); +SCM_INTERNAL SCM scm_i_foreign_call (SCM foreign, + const union scm_vm_stack_element *argv); SCM_INTERNAL int scm_i_foreign_arity (SCM foreign, int *req, int *opt, int *rest); diff --git a/libguile/frames.c b/libguile/frames.c index 2162f49ce..f89b0fd5b 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014, 2015 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 License @@ -25,14 +25,6 @@ #include "_scm.h" #include "frames.h" #include "vm.h" -#include - -/* Make sure assumptions on the layout of `struct scm_vm_frame' hold. */ -verify (sizeof (SCM) == sizeof (SCM *)); -verify (sizeof (struct scm_vm_frame) == 3 * sizeof (SCM)); -verify (offsetof (struct scm_vm_frame, dynamic_link) == 0); - - SCM scm_c_make_frame (enum scm_vm_frame_kind kind, const struct scm_frame *frame) @@ -57,16 +49,19 @@ scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate) scm_puts_unlocked (">", port); } -static SCM* -frame_stack_base (enum scm_vm_frame_kind kind, const struct scm_frame *frame) +static union scm_vm_stack_element* +frame_stack_top (enum scm_vm_frame_kind kind, const struct scm_frame *frame) { switch (kind) { - case SCM_VM_FRAME_KIND_CONT: - return ((struct scm_vm_cont *) frame->stack_holder)->stack_base; + case SCM_VM_FRAME_KIND_CONT: + { + struct scm_vm_cont *cont = frame->stack_holder; + return cont->stack_bottom + cont->stack_size; + } case SCM_VM_FRAME_KIND_VM: - return ((struct scm_vm *) frame->stack_holder)->stack_base; + return ((struct scm_vm *) frame->stack_holder)->stack_top; default: abort (); @@ -89,14 +84,14 @@ frame_offset (enum scm_vm_frame_kind kind, const struct scm_frame *frame) } } -SCM* -scm_i_frame_stack_base (SCM frame) -#define FUNC_NAME "frame-stack-base" +union scm_vm_stack_element* +scm_i_frame_stack_top (SCM frame) +#define FUNC_NAME "frame-stack-top" { SCM_VALIDATE_VM_FRAME (1, frame); - return frame_stack_base (SCM_VM_FRAME_KIND (frame), - SCM_VM_FRAME_DATA (frame)); + return frame_stack_top (SCM_VM_FRAME_KIND (frame), + SCM_VM_FRAME_DATA (frame)); } #undef FUNC_NAME @@ -130,10 +125,10 @@ SCM_DEFINE (scm_frame_p, "frame?", 1, 0, 0, SCM scm_c_frame_closure (enum scm_vm_frame_kind kind, const struct scm_frame *frame) { - SCM *fp, *sp; + union scm_vm_stack_element *fp, *sp; - fp = frame_stack_base (kind, frame) + frame->fp_offset; - sp = frame_stack_base (kind, frame) + frame->sp_offset; + fp = frame_stack_top (kind, frame) - frame->fp_offset; + sp = frame_stack_top (kind, frame) - frame->sp_offset; if (SCM_FRAME_NUM_LOCALS (fp, sp) > 0) return SCM_FRAME_LOCAL (fp, 0); @@ -214,7 +209,7 @@ SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0, "") #define FUNC_NAME s_scm_frame_num_locals { - SCM *fp, *sp; + union scm_vm_stack_element *fp, *sp; SCM_VALIDATE_VM_FRAME (1, frame); @@ -230,7 +225,7 @@ SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0, "") #define FUNC_NAME s_scm_frame_local_ref { - SCM *fp, *sp; + union scm_vm_stack_element *fp, *sp; unsigned int i; SCM_VALIDATE_VM_FRAME (1, frame); @@ -252,7 +247,7 @@ SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0, "") #define FUNC_NAME s_scm_frame_local_set_x { - SCM *fp, *sp; + union scm_vm_stack_element *fp, *sp; unsigned int i; SCM_VALIDATE_VM_FRAME (1, frame); @@ -314,8 +309,7 @@ SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0, } #undef FUNC_NAME -#define RELOC(kind, frame, val) \ - (((SCM *) (val)) + frame_offset (kind, frame)) +#define RELOC(kind, frame, val) ((val) + frame_offset (kind, frame)) SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0, (SCM frame), @@ -334,13 +328,13 @@ SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0, int scm_c_frame_previous (enum scm_vm_frame_kind kind, struct scm_frame *frame) { - SCM *this_fp, *new_fp, *new_sp; - SCM *stack_base = frame_stack_base (kind, frame); + union scm_vm_stack_element *this_fp, *new_fp, *new_sp; + union scm_vm_stack_element *stack_top = frame_stack_top (kind, frame); again: - this_fp = frame->fp_offset + stack_base; + this_fp = stack_top - frame->fp_offset; - if (this_fp == stack_base) + if (this_fp == stack_top) return 0; new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp); @@ -350,12 +344,12 @@ scm_c_frame_previous (enum scm_vm_frame_kind kind, struct scm_frame *frame) new_fp = RELOC (kind, frame, new_fp); - if (new_fp < stack_base) + if (new_fp > stack_top) return 0; new_sp = SCM_FRAME_PREVIOUS_SP (this_fp); - frame->fp_offset = new_fp - stack_base; - frame->sp_offset = new_sp - stack_base; + frame->fp_offset = stack_top - new_fp; + frame->sp_offset = stack_top - new_sp; frame->ip = SCM_FRAME_RETURN_ADDRESS (this_fp); { diff --git a/libguile/frames.h b/libguile/frames.h index 31f86345f..c2f1e57db 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014, 2015 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 License @@ -38,24 +38,29 @@ Stack frame layout ------------------ - /------------------\ - | Local N-1 | <- sp | ... | - | Local 1 | - | Local 0 | <- fp = SCM_FRAME_LOCALS_ADDRESS (fp) - +==================+ + +==================+ <- fp + 2 = SCM_FRAME_PREVIOUS_SP (fp) + | Dynamic link | + +------------------+ | Return address | - | Dynamic link | <- fp - 2 = SCM_FRAME_LOWER_ADDRESS (fp) - +==================+ - | | <- fp - 3 = SCM_FRAME_PREVIOUS_SP (fp) + +==================+ <- fp + | Local 0 | + +------------------+ + | Local 1 | + +------------------+ + | ... | + +------------------+ + | Local N-1 | + \------------------/ <- sp + + The stack grows down. The calling convention is that a caller prepares a stack frame consisting of the saved FP and the return address, followed by the procedure and then the arguments to the call, in order. Thus in the beginning of a call, the procedure being called is in slot 0, the first argument is in slot 1, and the SP points to the last argument. - The number of arguments, including the procedure, is thus SP - FP + - 1. + The number of arguments, including the procedure, is thus FP - SP. After ensuring that the correct number of arguments have been passed, a function will set the stack pointer to point to the last local @@ -80,35 +85,26 @@ -/* This structure maps to the contents of a VM stack frame. It can - alias a frame directly. */ -struct scm_vm_frame +/* Each element on the stack occupies the same amount of space. */ +union scm_vm_stack_element { - SCM *dynamic_link; - scm_t_uint32 *return_address; - SCM locals[1]; /* Variable-length */ + union scm_vm_stack_element *fp; + scm_t_uint32 *ip; + SCM scm; + + /* For GC purposes. */ + void *ptr; + scm_t_bits bits; }; -#define SCM_FRAME_LOWER_ADDRESS(fp) (((SCM *) (fp)) - 2) -#define SCM_FRAME_STRUCT(fp) \ - ((struct scm_vm_frame *) SCM_FRAME_LOWER_ADDRESS (fp)) -#define SCM_FRAME_LOCALS_ADDRESS(fp) (SCM_FRAME_STRUCT (fp)->locals) - -#define SCM_FRAME_PREVIOUS_SP(fp) (((SCM *) (fp)) - 3) - -#define SCM_FRAME_RETURN_ADDRESS(fp) \ - (SCM_FRAME_STRUCT (fp)->return_address) -#define SCM_FRAME_SET_RETURN_ADDRESS(fp, ra) \ - SCM_FRAME_STRUCT (fp)->return_address = (ra) -#define SCM_FRAME_DYNAMIC_LINK(fp) \ - (SCM_FRAME_STRUCT (fp)->dynamic_link) -#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \ - SCM_FRAME_DYNAMIC_LINK (fp) = (dl) -#define SCM_FRAME_LOCAL(fp,i) \ - (SCM_FRAME_STRUCT (fp)->locals[i]) - -#define SCM_FRAME_NUM_LOCALS(fp, sp) \ - ((sp) + 1 - &SCM_FRAME_LOCAL (fp, 0)) +#define SCM_FRAME_PREVIOUS_SP(fp_) ((fp_) + 2) +#define SCM_FRAME_RETURN_ADDRESS(fp_) ((fp_)[0].ip) +#define SCM_FRAME_SET_RETURN_ADDRESS(fp_, ra) ((fp_)[0].ip = (ra)) +#define SCM_FRAME_DYNAMIC_LINK(fp_) ((fp_)[1].fp) +#define SCM_FRAME_SET_DYNAMIC_LINK(fp_, dl) ((fp_)[1].fp = (dl)) +#define SCM_FRAME_SLOT(fp_,i) ((fp_) - (i) - 1) +#define SCM_FRAME_LOCAL(fp_,i) (SCM_FRAME_SLOT (fp_, i)->scm) +#define SCM_FRAME_NUM_LOCALS(fp_, sp) ((fp_) - (sp)) /* @@ -137,13 +133,13 @@ enum scm_vm_frame_kind #define SCM_VM_FRAME_STACK_HOLDER(f) SCM_VM_FRAME_DATA (f)->stack_holder #define SCM_VM_FRAME_FP_OFFSET(f) SCM_VM_FRAME_DATA (f)->fp_offset #define SCM_VM_FRAME_SP_OFFSET(f) SCM_VM_FRAME_DATA (f)->sp_offset -#define SCM_VM_FRAME_FP(f) (SCM_VM_FRAME_FP_OFFSET (f) + scm_i_frame_stack_base (f)) -#define SCM_VM_FRAME_SP(f) (SCM_VM_FRAME_SP_OFFSET (f) + scm_i_frame_stack_base (f)) +#define SCM_VM_FRAME_FP(f) (scm_i_frame_stack_top (f) - SCM_VM_FRAME_FP_OFFSET (f)) +#define SCM_VM_FRAME_SP(f) (scm_i_frame_stack_top (f) - SCM_VM_FRAME_SP_OFFSET (f)) #define SCM_VM_FRAME_IP(f) SCM_VM_FRAME_DATA (f)->ip #define SCM_VM_FRAME_OFFSET(f) scm_i_frame_offset (f) #define SCM_VALIDATE_VM_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_FRAME_P) -SCM_INTERNAL SCM* scm_i_frame_stack_base (SCM frame); +SCM_INTERNAL union scm_vm_stack_element* scm_i_frame_stack_top (SCM frame); SCM_INTERNAL scm_t_ptrdiff scm_i_frame_offset (SCM frame); /* See notes in frames.c before using this. */ diff --git a/libguile/stacks.c b/libguile/stacks.c index a09c3b9a3..ec3ec789f 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -320,14 +320,17 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, { SCM cont; struct scm_vm_cont *c; + union scm_vm_stack_element *stack_top; cont = scm_i_capture_current_stack (); c = SCM_VM_CONT_DATA (cont); + /* FIXME vm_cont should hold fp/sp offsets */ + stack_top = c->stack_bottom + c->stack_size; kind = SCM_VM_FRAME_KIND_CONT; frame.stack_holder = c; - frame.fp_offset = (c->fp + c->reloc) - c->stack_base; - frame.sp_offset = (c->sp + c->reloc) - c->stack_base; + frame.fp_offset = stack_top - (c->fp + c->reloc); + frame.sp_offset = stack_top - (c->sp + c->reloc); frame.ip = c->ra; } else if (SCM_VM_FRAME_P (obj)) diff --git a/libguile/throw.c b/libguile/throw.c index bbde5e009..773ac2783 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -102,14 +102,13 @@ catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler) scm_c_vector_set_x (eh, 3, pre_unwind_handler); vp = scm_the_vm (); - saved_stack_depth = vp->sp - vp->stack_base; + saved_stack_depth = vp->stack_top - vp->sp; /* Push the prompt and exception handler onto the dynamic stack. */ scm_dynstack_push_prompt (dynstack, - SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY - | SCM_F_DYNSTACK_PROMPT_PUSH_NARGS, + SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY, prompt_tag, - vp->fp - vp->stack_base, + vp->stack_top - vp->fp, saved_stack_depth, vp->ip, ®isters); @@ -125,7 +124,7 @@ catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler) /* FIXME: We know where the args will be on the stack; we could avoid consing them. */ - args = scm_i_prompt_pop_abort_args_x (vp); + args = scm_i_prompt_pop_abort_args_x (vp, saved_stack_depth); /* Cdr past the continuation. */ args = scm_cdr (args); diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 7e752dd14..f6cb0c49c 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -134,10 +134,10 @@ /* Virtual Machine The VM has three state bits: the instruction pointer (IP), the frame - pointer (FP), and the top-of-stack pointer (SP). We cache the first - two of these in machine registers, local to the VM, because they are - used extensively by the VM. As the SP is used more by code outside - the VM than by the VM itself, we don't bother caching it locally. + pointer (FP), and the stack pointer (SP). We cache the first two of + these in machine registers, local to the VM, because they are used + extensively by the VM. As the SP is used more by code outside the VM + than by the VM itself, we don't bother caching it locally. Since the FP changes infrequently, relative to the IP, we keep vp->fp in sync with the local FP. This would be a big lose for the IP, @@ -172,17 +172,17 @@ FP is valid across an ALLOC_FRAME call. Be careful! */ #define ALLOC_FRAME(n) \ do { \ - SCM *new_sp = LOCAL_ADDRESS (n - 1); \ - if (new_sp > vp->sp_max_since_gc) \ + union scm_vm_stack_element *new_sp = LOCAL_ADDRESS (n - 1); \ + if (new_sp < vp->sp_min_since_gc) \ { \ - if (SCM_UNLIKELY (new_sp >= vp->stack_limit)) \ + if (SCM_UNLIKELY (new_sp < vp->stack_limit)) \ { \ SYNC_IP (); \ vm_expand_stack (vp, new_sp); \ CACHE_FP (); \ } \ else \ - vp->sp_max_since_gc = vp->sp = new_sp; \ + vp->sp_min_since_gc = vp->sp = new_sp; \ } \ else \ vp->sp = new_sp; \ @@ -193,15 +193,15 @@ #define RESET_FRAME(n) \ do { \ vp->sp = LOCAL_ADDRESS (n - 1); \ - if (vp->sp > vp->sp_max_since_gc) \ - vp->sp_max_since_gc = vp->sp; \ + if (vp->sp < vp->sp_min_since_gc) \ + vp->sp_min_since_gc = vp->sp; \ } while (0) /* Compute the number of locals in the frame. At a call, this is equal to the number of actual arguments when a function is first called, plus one for the function. */ #define FRAME_LOCALS_COUNT_FROM(slot) \ - (vp->sp + 1 - LOCAL_ADDRESS (slot)) + (LOCAL_ADDRESS (slot) + 1 - vp->sp) #define FRAME_LOCALS_COUNT() \ FRAME_LOCALS_COUNT_FROM (0) @@ -246,7 +246,7 @@ case opcode: #endif -#define LOCAL_ADDRESS(i) (&SCM_FRAME_LOCAL (fp, i)) +#define LOCAL_ADDRESS(i) SCM_FRAME_SLOT (fp, i) #define LOCAL_REF(i) SCM_FRAME_LOCAL (fp, i) #define LOCAL_SET(i,o) SCM_FRAME_LOCAL (fp, i) = o @@ -257,18 +257,18 @@ #define RETURN_ONE_VALUE(ret) \ do { \ SCM val = ret; \ - SCM *old_fp; \ + union scm_vm_stack_element *old_fp; \ VM_HANDLE_INTERRUPTS; \ ALLOC_FRAME (2); \ old_fp = fp; \ ip = SCM_FRAME_RETURN_ADDRESS (fp); \ fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); \ /* Clear frame. */ \ - old_fp[-1] = SCM_BOOL_F; \ - old_fp[-2] = SCM_BOOL_F; \ + old_fp[0].scm = SCM_BOOL_F; \ + old_fp[1].scm = SCM_BOOL_F; \ /* Leave proc. */ \ SCM_FRAME_LOCAL (old_fp, 1) = val; \ - vp->sp = &SCM_FRAME_LOCAL (old_fp, 1); \ + vp->sp = SCM_FRAME_SLOT (old_fp, 1); \ POP_CONTINUATION_HOOK (old_fp); \ NEXT (0); \ } while (0) @@ -279,10 +279,10 @@ do { \ SCM vals = vals_; \ VM_HANDLE_INTERRUPTS; \ - ALLOC_FRAME (3); \ - fp[0] = vm_builtin_apply; \ - fp[1] = vm_builtin_values; \ - fp[2] = vals; \ + ALLOC_FRAME (3); \ + SCM_FRAME_LOCAL (fp, 0) = vm_builtin_apply; \ + SCM_FRAME_LOCAL (fp, 1) = vm_builtin_values; \ + SCM_FRAME_LOCAL (fp, 2) = vals; \ ip = (scm_t_uint32 *) vm_builtin_apply_code; \ goto op_tail_apply; \ } while (0) @@ -429,7 +429,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, /* Frame pointer: A pointer into the stack, off of which we index arguments and local variables. Pushed at function calls, popped on returns. */ - register SCM *fp FP_REG; + register union scm_vm_stack_element *fp FP_REG; /* Current opcode: A cache of *ip. */ register scm_t_uint32 op; @@ -472,8 +472,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, { scm_t_uint32 n = FRAME_LOCALS_COUNT(); - /* Shuffle args up. */ - RESET_FRAME (n + 1); + /* Shuffle args up. (FIXME: no real need to shuffle; just set + IP and go. ) */ + ALLOC_FRAME (n + 1); while (n--) LOCAL_SET (n + 1, LOCAL_REF (n)); @@ -546,7 +547,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, VM_DEFINE_OP (1, call, "call", OP2 (U8_U24, X8_U24)) { scm_t_uint32 proc, nlocals; - SCM *old_fp; + union scm_vm_stack_element *old_fp; UNPACK_24 (op, proc); UNPACK_24 (ip[1], nlocals); @@ -556,7 +557,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, PUSH_CONTINUATION_HOOK (); old_fp = fp; - fp = vp->fp = old_fp + proc; + fp = vp->fp = SCM_FRAME_SLOT (old_fp, proc - 1); SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp); SCM_FRAME_SET_RETURN_ADDRESS (fp, ip + 2); @@ -586,7 +587,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, { scm_t_uint32 proc, nlocals; scm_t_int32 label; - SCM *old_fp; + union scm_vm_stack_element *old_fp; UNPACK_24 (op, proc); UNPACK_24 (ip[1], nlocals); @@ -597,7 +598,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, PUSH_CONTINUATION_HOOK (); old_fp = fp; - fp = vp->fp = old_fp + proc; + fp = vp->fp = SCM_FRAME_SLOT (old_fp, proc - 1); SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp); SCM_FRAME_SET_RETURN_ADDRESS (fp, ip + 3); @@ -754,7 +755,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, */ VM_DEFINE_OP (9, return_values, "return-values", OP1 (U8_X24)) { - SCM *old_fp; + union scm_vm_stack_element *old_fp; VM_HANDLE_INTERRUPTS; @@ -763,8 +764,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); /* Clear stack frame. */ - old_fp[-1] = SCM_BOOL_F; - old_fp[-2] = SCM_BOOL_F; + old_fp[0].scm = SCM_BOOL_F; + old_fp[1].scm = SCM_BOOL_F; POP_CONTINUATION_HOOK (old_fp); @@ -804,34 +805,46 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, ret = subr (); break; case 1: - ret = subr (fp[1]); + ret = subr (LOCAL_REF (1)); break; case 2: - ret = subr (fp[1], fp[2]); + ret = subr (LOCAL_REF (1), LOCAL_REF (2)); break; case 3: - ret = subr (fp[1], fp[2], fp[3]); + ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3)); break; case 4: - ret = subr (fp[1], fp[2], fp[3], fp[4]); + ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3), + LOCAL_REF (4)); break; case 5: - ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5]); + ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3), + LOCAL_REF (4), LOCAL_REF (5)); break; case 6: - ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6]); + ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3), + LOCAL_REF (4), LOCAL_REF (5), LOCAL_REF (6)); break; case 7: - ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7]); + ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3), + LOCAL_REF (4), LOCAL_REF (5), LOCAL_REF (6), + LOCAL_REF (7)); break; case 8: - ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8]); + ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3), + LOCAL_REF (4), LOCAL_REF (5), LOCAL_REF (6), + LOCAL_REF (7), LOCAL_REF (8)); break; case 9: - ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8], fp[9]); + ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3), + LOCAL_REF (4), LOCAL_REF (5), LOCAL_REF (6), + LOCAL_REF (7), LOCAL_REF (8), LOCAL_REF (9)); break; case 10: - ret = subr (fp[1], fp[2], fp[3], fp[4], fp[5], fp[6], fp[7], fp[8], fp[9], fp[10]); + ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3), + LOCAL_REF (4), LOCAL_REF (5), LOCAL_REF (6), + LOCAL_REF (7), LOCAL_REF (8), LOCAL_REF (9), + LOCAL_REF (10)); break; default: abort (); @@ -869,7 +882,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, // FIXME: separate args ret = scm_i_foreign_call (scm_inline_cons (thread, cif, pointer), - LOCAL_ADDRESS (1)); + vp->sp); CACHE_FP (); @@ -903,7 +916,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, vm_return_to_continuation (scm_i_contregs_vp (contregs), scm_i_contregs_vm_cont (contregs), FRAME_LOCALS_COUNT_FROM (1), - LOCAL_ADDRESS (1)); + vp->sp); scm_i_reinstate_continuation (contregs); /* no NEXT */ @@ -912,7 +925,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, /* compose-continuation cont:24 * - * Compose a partial continution with the current continuation. The + * Compose a partial continuation with the current continuation. The * arguments to the continuation are taken from the stack. CONT is a * free variable containing the reified continuation. This * instruction is part of the implementation of partial continuations, @@ -930,9 +943,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont), vm_error_continuation_not_rewindable (vmcont)); vm_reinstate_partial_continuation (vp, vmcont, FRAME_LOCALS_COUNT_FROM (1), - LOCAL_ADDRESS (1), - &thread->dynstack, - registers); + &thread->dynstack, registers); CACHE_REGISTER (); NEXT (0); } @@ -999,7 +1010,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, SYNC_IP (); dynstack = scm_dynstack_capture_all (&thread->dynstack); - vm_cont = scm_i_vm_capture_stack (vp->stack_base, + vm_cont = scm_i_vm_capture_stack (vp->stack_top, SCM_FRAME_DYNAMIC_LINK (fp), SCM_FRAME_PREVIOUS_SP (fp), SCM_FRAME_RETURN_ADDRESS (fp), @@ -1051,8 +1062,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, it continues with the next instruction. */ ip++; SYNC_IP (); - vm_abort (vp, LOCAL_REF (1), nlocals - 2, LOCAL_ADDRESS (2), - SCM_EOL, LOCAL_ADDRESS (0), registers); + vm_abort (vp, LOCAL_REF (1), nlocals - 2, registers); /* vm_abort should not return */ abort (); @@ -2065,8 +2075,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0; scm_dynstack_push_prompt (&thread->dynstack, flags, LOCAL_REF (tag), - fp - vp->stack_base, - LOCAL_ADDRESS (proc_slot) - vp->stack_base, + vp->stack_top - fp, + vp->stack_top - LOCAL_ADDRESS (proc_slot), ip + offset, registers); NEXT (3); diff --git a/libguile/vm.c b/libguile/vm.c index 0e5983575..d5a72727f 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -16,9 +16,6 @@ * 02110-1301 USA */ -/* For mremap(2) on GNU/Linux systems. */ -#define _GNU_SOURCE - #if HAVE_CONFIG_H # include #endif @@ -65,7 +62,8 @@ static size_t page_size; necessary, but might be if you think you found a bug in the VM. */ /* #define VM_ENABLE_ASSERTIONS */ -static void vm_expand_stack (struct scm_vm *vp, SCM *new_sp) SCM_NOINLINE; +static void vm_expand_stack (struct scm_vm *vp, + union scm_vm_stack_element *new_sp) SCM_NOINLINE; /* RESTORE is for the case where we know we have done a PUSH of equal or greater stack size in the past. Otherwise PUSH is the thing, which @@ -73,28 +71,29 @@ static void vm_expand_stack (struct scm_vm *vp, SCM *new_sp) SCM_NOINLINE; enum vm_increase_sp_kind { VM_SP_PUSH, VM_SP_RESTORE }; static inline void -vm_increase_sp (struct scm_vm *vp, SCM *new_sp, enum vm_increase_sp_kind kind) +vm_increase_sp (struct scm_vm *vp, union scm_vm_stack_element *new_sp, + enum vm_increase_sp_kind kind) { - if (new_sp <= vp->sp_max_since_gc) + if (new_sp >= vp->sp_min_since_gc) { vp->sp = new_sp; return; } - if (kind == VM_SP_PUSH && new_sp >= vp->stack_limit) + if (kind == VM_SP_PUSH && new_sp < vp->stack_limit) vm_expand_stack (vp, new_sp); else - vp->sp_max_since_gc = vp->sp = new_sp; + vp->sp_min_since_gc = vp->sp = new_sp; } static inline void -vm_push_sp (struct scm_vm *vp, SCM *new_sp) +vm_push_sp (struct scm_vm *vp, union scm_vm_stack_element *new_sp) { vm_increase_sp (vp, new_sp, VM_SP_PUSH); } static inline void -vm_restore_sp (struct scm_vm *vp, SCM *new_sp) +vm_restore_sp (struct scm_vm *vp, union scm_vm_stack_element *new_sp) { vm_increase_sp (vp, new_sp, VM_SP_RESTORE); } @@ -116,10 +115,12 @@ int scm_i_vm_cont_to_frame (SCM cont, struct scm_frame *frame) { struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont); + union scm_vm_stack_element *stack_top; + stack_top = data->stack_bottom + data->stack_size; frame->stack_holder = data; - frame->fp_offset = (data->fp + data->reloc) - data->stack_base; - frame->sp_offset = (data->sp + data->reloc) - data->stack_base; + frame->fp_offset = stack_top - (data->fp + data->reloc); + frame->sp_offset = stack_top - (data->sp + data->reloc); frame->ip = data->ra; return 1; @@ -129,23 +130,25 @@ scm_i_vm_cont_to_frame (SCM cont, struct scm_frame *frame) is inside VM code, and call/cc was invoked within that same call to vm_run. That's currently not implemented. */ SCM -scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, scm_t_uint32 *ra, +scm_i_vm_capture_stack (union scm_vm_stack_element *stack_top, + union scm_vm_stack_element *fp, + union scm_vm_stack_element *sp, scm_t_uint32 *ra, scm_t_dynstack *dynstack, scm_t_uint32 flags) { struct scm_vm_cont *p; p = scm_gc_malloc (sizeof (*p), "capture_vm_cont"); - p->stack_size = sp - stack_base + 1; - p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM), - "capture_vm_cont"); + p->stack_size = stack_top - sp; + p->stack_bottom = scm_gc_malloc (p->stack_size * sizeof (*p->stack_bottom), + "capture_vm_cont"); p->ra = ra; p->sp = sp; p->fp = fp; - memcpy (p->stack_base, stack_base, (sp + 1 - stack_base) * sizeof (SCM)); - p->reloc = p->stack_base - stack_base; + memcpy (p->stack_bottom, sp, p->stack_size * sizeof (*p->stack_bottom)); + p->reloc = (p->stack_bottom + p->stack_size) - stack_top; p->dynstack = dynstack; p->flags = flags; - return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p); + return scm_cell (scm_tc7_vm_cont, (scm_t_bits) p); } struct return_to_continuation_data @@ -162,23 +165,27 @@ vm_return_to_continuation_inner (void *data_ptr) struct return_to_continuation_data *data = data_ptr; struct scm_vm *vp = data->vp; struct scm_vm_cont *cp = data->cp; + union scm_vm_stack_element *cp_stack_top; scm_t_ptrdiff reloc; /* We know that there is enough space for the continuation, because we captured it in the past. However there may have been an expansion since the capture, so we may have to re-link the frame pointers. */ - reloc = (vp->stack_base - (cp->stack_base - cp->reloc)); + cp_stack_top = cp->stack_bottom + cp->stack_size; + reloc = (vp->stack_top - (cp_stack_top - cp->reloc)); vp->fp = cp->fp + reloc; - memcpy (vp->stack_base, cp->stack_base, cp->stack_size * sizeof (SCM)); + memcpy (vp->stack_top - cp->stack_size, + cp->stack_bottom, + cp->stack_size * sizeof (*cp->stack_bottom)); vm_restore_sp (vp, cp->sp + reloc); if (reloc) { - SCM *fp = vp->fp; + union scm_vm_stack_element *fp = vp->fp; while (fp) { - SCM *next_fp = SCM_FRAME_DYNAMIC_LINK (fp); + union scm_vm_stack_element *next_fp = SCM_FRAME_DYNAMIC_LINK (fp); if (next_fp) { next_fp += reloc; @@ -192,14 +199,15 @@ vm_return_to_continuation_inner (void *data_ptr) } static void -vm_return_to_continuation (struct scm_vm *vp, SCM cont, size_t n, SCM *argv) +vm_return_to_continuation (struct scm_vm *vp, SCM cont, size_t n, + union scm_vm_stack_element *argv) { struct scm_vm_cont *cp; - SCM *argv_copy; + union scm_vm_stack_element *argv_copy; struct return_to_continuation_data data; - argv_copy = alloca (n * sizeof(SCM)); - memcpy (argv_copy, argv, n * sizeof(SCM)); + argv_copy = alloca (n * sizeof (*argv)); + memcpy (argv_copy, argv, n * sizeof (*argv)); cp = SCM_VM_CONT_DATA (cont); @@ -208,22 +216,13 @@ vm_return_to_continuation (struct scm_vm *vp, SCM cont, size_t n, SCM *argv) GC_call_with_alloc_lock (vm_return_to_continuation_inner, &data); /* Now we have the continuation properly copied over. We just need to - copy the arguments. It is not guaranteed that there is actually - space for the arguments, though, so we have to bump the SP first. */ - vm_push_sp (vp, vp->sp + 3 + n); - - /* Now copy on an empty frame and the return values, as the - continuation expects. */ - { - SCM *base = vp->sp + 1 - 3 - n; - size_t i; - - for (i = 0; i < 3; i++) - base[i] = SCM_BOOL_F; - - for (i = 0; i < n; i++) - base[i + 3] = argv_copy[i]; - } + copy on an empty frame and the return values, as the continuation + expects. */ + vm_push_sp (vp, vp->sp - 3 - n); + vp->sp[n+2].scm = SCM_BOOL_F; + vp->sp[n+1].scm = SCM_BOOL_F; + vp->sp[n].scm = SCM_BOOL_F; + memcpy(vp->sp, argv_copy, n * sizeof (union scm_vm_stack_element)); vp->ip = cp->ra; } @@ -238,19 +237,21 @@ scm_i_capture_current_stack (void) thread = SCM_I_CURRENT_THREAD; vp = thread_vm (thread); - return scm_i_vm_capture_stack (vp->stack_base, vp->fp, vp->sp, vp->ip, + return scm_i_vm_capture_stack (vp->stack_top, vp->fp, vp->sp, vp->ip, scm_dynstack_capture_all (&thread->dynstack), 0); } static void vm_dispatch_apply_hook (struct scm_vm *vp) SCM_NOINLINE; static void vm_dispatch_push_continuation_hook (struct scm_vm *vp) SCM_NOINLINE; -static void vm_dispatch_pop_continuation_hook (struct scm_vm *vp, SCM *old_fp) SCM_NOINLINE; +static void vm_dispatch_pop_continuation_hook + (struct scm_vm *vp, union scm_vm_stack_element *old_fp) SCM_NOINLINE; static void vm_dispatch_next_hook (struct scm_vm *vp) SCM_NOINLINE; static void vm_dispatch_abort_hook (struct scm_vm *vp) SCM_NOINLINE; static void -vm_dispatch_hook (struct scm_vm *vp, int hook_num, SCM *argv, int n) +vm_dispatch_hook (struct scm_vm *vp, int hook_num, + union scm_vm_stack_element *argv, int n) { SCM hook; struct scm_frame c_frame; @@ -275,8 +276,8 @@ vm_dispatch_hook (struct scm_vm *vp, int hook_num, SCM *argv, int n) seems reasonable to limit the lifetime of frame objects. */ c_frame.stack_holder = vp; - c_frame.fp_offset = vp->fp - vp->stack_base; - c_frame.sp_offset = vp->sp - vp->stack_base; + c_frame.fp_offset = vp->stack_top - vp->fp; + c_frame.sp_offset = vp->stack_top - vp->sp; c_frame.ip = vp->ip; /* Arrange for FRAME to be 8-byte aligned, like any other cell. */ @@ -298,15 +299,16 @@ vm_dispatch_hook (struct scm_vm *vp, int hook_num, SCM *argv, int n) SCM args[2]; args[0] = SCM_PACK_POINTER (frame); - args[1] = argv[0]; + args[1] = argv[0].scm; scm_c_run_hookn (hook, args, 2); } else { SCM args = SCM_EOL; + int i; - while (n--) - args = scm_cons (argv[n], args); + for (i = 0; i < n; i++) + args = scm_cons (argv[i].scm, args); scm_c_run_hook (hook, scm_cons (SCM_PACK_POINTER (frame), args)); } @@ -322,11 +324,11 @@ static void vm_dispatch_push_continuation_hook (struct scm_vm *vp) { return vm_dispatch_hook (vp, SCM_VM_PUSH_CONTINUATION_HOOK, NULL, 0); } -static void vm_dispatch_pop_continuation_hook (struct scm_vm *vp, SCM *old_fp) +static void vm_dispatch_pop_continuation_hook (struct scm_vm *vp, + union scm_vm_stack_element *old_fp) { return vm_dispatch_hook (vp, SCM_VM_POP_CONTINUATION_HOOK, - &SCM_FRAME_LOCAL (old_fp, 1), - SCM_FRAME_NUM_LOCALS (old_fp, vp->sp) - 1); + vp->sp, SCM_FRAME_NUM_LOCALS (old_fp, vp->sp) - 1); } static void vm_dispatch_next_hook (struct scm_vm *vp) { @@ -335,38 +337,27 @@ static void vm_dispatch_next_hook (struct scm_vm *vp) static void vm_dispatch_abort_hook (struct scm_vm *vp) { return vm_dispatch_hook (vp, SCM_VM_ABORT_CONTINUATION_HOOK, - &SCM_FRAME_LOCAL (vp->fp, 1), - SCM_FRAME_NUM_LOCALS (vp->fp, vp->sp) - 1); + vp->sp, SCM_FRAME_NUM_LOCALS (vp->fp, vp->sp) - 1); } static void -vm_abort (struct scm_vm *vp, SCM tag, - size_t nstack, SCM *stack_args, SCM tail, SCM *sp, +vm_abort (struct scm_vm *vp, SCM tag, size_t nargs, scm_i_jmp_buf *current_registers) SCM_NORETURN; static void -vm_abort (struct scm_vm *vp, SCM tag, - size_t nstack, SCM *stack_args, SCM tail, SCM *sp, +vm_abort (struct scm_vm *vp, SCM tag, size_t nargs, scm_i_jmp_buf *current_registers) { size_t i; - ssize_t tail_len; SCM *argv; - tail_len = scm_ilength (tail); - if (tail_len < 0) - scm_misc_error ("vm-engine", "tail values to abort should be a list", - scm_list_1 (tail)); + argv = alloca (nargs * sizeof (SCM)); + for (i = 0; i < nargs; i++) + argv[i] = vp->sp[nargs - i - 1].scm; - argv = alloca ((nstack + tail_len) * sizeof (SCM)); - for (i = 0; i < nstack; i++) - argv[i] = stack_args[i]; - for (; i < nstack + tail_len; i++, tail = scm_cdr (tail)) - argv[i] = scm_car (tail); + vp->sp = vp->fp; - vp->sp = sp; - - scm_c_abort (vp, tag, nstack + tail_len, argv, current_registers); + scm_c_abort (vp, tag, nargs, argv, current_registers); } struct vm_reinstate_partial_continuation_data @@ -382,23 +373,23 @@ vm_reinstate_partial_continuation_inner (void *data_ptr) struct vm_reinstate_partial_continuation_data *data = data_ptr; struct scm_vm *vp = data->vp; struct scm_vm_cont *cp = data->cp; - SCM *base; + union scm_vm_stack_element *base_fp; scm_t_ptrdiff reloc; - base = SCM_FRAME_LOCALS_ADDRESS (vp->fp); - reloc = cp->reloc + (base - cp->stack_base); + base_fp = vp->fp; + reloc = cp->reloc + (base_fp - (cp->stack_bottom + cp->stack_size)); - memcpy (base, cp->stack_base, cp->stack_size * sizeof (SCM)); + memcpy (base_fp - cp->stack_size, + cp->stack_bottom, + cp->stack_size * sizeof (*cp->stack_bottom)); vp->fp = cp->fp + reloc; vp->ip = cp->ra; /* now relocate frame pointers */ { - SCM *fp; - for (fp = vp->fp; - SCM_FRAME_LOWER_ADDRESS (fp) >= base; - fp = SCM_FRAME_DYNAMIC_LINK (fp)) + union scm_vm_stack_element *fp; + for (fp = vp->fp; fp < base_fp; fp = SCM_FRAME_DYNAMIC_LINK (fp)) SCM_FRAME_SET_DYNAMIC_LINK (fp, SCM_FRAME_DYNAMIC_LINK (fp) + reloc); } @@ -408,32 +399,32 @@ vm_reinstate_partial_continuation_inner (void *data_ptr) } static void -vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont, - size_t n, SCM *argv, +vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont, size_t nargs, scm_t_dynstack *dynstack, scm_i_jmp_buf *registers) { struct vm_reinstate_partial_continuation_data data; struct scm_vm_cont *cp; - SCM *argv_copy; + union scm_vm_stack_element *args; scm_t_ptrdiff reloc; - size_t i; - argv_copy = alloca (n * sizeof(SCM)); - memcpy (argv_copy, argv, n * sizeof(SCM)); + args = alloca (nargs * sizeof (*args)); + memcpy (args, vp->sp, nargs * sizeof (*args)); cp = SCM_VM_CONT_DATA (cont); - vm_push_sp (vp, SCM_FRAME_LOCALS_ADDRESS (vp->fp) + cp->stack_size + n - 1); + vm_push_sp (vp, vp->fp - (cp->stack_size + nargs + 1)); data.vp = vp; data.cp = cp; GC_call_with_alloc_lock (vm_reinstate_partial_continuation_inner, &data); reloc = data.reloc; - /* Push the arguments. */ - for (i = 0; i < n; i++) - vp->sp[i + 1 - n] = argv_copy[i]; + /* The resume continuation will expect ARGS on the stack as if from a + multiple-value return. Fill in the closure slot with #f, and copy + the arguments into place. */ + vp->sp[nargs].scm = SCM_BOOL_F; + memcpy (vp->sp, args, nargs * sizeof (*args)); /* The prompt captured a slice of the dynamic stack. Here we wind those entries onto the current thread's stack. We also have to @@ -789,20 +780,22 @@ typedef SCM (*scm_t_vm_engine) (scm_i_thread *current_thread, struct scm_vm *vp, static const scm_t_vm_engine vm_engines[SCM_VM_NUM_ENGINES] = { vm_regular_engine, vm_debug_engine }; -static SCM* +static union scm_vm_stack_element* allocate_stack (size_t size) -#define FUNC_NAME "make_vm" { void *ret; - if (size >= ((size_t) -1) / sizeof (SCM)) + if (size >= ((size_t) -1) / sizeof (union scm_vm_stack_element)) abort (); - size *= sizeof (SCM); + size *= sizeof (union scm_vm_stack_element); #if HAVE_SYS_MMAN_H ret = mmap (NULL, size, PROT_READ | PROT_WRITE, MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); + if (ret == NULL) + /* Shouldn't happen. */ + abort (); if (ret == MAP_FAILED) ret = NULL; #else @@ -810,19 +803,15 @@ allocate_stack (size_t size) #endif if (!ret) - { - perror ("allocate_stack failed"); - return NULL; - } + perror ("allocate_stack failed"); - return (SCM *) ret; + return (union scm_vm_stack_element *) ret; } -#undef FUNC_NAME static void -free_stack (SCM *stack, size_t size) +free_stack (union scm_vm_stack_element *stack, size_t size) { - size *= sizeof (SCM); + size *= sizeof (*stack); #if HAVE_SYS_MMAN_H munmap (stack, size); @@ -831,36 +820,38 @@ free_stack (SCM *stack, size_t size) #endif } -static SCM* -expand_stack (SCM *old_stack, size_t old_size, size_t new_size) +/* Ideally what we would like is an mremap or a realloc that grows at + the bottom, not the top. Oh well; mmap and memcpy are fast enough, + considering that they run very infrequently. */ +static union scm_vm_stack_element* +expand_stack (union scm_vm_stack_element *old_bottom, size_t old_size, + size_t new_size) #define FUNC_NAME "expand_stack" { -#if defined MREMAP_MAYMOVE - void *new_stack; + union scm_vm_stack_element *new_bottom; + size_t extension_size; - if (new_size >= ((size_t) -1) / sizeof (SCM)) + if (new_size >= ((size_t) -1) / sizeof (union scm_vm_stack_element)) + abort (); + if (new_size <= old_size) abort (); - old_size *= sizeof (SCM); - new_size *= sizeof (SCM); + extension_size = new_size - old_size; - new_stack = mremap (old_stack, old_size, new_size, MREMAP_MAYMOVE); - if (new_stack == MAP_FAILED) + if ((size_t)old_bottom < extension_size * sizeof (union scm_vm_stack_element)) + abort (); + + new_bottom = allocate_stack (new_size); + + if (!new_bottom) return NULL; - return (SCM *) new_stack; -#else - SCM *new_stack; + memcpy (new_bottom + extension_size, + old_bottom, + old_size * sizeof (union scm_vm_stack_element)); + free_stack (old_bottom, old_size); - new_stack = allocate_stack (new_size); - if (!new_stack) - return NULL; - - memcpy (new_stack, old_stack, old_size * sizeof (SCM)); - free_stack (old_stack, old_size); - - return new_stack; -#endif + return new_bottom; } #undef FUNC_NAME @@ -873,19 +864,21 @@ make_vm (void) vp = scm_gc_malloc (sizeof (struct scm_vm), "vm"); - vp->stack_size = page_size / sizeof (SCM); - vp->stack_base = allocate_stack (vp->stack_size); - if (!vp->stack_base) + vp->stack_size = page_size / sizeof (union scm_vm_stack_element); + vp->stack_bottom = allocate_stack (vp->stack_size); + if (!vp->stack_bottom) /* As in expand_stack, we don't have any way to throw an exception if we can't allocate one measely page -- there's no stack to handle it. For now, abort. */ abort (); - vp->stack_limit = vp->stack_base + vp->stack_size; + vp->stack_top = vp->stack_bottom + vp->stack_size; + vp->stack_limit = vp->stack_bottom; vp->overflow_handler_stack = SCM_EOL; - vp->ip = NULL; - vp->sp = vp->stack_base - 1; - vp->fp = NULL; - vp->engine = vm_default_engine; + vp->ip = NULL; + vp->sp = vp->stack_top; + vp->sp_min_since_gc = vp->sp; + vp->fp = NULL; + vp->engine = vm_default_engine; vp->trace_level = 0; for (i = 0; i < SCM_VM_NUM_HOOKS; i++) vp->hooks[i] = SCM_BOOL_F; @@ -898,30 +891,30 @@ static void return_unused_stack_to_os (struct scm_vm *vp) { #if HAVE_SYS_MMAN_H - scm_t_uintptr start = (scm_t_uintptr) (vp->sp + 1); - scm_t_uintptr end = (scm_t_uintptr) vp->stack_limit; + scm_t_uintptr lo = (scm_t_uintptr) vp->stack_bottom; + scm_t_uintptr hi = (scm_t_uintptr) vp->sp; /* The second condition is needed to protect against wrap-around. */ - if (vp->sp_max_since_gc < vp->stack_limit && vp->sp < vp->sp_max_since_gc) - end = (scm_t_uintptr) (vp->sp_max_since_gc + 1); + if (vp->sp_min_since_gc >= vp->stack_bottom && vp->sp >= vp->sp_min_since_gc) + lo = (scm_t_uintptr) vp->sp_min_since_gc; - start = ((start - 1U) | (page_size - 1U)) + 1U; /* round up */ - end = ((end - 1U) | (page_size - 1U)) + 1U; /* round up */ + lo &= ~(page_size - 1U); /* round down */ + hi &= ~(page_size - 1U); /* round down */ /* Return these pages to the OS. The next time they are paged in, they will be zeroed. */ - if (start < end) + if (lo < hi) { int ret = 0; do - ret = madvise ((void *) start, end - start, MADV_DONTNEED); + ret = madvise ((void *) lo, hi - lo, MADV_DONTNEED); while (ret && errno == -EAGAIN); if (ret) perror ("madvise failed"); } - vp->sp_max_since_gc = vp->sp; + vp->sp_min_since_gc = vp->sp; #endif } @@ -957,45 +950,44 @@ find_dead_slot_map (scm_t_uint32 *ip, struct dead_slot_map_cache *cache) return map; } -/* Mark the VM stack region between its base and its current top. */ +/* Mark the active VM stack region. */ struct GC_ms_entry * scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr, struct GC_ms_entry *mark_stack_limit) { - SCM *sp, *fp; + union scm_vm_stack_element *sp, *fp; /* The first frame will be marked conservatively (without a dead slot map). This is because GC can happen at any point within the hottest activation, due to multiple threads or per-instruction hooks, and providing dead slot maps for all points in a program would take a prohibitive amount of space. */ const scm_t_uint8 *dead_slots = NULL; - scm_t_uintptr upper = (scm_t_uintptr) GC_greatest_plausible_heap_addr; - scm_t_uintptr lower = (scm_t_uintptr) GC_least_plausible_heap_addr; + void *upper = (void *) GC_greatest_plausible_heap_addr; + void *lower = (void *) GC_least_plausible_heap_addr; struct dead_slot_map_cache cache; memset (&cache, 0, sizeof (cache)); for (fp = vp->fp, sp = vp->sp; fp; fp = SCM_FRAME_DYNAMIC_LINK (fp)) { - for (; sp >= &SCM_FRAME_LOCAL (fp, 0); sp--) + scm_t_ptrdiff nlocals = SCM_FRAME_NUM_LOCALS (fp, sp); + size_t slot = nlocals - 1; + for (slot = nlocals - 1; sp < fp; sp++, slot--) { - SCM elt = *sp; - if (SCM_NIMP (elt) - && SCM_UNPACK (elt) >= lower && SCM_UNPACK (elt) <= upper) + if (SCM_NIMP (sp->scm) && sp->ptr >= lower && sp->ptr <= upper) { if (dead_slots) { - size_t slot = sp - &SCM_FRAME_LOCAL (fp, 0); if (dead_slots[slot / 8U] & (1U << (slot % 8U))) { /* This value may become dead as a result of GC, so we can't just leave it on the stack. */ - *sp = SCM_UNSPECIFIED; + sp->scm = SCM_UNSPECIFIED; continue; } } - mark_stack_ptr = GC_mark_and_push ((void *) elt, + mark_stack_ptr = GC_mark_and_push (sp->ptr, mark_stack_ptr, mark_stack_limit, NULL); @@ -1018,8 +1010,8 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr, void scm_i_vm_free_stack (struct scm_vm *vp) { - free_stack (vp->stack_base, vp->stack_size); - vp->stack_base = vp->stack_limit = NULL; + free_stack (vp->stack_bottom, vp->stack_size); + vp->stack_bottom = vp->stack_top = vp->stack_limit = NULL; vp->stack_size = 0; } @@ -1027,7 +1019,7 @@ struct vm_expand_stack_data { struct scm_vm *vp; size_t stack_size; - SCM *new_sp; + union scm_vm_stack_element *new_sp; }; static void * @@ -1036,34 +1028,35 @@ vm_expand_stack_inner (void *data_ptr) struct vm_expand_stack_data *data = data_ptr; struct scm_vm *vp = data->vp; - SCM *old_stack, *new_stack; + union scm_vm_stack_element *old_top, *new_bottom; size_t new_size; scm_t_ptrdiff reloc; + old_top = vp->stack_top; new_size = vp->stack_size; while (new_size < data->stack_size) new_size *= 2; - old_stack = vp->stack_base; - new_stack = expand_stack (vp->stack_base, vp->stack_size, new_size); - if (!new_stack) + new_bottom = expand_stack (vp->stack_bottom, vp->stack_size, new_size); + if (!new_bottom) return NULL; - vp->stack_base = new_stack; + vp->stack_bottom = new_bottom; vp->stack_size = new_size; - vp->stack_limit = vp->stack_base + new_size; - reloc = vp->stack_base - old_stack; + vp->stack_top = vp->stack_bottom + new_size; + vp->stack_limit = vp->stack_bottom; + reloc = vp->stack_top - old_top; if (reloc) { - SCM *fp; + union scm_vm_stack_element *fp; if (vp->fp) vp->fp += reloc; data->new_sp += reloc; fp = vp->fp; while (fp) { - SCM *next_fp = SCM_FRAME_DYNAMIC_LINK (fp); + union scm_vm_stack_element *next_fp = SCM_FRAME_DYNAMIC_LINK (fp); if (next_fp) { next_fp += reloc; @@ -1073,7 +1066,7 @@ vm_expand_stack_inner (void *data_ptr) } } - return new_stack; + return new_bottom; } static scm_t_ptrdiff @@ -1095,9 +1088,9 @@ static void reset_stack_limit (struct scm_vm *vp) { if (should_handle_stack_overflow (vp, vp->stack_size)) - vp->stack_limit = vp->stack_base + current_overflow_size (vp); + vp->stack_limit = vp->stack_top - current_overflow_size (vp); else - vp->stack_limit = vp->stack_base + vp->stack_size; + vp->stack_limit = vp->stack_bottom; } struct overflow_handler_data @@ -1127,9 +1120,9 @@ unwind_overflow_handler (void *ptr) } static void -vm_expand_stack (struct scm_vm *vp, SCM *new_sp) +vm_expand_stack (struct scm_vm *vp, union scm_vm_stack_element *new_sp) { - scm_t_ptrdiff stack_size = new_sp + 1 - vp->stack_base; + scm_t_ptrdiff stack_size = vp->stack_top - new_sp; if (stack_size > vp->stack_size) { @@ -1146,7 +1139,7 @@ vm_expand_stack (struct scm_vm *vp, SCM *new_sp) new_sp = data.new_sp; } - vp->sp_max_since_gc = vp->sp = new_sp; + vp->sp_min_since_gc = vp->sp = new_sp; if (should_handle_stack_overflow (vp, stack_size)) { @@ -1184,7 +1177,7 @@ vm_expand_stack (struct scm_vm *vp, SCM *new_sp) scm_dynwind_end (); - /* Recurse */ + /* Recurse. */ return vm_expand_stack (vp, new_sp); } } @@ -1209,10 +1202,13 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs) { scm_i_thread *thread; struct scm_vm *vp; - SCM *base; - ptrdiff_t base_frame_size; - /* Cached variables. */ - scm_i_jmp_buf registers; /* used for prompts */ + union scm_vm_stack_element *return_fp, *call_fp; + /* Since nargs can only describe the length of a valid argv array in + elements and each element is at least 4 bytes, nargs will not be + greater than INTMAX/2 and therefore we don't have to check for + overflow here or below. */ + size_t return_nlocals = 1, call_nlocals = nargs + 1, frame_size = 2; + scm_t_ptrdiff stack_reserve_words; size_t i; thread = SCM_I_CURRENT_THREAD; @@ -1220,32 +1216,36 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs) SCM_CHECK_STACK; - /* Check that we have enough space: 3 words for the boot continuation, - and 3 + nargs for the procedure application. */ - base_frame_size = 3 + 3 + nargs; - vm_push_sp (vp, vp->sp + base_frame_size); - base = vp->sp + 1 - base_frame_size; + /* It's not valid for argv to point into the stack already. */ + if ((void *) argv < (void *) vp->stack_top && + (void *) argv >= (void *) vp->sp) + abort(); - /* Since it's possible to receive the arguments on the stack itself, - shuffle up the arguments first. */ - for (i = nargs; i > 0; i--) - base[6 + i - 1] = argv[i - 1]; + /* Check that we have enough space for the two stack frames: the + innermost one that makes the call, and its continuation which + receives the resulting value(s) and returns from the engine + call. */ + stack_reserve_words = call_nlocals + frame_size + return_nlocals + frame_size; + vm_push_sp (vp, vp->sp - stack_reserve_words); + + call_fp = vp->sp + call_nlocals; + return_fp = call_fp + frame_size + return_nlocals; + + SCM_FRAME_SET_RETURN_ADDRESS (return_fp, vp->ip); + SCM_FRAME_SET_DYNAMIC_LINK (return_fp, vp->fp); + SCM_FRAME_LOCAL (return_fp, 0) = vm_boot_continuation; - /* Push the boot continuation, which calls PROC and returns its - result(s). */ - base[0] = SCM_PACK (vp->fp); /* dynamic link */ - base[1] = SCM_PACK (vp->ip); /* ra */ - base[2] = vm_boot_continuation; - vp->fp = &base[2]; vp->ip = (scm_t_uint32 *) vm_boot_continuation_code; + vp->fp = call_fp; - /* The pending call to PROC. */ - base[3] = SCM_PACK (vp->fp); /* dynamic link */ - base[4] = SCM_PACK (vp->ip); /* ra */ - base[5] = proc; - vp->fp = &base[5]; + SCM_FRAME_SET_RETURN_ADDRESS (call_fp, vp->ip); + SCM_FRAME_SET_DYNAMIC_LINK (call_fp, return_fp); + SCM_FRAME_LOCAL (call_fp, 0) = proc; + for (i = 0; i < nargs; i++) + SCM_FRAME_LOCAL (call_fp, i + 1) = argv[i]; { + scm_i_jmp_buf registers; int resume = SCM_I_SETJMP (registers); if (SCM_UNLIKELY (resume)) @@ -1449,7 +1449,7 @@ SCM_DEFINE (scm_call_with_stack_overflow_handler, SCM new_limit, ret; vp = scm_the_vm (); - stack_size = vp->sp - vp->stack_base; + stack_size = vp->stack_top - vp->sp; c_limit = scm_to_ptrdiff_t (limit); if (c_limit <= 0) @@ -1474,7 +1474,7 @@ SCM_DEFINE (scm_call_with_stack_overflow_handler, scm_dynwind_unwind_handler (unwind_overflow_handler, &data, SCM_F_WIND_EXPLICITLY); - /* Reset vp->sp_max_since_gc so that the VM checks actually + /* Reset vp->sp_min_since_gc so that the VM checks actually trigger. */ return_unused_stack_to_os (vp); diff --git a/libguile/vm.h b/libguile/vm.h index 8f88d0cd4..adac08593 100644 --- a/libguile/vm.h +++ b/libguile/vm.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014, 2015 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 License @@ -37,13 +37,14 @@ enum { struct scm_vm { scm_t_uint32 *ip; /* instruction pointer */ - SCM *sp; /* stack pointer */ - SCM *fp; /* frame pointer */ - SCM *stack_limit; /* stack limit address */ + union scm_vm_stack_element *sp; /* stack pointer */ + union scm_vm_stack_element *fp; /* frame pointer */ + union scm_vm_stack_element *stack_limit; /* stack limit address */ int trace_level; /* traces enabled if trace_level > 0 */ - SCM *sp_max_since_gc; /* highest sp since last gc */ + union scm_vm_stack_element *sp_min_since_gc; /* deepest sp since last gc */ size_t stack_size; /* stack size */ - SCM *stack_base; /* stack base address */ + union scm_vm_stack_element *stack_bottom; /* lowest address in allocated stack */ + union scm_vm_stack_element *stack_top; /* highest address in allocated stack */ SCM overflow_handler_stack; /* alist of max-stack-size -> thunk */ SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */ int engine; /* which vm engine we're using */ @@ -78,11 +79,13 @@ SCM_INTERNAL void scm_i_vm_free_stack (struct scm_vm *vp); #define SCM_F_VM_CONT_REWINDABLE 0x2 struct scm_vm_cont { - SCM *sp; - SCM *fp; + /* FIXME: sp isn't needed, it's effectively the same as + stack_bottom */ + union scm_vm_stack_element *sp; + union scm_vm_stack_element *fp; scm_t_uint32 *ra; scm_t_ptrdiff stack_size; - SCM *stack_base; + union scm_vm_stack_element *stack_bottom; scm_t_ptrdiff reloc; scm_t_dynstack *dynstack; scm_t_uint32 flags; @@ -97,7 +100,9 @@ SCM_API SCM scm_load_compiled_with_vm (SCM file); SCM_INTERNAL SCM scm_i_call_with_current_continuation (SCM proc); SCM_INTERNAL SCM scm_i_capture_current_stack (void); -SCM_INTERNAL SCM scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp, +SCM_INTERNAL SCM scm_i_vm_capture_stack (union scm_vm_stack_element *stack_top, + union scm_vm_stack_element *fp, + union scm_vm_stack_element *sp, scm_t_uint32 *ra, scm_t_dynstack *dynstack, scm_t_uint32 flags); From aa9f6b00827bd0c1a2f11274191f49b0ad31926d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 18 Oct 2015 19:54:58 +0200 Subject: [PATCH 054/865] VM caches address of local 0 instead of FP * libguile/vm-engine.c (vm_engine): Cache the address of local 0 instead of the FP. This makes locals access a bit cheaper, but we still have to negate the index. The right fix is to index relative to the SP instead. That's a more involved change, so we punt until later. --- libguile/vm-engine.c | 120 ++++++++++++++++++++++++------------------- 1 file changed, 66 insertions(+), 54 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index f6cb0c49c..9415de5b1 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -107,7 +107,7 @@ { \ SYNC_IP (); \ exp; \ - CACHE_FP (); \ + CACHE_LOCALS (); \ } \ } while (0) #else @@ -128,37 +128,39 @@ RUN_HOOK0 (abort) #define VM_HANDLE_INTERRUPTS \ - SCM_ASYNC_TICK_WITH_GUARD_CODE (thread, SYNC_IP (), CACHE_FP ()) + SCM_ASYNC_TICK_WITH_GUARD_CODE (thread, SYNC_IP (), CACHE_LOCALS ()) /* Virtual Machine The VM has three state bits: the instruction pointer (IP), the frame - pointer (FP), and the stack pointer (SP). We cache the first two of - these in machine registers, local to the VM, because they are used - extensively by the VM. As the SP is used more by code outside the VM - than by the VM itself, we don't bother caching it locally. + pointer (FP), and the stack pointer (SP). We cache the IP in a + machine register, local to the VM, because it is used extensively by + the VM. We cache the address of local 0 too, for now; when we change + to reference variables relative to the SP we'll cache the SP instead. + As it is, the SP is used more by code outside the VM than by the VM + itself, we don't bother caching it locally. - Since the FP changes infrequently, relative to the IP, we keep vp->fp - in sync with the local FP. This would be a big lose for the IP, - though, so instead of updating vp->ip all the time, we call SYNC_IP - whenever we would need to know the IP of the top frame. In practice, - we need to SYNC_IP whenever we call out of the VM to a function that - would like to walk the stack, perhaps as the result of an - exception. + Keeping vp->ip in sync with the local IP would be a big lose, as it + is updated so often. Instead of updating vp->ip all the time, we + call SYNC_IP whenever we would need to know the IP of the top frame. + In practice, we need to SYNC_IP whenever we call out of the VM to a + function that would like to walk the stack, perhaps as the result of + an exception. One more thing. We allow the stack to move, when it expands. Therefore if you call out to a C procedure that could call Scheme code, or otherwise push anything on the stack, you will need to - CACHE_FP afterwards to restore the possibly-changed FP. */ + CACHE_LOCALS afterwards to restore the possibly-changed address of + local 0. */ #define SYNC_IP() vp->ip = (ip) -#define CACHE_FP() fp = (vp->fp) +#define CACHE_LOCALS() locals = (vp->fp - 1) #define CACHE_REGISTER() \ do { \ ip = vp->ip; \ - fp = vp->fp; \ + CACHE_LOCALS (); \ } while (0) @@ -179,7 +181,7 @@ { \ SYNC_IP (); \ vm_expand_stack (vp, new_sp); \ - CACHE_FP (); \ + CACHE_LOCALS (); \ } \ else \ vp->sp_min_since_gc = vp->sp = new_sp; \ @@ -246,9 +248,15 @@ case opcode: #endif -#define LOCAL_ADDRESS(i) SCM_FRAME_SLOT (fp, i) -#define LOCAL_REF(i) SCM_FRAME_LOCAL (fp, i) -#define LOCAL_SET(i,o) SCM_FRAME_LOCAL (fp, i) = o +// This "locals + 1" is actually an optimization, because vp->fp points +// on before the zeroeth local. The result is to reference locals[-i]. +// In the future we should change to reference locals relative to the SP +// and cache the SP instead, which would give direct (non-negated) +// indexing off the SP, which is more in line with addressing modes +// supported by common CPUs. +#define LOCAL_ADDRESS(i) SCM_FRAME_SLOT (locals + 1, i) +#define LOCAL_REF(i) SCM_FRAME_LOCAL (locals + 1, i) +#define LOCAL_SET(i,o) SCM_FRAME_LOCAL (locals + 1, i) = o #define VARIABLE_REF(v) SCM_VARIABLE_REF (v) #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o) @@ -260,9 +268,10 @@ union scm_vm_stack_element *old_fp; \ VM_HANDLE_INTERRUPTS; \ ALLOC_FRAME (2); \ - old_fp = fp; \ - ip = SCM_FRAME_RETURN_ADDRESS (fp); \ - fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); \ + old_fp = vp->fp; \ + ip = SCM_FRAME_RETURN_ADDRESS (vp->fp); \ + vp->fp = SCM_FRAME_DYNAMIC_LINK (vp->fp); \ + CACHE_LOCALS (); \ /* Clear frame. */ \ old_fp[0].scm = SCM_BOOL_F; \ old_fp[1].scm = SCM_BOOL_F; \ @@ -280,9 +289,9 @@ SCM vals = vals_; \ VM_HANDLE_INTERRUPTS; \ ALLOC_FRAME (3); \ - SCM_FRAME_LOCAL (fp, 0) = vm_builtin_apply; \ - SCM_FRAME_LOCAL (fp, 1) = vm_builtin_values; \ - SCM_FRAME_LOCAL (fp, 2) = vals; \ + SCM_FRAME_LOCAL (vp->fp, 0) = vm_builtin_apply; \ + SCM_FRAME_LOCAL (vp->fp, 1) = vm_builtin_values; \ + SCM_FRAME_LOCAL (vp->fp, 2) = vals; \ ip = (scm_t_uint32 *) vm_builtin_apply_code; \ goto op_tail_apply; \ } while (0) @@ -355,7 +364,7 @@ SCM res; \ SYNC_IP (); \ res = srel (x, y); \ - CACHE_FP (); \ + CACHE_LOCALS (); \ if ((ip[1] & 0x1) ? scm_is_false (res) : scm_is_true (res)) \ { \ scm_t_int32 offset = ip[1]; \ @@ -382,7 +391,7 @@ #define RETURN(x) \ do { LOCAL_SET (dst, x); NEXT (1); } while (0) #define RETURN_EXP(exp) \ - do { SCM __x; SYNC_IP (); __x = exp; CACHE_FP (); RETURN (__x); } while (0) + do { SCM __x; SYNC_IP (); __x = exp; CACHE_LOCALS (); RETURN (__x); } while (0) /* The maximum/minimum tagged integers. */ #define INUM_MAX \ @@ -429,7 +438,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, /* Frame pointer: A pointer into the stack, off of which we index arguments and local variables. Pushed at function calls, popped on returns. */ - register union scm_vm_stack_element *fp FP_REG; + register union scm_vm_stack_element *locals FP_REG; /* Current opcode: A cache of *ip. */ register scm_t_uint32 op; @@ -524,9 +533,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, ret = scm_values (ret); } - vp->ip = SCM_FRAME_RETURN_ADDRESS (fp); - vp->sp = SCM_FRAME_PREVIOUS_SP (fp); - vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); + vp->ip = SCM_FRAME_RETURN_ADDRESS (vp->fp); + vp->sp = SCM_FRAME_PREVIOUS_SP (vp->fp); + vp->fp = SCM_FRAME_DYNAMIC_LINK (vp->fp); return ret; } @@ -556,10 +565,11 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, PUSH_CONTINUATION_HOOK (); - old_fp = fp; - fp = vp->fp = SCM_FRAME_SLOT (old_fp, proc - 1); - SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp); - SCM_FRAME_SET_RETURN_ADDRESS (fp, ip + 2); + old_fp = vp->fp; + vp->fp = SCM_FRAME_SLOT (old_fp, proc - 1); + CACHE_LOCALS (); + SCM_FRAME_SET_DYNAMIC_LINK (vp->fp, old_fp); + SCM_FRAME_SET_RETURN_ADDRESS (vp->fp, ip + 2); RESET_FRAME (nlocals); @@ -597,10 +607,11 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, PUSH_CONTINUATION_HOOK (); - old_fp = fp; - fp = vp->fp = SCM_FRAME_SLOT (old_fp, proc - 1); - SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp); - SCM_FRAME_SET_RETURN_ADDRESS (fp, ip + 3); + old_fp = vp->fp; + vp->fp = SCM_FRAME_SLOT (old_fp, proc - 1); + CACHE_LOCALS (); + SCM_FRAME_SET_DYNAMIC_LINK (vp->fp, old_fp); + SCM_FRAME_SET_RETURN_ADDRESS (vp->fp, ip + 3); RESET_FRAME (nlocals); @@ -759,9 +770,10 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, VM_HANDLE_INTERRUPTS; - old_fp = fp; - ip = SCM_FRAME_RETURN_ADDRESS (fp); - fp = vp->fp = SCM_FRAME_DYNAMIC_LINK (fp); + old_fp = vp->fp; + ip = SCM_FRAME_RETURN_ADDRESS (vp->fp); + vp->fp = SCM_FRAME_DYNAMIC_LINK (vp->fp); + CACHE_LOCALS (); /* Clear stack frame. */ old_fp[0].scm = SCM_BOOL_F; @@ -850,7 +862,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, abort (); } - CACHE_FP (); + CACHE_LOCALS (); if (SCM_UNLIKELY (SCM_VALUESP (ret))) /* multiple values returned to continuation */ @@ -884,7 +896,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, ret = scm_i_foreign_call (scm_inline_cons (thread, cif, pointer), vp->sp); - CACHE_FP (); + CACHE_LOCALS (); if (SCM_UNLIKELY (SCM_VALUESP (ret))) /* multiple values returned to continuation */ @@ -1011,9 +1023,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, SYNC_IP (); dynstack = scm_dynstack_capture_all (&thread->dynstack); vm_cont = scm_i_vm_capture_stack (vp->stack_top, - SCM_FRAME_DYNAMIC_LINK (fp), - SCM_FRAME_PREVIOUS_SP (fp), - SCM_FRAME_RETURN_ADDRESS (fp), + SCM_FRAME_DYNAMIC_LINK (vp->fp), + SCM_FRAME_PREVIOUS_SP (vp->fp), + SCM_FRAME_RETURN_ADDRESS (vp->fp), dynstack, 0); /* FIXME: Seems silly to capture the registers here, when they are @@ -1477,7 +1489,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * If the value in A is equal? to the value in B, add OFFSET, a signed * 24-bit number, to the current instruction pointer. */ - // FIXME: Should sync_ip before calling out and cache_fp before coming + // FIXME: Should sync_ip before calling out and cache_locals before coming // back! Another reason to remove this opcode! VM_DEFINE_OP (40, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24)) { @@ -1893,7 +1905,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, SYNC_IP (); var = scm_lookup (LOCAL_REF (sym)); - CACHE_FP (); + CACHE_LOCALS (); if (ip[1] & 0x1) VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (LOCAL_REF (sym))); LOCAL_SET (dst, var); @@ -1912,7 +1924,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_12_12 (op, sym, val); SYNC_IP (); scm_define (LOCAL_REF (sym), LOCAL_REF (val)); - CACHE_FP (); + CACHE_LOCALS (); NEXT (1); } @@ -1972,7 +1984,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, mod = scm_the_root_module (); var = scm_module_lookup (mod, sym); - CACHE_FP (); + CACHE_LOCALS (); if (ip[4] & 0x1) VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (sym)); @@ -2033,7 +2045,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, else var = scm_private_lookup (SCM_CDR (modname), sym); - CACHE_FP (); + CACHE_LOCALS (); if (ip[4] & 0x1) VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (sym)); @@ -2075,7 +2087,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0; scm_dynstack_push_prompt (&thread->dynstack, flags, LOCAL_REF (tag), - vp->stack_top - fp, + vp->stack_top - vp->fp, vp->stack_top - LOCAL_ADDRESS (proc_slot), ip + offset, registers); From 30c06bfbb3db6e8c05f2ee6e7866d4ecf5838482 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 18 Oct 2015 20:12:15 +0200 Subject: [PATCH 055/865] Remove sp from scm_vm_cont * libguile/vm.h (struct scm_vm_cont): Remove "sp" member; it's always the same as stack_bottom. * libguile/vm.c (scm_i_vm_cont_to_frame, scm_i_vm_capture_stack): (vm_return_to_continuation_inner): * libguile/stacks.c (scm_make_stack): * libguile/continuations.c (scm_i_continuation_to_frame): Adapt. --- libguile/continuations.c | 2 +- libguile/stacks.c | 2 +- libguile/vm.c | 5 ++--- libguile/vm.h | 3 --- 4 files changed, 4 insertions(+), 8 deletions(-) diff --git a/libguile/continuations.c b/libguile/continuations.c index 7cc3cea10..c0a2bd8ae 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -186,7 +186,7 @@ scm_i_continuation_to_frame (SCM continuation, struct scm_frame *frame) stack_top = data->stack_bottom + data->stack_size; frame->stack_holder = data; frame->fp_offset = stack_top - (data->fp + data->reloc); - frame->sp_offset = stack_top - (data->sp + data->reloc); + frame->sp_offset = data->stack_size; frame->ip = data->ra; return 1; diff --git a/libguile/stacks.c b/libguile/stacks.c index ec3ec789f..366176b10 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -330,7 +330,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, kind = SCM_VM_FRAME_KIND_CONT; frame.stack_holder = c; frame.fp_offset = stack_top - (c->fp + c->reloc); - frame.sp_offset = stack_top - (c->sp + c->reloc); + frame.sp_offset = c->stack_size; frame.ip = c->ra; } else if (SCM_VM_FRAME_P (obj)) diff --git a/libguile/vm.c b/libguile/vm.c index d5a72727f..74dce6351 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -120,7 +120,7 @@ scm_i_vm_cont_to_frame (SCM cont, struct scm_frame *frame) stack_top = data->stack_bottom + data->stack_size; frame->stack_holder = data; frame->fp_offset = stack_top - (data->fp + data->reloc); - frame->sp_offset = stack_top - (data->sp + data->reloc); + frame->sp_offset = data->stack_size; frame->ip = data->ra; return 1; @@ -142,7 +142,6 @@ scm_i_vm_capture_stack (union scm_vm_stack_element *stack_top, p->stack_bottom = scm_gc_malloc (p->stack_size * sizeof (*p->stack_bottom), "capture_vm_cont"); p->ra = ra; - p->sp = sp; p->fp = fp; memcpy (p->stack_bottom, sp, p->stack_size * sizeof (*p->stack_bottom)); p->reloc = (p->stack_bottom + p->stack_size) - stack_top; @@ -178,7 +177,7 @@ vm_return_to_continuation_inner (void *data_ptr) memcpy (vp->stack_top - cp->stack_size, cp->stack_bottom, cp->stack_size * sizeof (*cp->stack_bottom)); - vm_restore_sp (vp, cp->sp + reloc); + vm_restore_sp (vp, vp->stack_top - cp->stack_size); if (reloc) { diff --git a/libguile/vm.h b/libguile/vm.h index adac08593..936633d21 100644 --- a/libguile/vm.h +++ b/libguile/vm.h @@ -79,9 +79,6 @@ SCM_INTERNAL void scm_i_vm_free_stack (struct scm_vm *vp); #define SCM_F_VM_CONT_REWINDABLE 0x2 struct scm_vm_cont { - /* FIXME: sp isn't needed, it's effectively the same as - stack_bottom */ - union scm_vm_stack_element *sp; union scm_vm_stack_element *fp; scm_t_uint32 *ra; scm_t_ptrdiff stack_size; From 8f027385db228d68193ad7316cf0b79489ac038b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 18 Oct 2015 20:25:43 +0200 Subject: [PATCH 056/865] Rename union scm_vm_stack_element members * libguile/frames.h (union scm_vm_stack_element): Rename members from scm, ip, etc to as_scm, as_ip, etc. Adapt users. --- libguile/control.c | 6 +++--- libguile/foreign.c | 2 +- libguile/frames.h | 26 +++++++++++++------------- libguile/vm-engine.c | 22 +++++++++++----------- libguile/vm.c | 21 +++++++++++---------- 5 files changed, 39 insertions(+), 38 deletions(-) diff --git a/libguile/control.c b/libguile/control.c index a3457342b..c0bc62ddb 100644 --- a/libguile/control.c +++ b/libguile/control.c @@ -52,7 +52,7 @@ scm_i_prompt_pop_abort_args_x (struct scm_vm *vp, n = stack_depth - saved_stack_depth; for (i = 0; i < n; i++) - vals = scm_cons (vp->sp[i].scm, vals); + vals = scm_cons (vp->sp[i].as_scm, vals); vp->sp += n; @@ -169,9 +169,9 @@ scm_c_abort (struct scm_vm *vp, SCM tag, size_t n, SCM *argv, abort (); /* Push vals */ - vp->sp[n].scm = cont; + vp->sp[n].as_scm = cont; for (i = 0; i < n; i++) - vp->sp[n - i - 1].scm = argv[i]; + vp->sp[n - i - 1].as_scm = argv[i]; /* Jump! */ SCM_I_LONGJMP (*registers, 1); diff --git a/libguile/foreign.c b/libguile/foreign.c index 3ac06591d..864019e63 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -1016,7 +1016,7 @@ scm_i_foreign_call (SCM foreign, const union scm_vm_stack_element *argv) args[i] = (void *) ROUND_UP ((scm_t_uintptr) data + off, cif->arg_types[i]->alignment); assert ((scm_t_uintptr) args[i] % cif->arg_types[i]->alignment == 0); - unpack (cif->arg_types[i], args[i], argv[cif->nargs - i - 1].scm, 0); + unpack (cif->arg_types[i], args[i], argv[cif->nargs - i - 1].as_scm, 0); } /* Prepare space for the return value. On some platforms, such as diff --git a/libguile/frames.h b/libguile/frames.h index c2f1e57db..870477d53 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -88,23 +88,23 @@ /* Each element on the stack occupies the same amount of space. */ union scm_vm_stack_element { - union scm_vm_stack_element *fp; - scm_t_uint32 *ip; - SCM scm; + union scm_vm_stack_element *as_fp; + scm_t_uint32 *as_ip; + SCM as_scm; /* For GC purposes. */ - void *ptr; - scm_t_bits bits; + void *as_ptr; + scm_t_bits as_bits; }; -#define SCM_FRAME_PREVIOUS_SP(fp_) ((fp_) + 2) -#define SCM_FRAME_RETURN_ADDRESS(fp_) ((fp_)[0].ip) -#define SCM_FRAME_SET_RETURN_ADDRESS(fp_, ra) ((fp_)[0].ip = (ra)) -#define SCM_FRAME_DYNAMIC_LINK(fp_) ((fp_)[1].fp) -#define SCM_FRAME_SET_DYNAMIC_LINK(fp_, dl) ((fp_)[1].fp = (dl)) -#define SCM_FRAME_SLOT(fp_,i) ((fp_) - (i) - 1) -#define SCM_FRAME_LOCAL(fp_,i) (SCM_FRAME_SLOT (fp_, i)->scm) -#define SCM_FRAME_NUM_LOCALS(fp_, sp) ((fp_) - (sp)) +#define SCM_FRAME_PREVIOUS_SP(fp) ((fp) + 2) +#define SCM_FRAME_RETURN_ADDRESS(fp) ((fp)[0].as_ip) +#define SCM_FRAME_SET_RETURN_ADDRESS(fp, ra) ((fp)[0].as_ip = (ra)) +#define SCM_FRAME_DYNAMIC_LINK(fp) ((fp)[1].as_fp) +#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) ((fp)[1].as_fp = (dl)) +#define SCM_FRAME_SLOT(fp,i) ((fp) - (i) - 1) +#define SCM_FRAME_LOCAL(fp,i) (SCM_FRAME_SLOT (fp, i)->as_scm) +#define SCM_FRAME_NUM_LOCALS(fp, sp) ((fp) - (sp)) /* diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 9415de5b1..daea0bfe2 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -268,13 +268,13 @@ union scm_vm_stack_element *old_fp; \ VM_HANDLE_INTERRUPTS; \ ALLOC_FRAME (2); \ - old_fp = vp->fp; \ - ip = SCM_FRAME_RETURN_ADDRESS (vp->fp); \ - vp->fp = SCM_FRAME_DYNAMIC_LINK (vp->fp); \ - CACHE_LOCALS (); \ + old_fp = vp->fp; \ + ip = SCM_FRAME_RETURN_ADDRESS (vp->fp); \ + vp->fp = SCM_FRAME_DYNAMIC_LINK (vp->fp); \ + CACHE_LOCALS (); \ /* Clear frame. */ \ - old_fp[0].scm = SCM_BOOL_F; \ - old_fp[1].scm = SCM_BOOL_F; \ + old_fp[0].as_scm = SCM_BOOL_F; \ + old_fp[1].as_scm = SCM_BOOL_F; \ /* Leave proc. */ \ SCM_FRAME_LOCAL (old_fp, 1) = val; \ vp->sp = SCM_FRAME_SLOT (old_fp, 1); \ @@ -289,9 +289,9 @@ SCM vals = vals_; \ VM_HANDLE_INTERRUPTS; \ ALLOC_FRAME (3); \ - SCM_FRAME_LOCAL (vp->fp, 0) = vm_builtin_apply; \ - SCM_FRAME_LOCAL (vp->fp, 1) = vm_builtin_values; \ - SCM_FRAME_LOCAL (vp->fp, 2) = vals; \ + SCM_FRAME_LOCAL (vp->fp, 0) = vm_builtin_apply; \ + SCM_FRAME_LOCAL (vp->fp, 1) = vm_builtin_values; \ + SCM_FRAME_LOCAL (vp->fp, 2) = vals; \ ip = (scm_t_uint32 *) vm_builtin_apply_code; \ goto op_tail_apply; \ } while (0) @@ -776,8 +776,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, CACHE_LOCALS (); /* Clear stack frame. */ - old_fp[0].scm = SCM_BOOL_F; - old_fp[1].scm = SCM_BOOL_F; + old_fp[0].as_scm = SCM_BOOL_F; + old_fp[1].as_scm = SCM_BOOL_F; POP_CONTINUATION_HOOK (old_fp); diff --git a/libguile/vm.c b/libguile/vm.c index 74dce6351..bc9f29080 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -218,9 +218,9 @@ vm_return_to_continuation (struct scm_vm *vp, SCM cont, size_t n, copy on an empty frame and the return values, as the continuation expects. */ vm_push_sp (vp, vp->sp - 3 - n); - vp->sp[n+2].scm = SCM_BOOL_F; - vp->sp[n+1].scm = SCM_BOOL_F; - vp->sp[n].scm = SCM_BOOL_F; + vp->sp[n+2].as_scm = SCM_BOOL_F; + vp->sp[n+1].as_scm = SCM_BOOL_F; + vp->sp[n].as_scm = SCM_BOOL_F; memcpy(vp->sp, argv_copy, n * sizeof (union scm_vm_stack_element)); vp->ip = cp->ra; @@ -298,7 +298,7 @@ vm_dispatch_hook (struct scm_vm *vp, int hook_num, SCM args[2]; args[0] = SCM_PACK_POINTER (frame); - args[1] = argv[0].scm; + args[1] = argv[0].as_scm; scm_c_run_hookn (hook, args, 2); } else @@ -307,7 +307,7 @@ vm_dispatch_hook (struct scm_vm *vp, int hook_num, int i; for (i = 0; i < n; i++) - args = scm_cons (argv[i].scm, args); + args = scm_cons (argv[i].as_scm, args); scm_c_run_hook (hook, scm_cons (SCM_PACK_POINTER (frame), args)); } @@ -352,7 +352,7 @@ vm_abort (struct scm_vm *vp, SCM tag, size_t nargs, argv = alloca (nargs * sizeof (SCM)); for (i = 0; i < nargs; i++) - argv[i] = vp->sp[nargs - i - 1].scm; + argv[i] = vp->sp[nargs - i - 1].as_scm; vp->sp = vp->fp; @@ -422,7 +422,7 @@ vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont, size_t nargs, /* The resume continuation will expect ARGS on the stack as if from a multiple-value return. Fill in the closure slot with #f, and copy the arguments into place. */ - vp->sp[nargs].scm = SCM_BOOL_F; + vp->sp[nargs].as_scm = SCM_BOOL_F; memcpy (vp->sp, args, nargs * sizeof (*args)); /* The prompt captured a slice of the dynamic stack. Here we wind @@ -973,7 +973,8 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr, size_t slot = nlocals - 1; for (slot = nlocals - 1; sp < fp; sp++, slot--) { - if (SCM_NIMP (sp->scm) && sp->ptr >= lower && sp->ptr <= upper) + if (SCM_NIMP (sp->as_scm) && + sp->as_ptr >= lower && sp->as_ptr <= upper) { if (dead_slots) { @@ -981,12 +982,12 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr, { /* This value may become dead as a result of GC, so we can't just leave it on the stack. */ - sp->scm = SCM_UNSPECIFIED; + sp->as_scm = SCM_UNSPECIFIED; continue; } } - mark_stack_ptr = GC_mark_and_push (sp->ptr, + mark_stack_ptr = GC_mark_and_push (sp->as_ptr, mark_stack_ptr, mark_stack_limit, NULL); From 72353de77d0a06f158d8af66a2540015658e2574 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 18 Oct 2015 22:59:23 +0200 Subject: [PATCH 057/865] Replace dynamic link on stack with previous frame size * libguile/frames.h (SCM_FRAME_DYNAMIC_LINK) (SCM_FRAME_SET_DYNAMIC_LINK): Instead of storing the absolute value of the previous FP, store its offset from the current FP. This allows us to avoid relinking when composing continuations or when relocating the stack. * libguile/frames.c (scm_frame_dynamic_link, scm_c_frame_previous): No need to relocate the dynamic link. * libguile/vm.c (vm_return_to_continuation_inner): (vm_reinstate_partial_continuation_inner, vm_expand_stack_inner): Don't relocate the frame pointer chain. (scm_i_vm_mark_stack): Terminate when FP is above stack_top, not when 0. (make_vm): Init FP to stack_top. --- libguile/frames.c | 12 ++---------- libguile/frames.h | 6 +++--- libguile/vm.c | 49 +++++++---------------------------------------- 3 files changed, 12 insertions(+), 55 deletions(-) diff --git a/libguile/frames.c b/libguile/frames.c index f89b0fd5b..a1c7f3e71 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -309,8 +309,6 @@ SCM_DEFINE (scm_frame_return_address, "frame-return-address", 1, 0, 0, } #undef FUNC_NAME -#define RELOC(kind, frame, val) ((val) + frame_offset (kind, frame)) - SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0, (SCM frame), "") @@ -320,8 +318,7 @@ SCM_DEFINE (scm_frame_dynamic_link, "frame-dynamic-link", 1, 0, 0, /* fixme: munge fp if holder is a continuation */ return scm_from_uintptr_t ((scm_t_uintptr) - RELOC (SCM_VM_FRAME_KIND (frame), SCM_VM_FRAME_DATA (frame), - SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame)))); + SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame))); } #undef FUNC_NAME @@ -339,12 +336,7 @@ scm_c_frame_previous (enum scm_vm_frame_kind kind, struct scm_frame *frame) new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp); - if (!new_fp) - return 0; - - new_fp = RELOC (kind, frame, new_fp); - - if (new_fp > stack_top) + if (new_fp >= stack_top) return 0; new_sp = SCM_FRAME_PREVIOUS_SP (this_fp); diff --git a/libguile/frames.h b/libguile/frames.h index 870477d53..e1130e94b 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -88,7 +88,7 @@ /* Each element on the stack occupies the same amount of space. */ union scm_vm_stack_element { - union scm_vm_stack_element *as_fp; + scm_t_uintptr as_uint; scm_t_uint32 *as_ip; SCM as_scm; @@ -100,8 +100,8 @@ union scm_vm_stack_element #define SCM_FRAME_PREVIOUS_SP(fp) ((fp) + 2) #define SCM_FRAME_RETURN_ADDRESS(fp) ((fp)[0].as_ip) #define SCM_FRAME_SET_RETURN_ADDRESS(fp, ra) ((fp)[0].as_ip = (ra)) -#define SCM_FRAME_DYNAMIC_LINK(fp) ((fp)[1].as_fp) -#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) ((fp)[1].as_fp = (dl)) +#define SCM_FRAME_DYNAMIC_LINK(fp) ((fp) + (fp)[1].as_uint) +#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) ((fp)[1].as_uint = ((dl) - (fp))) #define SCM_FRAME_SLOT(fp,i) ((fp) - (i) - 1) #define SCM_FRAME_LOCAL(fp,i) (SCM_FRAME_SLOT (fp, i)->as_scm) #define SCM_FRAME_NUM_LOCALS(fp, sp) ((fp) - (sp)) diff --git a/libguile/vm.c b/libguile/vm.c index bc9f29080..2db079550 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -179,21 +179,6 @@ vm_return_to_continuation_inner (void *data_ptr) cp->stack_size * sizeof (*cp->stack_bottom)); vm_restore_sp (vp, vp->stack_top - cp->stack_size); - if (reloc) - { - union scm_vm_stack_element *fp = vp->fp; - while (fp) - { - union scm_vm_stack_element *next_fp = SCM_FRAME_DYNAMIC_LINK (fp); - if (next_fp) - { - next_fp += reloc; - SCM_FRAME_SET_DYNAMIC_LINK (fp, next_fp); - } - fp = next_fp; - } - } - return NULL; } @@ -385,13 +370,6 @@ vm_reinstate_partial_continuation_inner (void *data_ptr) vp->fp = cp->fp + reloc; vp->ip = cp->ra; - /* now relocate frame pointers */ - { - union scm_vm_stack_element *fp; - for (fp = vp->fp; fp < base_fp; fp = SCM_FRAME_DYNAMIC_LINK (fp)) - SCM_FRAME_SET_DYNAMIC_LINK (fp, SCM_FRAME_DYNAMIC_LINK (fp) + reloc); - } - data->reloc = reloc; return NULL; @@ -876,7 +854,7 @@ make_vm (void) vp->ip = NULL; vp->sp = vp->stack_top; vp->sp_min_since_gc = vp->sp; - vp->fp = NULL; + vp->fp = vp->stack_top; vp->engine = vm_default_engine; vp->trace_level = 0; for (i = 0; i < SCM_VM_NUM_HOOKS; i++) @@ -967,7 +945,9 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr, memset (&cache, 0, sizeof (cache)); - for (fp = vp->fp, sp = vp->sp; fp; fp = SCM_FRAME_DYNAMIC_LINK (fp)) + for (fp = vp->fp, sp = vp->sp; + fp < vp->stack_top; + fp = SCM_FRAME_DYNAMIC_LINK (fp)) { scm_t_ptrdiff nlocals = SCM_FRAME_NUM_LOCALS (fp, sp); size_t slot = nlocals - 1; @@ -1047,24 +1027,9 @@ vm_expand_stack_inner (void *data_ptr) vp->stack_limit = vp->stack_bottom; reloc = vp->stack_top - old_top; - if (reloc) - { - union scm_vm_stack_element *fp; - if (vp->fp) - vp->fp += reloc; - data->new_sp += reloc; - fp = vp->fp; - while (fp) - { - union scm_vm_stack_element *next_fp = SCM_FRAME_DYNAMIC_LINK (fp); - if (next_fp) - { - next_fp += reloc; - SCM_FRAME_SET_DYNAMIC_LINK (fp, next_fp); - } - fp = next_fp; - } - } + if (vp->fp) + vp->fp += reloc; + data->new_sp += reloc; return new_bottom; } From 0da0308b8479aab335230675c94e0773985f06d6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 20 Oct 2015 20:06:40 +0200 Subject: [PATCH 058/865] Prepare for SP-addressed locals * libguile/vm-engine.c: Renumber opcodes, and take the opportunity to fold recent additions into more logical places. Be more precise when describing the encoding of operands, to shuffle local references only and not constants, immediates, or other such values. (SP_REF, SP_SET): New helpers. (BR_BINARY, BR_ARITHMETIC): Take full 24-bit operands. Our shuffle strategy is to emit push when needed to bring far locals near, then pop afterwards, shuffling away far destination values as needed; but that doesn't work for conditionals, unless we introduce a trampoline. Let's just do the simple thing for now. Native compilation will use condition codes. (push, pop, drop): Back from the dead! We'll only use these for temporary shuffling though, when an opcode can't address the full 24-bit range. (long-fmov): New instruction, like long-mov but relative to the frame pointer. (load-typed-array, make-array): Don't use a compressed encoding so that we can avoid the shuffling case. It would be a pain, given that they have so many operands already. * module/language/bytecode.scm (compute-instruction-arity): Update for new instrution word encodings. * module/system/vm/assembler.scm: Update to expose some opcodes directly, without the need for shuffling wrappers. Adapt to instruction word encodings change. * module/system/vm/disassembler.scm (disassembler): Adapt to instruction coding change. --- libguile/instructions.c | 52 +-- libguile/vm-engine.c | 581 +++++++++++++++++------------- module/language/bytecode.scm | 42 ++- module/system/vm/assembler.scm | 135 ++++--- module/system/vm/disassembler.scm | 70 ++-- 5 files changed, 494 insertions(+), 386 deletions(-) diff --git a/libguile/instructions.c b/libguile/instructions.c index e474cf5d5..003fd5425 100644 --- a/libguile/instructions.c +++ b/libguile/instructions.c @@ -31,30 +31,34 @@ SCM_SYMBOL (sym_left_arrow, "<-"); SCM_SYMBOL (sym_bang, "!"); -#define OP_HAS_ARITY (1U << 0) - #define FOR_EACH_INSTRUCTION_WORD_TYPE(M) \ M(X32) \ - M(U8_X24) \ - M(U8_U24) \ - M(U8_L24) \ - M(U8_U8_I16) \ - M(U8_U8_U8_U8) \ - M(U8_U12_U12) \ - M(U32) /* Unsigned. */ \ + M(X8_S24) \ + M(X8_F24) \ + M(X8_L24) \ + M(X8_C24) \ + M(X8_S8_I16) \ + M(X8_S12_S12) \ + M(X8_S12_C12) \ + M(X8_C12_C12) \ + M(X8_F12_F12) \ + M(X8_S8_S8_S8) \ + M(X8_S8_C8_S8) \ + M(X8_S8_S8_C8) \ + M(C8_C24) \ + M(C32) /* Unsigned. */ \ M(I32) /* Immediate. */ \ M(A32) /* Immediate, high bits. */ \ M(B32) /* Immediate, low bits. */ \ M(N32) /* Non-immediate. */ \ - M(S32) /* Scheme value (indirected). */ \ + M(R32) /* Scheme value (indirected). */ \ M(L32) /* Label. */ \ M(LO32) /* Label with offset. */ \ - M(X8_U24) \ - M(X8_U12_U12) \ - M(X8_L24) \ + M(B1_C7_L24) \ M(B1_X7_L24) \ - M(B1_U7_L24) \ - M(B1_X7_U24) \ + M(B1_X7_C24) \ + M(B1_X7_S24) \ + M(B1_X7_F24) \ M(B1_X31) #define TYPE_WIDTH 5 @@ -73,7 +77,7 @@ static SCM word_type_symbols[] = #undef FALSE }; -#define OP(n,type) ((type) << (n*TYPE_WIDTH)) +#define OP(n,type) (((type) + 1) << (n*TYPE_WIDTH)) /* The VM_DEFINE_OP macro uses a CPP-based DSL to describe what kinds of arguments each instruction takes. This piece of code is the only @@ -99,8 +103,12 @@ static SCM word_type_symbols[] = #define OP_DST (1 << (TYPE_WIDTH * 5)) -#define WORD_TYPE(n, word) \ +#define WORD_TYPE_AND_FLAG(n, word) \ (((word) >> ((n) * TYPE_WIDTH)) & ((1 << TYPE_WIDTH) - 1)) +#define WORD_TYPE(n, word) \ + (WORD_TYPE_AND_FLAG (n, word) - 1) +#define HAS_WORD(n, word) \ + (WORD_TYPE_AND_FLAG (n, word) != 0) /* Scheme interface */ @@ -112,15 +120,15 @@ parse_instruction (scm_t_uint8 opcode, const char *name, scm_t_uint32 meta) /* Format: (name opcode word0 word1 ...) */ - if (WORD_TYPE (4, meta)) + if (HAS_WORD (4, meta)) len = 5; - else if (WORD_TYPE (3, meta)) + else if (HAS_WORD (3, meta)) len = 4; - else if (WORD_TYPE (2, meta)) + else if (HAS_WORD (2, meta)) len = 3; - else if (WORD_TYPE (1, meta)) + else if (HAS_WORD (1, meta)) len = 2; - else if (WORD_TYPE (0, meta)) + else if (HAS_WORD (0, meta)) len = 1; else abort (); diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index daea0bfe2..df7a528eb 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -258,6 +258,9 @@ #define LOCAL_REF(i) SCM_FRAME_LOCAL (locals + 1, i) #define LOCAL_SET(i,o) SCM_FRAME_LOCAL (locals + 1, i) = o +#define SP_REF(i) (vp->sp[i].as_scm) +#define SP_SET(i,o) (vp->sp[i].as_scm = o) + #define VARIABLE_REF(v) SCM_VARIABLE_REF (v) #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o) #define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED)) @@ -323,57 +326,59 @@ NEXT (2) #define BR_BINARY(x, y, exp) \ - scm_t_uint16 a, b; \ + scm_t_uint32 a, b; \ SCM x, y; \ - UNPACK_12_12 (op, a, b); \ + UNPACK_24 (op, a); \ + UNPACK_24 (ip[1], b); \ x = LOCAL_REF (a); \ y = LOCAL_REF (b); \ - if ((ip[1] & 0x1) ? !(exp) : (exp)) \ + if ((ip[2] & 0x1) ? !(exp) : (exp)) \ { \ - scm_t_int32 offset = ip[1]; \ + scm_t_int32 offset = ip[2]; \ offset >>= 8; /* Sign-extending shift. */ \ if (offset <= 0) \ VM_HANDLE_INTERRUPTS; \ NEXT (offset); \ } \ - NEXT (2) + NEXT (3) #define BR_ARITHMETIC(crel,srel) \ { \ - scm_t_uint16 a, b; \ + scm_t_uint32 a, b; \ SCM x, y; \ - UNPACK_12_12 (op, a, b); \ + UNPACK_24 (op, a); \ + UNPACK_24 (ip[1], b); \ x = LOCAL_REF (a); \ y = LOCAL_REF (b); \ if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \ { \ scm_t_signed_bits x_bits = SCM_UNPACK (x); \ scm_t_signed_bits y_bits = SCM_UNPACK (y); \ - if ((ip[1] & 0x1) ? !(x_bits crel y_bits) : (x_bits crel y_bits)) \ + if ((ip[2] & 0x1) ? !(x_bits crel y_bits) : (x_bits crel y_bits)) \ { \ - scm_t_int32 offset = ip[1]; \ + scm_t_int32 offset = ip[2]; \ offset >>= 8; /* Sign-extending shift. */ \ if (offset <= 0) \ VM_HANDLE_INTERRUPTS; \ NEXT (offset); \ } \ - NEXT (2); \ + NEXT (3); \ } \ else \ { \ SCM res; \ SYNC_IP (); \ res = srel (x, y); \ - CACHE_LOCALS (); \ - if ((ip[1] & 0x1) ? scm_is_false (res) : scm_is_true (res)) \ + CACHE_LOCALS (); \ + if ((ip[2] & 0x1) ? scm_is_false (res) : scm_is_true (res)) \ { \ - scm_t_int32 offset = ip[1]; \ + scm_t_int32 offset = ip[2]; \ offset >>= 8; /* Sign-extending shift. */ \ if (offset <= 0) \ VM_HANDLE_INTERRUPTS; \ NEXT (offset); \ } \ - NEXT (2); \ + NEXT (3); \ } \ } @@ -515,7 +520,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Bring the VM to a halt, returning all the values from the stack. */ - VM_DEFINE_OP (0, halt, "halt", OP1 (U8_X24)) + VM_DEFINE_OP (0, halt, "halt", OP1 (X32)) { /* Boot closure in r0, empty frame in r1/r2, proc in r3, values from r4. */ @@ -553,7 +558,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * stack; the precise number can be had by subtracting the address of * PROC from the post-call SP. */ - VM_DEFINE_OP (1, call, "call", OP2 (U8_U24, X8_U24)) + VM_DEFINE_OP (1, call, "call", OP2 (X8_F24, X8_C24)) { scm_t_uint32 proc, nlocals; union scm_vm_stack_element *old_fp; @@ -593,7 +598,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * the current IP. Since PROC is not dereferenced, it may be some * other representation of the closure. */ - VM_DEFINE_OP (2, call_label, "call-label", OP3 (U8_U24, X8_U24, L32)) + VM_DEFINE_OP (2, call_label, "call-label", OP3 (X8_F24, X8_C24, L32)) { scm_t_uint32 proc, nlocals; scm_t_int32 label; @@ -628,7 +633,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * arguments have already been shuffled into position. Will reset the * frame to NLOCALS. */ - VM_DEFINE_OP (3, tail_call, "tail-call", OP1 (U8_U24)) + VM_DEFINE_OP (3, tail_call, "tail-call", OP1 (X8_C24)) { scm_t_uint32 nlocals; @@ -653,7 +658,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Tail-call a known procedure. As call is to call-label, tail-call * is to tail-call-label. */ - VM_DEFINE_OP (4, tail_call_label, "tail-call-label", OP2 (U8_U24, L32)) + VM_DEFINE_OP (4, tail_call_label, "tail-call-label", OP2 (X8_C24, L32)) { scm_t_uint32 nlocals; scm_t_int32 label; @@ -679,7 +684,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * FROM, shuffled down to start at slot 0. This is part of the * implementation of the call-with-values builtin. */ - VM_DEFINE_OP (5, tail_call_shuffle, "tail-call/shuffle", OP1 (U8_U24)) + VM_DEFINE_OP (5, tail_call_shuffle, "tail-call/shuffle", OP1 (X8_F24)) { scm_t_uint32 n, from, nlocals; @@ -711,7 +716,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * PROC, asserting that the call actually returned at least one * value. Afterwards, resets the frame to NLOCALS locals. */ - VM_DEFINE_OP (6, receive, "receive", OP2 (U8_U12_U12, X8_U24) | OP_DST) + VM_DEFINE_OP (6, receive, "receive", OP2 (X8_F12_F12, X8_C24) | OP_DST) { scm_t_uint16 dst, proc; scm_t_uint32 nlocals; @@ -731,7 +736,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * return values equals NVALUES exactly. After receive-values has * run, the values can be copied down via `mov'. */ - VM_DEFINE_OP (7, receive_values, "receive-values", OP2 (U8_U24, B1_X7_U24)) + VM_DEFINE_OP (7, receive_values, "receive-values", OP2 (X8_F24, B1_X7_C24)) { scm_t_uint32 proc, nvalues; UNPACK_24 (op, proc); @@ -749,7 +754,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Return a value. */ - VM_DEFINE_OP (8, return, "return", OP1 (U8_U24)) + VM_DEFINE_OP (8, return, "return", OP1 (X8_S24)) { scm_t_uint32 src; UNPACK_24 (op, src); @@ -764,7 +769,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * shuffled down to a contiguous array starting at slot 1. * We also expect the frame has already been reset. */ - VM_DEFINE_OP (9, return_values, "return-values", OP1 (U8_X24)) + VM_DEFINE_OP (9, return_values, "return-values", OP1 (X32)) { union scm_vm_stack_element *old_fp; @@ -798,7 +803,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * calling frame. This instruction is part of the trampolines * created in gsubr.c, and is not generated by the compiler. */ - VM_DEFINE_OP (10, subr_call, "subr-call", OP1 (U8_U24)) + VM_DEFINE_OP (10, subr_call, "subr-call", OP1 (X8_C24)) { scm_t_uint32 ptr_idx; SCM pointer, ret; @@ -879,7 +884,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * part of the trampolines created by the FFI, and is not generated by * the compiler. */ - VM_DEFINE_OP (11, foreign_call, "foreign-call", OP1 (U8_U12_U12)) + VM_DEFINE_OP (11, foreign_call, "foreign-call", OP1 (X8_C12_C12)) { scm_t_uint16 cif_idx, ptr_idx; SCM closure, cif, pointer, ret; @@ -913,7 +918,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * the implementation of undelimited continuations, and is not * generated by the compiler. */ - VM_DEFINE_OP (12, continuation_call, "continuation-call", OP1 (U8_U24)) + VM_DEFINE_OP (12, continuation_call, "continuation-call", OP1 (X8_C24)) { SCM contregs; scm_t_uint32 contregs_idx; @@ -943,7 +948,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * instruction is part of the implementation of partial continuations, * and is not generated by the compiler. */ - VM_DEFINE_OP (13, compose_continuation, "compose-continuation", OP1 (U8_U24)) + VM_DEFINE_OP (13, compose_continuation, "compose-continuation", OP1 (X8_C24)) { SCM vmcont; scm_t_uint32 cont_idx; @@ -966,7 +971,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * arguments. This instruction is part of the implementation of * `apply', and is not generated by the compiler. */ - VM_DEFINE_OP (14, tail_apply, "tail-apply", OP1 (U8_X24)) + VM_DEFINE_OP (14, tail_apply, "tail-apply", OP1 (X32)) { int i, list_idx, list_len, nlocals; SCM list; @@ -1012,7 +1017,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * local slot 1 to it. This instruction is part of the implementation * of `call/cc', and is not generated by the compiler. */ - VM_DEFINE_OP (15, call_cc, "call/cc", OP1 (U8_X24)) + VM_DEFINE_OP (15, call_cc, "call/cc", OP1 (X32)) { SCM vm_cont, cont; scm_t_dynstack *dynstack; @@ -1064,7 +1069,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * of the values in the frame are returned to the prompt handler. * This corresponds to a tail application of abort-to-prompt. */ - VM_DEFINE_OP (16, abort, "abort", OP1 (U8_X24)) + VM_DEFINE_OP (16, abort, "abort", OP1 (X32)) { scm_t_uint32 nlocals = FRAME_LOCALS_COUNT (); @@ -1084,7 +1089,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Load a builtin stub by index into DST. */ - VM_DEFINE_OP (17, builtin_ref, "builtin-ref", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (17, builtin_ref, "builtin-ref", OP1 (X8_S12_C12) | OP_DST) { scm_t_uint16 dst, idx; @@ -1109,15 +1114,15 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * than EXPECTED, respectively, add OFFSET, a signed 24-bit number, to * the current instruction pointer. */ - VM_DEFINE_OP (18, br_if_nargs_ne, "br-if-nargs-ne", OP2 (U8_U24, X8_L24)) + VM_DEFINE_OP (18, br_if_nargs_ne, "br-if-nargs-ne", OP2 (X8_C24, X8_L24)) { BR_NARGS (!=); } - VM_DEFINE_OP (19, br_if_nargs_lt, "br-if-nargs-lt", OP2 (U8_U24, X8_L24)) + VM_DEFINE_OP (19, br_if_nargs_lt, "br-if-nargs-lt", OP2 (X8_C24, X8_L24)) { BR_NARGS (<); } - VM_DEFINE_OP (20, br_if_nargs_gt, "br-if-nargs-gt", OP2 (U8_U24, X8_L24)) + VM_DEFINE_OP (20, br_if_nargs_gt, "br-if-nargs-gt", OP2 (X8_C24, X8_L24)) { BR_NARGS (>); } @@ -1129,7 +1134,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * If the number of actual arguments is not ==, >=, or <= EXPECTED, * respectively, signal an error. */ - VM_DEFINE_OP (21, assert_nargs_ee, "assert-nargs-ee", OP1 (U8_U24)) + VM_DEFINE_OP (21, assert_nargs_ee, "assert-nargs-ee", OP1 (X8_C24)) { scm_t_uint32 expected; UNPACK_24 (op, expected); @@ -1137,7 +1142,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, vm_error_wrong_num_args (LOCAL_REF (0))); NEXT (1); } - VM_DEFINE_OP (22, assert_nargs_ge, "assert-nargs-ge", OP1 (U8_U24)) + VM_DEFINE_OP (22, assert_nargs_ge, "assert-nargs-ge", OP1 (X8_C24)) { scm_t_uint32 expected; UNPACK_24 (op, expected); @@ -1145,7 +1150,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, vm_error_wrong_num_args (LOCAL_REF (0))); NEXT (1); } - VM_DEFINE_OP (23, assert_nargs_le, "assert-nargs-le", OP1 (U8_U24)) + VM_DEFINE_OP (23, assert_nargs_le, "assert-nargs-le", OP1 (X8_C24)) { scm_t_uint32 expected; UNPACK_24 (op, expected); @@ -1160,7 +1165,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * setting them all to SCM_UNDEFINED, except those nargs values that * were passed as arguments and procedure. */ - VM_DEFINE_OP (24, alloc_frame, "alloc-frame", OP1 (U8_U24)) + VM_DEFINE_OP (24, alloc_frame, "alloc-frame", OP1 (X8_C24)) { scm_t_uint32 nlocals, nargs; UNPACK_24 (op, nlocals); @@ -1179,7 +1184,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Used to reset the frame size to something less than the size that * was previously set via alloc-frame. */ - VM_DEFINE_OP (25, reset_frame, "reset-frame", OP1 (U8_U24)) + VM_DEFINE_OP (25, reset_frame, "reset-frame", OP1 (X8_C24)) { scm_t_uint32 nlocals; UNPACK_24 (op, nlocals); @@ -1187,12 +1192,57 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (1); } + /* push src:24 + * + * Push SRC onto the stack. + */ + VM_DEFINE_OP (26, push, "push", OP1 (X8_S24)) + { + scm_t_uint32 src; + SCM val; + + UNPACK_24 (op, src); + val = SP_REF (src); + ALLOC_FRAME (FRAME_LOCALS_COUNT () + 1); + SP_SET (0, val); + NEXT (1); + } + + /* pop dst:24 + * + * Pop the stack, storing to DST. + */ + VM_DEFINE_OP (27, pop, "pop", OP1 (X8_S24) | OP_DST) + { + scm_t_uint32 dst; + SCM val; + + UNPACK_24 (op, dst); + val = SP_REF (0); + vp->sp++; + SP_SET (dst, val); + NEXT (1); + } + + /* drop count:24 + * + * Drop some number of values from the stack. + */ + VM_DEFINE_OP (28, drop, "drop", OP1 (X8_C24)) + { + scm_t_uint32 count; + + UNPACK_24 (op, count); + vp->sp += count; + NEXT (1); + } + /* assert-nargs-ee/locals expected:12 nlocals:12 * * Equivalent to a sequence of assert-nargs-ee and reserve-locals. The * number of locals reserved is EXPECTED + NLOCALS. */ - VM_DEFINE_OP (26, assert_nargs_ee_locals, "assert-nargs-ee/locals", OP1 (U8_U12_U12)) + VM_DEFINE_OP (29, assert_nargs_ee_locals, "assert-nargs-ee/locals", OP1 (X8_C12_C12)) { scm_t_uint16 expected, nlocals; UNPACK_12_12 (op, expected, nlocals); @@ -1215,7 +1265,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * See "Case-lambda" in the manual, for more on how case-lambda * chooses the clause to apply. */ - VM_DEFINE_OP (27, br_if_npos_gt, "br-if-npos-gt", OP3 (U8_U24, X8_U24, X8_L24)) + VM_DEFINE_OP (30, br_if_npos_gt, "br-if-npos-gt", OP3 (X8_C24, X8_C24, X8_L24)) { scm_t_uint32 nreq, npos; @@ -1253,7 +1303,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * A macro-mega-instruction. */ - VM_DEFINE_OP (28, bind_kwargs, "bind-kwargs", OP4 (U8_U24, U8_U24, X8_U24, N32)) + VM_DEFINE_OP (31, bind_kwargs, "bind-kwargs", OP4 (X8_C24, C8_C24, X8_C24, N32)) { scm_t_uint32 nreq, nreq_and_opt, ntotal, npositional, nkw, n, nargs; scm_t_int32 kw_offset; @@ -1339,7 +1389,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Collect any arguments at or above DST into a list, and store that * list at DST. */ - VM_DEFINE_OP (29, bind_rest, "bind-rest", OP1 (U8_U24) | OP_DST) + VM_DEFINE_OP (32, bind_rest, "bind-rest", OP1 (X8_F24) | OP_DST) { scm_t_uint32 dst, nargs; SCM rest = SCM_EOL; @@ -1381,7 +1431,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Add OFFSET, a signed 24-bit number, to the current instruction * pointer. */ - VM_DEFINE_OP (30, br, "br", OP1 (U8_L24)) + VM_DEFINE_OP (33, br, "br", OP1 (X8_L24)) { scm_t_int32 offset = op; offset >>= 8; /* Sign-extending shift. */ @@ -1395,7 +1445,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * If the value in TEST is true for the purposes of Scheme, add * OFFSET, a signed 24-bit number, to the current instruction pointer. */ - VM_DEFINE_OP (31, br_if_true, "br-if-true", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (34, br_if_true, "br-if-true", OP2 (X8_S24, B1_X7_L24)) { BR_UNARY (x, scm_is_true (x)); } @@ -1405,7 +1455,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * If the value in TEST is the end-of-list or Lisp nil, add OFFSET, a * signed 24-bit number, to the current instruction pointer. */ - VM_DEFINE_OP (32, br_if_null, "br-if-null", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (35, br_if_null, "br-if-null", OP2 (X8_S24, B1_X7_L24)) { BR_UNARY (x, scm_is_null (x)); } @@ -1415,7 +1465,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * If the value in TEST is false to Lisp, add OFFSET, a signed 24-bit * number, to the current instruction pointer. */ - VM_DEFINE_OP (33, br_if_nil, "br-if-nil", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (36, br_if_nil, "br-if-nil", OP2 (X8_S24, B1_X7_L24)) { BR_UNARY (x, scm_is_lisp_false (x)); } @@ -1425,7 +1475,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * If the value in TEST is a pair, add OFFSET, a signed 24-bit number, * to the current instruction pointer. */ - VM_DEFINE_OP (34, br_if_pair, "br-if-pair", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (37, br_if_pair, "br-if-pair", OP2 (X8_S24, B1_X7_L24)) { BR_UNARY (x, scm_is_pair (x)); } @@ -1435,7 +1485,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * If the value in TEST is a struct, add OFFSET, a signed 24-bit * number, to the current instruction pointer. */ - VM_DEFINE_OP (35, br_if_struct, "br-if-struct", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (38, br_if_struct, "br-if-struct", OP2 (X8_S24, B1_X7_L24)) { BR_UNARY (x, SCM_STRUCTP (x)); } @@ -1445,7 +1495,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * If the value in TEST is a char, add OFFSET, a signed 24-bit number, * to the current instruction pointer. */ - VM_DEFINE_OP (36, br_if_char, "br-if-char", OP2 (U8_U24, B1_X7_L24)) + VM_DEFINE_OP (39, br_if_char, "br-if-char", OP2 (X8_S24, B1_X7_L24)) { BR_UNARY (x, SCM_CHARP (x)); } @@ -1455,7 +1505,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * If the value in TEST has the TC7 given in the second word, add * OFFSET, a signed 24-bit number, to the current instruction pointer. */ - VM_DEFINE_OP (37, br_if_tc7, "br-if-tc7", OP2 (U8_U24, B1_U7_L24)) + VM_DEFINE_OP (40, br_if_tc7, "br-if-tc7", OP2 (X8_S24, B1_C7_L24)) { BR_UNARY (x, SCM_HAS_TYP7 (x, (ip[1] >> 1) & 0x7f)); } @@ -1465,7 +1515,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * If the value in A is eq? to the value in B, add OFFSET, a signed * 24-bit number, to the current instruction pointer. */ - VM_DEFINE_OP (38, br_if_eq, "br-if-eq", OP2 (U8_U12_U12, B1_X7_L24)) + VM_DEFINE_OP (41, br_if_eq, "br-if-eq", OP3 (X8_S24, X8_S24, B1_X7_L24)) { BR_BINARY (x, y, scm_is_eq (x, y)); } @@ -1475,7 +1525,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * If the value in A is eqv? to the value in B, add OFFSET, a signed * 24-bit number, to the current instruction pointer. */ - VM_DEFINE_OP (39, br_if_eqv, "br-if-eqv", OP2 (U8_U12_U12, B1_X7_L24)) + VM_DEFINE_OP (42, br_if_eqv, "br-if-eqv", OP3 (X8_S24, X8_S24, B1_X7_L24)) { BR_BINARY (x, y, scm_is_eq (x, y) @@ -1491,7 +1541,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, */ // FIXME: Should sync_ip before calling out and cache_locals before coming // back! Another reason to remove this opcode! - VM_DEFINE_OP (40, br_if_equal, "br-if-equal", OP2 (U8_U12_U12, B1_X7_L24)) + VM_DEFINE_OP (43, br_if_equal, "br-if-equal", OP3 (X8_S24, X8_S24, B1_X7_L24)) { BR_BINARY (x, y, scm_is_eq (x, y) @@ -1499,12 +1549,26 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, && scm_is_true (scm_equal_p (x, y)))); } + /* br-if-logtest a:24 _:8 b:24 invert:1 _:7 offset:24 + * + * If the exact integer in A has any bits in common with the exact + * integer in B, add OFFSET, a signed 24-bit number, to the current + * instruction pointer. + */ + VM_DEFINE_OP (44, br_if_logtest, "br-if-logtest", OP3 (X8_S24, X8_S24, B1_X7_L24)) + { + BR_BINARY (x, y, + ((SCM_I_INUMP (x) && SCM_I_INUMP (y)) + ? (SCM_UNPACK (x) & SCM_UNPACK (y) & ~scm_tc2_int) + : scm_is_true (scm_logtest (x, y)))); + } + /* br-if-= a:12 b:12 invert:1 _:7 offset:24 * * If the value in A is = to the value in B, add OFFSET, a signed * 24-bit number, to the current instruction pointer. */ - VM_DEFINE_OP (41, br_if_ee, "br-if-=", OP2 (U8_U12_U12, B1_X7_L24)) + VM_DEFINE_OP (45, br_if_ee, "br-if-=", OP3 (X8_S24, X8_S24, B1_X7_L24)) { BR_ARITHMETIC (==, scm_num_eq_p); } @@ -1514,7 +1578,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * If the value in A is < to the value in B, add OFFSET, a signed * 24-bit number, to the current instruction pointer. */ - VM_DEFINE_OP (42, br_if_lt, "br-if-<", OP2 (U8_U12_U12, B1_X7_L24)) + VM_DEFINE_OP (46, br_if_lt, "br-if-<", OP3 (X8_S24, X8_S24, B1_X7_L24)) { BR_ARITHMETIC (<, scm_less_p); } @@ -1524,7 +1588,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * If the value in A is <= to the value in B, add OFFSET, a signed * 24-bit number, to the current instruction pointer. */ - VM_DEFINE_OP (43, br_if_le, "br-if-<=", OP2 (U8_U12_U12, B1_X7_L24)) + VM_DEFINE_OP (47, br_if_le, "br-if-<=", OP3 (X8_S24, X8_S24, B1_X7_L24)) { BR_ARITHMETIC (<=, scm_leq_p); } @@ -1540,7 +1604,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Copy a value from one local slot to another. */ - VM_DEFINE_OP (44, mov, "mov", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (48, mov, "mov", OP1 (X8_S12_S12) | OP_DST) { scm_t_uint16 dst; scm_t_uint16 src; @@ -1555,7 +1619,24 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Copy a value from one local slot to another. */ - VM_DEFINE_OP (45, long_mov, "long-mov", OP2 (U8_U24, X8_U24) | OP_DST) + VM_DEFINE_OP (49, long_mov, "long-mov", OP2 (X8_S24, X8_S24) | OP_DST) + { + scm_t_uint32 dst; + scm_t_uint32 src; + + UNPACK_24 (op, dst); + UNPACK_24 (ip[1], src); + LOCAL_SET (dst, LOCAL_REF (src)); + + NEXT (2); + } + + /* long-fmov dst:24 _:8 src:24 + * + * Copy a value from one local slot to another. Slot indexes are + * relative to the FP. + */ + VM_DEFINE_OP (50, long_fmov, "long-fmov", OP2 (X8_F24, X8_F24) | OP_DST) { scm_t_uint32 dst; scm_t_uint32 src; @@ -1571,7 +1652,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Create a new variable holding SRC, and place it in DST. */ - VM_DEFINE_OP (46, box, "box", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (51, box, "box", OP1 (X8_S12_S12) | OP_DST) { scm_t_uint16 dst, src; UNPACK_12_12 (op, dst, src); @@ -1585,7 +1666,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Unpack the variable at SRC into DST, asserting that the variable is * actually bound. */ - VM_DEFINE_OP (47, box_ref, "box-ref", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (52, box_ref, "box-ref", OP1 (X8_S12_S12) | OP_DST) { scm_t_uint16 dst, src; SCM var; @@ -1602,7 +1683,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Set the contents of the variable at DST to SET. */ - VM_DEFINE_OP (48, box_set, "box-set!", OP1 (U8_U12_U12)) + VM_DEFINE_OP (53, box_set, "box-set!", OP1 (X8_S12_S12)) { scm_t_uint16 dst, src; SCM var; @@ -1621,7 +1702,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * signed 32-bit integer. Space for NFREE free variables will be * allocated. */ - VM_DEFINE_OP (49, make_closure, "make-closure", OP3 (U8_U24, L32, X8_U24) | OP_DST) + VM_DEFINE_OP (54, make_closure, "make-closure", OP3 (X8_S24, L32, X8_C24) | OP_DST) { scm_t_uint32 dst, nfree, n; scm_t_int32 offset; @@ -1646,7 +1727,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Load free variable IDX from the closure SRC into local slot DST. */ - VM_DEFINE_OP (50, free_ref, "free-ref", OP2 (U8_U12_U12, X8_U24) | OP_DST) + VM_DEFINE_OP (55, free_ref, "free-ref", OP2 (X8_S12_S12, X8_C24) | OP_DST) { scm_t_uint16 dst, src; scm_t_uint32 idx; @@ -1661,7 +1742,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Set free variable IDX from the closure DST to SRC. */ - VM_DEFINE_OP (51, free_set, "free-set!", OP2 (U8_U12_U12, X8_U24)) + VM_DEFINE_OP (56, free_set, "free-set!", OP2 (X8_S12_S12, X8_C24)) { scm_t_uint16 dst, src; scm_t_uint32 idx; @@ -1684,7 +1765,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Make an immediate whose low bits are LOW-BITS, and whose top bits are * 0. */ - VM_DEFINE_OP (52, make_short_immediate, "make-short-immediate", OP1 (U8_U8_I16) | OP_DST) + VM_DEFINE_OP (57, make_short_immediate, "make-short-immediate", OP1 (X8_S8_I16) | OP_DST) { scm_t_uint8 dst; scm_t_bits val; @@ -1699,7 +1780,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Make an immediate whose low bits are LOW-BITS, and whose top bits are * 0. */ - VM_DEFINE_OP (53, make_long_immediate, "make-long-immediate", OP2 (U8_U24, I32) | OP_DST) + VM_DEFINE_OP (58, make_long_immediate, "make-long-immediate", OP2 (X8_S24, I32) | OP_DST) { scm_t_uint32 dst; scm_t_bits val; @@ -1714,7 +1795,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Make an immediate with HIGH-BITS and LOW-BITS. */ - VM_DEFINE_OP (54, make_long_long_immediate, "make-long-long-immediate", OP3 (U8_U24, A32, B32) | OP_DST) + VM_DEFINE_OP (59, make_long_long_immediate, "make-long-long-immediate", OP3 (X8_S24, A32, B32) | OP_DST) { scm_t_uint32 dst; scm_t_bits val; @@ -1745,7 +1826,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Whether the object is mutable or immutable depends on where it was * allocated by the compiler, and loaded by the loader. */ - VM_DEFINE_OP (55, make_non_immediate, "make-non-immediate", OP2 (U8_U24, N32) | OP_DST) + VM_DEFINE_OP (60, make_non_immediate, "make-non-immediate", OP2 (X8_S24, N32) | OP_DST) { scm_t_uint32 dst; scm_t_int32 offset; @@ -1774,7 +1855,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * that the compiler is unable to statically allocate, like symbols. * These values would be initialized when the object file loads. */ - VM_DEFINE_OP (56, static_ref, "static-ref", OP2 (U8_U24, S32) | OP_DST) + VM_DEFINE_OP (61, static_ref, "static-ref", OP2 (X8_S24, R32) | OP_DST) { scm_t_uint32 dst; scm_t_int32 offset; @@ -1797,7 +1878,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Store a SCM value into memory, OFFSET 32-bit words away from the * current instruction pointer. OFFSET is a signed value. */ - VM_DEFINE_OP (57, static_set, "static-set!", OP2 (U8_U24, LO32)) + VM_DEFINE_OP (62, static_set, "static-set!", OP2 (X8_S24, LO32)) { scm_t_uint32 src; scm_t_int32 offset; @@ -1819,7 +1900,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * are signed 32-bit values, indicating a memory address as a number * of 32-bit words away from the current instruction pointer. */ - VM_DEFINE_OP (58, static_patch, "static-patch!", OP3 (U8_X24, LO32, L32)) + VM_DEFINE_OP (63, static_patch, "static-patch!", OP3 (X32, LO32, L32)) { scm_t_int32 dst_offset, src_offset; void *src; @@ -1877,7 +1958,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Store the current module in DST. */ - VM_DEFINE_OP (59, current_module, "current-module", OP1 (U8_U24) | OP_DST) + VM_DEFINE_OP (64, current_module, "current-module", OP1 (X8_S24) | OP_DST) { scm_t_uint32 dst; @@ -1894,7 +1975,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Resolve SYM in the current module, and place the resulting variable * in DST. */ - VM_DEFINE_OP (60, resolve, "resolve", OP2 (U8_U24, B1_X7_U24) | OP_DST) + VM_DEFINE_OP (65, resolve, "resolve", OP2 (X8_S24, B1_X7_S24) | OP_DST) { scm_t_uint32 dst; scm_t_uint32 sym; @@ -1918,7 +1999,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Look up a binding for SYM in the current module, creating it if * necessary. Set its value to VAL. */ - VM_DEFINE_OP (61, define, "define!", OP1 (U8_U12_U12)) + VM_DEFINE_OP (66, define, "define!", OP1 (X8_S12_S12)) { scm_t_uint16 sym, val; UNPACK_12_12 (op, sym, val); @@ -1947,7 +2028,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * DST, and caching the resolved variable so that we will hit the cache next * time. */ - VM_DEFINE_OP (62, toplevel_box, "toplevel-box", OP5 (U8_U24, S32, S32, N32, B1_X31) | OP_DST) + VM_DEFINE_OP (67, toplevel_box, "toplevel-box", OP5 (X8_S24, R32, R32, N32, B1_X31) | OP_DST) { scm_t_uint32 dst; scm_t_int32 var_offset; @@ -2000,7 +2081,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Like toplevel-box, except MOD-OFFSET points at the name of a module * instead of the module itself. */ - VM_DEFINE_OP (63, module_box, "module-box", OP5 (U8_U24, S32, N32, N32, B1_X31) | OP_DST) + VM_DEFINE_OP (68, module_box, "module-box", OP5 (X8_S24, R32, N32, N32, B1_X31) | OP_DST) { scm_t_uint32 dst; scm_t_int32 var_offset; @@ -2070,7 +2151,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * will expect a multiple-value return as if from a call with the * procedure at PROC-SLOT. */ - VM_DEFINE_OP (64, prompt, "prompt", OP3 (U8_U24, B1_X7_U24, X8_L24)) + VM_DEFINE_OP (69, prompt, "prompt", OP3 (X8_S24, B1_X7_F24, X8_L24)) { scm_t_uint32 tag, proc_slot; scm_t_int32 offset; @@ -2102,7 +2183,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * the compiler should have inserted checks that they wind and unwind * procs are thunks, if it could not prove that to be the case. */ - VM_DEFINE_OP (65, wind, "wind", OP1 (U8_U12_U12)) + VM_DEFINE_OP (70, wind, "wind", OP1 (X8_S12_S12)) { scm_t_uint16 winder, unwinder; UNPACK_12_12 (op, winder, unwinder); @@ -2116,7 +2197,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * A normal exit from the dynamic extent of an expression. Pop the top * entry off of the dynamic stack. */ - VM_DEFINE_OP (66, unwind, "unwind", OP1 (U8_X24)) + VM_DEFINE_OP (71, unwind, "unwind", OP1 (X32)) { scm_dynstack_pop (&thread->dynstack); NEXT (1); @@ -2126,7 +2207,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Dynamically bind VALUE to FLUID. */ - VM_DEFINE_OP (67, push_fluid, "push-fluid", OP1 (U8_U12_U12)) + VM_DEFINE_OP (72, push_fluid, "push-fluid", OP1 (X8_S12_S12)) { scm_t_uint32 fluid, value; @@ -2143,7 +2224,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Leave the dynamic extent of a with-fluid* expression, restoring the * fluid to its previous value. */ - VM_DEFINE_OP (68, pop_fluid, "pop-fluid", OP1 (U8_X24)) + VM_DEFINE_OP (73, pop_fluid, "pop-fluid", OP1 (X32)) { /* This function must not allocate. */ scm_dynstack_unwind_fluid (&thread->dynstack, @@ -2155,7 +2236,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Reference the fluid in SRC, and place the value in DST. */ - VM_DEFINE_OP (69, fluid_ref, "fluid-ref", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (74, fluid_ref, "fluid-ref", OP1 (X8_S12_S12) | OP_DST) { scm_t_uint16 dst, src; size_t num; @@ -2188,7 +2269,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Set the value of the fluid in DST to the value in SRC. */ - VM_DEFINE_OP (70, fluid_set, "fluid-set", OP1 (U8_U12_U12)) + VM_DEFINE_OP (75, fluid_set, "fluid-set", OP1 (X8_S12_S12)) { scm_t_uint16 a, b; size_t num; @@ -2221,7 +2302,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Store the length of the string in SRC in DST. */ - VM_DEFINE_OP (71, string_length, "string-length", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (76, string_length, "string-length", OP1 (X8_S12_S12) | OP_DST) { ARGS1 (str); if (SCM_LIKELY (scm_is_string (str))) @@ -2238,7 +2319,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Fetch the character at position IDX in the string in SRC, and store * it in DST. */ - VM_DEFINE_OP (72, string_ref, "string-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (77, string_ref, "string-ref", OP1 (X8_S8_S8_S8) | OP_DST) { scm_t_signed_bits i = 0; ARGS2 (str, idx); @@ -2260,7 +2341,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Parse a string in SRC to a number, and store in DST. */ - VM_DEFINE_OP (73, string_to_number, "string->number", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (78, string_to_number, "string->number", OP1 (X8_S12_S12) | OP_DST) { scm_t_uint16 dst, src; @@ -2276,7 +2357,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Parse a string in SRC to a symbol, and store in DST. */ - VM_DEFINE_OP (74, string_to_symbol, "string->symbol", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (79, string_to_symbol, "string->symbol", OP1 (X8_S12_S12) | OP_DST) { scm_t_uint16 dst, src; @@ -2290,7 +2371,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Make a keyword from the symbol in SRC, and store it in DST. */ - VM_DEFINE_OP (75, symbol_to_keyword, "symbol->keyword", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (80, symbol_to_keyword, "symbol->keyword", OP1 (X8_S12_S12) | OP_DST) { scm_t_uint16 dst, src; UNPACK_12_12 (op, dst, src); @@ -2309,7 +2390,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Cons CAR and CDR, and store the result in DST. */ - VM_DEFINE_OP (76, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (81, cons, "cons", OP1 (X8_S8_S8_S8) | OP_DST) { ARGS2 (x, y); RETURN (scm_inline_cons (thread, x, y)); @@ -2319,7 +2400,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Place the car of SRC in DST. */ - VM_DEFINE_OP (77, car, "car", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (82, car, "car", OP1 (X8_S12_S12) | OP_DST) { ARGS1 (x); VM_VALIDATE_PAIR (x, "car"); @@ -2330,7 +2411,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Place the cdr of SRC in DST. */ - VM_DEFINE_OP (78, cdr, "cdr", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (83, cdr, "cdr", OP1 (X8_S12_S12) | OP_DST) { ARGS1 (x); VM_VALIDATE_PAIR (x, "cdr"); @@ -2341,7 +2422,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Set the car of DST to SRC. */ - VM_DEFINE_OP (79, set_car, "set-car!", OP1 (U8_U12_U12)) + VM_DEFINE_OP (84, set_car, "set-car!", OP1 (X8_S12_S12)) { scm_t_uint16 a, b; SCM x, y; @@ -2357,7 +2438,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Set the cdr of DST to SRC. */ - VM_DEFINE_OP (80, set_cdr, "set-cdr!", OP1 (U8_U12_U12)) + VM_DEFINE_OP (85, set_cdr, "set-cdr!", OP1 (X8_S12_S12)) { scm_t_uint16 a, b; SCM x, y; @@ -2380,7 +2461,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Add A to B, and place the result in DST. */ - VM_DEFINE_OP (81, add, "add", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (86, add, "add", OP1 (X8_S8_S8_S8) | OP_DST) { BINARY_INTEGER_OP (+, scm_sum); } @@ -2389,7 +2470,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Add 1 to the value in SRC, and place the result in DST. */ - VM_DEFINE_OP (82, add1, "add1", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (87, add1, "add1", OP1 (X8_S12_S12) | OP_DST) { ARGS1 (x); @@ -2413,7 +2494,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Subtract B from A, and place the result in DST. */ - VM_DEFINE_OP (83, sub, "sub", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (88, sub, "sub", OP1 (X8_S8_S8_S8) | OP_DST) { BINARY_INTEGER_OP (-, scm_difference); } @@ -2422,7 +2503,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Subtract 1 from SRC, and place the result in DST. */ - VM_DEFINE_OP (84, sub1, "sub1", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (89, sub1, "sub1", OP1 (X8_S12_S12) | OP_DST) { ARGS1 (x); @@ -2446,7 +2527,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Multiply A and B, and place the result in DST. */ - VM_DEFINE_OP (85, mul, "mul", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (90, mul, "mul", OP1 (X8_S8_S8_S8) | OP_DST) { ARGS2 (x, y); RETURN_EXP (scm_product (x, y)); @@ -2456,7 +2537,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Divide A by B, and place the result in DST. */ - VM_DEFINE_OP (86, div, "div", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (91, div, "div", OP1 (X8_S8_S8_S8) | OP_DST) { ARGS2 (x, y); RETURN_EXP (scm_divide (x, y)); @@ -2466,7 +2547,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Divide A by B, and place the quotient in DST. */ - VM_DEFINE_OP (87, quo, "quo", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (92, quo, "quo", OP1 (X8_S8_S8_S8) | OP_DST) { ARGS2 (x, y); RETURN_EXP (scm_quotient (x, y)); @@ -2476,7 +2557,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Divide A by B, and place the remainder in DST. */ - VM_DEFINE_OP (88, rem, "rem", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (93, rem, "rem", OP1 (X8_S8_S8_S8) | OP_DST) { ARGS2 (x, y); RETURN_EXP (scm_remainder (x, y)); @@ -2486,7 +2567,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Place the modulo of A by B in DST. */ - VM_DEFINE_OP (89, mod, "mod", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (94, mod, "mod", OP1 (X8_S8_S8_S8) | OP_DST) { ARGS2 (x, y); RETURN_EXP (scm_modulo (x, y)); @@ -2496,7 +2577,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Shift A arithmetically by B bits, and place the result in DST. */ - VM_DEFINE_OP (90, ash, "ash", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (95, ash, "ash", OP1 (X8_S8_S8_S8) | OP_DST) { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) @@ -2533,7 +2614,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Place the bitwise AND of A and B into DST. */ - VM_DEFINE_OP (91, logand, "logand", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (96, logand, "logand", OP1 (X8_S8_S8_S8) | OP_DST) { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) @@ -2546,7 +2627,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Place the bitwise inclusive OR of A with B in DST. */ - VM_DEFINE_OP (92, logior, "logior", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (97, logior, "logior", OP1 (X8_S8_S8_S8) | OP_DST) { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) @@ -2559,7 +2640,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Place the bitwise exclusive OR of A with B in DST. */ - VM_DEFINE_OP (93, logxor, "logxor", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (98, logxor, "logxor", OP1 (X8_S8_S8_S8) | OP_DST) { ARGS2 (x, y); if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) @@ -2572,7 +2653,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Make a vector and write it to DST. The vector will have space for * LENGTH slots. They will be filled with the value in slot INIT. */ - VM_DEFINE_OP (94, make_vector, "make-vector", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (99, make_vector, "make-vector", OP1 (X8_S8_S8_S8) | OP_DST) { scm_t_uint8 dst, init, length; @@ -2589,7 +2670,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * will have space for LENGTH slots, an immediate value. They will be * filled with the value in slot INIT. */ - VM_DEFINE_OP (95, make_vector_immediate, "make-vector/immediate", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (100, make_vector_immediate, "make-vector/immediate", OP1 (X8_S8_C8_S8) | OP_DST) { scm_t_uint8 dst, init; scm_t_int32 length, n; @@ -2610,7 +2691,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Store the length of the vector in SRC in DST. */ - VM_DEFINE_OP (96, vector_length, "vector-length", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (101, vector_length, "vector-length", OP1 (X8_S12_S12) | OP_DST) { ARGS1 (vect); VM_ASSERT (SCM_I_IS_VECTOR (vect), @@ -2623,7 +2704,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Fetch the item at position IDX in the vector in SRC, and store it * in DST. */ - VM_DEFINE_OP (97, vector_ref, "vector-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (102, vector_ref, "vector-ref", OP1 (X8_S8_S8_S8) | OP_DST) { scm_t_signed_bits i = 0; ARGS2 (vect, idx); @@ -2641,7 +2722,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Fill DST with the item IDX elements into the vector at SRC. Useful * for building data types using vectors. */ - VM_DEFINE_OP (98, vector_ref_immediate, "vector-ref/immediate", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (103, vector_ref_immediate, "vector-ref/immediate", OP1 (X8_S8_S8_C8) | OP_DST) { scm_t_uint8 dst, src, idx; SCM v; @@ -2660,7 +2741,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Store SRC into the vector DST at index IDX. */ - VM_DEFINE_OP (99, vector_set, "vector-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (104, vector_set, "vector-set!", OP1 (X8_S8_S8_S8)) { scm_t_uint8 dst, idx_var, src; SCM vect, idx, val; @@ -2686,7 +2767,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Store SRC into the vector DST at index IDX. Here IDX is an * immediate value. */ - VM_DEFINE_OP (100, vector_set_immediate, "vector-set!/immediate", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (105, vector_set_immediate, "vector-set!/immediate", OP1 (X8_S8_C8_S8)) { scm_t_uint8 dst, idx, src; SCM vect, val; @@ -2714,20 +2795,105 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Store the vtable of SRC into DST. */ - VM_DEFINE_OP (101, struct_vtable, "struct-vtable", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (106, struct_vtable, "struct-vtable", OP1 (X8_S12_S12) | OP_DST) { ARGS1 (obj); VM_VALIDATE_STRUCT (obj, "struct_vtable"); RETURN (SCM_STRUCT_VTABLE (obj)); } + /* allocate-struct dst:8 vtable:8 nfields:8 + * + * Allocate a new struct with VTABLE, and place it in DST. The struct + * will be constructed with space for NFIELDS fields, which should + * correspond to the field count of the VTABLE. + */ + VM_DEFINE_OP (107, allocate_struct, "allocate-struct", OP1 (X8_S8_S8_S8) | OP_DST) + { + scm_t_uint8 dst, vtable, nfields; + SCM ret; + + UNPACK_8_8_8 (op, dst, vtable, nfields); + + SYNC_IP (); + ret = scm_allocate_struct (LOCAL_REF (vtable), LOCAL_REF (nfields)); + LOCAL_SET (dst, ret); + + NEXT (1); + } + + /* struct-ref dst:8 src:8 idx:8 + * + * Fetch the item at slot IDX in the struct in SRC, and store it + * in DST. + */ + VM_DEFINE_OP (108, struct_ref, "struct-ref", OP1 (X8_S8_S8_S8) | OP_DST) + { + scm_t_uint8 dst, src, idx; + SCM obj; + SCM index; + + UNPACK_8_8_8 (op, dst, src, idx); + + obj = LOCAL_REF (src); + index = LOCAL_REF (idx); + + if (SCM_LIKELY (SCM_STRUCTP (obj) + && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, + SCM_VTABLE_FLAG_SIMPLE) + && SCM_I_INUMP (index) + && SCM_I_INUM (index) >= 0 + && SCM_I_INUM (index) < (SCM_STRUCT_DATA_REF + (SCM_STRUCT_VTABLE (obj), + scm_vtable_index_size)))) + RETURN (SCM_STRUCT_SLOT_REF (obj, SCM_I_INUM (index))); + + SYNC_IP (); + RETURN (scm_struct_ref (obj, index)); + } + + /* struct-set! dst:8 idx:8 src:8 + * + * Store SRC into the struct DST at slot IDX. + */ + VM_DEFINE_OP (109, struct_set, "struct-set!", OP1 (X8_S8_S8_S8)) + { + scm_t_uint8 dst, idx, src; + SCM obj, val, index; + + UNPACK_8_8_8 (op, dst, idx, src); + + obj = LOCAL_REF (dst); + val = LOCAL_REF (src); + index = LOCAL_REF (idx); + + if (SCM_LIKELY (SCM_STRUCTP (obj) + && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, + SCM_VTABLE_FLAG_SIMPLE) + && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, + SCM_VTABLE_FLAG_SIMPLE_RW) + && SCM_I_INUMP (index) + && SCM_I_INUM (index) >= 0 + && SCM_I_INUM (index) < (SCM_STRUCT_DATA_REF + (SCM_STRUCT_VTABLE (obj), + scm_vtable_index_size)))) + { + SCM_STRUCT_SLOT_SET (obj, SCM_I_INUM (index), val); + NEXT (1); + } + + SYNC_IP (); + scm_struct_set_x (obj, index, val); + NEXT (1); + } + /* allocate-struct/immediate dst:8 vtable:8 nfields:8 * * Allocate a new struct with VTABLE, and place it in DST. The struct * will be constructed with space for NFIELDS fields, which should * correspond to the field count of the VTABLE. */ - VM_DEFINE_OP (102, allocate_struct_immediate, "allocate-struct/immediate", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (110, allocate_struct_immediate, "allocate-struct/immediate", OP1 (X8_S8_S8_C8) | OP_DST) { scm_t_uint8 dst, vtable, nfields; SCM ret; @@ -2746,7 +2912,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Fetch the item at slot IDX in the struct in SRC, and store it * in DST. IDX is an immediate unsigned 8-bit value. */ - VM_DEFINE_OP (103, struct_ref_immediate, "struct-ref/immediate", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (111, struct_ref_immediate, "struct-ref/immediate", OP1 (X8_S8_S8_C8) | OP_DST) { scm_t_uint8 dst, src, idx; SCM obj; @@ -2771,7 +2937,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Store SRC into the struct DST at slot IDX. IDX is an immediate * unsigned 8-bit value. */ - VM_DEFINE_OP (104, struct_set_immediate, "struct-set!/immediate", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (112, struct_set_immediate, "struct-set!/immediate", OP1 (X8_S8_C8_S8)) { scm_t_uint8 dst, idx, src; SCM obj, val; @@ -2802,7 +2968,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Store the vtable of SRC into DST. */ - VM_DEFINE_OP (105, class_of, "class-of", OP1 (U8_U12_U12) | OP_DST) + VM_DEFINE_OP (113, class_of, "class-of", OP1 (X8_S12_S12) | OP_DST) { ARGS1 (obj); if (SCM_INSTANCEP (obj)) @@ -2817,41 +2983,45 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Arrays, packed uniform arrays, and bytevectors. */ - /* load-typed-array dst:8 type:8 shape:8 offset:32 len:32 + /* load-typed-array dst:24 _:8 type:24 _:8 shape:24 offset:32 len:32 * * Load the contiguous typed array located at OFFSET 32-bit words away * from the instruction pointer, and store into DST. LEN is a byte * length. OFFSET is signed. */ - VM_DEFINE_OP (106, load_typed_array, "load-typed-array", OP3 (U8_U8_U8_U8, N32, U32) | OP_DST) + VM_DEFINE_OP (114, load_typed_array, "load-typed-array", OP5 (X8_S24, X8_S24, X8_S24, N32, C32) | OP_DST) { - scm_t_uint8 dst, type, shape; + scm_t_uint32 dst, type, shape; scm_t_int32 offset; scm_t_uint32 len; - UNPACK_8_8_8 (op, dst, type, shape); - offset = ip[1]; - len = ip[2]; + UNPACK_24 (op, dst); + UNPACK_24 (ip[1], type); + UNPACK_24 (ip[2], shape); + offset = ip[3]; + len = ip[4]; SYNC_IP (); LOCAL_SET (dst, scm_from_contiguous_typed_array (LOCAL_REF (type), LOCAL_REF (shape), ip + offset, len)); - NEXT (3); + NEXT (5); } - /* make-array dst:8 type:8 fill:8 _:8 bounds:24 + /* make-array dst:24 _:8 type:24 _:8 fill:24 _:8 bounds:24 * * Make a new array with TYPE, FILL, and BOUNDS, storing it in DST. */ - VM_DEFINE_OP (107, make_array, "make-array", OP2 (U8_U8_U8_U8, X8_U24) | OP_DST) + VM_DEFINE_OP (115, make_array, "make-array", OP4 (X8_S24, X8_S24, X8_S24, X8_S24) | OP_DST) { - scm_t_uint8 dst, type, fill, bounds; - UNPACK_8_8_8 (op, dst, type, fill); - UNPACK_24 (ip[1], bounds); + scm_t_uint32 dst, type, fill, bounds; + UNPACK_24 (op, dst); + UNPACK_24 (ip[1], type); + UNPACK_24 (ip[2], fill); + UNPACK_24 (ip[3], bounds); SYNC_IP (); LOCAL_SET (dst, scm_make_typed_array (LOCAL_REF (type), LOCAL_REF (fill), LOCAL_REF (bounds))); - NEXT (2); + NEXT (4); } /* bv-u8-ref dst:8 src:8 idx:8 @@ -2941,42 +3111,42 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \ } while (0) - VM_DEFINE_OP (108, bv_u8_ref, "bv-u8-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (116, bv_u8_ref, "bv-u8-ref", OP1 (X8_S8_S8_S8) | OP_DST) BV_FIXABLE_INT_REF (u8, u8, uint8, 1); - VM_DEFINE_OP (109, bv_s8_ref, "bv-s8-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (117, bv_s8_ref, "bv-s8-ref", OP1 (X8_S8_S8_S8) | OP_DST) BV_FIXABLE_INT_REF (s8, s8, int8, 1); - VM_DEFINE_OP (110, bv_u16_ref, "bv-u16-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (118, bv_u16_ref, "bv-u16-ref", OP1 (X8_S8_S8_S8) | OP_DST) BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2); - VM_DEFINE_OP (111, bv_s16_ref, "bv-s16-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (119, bv_s16_ref, "bv-s16-ref", OP1 (X8_S8_S8_S8) | OP_DST) BV_FIXABLE_INT_REF (s16, s16_native, int16, 2); - VM_DEFINE_OP (112, bv_u32_ref, "bv-u32-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (120, bv_u32_ref, "bv-u32-ref", OP1 (X8_S8_S8_S8) | OP_DST) #if SIZEOF_VOID_P > 4 BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4); #else BV_INT_REF (u32, uint32, 4); #endif - VM_DEFINE_OP (113, bv_s32_ref, "bv-s32-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (121, bv_s32_ref, "bv-s32-ref", OP1 (X8_S8_S8_S8) | OP_DST) #if SIZEOF_VOID_P > 4 BV_FIXABLE_INT_REF (s32, s32_native, int32, 4); #else BV_INT_REF (s32, int32, 4); #endif - VM_DEFINE_OP (114, bv_u64_ref, "bv-u64-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (122, bv_u64_ref, "bv-u64-ref", OP1 (X8_S8_S8_S8) | OP_DST) BV_INT_REF (u64, uint64, 8); - VM_DEFINE_OP (115, bv_s64_ref, "bv-s64-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (123, bv_s64_ref, "bv-s64-ref", OP1 (X8_S8_S8_S8) | OP_DST) BV_INT_REF (s64, int64, 8); - VM_DEFINE_OP (116, bv_f32_ref, "bv-f32-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (124, bv_f32_ref, "bv-f32-ref", OP1 (X8_S8_S8_S8) | OP_DST) BV_FLOAT_REF (f32, ieee_single, float, 4); - VM_DEFINE_OP (117, bv_f64_ref, "bv-f64-ref", OP1 (U8_U8_U8_U8) | OP_DST) + VM_DEFINE_OP (125, bv_f64_ref, "bv-f64-ref", OP1 (X8_S8_S8_S8) | OP_DST) BV_FLOAT_REF (f64, ieee_double, double, 8); /* bv-u8-set! dst:8 idx:8 src:8 @@ -3080,149 +3250,44 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (1); \ } while (0) - VM_DEFINE_OP (118, bv_u8_set, "bv-u8-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (126, bv_u8_set, "bv-u8-set!", OP1 (X8_S8_S8_S8)) BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1); - VM_DEFINE_OP (119, bv_s8_set, "bv-s8-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (127, bv_s8_set, "bv-s8-set!", OP1 (X8_S8_S8_S8)) BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1); - VM_DEFINE_OP (120, bv_u16_set, "bv-u16-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (128, bv_u16_set, "bv-u16-set!", OP1 (X8_S8_S8_S8)) BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2); - VM_DEFINE_OP (121, bv_s16_set, "bv-s16-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (129, bv_s16_set, "bv-s16-set!", OP1 (X8_S8_S8_S8)) BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2); - VM_DEFINE_OP (122, bv_u32_set, "bv-u32-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (130, bv_u32_set, "bv-u32-set!", OP1 (X8_S8_S8_S8)) #if SIZEOF_VOID_P > 4 BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4); #else BV_INT_SET (u32, uint32, 4); #endif - VM_DEFINE_OP (123, bv_s32_set, "bv-s32-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (131, bv_s32_set, "bv-s32-set!", OP1 (X8_S8_S8_S8)) #if SIZEOF_VOID_P > 4 BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4); #else BV_INT_SET (s32, int32, 4); #endif - VM_DEFINE_OP (124, bv_u64_set, "bv-u64-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (132, bv_u64_set, "bv-u64-set!", OP1 (X8_S8_S8_S8)) BV_INT_SET (u64, uint64, 8); - VM_DEFINE_OP (125, bv_s64_set, "bv-s64-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (133, bv_s64_set, "bv-s64-set!", OP1 (X8_S8_S8_S8)) BV_INT_SET (s64, int64, 8); - VM_DEFINE_OP (126, bv_f32_set, "bv-f32-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (134, bv_f32_set, "bv-f32-set!", OP1 (X8_S8_S8_S8)) BV_FLOAT_SET (f32, ieee_single, float, 4); - VM_DEFINE_OP (127, bv_f64_set, "bv-f64-set!", OP1 (U8_U8_U8_U8)) + VM_DEFINE_OP (135, bv_f64_set, "bv-f64-set!", OP1 (X8_S8_S8_S8)) BV_FLOAT_SET (f64, ieee_double, double, 8); - /* br-if-logtest a:12 b:12 invert:1 _:7 offset:24 - * - * If the exact integer in A has any bits in common with the exact - * integer in B, add OFFSET, a signed 24-bit number, to the current - * instruction pointer. - */ - VM_DEFINE_OP (128, br_if_logtest, "br-if-logtest", OP2 (U8_U12_U12, B1_X7_L24)) - { - BR_BINARY (x, y, - ((SCM_I_INUMP (x) && SCM_I_INUMP (y)) - ? (SCM_UNPACK (x) & SCM_UNPACK (y) & ~scm_tc2_int) - : scm_is_true (scm_logtest (x, y)))); - } - - /* FIXME: Move above */ - - /* allocate-struct dst:8 vtable:8 nfields:8 - * - * Allocate a new struct with VTABLE, and place it in DST. The struct - * will be constructed with space for NFIELDS fields, which should - * correspond to the field count of the VTABLE. - */ - VM_DEFINE_OP (129, allocate_struct, "allocate-struct", OP1 (U8_U8_U8_U8) | OP_DST) - { - scm_t_uint8 dst, vtable, nfields; - SCM ret; - - UNPACK_8_8_8 (op, dst, vtable, nfields); - - SYNC_IP (); - ret = scm_allocate_struct (LOCAL_REF (vtable), LOCAL_REF (nfields)); - LOCAL_SET (dst, ret); - - NEXT (1); - } - - /* struct-ref dst:8 src:8 idx:8 - * - * Fetch the item at slot IDX in the struct in SRC, and store it - * in DST. - */ - VM_DEFINE_OP (130, struct_ref, "struct-ref", OP1 (U8_U8_U8_U8) | OP_DST) - { - scm_t_uint8 dst, src, idx; - SCM obj; - SCM index; - - UNPACK_8_8_8 (op, dst, src, idx); - - obj = LOCAL_REF (src); - index = LOCAL_REF (idx); - - if (SCM_LIKELY (SCM_STRUCTP (obj) - && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, - SCM_VTABLE_FLAG_SIMPLE) - && SCM_I_INUMP (index) - && SCM_I_INUM (index) >= 0 - && SCM_I_INUM (index) < (SCM_STRUCT_DATA_REF - (SCM_STRUCT_VTABLE (obj), - scm_vtable_index_size)))) - RETURN (SCM_STRUCT_SLOT_REF (obj, SCM_I_INUM (index))); - - SYNC_IP (); - RETURN (scm_struct_ref (obj, index)); - } - - /* struct-set! dst:8 idx:8 src:8 - * - * Store SRC into the struct DST at slot IDX. - */ - VM_DEFINE_OP (131, struct_set, "struct-set!", OP1 (U8_U8_U8_U8)) - { - scm_t_uint8 dst, idx, src; - SCM obj, val, index; - - UNPACK_8_8_8 (op, dst, idx, src); - - obj = LOCAL_REF (dst); - val = LOCAL_REF (src); - index = LOCAL_REF (idx); - - if (SCM_LIKELY (SCM_STRUCTP (obj) - && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, - SCM_VTABLE_FLAG_SIMPLE) - && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, - SCM_VTABLE_FLAG_SIMPLE_RW) - && SCM_I_INUMP (index) - && SCM_I_INUM (index) >= 0 - && SCM_I_INUM (index) < (SCM_STRUCT_DATA_REF - (SCM_STRUCT_VTABLE (obj), - scm_vtable_index_size)))) - { - SCM_STRUCT_SLOT_SET (obj, SCM_I_INUM (index), val); - NEXT (1); - } - - SYNC_IP (); - scm_struct_set_x (obj, index, val); - NEXT (1); - } - - VM_DEFINE_OP (132, unused_132, NULL, NOP) - VM_DEFINE_OP (133, unused_133, NULL, NOP) - VM_DEFINE_OP (134, unused_134, NULL, NOP) - VM_DEFINE_OP (135, unused_135, NULL, NOP) VM_DEFINE_OP (136, unused_136, NULL, NOP) VM_DEFINE_OP (137, unused_137, NULL, NOP) VM_DEFINE_OP (138, unused_138, NULL, NOP) diff --git a/module/language/bytecode.scm b/module/language/bytecode.scm index 2ef98675a..089bf9e7e 100644 --- a/module/language/bytecode.scm +++ b/module/language/bytecode.scm @@ -34,34 +34,40 @@ (define (compute-instruction-arity name args) (define (first-word-arity word) (case word - ((U8_X24) 0) - ((U8_U24) 1) - ((U8_L24) 1) - ((U8_U8_I16) 2) - ((U8_U12_U12) 2) - ((U8_U8_U8_U8) 3))) + ((X32) 0) + ((X8_S24) 1) + ((X8_F24) 1) + ((X8_C24) 1) + ((X8_L24) 1) + ((X8_S8_I16) 2) + ((X8_S12_S12) 2) + ((X8_S12_C12) 2) + ((X8_C12_C12) 2) + ((X8_F12_F12) 2) + ((X8_S8_S8_S8) 3) + ((X8_S8_S8_C8) 3) + ((X8_S8_C8_S8) 3))) (define (tail-word-arity word) (case word - ((U8_U24) 2) - ((U8_L24) 2) - ((U8_U8_I16) 3) - ((U8_U12_U12) 3) - ((U8_U8_U8_U8) 4) - ((U32) 1) + ((C32) 1) ((I32) 1) ((A32) 1) ((B32) 0) ((N32) 1) - ((S32) 1) + ((R32) 1) ((L32) 1) ((LO32) 1) - ((X8_U24) 1) - ((X8_U12_U12) 2) - ((X8_L24) 1) + ((C8_C24) 2) + ((B1_C7_L24) 3) + ((B1_X7_S24) 2) + ((B1_X7_F24) 2) + ((B1_X7_C24) 2) ((B1_X7_L24) 2) - ((B1_U7_L24) 3) ((B1_X31) 1) - ((B1_X7_U24) 2))) + ((X8_S24) 1) + ((X8_F24) 1) + ((X8_C24) 1) + ((X8_L24) 1))) (match args ((arg0 . args) (fold (lambda (arg arity) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 6bc2bcf84..f29105108 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -89,13 +89,13 @@ emit-br-if-struct emit-br-if-char emit-br-if-tc7 - (emit-br-if-eq* . emit-br-if-eq) - (emit-br-if-eqv* . emit-br-if-eqv) - (emit-br-if-equal* . emit-br-if-equal) - (emit-br-if-=* . emit-br-if-=) - (emit-br-if-<* . emit-br-if-<) - (emit-br-if-<=* . emit-br-if-<=) - (emit-br-if-logtest* . emit-br-if-logtest) + emit-br-if-eq + emit-br-if-eqv + emit-br-if-equal + emit-br-if-= + emit-br-if-< + emit-br-if-<= + emit-br-if-logtest (emit-mov* . emit-mov) (emit-box* . emit-box) (emit-box-ref* . emit-box-ref) @@ -153,7 +153,7 @@ (emit-struct-ref* . emit-struct-ref) (emit-struct-set!* . emit-struct-set!) (emit-class-of* . emit-class-of) - (emit-make-array* . emit-make-array) + emit-make-array (emit-bv-u8-ref* . emit-bv-u8-ref) (emit-bv-s8-ref* . emit-bv-s8-ref) (emit-bv-u16-ref* . emit-bv-u16-ref) @@ -510,29 +510,38 @@ later by the linker." (with-syntax ((opcode opcode)) (op-case asm type - ((U8_X24) + ((X32) (emit asm opcode)) - ((U8_U24 arg) + ((X8_S24 arg) (emit asm (pack-u8-u24 opcode arg))) - ((U8_L24 label) + ((X8_F24 arg) + (emit asm (pack-u8-u24 opcode arg))) + ((X8_C24 arg) + (emit asm (pack-u8-u24 opcode arg))) + ((X8_L24 label) (record-label-reference asm label) (emit asm opcode)) - ((U8_U8_I16 a imm) + ((X8_S8_I16 a imm) (emit asm (pack-u8-u8-u16 opcode a (object-address imm)))) - ((U8_U12_U12 a b) + ((X8_S12_S12 a b) (emit asm (pack-u8-u12-u12 opcode a b))) - ((U8_U8_U8_U8 a b c) + ((X8_S12_C12 a b) + (emit asm (pack-u8-u12-u12 opcode a b))) + ((X8_C12_C12 a b) + (emit asm (pack-u8-u12-u12 opcode a b))) + ((X8_F12_F12 a b) + (emit asm (pack-u8-u12-u12 opcode a b))) + ((X8_S8_S8_S8 a b c) + (emit asm (pack-u8-u8-u8-u8 opcode a b c))) + ((X8_S8_S8_C8 a b c) + (emit asm (pack-u8-u8-u8-u8 opcode a b c))) + ((X8_S8_C8_S8 a b c) (emit asm (pack-u8-u8-u8-u8 opcode a b c)))))) (define (pack-tail-word asm type) (op-case asm type - ((U8_U24 a b) - (emit asm (pack-u8-u24 a b))) - ((U8_L24 a label) - (record-label-reference asm label) - (emit asm a)) - ((U32 a) + ((C32 a) (emit asm a)) ((I32 imm) (let ((val (object-address imm))) @@ -548,7 +557,7 @@ later by the linker." ((N32 label) (record-far-label-reference asm label) (emit asm 0)) - ((S32 label) + ((R32 label) (record-far-label-reference asm label) (emit asm 0)) ((L32 label) @@ -558,21 +567,31 @@ later by the linker." (record-far-label-reference asm label (* offset (/ (asm-word-size asm) 4))) (emit asm 0)) - ((X8_U24 a) - (emit asm (pack-u8-u24 0 a))) - ((X8_L24 label) - (record-label-reference asm label) - (emit asm 0)) + ((C8_C24 a b) + (emit asm (pack-u8-u24 a b))) ((B1_X7_L24 a label) (record-label-reference asm label) (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0))) - ((B1_U7_L24 a b label) + ((B1_C7_L24 a b label) (record-label-reference asm label) (emit asm (pack-u1-u7-u24 (if a 1 0) b 0))) ((B1_X31 a) (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0))) - ((B1_X7_U24 a b) - (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b))))) + ((B1_X7_S24 a b) + (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b))) + ((B1_X7_F24 a b) + (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b))) + ((B1_X7_C24 a b) + (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b))) + ((X8_S24 a) + (emit asm (pack-u8-u24 0 a))) + ((X8_F24 a) + (emit asm (pack-u8-u24 0 a))) + ((X8_C24 a) + (emit asm (pack-u8-u24 0 a))) + ((X8_L24 label) + (record-label-reference asm label) + (emit asm 0)))) (syntax-case x () ((_ name opcode word0 word* ...) @@ -651,25 +670,44 @@ later by the linker." #f))) (op-case word0 - ((U8_U8_I16 ! a imm) - (values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253)) - imm)) - ((U8_U8_I16 <- a imm) + ((X8_S8_I16 <- a imm) (values (if (< a (ash 1 8)) a 253) imm)) - ((U8_U12_U12 ! a b) + ((X8_S12_S12 ! a b) (values (if (< a (ash 1 12)) a (begin (emit-mov* asm 253 a) 253)) (if (< b (ash 1 12)) b (begin (emit-mov* asm 254 b) 254)))) - ((U8_U12_U12 <- a b) + ((X8_S12_S12 <- a b) (values (if (< a (ash 1 12)) a 253) (if (< b (ash 1 12)) b (begin (emit-mov* asm 254 b) 254)))) - ((U8_U8_U8_U8 ! a b c) + ((X8_S12_C12 <- a b) + (values (if (< a (ash 1 12)) a 253) + b)) + + ((X8_S8_S8_S8 ! a b c) (values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253)) (if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254)) (if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255)))) - ((U8_U8_U8_U8 <- a b c) + ((X8_S8_S8_S8 <- a b c) (values (if (< a (ash 1 8)) a 253) (if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254)) + (if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255)))) + + ((X8_S8_S8_C8 ! a b c) + (values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253)) + (if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254)) + c)) + ((X8_S8_S8_C8 <- a b c) + (values (if (< a (ash 1 8)) a 253) + (if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254)) + c)) + + ((X8_S8_C8_S8 ! a b c) + (values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253)) + b + (if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255)))) + ((X8_S8_C8_S8 <- a b c) + (values (if (< a (ash 1 8)) a 253) + b (if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255)))))) (define (tail-formals type) @@ -682,22 +720,25 @@ later by the linker." ((op-case type) (error "unmatched type" type)))) (op-case type - (U8_U24 a b) - (U8_L24 a label) - (U32 a) + (C32 a) (I32 imm) (A32 imm) (B32) (N32 label) - (S32 label) + (R32 label) (L32 label) (LO32 label offset) - (X8_U24 a) - (X8_L24 label) + (C8_C24 a b) + (B1_C7_L24 a b label) + (B1_X7_S24 a b) + (B1_X7_F24 a b) + (B1_X7_C24 a b) (B1_X7_L24 a label) - (B1_U7_L24 a b label) (B1_X31 a) - (B1_X7_U24 a b))) + (X8_S24 a) + (X8_F24 a) + (X8_C24 a) + (X8_L24 label))) (define (shuffle-up dst) (define-syntax op-case @@ -711,10 +752,10 @@ later by the linker." (with-syntax ((dst dst)) (op-case word0 - ((U8_U8_I16 U8_U8_U8_U8) + ((X8_S8_I16 X8_S8_S8_S8 X8_S8_S8_C8 X8_S8_C8_S8) (unless (< dst (ash 1 8)) (emit-mov* asm dst 253))) - ((U8_U12_U12) + ((X8_S12_S12 X8_S12_C12) (unless (< dst (ash 1 12)) (emit-mov* asm dst 253)))))) diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index 08aa057a2..c1a8ce700 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -80,70 +80,58 @@ (define (parse-first-word word type) (with-syntax ((word word)) (case type - ((U8_X24) + ((X32) #'()) - ((U8_U24) + ((X8_S24 X8_F24 X8_C24) #'((ash word -8))) - ((U8_L24) + ((X8_L24) #'((unpack-s24 (ash word -8)))) - ((U8_U8_I16) + ((X8_S8_I16) #'((logand (ash word -8) #xff) (ash word -16))) - ((U8_U12_U12) + ((X8_S12_S12 + X8_S12_C12 + X8_C12_C12 + X8_F12_F12) #'((logand (ash word -8) #xfff) (ash word -20))) - ((U8_U8_U8_U8) + ((X8_S8_S8_S8 + X8_S8_S8_C8 + X8_S8_C8_S8) #'((logand (ash word -8) #xff) (logand (ash word -16) #xff) (ash word -24))) (else - (error "bad kind" type))))) + (error "bad head kind" type))))) (define (parse-tail-word word type) (with-syntax ((word word)) (case type - ((U8_X24) - #'((logand word #ff))) - ((U8_U24) + ((C32 I32 A32 B32) + #'(word)) + ((N32 R32 L32 LO32) + #'((unpack-s32 word))) + ((C8_C24) #'((logand word #xff) (ash word -8))) - ((U8_L24) - #'((logand word #xff) - (unpack-s24 (ash word -8)))) - ((U32) - #'(word)) - ((I32) - #'(word)) - ((A32) - #'(word)) - ((B32) - #'(word)) - ((N32) - #'((unpack-s32 word))) - ((S32) - #'((unpack-s32 word))) - ((L32) - #'((unpack-s32 word))) - ((LO32) - #'((unpack-s32 word))) - ((X8_U24) - #'((ash word -8))) - ((X8_L24) - #'((unpack-s24 (ash word -8)))) - ((B1_X7_L24) - #'((not (zero? (logand word #x1))) - (unpack-s24 (ash word -8)))) - ((B1_U7_L24) + ((B1_C7_L24) #'((not (zero? (logand word #x1))) (logand (ash word -1) #x7f) (unpack-s24 (ash word -8)))) - ((B1_X31) - #'((not (zero? (logand word #x1))))) - ((B1_X7_U24) + ((B1_X7_S24 B1_X7_F24 B1_X7_C24) #'((not (zero? (logand word #x1))) (ash word -8))) + ((B1_X7_L24) + #'((not (zero? (logand word #x1))) + (unpack-s24 (ash word -8)))) + ((B1_X31) + #'((not (zero? (logand word #x1))))) + ((X8_S24 X8_F24 X8_C24) + #'((ash word -8))) + ((X8_L24) + #'((unpack-s24 (ash word -8)))) (else - (error "bad kind" type))))) + (error "bad tail kind" type))))) (syntax-case x () ((_ name opcode word0 word* ...) From 9b1ac02a8584ee7ca73a8f5920d7b33c0487bfc0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 21 Oct 2015 10:48:15 +0200 Subject: [PATCH 059/865] Fix boot closure wrong-num-args error * libguile/eval.c (prepare_boot_closure_env_for_eval): Fix issue if fixed closure is called with wrong number of arguments during bootstrap. --- libguile/eval.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/eval.c b/libguile/eval.c index 09fa71df4..6f2751970 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -882,7 +882,8 @@ prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc, *out_body = BOOT_CLOSURE_BODY (proc); *inout_env = new_env; } - else if (BOOT_CLOSURE_IS_REST (proc) && argc >= nreq) + else if (!BOOT_CLOSURE_IS_FIXED (proc) && + BOOT_CLOSURE_IS_REST (proc) && argc >= nreq) { SCM rest; int i; From 70c317ab5173e26d9f2a9b8b81a9441ef3ef7008 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 21 Oct 2015 10:48:58 +0200 Subject: [PATCH 060/865] SP-relative local addressing * libguile/vm-engine.c: S24/S12/S8 operands addressed relative to the SP, not the FP. Cache the SP instead of a FP-relative locals pointer. Further cleanups to follow. * libguile/vm.c (vm_builtin_call_with_values_code): Adapt to mov operand addresing change. * module/language/cps/compile-bytecode.scm (compile-function): Reify SP-relative local indexes where appropriate. * module/system/vm/assembler.scm (emit-fmov*): New helper, exported as emit-fmov. (shuffling-assembler, define-shuffling-assembler): Rewrite to shuffle via push/pop/drop. (standard-prelude, opt-prelude, kw-prelude): No need to provide for shuffling args. * test-suite/tests/rtl.test: Update. * module/language/cps/slot-allocation.scm: Don't reserve slots 253-255. --- libguile/vm-engine.c | 461 +++++++++++------------ libguile/vm.c | 4 +- module/language/cps/compile-bytecode.scm | 185 +++++---- module/language/cps/slot-allocation.scm | 23 +- module/system/vm/assembler.scm | 324 ++++++++-------- test-suite/tests/rtl.test | 114 +++--- 6 files changed, 562 insertions(+), 549 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index df7a528eb..ca369bd99 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -107,7 +107,7 @@ { \ SYNC_IP (); \ exp; \ - CACHE_LOCALS (); \ + CACHE_SP (); \ } \ } while (0) #else @@ -128,7 +128,7 @@ RUN_HOOK0 (abort) #define VM_HANDLE_INTERRUPTS \ - SCM_ASYNC_TICK_WITH_GUARD_CODE (thread, SYNC_IP (), CACHE_LOCALS ()) + SCM_ASYNC_TICK_WITH_GUARD_CODE (thread, SYNC_IP (), CACHE_SP ()) /* Virtual Machine @@ -136,31 +136,29 @@ The VM has three state bits: the instruction pointer (IP), the frame pointer (FP), and the stack pointer (SP). We cache the IP in a machine register, local to the VM, because it is used extensively by - the VM. We cache the address of local 0 too, for now; when we change - to reference variables relative to the SP we'll cache the SP instead. - As it is, the SP is used more by code outside the VM than by the VM - itself, we don't bother caching it locally. + the VM. We do the same for SP. The FP is used more by code outside + the VM than by the VM itself, we don't bother caching it locally. Keeping vp->ip in sync with the local IP would be a big lose, as it is updated so often. Instead of updating vp->ip all the time, we call SYNC_IP whenever we would need to know the IP of the top frame. In practice, we need to SYNC_IP whenever we call out of the VM to a function that would like to walk the stack, perhaps as the result of - an exception. + an exception. On the other hand, we do always keep vp->sp in sync + with the local SP. One more thing. We allow the stack to move, when it expands. Therefore if you call out to a C procedure that could call Scheme code, or otherwise push anything on the stack, you will need to - CACHE_LOCALS afterwards to restore the possibly-changed address of - local 0. */ + CACHE_SP afterwards to restore the possibly-changed stack pointer. */ #define SYNC_IP() vp->ip = (ip) -#define CACHE_LOCALS() locals = (vp->fp - 1) +#define CACHE_SP() sp = vp->sp #define CACHE_REGISTER() \ do { \ ip = vp->ip; \ - CACHE_LOCALS (); \ + CACHE_SP (); \ } while (0) @@ -174,38 +172,36 @@ FP is valid across an ALLOC_FRAME call. Be careful! */ #define ALLOC_FRAME(n) \ do { \ - union scm_vm_stack_element *new_sp = LOCAL_ADDRESS (n - 1); \ - if (new_sp < vp->sp_min_since_gc) \ + sp = vp->fp - (n); \ + if (sp < vp->sp_min_since_gc) \ { \ - if (SCM_UNLIKELY (new_sp < vp->stack_limit)) \ + if (SCM_UNLIKELY (sp < vp->stack_limit)) \ { \ SYNC_IP (); \ - vm_expand_stack (vp, new_sp); \ - CACHE_LOCALS (); \ + vm_expand_stack (vp, sp); \ + CACHE_SP (); \ } \ else \ - vp->sp_min_since_gc = vp->sp = new_sp; \ + vp->sp_min_since_gc = vp->sp = sp; \ } \ else \ - vp->sp = new_sp; \ + vp->sp = sp; \ } while (0) /* Reset the current frame to hold N locals. Used when we know that no stack expansion is needed. */ #define RESET_FRAME(n) \ do { \ - vp->sp = LOCAL_ADDRESS (n - 1); \ - if (vp->sp < vp->sp_min_since_gc) \ - vp->sp_min_since_gc = vp->sp; \ + vp->sp = sp = vp->fp - (n); \ + if (sp < vp->sp_min_since_gc) \ + vp->sp_min_since_gc = sp; \ } while (0) /* Compute the number of locals in the frame. At a call, this is equal to the number of actual arguments when a function is first called, plus one for the function. */ -#define FRAME_LOCALS_COUNT_FROM(slot) \ - (LOCAL_ADDRESS (slot) + 1 - vp->sp) -#define FRAME_LOCALS_COUNT() \ - FRAME_LOCALS_COUNT_FROM (0) +#define FRAME_LOCALS_COUNT() (vp->fp - sp) +#define FRAME_LOCALS_COUNT_FROM(slot) (FRAME_LOCALS_COUNT () - slot) /* Restore registers after returning from a frame. */ #define RESTORE_FRAME() \ @@ -248,18 +244,12 @@ case opcode: #endif -// This "locals + 1" is actually an optimization, because vp->fp points -// on before the zeroeth local. The result is to reference locals[-i]. -// In the future we should change to reference locals relative to the SP -// and cache the SP instead, which would give direct (non-negated) -// indexing off the SP, which is more in line with addressing modes -// supported by common CPUs. -#define LOCAL_ADDRESS(i) SCM_FRAME_SLOT (locals + 1, i) -#define LOCAL_REF(i) SCM_FRAME_LOCAL (locals + 1, i) -#define LOCAL_SET(i,o) SCM_FRAME_LOCAL (locals + 1, i) = o +#define FP_SLOT(i) SCM_FRAME_SLOT (vp->fp, i) +#define FP_REF(i) SCM_FRAME_LOCAL (vp->fp, i) +#define FP_SET(i,o) SCM_FRAME_LOCAL (vp->fp, i) = o -#define SP_REF(i) (vp->sp[i].as_scm) -#define SP_SET(i,o) (vp->sp[i].as_scm = o) +#define SP_REF(i) (sp[i].as_scm) +#define SP_SET(i,o) (sp[i].as_scm = o) #define VARIABLE_REF(v) SCM_VARIABLE_REF (v) #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o) @@ -272,15 +262,13 @@ VM_HANDLE_INTERRUPTS; \ ALLOC_FRAME (2); \ old_fp = vp->fp; \ - ip = SCM_FRAME_RETURN_ADDRESS (vp->fp); \ - vp->fp = SCM_FRAME_DYNAMIC_LINK (vp->fp); \ - CACHE_LOCALS (); \ + ip = SCM_FRAME_RETURN_ADDRESS (old_fp); \ + vp->fp = SCM_FRAME_DYNAMIC_LINK (old_fp); \ /* Clear frame. */ \ old_fp[0].as_scm = SCM_BOOL_F; \ old_fp[1].as_scm = SCM_BOOL_F; \ /* Leave proc. */ \ - SCM_FRAME_LOCAL (old_fp, 1) = val; \ - vp->sp = SCM_FRAME_SLOT (old_fp, 1); \ + SP_SET (0, val); \ POP_CONTINUATION_HOOK (old_fp); \ NEXT (0); \ } while (0) @@ -292,9 +280,9 @@ SCM vals = vals_; \ VM_HANDLE_INTERRUPTS; \ ALLOC_FRAME (3); \ - SCM_FRAME_LOCAL (vp->fp, 0) = vm_builtin_apply; \ - SCM_FRAME_LOCAL (vp->fp, 1) = vm_builtin_values; \ - SCM_FRAME_LOCAL (vp->fp, 2) = vals; \ + SP_SET (2, vm_builtin_apply); \ + SP_SET (1, vm_builtin_values); \ + SP_SET (0, vals); \ ip = (scm_t_uint32 *) vm_builtin_apply_code; \ goto op_tail_apply; \ } while (0) @@ -314,7 +302,7 @@ scm_t_uint32 test; \ SCM x; \ UNPACK_24 (op, test); \ - x = LOCAL_REF (test); \ + x = SP_REF (test); \ if ((ip[1] & 0x1) ? !(exp) : (exp)) \ { \ scm_t_int32 offset = ip[1]; \ @@ -330,8 +318,8 @@ SCM x, y; \ UNPACK_24 (op, a); \ UNPACK_24 (ip[1], b); \ - x = LOCAL_REF (a); \ - y = LOCAL_REF (b); \ + x = SP_REF (a); \ + y = SP_REF (b); \ if ((ip[2] & 0x1) ? !(exp) : (exp)) \ { \ scm_t_int32 offset = ip[2]; \ @@ -348,8 +336,8 @@ SCM x, y; \ UNPACK_24 (op, a); \ UNPACK_24 (ip[1], b); \ - x = LOCAL_REF (a); \ - y = LOCAL_REF (b); \ + x = SP_REF (a); \ + y = SP_REF (b); \ if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \ { \ scm_t_signed_bits x_bits = SCM_UNPACK (x); \ @@ -369,7 +357,7 @@ SCM res; \ SYNC_IP (); \ res = srel (x, y); \ - CACHE_LOCALS (); \ + CACHE_SP (); \ if ((ip[2] & 0x1) ? scm_is_false (res) : scm_is_true (res)) \ { \ scm_t_int32 offset = ip[2]; \ @@ -386,17 +374,17 @@ scm_t_uint16 dst, src; \ SCM a1; \ UNPACK_12_12 (op, dst, src); \ - a1 = LOCAL_REF (src) + a1 = SP_REF (src) #define ARGS2(a1, a2) \ scm_t_uint8 dst, src1, src2; \ SCM a1, a2; \ UNPACK_8_8_8 (op, dst, src1, src2); \ - a1 = LOCAL_REF (src1); \ - a2 = LOCAL_REF (src2) + a1 = SP_REF (src1); \ + a2 = SP_REF (src2) #define RETURN(x) \ - do { LOCAL_SET (dst, x); NEXT (1); } while (0) + do { SP_SET (dst, x); NEXT (1); } while (0) #define RETURN_EXP(exp) \ - do { SCM __x; SYNC_IP (); __x = exp; CACHE_LOCALS (); RETURN (__x); } while (0) + do { SCM __x; SYNC_IP (); __x = exp; CACHE_SP (); RETURN (__x); } while (0) /* The maximum/minimum tagged integers. */ #define INUM_MAX \ @@ -440,10 +428,10 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, running. */ register scm_t_uint32 *ip IP_REG; - /* Frame pointer: A pointer into the stack, off of which we index - arguments and local variables. Pushed at function calls, popped on - returns. */ - register union scm_vm_stack_element *locals FP_REG; + /* Stack pointer: A pointer to the hot end of the stack, off of which + we index arguments and local variables. Pushed at function calls, + popped on returns. */ + register union scm_vm_stack_element *sp FP_REG; /* Current opcode: A cache of *ip. */ register scm_t_uint32 op; @@ -473,13 +461,13 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (0); apply: - while (!SCM_PROGRAM_P (LOCAL_REF (0))) + while (!SCM_PROGRAM_P (FP_REF (0))) { - SCM proc = LOCAL_REF (0); + SCM proc = FP_REF (0); if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)) { - LOCAL_SET (0, SCM_STRUCT_PROCEDURE (proc)); + FP_SET (0, SCM_STRUCT_PROCEDURE (proc)); continue; } if (SCM_HAS_TYP7 (proc, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (proc)) @@ -490,9 +478,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, IP and go. ) */ ALLOC_FRAME (n + 1); while (n--) - LOCAL_SET (n + 1, LOCAL_REF (n)); + FP_SET (n + 1, FP_REF (n)); - LOCAL_SET (0, SCM_SMOB_DESCRIPTOR (proc).apply_trampoline); + FP_SET (0, SCM_SMOB_DESCRIPTOR (proc).apply_trampoline); continue; } @@ -501,7 +489,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, } /* Let's go! */ - ip = SCM_PROGRAM_CODE (LOCAL_REF (0)); + ip = SCM_PROGRAM_CODE (FP_REF (0)); APPLY_HOOK (); @@ -528,13 +516,13 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, SCM ret; if (nvals == 1) - ret = LOCAL_REF (4); + ret = FP_REF (4); else { scm_t_uint32 n; ret = SCM_EOL; for (n = nvals; n > 0; n--) - ret = scm_inline_cons (thread, LOCAL_REF (4 + n - 1), ret); + ret = scm_inline_cons (thread, FP_REF (4 + n - 1), ret); ret = scm_values (ret); } @@ -572,16 +560,15 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, old_fp = vp->fp; vp->fp = SCM_FRAME_SLOT (old_fp, proc - 1); - CACHE_LOCALS (); SCM_FRAME_SET_DYNAMIC_LINK (vp->fp, old_fp); SCM_FRAME_SET_RETURN_ADDRESS (vp->fp, ip + 2); RESET_FRAME (nlocals); - if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0)))) + if (SCM_UNLIKELY (!SCM_PROGRAM_P (FP_REF (0)))) goto apply; - ip = SCM_PROGRAM_CODE (LOCAL_REF (0)); + ip = SCM_PROGRAM_CODE (FP_REF (0)); APPLY_HOOK (); @@ -614,7 +601,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, old_fp = vp->fp; vp->fp = SCM_FRAME_SLOT (old_fp, proc - 1); - CACHE_LOCALS (); SCM_FRAME_SET_DYNAMIC_LINK (vp->fp, old_fp); SCM_FRAME_SET_RETURN_ADDRESS (vp->fp, ip + 3); @@ -643,10 +629,10 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, RESET_FRAME (nlocals); - if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0)))) + if (SCM_UNLIKELY (!SCM_PROGRAM_P (FP_REF (0)))) goto apply; - ip = SCM_PROGRAM_CODE (LOCAL_REF (0)); + ip = SCM_PROGRAM_CODE (FP_REF (0)); APPLY_HOOK (); @@ -696,14 +682,14 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, nlocals = FRAME_LOCALS_COUNT (); for (n = 0; from + n < nlocals; n++) - LOCAL_SET (n + 1, LOCAL_REF (from + n)); + FP_SET (n + 1, FP_REF (from + n)); RESET_FRAME (n + 1); - if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0)))) + if (SCM_UNLIKELY (!SCM_PROGRAM_P (FP_REF (0)))) goto apply; - ip = SCM_PROGRAM_CODE (LOCAL_REF (0)); + ip = SCM_PROGRAM_CODE (FP_REF (0)); APPLY_HOOK (); @@ -723,7 +709,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_12_12 (op, dst, proc); UNPACK_24 (ip[1], nlocals); VM_ASSERT (FRAME_LOCALS_COUNT () > proc + 1, vm_error_no_values ()); - LOCAL_SET (dst, LOCAL_REF (proc + 1)); + FP_SET (dst, FP_REF (proc + 1)); RESET_FRAME (nlocals); NEXT (2); } @@ -758,7 +744,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, { scm_t_uint32 src; UNPACK_24 (op, src); - RETURN_ONE_VALUE (LOCAL_REF (src)); + RETURN_ONE_VALUE (SP_REF (src)); } /* return-values _:24 @@ -778,7 +764,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, old_fp = vp->fp; ip = SCM_FRAME_RETURN_ADDRESS (vp->fp); vp->fp = SCM_FRAME_DYNAMIC_LINK (vp->fp); - CACHE_LOCALS (); /* Clear stack frame. */ old_fp[0].as_scm = SCM_BOOL_F; @@ -811,63 +796,64 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_24 (op, ptr_idx); - pointer = SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), ptr_idx); + pointer = SCM_PROGRAM_FREE_VARIABLE_REF (FP_REF (0), ptr_idx); subr = SCM_POINTER_VALUE (pointer); SYNC_IP (); + // FIXME!!!! switch (FRAME_LOCALS_COUNT_FROM (1)) { case 0: ret = subr (); break; case 1: - ret = subr (LOCAL_REF (1)); + ret = subr (FP_REF (1)); break; case 2: - ret = subr (LOCAL_REF (1), LOCAL_REF (2)); + ret = subr (FP_REF (1), FP_REF (2)); break; case 3: - ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3)); + ret = subr (FP_REF (1), FP_REF (2), FP_REF (3)); break; case 4: - ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3), - LOCAL_REF (4)); + ret = subr (FP_REF (1), FP_REF (2), FP_REF (3), + FP_REF (4)); break; case 5: - ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3), - LOCAL_REF (4), LOCAL_REF (5)); + ret = subr (FP_REF (1), FP_REF (2), FP_REF (3), + FP_REF (4), FP_REF (5)); break; case 6: - ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3), - LOCAL_REF (4), LOCAL_REF (5), LOCAL_REF (6)); + ret = subr (FP_REF (1), FP_REF (2), FP_REF (3), + FP_REF (4), FP_REF (5), FP_REF (6)); break; case 7: - ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3), - LOCAL_REF (4), LOCAL_REF (5), LOCAL_REF (6), - LOCAL_REF (7)); + ret = subr (FP_REF (1), FP_REF (2), FP_REF (3), + FP_REF (4), FP_REF (5), FP_REF (6), + FP_REF (7)); break; case 8: - ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3), - LOCAL_REF (4), LOCAL_REF (5), LOCAL_REF (6), - LOCAL_REF (7), LOCAL_REF (8)); + ret = subr (FP_REF (1), FP_REF (2), FP_REF (3), + FP_REF (4), FP_REF (5), FP_REF (6), + FP_REF (7), FP_REF (8)); break; case 9: - ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3), - LOCAL_REF (4), LOCAL_REF (5), LOCAL_REF (6), - LOCAL_REF (7), LOCAL_REF (8), LOCAL_REF (9)); + ret = subr (FP_REF (1), FP_REF (2), FP_REF (3), + FP_REF (4), FP_REF (5), FP_REF (6), + FP_REF (7), FP_REF (8), FP_REF (9)); break; case 10: - ret = subr (LOCAL_REF (1), LOCAL_REF (2), LOCAL_REF (3), - LOCAL_REF (4), LOCAL_REF (5), LOCAL_REF (6), - LOCAL_REF (7), LOCAL_REF (8), LOCAL_REF (9), - LOCAL_REF (10)); + ret = subr (FP_REF (1), FP_REF (2), FP_REF (3), + FP_REF (4), FP_REF (5), FP_REF (6), + FP_REF (7), FP_REF (8), FP_REF (9), + FP_REF (10)); break; default: abort (); } - CACHE_LOCALS (); + CACHE_SP (); if (SCM_UNLIKELY (SCM_VALUESP (ret))) /* multiple values returned to continuation */ @@ -891,17 +877,16 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_12_12 (op, cif_idx, ptr_idx); - closure = LOCAL_REF (0); + closure = FP_REF (0); cif = SCM_PROGRAM_FREE_VARIABLE_REF (closure, cif_idx); pointer = SCM_PROGRAM_FREE_VARIABLE_REF (closure, ptr_idx); SYNC_IP (); // FIXME: separate args - ret = scm_i_foreign_call (scm_inline_cons (thread, cif, pointer), - vp->sp); + ret = scm_i_foreign_call (scm_inline_cons (thread, cif, pointer), sp); - CACHE_LOCALS (); + CACHE_SP (); if (SCM_UNLIKELY (SCM_VALUESP (ret))) /* multiple values returned to continuation */ @@ -926,14 +911,14 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_24 (op, contregs_idx); contregs = - SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), contregs_idx); + SCM_PROGRAM_FREE_VARIABLE_REF (FP_REF (0), contregs_idx); SYNC_IP (); scm_i_check_continuation (contregs); vm_return_to_continuation (scm_i_contregs_vp (contregs), scm_i_contregs_vm_cont (contregs), FRAME_LOCALS_COUNT_FROM (1), - vp->sp); + sp); scm_i_reinstate_continuation (contregs); /* no NEXT */ @@ -954,7 +939,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, scm_t_uint32 cont_idx; UNPACK_24 (op, cont_idx); - vmcont = SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (0), cont_idx); + vmcont = SCM_PROGRAM_FREE_VARIABLE_REF (FP_REF (0), cont_idx); SYNC_IP (); VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont), @@ -982,7 +967,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, // At a minimum, there should be apply, f, and the list. VM_ASSERT (nlocals >= 3, abort ()); list_idx = nlocals - 1; - list = LOCAL_REF (list_idx); + list = FP_REF (list_idx); list_len = scm_ilength (list); VM_ASSERT (list_len >= 0, vm_error_apply_to_non_list (list)); @@ -991,20 +976,20 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, ALLOC_FRAME (nlocals); for (i = 1; i < list_idx; i++) - LOCAL_SET (i - 1, LOCAL_REF (i)); + FP_SET (i - 1, FP_REF (i)); /* Null out these slots, just in case there are less than 2 elements in the list. */ - LOCAL_SET (list_idx - 1, SCM_UNDEFINED); - LOCAL_SET (list_idx, SCM_UNDEFINED); + FP_SET (list_idx - 1, SCM_UNDEFINED); + FP_SET (list_idx, SCM_UNDEFINED); for (i = 0; i < list_len; i++, list = SCM_CDR (list)) - LOCAL_SET (list_idx - 1 + i, SCM_CAR (list)); + FP_SET (list_idx - 1 + i, SCM_CAR (list)); - if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0)))) + if (SCM_UNLIKELY (!SCM_PROGRAM_P (FP_REF (0)))) goto apply; - ip = SCM_PROGRAM_CODE (LOCAL_REF (0)); + ip = SCM_PROGRAM_CODE (FP_REF (0)); APPLY_HOOK (); @@ -1042,14 +1027,15 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, if (first) { - LOCAL_SET (0, LOCAL_REF (1)); - LOCAL_SET (1, cont); RESET_FRAME (2); - if (SCM_UNLIKELY (!SCM_PROGRAM_P (LOCAL_REF (0)))) + SP_SET (1, SP_REF (0)); + SP_SET (0, cont); + + if (SCM_UNLIKELY (!SCM_PROGRAM_P (SP_REF (1)))) goto apply; - ip = SCM_PROGRAM_CODE (LOCAL_REF (0)); + ip = SCM_PROGRAM_CODE (SP_REF (1)); APPLY_HOOK (); @@ -1079,7 +1065,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, it continues with the next instruction. */ ip++; SYNC_IP (); - vm_abort (vp, LOCAL_REF (1), nlocals - 2, registers); + vm_abort (vp, FP_REF (1), nlocals - 2, registers); /* vm_abort should not return */ abort (); @@ -1094,7 +1080,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, scm_t_uint16 dst, idx; UNPACK_12_12 (op, dst, idx); - LOCAL_SET (dst, scm_vm_builtin_ref (idx)); + SP_SET (dst, scm_vm_builtin_ref (idx)); NEXT (1); } @@ -1139,7 +1125,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, scm_t_uint32 expected; UNPACK_24 (op, expected); VM_ASSERT (FRAME_LOCALS_COUNT () == expected, - vm_error_wrong_num_args (LOCAL_REF (0))); + vm_error_wrong_num_args (FP_REF (0))); NEXT (1); } VM_DEFINE_OP (22, assert_nargs_ge, "assert-nargs-ge", OP1 (X8_C24)) @@ -1147,7 +1133,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, scm_t_uint32 expected; UNPACK_24 (op, expected); VM_ASSERT (FRAME_LOCALS_COUNT () >= expected, - vm_error_wrong_num_args (LOCAL_REF (0))); + vm_error_wrong_num_args (FP_REF (0))); NEXT (1); } VM_DEFINE_OP (23, assert_nargs_le, "assert-nargs-le", OP1 (X8_C24)) @@ -1155,7 +1141,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, scm_t_uint32 expected; UNPACK_24 (op, expected); VM_ASSERT (FRAME_LOCALS_COUNT () <= expected, - vm_error_wrong_num_args (LOCAL_REF (0))); + vm_error_wrong_num_args (FP_REF (0))); NEXT (1); } @@ -1173,7 +1159,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, nargs = FRAME_LOCALS_COUNT (); ALLOC_FRAME (nlocals); while (nlocals-- > nargs) - LOCAL_SET (nlocals, SCM_UNDEFINED); + FP_SET (nlocals, SCM_UNDEFINED); NEXT (1); } @@ -1219,7 +1205,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_24 (op, dst); val = SP_REF (0); - vp->sp++; + vp->sp = sp = sp + 1; SP_SET (dst, val); NEXT (1); } @@ -1233,7 +1219,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, scm_t_uint32 count; UNPACK_24 (op, count); - vp->sp += count; + vp->sp = sp = sp + count; NEXT (1); } @@ -1247,10 +1233,10 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, scm_t_uint16 expected, nlocals; UNPACK_12_12 (op, expected, nlocals); VM_ASSERT (FRAME_LOCALS_COUNT () == expected, - vm_error_wrong_num_args (LOCAL_REF (0))); + vm_error_wrong_num_args (FP_REF (0))); ALLOC_FRAME (expected + nlocals); while (nlocals--) - LOCAL_SET (expected + nlocals, SCM_UNDEFINED); + SP_SET (nlocals, SCM_UNDEFINED); NEXT (1); } @@ -1278,9 +1264,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, { scm_t_uint32 n; for (n = nreq; n < npos; n++) - if (scm_is_keyword (LOCAL_REF (n))) + if (scm_is_keyword (FP_REF (n))) break; - if (n == npos && !scm_is_keyword (LOCAL_REF (n))) + if (n == npos && !scm_is_keyword (FP_REF (n))) { scm_t_int32 offset = ip[2]; offset >>= 8; /* Sign-extending shift. */ @@ -1331,7 +1317,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, /* and we still have positionals to fill */ && npositional < nreq_and_opt /* and we haven't reached a keyword yet */ - && !scm_is_keyword (LOCAL_REF (npositional))) + && !scm_is_keyword (FP_REF (npositional))) /* bind this optional arg (by leaving it in place) */ npositional++; nkw = nargs - npositional; @@ -1339,44 +1325,44 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, ALLOC_FRAME (ntotal + nkw); n = nkw; while (n--) - LOCAL_SET (ntotal + n, LOCAL_REF (npositional + n)); + FP_SET (ntotal + n, FP_REF (npositional + n)); /* and fill optionals & keyword args with SCM_UNDEFINED */ n = npositional; while (n < ntotal) - LOCAL_SET (n++, SCM_UNDEFINED); + FP_SET (n++, SCM_UNDEFINED); VM_ASSERT (has_rest || (nkw % 2) == 0, - vm_error_kwargs_length_not_even (LOCAL_REF (0))); + vm_error_kwargs_length_not_even (FP_REF (0))); /* Now bind keywords, in the order given. */ for (n = 0; n < nkw; n++) - if (scm_is_keyword (LOCAL_REF (ntotal + n))) + if (scm_is_keyword (FP_REF (ntotal + n))) { SCM walk; for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk)) - if (scm_is_eq (SCM_CAAR (walk), LOCAL_REF (ntotal + n))) + if (scm_is_eq (SCM_CAAR (walk), FP_REF (ntotal + n))) { SCM si = SCM_CDAR (walk); - LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_uint32 (si), - LOCAL_REF (ntotal + n + 1)); + FP_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_uint32 (si), + FP_REF (ntotal + n + 1)); break; } VM_ASSERT (scm_is_pair (walk) || allow_other_keys, - vm_error_kwargs_unrecognized_keyword (LOCAL_REF (0), - LOCAL_REF (ntotal + n))); + vm_error_kwargs_unrecognized_keyword (FP_REF (0), + FP_REF (ntotal + n))); n++; } else - VM_ASSERT (has_rest, vm_error_kwargs_invalid_keyword (LOCAL_REF (0), - LOCAL_REF (ntotal + n))); + VM_ASSERT (has_rest, vm_error_kwargs_invalid_keyword (FP_REF (0), + FP_REF (ntotal + n))); if (has_rest) { SCM rest = SCM_EOL; n = nkw; while (n--) - rest = scm_inline_cons (thread, LOCAL_REF (ntotal + n), rest); - LOCAL_SET (nreq_and_opt, rest); + rest = scm_inline_cons (thread, FP_REF (ntotal + n), rest); + FP_SET (nreq_and_opt, rest); } RESET_FRAME (ntotal); @@ -1401,20 +1387,20 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, { ALLOC_FRAME (dst + 1); while (nargs < dst) - LOCAL_SET (nargs++, SCM_UNDEFINED); + FP_SET (nargs++, SCM_UNDEFINED); } else { while (nargs-- > dst) { - rest = scm_inline_cons (thread, LOCAL_REF (nargs), rest); - LOCAL_SET (nargs, SCM_UNDEFINED); + rest = scm_inline_cons (thread, FP_REF (nargs), rest); + FP_SET (nargs, SCM_UNDEFINED); } RESET_FRAME (dst + 1); } - LOCAL_SET (dst, rest); + FP_SET (dst, rest); NEXT (1); } @@ -1539,7 +1525,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * If the value in A is equal? to the value in B, add OFFSET, a signed * 24-bit number, to the current instruction pointer. */ - // FIXME: Should sync_ip before calling out and cache_locals before coming + // FIXME: Should sync_ip before calling out and cache_sp before coming // back! Another reason to remove this opcode! VM_DEFINE_OP (43, br_if_equal, "br-if-equal", OP3 (X8_S24, X8_S24, B1_X7_L24)) { @@ -1610,7 +1596,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, scm_t_uint16 src; UNPACK_12_12 (op, dst, src); - LOCAL_SET (dst, LOCAL_REF (src)); + SP_SET (dst, SP_REF (src)); NEXT (1); } @@ -1626,7 +1612,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_24 (op, dst); UNPACK_24 (ip[1], src); - LOCAL_SET (dst, LOCAL_REF (src)); + SP_SET (dst, SP_REF (src)); NEXT (2); } @@ -1643,7 +1629,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_24 (op, dst); UNPACK_24 (ip[1], src); - LOCAL_SET (dst, LOCAL_REF (src)); + FP_SET (dst, FP_REF (src)); NEXT (2); } @@ -1656,8 +1642,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, { scm_t_uint16 dst, src; UNPACK_12_12 (op, dst, src); - LOCAL_SET (dst, scm_inline_cell (thread, scm_tc7_variable, - SCM_UNPACK (LOCAL_REF (src)))); + SP_SET (dst, scm_inline_cell (thread, scm_tc7_variable, + SCM_UNPACK (SP_REF (src)))); NEXT (1); } @@ -1671,11 +1657,11 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, scm_t_uint16 dst, src; SCM var; UNPACK_12_12 (op, dst, src); - var = LOCAL_REF (src); + var = SP_REF (src); VM_ASSERT (SCM_VARIABLEP (var), vm_error_not_a_variable ("variable-ref", var)); VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (var)); - LOCAL_SET (dst, VARIABLE_REF (var)); + SP_SET (dst, VARIABLE_REF (var)); NEXT (1); } @@ -1688,10 +1674,10 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, scm_t_uint16 dst, src; SCM var; UNPACK_12_12 (op, dst, src); - var = LOCAL_REF (dst); + var = SP_REF (dst); VM_ASSERT (SCM_VARIABLEP (var), vm_error_not_a_variable ("variable-set!", var)); - VARIABLE_SET (var, LOCAL_REF (src)); + VARIABLE_SET (var, SP_REF (src)); NEXT (1); } @@ -1719,7 +1705,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, // FIXME: Elide these initializations? for (n = 0; n < nfree; n++) SCM_PROGRAM_FREE_VARIABLE_SET (closure, n, SCM_BOOL_F); - LOCAL_SET (dst, closure); + SP_SET (dst, closure); NEXT (3); } @@ -1734,7 +1720,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_12_12 (op, dst, src); UNPACK_24 (ip[1], idx); /* CHECK_FREE_VARIABLE (src); */ - LOCAL_SET (dst, SCM_PROGRAM_FREE_VARIABLE_REF (LOCAL_REF (src), idx)); + SP_SET (dst, SCM_PROGRAM_FREE_VARIABLE_REF (SP_REF (src), idx)); NEXT (2); } @@ -1749,7 +1735,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_12_12 (op, dst, src); UNPACK_24 (ip[1], idx); /* CHECK_FREE_VARIABLE (src); */ - SCM_PROGRAM_FREE_VARIABLE_SET (LOCAL_REF (dst), idx, LOCAL_REF (src)); + SCM_PROGRAM_FREE_VARIABLE_SET (SP_REF (dst), idx, SP_REF (src)); NEXT (2); } @@ -1771,7 +1757,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, scm_t_bits val; UNPACK_8_16 (op, dst, val); - LOCAL_SET (dst, SCM_PACK (val)); + SP_SET (dst, SCM_PACK (val)); NEXT (1); } @@ -1787,7 +1773,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_24 (op, dst); val = ip[1]; - LOCAL_SET (dst, SCM_PACK (val)); + SP_SET (dst, SCM_PACK (val)); NEXT (2); } @@ -1809,7 +1795,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, ASSERT (ip[1] == 0); val = ip[2]; #endif - LOCAL_SET (dst, SCM_PACK (val)); + SP_SET (dst, SCM_PACK (val)); NEXT (3); } @@ -1840,7 +1826,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, VM_ASSERT (!(unpacked & 0x7), abort()); - LOCAL_SET (dst, SCM_PACK (unpacked)); + SP_SET (dst, SCM_PACK (unpacked)); NEXT (2); } @@ -1868,7 +1854,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, loc_bits = (scm_t_uintptr) loc; VM_ASSERT (ALIGNED_P (loc, SCM), abort()); - LOCAL_SET (dst, *((SCM *) loc_bits)); + SP_SET (dst, *((SCM *) loc_bits)); NEXT (2); } @@ -1889,7 +1875,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, loc = ip + offset; VM_ASSERT (ALIGNED_P (loc, SCM), abort()); - *((SCM *) loc) = LOCAL_REF (src); + *((SCM *) loc) = SP_REF (src); NEXT (2); } @@ -1965,7 +1951,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_24 (op, dst); SYNC_IP (); - LOCAL_SET (dst, scm_current_module ()); + SP_SET (dst, scm_current_module ()); NEXT (1); } @@ -1985,11 +1971,11 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_24 (ip[1], sym); SYNC_IP (); - var = scm_lookup (LOCAL_REF (sym)); - CACHE_LOCALS (); + var = scm_lookup (SP_REF (sym)); + CACHE_SP (); if (ip[1] & 0x1) - VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (LOCAL_REF (sym))); - LOCAL_SET (dst, var); + VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (SP_REF (sym))); + SP_SET (dst, var); NEXT (2); } @@ -2004,8 +1990,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, scm_t_uint16 sym, val; UNPACK_12_12 (op, sym, val); SYNC_IP (); - scm_define (LOCAL_REF (sym), LOCAL_REF (val)); - CACHE_LOCALS (); + scm_define (SP_REF (sym), SP_REF (val)); + CACHE_SP (); NEXT (1); } @@ -2065,14 +2051,14 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, mod = scm_the_root_module (); var = scm_module_lookup (mod, sym); - CACHE_LOCALS (); + CACHE_SP (); if (ip[4] & 0x1) VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (sym)); *var_loc = var; } - LOCAL_SET (dst, var); + SP_SET (dst, var); NEXT (5); } @@ -2126,7 +2112,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, else var = scm_private_lookup (SCM_CDR (modname), sym); - CACHE_LOCALS (); + CACHE_SP (); if (ip[4] & 0x1) VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (sym)); @@ -2134,7 +2120,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, *var_loc = var; } - LOCAL_SET (dst, var); + SP_SET (dst, var); NEXT (5); } @@ -2167,9 +2153,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, /* Push the prompt onto the dynamic stack. */ flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0; scm_dynstack_push_prompt (&thread->dynstack, flags, - LOCAL_REF (tag), + SP_REF (tag), vp->stack_top - vp->fp, - vp->stack_top - LOCAL_ADDRESS (proc_slot), + vp->stack_top - FP_SLOT (proc_slot), ip + offset, registers); NEXT (3); @@ -2188,7 +2174,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, scm_t_uint16 winder, unwinder; UNPACK_12_12 (op, winder, unwinder); scm_dynstack_push_dynwind (&thread->dynstack, - LOCAL_REF (winder), LOCAL_REF (unwinder)); + SP_REF (winder), SP_REF (unwinder)); NEXT (1); } @@ -2214,7 +2200,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_12_12 (op, fluid, value); scm_dynstack_push_fluid (&thread->dynstack, - LOCAL_REF (fluid), LOCAL_REF (value), + SP_REF (fluid), SP_REF (value), thread->dynamic_state); NEXT (1); } @@ -2243,14 +2229,14 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, SCM fluid, fluids; UNPACK_12_12 (op, dst, src); - fluid = LOCAL_REF (src); + fluid = SP_REF (src); fluids = SCM_I_DYNAMIC_STATE_FLUIDS (thread->dynamic_state); if (SCM_UNLIKELY (!SCM_FLUID_P (fluid)) || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids))) { /* Punt dynstate expansion and error handling to the C proc. */ SYNC_IP (); - LOCAL_SET (dst, scm_fluid_ref (fluid)); + SP_SET (dst, scm_fluid_ref (fluid)); } else { @@ -2259,7 +2245,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, val = SCM_I_FLUID_DEFAULT (fluid); VM_ASSERT (!scm_is_eq (val, SCM_UNDEFINED), vm_error_unbound_fluid (fluid)); - LOCAL_SET (dst, val); + SP_SET (dst, val); } NEXT (1); @@ -2276,17 +2262,17 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, SCM fluid, fluids; UNPACK_12_12 (op, a, b); - fluid = LOCAL_REF (a); + fluid = SP_REF (a); fluids = SCM_I_DYNAMIC_STATE_FLUIDS (thread->dynamic_state); if (SCM_UNLIKELY (!SCM_FLUID_P (fluid)) || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids))) { /* Punt dynstate expansion and error handling to the C proc. */ SYNC_IP (); - scm_fluid_set_x (fluid, LOCAL_REF (b)); + scm_fluid_set_x (fluid, SP_REF (b)); } else - SCM_SIMPLE_VECTOR_SET (fluids, num, LOCAL_REF (b)); + SCM_SIMPLE_VECTOR_SET (fluids, num, SP_REF (b)); NEXT (1); } @@ -2347,8 +2333,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_12_12 (op, dst, src); SYNC_IP (); - LOCAL_SET (dst, - scm_string_to_number (LOCAL_REF (src), + SP_SET (dst, + scm_string_to_number (SP_REF (src), SCM_UNDEFINED /* radix = 10 */)); NEXT (1); } @@ -2363,7 +2349,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_12_12 (op, dst, src); SYNC_IP (); - LOCAL_SET (dst, scm_string_to_symbol (LOCAL_REF (src))); + SP_SET (dst, scm_string_to_symbol (SP_REF (src))); NEXT (1); } @@ -2376,7 +2362,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, scm_t_uint16 dst, src; UNPACK_12_12 (op, dst, src); SYNC_IP (); - LOCAL_SET (dst, scm_symbol_to_keyword (LOCAL_REF (src))); + SP_SET (dst, scm_symbol_to_keyword (SP_REF (src))); NEXT (1); } @@ -2427,8 +2413,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, scm_t_uint16 a, b; SCM x, y; UNPACK_12_12 (op, a, b); - x = LOCAL_REF (a); - y = LOCAL_REF (b); + x = SP_REF (a); + y = SP_REF (b); VM_VALIDATE_PAIR (x, "set-car!"); SCM_SETCAR (x, y); NEXT (1); @@ -2443,8 +2429,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, scm_t_uint16 a, b; SCM x, y; UNPACK_12_12 (op, a, b); - x = LOCAL_REF (a); - y = LOCAL_REF (b); + x = SP_REF (a); + y = SP_REF (b); VM_VALIDATE_PAIR (x, "set-car!"); SCM_SETCDR (x, y); NEXT (1); @@ -2659,7 +2645,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_8_8_8 (op, dst, length, init); - LOCAL_SET (dst, scm_make_vector (LOCAL_REF (length), LOCAL_REF (init))); + SP_SET (dst, scm_make_vector (SP_REF (length), SP_REF (init))); NEXT (1); } @@ -2678,12 +2664,12 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_8_8_8 (op, dst, length, init); - val = LOCAL_REF (init); + val = SP_REF (init); vector = scm_inline_words (thread, scm_tc7_vector | (length << 8), length + 1); for (n = 0; n < length; n++) SCM_SIMPLE_VECTOR_SET (vector, n, val); - LOCAL_SET (dst, vector); + SP_SET (dst, vector); NEXT (1); } @@ -2728,12 +2714,12 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, SCM v; UNPACK_8_8_8 (op, dst, src, idx); - v = LOCAL_REF (src); + v = SP_REF (src); VM_ASSERT (SCM_I_IS_VECTOR (v), vm_error_not_a_vector ("vector-ref", v)); VM_ASSERT (idx < SCM_I_VECTOR_LENGTH (v), vm_error_out_of_range ("vector-ref", scm_from_size_t (idx))); - LOCAL_SET (dst, SCM_I_VECTOR_ELTS (LOCAL_REF (src))[idx]); + SP_SET (dst, SCM_I_VECTOR_ELTS (SP_REF (src))[idx]); NEXT (1); } @@ -2748,9 +2734,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, scm_t_signed_bits i = 0; UNPACK_8_8_8 (op, dst, idx_var, src); - vect = LOCAL_REF (dst); - idx = LOCAL_REF (idx_var); - val = LOCAL_REF (src); + vect = SP_REF (dst); + idx = SP_REF (idx_var); + val = SP_REF (src); VM_ASSERT (SCM_I_IS_VECTOR (vect), vm_error_not_a_vector ("vector-ref", vect)); @@ -2773,8 +2759,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, SCM vect, val; UNPACK_8_8_8 (op, dst, idx, src); - vect = LOCAL_REF (dst); - val = LOCAL_REF (src); + vect = SP_REF (dst); + val = SP_REF (src); VM_ASSERT (SCM_I_IS_VECTOR (vect), vm_error_not_a_vector ("vector-ref", vect)); @@ -2816,8 +2802,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_8_8_8 (op, dst, vtable, nfields); SYNC_IP (); - ret = scm_allocate_struct (LOCAL_REF (vtable), LOCAL_REF (nfields)); - LOCAL_SET (dst, ret); + ret = scm_allocate_struct (SP_REF (vtable), SP_REF (nfields)); + SP_SET (dst, ret); NEXT (1); } @@ -2835,8 +2821,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_8_8_8 (op, dst, src, idx); - obj = LOCAL_REF (src); - index = LOCAL_REF (idx); + obj = SP_REF (src); + index = SP_REF (idx); if (SCM_LIKELY (SCM_STRUCTP (obj) && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, @@ -2863,9 +2849,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_8_8_8 (op, dst, idx, src); - obj = LOCAL_REF (dst); - val = LOCAL_REF (src); - index = LOCAL_REF (idx); + obj = SP_REF (dst); + val = SP_REF (src); + index = SP_REF (idx); if (SCM_LIKELY (SCM_STRUCTP (obj) && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, @@ -2901,8 +2887,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_8_8_8 (op, dst, vtable, nfields); SYNC_IP (); - ret = scm_allocate_struct (LOCAL_REF (vtable), SCM_I_MAKINUM (nfields)); - LOCAL_SET (dst, ret); + ret = scm_allocate_struct (SP_REF (vtable), SCM_I_MAKINUM (nfields)); + SP_SET (dst, ret); NEXT (1); } @@ -2919,7 +2905,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_8_8_8 (op, dst, src, idx); - obj = LOCAL_REF (src); + obj = SP_REF (src); if (SCM_LIKELY (SCM_STRUCTP (obj) && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, @@ -2944,8 +2930,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_8_8_8 (op, dst, idx, src); - obj = LOCAL_REF (dst); - val = LOCAL_REF (src); + obj = SP_REF (dst); + val = SP_REF (src); if (SCM_LIKELY (SCM_STRUCTP (obj) && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, @@ -3001,8 +2987,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, offset = ip[3]; len = ip[4]; SYNC_IP (); - LOCAL_SET (dst, scm_from_contiguous_typed_array (LOCAL_REF (type), - LOCAL_REF (shape), + SP_SET (dst, scm_from_contiguous_typed_array (SP_REF (type), + SP_REF (shape), ip + offset, len)); NEXT (5); } @@ -3019,8 +3005,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_24 (ip[2], fill); UNPACK_24 (ip[3], bounds); SYNC_IP (); - LOCAL_SET (dst, scm_make_typed_array (LOCAL_REF (type), LOCAL_REF (fill), - LOCAL_REF (bounds))); + SP_SET (dst, scm_make_typed_array (SP_REF (type), SP_REF (fill), + SP_REF (bounds))); NEXT (4); } @@ -3171,9 +3157,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, scm_t_ ## type *int_ptr; \ \ UNPACK_8_8_8 (op, dst, idx, src); \ - bv = LOCAL_REF (dst); \ - scm_idx = LOCAL_REF (idx); \ - val = LOCAL_REF (src); \ + bv = SP_REF (dst); \ + scm_idx = SP_REF (idx); \ + val = SP_REF (src); \ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ i = SCM_I_INUM (scm_idx); \ int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ @@ -3202,9 +3188,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, scm_t_ ## type *int_ptr; \ \ UNPACK_8_8_8 (op, dst, idx, src); \ - bv = LOCAL_REF (dst); \ - scm_idx = LOCAL_REF (idx); \ - val = LOCAL_REF (src); \ + bv = SP_REF (dst); \ + scm_idx = SP_REF (idx); \ + val = SP_REF (src); \ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ i = SCM_I_INUM (scm_idx); \ int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ @@ -3230,9 +3216,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, type *float_ptr; \ \ UNPACK_8_8_8 (op, dst, idx, src); \ - bv = LOCAL_REF (dst); \ - scm_idx = LOCAL_REF (idx); \ - val = LOCAL_REF (src); \ + bv = SP_REF (dst); \ + scm_idx = SP_REF (idx); \ + val = SP_REF (src); \ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ i = SCM_I_INUM (scm_idx); \ float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ @@ -3440,8 +3426,11 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, #undef INIT #undef INUM_MAX #undef INUM_MIN -#undef LOCAL_REF -#undef LOCAL_SET +#undef FP_REF +#undef FP_SET +#undef FP_SLOT +#undef SP_REF +#undef SP_SET #undef NEXT #undef NEXT_HOOK #undef NEXT_JUMP diff --git a/libguile/vm.c b/libguile/vm.c index 2db079550..9d9cc3129 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -649,9 +649,9 @@ static const scm_t_uint32 vm_builtin_abort_to_prompt_code[] = { static const scm_t_uint32 vm_builtin_call_with_values_code[] = { SCM_PACK_OP_24 (assert_nargs_ee, 3), SCM_PACK_OP_24 (alloc_frame, 7), - SCM_PACK_OP_12_12 (mov, 6, 1), + SCM_PACK_OP_12_12 (mov, 0, 5), SCM_PACK_OP_24 (call, 6), SCM_PACK_OP_ARG_8_24 (0, 1), - SCM_PACK_OP_12_12 (mov, 0, 2), + SCM_PACK_OP_24 (long_fmov, 0), SCM_PACK_OP_ARG_8_24 (0, 2), SCM_PACK_OP_24 (tail_call_shuffle, 7) }; diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 498bac9b3..5b0c32990 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -100,9 +100,12 @@ (define (constant sym) (lookup-constant-value sym allocation)) + (define (from-sp var) + (- frame-size 1 var)) + (define (maybe-mov dst src) (unless (= dst src) - (emit-mov asm dst src))) + (emit-mov asm (from-sp dst) (from-sp src)))) (define (compile-tail label exp) ;; There are only three kinds of expressions in tail position: @@ -110,12 +113,12 @@ (match exp (($ $call proc args) (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) + ((src . dst) (emit-mov asm (from-sp dst) (from-sp src)))) (lookup-parallel-moves label allocation)) (emit-tail-call asm (1+ (length args)))) (($ $callk k proc args) (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) + ((src . dst) (emit-mov asm (from-sp dst) (from-sp src)))) (lookup-parallel-moves label allocation)) (emit-tail-call-label asm (1+ (length args)) k)) (($ $values ()) @@ -123,83 +126,109 @@ (emit-return-values asm)) (($ $values (arg)) (if (maybe-slot arg) - (emit-return asm (slot arg)) + (emit-return asm (from-sp (slot arg))) (begin - (emit-load-constant asm 1 (constant arg)) - (emit-return asm 1)))) + (when (< frame-size 2) + (emit-alloc-frame asm 2)) + (emit-load-constant asm (from-sp 1) (constant arg)) + (emit-return asm (from-sp 1))))) (($ $values args) (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) + ((src . dst) (emit-mov asm (from-sp dst) (from-sp src)))) (lookup-parallel-moves label allocation)) (emit-reset-frame asm (1+ (length args))) (emit-return-values asm)) (($ $primcall 'return (arg)) - (emit-return asm (slot arg))))) + (emit-return asm (from-sp (slot arg)))))) (define (compile-value label exp dst) (match exp (($ $values (arg)) (maybe-mov dst (slot arg))) (($ $const exp) - (emit-load-constant asm dst exp)) + (emit-load-constant asm (from-sp dst) exp)) (($ $closure k 0) - (emit-load-static-procedure asm dst k)) + (emit-load-static-procedure asm (from-sp dst) k)) (($ $closure k nfree) - (emit-make-closure asm dst k nfree)) + (emit-make-closure asm (from-sp dst) k nfree)) (($ $primcall 'current-module) - (emit-current-module asm dst)) + (emit-current-module asm (from-sp dst))) (($ $primcall 'cached-toplevel-box (scope name bound?)) - (emit-cached-toplevel-box asm dst (constant scope) (constant name) + (emit-cached-toplevel-box asm (from-sp dst) + (constant scope) (constant name) (constant bound?))) (($ $primcall 'cached-module-box (mod name public? bound?)) - (emit-cached-module-box asm dst (constant mod) (constant name) + (emit-cached-module-box asm (from-sp dst) + (constant mod) (constant name) (constant public?) (constant bound?))) (($ $primcall 'resolve (name bound?)) - (emit-resolve asm dst (constant bound?) (slot name))) + (emit-resolve asm (from-sp dst) (constant bound?) + (from-sp (slot name)))) (($ $primcall 'free-ref (closure idx)) - (emit-free-ref asm dst (slot closure) (constant idx))) + (emit-free-ref asm (from-sp dst) (from-sp (slot closure)) + (constant idx))) (($ $primcall 'vector-ref (vector index)) - (emit-vector-ref asm dst (slot vector) (slot index))) + (emit-vector-ref asm (from-sp dst) (from-sp (slot vector)) + (from-sp (slot index)))) (($ $primcall 'make-vector (length init)) - (emit-make-vector asm dst (slot length) (slot init))) + (emit-make-vector asm (from-sp dst) (from-sp (slot length)) + (from-sp (slot init)))) (($ $primcall 'make-vector/immediate (length init)) - (emit-make-vector/immediate asm dst (constant length) (slot init))) + (emit-make-vector/immediate asm (from-sp dst) (constant length) + (from-sp (slot init)))) (($ $primcall 'vector-ref/immediate (vector index)) - (emit-vector-ref/immediate asm dst (slot vector) (constant index))) + (emit-vector-ref/immediate asm (from-sp dst) (from-sp (slot vector)) + (constant index))) (($ $primcall 'allocate-struct (vtable nfields)) - (emit-allocate-struct asm dst (slot vtable) (slot nfields))) + (emit-allocate-struct asm (from-sp dst) (from-sp (slot vtable)) + (from-sp (slot nfields)))) (($ $primcall 'allocate-struct/immediate (vtable nfields)) - (emit-allocate-struct/immediate asm dst (slot vtable) (constant nfields))) + (emit-allocate-struct/immediate asm (from-sp dst) + (from-sp (slot vtable)) + (constant nfields))) (($ $primcall 'struct-ref (struct n)) - (emit-struct-ref asm dst (slot struct) (slot n))) + (emit-struct-ref asm (from-sp dst) (from-sp (slot struct)) + (from-sp (slot n)))) (($ $primcall 'struct-ref/immediate (struct n)) - (emit-struct-ref/immediate asm dst (slot struct) (constant n))) + (emit-struct-ref/immediate asm (from-sp dst) (from-sp (slot struct)) + (constant n))) (($ $primcall 'builtin-ref (name)) - (emit-builtin-ref asm dst (constant name))) + (emit-builtin-ref asm (from-sp dst) (constant name))) (($ $primcall 'bv-u8-ref (bv idx)) - (emit-bv-u8-ref asm dst (slot bv) (slot idx))) + (emit-bv-u8-ref asm (from-sp dst) (from-sp (slot bv)) + (from-sp (slot idx)))) (($ $primcall 'bv-s8-ref (bv idx)) - (emit-bv-s8-ref asm dst (slot bv) (slot idx))) + (emit-bv-s8-ref asm (from-sp dst) (from-sp (slot bv)) + (from-sp (slot idx)))) (($ $primcall 'bv-u16-ref (bv idx)) - (emit-bv-u16-ref asm dst (slot bv) (slot idx))) + (emit-bv-u16-ref asm (from-sp dst) (from-sp (slot bv)) + (from-sp (slot idx)))) (($ $primcall 'bv-s16-ref (bv idx)) - (emit-bv-s16-ref asm dst (slot bv) (slot idx))) + (emit-bv-s16-ref asm (from-sp dst) (from-sp (slot bv)) + (from-sp (slot idx)))) (($ $primcall 'bv-u32-ref (bv idx val)) - (emit-bv-u32-ref asm dst (slot bv) (slot idx))) + (emit-bv-u32-ref asm (from-sp dst) (from-sp (slot bv)) + (from-sp (slot idx)))) (($ $primcall 'bv-s32-ref (bv idx val)) - (emit-bv-s32-ref asm dst (slot bv) (slot idx))) + (emit-bv-s32-ref asm (from-sp dst) (from-sp (slot bv)) + (from-sp (slot idx)))) (($ $primcall 'bv-u64-ref (bv idx val)) - (emit-bv-u64-ref asm dst (slot bv) (slot idx))) + (emit-bv-u64-ref asm (from-sp dst) (from-sp (slot bv)) + (from-sp (slot idx)))) (($ $primcall 'bv-s64-ref (bv idx val)) - (emit-bv-s64-ref asm dst (slot bv) (slot idx))) + (emit-bv-s64-ref asm (from-sp dst) (from-sp (slot bv)) + (from-sp (slot idx)))) (($ $primcall 'bv-f32-ref (bv idx val)) - (emit-bv-f32-ref asm dst (slot bv) (slot idx))) + (emit-bv-f32-ref asm (from-sp dst) (from-sp (slot bv)) + (from-sp (slot idx)))) (($ $primcall 'bv-f64-ref (bv idx val)) - (emit-bv-f64-ref asm dst (slot bv) (slot idx))) + (emit-bv-f64-ref asm (from-sp dst) (from-sp (slot bv)) + (from-sp (slot idx)))) (($ $primcall name args) ;; FIXME: Inline all the cases. (let ((inst (prim-instruction name))) - (emit-text asm `((,inst ,dst ,@(map slot args)))))))) + (emit-text asm `((,inst ,(from-sp dst) + ,@(map (compose from-sp slot) args)))))))) (define (compile-effect label exp k) (match exp @@ -210,7 +239,8 @@ (let ((receive-args (gensym "handler")) (nreq (length req)) (proc-slot (lookup-call-proc-slot label allocation))) - (emit-prompt asm (slot tag) escape? proc-slot receive-args) + (emit-prompt asm (from-sp (slot tag)) escape? proc-slot + receive-args) (emit-br asm k) (emit-label asm receive-args) (unless (and rest (zero? nreq)) @@ -221,57 +251,71 @@ (maybe-slot rest)))) (emit-bind-rest asm (+ proc-slot 1 nreq))) (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) + ((src . dst) (emit-fmov asm dst src))) (lookup-parallel-moves handler allocation)) (emit-reset-frame asm frame-size) (emit-br asm (forward-label khandler-body)))))) (($ $primcall 'cache-current-module! (sym scope)) - (emit-cache-current-module! asm (slot sym) (constant scope))) + (emit-cache-current-module! asm (from-sp (slot sym)) (constant scope))) (($ $primcall 'free-set! (closure idx value)) - (emit-free-set! asm (slot closure) (slot value) (constant idx))) + (emit-free-set! asm (from-sp (slot closure)) (from-sp (slot value)) + (constant idx))) (($ $primcall 'box-set! (box value)) - (emit-box-set! asm (slot box) (slot value))) + (emit-box-set! asm (from-sp (slot box)) (from-sp (slot value)))) (($ $primcall 'struct-set! (struct index value)) - (emit-struct-set! asm (slot struct) (slot index) (slot value))) + (emit-struct-set! asm (from-sp (slot struct)) (from-sp (slot index)) + (from-sp (slot value)))) (($ $primcall 'struct-set!/immediate (struct index value)) - (emit-struct-set!/immediate asm (slot struct) (constant index) (slot value))) + (emit-struct-set!/immediate asm (from-sp (slot struct)) + (constant index) (from-sp (slot value)))) (($ $primcall 'vector-set! (vector index value)) - (emit-vector-set! asm (slot vector) (slot index) (slot value))) + (emit-vector-set! asm (from-sp (slot vector)) (from-sp (slot index)) + (from-sp (slot value)))) (($ $primcall 'vector-set!/immediate (vector index value)) - (emit-vector-set!/immediate asm (slot vector) (constant index) - (slot value))) + (emit-vector-set!/immediate asm (from-sp (slot vector)) + (constant index) (from-sp (slot value)))) (($ $primcall 'set-car! (pair value)) - (emit-set-car! asm (slot pair) (slot value))) + (emit-set-car! asm (from-sp (slot pair)) (from-sp (slot value)))) (($ $primcall 'set-cdr! (pair value)) - (emit-set-cdr! asm (slot pair) (slot value))) + (emit-set-cdr! asm (from-sp (slot pair)) (from-sp (slot value)))) (($ $primcall 'define! (sym value)) - (emit-define! asm (slot sym) (slot value))) + (emit-define! asm (from-sp (slot sym)) (from-sp (slot value)))) (($ $primcall 'push-fluid (fluid val)) - (emit-push-fluid asm (slot fluid) (slot val))) + (emit-push-fluid asm (from-sp (slot fluid)) (from-sp (slot val)))) (($ $primcall 'pop-fluid ()) (emit-pop-fluid asm)) (($ $primcall 'wind (winder unwinder)) - (emit-wind asm (slot winder) (slot unwinder))) + (emit-wind asm (from-sp (slot winder)) (from-sp (slot unwinder)))) (($ $primcall 'bv-u8-set! (bv idx val)) - (emit-bv-u8-set! asm (slot bv) (slot idx) (slot val))) + (emit-bv-u8-set! asm (from-sp (slot bv)) (from-sp (slot idx)) + (from-sp (slot val)))) (($ $primcall 'bv-s8-set! (bv idx val)) - (emit-bv-s8-set! asm (slot bv) (slot idx) (slot val))) + (emit-bv-s8-set! asm (from-sp (slot bv)) (from-sp (slot idx)) + (from-sp (slot val)))) (($ $primcall 'bv-u16-set! (bv idx val)) - (emit-bv-u16-set! asm (slot bv) (slot idx) (slot val))) + (emit-bv-u16-set! asm (from-sp (slot bv)) (from-sp (slot idx)) + (from-sp (slot val)))) (($ $primcall 'bv-s16-set! (bv idx val)) - (emit-bv-s16-set! asm (slot bv) (slot idx) (slot val))) + (emit-bv-s16-set! asm (from-sp (slot bv)) (from-sp (slot idx)) + (from-sp (slot val)))) (($ $primcall 'bv-u32-set! (bv idx val)) - (emit-bv-u32-set! asm (slot bv) (slot idx) (slot val))) + (emit-bv-u32-set! asm (from-sp (slot bv)) (from-sp (slot idx)) + (from-sp (slot val)))) (($ $primcall 'bv-s32-set! (bv idx val)) - (emit-bv-s32-set! asm (slot bv) (slot idx) (slot val))) + (emit-bv-s32-set! asm (from-sp (slot bv)) (from-sp (slot idx)) + (from-sp (slot val)))) (($ $primcall 'bv-u64-set! (bv idx val)) - (emit-bv-u64-set! asm (slot bv) (slot idx) (slot val))) + (emit-bv-u64-set! asm (from-sp (slot bv)) (from-sp (slot idx)) + (from-sp (slot val)))) (($ $primcall 'bv-s64-set! (bv idx val)) - (emit-bv-s64-set! asm (slot bv) (slot idx) (slot val))) + (emit-bv-s64-set! asm (from-sp (slot bv)) (from-sp (slot idx)) + (from-sp (slot val)))) (($ $primcall 'bv-f32-set! (bv idx val)) - (emit-bv-f32-set! asm (slot bv) (slot idx) (slot val))) + (emit-bv-f32-set! asm (from-sp (slot bv)) (from-sp (slot idx)) + (from-sp (slot val)))) (($ $primcall 'bv-f64-set! (bv idx val)) - (emit-bv-f64-set! asm (slot bv) (slot idx) (slot val))) + (emit-bv-f64-set! asm (from-sp (slot bv)) (from-sp (slot idx)) + (from-sp (slot val)))) (($ $primcall 'unwind ()) (emit-unwind asm)))) @@ -279,7 +323,7 @@ (match exp (($ $values args) (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) + ((src . dst) (emit-mov asm (from-sp dst) (from-sp src)))) (lookup-parallel-moves label allocation))))) (define (compile-test label exp kt kf next-label) @@ -294,22 +338,23 @@ (define (unary op sym) (cond ((eq? kt next-label) - (op asm (slot sym) #t kf)) + (op asm (from-sp (slot sym)) #t kf)) ((eq? kf next-label) - (op asm (slot sym) #f kt)) + (op asm (from-sp (slot sym)) #f kt)) (else (let ((invert? (not (prefer-true?)))) - (op asm (slot sym) invert? (if invert? kf kt)) + (op asm (from-sp (slot sym)) invert? (if invert? kf kt)) (emit-br asm (if invert? kt kf)))))) (define (binary op a b) (cond ((eq? kt next-label) - (op asm (slot a) (slot b) #t kf)) + (op asm (from-sp (slot a)) (from-sp (slot b)) #t kf)) ((eq? kf next-label) - (op asm (slot a) (slot b) #f kt)) + (op asm (from-sp (slot a)) (from-sp (slot b)) #f kt)) (else (let ((invert? (not (prefer-true?)))) - (op asm (slot a) (slot b) invert? (if invert? kf kt)) + (op asm (from-sp (slot a)) (from-sp (slot b)) invert? + (if invert? kf kt)) (emit-br asm (if invert? kt kf)))))) (match exp (($ $values (sym)) (unary emit-br-if-true sym)) @@ -344,7 +389,7 @@ (nargs (1+ (length args))) (arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs)))) (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) + ((src . dst) (emit-mov asm (from-sp dst) (from-sp src)))) (lookup-parallel-moves label allocation)) (emit-call asm proc-slot nargs) (emit-dead-slot-map asm proc-slot @@ -365,7 +410,7 @@ (when (and rest-var (maybe-slot rest-var)) (emit-bind-rest asm (+ proc-slot 1 nreq))) (for-each (match-lambda - ((src . dst) (emit-mov asm dst src))) + ((src . dst) (emit-fmov asm dst src))) (lookup-parallel-moves k allocation)) (emit-reset-frame asm frame-size))))) (match exp diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 8be36e716..b3068985c 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -537,12 +537,6 @@ are comparable with eqv?. A tmp slot may be used." ;; could be that they are out of the computed live set. In that case ;; they need to be adjoined to the live set, used when choosing a ;; temporary slot. - ;; - ;; Note that although we reserve slots 253-255 for shuffling operands - ;; that address less than the full 24-bit range of locals, that - ;; reservation doesn't apply here, because this temporary itself is - ;; used while doing parallel assignment via "mov", and "mov" does not - ;; need shuffling. (define (compute-tmp-slot live stack-slots) (find-first-zero (fold add-live-slot live stack-slots))) @@ -687,10 +681,9 @@ are comparable with eqv?. A tmp slot may be used." (match vars (() slots) ((var . vars) - (let ((n (if (<= 253 n 255) 256 n))) - (lp vars - (intmap-add! slots var n) - (1+ n))))))))) + (lp vars + (intmap-add! slots var n) + (1+ n)))))))) (_ slots))) cps empty-intmap)) @@ -701,15 +694,9 @@ are comparable with eqv?. A tmp slot may be used." (logand live-slots (lognot (ash 1 slot)))) (define-inlinable (compute-slot live-slots hint) - ;; Slots 253-255 are reserved for shuffling; see comments in - ;; assembler.scm. - (if (and hint (not (logbit? hint live-slots)) - (or (< hint 253) (> hint 255))) + (if (and hint (not (logbit? hint live-slots))) hint - (let ((slot (find-first-zero live-slots))) - (if (or (< slot 253) (> slot 255)) - slot - (+ 256 (find-first-zero (ash live-slots -256))))))) + (find-first-zero live-slots))) (define (allocate-lazy-vars cps slots call-allocs live-in lazy) (define (compute-live-slots slots label) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index f29105108..bad298d0d 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -97,6 +97,7 @@ emit-br-if-<= emit-br-if-logtest (emit-mov* . emit-mov) + (emit-fmov* . emit-fmov) (emit-box* . emit-box) (emit-box-ref* . emit-box-ref) (emit-box-set!* . emit-box-set!) @@ -638,166 +639,170 @@ later by the linker." (eval-when (expand) - ;; Some operands are encoded using a restricted subset of the full - ;; 24-bit local address space, in order to make the bytecode more - ;; dense in the usual case that there are few live locals. Here we - ;; define wrapper emitters that shuffle out-of-range operands into and - ;; out of the reserved range of locals [233,255]. This range is - ;; sufficient because these restricted operands are only present in - ;; the first word of an instruction. Since 8 bits is the smallest - ;; slot-addressing operand size, that means we can fit 3 operands in - ;; the 24 bits of payload of the first word (the lower 8 bits being - ;; taken by the opcode). + ;; In Guile's VM, locals are usually addressed via the stack pointer + ;; (SP). There can be up to 2^24 slots for local variables in a + ;; frame. Some instructions encode their operands using a restricted + ;; subset of the full 24-bit local address space, in order to make the + ;; bytecode more dense in the usual case that a function needs few + ;; local slots. To allow these instructions to be used when there are + ;; many local slots, we can temporarily push the values on the stack, + ;; operate on them there, and then store back any result as we pop the + ;; SP to its original position. ;; - ;; The result are wrapper emitters with the same arity, - ;; e.g. emit-cons* that wraps emit-cons. We expose these wrappers as - ;; the public interface for emitting `cons' instructions. That way we - ;; solve the problem fully and in just one place. The only manual - ;; care that need be taken is in the exports list at the top of the - ;; file -- to be sure that we export the wrapper and not the wrapped - ;; emitter. + ;; We implement this shuffling via wrapper emitters that have the same + ;; arity as the emitter they wrap, e.g. emit-cons* that wraps + ;; emit-cons. We expose these wrappers as the public interface for + ;; emitting `cons' instructions. That way we solve the problem fully + ;; and in just one place. The only manual care that need be taken is + ;; in the exports list at the top of the file -- to be sure that we + ;; export the wrapper and not the wrapped emitter. - (define (shuffling-assembler name kind word0 word*) - (define (analyze-first-word) - (define-syntax op-case - (syntax-rules () - ((_ type ((%type %kind arg ...) values) clause ...) - (if (and (eq? type '%type) (eq? kind '%kind)) - (with-syntax (((arg ...) (generate-temporaries #'(arg ...)))) - #'((arg ...) values)) - (op-case type clause ...))) - ((_ type) - #f))) - (op-case - word0 - ((X8_S8_I16 <- a imm) - (values (if (< a (ash 1 8)) a 253) - imm)) - ((X8_S12_S12 ! a b) - (values (if (< a (ash 1 12)) a (begin (emit-mov* asm 253 a) 253)) - (if (< b (ash 1 12)) b (begin (emit-mov* asm 254 b) 254)))) - ((X8_S12_S12 <- a b) - (values (if (< a (ash 1 12)) a 253) - (if (< b (ash 1 12)) b (begin (emit-mov* asm 254 b) 254)))) - ((X8_S12_C12 <- a b) - (values (if (< a (ash 1 12)) a 253) - b)) + (define (shuffling-assembler emit kind word0 word*) + (with-syntax ((emit emit)) + (match (cons* word0 kind word*) + (('X8_S12_S12 '!) + #'(lambda (asm a b) + (cond + ((< (logior a b) (ash 1 12)) + (emit asm a b)) + (else + (emit-push asm a) + (emit-push asm (1+ b)) + (emit asm 1 0) + (emit-drop asm 2))))) + (('X8_S12_S12 '<-) + #'(lambda (asm dst a) + (cond + ((< (logior dst a) (ash 1 12)) + (emit asm dst a)) + (else + (emit-push asm a) + (emit asm 0 0) + (emit-pop asm dst))))) - ((X8_S8_S8_S8 ! a b c) - (values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253)) - (if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254)) - (if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255)))) - ((X8_S8_S8_S8 <- a b c) - (values (if (< a (ash 1 8)) a 253) - (if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254)) - (if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255)))) + (('X8_S12_S12 '! 'X8_C24) + #'(lambda (asm a b c) + (cond + ((< (logior a b) (ash 1 12)) + (emit asm a b c)) + (else + (emit-push asm a) + (emit-push asm (1+ b)) + (emit asm 1 0 c) + (emit-drop asm 2))))) + (('X8_S12_S12 '<- 'X8_C24) + #'(lambda (asm dst a c) + (cond + ((< (logior dst a) (ash 1 12)) + (emit asm dst a c)) + (else + (emit-push asm a) + (emit asm 0 0 c) + (emit-pop asm dst))))) - ((X8_S8_S8_C8 ! a b c) - (values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253)) - (if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254)) - c)) - ((X8_S8_S8_C8 <- a b c) - (values (if (< a (ash 1 8)) a 253) - (if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254)) - c)) + (('X8_S12_C12 '<-) + #'(lambda (asm dst const) + (cond + ((< dst (ash 1 12)) + (emit asm dst const)) + (else + ;; Push garbage value to make space for dst. + (emit-push asm dst) + (emit asm 0 const) + (emit-pop asm dst))))) - ((X8_S8_C8_S8 ! a b c) - (values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253)) - b - (if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255)))) - ((X8_S8_C8_S8 <- a b c) - (values (if (< a (ash 1 8)) a 253) - b - (if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255)))))) + (('X8_S8_I16 '<-) + #'(lambda (asm dst imm) + (cond + ((< dst (ash 1 8)) + (emit asm dst imm)) + (else + ;; Push garbage value to make space for dst. + (emit-push asm dst) + (emit asm 0 imm) + (emit-pop asm dst))))) - (define (tail-formals type) - (define-syntax op-case - (syntax-rules () - ((op-case type (%type arg ...) clause ...) - (if (eq? type '%type) - (generate-temporaries #'(arg ...)) - (op-case type clause ...))) - ((op-case type) - (error "unmatched type" type)))) - (op-case type - (C32 a) - (I32 imm) - (A32 imm) - (B32) - (N32 label) - (R32 label) - (L32 label) - (LO32 label offset) - (C8_C24 a b) - (B1_C7_L24 a b label) - (B1_X7_S24 a b) - (B1_X7_F24 a b) - (B1_X7_C24 a b) - (B1_X7_L24 a label) - (B1_X31 a) - (X8_S24 a) - (X8_F24 a) - (X8_C24 a) - (X8_L24 label))) + (('X8_S8_S8_S8 '!) + #'(lambda (asm a b c) + (cond + ((< (logior a b c) (ash 1 8)) + (emit asm a b c)) + (else + (emit-push asm a) + (emit-push asm (+ b 1)) + (emit-push asm (+ c 2)) + (emit asm 2 1 0) + (emit-drop asm 3))))) + (('X8_S8_S8_S8 '<-) + #'(lambda (asm dst a b) + (cond + ((< (logior dst a b) (ash 1 8)) + (emit asm dst a b)) + (else + (emit-push asm a) + (emit-push asm (1+ b)) + (emit asm 1 1 0) + (emit-drop asm 1) + (emit-pop asm dst))))) - (define (shuffle-up dst) - (define-syntax op-case - (syntax-rules () - ((_ type ((%type ...) exp) clause ...) - (if (memq type '(%type ...)) - #'exp - (op-case type clause ...))) - ((_ type) - (error "unexpected type" type)))) - (with-syntax ((dst dst)) - (op-case - word0 - ((X8_S8_I16 X8_S8_S8_S8 X8_S8_S8_C8 X8_S8_C8_S8) - (unless (< dst (ash 1 8)) - (emit-mov* asm dst 253))) - ((X8_S12_S12 X8_S12_C12) - (unless (< dst (ash 1 12)) - (emit-mov* asm dst 253)))))) + (('X8_S8_S8_C8 '<-) + #'(lambda (asm dst a const) + (cond + ((< (logior dst a) (ash 1 8)) + (emit asm dst a const)) + (else + (emit-push asm a) + (emit asm 0 0 const) + (emit-pop asm dst))))) - (and=> - (analyze-first-word) - (lambda (formals+shuffle) - (with-syntax ((emit-name (id-append name #'emit- name)) - (((formal0 ...) shuffle) formals+shuffle) - (((formal* ...) ...) (map tail-formals word*))) - (with-syntax (((shuffle-up-dst ...) - (if (eq? kind '<-) - (syntax-case #'(formal0 ...) () - ((dst . _) - (list (shuffle-up #'dst)))) - '()))) - #'(lambda (asm formal0 ... formal* ... ...) - (call-with-values (lambda () shuffle) - (lambda (formal0 ...) - (emit-name asm formal0 ... formal* ... ...))) - shuffle-up-dst ...)))))) + (('X8_S8_C8_S8 '!) + #'(lambda (asm a const b) + (cond + ((< (logior a b) (ash 1 8)) + (emit asm a const b)) + (else + (emit-push asm a) + (emit-push asm (1+ b)) + (emit asm 1 const 0) + (emit-drop asm 2))))) + (('X8_S8_C8_S8 '<-) + #'(lambda (asm dst const a) + (cond + ((< (logior dst a) (ash 1 8)) + (emit asm dst const a)) + (else + (emit-push asm a) + (emit asm 0 const 0) + (emit-pop asm dst)))))))) (define-syntax define-shuffling-assembler (lambda (stx) + (define (might-shuffle? word0) + (case word0 + ((X8_S12_S12 X8_S12_C12 + X8_S8_I16 + X8_S8_S8_S8 X8_S8_S8_C8 X8_S8_C8_S8) #t) + (else #f))) + (syntax-case stx () ((_ #:except (except ...) name opcode kind word0 word* ...) - (cond - ((or-map (lambda (op) (eq? (syntax->datum #'name) op)) - (map syntax->datum #'(except ...))) - #'(begin)) - ((shuffling-assembler #'name (syntax->datum #'kind) - (syntax->datum #'word0) - (map syntax->datum #'(word* ...))) - => (lambda (proc) - (with-syntax ((emit (id-append #'name - (id-append #'name #'emit- #'name) - #'*)) - (proc proc)) - #'(define emit - (let ((emit proc)) - (hashq-set! assemblers 'name emit) - emit))))) - (else #'(begin)))))))) + (let ((_except (syntax->datum #'(except ...))) + (_name (syntax->datum #'name)) + (_kind (syntax->datum #'kind)) + (_word0 (syntax->datum #'word0)) + (_word* (syntax->datum #'(word* ...))) + (emit (id-append #'name #'emit- #'name))) + (cond + ((and (might-shuffle? _word0) (not (memq _name _except))) + (with-syntax + ((emit* (id-append #'name emit #'*)) + (proc (shuffling-assembler emit _kind _word0 _word*))) + #'(define emit* + (let ((emit* proc)) + (hashq-set! assemblers 'name emit*) + emit*)))) + (else + #'(begin))))))))) (visit-opcodes define-shuffling-assembler #:except (receive mov)) @@ -809,6 +814,9 @@ later by the linker." (emit-mov asm dst src) (emit-long-mov asm dst src))) +(define (emit-fmov* asm dst src) + (emit-long-fmov asm dst src)) + (define (emit-receive* asm dst proc nlocals) (if (and (< dst (ash 1 12)) (< proc (ash 1 12))) (emit-receive asm dst proc nlocals) @@ -1104,19 +1112,6 @@ returned instead." (set-arity-definitions! arity (reverse (arity-definitions arity))) (set-arity-high-pc! arity (asm-start asm)))) -;; As noted above, we reserve locals 253 through 255 for shuffling large -;; operands. However the calling convention has all arguments passed in -;; a contiguous block. This helper, called after the clause has been -;; chosen and the keyword/optional/rest arguments have been processed, -;; shuffles up arguments from slot 253 and higher into their final -;; allocations. -;; -(define (shuffle-up-args asm nargs) - (when (> nargs 253) - (let ((slot (1- nargs))) - (emit-mov asm (+ slot 3) slot) - (shuffle-up-args asm (1- nargs))))) - (define-macro-assembler (standard-prelude asm nreq nlocals alternate) (cond (alternate @@ -1126,8 +1121,7 @@ returned instead." (emit-assert-nargs-ee/locals asm nreq (- nlocals nreq))) (else (emit-assert-nargs-ee asm nreq) - (emit-alloc-frame asm nlocals))) - (shuffle-up-args asm nreq)) + (emit-alloc-frame asm nlocals)))) (define-macro-assembler (opt-prelude asm nreq nopt rest? nlocals alternate) (if alternate @@ -1140,8 +1134,7 @@ returned instead." (emit-br-if-nargs-gt asm (+ nreq nopt) alternate)) (else (emit-assert-nargs-le asm (+ nreq nopt)))) - (emit-alloc-frame asm nlocals) - (shuffle-up-args asm (+ nreq nopt (if rest? 1 0)))) + (emit-alloc-frame asm nlocals)) (define-macro-assembler (kw-prelude asm nreq nopt rest? kw-indices allow-other-keys? nlocals alternate) @@ -1162,8 +1155,7 @@ returned instead." (+ nreq nopt) ntotal (intern-constant asm kw-indices)) - (emit-alloc-frame asm nlocals) - (shuffle-up-args asm ntotal))) + (emit-alloc-frame asm nlocals))) (define-macro-assembler (label asm sym) (hashq-set! (asm-labels asm) sym (asm-start asm))) diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test index 082e44fa9..952916963 100644 --- a/test-suite/tests/rtl.test +++ b/test-suite/tests/rtl.test @@ -40,8 +40,8 @@ a procedure." (assemble-program `((begin-program foo ((name . foo))) (begin-standard-arity () 2 #f) - (load-constant 1 ,val) - (return 1) + (load-constant 0 ,val) + (return 0) (end-arity) (end-program)))) @@ -82,15 +82,15 @@ a procedure." (((assemble-program `((begin-program foo ((name . foo))) (begin-standard-arity () 2 #f) - (load-static-procedure 1 bar) - (return 1) + (load-static-procedure 0 bar) + (return 0) (end-arity) (end-program) (begin-program bar ((name . bar))) (begin-standard-arity () 2 #f) - (load-constant 1 42) - (return 1) + (load-constant 0 42) + (return 0) (end-arity) (end-program))))))) @@ -107,16 +107,16 @@ a procedure." (definition x 1) (br fix-body) (label loop-head) - (br-if-= 2 1 #f out) - (add 3 2 3) - (add1 2 2) + (br-if-= 1 2 #f out) + (add 0 1 0) + (add1 1 1) (br loop-head) (label fix-body) - (load-constant 2 0) - (load-constant 3 0) + (load-constant 1 0) + (load-constant 0 0) (br loop-head) (label out) - (return 3) + (return 0) (end-arity) (end-program))))) (sumto 1000)))) @@ -133,20 +133,20 @@ a procedure." (begin-standard-arity () 3 #f) (load-constant 1 0) (box 1 1) - (make-closure 2 accum 1) - (free-set! 2 1 0) - (return 2) + (make-closure 0 accum 1) + (free-set! 0 1 0) + (return 0) (end-arity) (end-program) (begin-program accum ((name . accum))) (begin-standard-arity (x) 4 #f) (definition x 1) - (free-ref 2 0 0) - (box-ref 3 2) - (add 3 3 1) - (box-set! 2 3) - (return 3) + (free-ref 1 3 0) + (box-ref 0 1) + (add 0 0 2) + (box-set! 1 0) + (return 0) (end-arity) (end-program))))) (let ((accum (make-accum))) @@ -162,10 +162,10 @@ a procedure." ((name . call))) (begin-standard-arity (f) 7 #f) (definition f 1) - (mov 5 1) + (mov 1 5) (call 5 1) (receive 2 5 7) - (return 2) + (return 4) (end-arity) (end-program))))) (call (lambda () 42)))) @@ -177,11 +177,11 @@ a procedure." ((name . call-with-3))) (begin-standard-arity (f) 7 #f) (definition f 1) - (mov 5 1) - (load-constant 6 3) + (mov 1 5) + (load-constant 0 3) (call 5 2) (receive 2 5 7) - (return 2) + (return 4) (end-arity) (end-program))))) (call-with-3 (lambda (x) (* x 2)))))) @@ -194,7 +194,7 @@ a procedure." ((name . call))) (begin-standard-arity (f) 2 #f) (definition f 1) - (mov 0 1) + (mov 1 0) (tail-call 1) (end-arity) (end-program))))) @@ -207,8 +207,8 @@ a procedure." ((name . call-with-3))) (begin-standard-arity (f) 2 #f) (definition f 1) - (mov 0 1) ;; R0 <- R1 - (load-constant 1 3) ;; R1 <- 3 + (mov 1 0) ;; R0 <- R1 + (load-constant 0 3) ;; R1 <- 3 (tail-call 2) (end-arity) (end-program))))) @@ -221,10 +221,10 @@ a procedure." '((begin-program get-sqrt-trampoline ((name . get-sqrt-trampoline))) (begin-standard-arity () 2 #f) - (current-module 1) - (cache-current-module! 1 sqrt-scope) - (load-static-procedure 1 sqrt-trampoline) - (return 1) + (current-module 0) + (cache-current-module! 0 sqrt-scope) + (load-static-procedure 0 sqrt-trampoline) + (return 0) (end-arity) (end-program) @@ -232,8 +232,8 @@ a procedure." ((name . sqrt-trampoline))) (begin-standard-arity (x) 3 #f) (definition x 1) - (cached-toplevel-box 2 sqrt-scope sqrt #t) - (box-ref 0 2) + (cached-toplevel-box 0 sqrt-scope sqrt #t) + (box-ref 2 0) (tail-call 2) (end-arity) (end-program))))) @@ -249,10 +249,10 @@ a procedure." '((begin-program make-top-incrementor ((name . make-top-incrementor))) (begin-standard-arity () 2 #f) - (current-module 1) - (cache-current-module! 1 top-incrementor) - (load-static-procedure 1 top-incrementor) - (return 1) + (current-module 0) + (cache-current-module! 0 top-incrementor) + (load-static-procedure 0 top-incrementor) + (return 0) (end-arity) (end-program) @@ -260,9 +260,9 @@ a procedure." ((name . top-incrementor))) (begin-standard-arity () 3 #f) (cached-toplevel-box 1 top-incrementor *top-val* #t) - (box-ref 2 1) - (add1 2 2) - (box-set! 1 2) + (box-ref 0 1) + (add1 0 0) + (box-set! 1 0) (reset-frame 1) (return-values) (end-arity) @@ -277,8 +277,8 @@ a procedure." '((begin-program get-sqrt-trampoline ((name . get-sqrt-trampoline))) (begin-standard-arity () 2 #f) - (load-static-procedure 1 sqrt-trampoline) - (return 1) + (load-static-procedure 0 sqrt-trampoline) + (return 0) (end-arity) (end-program) @@ -286,8 +286,8 @@ a procedure." ((name . sqrt-trampoline))) (begin-standard-arity (x) 3 #f) (definition x 1) - (cached-module-box 2 (guile) sqrt #t #t) - (box-ref 0 2) + (cached-module-box 0 (guile) sqrt #t #t) + (box-ref 2 0) (tail-call 2) (end-arity) (end-program))))) @@ -301,8 +301,8 @@ a procedure." '((begin-program make-top-incrementor ((name . make-top-incrementor))) (begin-standard-arity () 2 #f) - (load-static-procedure 1 top-incrementor) - (return 1) + (load-static-procedure 0 top-incrementor) + (return 0) (end-arity) (end-program) @@ -310,10 +310,10 @@ a procedure." ((name . top-incrementor))) (begin-standard-arity () 3 #f) (cached-module-box 1 (tests bytecode) *top-val* #f #t) - (box-ref 2 1) - (add1 2 2) - (box-set! 1 2) - (return 2) + (box-ref 0 1) + (add1 0 0) + (box-set! 1 0) + (return 0) (end-arity) (end-program))))) ((make-top-incrementor)) @@ -323,8 +323,8 @@ a procedure." (let ((return-3 (assemble-program '((begin-program return-3 ((name . return-3))) (begin-standard-arity () 2 #f) - (load-constant 1 3) - (return 1) + (load-constant 0 3) + (return 0) (end-arity) (end-program))))) (pass-if "program name" @@ -345,8 +345,8 @@ a procedure." (assemble-program '((begin-program foo ((name . foo))) (begin-standard-arity () 2 #f) - (load-constant 1 42) - (return 1) + (load-constant 0 42) + (return 0) (end-arity) (end-program)))))) @@ -356,8 +356,8 @@ a procedure." (assemble-program '((begin-program foo ((name . foo))) (begin-standard-arity () 2 #f) - (load-constant 1 42) - (return 1) + (load-constant 0 42) + (return 0) (end-arity) (end-program))))) (pass-if-equal "#" From 4afb46f8599854dd36af25576ec4b7ab1c39745f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 21 Oct 2015 15:02:08 +0200 Subject: [PATCH 061/865] Minor assembler cleanups * module/system/vm/assembler.scm (shuffling-assembler): Minor renames. --- module/system/vm/assembler.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index bad298d0d..d50ab13b5 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -691,13 +691,13 @@ later by the linker." (emit asm 1 0 c) (emit-drop asm 2))))) (('X8_S12_S12 '<- 'X8_C24) - #'(lambda (asm dst a c) + #'(lambda (asm dst a const) (cond ((< (logior dst a) (ash 1 12)) - (emit asm dst a c)) + (emit asm dst a const)) (else (emit-push asm a) - (emit asm 0 0 c) + (emit asm 0 0 const) (emit-pop asm dst))))) (('X8_S12_C12 '<-) From f03960412ebf3ac40686a79b8ed5ebf7c6e49b18 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 21 Oct 2015 15:02:28 +0200 Subject: [PATCH 062/865] Add stack size computation to disassembler * module/system/vm/disassembler.scm (define-stack-effect-parser) (stack-effect-parsers, instruction-stack-size-after): New stack size facility. (define-clobber-parser, clobber-parsers, instruction-slot-clobbers): Take incoming and outgoing stack sizes as arguments to interpret SP-relative clobbers. * module/system/vm/frame.scm (compute-frame-sizes): New helper that computes frame sizes for each position in a function. (compute-killv): Adapt to compute the clobbered set given the computed frame sizes. --- module/system/vm/disassembler.scm | 78 +++++++++++++++++++++++++++---- module/system/vm/frame.scm | 54 +++++++++++++++++++-- 2 files changed, 121 insertions(+), 11 deletions(-) diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index c1a8ce700..b76433ba5 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -39,6 +39,7 @@ instruction-length instruction-has-fallthrough? instruction-relative-jump-targets + instruction-stack-size-after instruction-slot-clobbers)) (define-syntax-rule (u32-ref buf n) @@ -536,15 +537,70 @@ address of that offset." (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff))) ((vector-ref jump-parsers opcode) code pos))) +(define-syntax define-stack-effect-parser + (lambda (x) + (define (stack-effect-parser name) + (case name + ((push) + #'(lambda (code pos size) (+ size 1))) + ((pop) + #'(lambda (code pos size) (- size 1))) + ((drop) + #'(lambda (code pos size) + (let ((count (ash (bytevector-u32-native-ref code pos) -8))) + (- size count)))) + ((alloc-frame reset-frame) + #'(lambda (code pos size) + (let ((nlocals (ash (bytevector-u32-native-ref code pos) -8))) + nlocals))) + ((receive) + #'(lambda (code pos size) + (let ((nlocals (ash (bytevector-u32-native-ref code (+ pos 4)) + -8))) + nlocals))) + ((bind-kwargs) + #'(lambda (code pos size) + (let ((ntotal (ash (bytevector-u32-native-ref code (+ pos 8)) -8))) + ntotal))) + ((bind-rest) + #'(lambda (code pos size) + (let ((dst (ash (bytevector-u32-native-ref code pos) -8))) + (+ dst 1)))) + ((assert-nargs-ee/locals) + #'(lambda (code pos size) + (let ((nargs (logand (ash (bytevector-u32-native-ref code pos) -8) + #xfff)) + (nlocals (ash (bytevector-u32-native-ref code pos) -20))) + (+ nargs nlocals)))) + ((call call-label) + #'(lambda (code pos size) #f)) + ((tail-call tail-call-label tail-call/shuffle tail-apply) + #'(lambda (code pos size) #f)) + (else + #f))) + (syntax-case x () + ((_ name opcode kind word0 word* ...) + (let ((parser (stack-effect-parser (syntax->datum #'name)))) + (if parser + #`(vector-set! stack-effect-parsers opcode #,parser) + #'(begin))))))) + +(define stack-effect-parsers (make-vector 256 (lambda (code pos size) size))) +(visit-opcodes define-stack-effect-parser) + +(define (instruction-stack-size-after code pos size) + (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff))) + ((vector-ref stack-effect-parsers opcode) code pos size))) + (define-syntax define-clobber-parser (lambda (x) (syntax-case x () - ((_ name opcode kind arg ...) + ((_ name opcode kind arg0 arg* ...) (case (syntax->datum #'kind) ((!) (case (syntax->datum #'name) ((call call-label) - #'(let ((parse (lambda (code pos nslots) + #'(let ((parse (lambda (code pos nslots-in nslots-out) (call-with-values (lambda () (disassemble-one code (/ pos 4))) @@ -552,26 +608,32 @@ address of that offset." (match elt ((_ proc . _) (let lp ((slot (- proc 2))) - (if (< slot nslots) + (if (< slot nslots-in) (cons slot (lp (1+ slot))) '()))))))))) (vector-set! clobber-parsers opcode parse))) (else #'(begin)))) ((<-) - #'(let ((parse (lambda (code pos nslots) + #`(let ((parse (lambda (code pos nslots-in nslots-out) (call-with-values (lambda () (disassemble-one code (/ pos 4))) (lambda (len elt) (match elt - ((_ dst . _) (list dst)))))))) + ((_ dst . _) + #,(case (syntax->datum #'arg0) + ((X8_F24 X8_F12_F12) + #'(list dst)) + (else + #'(list (- nslots-out 1 dst))))))))))) (vector-set! clobber-parsers opcode parse))) (else (error "unexpected instruction kind" #'kind))))))) -(define clobber-parsers (make-vector 256 (lambda (code pos nslots) '()))) +(define clobber-parsers + (make-vector 256 (lambda (code pos nslots-in nslots-out) '()))) (visit-opcodes define-clobber-parser) -(define (instruction-slot-clobbers code pos nslots) +(define (instruction-slot-clobbers code pos nslots-in nslots-out) (let ((opcode (logand (bytevector-u32-native-ref code pos) #xff))) - ((vector-ref clobber-parsers opcode) code pos nslots))) + ((vector-ref clobber-parsers opcode) code pos nslots-in nslots-out))) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index b84f6683e..7f0211da8 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -25,6 +25,7 @@ #:use-module (system vm debug) #:use-module (system vm disassembler) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:export (binding-index @@ -83,6 +84,49 @@ (lp (1+ n) (+ pos (vector-ref parsed n))))) preds)) +(define (compute-frame-sizes code parsed initial-size) + (let ((in-sizes (make-vector (vector-length parsed) #f)) + (out-sizes (make-vector (vector-length parsed) #f))) + ;; This only computes all possible valid stack sizes if the bytecode + ;; is sorted topologically. Guiles' compiler does this currently, + ;; but if that changes we should do a proper pre-order visit. Of + ;; course the bytecode has to be valid too. + (define (find-idx n diff) + (let lp ((n n) (diff diff)) + (cond + ((negative? diff) + (lp (1- n) (+ diff (vector-ref parsed (1- n))))) + ((positive? diff) + (lp (1+ n) (- diff (vector-ref parsed n)))) + (else n)))) + (vector-set! in-sizes 0 initial-size) + (let lp ((n 0) (pos 0)) + (define (offset->idx target) + (call-with-values (lambda () + (if (>= target pos) + (values n pos) + (values 0 0))) + (lambda (n pos) + (let lp ((n n) (pos pos)) + (cond + ((= pos target) n) + ((< pos target) (lp (1+ n) (+ pos (vector-ref parsed n)))) + (else (error "bad target" target))))))) + (when (< n (vector-length parsed)) + (let* ((in (vector-ref in-sizes n)) + (out (instruction-stack-size-after code pos in))) + (vector-set! out-sizes n out) + (when out + (when (instruction-has-fallthrough? code pos) + (vector-set! in-sizes (1+ n) out)) + (for-each (lambda (target) + (let ((idx (find-idx n target))) + (when idx + (vector-set! in-sizes idx out)))) + (instruction-relative-jump-targets code pos)))) + (lp (1+ n) (+ pos (vector-ref parsed n))))) + (values in-sizes out-sizes))) + (define (compute-genv parsed defs) (let ((genv (make-vector (vector-length parsed) '()))) (define (add-def! pos var) @@ -118,8 +162,11 @@ by-slot)) (define (compute-killv code parsed defs) - (let ((defs-by-slot (compute-defs-by-slot defs)) - (killv (make-vector (vector-length parsed) #f))) + (let*-values (((defs-by-slot) (compute-defs-by-slot defs)) + ((initial-frame-size) (vector-length defs-by-slot)) + ((in-sizes out-sizes) + (compute-frame-sizes code parsed initial-frame-size)) + ((killv) (make-vector (vector-length parsed) #f))) (define (kill-slot! n slot) (bit-set*! (vector-ref killv n) (vector-ref defs-by-slot slot) #t)) (let lp ((n 0)) @@ -147,7 +194,8 @@ (when (< slot (vector-length defs-by-slot)) (kill-slot! n slot))) (instruction-slot-clobbers code pos - (vector-length defs-by-slot))) + (vector-ref in-sizes n) + (vector-ref out-sizes n))) (lp (1+ n) (+ pos (vector-ref parsed n))))) killv)) From 467e587d68fac4a4c269e892740cd5077f5da815 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 22 Oct 2015 11:02:18 +0000 Subject: [PATCH 063/865] Update VM documentation for new stack layout * doc/ref/vm.texi: Update for new stack layout. * module/system/vm/disassembler.scm (code-annotation): Print the frame sizes after alloc-frame, reset-frame, etc to make reading the disassembly easier. --- doc/ref/vm.texi | 437 +++++++++++++++++------------- module/system/vm/disassembler.scm | 8 +- 2 files changed, 256 insertions(+), 189 deletions(-) diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index ba31d7ccb..45c3928a0 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -144,19 +144,23 @@ course is the tail call case, @pxref{Tail Calls}.) The structure of the top stack frame is as follows: @example - /------------------\ <- top of stack - | Local N-1 | <- sp | ... | - | Local 1 | - | Local 0 | <- fp = SCM_FRAME_LOCALS_ADDRESS (fp) - +==================+ + +==================+ <- fp + 2 = SCM_FRAME_PREVIOUS_SP (fp) + | Dynamic link | + +------------------+ | Return address | - | Dynamic link | <- fp - 2 = SCM_FRAME_LOWER_ADDRESS (fp) - +==================+ - | | <- fp - 3 = SCM_FRAME_PREVIOUS_SP (fp) + +==================+ <- fp + | Local 0 | + +------------------+ + | Local 1 | + +------------------+ + | ... | + +------------------+ + | Local N-1 | + \------------------/ <- sp @end example -In the above drawing, the stack grows upward. Usually the procedure +In the above drawing, the stack grows downward. Usually the procedure being applied is in local 0, followed by the arguments from local 1. After that are enough slots to store the various lexically-bound and temporary values that are needed in the function's application. @@ -164,7 +168,8 @@ temporary values that are needed in the function's application. The @dfn{return address} is the @code{ip} that was in effect before this program was applied. When we return from this activation frame, we will jump back to this @code{ip}. Likewise, the @dfn{dynamic link} is the -@code{fp} in effect before this program was applied. +offset of the @code{fp} that was in effect before this program was +applied, relative to the current @code{fp}. To prepare for a non-tail application, Guile's VM will emit code that shuffles the function to apply and its arguments into appropriate stack @@ -176,6 +181,12 @@ new call frame. In this way, the dynamic link links the current frame to the previous frame. Computing a stack trace involves traversing these frames. +As an implementation detail, we actually store the dynamic link as an +offset and not an absolute value because the stack can move at runtime +as it expands or during partial continuation calls. If it were an +absolute value, we would have to walk the frames, relocating frame +pointers. + @node Variables and the VM @subsection Variables and the VM @@ -263,54 +274,71 @@ We can see how these concepts tie together by disassembling the @smallexample scheme@@(guile-user)> (define (foo a) (lambda (b) (list foo a b))) scheme@@(guile-user)> ,x foo -Disassembly of # at #x203be34: +Disassembly of # at #xddb824: - 0 (assert-nargs-ee/locals 2 1) ;; 1 arg, 1 local at (unknown file):1:0 - 1 (make-closure 2 6 1) ;; anonymous procedure at #x203be50 (1 free var) - 4 (free-set! 2 1 0) ;; free var 0 - 6 (return 2) + 0 (assert-nargs-ee/locals 2 0) ;; 2 slots (1 arg) at (unknown file):1:0 + 1 (make-closure 1 6 1) ;; anonymous procedure at #xddb840 (1 free var) + 4 (free-set! 1 0 0) ;; free var 0 + 6 (return 1) ---------------------------------------- -Disassembly of anonymous procedure at #x203be50: +Disassembly of anonymous procedure at #xddb840: - 0 (assert-nargs-ee/locals 2 3) ;; 1 arg, 3 locals at (unknown file):1:0 - 1 (toplevel-box 2 73 57 71 #t) ;; `foo' - 6 (box-ref 2 2) - 7 (make-short-immediate 3 772) ;; () - 8 (cons 3 1 3) - 9 (free-ref 4 0 0) ;; free var 0 - 11 (cons 3 4 3) - 12 (cons 2 2 3) - 13 (return 2) + 0 (assert-nargs-ee/locals 2 2) ;; 4 slots (1 arg) at (unknown file):1:16 + 1 (toplevel-box 1 73 57 67 #t) ;; `foo' + 6 (box-ref 1 1) + 7 (make-short-immediate 0 772) ;; () at (unknown file):1:28 + 8 (cons 2 2 0) + 9 (free-ref 3 3 0) ;; free var 0 + 11 (cons 3 3 2) + 12 (cons 3 1 3) + 13 (return 3) @end smallexample First there's some prelude, where @code{foo} checks that it was called with only 1 argument. Then at @code{ip} 1, we allocate a new closure -and store it in slot 2. The `6' in the @code{(make-closure 2 6 1)} is a -relative offset from the instruction pointer of the code for the -closure. +and store it in slot 1, relative to the @code{sp}. -A closure is code with data. We already have the code part initialized; -what remains is to set the data. @code{Ip} 4 initializes free variable -0 in the new closure with the value from local variable 1, which -corresponds to the first argument of @code{foo}: `a'. Finally we return -the closure. +At run-time, local variables in Guile are usually addressed relative to +the stack pointer, which leads to a pleasantly efficient +@code{sp[@var{n}]} access. However it can make the disassembly hard to +read, because the @code{sp} can change during the function, and because +incoming arguments are relative to the @code{fp}, not the @code{sp}. + +To know what @code{fp}-relative slot corresponds to an +@code{sp}-relative reference, scan up in the disassembly until you get +to a ``@var{n} slots'' annotation; in our case, 2, indicating that the +frame has space for 2 slots. Thus a zero-indexed @code{sp}-relative +slot of 1 corresponds to the @code{fp}-relative slot of 0, which +initially held the value of the closure being called. This means that +Guile doesn't need the value of the closure to compute its result, and +so slot 0 was free for re-use, in this case for the result of making a +new closure. + +A closure is code with data. The @code{6} in the @code{(make-closure 1 +6 1)} is a relative offset from the instruction pointer of the code for +the closure, and the final @code{1} indicates that the closure has space +for 1 free variable. @code{Ip} 4 initializes free variable 0 in the new +closure with the value from @code{sp}-relative slot 0, which corresponds +to @code{fp}-relative slot 1, the first argument of @code{foo}: +@code{a}. Finally we return the closure. The second stanza disassembles the code for the closure. After the prelude, we load the variable for the toplevel variable @code{foo} into -local variable 2. This lookup occurs lazily, the first time the -variable is actually referenced, and the location of the lookup is -cached so that future references are very cheap. @xref{Top-Level -Environment Instructions}, for more details. The @code{box-ref} -dereferences the variable cell, replacing the contents of local 2. +slot 1. This lookup occurs lazily, the first time the variable is +actually referenced, and the location of the lookup is cached so that +future references are very cheap. @xref{Top-Level Environment +Instructions}, for more details. The @code{box-ref} dereferences the +variable cell, replacing the contents of slot 1. What follows is a sequence of conses to build up the result list. @code{Ip} 7 makes the tail of the list. @code{Ip} 8 conses on the value -in local 1, corresponding to the first argument to the closure: `b'. -@code{Ip} 9 loads free variable 0 of local 0 -- the procedure being -called -- into slot 4, then @code{ip} 11 conses it onto the list. -Finally we cons local 2, containing the @code{foo} toplevel, onto the -front of the list, and we return it. +in slot 2, corresponding to the first argument to the closure: @code{b}. +@code{Ip} 9 loads free variable 0 of slot 3 -- the procedure being +called, in @code{fp}-relative slot 0 -- into slot 3, then @code{ip} 11 +conses it onto the list. Finally we cons the value in slot 1, +containing the @code{foo} toplevel, onto the front of the list, and we +return it. @node Object File Format @@ -431,10 +459,16 @@ instruction describe the operands. There are a number of different ways operands can be encoded. @table @code -@item u@var{n} -An unsigned @var{n}-bit integer. Usually indicates the index of a local -variable, but some instructions interpret these operands as immediate -values. +@item s@var{n} +An unsigned @var{n}-bit integer, indicating the @code{sp}-relative index +of a local variable. +@item f@var{n} +An unsigned @var{n}-bit integer, indicating the @code{fp}-relative index +of a local variable. Used when a continuation accepts a variable number +of values, to shuffle received values into known locations in the +frame. +@item c@var{n} +An unsigned @var{n}-bit integer, indicating a constant value. @item l24 An offset from the current @code{ip}, in 32-bit units, as a signed 24-bit value. Indicates a bytecode address, for a relative jump. @@ -452,7 +486,7 @@ and indicate the high and low bits, respectively. Normally only used on A statically allocated non-immediate. The address of the non-immediate is encoded as a signed 32-bit integer, and indicates a relative offset in 32-bit units. Think of it as @code{SCM x = ip + offset}. -@item s32 +@item r32 Indirect scheme value, like @code{n32} but indirected. Think of it as @code{SCM *x = ip + offset}. @item l32 @@ -478,7 +512,7 @@ operands occupying the lower bits. For example, consider the following instruction specification: -@deftypefn Instruction {} free-set! u12:@var{dst} u12:@var{src} x8:@var{_} u24:@var{idx} +@deftypefn Instruction {} free-set! s12:@var{dst} s12:@var{src} x8:@var{_} c24:@var{idx} Set free variable @var{idx} from the closure @var{dst} to @var{src}. @end deftypefn @@ -504,11 +538,6 @@ In addition, some Scheme primitives have their own inline implementations. For example, in the previous section we saw @code{cons}. -Guile's instruction set is a @emph{complete} instruction set, in that it -provides the instructions that are suited to the problem, and is not -concerned with making a minimal, orthogonal set of instructions. More -instructions may be added over time. - @menu * Lexical Environment Instructions:: * Top-Level Environment Instructions:: @@ -532,8 +561,8 @@ These instructions access and mutate the lexical environment of a compiled procedure---its free and bound variables. @xref{Stack Layout}, for more information on the format of stack frames. -@deftypefn Instruction {} mov u12:@var{dst} u12:@var{src} -@deftypefnx Instruction {} long-mov u24:@var{dst} x8:@var{_} u24:@var{src} +@deftypefn Instruction {} mov s12:@var{dst} s12:@var{src} +@deftypefnx Instruction {} long-mov s24:@var{dst} x8:@var{_} s24:@var{src} Copy a value from one local slot to another. As discussed previously, procedure arguments and local variables are @@ -543,7 +572,13 @@ instructions redundant. However there are some cases in which shuffling is necessary, and in those cases, @code{mov} is the thing to use. @end deftypefn -@deftypefn Instruction {} make-closure u24:@var{dst} l32:@var{offset} x8:@var{_} u24:@var{nfree} +@deftypefn Instruction {} long-fmov f24:@var{dst} x8:@var{_} f24:@var{src} +Copy a value from one local slot to another, but addressing slots +relative to the @code{fp} instead of the @code{sp}. This is used when +shuffling values into place after multiple-value returns. +@end deftypefn + +@deftypefn Instruction {} make-closure s24:@var{dst} l32:@var{offset} x8:@var{_} c24:@var{nfree} Make a new closure, and write it to @var{dst}. The code for the closure will be found at @var{offset} words from the current @code{ip}. @var{offset} is a signed 32-bit integer. Space for @var{nfree} free @@ -553,12 +588,12 @@ The size of a closure is currently two words, plus one word per free variable. @end deftypefn -@deftypefn Instruction {} free-ref u12:@var{dst} u12:@var{src} x8:@var{_} u24:@var{idx} +@deftypefn Instruction {} free-ref s12:@var{dst} s12:@var{src} x8:@var{_} c24:@var{idx} Load free variable @var{idx} from the closure @var{src} into local slot @var{dst}. @end deftypefn -@deftypefn Instruction {} free-set! u12:@var{dst} u12:@var{src} x8:@var{_} u24:@var{idx} +@deftypefn Instruction {} free-set! s12:@var{dst} s12:@var{src} x8:@var{_} c24:@var{idx} Set free variable @var{idx} from the closure @var{dst} to @var{src}. This instruction is usually used when initializing a closure's free @@ -572,16 +607,16 @@ their value at one point in time. Variables are also used in the implementation of top-level bindings; see the next section for more information. -@deftypefn Instruction {} box u12:@var{dst} u12:@var{src} +@deftypefn Instruction {} box s12:@var{dst} s12:@var{src} Create a new variable holding @var{src}, and place it in @var{dst}. @end deftypefn -@deftypefn Instruction {} box-ref u12:@var{dst} u12:@var{src} +@deftypefn Instruction {} box-ref s12:@var{dst} s12:@var{src} Unpack the variable at @var{src} into @var{dst}, asserting that the variable is actually bound. @end deftypefn -@deftypefn Instruction {} box-set! u12:@var{dst} u12:@var{src} +@deftypefn Instruction {} box-set! s12:@var{dst} s12:@var{src} Set the contents of the variable at @var{dst} to @var{set}. @end deftypefn @@ -597,23 +632,23 @@ The location in which a toplevel binding is stored can be looked up once and cached for later. The binding itself may change over time, but its location will stay constant. -@deftypefn Instruction {} current-module u24:@var{dst} +@deftypefn Instruction {} current-module s24:@var{dst} Store the current module in @var{dst}. @end deftypefn -@deftypefn Instruction {} resolve u24:@var{dst} b1:@var{bound?} x7:@var{_} u24:@var{sym} +@deftypefn Instruction {} resolve s24:@var{dst} b1:@var{bound?} x7:@var{_} s24:@var{sym} Resolve @var{sym} in the current module, and place the resulting variable in @var{dst}. An error will be signalled if no variable is found. If @var{bound?} is true, an error will be signalled if the variable is unbound. @end deftypefn -@deftypefn Instruction {} define! u12:@var{sym} u12:@var{val} +@deftypefn Instruction {} define! s12:@var{sym} s12:@var{val} Look up a binding for @var{sym} in the current module, creating it if necessary. Set its value to @var{val}. @end deftypefn -@deftypefn Instruction {} toplevel-box u24:@var{dst} s32:@var{var-offset} s32:@var{mod-offset} n32:@var{sym-offset} b1:@var{bound?} x31:@var{_} +@deftypefn Instruction {} toplevel-box s24:@var{dst} r32:@var{var-offset} r32:@var{mod-offset} n32:@var{sym-offset} b1:@var{bound?} x31:@var{_} Load a value. The value will be fetched from memory, @var{var-offset} 32-bit words away from the current instruction pointer. @var{var-offset} is a signed value. Up to here, @code{toplevel-box} is @@ -633,7 +668,7 @@ cache next time. If @var{bound?} is true, an error will be signalled if the variable is unbound. @end deftypefn -@deftypefn Instruction {} module-box u24:@var{dst} s32:@var{var-offset} n32:@var{mod-offset} n32:@var{sym-offset} b1:@var{bound?} x31:@var{_} +@deftypefn Instruction {} module-box s24:@var{dst} r32:@var{var-offset} n32:@var{mod-offset} n32:@var{sym-offset} b1:@var{bound?} x31:@var{_} Like @code{toplevel-box}, except @var{mod-offset} points at a module identifier instead of the module itself. A module identifier is a module name, as a list, prefixed by a boolean. If the prefix is true, @@ -651,23 +686,25 @@ is that arguments are passed and values returned on the stack. For calls, both in tail position and in non-tail position, we require that the procedure and the arguments already be shuffled into place befor the call instruction. ``Into place'' for a tail call means that -the procedure should be in slot 0, and the arguments should follow. For -a non-tail call, if the procedure is in slot @var{n}, the arguments -should follow from slot @var{n}+1, and there should be two free slots at -@var{n}-1 and @var{n}-2 in which to save the @code{ip} and @code{fp}. +the procedure should be in slot 0, relative to the @code{fp}, and the +arguments should follow. For a non-tail call, if the procedure is in +@code{fp}-relative slot @var{n}, the arguments should follow from slot +@var{n}+1, and there should be two free slots at @var{n}-1 and @var{n}-2 +in which to save the @code{ip} and @code{fp}. Returning values is similar. Multiple-value returns should have values -already shuffled down to start from slot 1 before emitting -@code{return-values}. There is a short-cut in the single-value case, in -that @code{return} handles the trivial shuffling itself. We start from -slot 1 instead of slot 0 to make tail calls to @code{values} trivial. +already shuffled down to start from @code{fp}-relative slot 1 before +emitting @code{return-values}. There is a short-cut in the single-value +case, in that @code{return} handles the trivial shuffling itself. We +start from slot 1 instead of slot 0 to make tail calls to @code{values} +trivial. In both calls and returns, the @code{sp} is used to indicate to the callee or caller the number of arguments or return values, respectively. After receiving return values, it is the caller's responsibility to @dfn{restore the frame} by resetting the @code{sp} to its former value. -@deftypefn Instruction {} call u24:@var{proc} x8:@var{_} u24:@var{nlocals} +@deftypefn Instruction {} call f24:@var{proc} x8:@var{_} c24:@var{nlocals} Call a procedure. @var{proc} is the local corresponding to a procedure. The two values below @var{proc} will be overwritten by the saved call frame data. The new frame will have space for @var{nlocals} locals: one @@ -680,7 +717,7 @@ number can be had by subtracting the address of @var{proc} from the post-call @code{sp}. @end deftypefn -@deftypefn Instruction {} call-label u24:@var{proc} x8:@var{_} u24:@var{nlocals} l32:@var{label} +@deftypefn Instruction {} call-label f24:@var{proc} x8:@var{_} c24:@var{nlocals} l32:@var{label} Call a procedure in the same compilation unit. This instruction is just like @code{call}, except that instead of @@ -690,31 +727,31 @@ the current @code{ip}. Since @var{proc} is not dereferenced, it may be some other representation of the closure. @end deftypefn -@deftypefn Instruction {} tail-call u24:@var{nlocals} +@deftypefn Instruction {} tail-call c24:@var{nlocals} Tail-call a procedure. Requires that the procedure and all of the arguments have already been shuffled into position. Will reset the frame to @var{nlocals}. @end deftypefn -@deftypefn Instruction {} tail-call-label u24:@var{nlocals} l32:@var{label} +@deftypefn Instruction {} tail-call-label c24:@var{nlocals} l32:@var{label} Tail-call a known procedure. As @code{call} is to @code{call-label}, @code{tail-call} is to @code{tail-call-label}. @end deftypefn -@deftypefn Instruction {} tail-call/shuffle u24:@var{from} +@deftypefn Instruction {} tail-call/shuffle f24:@var{from} Tail-call a procedure. The procedure should already be set to slot 0. The rest of the args are taken from the frame, starting at @var{from}, shuffled down to start at slot 0. This is part of the implementation of the @code{call-with-values} builtin. @end deftypefn -@deftypefn Instruction {} receive u12:@var{dst} u12:@var{proc} x8:@var{_} u24:@var{nlocals} +@deftypefn Instruction {} receive f12:@var{dst} f12:@var{proc} x8:@var{_} c24:@var{nlocals} Receive a single return value from a call whose procedure was in @var{proc}, asserting that the call actually returned at least one value. Afterwards, resets the frame to @var{nlocals} locals. @end deftypefn -@deftypefn Instruction {} receive-values u24:@var{proc} b1:@var{allow-extra?} x7:@var{_} u24:@var{nvalues} +@deftypefn Instruction {} receive-values f24:@var{proc} b1:@var{allow-extra?} x7:@var{_} c24:@var{nvalues} Receive a return of multiple values from a call whose procedure was in @var{proc}. If fewer than @var{nvalues} values were returned, signal an error. Unless @var{allow-extra?} is true, require that the number of @@ -722,7 +759,7 @@ return values equals @var{nvalues} exactly. After @code{receive-values} has run, the values can be copied down via @code{mov}, or used in place. @end deftypefn -@deftypefn Instruction {} return u24:@var{src} +@deftypefn Instruction {} return s24:@var{src} Return a value. @end deftypefn @@ -755,21 +792,21 @@ cost of parsing keyword arguments. (At the time of this writing, calling procedures with keyword arguments is typically two to four times as costly as calling procedures with a fixed set of arguments.) -@deftypefn Instruction {} assert-nargs-ee u24:@var{expected} -@deftypefnx Instruction {} assert-nargs-ge u24:@var{expected} -@deftypefnx Instruction {} assert-nargs-le u24:@var{expected} +@deftypefn Instruction {} assert-nargs-ee c24:@var{expected} +@deftypefnx Instruction {} assert-nargs-ge c24:@var{expected} +@deftypefnx Instruction {} assert-nargs-le c24:@var{expected} If the number of actual arguments is not @code{==}, @code{>=}, or @code{<=} @var{expected}, respectively, signal an error. -The number of arguments is determined by subtracting the frame pointer -from the stack pointer (@code{sp + 1 - fp}). @xref{Stack Layout}, for -more details on stack frames. Note that @var{expected} includes the +The number of arguments is determined by subtracting the stack pointer +from the frame pointer (@code{fp - sp}). @xref{Stack Layout}, for more +details on stack frames. Note that @var{expected} includes the procedure itself. @end deftypefn -@deftypefn Instruction {} br-if-nargs-ne u24:@var{expected} x8:@var{_} l24:@var{offset} -@deftypefnx Instruction {} br-if-nargs-lt u24:@var{expected} x8:@var{_} l24:@var{offset} -@deftypefnx Instruction {} br-if-nargs-gt u24:@var{expected} x8:@var{_} l24:@var{offset} +@deftypefn Instruction {} br-if-nargs-ne c24:@var{expected} x8:@var{_} l24:@var{offset} +@deftypefnx Instruction {} br-if-nargs-lt c24:@var{expected} x8:@var{_} l24:@var{offset} +@deftypefnx Instruction {} br-if-nargs-gt c24:@var{expected} x8:@var{_} l24:@var{offset} If the number of actual arguments is not equal, less than, or greater than @var{expected}, respectively, add @var{offset}, a signed 24-bit number, to the current instruction pointer. Note that @var{expected} @@ -779,26 +816,26 @@ These instructions are used to implement multiple arities, as in @code{case-lambda}. @xref{Case-lambda}, for more information. @end deftypefn -@deftypefn Instruction {} alloc-frame u24:@var{nlocals} +@deftypefn Instruction {} alloc-frame c24:@var{nlocals} Ensure that there is space on the stack for @var{nlocals} local variables, setting them all to @code{SCM_UNDEFINED}, except those values that are already on the stack. @end deftypefn -@deftypefn Instruction {} reset-frame u24:@var{nlocals} +@deftypefn Instruction {} reset-frame c24:@var{nlocals} Like @code{alloc-frame}, but doesn't check that the stack is big enough, and doesn't initialize values to @code{SCM_UNDEFINED}. Used to reset the frame size to something less than the size that was previously set via alloc-frame. @end deftypefn -@deftypefn Instruction {} assert-nargs-ee/locals u12:@var{expected} u12:@var{nlocals} +@deftypefn Instruction {} assert-nargs-ee/locals c12:@var{expected} c12:@var{nlocals} Equivalent to a sequence of @code{assert-nargs-ee} and @code{reserve-locals}. The number of locals reserved is @var{expected} + @var{nlocals}. @end deftypefn -@deftypefn Instruction {} br-if-npos-gt u24:@var{nreq} x8:@var{_} u24:@var{npos} x8:@var{_} l24:@var{offset} +@deftypefn Instruction {} br-if-npos-gt c24:@var{nreq} x8:@var{_} c24:@var{npos} x8:@var{_} l24:@var{offset} Find the first positional argument after @var{nreq}. If it is greater than @var{npos}, jump to @var{offset}. @@ -808,7 +845,7 @@ and an earlier clause has keywords and no rest arguments. clause to apply. @end deftypefn -@deftypefn Instruction {} bind-kwargs u24:@var{nreq} u8:@var{flags} u24:@var{nreq-and-opt} x8:@var{_} u24:@var{ntotal} n32:@var{kw-offset} +@deftypefn Instruction {} bind-kwargs c24:@var{nreq} c8:@var{flags} c24:@var{nreq-and-opt} x8:@var{_} c24:@var{ntotal} n32:@var{kw-offset} @var{flags} is a bitfield, whose lowest bit is @var{allow-other-keys}, second bit is @var{has-rest}, and whose following six bits are unused. @@ -829,7 +866,7 @@ will signal an error if an unknown key is found. A macro-mega-instruction. @end deftypefn -@deftypefn Instruction {} bind-rest u24:@var{dst} +@deftypefn Instruction {} bind-rest f24:@var{dst} Collect any arguments at or above @var{dst} into a list, and store that list at @var{dst}. @end deftypefn @@ -851,25 +888,25 @@ compiler probably shouldn't emit code with these instructions. However, it's still interesting to know how these things work, so we document these trampoline instructions here. -@deftypefn Instruction {} subr-call u24:@var{ptr-idx} +@deftypefn Instruction {} subr-call c24:@var{ptr-idx} Call a subr, passing all locals in this frame as arguments. Fetch the foreign pointer from @var{ptr-idx}, a free variable. Return from the calling frame. @end deftypefn -@deftypefn Instruction {} foreign-call u12:@var{cif-idx} u12:@var{ptr-idx} +@deftypefn Instruction {} foreign-call c12:@var{cif-idx} c12:@var{ptr-idx} Call a foreign function. Fetch the @var{cif} and foreign pointer from @var{cif-idx} and @var{ptr-idx}, both free variables. Return from the calling frame. Arguments are taken from the stack. @end deftypefn -@deftypefn Instruction {} continuation-call u24:@var{contregs} +@deftypefn Instruction {} continuation-call c24:@var{contregs} Return to a continuation, nonlocally. The arguments to the continuation are taken from the stack. @var{contregs} is a free variable containing the reified continuation. @end deftypefn -@deftypefn Instruction {} compose-continuation u24:@var{cont} +@deftypefn Instruction {} compose-continuation c24:@var{cont} Compose a partial continution with the current continuation. The arguments to the continuation are taken from the stack. @var{cont} is a free variable containing the reified continuation. @@ -881,7 +918,7 @@ This instruction is part of the implementation of @code{apply}, and is not generated by the compiler. @end deftypefn -@deftypefn Instruction {} builtin-ref u12:@var{dst} u12:@var{idx} +@deftypefn Instruction {} builtin-ref s12:@var{dst} c12:@var{idx} Load a builtin stub by index into @var{dst}. @end deftypefn @@ -901,60 +938,60 @@ All the conditional branch instructions described below have an @var{invert} parameter, which if true reverses the test: @code{br-if-true} becomes @code{br-if-false}, and so on. -@deftypefn Instruction {} br-if-true u24:@var{test} b1:@var{invert} x7:@var{_} l24:@var{offset} +@deftypefn Instruction {} br-if-true s24:@var{test} b1:@var{invert} x7:@var{_} l24:@var{offset} If the value in @var{test} is true for the purposes of Scheme, add @var{offset} to the current instruction pointer. @end deftypefn -@deftypefn Instruction {} br-if-null u24:@var{test} b1:@var{invert} x7:@var{_} l24:@var{offset} +@deftypefn Instruction {} br-if-null s24:@var{test} b1:@var{invert} x7:@var{_} l24:@var{offset} If the value in @var{test} is the end-of-list or Lisp nil, add @var{offset} to the current instruction pointer. @end deftypefn -@deftypefn Instruction {} br-if-nil u24:@var{test} b1:@var{invert} x7:@var{_} l24:@var{offset} +@deftypefn Instruction {} br-if-nil s24:@var{test} b1:@var{invert} x7:@var{_} l24:@var{offset} If the value in @var{test} is false to Lisp, add @var{offset} to the current instruction pointer. @end deftypefn -@deftypefn Instruction {} br-if-pair u24:@var{test} b1:@var{invert} x7:@var{_} l24:@var{offset} +@deftypefn Instruction {} br-if-pair s24:@var{test} b1:@var{invert} x7:@var{_} l24:@var{offset} If the value in @var{test} is a pair, add @var{offset} to the current instruction pointer. @end deftypefn -@deftypefn Instruction {} br-if-struct u24:@var{test} b1:@var{invert} x7:@var{_} l24:@var{offset} +@deftypefn Instruction {} br-if-struct s24:@var{test} b1:@var{invert} x7:@var{_} l24:@var{offset} If the value in @var{test} is a struct, add @var{offset} number to the current instruction pointer. @end deftypefn -@deftypefn Instruction {} br-if-char u24:@var{test} b1:@var{invert} x7:@var{_} l24:@var{offset} +@deftypefn Instruction {} br-if-char s24:@var{test} b1:@var{invert} x7:@var{_} l24:@var{offset} If the value in @var{test} is a char, add @var{offset} to the current instruction pointer. @end deftypefn -@deftypefn Instruction {} br-if-tc7 u24:@var{test} b1:@var{invert} u7:@var{tc7} l24:@var{offset} +@deftypefn Instruction {} br-if-tc7 s24:@var{test} b1:@var{invert} u7:@var{tc7} l24:@var{offset} If the value in @var{test} has the TC7 given in the second word, add @var{offset} to the current instruction pointer. TC7 codes are part of the way Guile represents non-immediate objects, and are deep wizardry. See @code{libguile/tags.h} for all the details. @end deftypefn -@deftypefn Instruction {} br-if-eq u12:@var{a} u12:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} -@deftypefnx Instruction {} br-if-eqv u12:@var{a} u12:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} -@deftypefnx Instruction {} br-if-equal u12:@var{a} u12:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} +@deftypefn Instruction {} br-if-eq s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} +@deftypefnx Instruction {} br-if-eqv s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} +@deftypefnx Instruction {} br-if-equal s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} If the value in @var{a} is @code{eq?}, @code{eqv?}, or @code{equal?} to the value in @var{b}, respectively, add @var{offset} to the current instruction pointer. @end deftypefn -@deftypefn Instruction {} br-if-= u12:@var{a} u12:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} -@deftypefnx Instruction {} br-if-< u12:@var{a} u12:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} -@deftypefnx Instruction {} br-if-<= u12:@var{a} u12:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} +@deftypefn Instruction {} br-if-= s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} +@deftypefnx Instruction {} br-if-< s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} +@deftypefnx Instruction {} br-if-<= s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} If the value in @var{a} is @code{=}, @code{<}, or @code{<=} to the value in @var{b}, respectively, add @var{offset} to the current instruction pointer. @end deftypefn -@deftypefn Instruction {} br-if-logtest u12:@var{a} u12:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} +@deftypefn Instruction {} br-if-logtest s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} If the bitwise intersection of the integers in @var{a} and @var{b} is nonzero, add @var{offset} to the current instruction pointer. @end deftypefn @@ -969,17 +1006,17 @@ two kinds. The first set of instructions loads immediate values. These instructions encode the immediate directly into the instruction stream. -@deftypefn Instruction {} make-short-immediate u8:@var{dst} i16:@var{low-bits} +@deftypefn Instruction {} make-short-immediate s8:@var{dst} i16:@var{low-bits} Make an immediate whose low bits are @var{low-bits}, and whose top bits are 0. @end deftypefn -@deftypefn Instruction {} make-long-immediate u24:@var{dst} i32:@var{low-bits} +@deftypefn Instruction {} make-long-immediate s24:@var{dst} i32:@var{low-bits} Make an immediate whose low bits are @var{low-bits}, and whose top bits are 0. @end deftypefn -@deftypefn Instruction {} make-long-long-immediate u24:@var{dst} a32:@var{high-bits} b32:@var{low-bits} +@deftypefn Instruction {} make-long-long-immediate s24:@var{dst} a32:@var{high-bits} b32:@var{low-bits} Make an immediate with @var{high-bits} and @var{low-bits}. @end deftypefn @@ -990,7 +1027,7 @@ compiled image. A reference to a string will use @code{make-non-immediate} to treat a pointer into the compilation unit as a @code{SCM} value directly. -@deftypefn Instruction {} make-non-immediate u24:@var{dst} n32:@var{offset} +@deftypefn Instruction {} make-non-immediate s24:@var{dst} n32:@var{offset} Load a pointer to statically allocated memory into @var{dst}. The object's memory is will be found @var{offset} 32-bit words away from the current instruction pointer. Whether the object is mutable or immutable @@ -1004,7 +1041,7 @@ initialize them when the compilation unit is loaded, storing them into a slot in the image. References go indirectly through that slot. @code{static-ref} is used in this case. -@deftypefn Instruction {} static-ref u24:@var{dst} s32:@var{offset} +@deftypefn Instruction {} static-ref s24:@var{dst} r32:@var{offset} Load a @var{scm} value into @var{dst}. The @var{scm} value will be fetched from memory, @var{offset} 32-bit words away from the current instruction pointer. @var{offset} is a signed value. @@ -1016,7 +1053,7 @@ the case, for example, for a pair containing a non-immediate in one of its fields. @code{static-ref} and @code{static-patch!} are used in these situations. -@deftypefn Instruction {} static-set! u24:@var{src} lo32:@var{offset} +@deftypefn Instruction {} static-set! s24:@var{src} lo32:@var{offset} Store a @var{scm} value into memory, @var{offset} 32-bit words away from the current instruction pointer. @var{offset} is a signed value. @end deftypefn @@ -1033,19 +1070,19 @@ case for vectors, strings, uniform vectors, pairs, and procedures with no free variables. Other kinds of data might need special initializers; those instructions follow. -@deftypefn Instruction {} string->number u12:@var{dst} u12:@var{src} +@deftypefn Instruction {} string->number s12:@var{dst} s12:@var{src} Parse a string in @var{src} to a number, and store in @var{dst}. @end deftypefn -@deftypefn Instruction {} string->symbol u12:@var{dst} u12:@var{src} +@deftypefn Instruction {} string->symbol s12:@var{dst} s12:@var{src} Parse a string in @var{src} to a symbol, and store in @var{dst}. @end deftypefn -@deftypefn Instruction {} symbol->keyword u12:@var{dst} u12:@var{src} +@deftypefn Instruction {} symbol->keyword s12:@var{dst} s12:@var{src} Make a keyword from the symbol in @var{src}, and store it in @var{dst}. @end deftypefn -@deftypefn Instruction {} load-typed-array u8:@var{dst} u8:@var{type} u8:@var{shape} n32:@var{offset} u32:@var{len} +@deftypefn Instruction {} load-typed-array s24:@var{dst} x8:@var{_} s24:@var{type} x8:@var{_} s24:@var{shape} n32:@var{offset} u32:@var{len} Load the contiguous typed array located at @var{offset} 32-bit words away from the instruction pointer, and store into @var{dst}. @var{len} is a byte length. @var{offset} is signed. @@ -1077,7 +1114,7 @@ function, a call to @code{abort-to-prompt} looks like any other function call. @end deftypefn -@deftypefn Instruction {} prompt u24:@var{tag} b1:@var{escape-only?} x7:@var{_} u24:@var{proc-slot} x8:@var{_} l24:@var{handler-offset} +@deftypefn Instruction {} prompt s24:@var{tag} b1:@var{escape-only?} x7:@var{_} f24:@var{proc-slot} x8:@var{_} l24:@var{handler-offset} Push a new prompt on the dynamic stack, with a tag from @var{tag} and a handler at @var{handler-offset} words from the current @var{ip}. @@ -1096,7 +1133,7 @@ continuation. @xref{Prompts}, for more information on prompts. @end deftypefn -@deftypefn Instruction {} wind u12:@var{winder} u12:@var{unwinder} +@deftypefn Instruction {} wind s12:@var{winder} s12:@var{unwinder} Push wind and unwind procedures onto the dynamic stack. Note that neither are actually called; the compiler should emit calls to wind and unwind for the normal dynamic-wind control flow. Also note that the @@ -1109,7 +1146,7 @@ thunks, if it could not prove that to be the case. @xref{Dynamic Wind}. entry off of the dynamic stack. @end deftypefn -@deftypefn Instruction {} push-fluid u12:@var{fluid} u12:@var{value} +@deftypefn Instruction {} push-fluid s12:@var{fluid} s12:@var{value} Dynamically bind @var{value} to @var{fluid} by creating a with-fluids object and pushing that object on the dynamic stack. @xref{Fluids and Dynamic States}. @@ -1121,11 +1158,11 @@ the fluid to its previous value. @code{push-fluid} should always be balanced with @code{pop-fluid}. @end deftypefn -@deftypefn Instruction {} fluid-ref u12:@var{dst} u12:@var{src} +@deftypefn Instruction {} fluid-ref s12:@var{dst} s12:@var{src} Reference the fluid in @var{src}, and place the value in @var{dst}. @end deftypefn -@deftypefn Instruction {} fluid-set u12:@var{fluid} u12:@var{val} +@deftypefn Instruction {} fluid-set s12:@var{fluid} s12:@var{val} Set the value of the fluid in @var{dst} to the value in @var{src}. @end deftypefn @@ -1138,6 +1175,30 @@ Bring the VM to a halt, returning all the values from the stack. Used in the ``boot continuation'', which is used when entering the VM from C. @end deftypefn +@deftypefn Instruction {} push s24:@var{src} +Bump the stack pointer by one word, and fill it with the value from slot +@var{src}. The offset to @var{src} is calculated before the stack +pointer is adjusted. +@end deftypefn + +The @code{push} instruction is used when another instruction is unable +to address an operand because the operand is encoded with fewer than 24 +bits. In that case, Guile's assembler will transparently emit code that +temporarily pushes any needed operands onto the stack, emits the +original instruction to address those now-near variables, then shuffles +the result (if any) back into place. + +@deftypefn Instruction {} pop s24:@var{dst} +Pop the stack pointer, storing the value that was there in slot +@var{dst}. The offset to @var{dst} is calculated after the stack +pointer is adjusted. +@end deftypefn + +@deftypefn Instruction {} drop c24:@var{count} +Pop the stack pointer by @var{count} words, discarding any values that +were stored there. +@end deftypefn + @node Inlined Scheme Instructions @subsubsection Inlined Scheme Instructions @@ -1147,101 +1208,101 @@ procedures. It tries to inline these small operations to avoid the overhead of creating new stack frames. This allows the compiler to optimize better. -@deftypefn Instruction {} make-vector u8:@var{dst} u8:@var{length} u8:@var{init} +@deftypefn Instruction {} make-vector s8:@var{dst} s8:@var{length} s8:@var{init} Make a vector and write it to @var{dst}. The vector will have space for @var{length} slots. They will be filled with the value in slot @var{init}. @end deftypefn -@deftypefn Instruction {} make-vector/immediate u8:@var{dst} u8:@var{length} u8:@var{init} +@deftypefn Instruction {} make-vector/immediate s8:@var{dst} s8:@var{length} c8:@var{init} Make a short vector of known size and write it to @var{dst}. The vector will have space for @var{length} slots, an immediate value. They will be filled with the value in slot @var{init}. @end deftypefn -@deftypefn Instruction {} vector-length u12:@var{dst} u12:@var{src} +@deftypefn Instruction {} vector-length s12:@var{dst} s12:@var{src} Store the length of the vector in @var{src} in @var{dst}. @end deftypefn -@deftypefn Instruction {} vector-ref u8:@var{dst} u8:@var{src} u8:@var{idx} +@deftypefn Instruction {} vector-ref s8:@var{dst} s8:@var{src} s8:@var{idx} Fetch the item at position @var{idx} in the vector in @var{src}, and store it in @var{dst}. @end deftypefn -@deftypefn Instruction {} vector-ref/immediate u8:@var{dst} u8:@var{src} u8:@var{idx} +@deftypefn Instruction {} vector-ref/immediate s8:@var{dst} s8:@var{src} c8:@var{idx} Fill @var{dst} with the item @var{idx} elements into the vector at @var{src}. Useful for building data types using vectors. @end deftypefn -@deftypefn Instruction {} vector-set! u8:@var{dst} u8:@var{idx} u8:@var{src} +@deftypefn Instruction {} vector-set! s8:@var{dst} s8:@var{idx} s8:@var{src} Store @var{src} into the vector @var{dst} at index @var{idx}. @end deftypefn -@deftypefn Instruction {} vector-set!/immediate u8:@var{dst} u8:@var{idx} u8:@var{src} +@deftypefn Instruction {} vector-set!/immediate s8:@var{dst} c8:@var{idx} s8:@var{src} Store @var{src} into the vector @var{dst} at index @var{idx}. Here @var{idx} is an immediate value. @end deftypefn -@deftypefn Instruction {} struct-vtable u12:@var{dst} u12:@var{src} +@deftypefn Instruction {} struct-vtable s12:@var{dst} s12:@var{src} Store the vtable of @var{src} into @var{dst}. @end deftypefn -@deftypefn Instruction {} allocate-struct u8:@var{dst} u8:@var{vtable} u8:@var{nfields} +@deftypefn Instruction {} allocate-struct s8:@var{dst} s8:@var{vtable} s8:@var{nfields} Allocate a new struct with @var{vtable}, and place it in @var{dst}. The struct will be constructed with space for @var{nfields} fields, which should correspond to the field count of the @var{vtable}. @end deftypefn -@deftypefn Instruction {} struct-ref u8:@var{dst} u8:@var{src} u8:@var{idx} +@deftypefn Instruction {} struct-ref s8:@var{dst} s8:@var{src} s8:@var{idx} Fetch the item at slot @var{idx} in the struct in @var{src}, and store it in @var{dst}. @end deftypefn -@deftypefn Instruction {} struct-set! u8:@var{dst} u8:@var{idx} u8:@var{src} +@deftypefn Instruction {} struct-set! s8:@var{dst} s8:@var{idx} s8:@var{src} Store @var{src} into the struct @var{dst} at slot @var{idx}. @end deftypefn -@deftypefn Instruction {} allocate-struct/immediate u8:@var{dst} u8:@var{vtable} u8:@var{nfields} -@deftypefnx Instruction {} struct-ref/immediate u8:@var{dst} u8:@var{src} u8:@var{idx} -@deftypefnx Instruction {} struct-set!/immediate u8:@var{dst} u8:@var{idx} u8:@var{src} +@deftypefn Instruction {} allocate-struct/immediate s8:@var{dst} s8:@var{vtable} c8:@var{nfields} +@deftypefnx Instruction {} struct-ref/immediate s8:@var{dst} s8:@var{src} c8:@var{idx} +@deftypefnx Instruction {} struct-set!/immediate s8:@var{dst} c8:@var{idx} s8:@var{src} Variants of the struct instructions, but in which the @var{nfields} or @var{idx} fields are immediate values. @end deftypefn -@deftypefn Instruction {} class-of u12:@var{dst} u12:@var{type} +@deftypefn Instruction {} class-of s12:@var{dst} s12:@var{type} Store the vtable of @var{src} into @var{dst}. @end deftypefn -@deftypefn Instruction {} make-array u8:@var{dst} u8:@var{type} u8:@var{fill} x8:@var{_} u24:@var{bounds} +@deftypefn Instruction {} make-array s24:@var{dst} x8:@var{_} s24:@var{type} x8:@var{_} s24:@var{fill} x8:@var{_} s24:@var{bounds} Make a new array with @var{type}, @var{fill}, and @var{bounds}, storing it in @var{dst}. @end deftypefn -@deftypefn Instruction {} string-length u12:@var{dst} u12:@var{src} +@deftypefn Instruction {} string-length s12:@var{dst} s12:@var{src} Store the length of the string in @var{src} in @var{dst}. @end deftypefn -@deftypefn Instruction {} string-ref u8:@var{dst} u8:@var{src} u8:@var{idx} +@deftypefn Instruction {} string-ref s8:@var{dst} s8:@var{src} s8:@var{idx} Fetch the character at position @var{idx} in the string in @var{src}, and store it in @var{dst}. @end deftypefn -@deftypefn Instruction {} cons u8:@var{dst} u8:@var{car} u8:@var{cdr} +@deftypefn Instruction {} cons s8:@var{dst} s8:@var{car} s8:@var{cdr} Cons @var{car} and @var{cdr}, and store the result in @var{dst}. @end deftypefn -@deftypefn Instruction {} car u12:@var{dst} u12:@var{src} +@deftypefn Instruction {} car s12:@var{dst} s12:@var{src} Place the car of @var{src} in @var{dst}. @end deftypefn -@deftypefn Instruction {} cdr u12:@var{dst} u12:@var{src} +@deftypefn Instruction {} cdr s12:@var{dst} s12:@var{src} Place the cdr of @var{src} in @var{dst}. @end deftypefn -@deftypefn Instruction {} set-car! u12:@var{pair} u12:@var{car} +@deftypefn Instruction {} set-car! s12:@var{pair} s12:@var{car} Set the car of @var{dst} to @var{src}. @end deftypefn -@deftypefn Instruction {} set-cdr! u12:@var{pair} u12:@var{cdr} +@deftypefn Instruction {} set-cdr! s12:@var{pair} s12:@var{cdr} Set the cdr of @var{dst} to @var{src}. @end deftypefn @@ -1262,55 +1323,55 @@ More instructions could be added here over time. All of these operations place their result in their first operand, @var{dst}. -@deftypefn Instruction {} add u8:@var{dst} u8:@var{a} u8:@var{b} +@deftypefn Instruction {} add s8:@var{dst} s8:@var{a} s8:@var{b} Add @var{a} to @var{b}. @end deftypefn -@deftypefn Instruction {} add1 u12:@var{dst} u12:@var{src} +@deftypefn Instruction {} add1 s12:@var{dst} s12:@var{src} Add 1 to the value in @var{src}. @end deftypefn -@deftypefn Instruction {} sub u8:@var{dst} u8:@var{a} u8:@var{b} +@deftypefn Instruction {} sub s8:@var{dst} s8:@var{a} s8:@var{b} Subtract @var{b} from @var{a}. @end deftypefn -@deftypefn Instruction {} sub1 u12:@var{dst} u12:@var{src} +@deftypefn Instruction {} sub1 s12:@var{dst} s12:@var{src} Subtract 1 from @var{src}. @end deftypefn -@deftypefn Instruction {} mul u8:@var{dst} u8:@var{a} u8:@var{b} +@deftypefn Instruction {} mul s8:@var{dst} s8:@var{a} s8:@var{b} Multiply @var{a} and @var{b}. @end deftypefn -@deftypefn Instruction {} div u8:@var{dst} u8:@var{a} u8:@var{b} +@deftypefn Instruction {} div s8:@var{dst} s8:@var{a} s8:@var{b} Divide @var{a} by @var{b}. @end deftypefn -@deftypefn Instruction {} quo u8:@var{dst} u8:@var{a} u8:@var{b} +@deftypefn Instruction {} quo s8:@var{dst} s8:@var{a} s8:@var{b} Divide @var{a} by @var{b}. @end deftypefn -@deftypefn Instruction {} rem u8:@var{dst} u8:@var{a} u8:@var{b} +@deftypefn Instruction {} rem s8:@var{dst} s8:@var{a} s8:@var{b} Divide @var{a} by @var{b}. @end deftypefn -@deftypefn Instruction {} mod u8:@var{dst} u8:@var{a} u8:@var{b} +@deftypefn Instruction {} mod s8:@var{dst} s8:@var{a} s8:@var{b} Compute the modulo of @var{a} by @var{b}. @end deftypefn -@deftypefn Instruction {} ash u8:@var{dst} u8:@var{a} u8:@var{b} +@deftypefn Instruction {} ash s8:@var{dst} s8:@var{a} s8:@var{b} Shift @var{a} arithmetically by @var{b} bits. @end deftypefn -@deftypefn Instruction {} logand u8:@var{dst} u8:@var{a} u8:@var{b} +@deftypefn Instruction {} logand s8:@var{dst} s8:@var{a} s8:@var{b} Compute the bitwise @code{and} of @var{a} and @var{b}. @end deftypefn -@deftypefn Instruction {} logior u8:@var{dst} u8:@var{a} u8:@var{b} +@deftypefn Instruction {} logior s8:@var{dst} s8:@var{a} s8:@var{b} Compute the bitwise inclusive @code{or} of @var{a} with @var{b}. @end deftypefn -@deftypefn Instruction {} logxor u8:@var{dst} u8:@var{a} u8:@var{b} +@deftypefn Instruction {} logxor s8:@var{dst} s8:@var{a} s8:@var{b} Compute the bitwise exclusive @code{or} of @var{a} with @var{b}. @end deftypefn @@ -1324,31 +1385,31 @@ a clear path for eventual native compilation. Without this, Scheme programs would need other primitives for accessing raw bytes -- but these primitives are as good as any. -@deftypefn Instruction {} bv-u8-ref u8:@var{dst} u8:@var{src} u8:@var{idx} -@deftypefnx Instruction {} bv-s8-ref u8:@var{dst} u8:@var{src} u8:@var{idx} -@deftypefnx Instruction {} bv-u16-ref u8:@var{dst} u8:@var{src} u8:@var{idx} -@deftypefnx Instruction {} bv-s16-ref u8:@var{dst} u8:@var{src} u8:@var{idx} -@deftypefnx Instruction {} bv-u32-ref u8:@var{dst} u8:@var{src} u8:@var{idx} -@deftypefnx Instruction {} bv-s32-ref u8:@var{dst} u8:@var{src} u8:@var{idx} -@deftypefnx Instruction {} bv-u64-ref u8:@var{dst} u8:@var{src} u8:@var{idx} -@deftypefnx Instruction {} bv-s64-ref u8:@var{dst} u8:@var{src} u8:@var{idx} -@deftypefnx Instruction {} bv-f32-ref u8:@var{dst} u8:@var{src} u8:@var{idx} -@deftypefnx Instruction {} bv-f64-ref u8:@var{dst} u8:@var{src} u8:@var{idx} +@deftypefn Instruction {} bv-u8-ref s8:@var{dst} s8:@var{src} s8:@var{idx} +@deftypefnx Instruction {} bv-s8-ref s8:@var{dst} s8:@var{src} s8:@var{idx} +@deftypefnx Instruction {} bv-u16-ref s8:@var{dst} s8:@var{src} s8:@var{idx} +@deftypefnx Instruction {} bv-s16-ref s8:@var{dst} s8:@var{src} s8:@var{idx} +@deftypefnx Instruction {} bv-u32-ref s8:@var{dst} s8:@var{src} s8:@var{idx} +@deftypefnx Instruction {} bv-s32-ref s8:@var{dst} s8:@var{src} s8:@var{idx} +@deftypefnx Instruction {} bv-u64-ref s8:@var{dst} s8:@var{src} s8:@var{idx} +@deftypefnx Instruction {} bv-s64-ref s8:@var{dst} s8:@var{src} s8:@var{idx} +@deftypefnx Instruction {} bv-f32-ref s8:@var{dst} s8:@var{src} s8:@var{idx} +@deftypefnx Instruction {} bv-f64-ref s8:@var{dst} s8:@var{src} s8:@var{idx} Fetch the item at byte offset @var{idx} in the bytevector @var{src}, and store it in @var{dst}. All accesses use native endianness. @end deftypefn -@deftypefn Instruction {} bv-u8-set! u8:@var{dst} u8:@var{idx} u8:@var{src} -@deftypefnx Instruction {} bv-s8-set! u8:@var{dst} u8:@var{idx} u8:@var{src} -@deftypefnx Instruction {} bv-u16-set! u8:@var{dst} u8:@var{idx} u8:@var{src} -@deftypefnx Instruction {} bv-s16-set! u8:@var{dst} u8:@var{idx} u8:@var{src} -@deftypefnx Instruction {} bv-u32-set! u8:@var{dst} u8:@var{idx} u8:@var{src} -@deftypefnx Instruction {} bv-s32-set! u8:@var{dst} u8:@var{idx} u8:@var{src} -@deftypefnx Instruction {} bv-u64-set! u8:@var{dst} u8:@var{idx} u8:@var{src} -@deftypefnx Instruction {} bv-s64-set! u8:@var{dst} u8:@var{idx} u8:@var{src} -@deftypefnx Instruction {} bv-f32-set! u8:@var{dst} u8:@var{idx} u8:@var{src} -@deftypefnx Instruction {} bv-f64-set! u8:@var{dst} u8:@var{idx} u8:@var{src} +@deftypefn Instruction {} bv-u8-set! s8:@var{dst} s8:@var{idx} s8:@var{src} +@deftypefnx Instruction {} bv-s8-set! s8:@var{dst} s8:@var{idx} s8:@var{src} +@deftypefnx Instruction {} bv-u16-set! s8:@var{dst} s8:@var{idx} s8:@var{src} +@deftypefnx Instruction {} bv-s16-set! s8:@var{dst} s8:@var{idx} s8:@var{src} +@deftypefnx Instruction {} bv-u32-set! s8:@var{dst} s8:@var{idx} s8:@var{src} +@deftypefnx Instruction {} bv-s32-set! s8:@var{dst} s8:@var{idx} s8:@var{src} +@deftypefnx Instruction {} bv-u64-set! s8:@var{dst} s8:@var{idx} s8:@var{src} +@deftypefnx Instruction {} bv-s64-set! s8:@var{dst} s8:@var{idx} s8:@var{src} +@deftypefnx Instruction {} bv-f32-set! s8:@var{dst} s8:@var{idx} s8:@var{src} +@deftypefnx Instruction {} bv-f64-set! s8:@var{dst} s8:@var{idx} s8:@var{src} Store @var{src} into the bytevector @var{dst} at byte offset @var{idx}. Multibyte values are written using native endianness. diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index b76433ba5..233ba759b 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -219,7 +219,13 @@ address of that offset." (list "~S" (unpack-scm (logior (ash high 32) low)))) (('assert-nargs-ee/locals nargs locals) ;; The nargs includes the procedure. - (list "~a arg~:p, ~a local~:p" (1- nargs) locals)) + (list "~a slot~:p (~a arg~:p)" (+ locals nargs) (1- nargs))) + (('alloc-frame nlocals) + (list "~a slot~:p" nlocals)) + (('reset-frame nlocals) + (list "~a slot~:p" nlocals)) + (('bind-rest dst) + (list "~a slot~:p" (1+ dst))) (('tail-call nargs proc) (list "~a arg~:p" nargs)) (('make-closure dst target nfree) From 9144f50c319845828515ceb313609da9e827ffa6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 22 Oct 2015 11:35:07 +0000 Subject: [PATCH 064/865] subr-call implementation simplification * libguile/vm-engine.c (subr-call): Reference args from SP, not FP. --- libguile/vm-engine.c | 45 ++++++++++++++++++++++---------------------- 1 file changed, 22 insertions(+), 23 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index ca369bd99..308c04cd9 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -801,53 +801,52 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, SYNC_IP (); - // FIXME!!!! switch (FRAME_LOCALS_COUNT_FROM (1)) { case 0: ret = subr (); break; case 1: - ret = subr (FP_REF (1)); + ret = subr (SP_REF (0)); break; case 2: - ret = subr (FP_REF (1), FP_REF (2)); + ret = subr (SP_REF (1), SP_REF (0)); break; case 3: - ret = subr (FP_REF (1), FP_REF (2), FP_REF (3)); + ret = subr (SP_REF (2), SP_REF (1), SP_REF (0)); break; case 4: - ret = subr (FP_REF (1), FP_REF (2), FP_REF (3), - FP_REF (4)); + ret = subr (SP_REF (3), SP_REF (2), SP_REF (1), + SP_REF (0)); break; case 5: - ret = subr (FP_REF (1), FP_REF (2), FP_REF (3), - FP_REF (4), FP_REF (5)); + ret = subr (SP_REF (4), SP_REF (3), SP_REF (2), + SP_REF (1), SP_REF (0)); break; case 6: - ret = subr (FP_REF (1), FP_REF (2), FP_REF (3), - FP_REF (4), FP_REF (5), FP_REF (6)); + ret = subr (SP_REF (5), SP_REF (4), SP_REF (3), + SP_REF (2), SP_REF (1), SP_REF (0)); break; case 7: - ret = subr (FP_REF (1), FP_REF (2), FP_REF (3), - FP_REF (4), FP_REF (5), FP_REF (6), - FP_REF (7)); + ret = subr (SP_REF (6), SP_REF (5), SP_REF (4), + SP_REF (3), SP_REF (2), SP_REF (1), + SP_REF (0)); break; case 8: - ret = subr (FP_REF (1), FP_REF (2), FP_REF (3), - FP_REF (4), FP_REF (5), FP_REF (6), - FP_REF (7), FP_REF (8)); + ret = subr (SP_REF (7), SP_REF (6), SP_REF (5), + SP_REF (4), SP_REF (3), SP_REF (2), + SP_REF (1), SP_REF (0)); break; case 9: - ret = subr (FP_REF (1), FP_REF (2), FP_REF (3), - FP_REF (4), FP_REF (5), FP_REF (6), - FP_REF (7), FP_REF (8), FP_REF (9)); + ret = subr (SP_REF (8), SP_REF (7), SP_REF (6), + SP_REF (5), SP_REF (4), SP_REF (3), + SP_REF (2), SP_REF (1), SP_REF (0)); break; case 10: - ret = subr (FP_REF (1), FP_REF (2), FP_REF (3), - FP_REF (4), FP_REF (5), FP_REF (6), - FP_REF (7), FP_REF (8), FP_REF (9), - FP_REF (10)); + ret = subr (SP_REF (9), SP_REF (8), SP_REF (7), + SP_REF (6), SP_REF (5), SP_REF (4), + SP_REF (3), SP_REF (2), SP_REF (1), + SP_REF (0)); break; default: abort (); From 8832e8b68c528fe48e65902692abe713730dd68e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 22 Oct 2015 12:13:37 +0000 Subject: [PATCH 065/865] Small subr-call refactor * libguile/gsubr.c (scm_apply_subr): New internal helper. * libguile/vm-engine.c (subr-call): Call out to scm_apply_subr. * doc/ref/vm.texi (subr-call): Don't specify how the foreign pointer is obtained. --- doc/ref/vm.texi | 7 ++--- libguile/gsubr.c | 43 ++++++++++++++++++++++++- libguile/gsubr.h | 6 +++- libguile/vm-engine.c | 74 +++++--------------------------------------- 4 files changed, 58 insertions(+), 72 deletions(-) diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 45c3928a0..e44f21169 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -888,10 +888,9 @@ compiler probably shouldn't emit code with these instructions. However, it's still interesting to know how these things work, so we document these trampoline instructions here. -@deftypefn Instruction {} subr-call c24:@var{ptr-idx} -Call a subr, passing all locals in this frame as arguments. Fetch the -foreign pointer from @var{ptr-idx}, a free variable. Return from the -calling frame. +@deftypefn Instruction {} subr-call x24:@var{_} +Call a subr, passing all locals in this frame as arguments. Return from +the calling frame. @end deftypefn @deftypefn Instruction {} foreign-call c12:@var{cif-idx} c12:@var{ptr-idx} diff --git a/libguile/gsubr.c b/libguile/gsubr.c index 329241da2..a3b804bb5 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995-2001, 2006, 2008-2011, 2013 +/* Copyright (C) 1995-2001, 2006, 2008-2011, 2013, 2015 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -295,6 +295,47 @@ scm_i_primitive_call_ip (SCM subr) return (scm_t_uintptr)(code + (code[3] ? 3 : code[2] ? 2 : 1)); } +SCM +scm_apply_subr (union scm_vm_stack_element *sp, scm_t_ptrdiff nslots) +{ + SCM (*subr)() = SCM_SUBRF (sp[nslots - 1].as_scm); + +#define ARG(i) (sp[i].as_scm) + switch (nslots - 1) + { + case 0: + return subr (); + case 1: + return subr (ARG (0)); + case 2: + return subr (ARG (1), ARG (0)); + case 3: + return subr (ARG (2), ARG (1), ARG (0)); + case 4: + return subr (ARG (3), ARG (2), ARG (1), ARG (0)); + case 5: + return subr (ARG (4), ARG (3), ARG (2), ARG (1), ARG (0)); + case 6: + return subr (ARG (5), ARG (4), ARG (3), ARG (2), ARG (1), + ARG (0)); + case 7: + return subr (ARG (6), ARG (5), ARG (4), ARG (3), ARG (2), + ARG (1), ARG (0)); + case 8: + return subr (ARG (7), ARG (6), ARG (5), ARG (4), ARG (3), + ARG (2), ARG (1), ARG (0)); + case 9: + return subr (ARG (8), ARG (7), ARG (6), ARG (5), ARG (4), + ARG (3), ARG (2), ARG (1), ARG (0)); + case 10: + return subr (ARG (9), ARG (8), ARG (7), ARG (6), ARG (5), + ARG (4), ARG (3), ARG (2), ARG (1), ARG (0)); + default: + abort (); + } +#undef ARG +} + SCM scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)()) { diff --git a/libguile/gsubr.h b/libguile/gsubr.h index 065b94766..a9db85e44 100644 --- a/libguile/gsubr.h +++ b/libguile/gsubr.h @@ -4,7 +4,7 @@ #define SCM_GSUBR_H /* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2006, 2008, 2009, - * 2010, 2011, 2013 Free Software Foundation, Inc. + * 2010, 2011, 2013, 2015 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 License @@ -57,6 +57,10 @@ SCM_INTERNAL int scm_i_primitive_arity (SCM subr, int *req, int *opt, int *rest); SCM_INTERNAL scm_t_uintptr scm_i_primitive_call_ip (SCM subr); +union scm_vm_stack_element; +SCM_INTERNAL SCM scm_apply_subr (union scm_vm_stack_element *sp, + scm_t_ptrdiff nargs); + SCM_API SCM scm_c_make_gsubr (const char *name, int req, int opt, int rst, scm_t_subr fcn); SCM_API SCM scm_c_make_gsubr_with_generic (const char *name, diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 308c04cd9..d5f68578d 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -781,77 +781,19 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Specialized call stubs */ - /* subr-call ptr-idx:24 + /* subr-call _:24 * - * Call a subr, passing all locals in this frame as arguments. Fetch - * the foreign pointer from PTR-IDX, a free variable. Return from the - * calling frame. This instruction is part of the trampolines - * created in gsubr.c, and is not generated by the compiler. + * Call a subr, passing all locals in this frame as arguments. Return + * from the calling frame. This instruction is part of the + * trampolines created in gsubr.c, and is not generated by the + * compiler. */ - VM_DEFINE_OP (10, subr_call, "subr-call", OP1 (X8_C24)) + VM_DEFINE_OP (10, subr_call, "subr-call", OP1 (X32)) { - scm_t_uint32 ptr_idx; - SCM pointer, ret; - SCM (*subr)(); - - UNPACK_24 (op, ptr_idx); - - pointer = SCM_PROGRAM_FREE_VARIABLE_REF (FP_REF (0), ptr_idx); - subr = SCM_POINTER_VALUE (pointer); + SCM ret; SYNC_IP (); - - switch (FRAME_LOCALS_COUNT_FROM (1)) - { - case 0: - ret = subr (); - break; - case 1: - ret = subr (SP_REF (0)); - break; - case 2: - ret = subr (SP_REF (1), SP_REF (0)); - break; - case 3: - ret = subr (SP_REF (2), SP_REF (1), SP_REF (0)); - break; - case 4: - ret = subr (SP_REF (3), SP_REF (2), SP_REF (1), - SP_REF (0)); - break; - case 5: - ret = subr (SP_REF (4), SP_REF (3), SP_REF (2), - SP_REF (1), SP_REF (0)); - break; - case 6: - ret = subr (SP_REF (5), SP_REF (4), SP_REF (3), - SP_REF (2), SP_REF (1), SP_REF (0)); - break; - case 7: - ret = subr (SP_REF (6), SP_REF (5), SP_REF (4), - SP_REF (3), SP_REF (2), SP_REF (1), - SP_REF (0)); - break; - case 8: - ret = subr (SP_REF (7), SP_REF (6), SP_REF (5), - SP_REF (4), SP_REF (3), SP_REF (2), - SP_REF (1), SP_REF (0)); - break; - case 9: - ret = subr (SP_REF (8), SP_REF (7), SP_REF (6), - SP_REF (5), SP_REF (4), SP_REF (3), - SP_REF (2), SP_REF (1), SP_REF (0)); - break; - case 10: - ret = subr (SP_REF (9), SP_REF (8), SP_REF (7), - SP_REF (6), SP_REF (5), SP_REF (4), - SP_REF (3), SP_REF (2), SP_REF (1), - SP_REF (0)); - break; - default: - abort (); - } - + ret = scm_apply_subr (sp, FRAME_LOCALS_COUNT ()); CACHE_SP (); if (SCM_UNLIKELY (SCM_VALUESP (ret))) From 139ef2d17c98488fc8e5444bf642699f2ad09e08 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 22 Oct 2015 13:03:51 +0000 Subject: [PATCH 066/865] Minor NEWS update. --- NEWS | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/NEWS b/NEWS index 208ec9ebd..604113470 100644 --- a/NEWS +++ b/NEWS @@ -132,10 +132,10 @@ Guile's compiler now uses a Continuation-Passing Style (CPS) intermediate language, allowing it to reason easily about temporary values and control flow. Examples of optimizations that this permits are optimal contification, optimal common subexpression elimination, -dead code elimination, parallel moves with at most one temporary, -allocation of stack slots using precise liveness information, and -closure optimization. For more, see "Continuation-Passing Style" in the -manual. +dead code elimination, loop-invariant code motion, loop peeling, loop +inversion, parallel moves with at most one temporary, allocation of +stack slots using precise liveness information, and closure +optimization. For more, see "Continuation-Passing Style" in the manual. ** Faster interpreter From 2d4da30fdefbcdb065d4b1f48f2a77d06f69e3c3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 22 Oct 2015 13:10:30 +0000 Subject: [PATCH 067/865] Update Gnulib to v0.1-603-g1d16a7b --- GNUmakefile | 2 +- build-aux/announce-gen | 24 +- build-aux/config.rpath | 18 +- build-aux/gendocs.sh | 115 +-- build-aux/git-version-gen | 11 +- build-aux/gitlog-to-changelog | 180 +++-- build-aux/gnu-web-doc-update | 19 +- build-aux/gnupload | 2 +- build-aux/snippet/arg-nonnull.h | 2 +- build-aux/snippet/c++defs.h | 2 +- build-aux/snippet/unused-parameter.h | 2 +- build-aux/snippet/warn-on-use.h | 2 +- build-aux/useless-if-before-free | 2 +- build-aux/vc-list-files | 2 +- doc/gendocs_template | 20 +- gnulib-local/build-aux/git-version-gen.diff | 14 +- lib/Makefile.am | 75 +- lib/accept.c | 2 +- lib/alignof.h | 2 +- lib/alloca.in.h | 2 +- lib/arpa_inet.in.h | 2 +- lib/asnprintf.c | 2 +- lib/assure.h | 37 + lib/basename-lgpl.c | 2 +- lib/binary-io.c | 1 + lib/binary-io.h | 2 +- lib/bind.c | 2 +- lib/btowc.c | 2 +- lib/byteswap.in.h | 2 +- lib/c-ctype.c | 394 +---------- lib/c-ctype.h | 453 +++++++----- lib/c-strcase.h | 2 +- lib/c-strcasecmp.c | 2 +- lib/c-strcaseeq.h | 5 +- lib/c-strncasecmp.c | 2 +- lib/canonicalize-lgpl.c | 2 +- lib/ceil.c | 2 +- lib/close.c | 2 +- lib/config.charset | 6 +- lib/connect.c | 2 +- lib/copysign.c | 2 +- lib/dirent.in.h | 4 +- lib/dirfd.c | 2 +- lib/dirname-lgpl.c | 2 +- lib/dirname.h | 10 +- lib/dosname.h | 2 +- lib/dup2.c | 2 +- lib/duplocale.c | 2 +- lib/errno.in.h | 2 +- lib/fcntl.in.h | 22 +- lib/fd-hook.c | 2 +- lib/fd-hook.h | 2 +- lib/float+.h | 2 +- lib/float.c | 2 +- lib/float.in.h | 2 +- lib/flock.c | 2 +- lib/floor.c | 2 +- lib/frexp.c | 2 +- lib/fstat.c | 2 +- lib/fsync.c | 2 +- lib/full-read.c | 2 +- lib/full-read.h | 3 +- lib/full-write.c | 2 +- lib/full-write.h | 2 +- lib/gai_strerror.c | 2 +- lib/getaddrinfo.c | 2 +- lib/getlogin.c | 2 +- lib/getpeername.c | 2 +- lib/getsockname.c | 2 +- lib/getsockopt.c | 2 +- lib/gettext.h | 2 +- lib/gettimeofday.c | 2 +- lib/glthread/lock.h | 2 +- lib/iconv.c | 2 +- lib/iconv.in.h | 2 +- lib/iconv_close.c | 2 +- lib/iconv_open-aix.h | 2 +- lib/iconv_open-hpux.h | 4 +- lib/iconv_open-irix.h | 4 +- lib/iconv_open-osf.h | 4 +- lib/iconv_open.c | 2 +- lib/iconveh.h | 2 +- lib/ignore-value.h | 37 - lib/inet_ntop.c | 2 +- lib/inet_pton.c | 2 +- lib/isfinite.c | 2 +- lib/isinf.c | 2 +- lib/isnan.c | 2 +- lib/isnand-nolibm.h | 2 +- lib/isnand.c | 2 +- lib/isnanf-nolibm.h | 2 +- lib/isnanf.c | 2 +- lib/isnanl-nolibm.h | 2 +- lib/isnanl.c | 2 +- lib/itold.c | 2 +- lib/langinfo.in.h | 20 +- lib/link.c | 2 +- lib/listen.c | 2 +- lib/localcharset.c | 81 ++- lib/localcharset.h | 2 +- lib/locale.in.h | 2 +- lib/localeconv.c | 2 +- lib/log.c | 2 +- lib/log1p.c | 2 +- lib/lstat.c | 2 +- lib/malloc.c | 2 +- lib/malloca.c | 2 +- lib/malloca.h | 2 +- lib/math.c | 1 + lib/math.in.h | 2 +- lib/mbrtowc.c | 9 +- lib/mbsinit.c | 2 +- lib/mbtowc-impl.h | 2 +- lib/mbtowc.c | 2 +- lib/memchr.c | 2 +- lib/mkdir.c | 2 +- lib/mkstemp.c | 2 +- lib/mktime-internal.h | 4 + lib/mktime.c | 741 ++++++++++++++++++++ lib/msvc-inval.c | 2 +- lib/msvc-inval.h | 2 +- lib/msvc-nothrow.c | 2 +- lib/msvc-nothrow.h | 2 +- lib/netdb.in.h | 2 +- lib/netinet_in.in.h | 2 +- lib/nl_langinfo.c | 255 ++++--- lib/nproc.c | 2 +- lib/nproc.h | 2 +- lib/open.c | 2 +- lib/pathmax.h | 2 +- lib/pipe.c | 2 +- lib/pipe2.c | 2 +- lib/poll.c | 83 +-- lib/poll.in.h | 2 +- lib/printf-args.c | 2 +- lib/printf-args.h | 2 +- lib/printf-parse.c | 2 +- lib/printf-parse.h | 2 +- lib/putenv.c | 2 +- lib/raise.c | 2 +- lib/read.c | 2 +- lib/readlink.c | 2 +- lib/recv.c | 2 +- lib/recvfrom.c | 2 +- lib/ref-add.sin | 2 +- lib/ref-del.sin | 2 +- lib/regcomp.c | 44 +- lib/regex.c | 2 +- lib/regex.h | 19 +- lib/regex_internal.c | 23 +- lib/regex_internal.h | 35 +- lib/regexec.c | 10 +- lib/rename.c | 8 +- lib/rmdir.c | 2 +- lib/round.c | 2 +- lib/safe-read.c | 2 +- lib/safe-read.h | 2 +- lib/safe-write.c | 2 +- lib/safe-write.h | 2 +- lib/same-inode.h | 2 +- lib/secure_getenv.c | 2 +- lib/select.c | 38 +- lib/send.c | 2 +- lib/sendto.c | 2 +- lib/setenv.c | 2 +- lib/setsockopt.c | 2 +- lib/shutdown.c | 2 +- lib/signal.in.h | 10 +- lib/signbitd.c | 2 +- lib/signbitf.c | 2 +- lib/signbitl.c | 2 +- lib/size_max.h | 2 +- lib/snprintf.c | 2 +- lib/socket.c | 2 +- lib/sockets.c | 9 +- lib/sockets.h | 12 +- lib/stat-time.h | 18 +- lib/stat.c | 2 +- lib/stdalign.in.h | 21 +- lib/stdbool.in.h | 2 +- lib/stddef.in.h | 54 +- lib/stdint.in.h | 5 +- lib/stdio.in.h | 12 +- lib/stdlib.in.h | 25 +- lib/strdup.c | 2 +- lib/streq.h | 2 +- lib/strftime.c | 122 ++-- lib/strftime.h | 9 +- lib/striconveh.c | 2 +- lib/striconveh.h | 2 +- lib/string.in.h | 23 +- lib/stripslash.c | 2 +- lib/sys_file.in.h | 2 +- lib/sys_select.in.h | 17 +- lib/sys_socket.c | 1 + lib/sys_socket.in.h | 2 +- lib/sys_stat.in.h | 2 +- lib/sys_time.in.h | 2 +- lib/sys_times.in.h | 2 +- lib/sys_types.in.h | 4 +- lib/sys_uio.in.h | 2 +- lib/tempname.c | 120 ++-- lib/tempname.h | 17 +- lib/time-internal.h | 49 ++ lib/time.in.h | 31 +- lib/time_r.c | 2 +- lib/time_rz.c | 323 +++++++++ lib/timegm.c | 38 + lib/times.c | 4 +- lib/trunc.c | 2 +- lib/unistd.c | 1 + lib/unistd.in.h | 39 +- lib/unistr.in.h | 2 +- lib/unistr/u8-mbtouc-aux.c | 2 +- lib/unistr/u8-mbtouc-unsafe-aux.c | 2 +- lib/unistr/u8-mbtouc-unsafe.c | 2 +- lib/unistr/u8-mbtouc.c | 2 +- lib/unistr/u8-mbtoucr.c | 2 +- lib/unistr/u8-prev.c | 2 +- lib/unistr/u8-uctomb-aux.c | 2 +- lib/unistr/u8-uctomb.c | 2 +- lib/unitypes.in.h | 2 +- lib/unsetenv.c | 127 ++++ lib/vasnprintf.c | 199 +++--- lib/vasnprintf.h | 2 +- lib/verify.h | 2 +- lib/vsnprintf.c | 2 +- lib/w32sock.h | 2 +- lib/wchar.in.h | 11 +- lib/wcrtomb.c | 2 +- lib/wctype.in.h | 2 +- lib/write.c | 2 +- lib/xsize.h | 2 +- m4/00gnulib.m4 | 2 +- m4/absolute-header.m4 | 2 +- m4/alloca.m4 | 2 +- m4/arpa_inet_h.m4 | 2 +- m4/autobuild.m4 | 2 +- m4/btowc.m4 | 2 +- m4/byteswap.m4 | 2 +- m4/canonicalize.m4 | 2 +- m4/ceil.m4 | 2 +- m4/check-math-lib.m4 | 2 +- m4/clock_time.m4 | 2 +- m4/close.m4 | 2 +- m4/configmake.m4 | 2 +- m4/copysign.m4 | 2 +- m4/dirent_h.m4 | 2 +- m4/dirfd.m4 | 2 +- m4/dirname.m4 | 2 +- m4/double-slash-root.m4 | 2 +- m4/dup2.m4 | 84 ++- m4/duplocale.m4 | 2 +- m4/eealloc.m4 | 2 +- m4/environ.m4 | 2 +- m4/errno_h.m4 | 2 +- m4/exponentd.m4 | 2 +- m4/exponentf.m4 | 2 +- m4/exponentl.m4 | 2 +- m4/extensions.m4 | 7 +- m4/extern-inline.m4 | 45 +- m4/fcntl-o.m4 | 2 +- m4/fcntl_h.m4 | 2 +- m4/flexmember.m4 | 41 ++ m4/float_h.m4 | 2 +- m4/flock.m4 | 2 +- m4/floor.m4 | 2 +- m4/fpieee.m4 | 4 +- m4/frexp.m4 | 2 +- m4/fstat.m4 | 2 +- m4/fsync.m4 | 2 +- m4/func.m4 | 2 +- m4/getaddrinfo.m4 | 2 +- m4/getlogin.m4 | 2 +- m4/gettimeofday.m4 | 2 +- m4/glibc21.m4 | 2 +- m4/gnulib-cache.m4 | 5 +- m4/gnulib-common.m4 | 105 +-- m4/gnulib-comp.m4 | 65 +- m4/gnulib-tool.m4 | 2 +- m4/hostent.m4 | 2 +- m4/iconv.m4 | 61 +- m4/iconv_h.m4 | 2 +- m4/iconv_open-utf.m4 | 2 +- m4/iconv_open.m4 | 2 +- m4/include_next.m4 | 2 +- m4/inet_ntop.m4 | 2 +- m4/inet_pton.m4 | 2 +- m4/inline.m4 | 2 +- m4/intmax_t.m4 | 2 +- m4/inttypes_h.m4 | 2 +- m4/isfinite.m4 | 40 +- m4/isinf.m4 | 43 +- m4/isnan.m4 | 2 +- m4/isnand.m4 | 2 +- m4/isnanf.m4 | 2 +- m4/isnanl.m4 | 43 +- m4/langinfo_h.m4 | 2 +- m4/largefile.m4 | 2 +- m4/ld-version-script.m4 | 47 +- m4/ldexp.m4 | 2 +- m4/lib-ld.m4 | 2 +- m4/lib-link.m4 | 2 +- m4/lib-prefix.m4 | 2 +- m4/libunistring-base.m4 | 2 +- m4/libunistring.m4 | 2 +- m4/link.m4 | 2 +- m4/localcharset.m4 | 2 +- m4/locale-fr.m4 | 2 +- m4/locale-ja.m4 | 2 +- m4/locale-zh.m4 | 2 +- m4/locale_h.m4 | 2 +- m4/localeconv.m4 | 2 +- m4/log.m4 | 2 +- m4/log1p.m4 | 2 +- m4/longlong.m4 | 2 +- m4/lstat.m4 | 50 +- m4/malloc.m4 | 2 +- m4/malloca.m4 | 2 +- m4/math_h.m4 | 2 +- m4/mathfunc.m4 | 2 +- m4/mbrtowc.m4 | 48 +- m4/mbsinit.m4 | 2 +- m4/mbstate_t.m4 | 2 +- m4/mbtowc.m4 | 2 +- m4/memchr.m4 | 2 +- m4/mkdir.m4 | 2 +- m4/mkstemp.m4 | 2 +- m4/mktime.m4 | 253 +++++++ m4/mmap-anon.m4 | 2 +- m4/mode_t.m4 | 2 +- m4/msvc-inval.m4 | 2 +- m4/msvc-nothrow.m4 | 2 +- m4/multiarch.m4 | 2 +- m4/netdb_h.m4 | 2 +- m4/netinet_in_h.m4 | 2 +- m4/nl_langinfo.m4 | 2 +- m4/nocrash.m4 | 2 +- m4/nproc.m4 | 2 +- m4/off_t.m4 | 2 +- m4/open.m4 | 2 +- m4/pathmax.m4 | 2 +- m4/pipe.m4 | 2 +- m4/pipe2.m4 | 2 +- m4/poll.m4 | 2 +- m4/poll_h.m4 | 2 +- m4/printf.m4 | 67 +- m4/putenv.m4 | 2 +- m4/raise.m4 | 2 +- m4/read.m4 | 2 +- m4/readlink.m4 | 2 +- m4/regex.m4 | 2 +- m4/rename.m4 | 2 +- m4/rmdir.m4 | 2 +- m4/round.m4 | 2 +- m4/safe-read.m4 | 2 +- m4/safe-write.m4 | 2 +- m4/secure_getenv.m4 | 2 +- m4/select.m4 | 2 +- m4/servent.m4 | 2 +- m4/setenv.m4 | 2 +- m4/signal_h.m4 | 2 +- m4/signbit.m4 | 2 +- m4/size_max.m4 | 2 +- m4/snprintf.m4 | 2 +- m4/socketlib.m4 | 2 +- m4/sockets.m4 | 2 +- m4/socklen.m4 | 2 +- m4/sockpfaf.m4 | 2 +- m4/ssize_t.m4 | 2 +- m4/stat-time.m4 | 2 +- m4/stat.m4 | 2 +- m4/stdalign.m4 | 10 +- m4/stdbool.m4 | 2 +- m4/stddef_h.m4 | 10 +- m4/stdint.m4 | 2 +- m4/stdint_h.m4 | 2 +- m4/stdio_h.m4 | 31 +- m4/stdlib_h.m4 | 4 +- m4/strdup.m4 | 2 +- m4/strftime.m4 | 2 +- m4/string_h.m4 | 2 +- m4/sys_file_h.m4 | 2 +- m4/sys_select_h.m4 | 2 +- m4/sys_socket_h.m4 | 2 +- m4/sys_stat_h.m4 | 2 +- m4/sys_time_h.m4 | 3 +- m4/sys_times_h.m4 | 2 +- m4/sys_types_h.m4 | 2 +- m4/sys_uio_h.m4 | 2 +- m4/tempname.m4 | 2 +- m4/time_h.m4 | 22 +- m4/time_r.m4 | 2 +- m4/time_rz.m4 | 21 + m4/timegm.m4 | 26 + m4/times.m4 | 2 +- m4/tm_gmtoff.m4 | 2 +- m4/trunc.m4 | 2 +- m4/unistd_h.m4 | 6 +- m4/vasnprintf.m4 | 2 +- m4/visibility.m4 | 2 +- m4/vsnprintf.m4 | 2 +- m4/warn-on-use.m4 | 2 +- m4/warnings.m4 | 2 +- m4/wchar_h.m4 | 2 +- m4/wchar_t.m4 | 2 +- m4/wcrtomb.m4 | 2 +- m4/wctype_h.m4 | 2 +- m4/wint_t.m4 | 2 +- m4/write.m4 | 2 +- m4/xsize.m4 | 2 +- maint.mk | 48 +- 412 files changed, 3961 insertions(+), 2000 deletions(-) create mode 100644 lib/assure.h delete mode 100644 lib/ignore-value.h create mode 100644 lib/mktime-internal.h create mode 100644 lib/mktime.c create mode 100644 lib/time-internal.h create mode 100644 lib/time_rz.c create mode 100644 lib/timegm.c create mode 100644 lib/unsetenv.c create mode 100644 m4/flexmember.m4 create mode 100644 m4/mktime.m4 create mode 100644 m4/time_rz.m4 create mode 100644 m4/timegm.m4 diff --git a/GNUmakefile b/GNUmakefile index 4ab642943..6617eec2e 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -5,7 +5,7 @@ # It is necessary if you want to build targets usually of interest # only to the maintainer. -# Copyright (C) 2001, 2003, 2006-2014 Free Software Foundation, Inc. +# Copyright (C) 2001, 2003, 2006-2015 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/build-aux/announce-gen b/build-aux/announce-gen index db9ed50a7..8a6edb5d4 100755 --- a/build-aux/announce-gen +++ b/build-aux/announce-gen @@ -3,13 +3,13 @@ eval '(exit $?0)' && eval 'exec perl -wS "$0" ${1+"$@"}' if 0; # Generate a release announcement message. -my $VERSION = '2012-06-08 06:53'; # UTC +my $VERSION = '2013-07-09 06:39'; # UTC # The definition above must lie within the first 8 lines in order # for the Emacs time-stamp write hook (at end) to update it. # If you change this file with Emacs, please let the write hook # do its job. Otherwise, update this string manually. -# Copyright (C) 2002-2014 Free Software Foundation, Inc. +# Copyright (C) 2002-2015 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -29,15 +29,18 @@ my $VERSION = '2012-06-08 06:53'; # UTC use strict; use Getopt::Long; -use Digest::MD5; -eval { require Digest::SHA; } - or eval 'use Digest::SHA1'; use POSIX qw(strftime); (my $ME = $0) =~ s|.*/||; my %valid_release_types = map {$_ => 1} qw (alpha beta stable); my @archive_suffixes = ('tar.gz', 'tar.bz2', 'tar.lzma', 'tar.xz'); +my %digest_classes = + ( + 'md5' => (eval { require Digest::MD5; } and 'Digest::MD5'), + 'sha1' => ((eval { require Digest::SHA; } and 'Digest::SHA') + or (eval { require Digest::SHA1; } and 'Digest::SHA1')) + ); my $srcdir = '.'; sub usage ($) @@ -157,15 +160,13 @@ sub print_checksums (@) foreach my $meth (qw (md5 sha1)) { + my $class = $digest_classes{$meth} or next; foreach my $f (@file) { open IN, '<', $f or die "$ME: $f: cannot open for reading: $!\n"; binmode IN; - my $dig = - ($meth eq 'md5' - ? Digest::MD5->new->addfile(*IN)->hexdigest - : Digest::SHA1->new->addfile(*IN)->hexdigest); + my $dig = $class->new->addfile(*IN)->hexdigest; close IN; print "$dig $f\n"; } @@ -416,14 +417,15 @@ sub get_tool_versions ($$) @url_dir_list or (warn "URL directory name(s) not specified\n"), $fail = 1; - my @tool_list = split ',', $bootstrap_tools; + my @tool_list = split ',', $bootstrap_tools + if $bootstrap_tools; grep (/^gnulib$/, @tool_list) ^ defined $gnulib_version and (warn "when specifying gnulib as a tool, you must also specify\n" . "--gnulib-version=V, where V is the result of running git describe\n" . "in the gnulib source directory.\n"), $fail = 1; - exists $valid_release_types{$release_type} + !$release_type || exists $valid_release_types{$release_type} or (warn "'$release_type': invalid release type\n"), $fail = 1; @ARGV diff --git a/build-aux/config.rpath b/build-aux/config.rpath index ab6fd995f..a3e25c844 100755 --- a/build-aux/config.rpath +++ b/build-aux/config.rpath @@ -2,7 +2,7 @@ # Output a system dependent set of variables, describing how to set the # run time search path of shared libraries in an executable. # -# Copyright 1996-2014 Free Software Foundation, Inc. +# Copyright 1996-2015 Free Software Foundation, Inc. # Taken from GNU libtool, 2001 # Originally by Gordon Matzigkeit , 1996 # @@ -367,11 +367,7 @@ else dgux*) hardcode_libdir_flag_spec='-L$libdir' ;; - freebsd2.2*) - hardcode_libdir_flag_spec='-R$libdir' - hardcode_direct=yes - ;; - freebsd2*) + freebsd2.[01]*) hardcode_direct=yes hardcode_minus_L=yes ;; @@ -548,13 +544,11 @@ case "$host_os" in dgux*) library_names_spec='$libname$shrext' ;; + freebsd[23].*) + library_names_spec='$libname$shrext$versuffix' + ;; freebsd* | dragonfly*) - case "$host_os" in - freebsd[123]*) - library_names_spec='$libname$shrext$versuffix' ;; - *) - library_names_spec='$libname$shrext' ;; - esac + library_names_spec='$libname$shrext' ;; gnu*) library_names_spec='$libname$shrext' diff --git a/build-aux/gendocs.sh b/build-aux/gendocs.sh index f9ec9df76..c8ca1bbc4 100755 --- a/build-aux/gendocs.sh +++ b/build-aux/gendocs.sh @@ -2,10 +2,9 @@ # gendocs.sh -- generate a GNU manual in many formats. This script is # mentioned in maintain.texi. See the help message below for usage details. -scriptversion=2013-10-10.09 +scriptversion=2015-05-05.16 -# Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 -# Free Software Foundation, Inc. +# Copyright 2003-2015 Free Software Foundation, Inc. # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -21,17 +20,16 @@ scriptversion=2013-10-10.09 # along with this program. If not, see . # # Original author: Mohit Agarwal. -# Send bug reports and any other correspondence to bug-texinfo@gnu.org. +# Send bug reports and any other correspondence to bug-gnulib@gnu.org. # # The latest version of this script, and the companion template, is -# available from Texinfo CVS: -# http://savannah.gnu.org/cgi-bin/viewcvs/texinfo/texinfo/util/gendocs.sh -# http://savannah.gnu.org/cgi-bin/viewcvs/texinfo/texinfo/util/gendocs_template +# available from the Gnulib repository: # -# An up-to-date copy is also maintained in Gnulib (gnu.org/software/gnulib). +# http://git.savannah.gnu.org/cgit/gnulib.git/tree/build-aux/gendocs.sh +# http://git.savannah.gnu.org/cgit/gnulib.git/tree/doc/gendocs_template # TODO: -# - image importation was only implemented for HTML generated by +# - image importing was only implemented for HTML generated by # makeinfo. But it should be simple enough to adjust. # - images are not imported in the source tarball. All the needed # formats (PDF, PNG, etc.) should be included. @@ -39,12 +37,12 @@ scriptversion=2013-10-10.09 prog=`basename "$0"` srcdir=`pwd` -scripturl="http://savannah.gnu.org/cgi-bin/viewcvs/~checkout~/texinfo/texinfo/util/gendocs.sh" -templateurl="http://savannah.gnu.org/cgi-bin/viewcvs/~checkout~/texinfo/texinfo/util/gendocs_template" +scripturl="http://git.savannah.gnu.org/cgit/gnulib.git/plain/build-aux/gendocs.sh" +templateurl="http://git.savannah.gnu.org/cgit/gnulib.git/plain/doc/gendocs_template" : ${SETLANG="env LANG= LC_MESSAGES= LC_ALL= LANGUAGE="} : ${MAKEINFO="makeinfo"} -: ${TEXI2DVI="texi2dvi -t @finalout"} +: ${TEXI2DVI="texi2dvi"} : ${DOCBOOK2HTML="docbook2html"} : ${DOCBOOK2PDF="docbook2pdf"} : ${DOCBOOK2TXT="docbook2txt"} @@ -56,7 +54,7 @@ unset use_texi2html version="gendocs.sh $scriptversion -Copyright 2013 Free Software Foundation, Inc. +Copyright 2015 Free Software Foundation, Inc. There is NO warranty. You may redistribute this software under the terms of the GNU General Public License. For more information about these matters, see the files named COPYING." @@ -75,11 +73,16 @@ Options: -o OUTDIR write files into OUTDIR, instead of manual/. -I DIR append DIR to the Texinfo search path. --common ARG pass ARG in all invocations. - --html ARG pass ARG to makeinfo or texi2html for HTML targets. + --html ARG pass ARG to makeinfo or texi2html for HTML targets, + instead of --css-ref=/software/gnulib/manual.css. --info ARG pass ARG to makeinfo for Info, instead of --no-split. --no-ascii skip generating the plain text output. + --no-html skip generating the html output. + --no-info skip generating the info output. + --no-tex skip generating the dvi and pdf output. --source ARG include ARG in tar archive of sources. --split HOW make split HTML by node, section, chapter; default node. + --tex ARG pass ARG to texi2dvi for DVI and PDF, instead of -t @finalout. --texi2html use texi2html to make HTML target, with all split versions. --docbook convert through DocBook too (xml, txt, html, pdf). @@ -131,7 +134,7 @@ locale, since that's the language of most Texinfo manuals. If you happen to have a non-English manual and non-English web site, see the SETLANG setting in the source. -Email bug reports or enhancement requests to bug-texinfo@gnu.org. +Email bug reports or enhancement requests to bug-gnulib@gnu.org. " MANUAL_TITLE= @@ -139,14 +142,18 @@ PACKAGE= EMAIL=webmasters@gnu.org # please override with --email commonarg= # passed to all makeinfo/texi2html invcations. dirargs= # passed to all tools (-I dir). -dirs= # -I's directories. -htmlarg= +dirs= # -I directories. +htmlarg=--css-ref=/software/gnulib/manual.css infoarg=--no-split generate_ascii=true +generate_html=true +generate_info=true +generate_tex=true outdir=manual source_extra= split=node srcfile= +texarg="-t @finalout" while test $# -gt 0; do case $1 in @@ -159,8 +166,12 @@ while test $# -gt 0; do --html) shift; htmlarg=$1;; --info) shift; infoarg=$1;; --no-ascii) generate_ascii=false;; + --no-html) generate_ascii=false;; + --no-info) generate_info=false;; + --no-tex) generate_tex=false;; --source) shift; source_extra=$1;; --split) shift; split=$1;; + --tex) shift; texarg=$1;; --texi2html) use_texi2html=1;; --help) echo "$usage"; exit 0;; @@ -221,8 +232,9 @@ calcsize() # copy_images OUTDIR HTML-FILE... # ------------------------------- -# Copy all the images needed by the HTML-FILEs into OUTDIR. Look -# for them in the -I directories. +# Copy all the images needed by the HTML-FILEs into OUTDIR. +# Look for them in . and the -I directories; this is simpler than what +# makeinfo supports with -I, but hopefully it will suffice. copy_images() { local odir @@ -232,7 +244,7 @@ copy_images() BEGIN { \$me = '$prog'; \$odir = '$odir'; - @dirs = qw($dirs); + @dirs = qw(. $dirs); } " -e ' /${srcdir}/$PACKAGE-db.xml" @@ -431,7 +457,8 @@ if test -n "$docbook"; then mv $PACKAGE-db.pdf "$outdir/" fi -printf "\nMaking index file...\n" +# +printf "\nMaking index.html for $PACKAGE...\n" if test -z "$use_texi2html"; then CONDS="/%%IF *HTML_SECTION%%/,/%%ENDIF *HTML_SECTION%%/d;\ /%%IF *HTML_CHAPTER%%/,/%%ENDIF *HTML_CHAPTER%%/d" diff --git a/build-aux/git-version-gen b/build-aux/git-version-gen index 1e5d556e9..8e185a9d1 100755 --- a/build-aux/git-version-gen +++ b/build-aux/git-version-gen @@ -1,8 +1,8 @@ #!/bin/sh # Print a version string. -scriptversion=2012-12-31.23; # UTC +scriptversion=2014-12-02.19; # UTC -# Copyright (C) 2007-2014 Free Software Foundation, Inc. +# Copyright (C) 2007-2015 Free Software Foundation, Inc. # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -85,9 +85,10 @@ Print a version string. Options: - --prefix prefix of git tags (default 'v') + --prefix PREFIX prefix of git tags (default 'v') --match pattern for git tags to match (default: '\$prefix*') - --fallback fallback version to use if \"git --version\" fails + --fallback VERSION + fallback version to use if \"git --version\" fails --help display this help and exit --version output version information and exit @@ -220,7 +221,7 @@ if test "x$v_from_git" != x; then fi # Omit the trailing newline, so that m4_esyscmd can use the result directly. -echo "$v" | tr -d "$nl" +printf %s "$v" # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) diff --git a/build-aux/gitlog-to-changelog b/build-aux/gitlog-to-changelog index 78afff4e8..a0e0a05df 100755 --- a/build-aux/gitlog-to-changelog +++ b/build-aux/gitlog-to-changelog @@ -3,13 +3,13 @@ eval '(exit $?0)' && eval 'exec perl -wS "$0" ${1+"$@"}' if 0; # Convert git log output to ChangeLog format. -my $VERSION = '2012-07-29 06:11'; # UTC +my $VERSION = '2015-06-11 01:03'; # UTC # The definition above must lie within the first 8 lines in order # for the Emacs time-stamp write hook (at end) to update it. # If you change this file with Emacs, please let the write hook # do its job. Otherwise, update this string manually. -# Copyright (C) 2008-2014 Free Software Foundation, Inc. +# Copyright (C) 2008-2015 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -72,6 +72,9 @@ OPTIONS: directory can be derived. --since=DATE convert only the logs since DATE; the default is to convert all log entries. + --until=DATE convert only the logs older than DATE. + --ignore-matching=PAT ignore commit messages whose first lines match PAT. + --ignore-line=PAT ignore lines of commit messages that match PAT. --format=FMT set format string for commit subject and body; see 'man git-log' for the list of format metacharacters; the default is '%s%n%b%n' @@ -220,10 +223,13 @@ sub git_dir_option($) { my $since_date; + my $until_date; my $format_string = '%s%n%b%n'; my $amend_file; my $append_dot = 0; my $cluster = 1; + my $ignore_matching; + my $ignore_line; my $strip_tab = 0; my $strip_cherry_pick = 0; my $srcdir; @@ -232,10 +238,13 @@ sub git_dir_option($) help => sub { usage 0 }, version => sub { print "$ME version $VERSION\n"; exit }, 'since=s' => \$since_date, + 'until=s' => \$until_date, 'format=s' => \$format_string, 'amend=s' => \$amend_file, 'append-dot' => \$append_dot, 'cluster!' => \$cluster, + 'ignore-matching=s' => \$ignore_matching, + 'ignore-line=s' => \$ignore_line, 'strip-tab' => \$strip_tab, 'strip-cherry-pick' => \$strip_cherry_pick, 'srcdir=s' => \$srcdir, @@ -243,6 +252,8 @@ sub git_dir_option($) defined $since_date and unshift @ARGV, "--since=$since_date"; + defined $until_date + and unshift @ARGV, "--until=$until_date"; # This is a hash that maps an SHA1 to perl code (i.e., s/old/new/) # that makes a correction in the log or attribution of that commit. @@ -259,6 +270,7 @@ sub git_dir_option($) my $prev_multi_paragraph; my $prev_date_line = ''; my @prev_coauthors = (); + my @skipshas = (); while (1) { defined (my $in = ) @@ -279,6 +291,21 @@ sub git_dir_option($) $sha =~ /^[0-9a-fA-F]{40}$/ or die "$ME:$.: invalid SHA1: $sha\n"; + my $skipflag = 0; + if (@skipshas) + { + foreach(@skipshas) + { + if ($sha =~ /^$_/) + { + $skipflag = 1; + ## Perhaps only warn if a pattern matches more than once? + warn "$ME: warning: skipping $sha due to $_\n"; + last; + } + } + } + # If this commit's log requires any transformation, do it now. my $code = $amend_code->{$sha}; if (defined $code) @@ -306,7 +333,7 @@ sub git_dir_option($) $rest =~ s/^\s*\(cherry picked from commit [\da-f]+\)\n//m; } - my @line = split "\n", $rest; + my @line = split /[ \t]*\n/, $rest; my $author_line = shift @line; defined $author_line or die "$ME:$.: unexpected EOF\n"; @@ -316,17 +343,18 @@ sub git_dir_option($) # Format 'Copyright-paperwork-exempt: Yes' as a standard ChangeLog # `(tiny change)' annotation. - my $tiny = (grep (/^Copyright-paperwork-exempt:\s+[Yy]es$/, @line) + my $tiny = (grep (/^(?:Copyright-paperwork-exempt|Tiny-change):\s+[Yy]es$/, @line) ? ' (tiny change)' : ''); my $date_line = sprintf "%s %s$tiny\n", - strftime ("%F", localtime ($1)), $2; + strftime ("%Y-%m-%d", localtime ($1)), $2; my @coauthors = grep /^Co-authored-by:.*$/, @line; # Omit meta-data lines we've already interpreted. @line = grep !/^(?:Signed-off-by:[ ].*>$ |Co-authored-by:[ ] |Copyright-paperwork-exempt:[ ] + |Tiny-change:[ ] )/x, @line; # Remove leading and trailing blank lines. @@ -336,68 +364,100 @@ sub git_dir_option($) while ($line[$#line] =~ /^\s*$/) { pop @line; } } - # Record whether there are two or more paragraphs. - my $multi_paragraph = grep /^\s*$/, @line; + # Handle Emacs gitmerge.el "skipped" commits. + # Yes, this should be controlled by an option. So sue me. + if ( grep /^(; )?Merge from /, @line ) + { + my $found = 0; + foreach (@line) + { + if (grep /^The following commit.*skipped:$/, $_) + { + $found = 1; + ## Reset at each merge to reduce chance of false matches. + @skipshas = (); + next; + } + if ($found && $_ =~ /^([0-9a-fA-F]{7,}) [^ ]/) + { + push ( @skipshas, $1 ); + } + } + } - # Format 'Co-authored-by: A U Thor ' lines in - # standard multi-author ChangeLog format. - for (@coauthors) + # Ignore commits that match the --ignore-matching pattern, if specified. + if (! ($skipflag || (defined $ignore_matching + && @line && $line[0] =~ /$ignore_matching/))) { - s/^Co-authored-by:\s*/\t /; - s/\s*/ - or warn "$ME: warning: missing email address for " - . substr ($_, 5) . "\n"; - } - - # If clustering of commit messages has been disabled, if this header - # would be different from the previous date/name/email/coauthors header, - # or if this or the previous entry consists of two or more paragraphs, - # then print the header. - if ( ! $cluster - || $date_line ne $prev_date_line - || "@coauthors" ne "@prev_coauthors" - || $multi_paragraph - || $prev_multi_paragraph) - { - $prev_date_line eq '' - or print "\n"; - print $date_line; - @coauthors - and print join ("\n", @coauthors), "\n"; - } - $prev_date_line = $date_line; - @prev_coauthors = @coauthors; - $prev_multi_paragraph = $multi_paragraph; - - # If there were any lines - if (@line == 0) - { - warn "$ME: warning: empty commit message:\n $date_line\n"; - } - else - { - if ($append_dot) + if (defined $ignore_line && @line) { - # If the first line of the message has enough room, then - if (length $line[0] < 72) - { - # append a dot if there is no other punctuation or blank - # at the end. - $line[0] =~ /[[:punct:]\s]$/ - or $line[0] .= '.'; - } + @line = grep ! /$ignore_line/, @line; + while ($line[$#line] =~ /^\s*$/) { pop @line; } } - # Remove one additional leading TAB from each line. - $strip_tab - and map { s/^\t// } @line; + # Record whether there are two or more paragraphs. + my $multi_paragraph = grep /^\s*$/, @line; - # Prefix each non-empty line with a TAB. - @line = map { length $_ ? "\t$_" : '' } @line; + # Format 'Co-authored-by: A U Thor ' lines in + # standard multi-author ChangeLog format. + for (@coauthors) + { + s/^Co-authored-by:\s*/\t /; + s/\s*/ + or warn "$ME: warning: missing email address for " + . substr ($_, 5) . "\n"; + } + + # If clustering of commit messages has been disabled, if this header + # would be different from the previous date/name/etc. header, + # or if this or the previous entry consists of two or more paragraphs, + # then print the header. + if ( ! $cluster + || $date_line ne $prev_date_line + || "@coauthors" ne "@prev_coauthors" + || $multi_paragraph + || $prev_multi_paragraph) + { + $prev_date_line eq '' + or print "\n"; + print $date_line; + @coauthors + and print join ("\n", @coauthors), "\n"; + } + $prev_date_line = $date_line; + @prev_coauthors = @coauthors; + $prev_multi_paragraph = $multi_paragraph; + + # If there were any lines + if (@line == 0) + { + warn "$ME: warning: empty commit message:\n $date_line\n"; + } + else + { + if ($append_dot) + { + # If the first line of the message has enough room, then + if (length $line[0] < 72) + { + # append a dot if there is no other punctuation or blank + # at the end. + $line[0] =~ /[[:punct:]\s]$/ + or $line[0] .= '.'; + } + } + + # Remove one additional leading TAB from each line. + $strip_tab + and map { s/^\t// } @line; + + # Prefix each non-empty line with a TAB. + @line = map { length $_ ? "\t$_" : '' } @line; + + print "\n", join ("\n", @line), "\n"; + } } defined ($in = ) diff --git a/build-aux/gnu-web-doc-update b/build-aux/gnu-web-doc-update index 7af2f185f..c8fc7e5de 100755 --- a/build-aux/gnu-web-doc-update +++ b/build-aux/gnu-web-doc-update @@ -2,9 +2,9 @@ # Run this after each non-alpha release, to update the web documentation at # http://www.gnu.org/software/$pkg/manual/ -VERSION=2012-12-16.14; # UTC +VERSION=2015-06-16.06; # UTC -# Copyright (C) 2009-2014 Free Software Foundation, Inc. +# Copyright (C) 2009-2015 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -40,6 +40,7 @@ assumes all documentation is in the doc/ sub-directory. Options: -C, --builddir=DIR location of (configured) Makefile (default: .) -n, --dry-run don't actually commit anything + -m, --mirror remove out of date files from document server --help print this help, then exit --version print version number, then exit @@ -107,6 +108,7 @@ find_tool XARGS gxargs xargs builddir=. dryrun= +rm_stale='echo' while test $# != 0 do # Handle --option=value by splitting apart and putting back on argv. @@ -123,6 +125,7 @@ do --help|--version) ${1#--};; -C|--builddir) shift; builddir=$1; shift ;; -n|--dry-run) dryrun=echo; shift;; + -m|--mirror) rm_stale=''; shift;; --*) die "unrecognized option: $1";; *) break;; esac @@ -159,6 +162,7 @@ $GIT submodule update --recursive ./bootstrap srcdir=$(pwd) cd "$builddir" +builddir=$(pwd) ./config.status --recheck ./config.status make @@ -182,6 +186,17 @@ $RSYNC -avP "$builddir"/doc/manual/ $tmp/$pkg/manual find . -name CVS -prune -o -print \ | $XARGS --no-run-if-empty -- $dryrun $CVS add -ko + # Report/Remove stale files + # excluding doc server specific files like CVS/* and .symlinks + if test -n "$rm_stale"; then + echo 'Consider the --mirror option if all of the manual is generated,' >&2 + echo 'which will run `cvs remove` to remove stale files.' >&2 + fi + { find . \( -name CVS -o -type f -name '.*' \) -prune -o -type f -print + (cd "$builddir"/doc/manual/ && find . -type f -print | sed p) + } | sort | uniq -u \ + | $XARGS --no-run-if-empty -- ${rm_stale:-$dryrun} $CVS remove -f + $dryrun $CVS ci -m $version ) diff --git a/build-aux/gnupload b/build-aux/gnupload index 2da97d894..f87c195dc 100755 --- a/build-aux/gnupload +++ b/build-aux/gnupload @@ -3,7 +3,7 @@ scriptversion=2013-03-19.17; # UTC -# Copyright (C) 2004-2014 Free Software Foundation, Inc. +# Copyright (C) 2004-2015 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/build-aux/snippet/arg-nonnull.h b/build-aux/snippet/arg-nonnull.h index 9ee8b1555..0d55e2bce 100644 --- a/build-aux/snippet/arg-nonnull.h +++ b/build-aux/snippet/arg-nonnull.h @@ -1,5 +1,5 @@ /* A C macro for declaring that specific arguments must not be NULL. - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published diff --git a/build-aux/snippet/c++defs.h b/build-aux/snippet/c++defs.h index 67b12335d..585b38ab3 100644 --- a/build-aux/snippet/c++defs.h +++ b/build-aux/snippet/c++defs.h @@ -1,5 +1,5 @@ /* C++ compatible function declaration macros. - Copyright (C) 2010-2014 Free Software Foundation, Inc. + Copyright (C) 2010-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published diff --git a/build-aux/snippet/unused-parameter.h b/build-aux/snippet/unused-parameter.h index 41d9510ca..f507eb745 100644 --- a/build-aux/snippet/unused-parameter.h +++ b/build-aux/snippet/unused-parameter.h @@ -1,5 +1,5 @@ /* A C macro for declaring that specific function parameters are not used. - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published diff --git a/build-aux/snippet/warn-on-use.h b/build-aux/snippet/warn-on-use.h index 1c4d7bd4e..90f4985ce 100644 --- a/build-aux/snippet/warn-on-use.h +++ b/build-aux/snippet/warn-on-use.h @@ -1,5 +1,5 @@ /* A C macro for emitting warnings if a function is used. - Copyright (C) 2010-2014 Free Software Foundation, Inc. + Copyright (C) 2010-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published diff --git a/build-aux/useless-if-before-free b/build-aux/useless-if-before-free index 4c76c75d7..82a09b39e 100755 --- a/build-aux/useless-if-before-free +++ b/build-aux/useless-if-before-free @@ -10,7 +10,7 @@ my $VERSION = '2012-01-06 07:23'; # UTC # If you change this file with Emacs, please let the write hook # do its job. Otherwise, update this string manually. -# Copyright (C) 2008-2014 Free Software Foundation, Inc. +# Copyright (C) 2008-2015 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/build-aux/vc-list-files b/build-aux/vc-list-files index b2bca54c9..3bf93c3c0 100755 --- a/build-aux/vc-list-files +++ b/build-aux/vc-list-files @@ -4,7 +4,7 @@ # Print a version string. scriptversion=2011-05-16.22; # UTC -# Copyright (C) 2006-2014 Free Software Foundation, Inc. +# Copyright (C) 2006-2015 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/doc/gendocs_template b/doc/gendocs_template index 4836df787..df7faa3d3 100644 --- a/doc/gendocs_template +++ b/doc/gendocs_template @@ -1,5 +1,6 @@ -%%TITLE%% - GNU Project - Free Software Foundation (FSF) + +%%TITLE%% - GNU Project - Free Software Foundation

%%TITLE%%

@@ -67,19 +68,22 @@ script.)

diff --git a/gnulib-local/build-aux/git-version-gen.diff b/gnulib-local/build-aux/git-version-gen.diff index f875f49d9..e15acf336 100644 --- a/gnulib-local/build-aux/git-version-gen.diff +++ b/gnulib-local/build-aux/git-version-gen.diff @@ -4,15 +4,15 @@ Remove when integrated in Gnulib. --- a/build-aux/git-version-gen +++ b/build-aux/git-version-gen -@@ -86,6 +86,7 @@ Print a version string. +@@ -86,6 +86,7 @@ Options: - --prefix prefix of git tags (default 'v') + --prefix PREFIX prefix of git tags (default 'v') + --match pattern for git tags to match (default: '\$prefix*') - --fallback fallback version to use if \"git --version\" fails + --fallback VERSION + fallback version to use if \"git --version\" fails - --help display this help and exit -@@ -96,11 +97,15 @@ Running without arguments will suffice in most cases." +@@ -97,11 +98,15 @@ prefix=v fallback= @@ -28,7 +28,7 @@ Remove when integrated in Gnulib. --fallback) shift; fallback="$1";; -*) echo "$0: Unknown option '$1'." >&2 -@@ -124,6 +129,7 @@ if test "x$tarball_version_file" = x; then +@@ -125,6 +130,7 @@ exit 1 fi @@ -36,7 +36,7 @@ Remove when integrated in Gnulib. tag_sed_script="${tag_sed_script:-s/x/x/}" nl=' -@@ -154,7 +160,7 @@ then +@@ -155,7 +161,7 @@ # directory, and "git describe" output looks sensible, use that to # derive a version string. elif test "`git log -1 --pretty=format:x . 2>&1`" = x \ diff --git a/lib/Makefile.am b/lib/Makefile.am index 5d9c902fc..e5a4aed8b 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -1,6 +1,6 @@ ## DO NOT EDIT! GENERATED AUTOMATICALLY! ## Process this file with automake to produce Makefile.in. -# Copyright (C) 2002-2014 Free Software Foundation, Inc. +# Copyright (C) 2002-2015 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -176,6 +176,13 @@ EXTRA_DIST += arpa_inet.in.h ## end gnulib module arpa_inet +## begin gnulib module assure + + +EXTRA_DIST += assure.h + +## end gnulib module assure + ## begin gnulib module binary-io libgnu_la_SOURCES += binary-io.h binary-io.c @@ -699,6 +706,9 @@ EXTRA_DIST += $(top_srcdir)/build-aux/gnupload ## begin gnulib module gperf GPERF = gperf +V_GPERF = $(V_GPERF_@AM_V@) +V_GPERF_ = $(V_GPERF_@AM_DEFAULT_V@) +V_GPERF_0 = @echo " GPERF " $@; ## end gnulib module gperf @@ -748,19 +758,19 @@ EXTRA_DIST += iconv.in.h ## begin gnulib module iconv_open iconv_open-aix.h: iconv_open-aix.gperf - $(GPERF) -m 10 $(srcdir)/iconv_open-aix.gperf > $(srcdir)/iconv_open-aix.h-t + $(V_GPERF)$(GPERF) -m 10 $(srcdir)/iconv_open-aix.gperf > $(srcdir)/iconv_open-aix.h-t && \ mv $(srcdir)/iconv_open-aix.h-t $(srcdir)/iconv_open-aix.h iconv_open-hpux.h: iconv_open-hpux.gperf - $(GPERF) -m 10 $(srcdir)/iconv_open-hpux.gperf > $(srcdir)/iconv_open-hpux.h-t + $(V_GPERF)$(GPERF) -m 10 $(srcdir)/iconv_open-hpux.gperf > $(srcdir)/iconv_open-hpux.h-t && \ mv $(srcdir)/iconv_open-hpux.h-t $(srcdir)/iconv_open-hpux.h iconv_open-irix.h: iconv_open-irix.gperf - $(GPERF) -m 10 $(srcdir)/iconv_open-irix.gperf > $(srcdir)/iconv_open-irix.h-t + $(V_GPERF)$(GPERF) -m 10 $(srcdir)/iconv_open-irix.gperf > $(srcdir)/iconv_open-irix.h-t && \ mv $(srcdir)/iconv_open-irix.h-t $(srcdir)/iconv_open-irix.h iconv_open-osf.h: iconv_open-osf.gperf - $(GPERF) -m 10 $(srcdir)/iconv_open-osf.gperf > $(srcdir)/iconv_open-osf.h-t + $(V_GPERF)$(GPERF) -m 10 $(srcdir)/iconv_open-osf.gperf > $(srcdir)/iconv_open-osf.h-t && \ mv $(srcdir)/iconv_open-osf.h-t $(srcdir)/iconv_open-osf.h iconv_open-solaris.h: iconv_open-solaris.gperf - $(GPERF) -m 10 $(srcdir)/iconv_open-solaris.gperf > $(srcdir)/iconv_open-solaris.h-t + $(V_GPERF)$(GPERF) -m 10 $(srcdir)/iconv_open-solaris.gperf > $(srcdir)/iconv_open-solaris.h-t && \ mv $(srcdir)/iconv_open-solaris.h-t $(srcdir)/iconv_open-solaris.h BUILT_SOURCES += iconv_open-aix.h iconv_open-hpux.h iconv_open-irix.h iconv_open-osf.h iconv_open-solaris.h MOSTLYCLEANFILES += iconv_open-aix.h-t iconv_open-hpux.h-t iconv_open-irix.h-t iconv_open-osf.h-t iconv_open-solaris.h-t @@ -1446,6 +1456,24 @@ EXTRA_libgnu_la_SOURCES += mkstemp.c ## end gnulib module mkstemp +## begin gnulib module mktime + + +EXTRA_DIST += mktime-internal.h mktime.c + +EXTRA_libgnu_la_SOURCES += mktime.c + +## end gnulib module mktime + +## begin gnulib module mktime-internal + + +EXTRA_DIST += mktime-internal.h mktime.c + +EXTRA_libgnu_la_SOURCES += mktime.c + +## end gnulib module mktime-internal + ## begin gnulib module msvc-inval @@ -2060,6 +2088,7 @@ stddef.h: stddef.in.h $(top_builddir)/config.status -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \ -e 's|@''PRAGMA_COLUMNS''@|@PRAGMA_COLUMNS@|g' \ -e 's|@''NEXT_STDDEF_H''@|$(NEXT_STDDEF_H)|g' \ + -e 's|@''HAVE_MAX_ALIGN_T''@|$(HAVE_MAX_ALIGN_T)|g' \ -e 's|@''HAVE_WCHAR_T''@|$(HAVE_WCHAR_T)|g' \ -e 's|@''REPLACE_NULL''@|$(REPLACE_NULL)|g' \ < $(srcdir)/stddef.in.h; \ @@ -2286,6 +2315,7 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \ -e 's/@''GNULIB_PTSNAME''@/$(GNULIB_PTSNAME)/g' \ -e 's/@''GNULIB_PTSNAME_R''@/$(GNULIB_PTSNAME_R)/g' \ -e 's/@''GNULIB_PUTENV''@/$(GNULIB_PUTENV)/g' \ + -e 's/@''GNULIB_QSORT_R''@/$(GNULIB_QSORT_R)/g' \ -e 's/@''GNULIB_RANDOM''@/$(GNULIB_RANDOM)/g' \ -e 's/@''GNULIB_RANDOM_R''@/$(GNULIB_RANDOM_R)/g' \ -e 's/@''GNULIB_REALLOC_POSIX''@/$(GNULIB_REALLOC_POSIX)/g' \ @@ -2337,6 +2367,7 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \ -e 's|@''REPLACE_PTSNAME''@|$(REPLACE_PTSNAME)|g' \ -e 's|@''REPLACE_PTSNAME_R''@|$(REPLACE_PTSNAME_R)|g' \ -e 's|@''REPLACE_PUTENV''@|$(REPLACE_PUTENV)|g' \ + -e 's|@''REPLACE_QSORT_R''@|$(REPLACE_QSORT_R)|g' \ -e 's|@''REPLACE_RANDOM_R''@|$(REPLACE_RANDOM_R)|g' \ -e 's|@''REPLACE_REALLOC''@|$(REPLACE_REALLOC)|g' \ -e 's|@''REPLACE_REALPATH''@|$(REPLACE_REALPATH)|g' \ @@ -2812,10 +2843,12 @@ time.h: time.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $( -e 's/@''GNULIB_STRPTIME''@/$(GNULIB_STRPTIME)/g' \ -e 's/@''GNULIB_TIMEGM''@/$(GNULIB_TIMEGM)/g' \ -e 's/@''GNULIB_TIME_R''@/$(GNULIB_TIME_R)/g' \ + -e 's/@''GNULIB_TIME_RZ''@/$(GNULIB_TIME_RZ)/g' \ -e 's|@''HAVE_DECL_LOCALTIME_R''@|$(HAVE_DECL_LOCALTIME_R)|g' \ -e 's|@''HAVE_NANOSLEEP''@|$(HAVE_NANOSLEEP)|g' \ -e 's|@''HAVE_STRPTIME''@|$(HAVE_STRPTIME)|g' \ -e 's|@''HAVE_TIMEGM''@|$(HAVE_TIMEGM)|g' \ + -e 's|@''HAVE_TIMEZONE_T''@|$(HAVE_TIMEZONE_T)|g' \ -e 's|@''REPLACE_GMTIME''@|$(REPLACE_GMTIME)|g' \ -e 's|@''REPLACE_LOCALTIME''@|$(REPLACE_LOCALTIME)|g' \ -e 's|@''REPLACE_LOCALTIME_R''@|$(REPLACE_LOCALTIME_R)|g' \ @@ -2825,6 +2858,7 @@ time.h: time.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $( -e 's|@''PTHREAD_H_DEFINES_STRUCT_TIMESPEC''@|$(PTHREAD_H_DEFINES_STRUCT_TIMESPEC)|g' \ -e 's|@''SYS_TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(SYS_TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \ -e 's|@''TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \ + -e 's|@''UNISTD_H_DEFINES_STRUCT_TIMESPEC''@|$(UNISTD_H_DEFINES_STRUCT_TIMESPEC)|g' \ -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \ -e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \ -e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \ @@ -2846,6 +2880,24 @@ EXTRA_libgnu_la_SOURCES += time_r.c ## end gnulib module time_r +## begin gnulib module time_rz + + +EXTRA_DIST += time-internal.h time_rz.c + +EXTRA_libgnu_la_SOURCES += time_rz.c + +## end gnulib module time_rz + +## begin gnulib module timegm + + +EXTRA_DIST += mktime-internal.h timegm.c + +EXTRA_libgnu_la_SOURCES += timegm.c + +## end gnulib module timegm + ## begin gnulib module times @@ -2995,9 +3047,11 @@ unistd.h: unistd.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H -e 's|@''REPLACE_PWRITE''@|$(REPLACE_PWRITE)|g' \ -e 's|@''REPLACE_READ''@|$(REPLACE_READ)|g' \ -e 's|@''REPLACE_READLINK''@|$(REPLACE_READLINK)|g' \ + -e 's|@''REPLACE_READLINKAT''@|$(REPLACE_READLINKAT)|g' \ -e 's|@''REPLACE_RMDIR''@|$(REPLACE_RMDIR)|g' \ -e 's|@''REPLACE_SLEEP''@|$(REPLACE_SLEEP)|g' \ -e 's|@''REPLACE_SYMLINK''@|$(REPLACE_SYMLINK)|g' \ + -e 's|@''REPLACE_SYMLINKAT''@|$(REPLACE_SYMLINKAT)|g' \ -e 's|@''REPLACE_TTYNAME_R''@|$(REPLACE_TTYNAME_R)|g' \ -e 's|@''REPLACE_UNLINK''@|$(REPLACE_UNLINK)|g' \ -e 's|@''REPLACE_UNLINKAT''@|$(REPLACE_UNLINKAT)|g' \ @@ -3088,6 +3142,15 @@ EXTRA_DIST += unitypes.in.h ## end gnulib module unitypes +## begin gnulib module unsetenv + + +EXTRA_DIST += unsetenv.c + +EXTRA_libgnu_la_SOURCES += unsetenv.c + +## end gnulib module unsetenv + ## begin gnulib module useless-if-before-free diff --git a/lib/accept.c b/lib/accept.c index b216c6bd6..441c065db 100644 --- a/lib/accept.c +++ b/lib/accept.c @@ -1,6 +1,6 @@ /* accept.c --- wrappers for Windows accept function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/alignof.h b/lib/alignof.h index 280f3e384..713f3bd89 100644 --- a/lib/alignof.h +++ b/lib/alignof.h @@ -1,5 +1,5 @@ /* Determine alignment of types. - Copyright (C) 2003-2004, 2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2003-2004, 2006, 2009-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/alloca.in.h b/lib/alloca.in.h index e3aa62d2d..dc1b55060 100644 --- a/lib/alloca.in.h +++ b/lib/alloca.in.h @@ -1,6 +1,6 @@ /* Memory allocation on the stack. - Copyright (C) 1995, 1999, 2001-2004, 2006-2014 Free Software Foundation, + Copyright (C) 1995, 1999, 2001-2004, 2006-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it diff --git a/lib/arpa_inet.in.h b/lib/arpa_inet.in.h index 3f5df4776..6ad528cc6 100644 --- a/lib/arpa_inet.in.h +++ b/lib/arpa_inet.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 2005-2006, 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2005-2006, 2008-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/asnprintf.c b/lib/asnprintf.c index 7806f6888..413b8d763 100644 --- a/lib/asnprintf.c +++ b/lib/asnprintf.c @@ -1,5 +1,5 @@ /* Formatted output to strings. - Copyright (C) 1999, 2002, 2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 1999, 2002, 2006, 2009-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/assure.h b/lib/assure.h new file mode 100644 index 000000000..867688e01 --- /dev/null +++ b/lib/assure.h @@ -0,0 +1,37 @@ +/* Run-time assert-like macros. + + Copyright (C) 2014-2015 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +/* Written by Paul Eggert. */ + +#ifndef _GL_ASSURE_H +#define _GL_ASSURE_H + +#include + +/* Check E's value at runtime, and report an error and abort if not. + However, do nothng if NDEBUG is defined. + + Unlike standard 'assert', this macro always compiles E even when NDEBUG + is defined, so as to catch typos and avoid some GCC warnings. */ + +#ifdef NDEBUG +# define assure(E) ((void) (0 && (E))) +#else +# define assure(E) assert (E) +#endif + +#endif diff --git a/lib/basename-lgpl.c b/lib/basename-lgpl.c index fe007936f..12d1e522b 100644 --- a/lib/basename-lgpl.c +++ b/lib/basename-lgpl.c @@ -1,6 +1,6 @@ /* basename.c -- return the last element in a file name - Copyright (C) 1990, 1998-2001, 2003-2006, 2009-2014 Free Software + Copyright (C) 1990, 1998-2001, 2003-2006, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/binary-io.c b/lib/binary-io.c index 8bbdb44d1..d828bcd01 100644 --- a/lib/binary-io.c +++ b/lib/binary-io.c @@ -1,3 +1,4 @@ #include #define BINARY_IO_INLINE _GL_EXTERN_INLINE #include "binary-io.h" +typedef int dummy; diff --git a/lib/binary-io.h b/lib/binary-io.h index c276faa88..1a87e8f3b 100644 --- a/lib/binary-io.h +++ b/lib/binary-io.h @@ -1,5 +1,5 @@ /* Binary mode I/O. - Copyright (C) 2001, 2003, 2005, 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2001, 2003, 2005, 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/bind.c b/lib/bind.c index 36750c9a8..72263cc1b 100644 --- a/lib/bind.c +++ b/lib/bind.c @@ -1,6 +1,6 @@ /* bind.c --- wrappers for Windows bind function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/btowc.c b/lib/btowc.c index aad27f593..01e80c50a 100644 --- a/lib/btowc.c +++ b/lib/btowc.c @@ -1,5 +1,5 @@ /* Convert unibyte character to wide character. - Copyright (C) 2008, 2010-2014 Free Software Foundation, Inc. + Copyright (C) 2008, 2010-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2008. This program is free software: you can redistribute it and/or modify diff --git a/lib/byteswap.in.h b/lib/byteswap.in.h index 130c79dfb..673c53b25 100644 --- a/lib/byteswap.in.h +++ b/lib/byteswap.in.h @@ -1,5 +1,5 @@ /* byteswap.h - Byte swapping - Copyright (C) 2005, 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2005, 2007, 2009-2015 Free Software Foundation, Inc. Written by Oskar Liljeblad , 2005. This program is free software: you can redistribute it and/or modify diff --git a/lib/c-ctype.c b/lib/c-ctype.c index 7fe3f7efa..5d9d4d87a 100644 --- a/lib/c-ctype.c +++ b/lib/c-ctype.c @@ -1,395 +1,3 @@ -/* Character handling in C locale. - - Copyright 2000-2003, 2006, 2009-2014 Free Software Foundation, Inc. - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public License -along with this program; if not, see . */ - #include - -/* Specification. */ -#define NO_C_CTYPE_MACROS +#define C_CTYPE_INLINE _GL_EXTERN_INLINE #include "c-ctype.h" - -/* The function isascii is not locale dependent. Its use in EBCDIC is - questionable. */ -bool -c_isascii (int c) -{ - return (c >= 0x00 && c <= 0x7f); -} - -bool -c_isalnum (int c) -{ -#if C_CTYPE_CONSECUTIVE_DIGITS \ - && C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE -#if C_CTYPE_ASCII - return ((c >= '0' && c <= '9') - || ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'Z')); -#else - return ((c >= '0' && c <= '9') - || (c >= 'A' && c <= 'Z') - || (c >= 'a' && c <= 'z')); -#endif -#else - switch (c) - { - case '0': case '1': case '2': case '3': case '4': case '5': - case '6': case '7': case '8': case '9': - case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': - case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': - case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': - case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': - case 'Y': case 'Z': - case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': - case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': - case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': - case 's': case 't': case 'u': case 'v': case 'w': case 'x': - case 'y': case 'z': - return 1; - default: - return 0; - } -#endif -} - -bool -c_isalpha (int c) -{ -#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE -#if C_CTYPE_ASCII - return ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'Z'); -#else - return ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')); -#endif -#else - switch (c) - { - case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': - case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': - case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': - case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': - case 'Y': case 'Z': - case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': - case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': - case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': - case 's': case 't': case 'u': case 'v': case 'w': case 'x': - case 'y': case 'z': - return 1; - default: - return 0; - } -#endif -} - -bool -c_isblank (int c) -{ - return (c == ' ' || c == '\t'); -} - -bool -c_iscntrl (int c) -{ -#if C_CTYPE_ASCII - return ((c & ~0x1f) == 0 || c == 0x7f); -#else - switch (c) - { - case ' ': case '!': case '"': case '#': case '$': case '%': - case '&': case '\'': case '(': case ')': case '*': case '+': - case ',': case '-': case '.': case '/': - case '0': case '1': case '2': case '3': case '4': case '5': - case '6': case '7': case '8': case '9': - case ':': case ';': case '<': case '=': case '>': case '?': - case '@': - case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': - case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': - case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': - case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': - case 'Y': case 'Z': - case '[': case '\\': case ']': case '^': case '_': case '`': - case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': - case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': - case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': - case 's': case 't': case 'u': case 'v': case 'w': case 'x': - case 'y': case 'z': - case '{': case '|': case '}': case '~': - return 0; - default: - return 1; - } -#endif -} - -bool -c_isdigit (int c) -{ -#if C_CTYPE_CONSECUTIVE_DIGITS - return (c >= '0' && c <= '9'); -#else - switch (c) - { - case '0': case '1': case '2': case '3': case '4': case '5': - case '6': case '7': case '8': case '9': - return 1; - default: - return 0; - } -#endif -} - -bool -c_islower (int c) -{ -#if C_CTYPE_CONSECUTIVE_LOWERCASE - return (c >= 'a' && c <= 'z'); -#else - switch (c) - { - case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': - case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': - case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': - case 's': case 't': case 'u': case 'v': case 'w': case 'x': - case 'y': case 'z': - return 1; - default: - return 0; - } -#endif -} - -bool -c_isgraph (int c) -{ -#if C_CTYPE_ASCII - return (c >= '!' && c <= '~'); -#else - switch (c) - { - case '!': case '"': case '#': case '$': case '%': case '&': - case '\'': case '(': case ')': case '*': case '+': case ',': - case '-': case '.': case '/': - case '0': case '1': case '2': case '3': case '4': case '5': - case '6': case '7': case '8': case '9': - case ':': case ';': case '<': case '=': case '>': case '?': - case '@': - case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': - case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': - case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': - case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': - case 'Y': case 'Z': - case '[': case '\\': case ']': case '^': case '_': case '`': - case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': - case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': - case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': - case 's': case 't': case 'u': case 'v': case 'w': case 'x': - case 'y': case 'z': - case '{': case '|': case '}': case '~': - return 1; - default: - return 0; - } -#endif -} - -bool -c_isprint (int c) -{ -#if C_CTYPE_ASCII - return (c >= ' ' && c <= '~'); -#else - switch (c) - { - case ' ': case '!': case '"': case '#': case '$': case '%': - case '&': case '\'': case '(': case ')': case '*': case '+': - case ',': case '-': case '.': case '/': - case '0': case '1': case '2': case '3': case '4': case '5': - case '6': case '7': case '8': case '9': - case ':': case ';': case '<': case '=': case '>': case '?': - case '@': - case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': - case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': - case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': - case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': - case 'Y': case 'Z': - case '[': case '\\': case ']': case '^': case '_': case '`': - case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': - case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': - case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': - case 's': case 't': case 'u': case 'v': case 'w': case 'x': - case 'y': case 'z': - case '{': case '|': case '}': case '~': - return 1; - default: - return 0; - } -#endif -} - -bool -c_ispunct (int c) -{ -#if C_CTYPE_ASCII - return ((c >= '!' && c <= '~') - && !((c >= '0' && c <= '9') - || ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'Z'))); -#else - switch (c) - { - case '!': case '"': case '#': case '$': case '%': case '&': - case '\'': case '(': case ')': case '*': case '+': case ',': - case '-': case '.': case '/': - case ':': case ';': case '<': case '=': case '>': case '?': - case '@': - case '[': case '\\': case ']': case '^': case '_': case '`': - case '{': case '|': case '}': case '~': - return 1; - default: - return 0; - } -#endif -} - -bool -c_isspace (int c) -{ - return (c == ' ' || c == '\t' - || c == '\n' || c == '\v' || c == '\f' || c == '\r'); -} - -bool -c_isupper (int c) -{ -#if C_CTYPE_CONSECUTIVE_UPPERCASE - return (c >= 'A' && c <= 'Z'); -#else - switch (c) - { - case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': - case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': - case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': - case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': - case 'Y': case 'Z': - return 1; - default: - return 0; - } -#endif -} - -bool -c_isxdigit (int c) -{ -#if C_CTYPE_CONSECUTIVE_DIGITS \ - && C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE -#if C_CTYPE_ASCII - return ((c >= '0' && c <= '9') - || ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'F')); -#else - return ((c >= '0' && c <= '9') - || (c >= 'A' && c <= 'F') - || (c >= 'a' && c <= 'f')); -#endif -#else - switch (c) - { - case '0': case '1': case '2': case '3': case '4': case '5': - case '6': case '7': case '8': case '9': - case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': - case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': - return 1; - default: - return 0; - } -#endif -} - -int -c_tolower (int c) -{ -#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE - return (c >= 'A' && c <= 'Z' ? c - 'A' + 'a' : c); -#else - switch (c) - { - case 'A': return 'a'; - case 'B': return 'b'; - case 'C': return 'c'; - case 'D': return 'd'; - case 'E': return 'e'; - case 'F': return 'f'; - case 'G': return 'g'; - case 'H': return 'h'; - case 'I': return 'i'; - case 'J': return 'j'; - case 'K': return 'k'; - case 'L': return 'l'; - case 'M': return 'm'; - case 'N': return 'n'; - case 'O': return 'o'; - case 'P': return 'p'; - case 'Q': return 'q'; - case 'R': return 'r'; - case 'S': return 's'; - case 'T': return 't'; - case 'U': return 'u'; - case 'V': return 'v'; - case 'W': return 'w'; - case 'X': return 'x'; - case 'Y': return 'y'; - case 'Z': return 'z'; - default: return c; - } -#endif -} - -int -c_toupper (int c) -{ -#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE - return (c >= 'a' && c <= 'z' ? c - 'a' + 'A' : c); -#else - switch (c) - { - case 'a': return 'A'; - case 'b': return 'B'; - case 'c': return 'C'; - case 'd': return 'D'; - case 'e': return 'E'; - case 'f': return 'F'; - case 'g': return 'G'; - case 'h': return 'H'; - case 'i': return 'I'; - case 'j': return 'J'; - case 'k': return 'K'; - case 'l': return 'L'; - case 'm': return 'M'; - case 'n': return 'N'; - case 'o': return 'O'; - case 'p': return 'P'; - case 'q': return 'Q'; - case 'r': return 'R'; - case 's': return 'S'; - case 't': return 'T'; - case 'u': return 'U'; - case 'v': return 'V'; - case 'w': return 'W'; - case 'x': return 'X'; - case 'y': return 'Y'; - case 'z': return 'Z'; - default: return c; - } -#endif -} diff --git a/lib/c-ctype.h b/lib/c-ctype.h index a258019f4..c7da46f54 100644 --- a/lib/c-ctype.h +++ b/lib/c-ctype.h @@ -5,7 +5,7 @@ functions' behaviour depends on the current locale set via setlocale. - Copyright (C) 2000-2003, 2006, 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2000-2003, 2006, 2008-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -25,6 +25,13 @@ along with this program; if not, see . */ #include +#ifndef _GL_INLINE_HEADER_BEGIN + #error "Please include config.h first." +#endif +_GL_INLINE_HEADER_BEGIN +#ifndef C_CTYPE_INLINE +# define C_CTYPE_INLINE _GL_INLINE +#endif #ifdef __cplusplus extern "C" { @@ -39,38 +46,6 @@ extern "C" { characters. */ -/* Check whether the ASCII optimizations apply. */ - -/* ANSI C89 (and ISO C99 5.2.1.3 too) already guarantees that - '0', '1', ..., '9' have consecutive integer values. */ -#define C_CTYPE_CONSECUTIVE_DIGITS 1 - -#if ('A' <= 'Z') \ - && ('A' + 1 == 'B') && ('B' + 1 == 'C') && ('C' + 1 == 'D') \ - && ('D' + 1 == 'E') && ('E' + 1 == 'F') && ('F' + 1 == 'G') \ - && ('G' + 1 == 'H') && ('H' + 1 == 'I') && ('I' + 1 == 'J') \ - && ('J' + 1 == 'K') && ('K' + 1 == 'L') && ('L' + 1 == 'M') \ - && ('M' + 1 == 'N') && ('N' + 1 == 'O') && ('O' + 1 == 'P') \ - && ('P' + 1 == 'Q') && ('Q' + 1 == 'R') && ('R' + 1 == 'S') \ - && ('S' + 1 == 'T') && ('T' + 1 == 'U') && ('U' + 1 == 'V') \ - && ('V' + 1 == 'W') && ('W' + 1 == 'X') && ('X' + 1 == 'Y') \ - && ('Y' + 1 == 'Z') -#define C_CTYPE_CONSECUTIVE_UPPERCASE 1 -#endif - -#if ('a' <= 'z') \ - && ('a' + 1 == 'b') && ('b' + 1 == 'c') && ('c' + 1 == 'd') \ - && ('d' + 1 == 'e') && ('e' + 1 == 'f') && ('f' + 1 == 'g') \ - && ('g' + 1 == 'h') && ('h' + 1 == 'i') && ('i' + 1 == 'j') \ - && ('j' + 1 == 'k') && ('k' + 1 == 'l') && ('l' + 1 == 'm') \ - && ('m' + 1 == 'n') && ('n' + 1 == 'o') && ('o' + 1 == 'p') \ - && ('p' + 1 == 'q') && ('q' + 1 == 'r') && ('r' + 1 == 's') \ - && ('s' + 1 == 't') && ('t' + 1 == 'u') && ('u' + 1 == 'v') \ - && ('v' + 1 == 'w') && ('w' + 1 == 'x') && ('x' + 1 == 'y') \ - && ('y' + 1 == 'z') -#define C_CTYPE_CONSECUTIVE_LOWERCASE 1 -#endif - #if (' ' == 32) && ('!' == 33) && ('"' == 34) && ('#' == 35) \ && ('%' == 37) && ('&' == 38) && ('\'' == 39) && ('(' == 40) \ && (')' == 41) && ('*' == 42) && ('+' == 43) && (',' == 44) \ @@ -96,11 +71,84 @@ extern "C" { && ('{' == 123) && ('|' == 124) && ('}' == 125) && ('~' == 126) /* The character set is ASCII or one of its variants or extensions, not EBCDIC. Testing the value of '\n' and '\r' is not relevant. */ -#define C_CTYPE_ASCII 1 +# define C_CTYPE_ASCII 1 +#elif ! (' ' == '\x40' && '0' == '\xf0' \ + && 'A' == '\xc1' && 'J' == '\xd1' && 'S' == '\xe2' \ + && 'a' == '\x81' && 'j' == '\x91' && 's' == '\xa2') +# error "Only ASCII and EBCDIC are supported" #endif +#if 'A' < 0 +# error "EBCDIC and char is signed -- not supported" +#endif -/* Function declarations. */ +/* Cases for control characters. */ + +#define _C_CTYPE_CNTRL \ + case '\a': case '\b': case '\f': case '\n': \ + case '\r': case '\t': case '\v': \ + _C_CTYPE_OTHER_CNTRL + +/* ASCII control characters other than those with \-letter escapes. */ + +#if C_CTYPE_ASCII +# define _C_CTYPE_OTHER_CNTRL \ + case '\x00': case '\x01': case '\x02': case '\x03': \ + case '\x04': case '\x05': case '\x06': case '\x0e': \ + case '\x0f': case '\x10': case '\x11': case '\x12': \ + case '\x13': case '\x14': case '\x15': case '\x16': \ + case '\x17': case '\x18': case '\x19': case '\x1a': \ + case '\x1b': case '\x1c': case '\x1d': case '\x1e': \ + case '\x1f': case '\x7f' +#else + /* Use EBCDIC code page 1047's assignments for ASCII control chars; + assume all EBCDIC code pages agree about these assignments. */ +# define _C_CTYPE_OTHER_CNTRL \ + case '\x00': case '\x01': case '\x02': case '\x03': \ + case '\x07': case '\x0e': case '\x0f': case '\x10': \ + case '\x11': case '\x12': case '\x13': case '\x18': \ + case '\x19': case '\x1c': case '\x1d': case '\x1e': \ + case '\x1f': case '\x26': case '\x27': case '\x2d': \ + case '\x2e': case '\x32': case '\x37': case '\x3c': \ + case '\x3d': case '\x3f' +#endif + +/* Cases for lowercase hex letters, and lowercase letters, all offset by N. */ + +#define _C_CTYPE_LOWER_A_THRU_F_N(n) \ + case 'a' + (n): case 'b' + (n): case 'c' + (n): case 'd' + (n): \ + case 'e' + (n): case 'f' + (n) +#define _C_CTYPE_LOWER_N(n) \ + _C_CTYPE_LOWER_A_THRU_F_N(n): \ + case 'g' + (n): case 'h' + (n): case 'i' + (n): case 'j' + (n): \ + case 'k' + (n): case 'l' + (n): case 'm' + (n): case 'n' + (n): \ + case 'o' + (n): case 'p' + (n): case 'q' + (n): case 'r' + (n): \ + case 's' + (n): case 't' + (n): case 'u' + (n): case 'v' + (n): \ + case 'w' + (n): case 'x' + (n): case 'y' + (n): case 'z' + (n) + +/* Cases for hex letters, digits, lower, punct, and upper. */ + +#define _C_CTYPE_A_THRU_F \ + _C_CTYPE_LOWER_A_THRU_F_N (0): \ + _C_CTYPE_LOWER_A_THRU_F_N ('A' - 'a') +#define _C_CTYPE_DIGIT \ + case '0': case '1': case '2': case '3': \ + case '4': case '5': case '6': case '7': \ + case '8': case '9' +#define _C_CTYPE_LOWER _C_CTYPE_LOWER_N (0) +#define _C_CTYPE_PUNCT \ + case '!': case '"': case '#': case '$': \ + case '%': case '&': case '\'': case '(': \ + case ')': case '*': case '+': case ',': \ + case '-': case '.': case '/': case ':': \ + case ';': case '<': case '=': case '>': \ + case '?': case '@': case '[': case '\\': \ + case ']': case '^': case '_': case '`': \ + case '{': case '|': case '}': case '~' +#define _C_CTYPE_UPPER _C_CTYPE_LOWER_N ('A' - 'a') + + +/* Function definitions. */ /* Unlike the functions in , which require an argument in the range of the 'unsigned char' type, the functions here operate on values that are @@ -117,179 +165,202 @@ extern "C" { if (c_isalpha (*s)) ... */ -extern bool c_isascii (int c) _GL_ATTRIBUTE_CONST; /* not locale dependent */ +C_CTYPE_INLINE bool +c_isalnum (int c) +{ + switch (c) + { + _C_CTYPE_DIGIT: + _C_CTYPE_LOWER: + _C_CTYPE_UPPER: + return true; + default: + return false; + } +} -extern bool c_isalnum (int c) _GL_ATTRIBUTE_CONST; -extern bool c_isalpha (int c) _GL_ATTRIBUTE_CONST; -extern bool c_isblank (int c) _GL_ATTRIBUTE_CONST; -extern bool c_iscntrl (int c) _GL_ATTRIBUTE_CONST; -extern bool c_isdigit (int c) _GL_ATTRIBUTE_CONST; -extern bool c_islower (int c) _GL_ATTRIBUTE_CONST; -extern bool c_isgraph (int c) _GL_ATTRIBUTE_CONST; -extern bool c_isprint (int c) _GL_ATTRIBUTE_CONST; -extern bool c_ispunct (int c) _GL_ATTRIBUTE_CONST; -extern bool c_isspace (int c) _GL_ATTRIBUTE_CONST; -extern bool c_isupper (int c) _GL_ATTRIBUTE_CONST; -extern bool c_isxdigit (int c) _GL_ATTRIBUTE_CONST; +C_CTYPE_INLINE bool +c_isalpha (int c) +{ + switch (c) + { + _C_CTYPE_LOWER: + _C_CTYPE_UPPER: + return true; + default: + return false; + } +} -extern int c_tolower (int c) _GL_ATTRIBUTE_CONST; -extern int c_toupper (int c) _GL_ATTRIBUTE_CONST; +/* The function isascii is not locale dependent. + Its use in EBCDIC is questionable. */ +C_CTYPE_INLINE bool +c_isascii (int c) +{ + switch (c) + { + case ' ': + _C_CTYPE_CNTRL: + _C_CTYPE_DIGIT: + _C_CTYPE_LOWER: + _C_CTYPE_PUNCT: + _C_CTYPE_UPPER: + return true; + default: + return false; + } +} +C_CTYPE_INLINE bool +c_isblank (int c) +{ + return c == ' ' || c == '\t'; +} -#if (defined __GNUC__ && !defined __STRICT_ANSI__ && defined __OPTIMIZE__ \ - && !defined __OPTIMIZE_SIZE__ && !defined NO_C_CTYPE_MACROS) +C_CTYPE_INLINE bool +c_iscntrl (int c) +{ + switch (c) + { + _C_CTYPE_CNTRL: + return true; + default: + return false; + } +} -/* ASCII optimizations. */ +C_CTYPE_INLINE bool +c_isdigit (int c) +{ + switch (c) + { + _C_CTYPE_DIGIT: + return true; + default: + return false; + } +} -#undef c_isascii -#define c_isascii(c) \ - ({ int __c = (c); \ - (__c >= 0x00 && __c <= 0x7f); \ - }) +C_CTYPE_INLINE bool +c_isgraph (int c) +{ + switch (c) + { + _C_CTYPE_DIGIT: + _C_CTYPE_LOWER: + _C_CTYPE_PUNCT: + _C_CTYPE_UPPER: + return true; + default: + return false; + } +} -#if C_CTYPE_CONSECUTIVE_DIGITS \ - && C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE -#if C_CTYPE_ASCII -#undef c_isalnum -#define c_isalnum(c) \ - ({ int __c = (c); \ - ((__c >= '0' && __c <= '9') \ - || ((__c & ~0x20) >= 'A' && (__c & ~0x20) <= 'Z')); \ - }) -#else -#undef c_isalnum -#define c_isalnum(c) \ - ({ int __c = (c); \ - ((__c >= '0' && __c <= '9') \ - || (__c >= 'A' && __c <= 'Z') \ - || (__c >= 'a' && __c <= 'z')); \ - }) -#endif -#endif +C_CTYPE_INLINE bool +c_islower (int c) +{ + switch (c) + { + _C_CTYPE_LOWER: + return true; + default: + return false; + } +} -#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE -#if C_CTYPE_ASCII -#undef c_isalpha -#define c_isalpha(c) \ - ({ int __c = (c); \ - ((__c & ~0x20) >= 'A' && (__c & ~0x20) <= 'Z'); \ - }) -#else -#undef c_isalpha -#define c_isalpha(c) \ - ({ int __c = (c); \ - ((__c >= 'A' && __c <= 'Z') || (__c >= 'a' && __c <= 'z')); \ - }) -#endif -#endif +C_CTYPE_INLINE bool +c_isprint (int c) +{ + switch (c) + { + case ' ': + _C_CTYPE_DIGIT: + _C_CTYPE_LOWER: + _C_CTYPE_PUNCT: + _C_CTYPE_UPPER: + return true; + default: + return false; + } +} -#undef c_isblank -#define c_isblank(c) \ - ({ int __c = (c); \ - (__c == ' ' || __c == '\t'); \ - }) +C_CTYPE_INLINE bool +c_ispunct (int c) +{ + switch (c) + { + _C_CTYPE_PUNCT: + return true; + default: + return false; + } +} -#if C_CTYPE_ASCII -#undef c_iscntrl -#define c_iscntrl(c) \ - ({ int __c = (c); \ - ((__c & ~0x1f) == 0 || __c == 0x7f); \ - }) -#endif +C_CTYPE_INLINE bool +c_isspace (int c) +{ + switch (c) + { + case ' ': case '\t': case '\n': case '\v': case '\f': case '\r': + return true; + default: + return false; + } +} -#if C_CTYPE_CONSECUTIVE_DIGITS -#undef c_isdigit -#define c_isdigit(c) \ - ({ int __c = (c); \ - (__c >= '0' && __c <= '9'); \ - }) -#endif +C_CTYPE_INLINE bool +c_isupper (int c) +{ + switch (c) + { + _C_CTYPE_UPPER: + return true; + default: + return false; + } +} -#if C_CTYPE_CONSECUTIVE_LOWERCASE -#undef c_islower -#define c_islower(c) \ - ({ int __c = (c); \ - (__c >= 'a' && __c <= 'z'); \ - }) -#endif +C_CTYPE_INLINE bool +c_isxdigit (int c) +{ + switch (c) + { + _C_CTYPE_DIGIT: + _C_CTYPE_A_THRU_F: + return true; + default: + return false; + } +} -#if C_CTYPE_ASCII -#undef c_isgraph -#define c_isgraph(c) \ - ({ int __c = (c); \ - (__c >= '!' && __c <= '~'); \ - }) -#endif - -#if C_CTYPE_ASCII -#undef c_isprint -#define c_isprint(c) \ - ({ int __c = (c); \ - (__c >= ' ' && __c <= '~'); \ - }) -#endif - -#if C_CTYPE_ASCII -#undef c_ispunct -#define c_ispunct(c) \ - ({ int _c = (c); \ - (c_isgraph (_c) && ! c_isalnum (_c)); \ - }) -#endif - -#undef c_isspace -#define c_isspace(c) \ - ({ int __c = (c); \ - (__c == ' ' || __c == '\t' \ - || __c == '\n' || __c == '\v' || __c == '\f' || __c == '\r'); \ - }) - -#if C_CTYPE_CONSECUTIVE_UPPERCASE -#undef c_isupper -#define c_isupper(c) \ - ({ int __c = (c); \ - (__c >= 'A' && __c <= 'Z'); \ - }) -#endif - -#if C_CTYPE_CONSECUTIVE_DIGITS \ - && C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE -#if C_CTYPE_ASCII -#undef c_isxdigit -#define c_isxdigit(c) \ - ({ int __c = (c); \ - ((__c >= '0' && __c <= '9') \ - || ((__c & ~0x20) >= 'A' && (__c & ~0x20) <= 'F')); \ - }) -#else -#undef c_isxdigit -#define c_isxdigit(c) \ - ({ int __c = (c); \ - ((__c >= '0' && __c <= '9') \ - || (__c >= 'A' && __c <= 'F') \ - || (__c >= 'a' && __c <= 'f')); \ - }) -#endif -#endif - -#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE -#undef c_tolower -#define c_tolower(c) \ - ({ int __c = (c); \ - (__c >= 'A' && __c <= 'Z' ? __c - 'A' + 'a' : __c); \ - }) -#undef c_toupper -#define c_toupper(c) \ - ({ int __c = (c); \ - (__c >= 'a' && __c <= 'z' ? __c - 'a' + 'A' : __c); \ - }) -#endif - -#endif /* optimizing for speed */ +C_CTYPE_INLINE int +c_tolower (int c) +{ + switch (c) + { + _C_CTYPE_UPPER: + return c - 'A' + 'a'; + default: + return c; + } +} +C_CTYPE_INLINE int +c_toupper (int c) +{ + switch (c) + { + _C_CTYPE_LOWER: + return c - 'a' + 'A'; + default: + return c; + } +} #ifdef __cplusplus } #endif +_GL_INLINE_HEADER_END + #endif /* C_CTYPE_H */ diff --git a/lib/c-strcase.h b/lib/c-strcase.h index ee3bd3f72..55fd801ee 100644 --- a/lib/c-strcase.h +++ b/lib/c-strcase.h @@ -1,5 +1,5 @@ /* Case-insensitive string comparison functions in C locale. - Copyright (C) 1995-1996, 2001, 2003, 2005, 2009-2014 Free Software + Copyright (C) 1995-1996, 2001, 2003, 2005, 2009-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/c-strcasecmp.c b/lib/c-strcasecmp.c index 5059cc659..ce0223fcb 100644 --- a/lib/c-strcasecmp.c +++ b/lib/c-strcasecmp.c @@ -1,5 +1,5 @@ /* c-strcasecmp.c -- case insensitive string comparator in C locale - Copyright (C) 1998-1999, 2005-2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 1998-1999, 2005-2006, 2009-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/c-strcaseeq.h b/lib/c-strcaseeq.h index 44d375148..ce4b82dd1 100644 --- a/lib/c-strcaseeq.h +++ b/lib/c-strcaseeq.h @@ -1,5 +1,5 @@ /* Optimized case-insensitive string comparison in C locale. - Copyright (C) 2001-2002, 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2001-2002, 2007, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published @@ -33,9 +33,6 @@ # if C_CTYPE_ASCII # define CASEEQ(other,upper) \ (c_isupper (upper) ? ((other) & ~0x20) == (upper) : (other) == (upper)) -# elif C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE -# define CASEEQ(other,upper) \ - (c_isupper (upper) ? (other) == (upper) || (other) == (upper) - 'A' + 'a' : (other) == (upper)) # else # define CASEEQ(other,upper) \ (c_toupper (other) == (upper)) diff --git a/lib/c-strncasecmp.c b/lib/c-strncasecmp.c index 614598156..7a7f61df8 100644 --- a/lib/c-strncasecmp.c +++ b/lib/c-strncasecmp.c @@ -1,5 +1,5 @@ /* c-strncasecmp.c -- case insensitive string comparator in C locale - Copyright (C) 1998-1999, 2005-2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 1998-1999, 2005-2006, 2009-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/canonicalize-lgpl.c b/lib/canonicalize-lgpl.c index a999c9c84..624a40eb9 100644 --- a/lib/canonicalize-lgpl.c +++ b/lib/canonicalize-lgpl.c @@ -1,5 +1,5 @@ /* Return the canonical absolute name of a given file. - Copyright (C) 1996-2014 Free Software Foundation, Inc. + Copyright (C) 1996-2015 Free Software Foundation, Inc. This file is part of the GNU C Library. This program is free software: you can redistribute it and/or modify diff --git a/lib/ceil.c b/lib/ceil.c index 7e810357b..236d258b1 100644 --- a/lib/ceil.c +++ b/lib/ceil.c @@ -1,5 +1,5 @@ /* Round towards positive infinity. - Copyright (C) 2007, 2010-2014 Free Software Foundation, Inc. + Copyright (C) 2007, 2010-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/close.c b/lib/close.c index 9d2e0276a..c1f112590 100644 --- a/lib/close.c +++ b/lib/close.c @@ -1,5 +1,5 @@ /* close replacement. - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/config.charset b/lib/config.charset index 8fe2507d9..8083c6029 100644 --- a/lib/config.charset +++ b/lib/config.charset @@ -1,7 +1,7 @@ #! /bin/sh # Output a system dependent table of character encoding aliases. # -# Copyright (C) 2000-2004, 2006-2014 Free Software Foundation, Inc. +# Copyright (C) 2000-2004, 2006-2015 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU Lesser General Public License as published by @@ -348,12 +348,10 @@ case "$os" in #echo "sun_eu_greek ?" # what is this? echo "UTF-8 UTF-8" ;; - freebsd* | os2*) + freebsd*) # FreeBSD 4.2 doesn't have nl_langinfo(CODESET); therefore # localcharset.c falls back to using the full locale name # from the environment variables. - # Likewise for OS/2. OS/2 has XFree86 just like FreeBSD. Just - # reuse FreeBSD's locale data for OS/2. echo "C ASCII" echo "US-ASCII ASCII" for l in la_LN lt_LN; do diff --git a/lib/connect.c b/lib/connect.c index 295fe95d8..bde8a60bc 100644 --- a/lib/connect.c +++ b/lib/connect.c @@ -1,6 +1,6 @@ /* connect.c --- wrappers for Windows connect function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/copysign.c b/lib/copysign.c index 616ea356e..761320bc0 100644 --- a/lib/copysign.c +++ b/lib/copysign.c @@ -1,5 +1,5 @@ /* Copy sign into another 'double' number. - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/dirent.in.h b/lib/dirent.in.h index 3418bd9dc..e4490caf5 100644 --- a/lib/dirent.in.h +++ b/lib/dirent.in.h @@ -1,5 +1,5 @@ /* A GNU-like . - Copyright (C) 2006-2014 Free Software Foundation, Inc. + Copyright (C) 2006-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -77,6 +77,7 @@ typedef struct gl_directory DIR; # if !(defined __cplusplus && defined GNULIB_NAMESPACE) # undef opendir # define opendir rpl_opendir +# define GNULIB_defined_opendir 1 # endif _GL_FUNCDECL_RPL (opendir, DIR *, (const char *dir_name) _GL_ARG_NONNULL ((1))); _GL_CXXALIAS_RPL (opendir, DIR *, (const char *dir_name)); @@ -128,6 +129,7 @@ _GL_WARN_ON_USE (rewinddir, "rewinddir is not portable - " # if !(defined __cplusplus && defined GNULIB_NAMESPACE) # undef closedir # define closedir rpl_closedir +# define GNULIB_defined_closedir 1 # endif _GL_FUNCDECL_RPL (closedir, int, (DIR *dirp) _GL_ARG_NONNULL ((1))); _GL_CXXALIAS_RPL (closedir, int, (DIR *dirp)); diff --git a/lib/dirfd.c b/lib/dirfd.c index 86f8e0a1a..c196c6601 100644 --- a/lib/dirfd.c +++ b/lib/dirfd.c @@ -1,6 +1,6 @@ /* dirfd.c -- return the file descriptor associated with an open DIR* - Copyright (C) 2001, 2006, 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2001, 2006, 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/dirname-lgpl.c b/lib/dirname-lgpl.c index 121d38754..c1e610109 100644 --- a/lib/dirname-lgpl.c +++ b/lib/dirname-lgpl.c @@ -1,6 +1,6 @@ /* dirname.c -- return all but the last element in a file name - Copyright (C) 1990, 1998, 2000-2001, 2003-2006, 2009-2014 Free Software + Copyright (C) 1990, 1998, 2000-2001, 2003-2006, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/dirname.h b/lib/dirname.h index e31cb6190..abb058497 100644 --- a/lib/dirname.h +++ b/lib/dirname.h @@ -1,6 +1,6 @@ /* Take file names apart into directory and base names. - Copyright (C) 1998, 2001, 2003-2006, 2009-2014 Free Software Foundation, + Copyright (C) 1998, 2001, 2003-2006, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify @@ -31,6 +31,10 @@ # define DOUBLE_SLASH_IS_DISTINCT_ROOT 0 # endif +#ifdef __cplusplus +extern "C" { +#endif + # if GNULIB_DIRNAME char *base_name (char const *file); char *dir_name (char const *file); @@ -43,4 +47,8 @@ char *last_component (char const *file) _GL_ATTRIBUTE_PURE; bool strip_trailing_slashes (char *file); +#ifdef __cplusplus +} /* extern "C" */ +#endif + #endif /* not DIRNAME_H_ */ diff --git a/lib/dosname.h b/lib/dosname.h index b81163d4b..42e3186ab 100644 --- a/lib/dosname.h +++ b/lib/dosname.h @@ -1,6 +1,6 @@ /* File names on MS-DOS/Windows systems. - Copyright (C) 2000-2001, 2004-2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2000-2001, 2004-2006, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/dup2.c b/lib/dup2.c index 9709b7a64..7f984ccb0 100644 --- a/lib/dup2.c +++ b/lib/dup2.c @@ -1,6 +1,6 @@ /* Duplicate an open file descriptor to a specified file descriptor. - Copyright (C) 1999, 2004-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 1999, 2004-2007, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/duplocale.c b/lib/duplocale.c index 86d5ce59a..9fdb26811 100644 --- a/lib/duplocale.c +++ b/lib/duplocale.c @@ -1,5 +1,5 @@ /* Duplicate a locale object. - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/errno.in.h b/lib/errno.in.h index 8dbb5f97a..5f1aa8dce 100644 --- a/lib/errno.in.h +++ b/lib/errno.in.h @@ -1,6 +1,6 @@ /* A POSIX-like . - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/fcntl.in.h b/lib/fcntl.in.h index 1cd197002..1c3b2c83f 100644 --- a/lib/fcntl.in.h +++ b/lib/fcntl.in.h @@ -1,6 +1,6 @@ /* Like , but with non-working flags defined to 0. - Copyright (C) 2006-2014 Free Software Foundation, Inc. + Copyright (C) 2006-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -34,7 +34,7 @@ extern "C" { ... } block, which leads to errors in C++ mode with the overridden from gnulib. These errors are known to be gone with g++ version >= 4.3. */ -#if !(defined __GLIBC__ || defined __UCLIBC__) || (defined __cplusplus && defined GNULIB_NAMESPACE && !(__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3))) +#if !(defined __GLIBC__ || defined __UCLIBC__) || (defined __cplusplus && defined GNULIB_NAMESPACE && (defined __ICC || !(__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3)))) # include #endif #@INCLUDE_NEXT@ @NEXT_FCNTL_H@ @@ -53,7 +53,7 @@ extern "C" { ... } block, which leads to errors in C++ mode with the overridden from gnulib. These errors are known to be gone with g++ version >= 4.3. */ -#if !(defined __GLIBC__ || defined __UCLIBC__) || (defined __cplusplus && defined GNULIB_NAMESPACE && !(__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3))) +#if !(defined __GLIBC__ || defined __UCLIBC__) || (defined __cplusplus && defined GNULIB_NAMESPACE && (defined __ICC || !(__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3)))) # include #endif /* The include_next requires a split double-inclusion guard. */ @@ -186,6 +186,22 @@ _GL_WARN_ON_USE (openat, "openat is not portable - " /* Fix up the O_* macros. */ +/* AIX 7.1 with XL C 12.1 defines O_CLOEXEC, O_NOFOLLOW, and O_TTY_INIT + to values outside 'int' range, so omit these misdefinitions. + But avoid namespace pollution on non-AIX systems. */ +#ifdef _AIX +# include +# if defined O_CLOEXEC && ! (INT_MIN <= O_CLOEXEC && O_CLOEXEC <= INT_MAX) +# undef O_CLOEXEC +# endif +# if defined O_NOFOLLOW && ! (INT_MIN <= O_NOFOLLOW && O_NOFOLLOW <= INT_MAX) +# undef O_NOFOLLOW +# endif +# if defined O_TTY_INIT && ! (INT_MIN <= O_TTY_INIT && O_TTY_INIT <= INT_MAX) +# undef O_TTY_INIT +# endif +#endif + #if !defined O_DIRECT && defined O_DIRECTIO /* Tru64 spells it 'O_DIRECTIO'. */ # define O_DIRECT O_DIRECTIO diff --git a/lib/fd-hook.c b/lib/fd-hook.c index fd07578f1..158b1ecda 100644 --- a/lib/fd-hook.c +++ b/lib/fd-hook.c @@ -1,5 +1,5 @@ /* Hook for making making file descriptor functions close(), ioctl() extensible. - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2009. This program is free software: you can redistribute it and/or modify it diff --git a/lib/fd-hook.h b/lib/fd-hook.h index 5ff0f73fc..7010ccaef 100644 --- a/lib/fd-hook.h +++ b/lib/fd-hook.h @@ -1,5 +1,5 @@ /* Hook for making making file descriptor functions close(), ioctl() extensible. - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/float+.h b/lib/float+.h index 085c379b1..c3d28a598 100644 --- a/lib/float+.h +++ b/lib/float+.h @@ -1,5 +1,5 @@ /* Supplemental information about the floating-point formats. - Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2007. This program is free software; you can redistribute it and/or modify diff --git a/lib/float.c b/lib/float.c index 3faa5eede..9a2d0f723 100644 --- a/lib/float.c +++ b/lib/float.c @@ -1,5 +1,5 @@ /* Auxiliary definitions for . - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/float.in.h b/lib/float.in.h index e814eaba5..dab2a2b44 100644 --- a/lib/float.in.h +++ b/lib/float.in.h @@ -1,6 +1,6 @@ /* A correct . - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/flock.c b/lib/flock.c index 928e151b0..a591f1e38 100644 --- a/lib/flock.c +++ b/lib/flock.c @@ -6,7 +6,7 @@ Written by Richard W.M. Jones - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 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 diff --git a/lib/floor.c b/lib/floor.c index a00f937ed..010131144 100644 --- a/lib/floor.c +++ b/lib/floor.c @@ -1,5 +1,5 @@ /* Round towards negative infinity. - Copyright (C) 2007, 2010-2014 Free Software Foundation, Inc. + Copyright (C) 2007, 2010-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/frexp.c b/lib/frexp.c index 6eff94574..21edf0afb 100644 --- a/lib/frexp.c +++ b/lib/frexp.c @@ -1,5 +1,5 @@ /* Split a double into fraction and mantissa. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/fstat.c b/lib/fstat.c index 17ccc8e29..71ca7b0cb 100644 --- a/lib/fstat.c +++ b/lib/fstat.c @@ -1,5 +1,5 @@ /* fstat() replacement. - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/fsync.c b/lib/fsync.c index 99475ff65..8ef6dbee8 100644 --- a/lib/fsync.c +++ b/lib/fsync.c @@ -7,7 +7,7 @@ Written by Richard W.M. Jones - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 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 diff --git a/lib/full-read.c b/lib/full-read.c index 4d67afb92..ac7fb5651 100644 --- a/lib/full-read.c +++ b/lib/full-read.c @@ -1,5 +1,5 @@ /* An interface to read that retries after partial reads and interrupts. - Copyright (C) 2002-2003, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2002-2003, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/full-read.h b/lib/full-read.h index 954b94dce..950b9bd3f 100644 --- a/lib/full-read.h +++ b/lib/full-read.h @@ -1,6 +1,6 @@ /* An interface to read() that reads all it is asked to read. - Copyright (C) 2002, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2002, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -13,7 +13,6 @@ GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License - along with this program; if not, read to the Free Software Foundation, along with this program. If not, see . */ #include diff --git a/lib/full-write.c b/lib/full-write.c index 6a77b7b45..df3bad0d5 100644 --- a/lib/full-write.c +++ b/lib/full-write.c @@ -1,6 +1,6 @@ /* An interface to read and write that retries (if necessary) until complete. - Copyright (C) 1993-1994, 1997-2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 1993-1994, 1997-2006, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/full-write.h b/lib/full-write.h index 2fab6fa02..607facd35 100644 --- a/lib/full-write.h +++ b/lib/full-write.h @@ -1,6 +1,6 @@ /* An interface to write() that writes all it is asked to write. - Copyright (C) 2002-2003, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2002-2003, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/gai_strerror.c b/lib/gai_strerror.c index d0c589da1..fbef3bbe9 100644 --- a/lib/gai_strerror.c +++ b/lib/gai_strerror.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1997, 2001-2002, 2004-2006, 2008-2014 Free Software +/* Copyright (C) 1997, 2001-2002, 2004-2006, 2008-2015 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Philip Blundell , 1997. diff --git a/lib/getaddrinfo.c b/lib/getaddrinfo.c index 6581dd55a..9d3384f71 100644 --- a/lib/getaddrinfo.c +++ b/lib/getaddrinfo.c @@ -1,5 +1,5 @@ /* Get address information (partial implementation). - Copyright (C) 1997, 2001-2002, 2004-2014 Free Software Foundation, Inc. + Copyright (C) 1997, 2001-2002, 2004-2015 Free Software Foundation, Inc. Contributed by Simon Josefsson . This program is free software; you can redistribute it and/or modify diff --git a/lib/getlogin.c b/lib/getlogin.c index f8cfe5d78..5fc54b851 100644 --- a/lib/getlogin.c +++ b/lib/getlogin.c @@ -1,6 +1,6 @@ /* Provide a working getlogin for systems which lack it. - Copyright (C) 2010-2014 Free Software Foundation, Inc. + Copyright (C) 2010-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/getpeername.c b/lib/getpeername.c index e5b3eaea3..ce2e105a6 100644 --- a/lib/getpeername.c +++ b/lib/getpeername.c @@ -1,6 +1,6 @@ /* getpeername.c --- wrappers for Windows getpeername function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/getsockname.c b/lib/getsockname.c index d26bae592..6f24e7c18 100644 --- a/lib/getsockname.c +++ b/lib/getsockname.c @@ -1,6 +1,6 @@ /* getsockname.c --- wrappers for Windows getsockname function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/getsockopt.c b/lib/getsockopt.c index 0b2fb2b73..ccd2e6fe7 100644 --- a/lib/getsockopt.c +++ b/lib/getsockopt.c @@ -1,6 +1,6 @@ /* getsockopt.c --- wrappers for Windows getsockopt function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/gettext.h b/lib/gettext.h index 330d8dad4..3770ca0e8 100644 --- a/lib/gettext.h +++ b/lib/gettext.h @@ -1,5 +1,5 @@ /* Convenience header for conditional use of GNU . - Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2009-2014 Free Software + Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2009-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/gettimeofday.c b/lib/gettimeofday.c index c4e40fbe9..a615f3b25 100644 --- a/lib/gettimeofday.c +++ b/lib/gettimeofday.c @@ -1,6 +1,6 @@ /* Provide gettimeofday for systems that don't have it or for which it's broken. - Copyright (C) 2001-2003, 2005-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2001-2003, 2005-2007, 2009-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/glthread/lock.h b/lib/glthread/lock.h index 66c78a6cd..1aafd8bb4 100644 --- a/lib/glthread/lock.h +++ b/lib/glthread/lock.h @@ -1,7 +1,7 @@ #ifndef SCM_GLTHREADS_H #define SCM_GLTHREADS_H -/* Copyright (C) 2014 Free Software Foundation, Inc. +/* Copyright (C) 2014, 2015 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 License diff --git a/lib/iconv.c b/lib/iconv.c index a6dfed355..850c8b77b 100644 --- a/lib/iconv.c +++ b/lib/iconv.c @@ -1,5 +1,5 @@ /* Character set conversion. - Copyright (C) 1999-2001, 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 1999-2001, 2007, 2009-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/iconv.in.h b/lib/iconv.in.h index ed95ed719..6b3d245c9 100644 --- a/lib/iconv.in.h +++ b/lib/iconv.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/iconv_close.c b/lib/iconv_close.c index 6e286734d..d728c0741 100644 --- a/lib/iconv_close.c +++ b/lib/iconv_close.c @@ -1,5 +1,5 @@ /* Character set conversion. - Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/iconv_open-aix.h b/lib/iconv_open-aix.h index a598e819d..129e03084 100644 --- a/lib/iconv_open-aix.h +++ b/lib/iconv_open-aix.h @@ -1,4 +1,4 @@ -/* ANSI-C code produced by gperf version 3.0.3 */ +/* ANSI-C code produced by gperf version 3.0.4 */ /* Command-line: gperf -m 10 ./iconv_open-aix.gperf */ /* Computed positions: -k'4,$' */ diff --git a/lib/iconv_open-hpux.h b/lib/iconv_open-hpux.h index 8f9f0a9ad..3bcff76a7 100644 --- a/lib/iconv_open-hpux.h +++ b/lib/iconv_open-hpux.h @@ -1,4 +1,4 @@ -/* ANSI-C code produced by gperf version 3.0.3 */ +/* ANSI-C code produced by gperf version 3.0.4 */ /* Command-line: gperf -m 10 ./iconv_open-hpux.gperf */ /* Computed positions: -k'4,$' */ @@ -272,7 +272,7 @@ static const struct mapping mappings[] = #ifdef __GNUC__ __inline -#ifdef __GNUC_STDC_INLINE__ +#if defined __GNUC_STDC_INLINE__ || defined __GNUC_GNU_INLINE__ __attribute__ ((__gnu_inline__)) #endif #endif diff --git a/lib/iconv_open-irix.h b/lib/iconv_open-irix.h index 520582e52..74ceb8f57 100644 --- a/lib/iconv_open-irix.h +++ b/lib/iconv_open-irix.h @@ -1,4 +1,4 @@ -/* ANSI-C code produced by gperf version 3.0.3 */ +/* ANSI-C code produced by gperf version 3.0.4 */ /* Command-line: gperf -m 10 ./iconv_open-irix.gperf */ /* Computed positions: -k'1,$' */ @@ -172,7 +172,7 @@ static const struct mapping mappings[] = #ifdef __GNUC__ __inline -#ifdef __GNUC_STDC_INLINE__ +#if defined __GNUC_STDC_INLINE__ || defined __GNUC_GNU_INLINE__ __attribute__ ((__gnu_inline__)) #endif #endif diff --git a/lib/iconv_open-osf.h b/lib/iconv_open-osf.h index 85e4c0f8f..4d3576495 100644 --- a/lib/iconv_open-osf.h +++ b/lib/iconv_open-osf.h @@ -1,4 +1,4 @@ -/* ANSI-C code produced by gperf version 3.0.3 */ +/* ANSI-C code produced by gperf version 3.0.4 */ /* Command-line: gperf -m 10 ./iconv_open-osf.gperf */ /* Computed positions: -k'4,$' */ @@ -251,7 +251,7 @@ static const struct mapping mappings[] = #ifdef __GNUC__ __inline -#ifdef __GNUC_STDC_INLINE__ +#if defined __GNUC_STDC_INLINE__ || defined __GNUC_GNU_INLINE__ __attribute__ ((__gnu_inline__)) #endif #endif diff --git a/lib/iconv_open.c b/lib/iconv_open.c index fc19d44e2..07174331f 100644 --- a/lib/iconv_open.c +++ b/lib/iconv_open.c @@ -1,5 +1,5 @@ /* Character set conversion. - Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/iconveh.h b/lib/iconveh.h index 43b23eb39..d02c97502 100644 --- a/lib/iconveh.h +++ b/lib/iconveh.h @@ -1,5 +1,5 @@ /* Character set conversion handler type. - Copyright (C) 2001-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2001-2007, 2009-2015 Free Software Foundation, Inc. Written by Bruno Haible. This program is free software: you can redistribute it and/or modify diff --git a/lib/ignore-value.h b/lib/ignore-value.h deleted file mode 100644 index 86cfad77b..000000000 --- a/lib/ignore-value.h +++ /dev/null @@ -1,37 +0,0 @@ -/* ignore a function return without a compiler warning - - Copyright (C) 2008-2009 Free Software Foundation, Inc. - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . */ - -/* Written by Jim Meyering. */ - -/* Use these functions to avoid a warning when using a function declared with - gcc's warn_unused_result attribute, but for which you really do want to - ignore the result. Traditionally, people have used a "(void)" cast to - indicate that a function's return value is deliberately unused. However, - if the function is declared with __attribute__((warn_unused_result)), - gcc issues a warning even with the cast. - - Caution: most of the time, you really should heed gcc's warning, and - check the return value. However, in those exceptional cases in which - you're sure you know what you're doing, use this function. - - For the record, here's one of the ignorable warnings: - "copy.c:233: warning: ignoring return value of 'fchown', - declared with attribute warn_unused_result". */ - -static inline void ignore_value (int i) { (void) i; } -static inline void ignore_ptr (void* p) { (void) p; } -/* FIXME: what about aggregate types? */ diff --git a/lib/inet_ntop.c b/lib/inet_ntop.c index 462951968..4620c2c09 100644 --- a/lib/inet_ntop.c +++ b/lib/inet_ntop.c @@ -1,6 +1,6 @@ /* inet_ntop.c -- convert IPv4 and IPv6 addresses from binary to text form - Copyright (C) 2005-2006, 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2005-2006, 2008-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/inet_pton.c b/lib/inet_pton.c index 52ae31784..1fc159a10 100644 --- a/lib/inet_pton.c +++ b/lib/inet_pton.c @@ -1,6 +1,6 @@ /* inet_pton.c -- convert IPv4 and IPv6 addresses from text to binary form - Copyright (C) 2006, 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2006, 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isfinite.c b/lib/isfinite.c index 18c1d217f..3792b9974 100644 --- a/lib/isfinite.c +++ b/lib/isfinite.c @@ -1,5 +1,5 @@ /* Test for finite value (zero, subnormal, or normal, and not infinite or NaN). - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isinf.c b/lib/isinf.c index 217de79df..4c79580e3 100644 --- a/lib/isinf.c +++ b/lib/isinf.c @@ -1,5 +1,5 @@ /* Test for positive or negative infinity. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnan.c b/lib/isnan.c index 1557733bf..d70c9348a 100644 --- a/lib/isnan.c +++ b/lib/isnan.c @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnand-nolibm.h b/lib/isnand-nolibm.h index b0498ef08..f5204f328 100644 --- a/lib/isnand-nolibm.h +++ b/lib/isnand-nolibm.h @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnand.c b/lib/isnand.c index 11efbf8d8..34e604fb7 100644 --- a/lib/isnand.c +++ b/lib/isnand.c @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnanf-nolibm.h b/lib/isnanf-nolibm.h index 9e2aa2f54..b3a280c70 100644 --- a/lib/isnanf-nolibm.h +++ b/lib/isnanf-nolibm.h @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnanf.c b/lib/isnanf.c index c7a66ca3a..7d21bddb4 100644 --- a/lib/isnanf.c +++ b/lib/isnanf.c @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnanl-nolibm.h b/lib/isnanl-nolibm.h index 9cf090caa..48a02b24e 100644 --- a/lib/isnanl-nolibm.h +++ b/lib/isnanl-nolibm.h @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnanl.c b/lib/isnanl.c index dbf9d5dd1..9ec4eb31f 100644 --- a/lib/isnanl.c +++ b/lib/isnanl.c @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/itold.c b/lib/itold.c index 136742eab..4963b9b2d 100644 --- a/lib/itold.c +++ b/lib/itold.c @@ -1,5 +1,5 @@ /* Replacement for 'int' to 'long double' conversion routine. - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/langinfo.in.h b/lib/langinfo.in.h index f4a281a33..cf992cede 100644 --- a/lib/langinfo.in.h +++ b/lib/langinfo.in.h @@ -1,5 +1,5 @@ /* Substitute for and wrapper around . - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -49,7 +49,10 @@ typedef int nl_item; # define CODESET 10000 /* nl_langinfo items of the LC_NUMERIC category */ # define RADIXCHAR 10001 +# define DECIMAL_POINT RADIXCHAR # define THOUSEP 10002 +# define THOUSANDS_SEP THOUSEP +# define GROUPING 10114 /* nl_langinfo items of the LC_TIME category */ # define D_T_FMT 10003 # define D_FMT 10004 @@ -102,6 +105,21 @@ typedef int nl_item; # define ALT_DIGITS 10051 /* nl_langinfo items of the LC_MONETARY category */ # define CRNCYSTR 10052 +# define CURRENCY_SYMBOL CRNCYSTR +# define INT_CURR_SYMBOL 10100 +# define MON_DECIMAL_POINT 10101 +# define MON_THOUSANDS_SEP 10102 +# define MON_GROUPING 10103 +# define POSITIVE_SIGN 10104 +# define NEGATIVE_SIGN 10105 +# define FRAC_DIGITS 10106 +# define INT_FRAC_DIGITS 10107 +# define P_CS_PRECEDES 10108 +# define N_CS_PRECEDES 10109 +# define P_SEP_BY_SPACE 10110 +# define N_SEP_BY_SPACE 10111 +# define P_SIGN_POSN 10112 +# define N_SIGN_POSN 10113 /* nl_langinfo items of the LC_MESSAGES category */ # define YESEXPR 10053 # define NOEXPR 10054 diff --git a/lib/link.c b/lib/link.c index 9db1f8cef..ebdd9f4ef 100644 --- a/lib/link.c +++ b/lib/link.c @@ -1,6 +1,6 @@ /* Emulate link on platforms that lack it, namely native Windows platforms. - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/listen.c b/lib/listen.c index 912f1b7a7..7cf092587 100644 --- a/lib/listen.c +++ b/lib/listen.c @@ -1,6 +1,6 @@ /* listen.c --- wrappers for Windows listen function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/localcharset.c b/lib/localcharset.c index 7f09567ce..6dffe3454 100644 --- a/lib/localcharset.c +++ b/lib/localcharset.c @@ -1,6 +1,6 @@ /* Determine a canonical name for the current locale's character encoding. - Copyright (C) 2000-2006, 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2000-2006, 2008-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -34,6 +34,7 @@ #if defined _WIN32 || defined __WIN32__ # define WINDOWS_NATIVE +# include #endif #if defined __EMX__ @@ -127,7 +128,7 @@ get_charset_aliases (void) cp = charset_aliases; if (cp == NULL) { -#if !(defined DARWIN7 || defined VMS || defined WINDOWS_NATIVE || defined __CYGWIN__) +#if !(defined DARWIN7 || defined VMS || defined WINDOWS_NATIVE || defined __CYGWIN__ || defined OS2) const char *dir; const char *base = "charset.alias"; char *file_name; @@ -341,6 +342,36 @@ get_charset_aliases (void) "CP54936" "\0" "GB18030" "\0" "CP65001" "\0" "UTF-8" "\0"; # endif +# if defined OS2 + /* To avoid the troubles of installing a separate file in the same + directory as the DLL and of retrieving the DLL's directory at + runtime, simply inline the aliases here. */ + + /* The list of encodings is taken from "List of OS/2 Codepages" + by Alex Taylor: + . + See also "IBM Globalization - Code page identifiers": + . */ + cp = "CP813" "\0" "ISO-8859-7" "\0" + "CP878" "\0" "KOI8-R" "\0" + "CP819" "\0" "ISO-8859-1" "\0" + "CP912" "\0" "ISO-8859-2" "\0" + "CP913" "\0" "ISO-8859-3" "\0" + "CP914" "\0" "ISO-8859-4" "\0" + "CP915" "\0" "ISO-8859-5" "\0" + "CP916" "\0" "ISO-8859-8" "\0" + "CP920" "\0" "ISO-8859-9" "\0" + "CP921" "\0" "ISO-8859-13" "\0" + "CP923" "\0" "ISO-8859-15" "\0" + "CP954" "\0" "EUC-JP" "\0" + "CP964" "\0" "EUC-TW" "\0" + "CP970" "\0" "EUC-KR" "\0" + "CP1089" "\0" "ISO-8859-6" "\0" + "CP1208" "\0" "UTF-8" "\0" + "CP1381" "\0" "GB2312" "\0" + "CP1386" "\0" "GBK" "\0" + "CP3372" "\0" "EUC-JP" "\0"; +# endif #endif charset_aliases = cp; @@ -461,14 +492,34 @@ locale_charset (void) static char buf[2 + 10 + 1]; - /* The Windows API has a function returning the locale's codepage as a - number: GetACP(). - When the output goes to a console window, it needs to be provided in - GetOEMCP() encoding if the console is using a raster font, or in - GetConsoleOutputCP() encoding if it is using a TrueType font. - But in GUI programs and for output sent to files and pipes, GetACP() - encoding is the best bet. */ - sprintf (buf, "CP%u", GetACP ()); + /* The Windows API has a function returning the locale's codepage as + a number, but the value doesn't change according to what the + 'setlocale' call specified. So we use it as a last resort, in + case the string returned by 'setlocale' doesn't specify the + codepage. */ + char *current_locale = setlocale (LC_ALL, NULL); + char *pdot; + + /* If they set different locales for different categories, + 'setlocale' will return a semi-colon separated list of locale + values. To make sure we use the correct one, we choose LC_CTYPE. */ + if (strchr (current_locale, ';')) + current_locale = setlocale (LC_CTYPE, NULL); + + pdot = strrchr (current_locale, '.'); + if (pdot) + sprintf (buf, "CP%s", pdot + 1); + else + { + /* The Windows API has a function returning the locale's codepage as a + number: GetACP(). + When the output goes to a console window, it needs to be provided in + GetOEMCP() encoding if the console is using a raster font, or in + GetConsoleOutputCP() encoding if it is using a TrueType font. + But in GUI programs and for output sent to files and pipes, GetACP() + encoding is the best bet. */ + sprintf (buf, "CP%u", GetACP ()); + } codeset = buf; #elif defined OS2 @@ -478,6 +529,8 @@ locale_charset (void) ULONG cp[3]; ULONG cplen; + codeset = NULL; + /* Allow user to override the codeset, as set in the operating system, with standard language environment variables. */ locale = getenv ("LC_ALL"); @@ -509,10 +562,12 @@ locale_charset (void) } } - /* Resolve through the charset.alias file. */ - codeset = locale; + /* For the POSIX locale, don't use the system's codepage. */ + if (strcmp (locale, "C") == 0 || strcmp (locale, "POSIX") == 0) + codeset = ""; } - else + + if (codeset == NULL) { /* OS/2 has a function returning the locale's codepage as a number. */ if (DosQueryCp (sizeof (cp), cp, &cplen)) diff --git a/lib/localcharset.h b/lib/localcharset.h index 4b104c304..86eaec198 100644 --- a/lib/localcharset.h +++ b/lib/localcharset.h @@ -1,5 +1,5 @@ /* Determine a canonical name for the current locale's character encoding. - Copyright (C) 2000-2003, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2000-2003, 2009-2015 Free Software Foundation, Inc. This file is part of the GNU CHARSET Library. This program is free software; you can redistribute it and/or modify diff --git a/lib/locale.in.h b/lib/locale.in.h index a10b129ca..4a1e229f3 100644 --- a/lib/locale.in.h +++ b/lib/locale.in.h @@ -1,5 +1,5 @@ /* A POSIX . - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/localeconv.c b/lib/localeconv.c index ed2767be0..e8fe69d34 100644 --- a/lib/localeconv.c +++ b/lib/localeconv.c @@ -1,5 +1,5 @@ /* Query locale dependent information for formatting numbers. - Copyright (C) 2012-2014 Free Software Foundation, Inc. + Copyright (C) 2012-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/log.c b/lib/log.c index ef8d332f8..e09b50c58 100644 --- a/lib/log.c +++ b/lib/log.c @@ -1,5 +1,5 @@ /* Logarithm. - Copyright (C) 2012-2014 Free Software Foundation, Inc. + Copyright (C) 2012-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/log1p.c b/lib/log1p.c index d1132d3e4..10105f0a8 100644 --- a/lib/log1p.c +++ b/lib/log1p.c @@ -1,5 +1,5 @@ /* Natural logarithm of 1 plus argument. - Copyright (C) 2012-2014 Free Software Foundation, Inc. + Copyright (C) 2012-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/lstat.c b/lib/lstat.c index cff1188f3..221bd0a26 100644 --- a/lib/lstat.c +++ b/lib/lstat.c @@ -1,6 +1,6 @@ /* Work around a bug of lstat on some systems - Copyright (C) 1997-2006, 2008-2014 Free Software Foundation, Inc. + Copyright (C) 1997-2006, 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/malloc.c b/lib/malloc.c index c6e292a74..7622f4d95 100644 --- a/lib/malloc.c +++ b/lib/malloc.c @@ -1,6 +1,6 @@ /* malloc() function that is glibc compatible. - Copyright (C) 1997-1998, 2006-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 1997-1998, 2006-2007, 2009-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/malloca.c b/lib/malloca.c index 3e95f2333..ef07acd7f 100644 --- a/lib/malloca.c +++ b/lib/malloca.c @@ -1,5 +1,5 @@ /* Safe automatic memory allocation. - Copyright (C) 2003, 2006-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2003, 2006-2007, 2009-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2003. This program is free software; you can redistribute it and/or modify diff --git a/lib/malloca.h b/lib/malloca.h index 5810afa54..37b106ffb 100644 --- a/lib/malloca.h +++ b/lib/malloca.h @@ -1,5 +1,5 @@ /* Safe automatic memory allocation. - Copyright (C) 2003-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2003-2007, 2009-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2003. This program is free software; you can redistribute it and/or modify diff --git a/lib/math.c b/lib/math.c index ddb2ded53..ba2a6abd6 100644 --- a/lib/math.c +++ b/lib/math.c @@ -1,3 +1,4 @@ #include #define _GL_MATH_INLINE _GL_EXTERN_INLINE #include "math.h" +typedef int dummy; diff --git a/lib/math.in.h b/lib/math.in.h index 4f2aa862b..b3803f8d0 100644 --- a/lib/math.in.h +++ b/lib/math.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 2002-2003, 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2002-2003, 2007-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/mbrtowc.c b/lib/mbrtowc.c index dff12962d..a5d61a066 100644 --- a/lib/mbrtowc.c +++ b/lib/mbrtowc.c @@ -1,5 +1,5 @@ /* Convert multibyte character to wide character. - Copyright (C) 1999-2002, 2005-2014 Free Software Foundation, Inc. + Copyright (C) 1999-2002, 2005-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2008. This program is free software: you can redistribute it and/or modify @@ -328,7 +328,7 @@ mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps) size_t rpl_mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps) { -# if MBRTOWC_NULL_ARG2_BUG || MBRTOWC_RETVAL_BUG +# if MBRTOWC_NULL_ARG2_BUG || MBRTOWC_RETVAL_BUG || MBRTOWC_EMPTY_INPUT_BUG if (s == NULL) { pwc = NULL; @@ -337,6 +337,11 @@ rpl_mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps) } # endif +# if MBRTOWC_EMPTY_INPUT_BUG + if (n == 0) + return (size_t) -2; +# endif + # if MBRTOWC_RETVAL_BUG { static mbstate_t internal_state; diff --git a/lib/mbsinit.c b/lib/mbsinit.c index 71bae341b..59997834e 100644 --- a/lib/mbsinit.c +++ b/lib/mbsinit.c @@ -1,5 +1,5 @@ /* Test for initial conversion state. - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2008. This program is free software: you can redistribute it and/or modify diff --git a/lib/mbtowc-impl.h b/lib/mbtowc-impl.h index df11ad2bf..737d7633a 100644 --- a/lib/mbtowc-impl.h +++ b/lib/mbtowc-impl.h @@ -1,5 +1,5 @@ /* Convert multibyte character to wide character. - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/mbtowc.c b/lib/mbtowc.c index bd9d3aa6b..be0d60992 100644 --- a/lib/mbtowc.c +++ b/lib/mbtowc.c @@ -1,5 +1,5 @@ /* Convert multibyte character to wide character. - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/memchr.c b/lib/memchr.c index c1caad3a2..a815ce78a 100644 --- a/lib/memchr.c +++ b/lib/memchr.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1991, 1993, 1996-1997, 1999-2000, 2003-2004, 2006, 2008-2014 +/* Copyright (C) 1991, 1993, 1996-1997, 1999-2000, 2003-2004, 2006, 2008-2015 Free Software Foundation, Inc. Based on strlen implementation by Torbjorn Granlund (tege@sics.se), diff --git a/lib/mkdir.c b/lib/mkdir.c index f1b802b57..c76c57e1f 100644 --- a/lib/mkdir.c +++ b/lib/mkdir.c @@ -1,7 +1,7 @@ /* On some systems, mkdir ("foo/", 0700) fails because of the trailing slash. On those systems, this wrapper removes the trailing slash. - Copyright (C) 2001, 2003, 2006, 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2001, 2003, 2006, 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/mkstemp.c b/lib/mkstemp.c index 0af69f9c3..3c0ee9eba 100644 --- a/lib/mkstemp.c +++ b/lib/mkstemp.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998-1999, 2001, 2005-2007, 2009-2014 Free Software +/* Copyright (C) 1998-1999, 2001, 2005-2007, 2009-2015 Free Software Foundation, Inc. This file is derived from the one in the GNU C Library. diff --git a/lib/mktime-internal.h b/lib/mktime-internal.h new file mode 100644 index 000000000..4287acf4a --- /dev/null +++ b/lib/mktime-internal.h @@ -0,0 +1,4 @@ +#include +time_t mktime_internal (struct tm *, + struct tm * (*) (time_t const *, struct tm *), + time_t *); diff --git a/lib/mktime.c b/lib/mktime.c new file mode 100644 index 000000000..7b125a79e --- /dev/null +++ b/lib/mktime.c @@ -0,0 +1,741 @@ +/* Convert a 'struct tm' to a time_t value. + Copyright (C) 1993-2015 Free Software Foundation, Inc. + This file is part of the GNU C Library. + Contributed by Paul Eggert . + + The GNU C Library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + The GNU C Library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with the GNU C Library; if not, see + . */ + +/* Define this to have a standalone program to test this implementation of + mktime. */ +/* #define DEBUG 1 */ + +#ifndef _LIBC +# include +#endif + +/* Assume that leap seconds are possible, unless told otherwise. + If the host has a 'zic' command with a '-L leapsecondfilename' option, + then it supports leap seconds; otherwise it probably doesn't. */ +#ifndef LEAP_SECONDS_POSSIBLE +# define LEAP_SECONDS_POSSIBLE 1 +#endif + +#include + +#include + +#include /* For the real memcpy prototype. */ + +#if defined DEBUG && DEBUG +# include +# include +/* Make it work even if the system's libc has its own mktime routine. */ +# undef mktime +# define mktime my_mktime +#endif /* DEBUG */ + +/* Some of the code in this file assumes that signed integer overflow + silently wraps around. This assumption can't easily be programmed + around, nor can it be checked for portably at compile-time or + easily eliminated at run-time. + + Define WRAPV to 1 if the assumption is valid and if + #pragma GCC optimize ("wrapv") + does not trigger GCC bug 51793 + . + Otherwise, define it to 0; this forces the use of slower code that, + while not guaranteed by the C Standard, works on all production + platforms that we know about. */ +#ifndef WRAPV +# if (((__GNUC__ == 4 && 4 <= __GNUC_MINOR__) || 4 < __GNUC__) \ + && defined __GLIBC__) +# pragma GCC optimize ("wrapv") +# define WRAPV 1 +# else +# define WRAPV 0 +# endif +#endif + +/* Verify a requirement at compile-time (unlike assert, which is runtime). */ +#define verify(name, assertion) struct name { char a[(assertion) ? 1 : -1]; } + +/* A signed type that is at least one bit wider than int. */ +#if INT_MAX <= LONG_MAX / 2 +typedef long int long_int; +#else +typedef long long int long_int; +#endif +verify (long_int_is_wide_enough, INT_MAX == INT_MAX * (long_int) 2 / 2); + +/* Shift A right by B bits portably, by dividing A by 2**B and + truncating towards minus infinity. A and B should be free of side + effects, and B should be in the range 0 <= B <= INT_BITS - 2, where + INT_BITS is the number of useful bits in an int. GNU code can + assume that INT_BITS is at least 32. + + ISO C99 says that A >> B is implementation-defined if A < 0. Some + implementations (e.g., UNICOS 9.0 on a Cray Y-MP EL) don't shift + right in the usual way when A < 0, so SHR falls back on division if + ordinary A >> B doesn't seem to be the usual signed shift. */ +#define SHR(a, b) \ + ((-1 >> 1 == -1 \ + && (long_int) -1 >> 1 == -1 \ + && ((time_t) -1 >> 1 == -1 || ! TYPE_SIGNED (time_t))) \ + ? (a) >> (b) \ + : (a) / (1 << (b)) - ((a) % (1 << (b)) < 0)) + +/* The extra casts in the following macros work around compiler bugs, + e.g., in Cray C 5.0.3.0. */ + +/* True if the arithmetic type T is an integer type. bool counts as + an integer. */ +#define TYPE_IS_INTEGER(t) ((t) 1.5 == 1) + +/* True if negative values of the signed integer type T use two's + complement, or if T is an unsigned integer type. */ +#define TYPE_TWOS_COMPLEMENT(t) ((t) ~ (t) 0 == (t) -1) + +/* True if the arithmetic type T is signed. */ +#define TYPE_SIGNED(t) (! ((t) 0 < (t) -1)) + +/* The maximum and minimum values for the integer type T. These + macros have undefined behavior if T is signed and has padding bits. + If this is a problem for you, please let us know how to fix it for + your host. */ +#define TYPE_MINIMUM(t) \ + ((t) (! TYPE_SIGNED (t) \ + ? (t) 0 \ + : ~ TYPE_MAXIMUM (t))) +#define TYPE_MAXIMUM(t) \ + ((t) (! TYPE_SIGNED (t) \ + ? (t) -1 \ + : ((((t) 1 << (sizeof (t) * CHAR_BIT - 2)) - 1) * 2 + 1))) + +#ifndef TIME_T_MIN +# define TIME_T_MIN TYPE_MINIMUM (time_t) +#endif +#ifndef TIME_T_MAX +# define TIME_T_MAX TYPE_MAXIMUM (time_t) +#endif +#define TIME_T_MIDPOINT (SHR (TIME_T_MIN + TIME_T_MAX, 1) + 1) + +verify (time_t_is_integer, TYPE_IS_INTEGER (time_t)); +verify (twos_complement_arithmetic, + (TYPE_TWOS_COMPLEMENT (int) + && TYPE_TWOS_COMPLEMENT (long_int) + && TYPE_TWOS_COMPLEMENT (time_t))); + +#define EPOCH_YEAR 1970 +#define TM_YEAR_BASE 1900 +verify (base_year_is_a_multiple_of_100, TM_YEAR_BASE % 100 == 0); + +/* Return 1 if YEAR + TM_YEAR_BASE is a leap year. */ +static int +leapyear (long_int year) +{ + /* Don't add YEAR to TM_YEAR_BASE, as that might overflow. + Also, work even if YEAR is negative. */ + return + ((year & 3) == 0 + && (year % 100 != 0 + || ((year / 100) & 3) == (- (TM_YEAR_BASE / 100) & 3))); +} + +/* How many days come before each month (0-12). */ +#ifndef _LIBC +static +#endif +const unsigned short int __mon_yday[2][13] = + { + /* Normal years. */ + { 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365 }, + /* Leap years. */ + { 0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366 } + }; + + +#ifndef _LIBC +/* Portable standalone applications should supply a that + declares a POSIX-compliant localtime_r, for the benefit of older + implementations that lack localtime_r or have a nonstandard one. + See the gnulib time_r module for one way to implement this. */ +# undef __localtime_r +# define __localtime_r localtime_r +# define __mktime_internal mktime_internal +# include "mktime-internal.h" +#endif + +/* Return 1 if the values A and B differ according to the rules for + tm_isdst: A and B differ if one is zero and the other positive. */ +static int +isdst_differ (int a, int b) +{ + return (!a != !b) && (0 <= a) && (0 <= b); +} + +/* Return an integer value measuring (YEAR1-YDAY1 HOUR1:MIN1:SEC1) - + (YEAR0-YDAY0 HOUR0:MIN0:SEC0) in seconds, assuming that the clocks + were not adjusted between the time stamps. + + The YEAR values uses the same numbering as TP->tm_year. Values + need not be in the usual range. However, YEAR1 must not be less + than 2 * INT_MIN or greater than 2 * INT_MAX. + + The result may overflow. It is the caller's responsibility to + detect overflow. */ + +static time_t +ydhms_diff (long_int year1, long_int yday1, int hour1, int min1, int sec1, + int year0, int yday0, int hour0, int min0, int sec0) +{ + verify (C99_integer_division, -1 / 2 == 0); + + /* Compute intervening leap days correctly even if year is negative. + Take care to avoid integer overflow here. */ + int a4 = SHR (year1, 2) + SHR (TM_YEAR_BASE, 2) - ! (year1 & 3); + int b4 = SHR (year0, 2) + SHR (TM_YEAR_BASE, 2) - ! (year0 & 3); + int a100 = a4 / 25 - (a4 % 25 < 0); + int b100 = b4 / 25 - (b4 % 25 < 0); + int a400 = SHR (a100, 2); + int b400 = SHR (b100, 2); + int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400); + + /* Compute the desired time in time_t precision. Overflow might + occur here. */ + time_t tyear1 = year1; + time_t years = tyear1 - year0; + time_t days = 365 * years + yday1 - yday0 + intervening_leap_days; + time_t hours = 24 * days + hour1 - hour0; + time_t minutes = 60 * hours + min1 - min0; + time_t seconds = 60 * minutes + sec1 - sec0; + return seconds; +} + +/* Return the average of A and B, even if A + B would overflow. */ +static time_t +time_t_avg (time_t a, time_t b) +{ + return SHR (a, 1) + SHR (b, 1) + (a & b & 1); +} + +/* Return 1 if A + B does not overflow. If time_t is unsigned and if + B's top bit is set, assume that the sum represents A - -B, and + return 1 if the subtraction does not wrap around. */ +static int +time_t_add_ok (time_t a, time_t b) +{ + if (! TYPE_SIGNED (time_t)) + { + time_t sum = a + b; + return (sum < a) == (TIME_T_MIDPOINT <= b); + } + else if (WRAPV) + { + time_t sum = a + b; + return (sum < a) == (b < 0); + } + else + { + time_t avg = time_t_avg (a, b); + return TIME_T_MIN / 2 <= avg && avg <= TIME_T_MAX / 2; + } +} + +/* Return 1 if A + B does not overflow. */ +static int +time_t_int_add_ok (time_t a, int b) +{ + verify (int_no_wider_than_time_t, INT_MAX <= TIME_T_MAX); + if (WRAPV) + { + time_t sum = a + b; + return (sum < a) == (b < 0); + } + else + { + int a_odd = a & 1; + time_t avg = SHR (a, 1) + (SHR (b, 1) + (a_odd & b)); + return TIME_T_MIN / 2 <= avg && avg <= TIME_T_MAX / 2; + } +} + +/* Return a time_t value corresponding to (YEAR-YDAY HOUR:MIN:SEC), + assuming that *T corresponds to *TP and that no clock adjustments + occurred between *TP and the desired time. + If TP is null, return a value not equal to *T; this avoids false matches. + If overflow occurs, yield the minimal or maximal value, except do not + yield a value equal to *T. */ +static time_t +guess_time_tm (long_int year, long_int yday, int hour, int min, int sec, + const time_t *t, const struct tm *tp) +{ + if (tp) + { + time_t d = ydhms_diff (year, yday, hour, min, sec, + tp->tm_year, tp->tm_yday, + tp->tm_hour, tp->tm_min, tp->tm_sec); + if (time_t_add_ok (*t, d)) + return *t + d; + } + + /* Overflow occurred one way or another. Return the nearest result + that is actually in range, except don't report a zero difference + if the actual difference is nonzero, as that would cause a false + match; and don't oscillate between two values, as that would + confuse the spring-forward gap detector. */ + return (*t < TIME_T_MIDPOINT + ? (*t <= TIME_T_MIN + 1 ? *t + 1 : TIME_T_MIN) + : (TIME_T_MAX - 1 <= *t ? *t - 1 : TIME_T_MAX)); +} + +/* Use CONVERT to convert *T to a broken down time in *TP. + If *T is out of range for conversion, adjust it so that + it is the nearest in-range value and then convert that. */ +static struct tm * +ranged_convert (struct tm *(*convert) (const time_t *, struct tm *), + time_t *t, struct tm *tp) +{ + struct tm *r = convert (t, tp); + + if (!r && *t) + { + time_t bad = *t; + time_t ok = 0; + + /* BAD is a known unconvertible time_t, and OK is a known good one. + Use binary search to narrow the range between BAD and OK until + they differ by 1. */ + while (bad != ok + (bad < 0 ? -1 : 1)) + { + time_t mid = *t = time_t_avg (ok, bad); + r = convert (t, tp); + if (r) + ok = mid; + else + bad = mid; + } + + if (!r && ok) + { + /* The last conversion attempt failed; + revert to the most recent successful attempt. */ + *t = ok; + r = convert (t, tp); + } + } + + return r; +} + + +/* Convert *TP to a time_t value, inverting + the monotonic and mostly-unit-linear conversion function CONVERT. + Use *OFFSET to keep track of a guess at the offset of the result, + compared to what the result would be for UTC without leap seconds. + If *OFFSET's guess is correct, only one CONVERT call is needed. + This function is external because it is used also by timegm.c. */ +time_t +__mktime_internal (struct tm *tp, + struct tm *(*convert) (const time_t *, struct tm *), + time_t *offset) +{ + time_t t, gt, t0, t1, t2; + struct tm tm; + + /* The maximum number of probes (calls to CONVERT) should be enough + to handle any combinations of time zone rule changes, solar time, + leap seconds, and oscillations around a spring-forward gap. + POSIX.1 prohibits leap seconds, but some hosts have them anyway. */ + int remaining_probes = 6; + + /* Time requested. Copy it in case CONVERT modifies *TP; this can + occur if TP is localtime's returned value and CONVERT is localtime. */ + int sec = tp->tm_sec; + int min = tp->tm_min; + int hour = tp->tm_hour; + int mday = tp->tm_mday; + int mon = tp->tm_mon; + int year_requested = tp->tm_year; + int isdst = tp->tm_isdst; + + /* 1 if the previous probe was DST. */ + int dst2; + + /* Ensure that mon is in range, and set year accordingly. */ + int mon_remainder = mon % 12; + int negative_mon_remainder = mon_remainder < 0; + int mon_years = mon / 12 - negative_mon_remainder; + long_int lyear_requested = year_requested; + long_int year = lyear_requested + mon_years; + + /* The other values need not be in range: + the remaining code handles minor overflows correctly, + assuming int and time_t arithmetic wraps around. + Major overflows are caught at the end. */ + + /* Calculate day of year from year, month, and day of month. + The result need not be in range. */ + int mon_yday = ((__mon_yday[leapyear (year)] + [mon_remainder + 12 * negative_mon_remainder]) + - 1); + long_int lmday = mday; + long_int yday = mon_yday + lmday; + + time_t guessed_offset = *offset; + + int sec_requested = sec; + + if (LEAP_SECONDS_POSSIBLE) + { + /* Handle out-of-range seconds specially, + since ydhms_tm_diff assumes every minute has 60 seconds. */ + if (sec < 0) + sec = 0; + if (59 < sec) + sec = 59; + } + + /* Invert CONVERT by probing. First assume the same offset as last + time. */ + + t0 = ydhms_diff (year, yday, hour, min, sec, + EPOCH_YEAR - TM_YEAR_BASE, 0, 0, 0, - guessed_offset); + + if (TIME_T_MAX / INT_MAX / 366 / 24 / 60 / 60 < 3) + { + /* time_t isn't large enough to rule out overflows, so check + for major overflows. A gross check suffices, since if t0 + has overflowed, it is off by a multiple of TIME_T_MAX - + TIME_T_MIN + 1. So ignore any component of the difference + that is bounded by a small value. */ + + /* Approximate log base 2 of the number of time units per + biennium. A biennium is 2 years; use this unit instead of + years to avoid integer overflow. For example, 2 average + Gregorian years are 2 * 365.2425 * 24 * 60 * 60 seconds, + which is 63113904 seconds, and rint (log2 (63113904)) is + 26. */ + int ALOG2_SECONDS_PER_BIENNIUM = 26; + int ALOG2_MINUTES_PER_BIENNIUM = 20; + int ALOG2_HOURS_PER_BIENNIUM = 14; + int ALOG2_DAYS_PER_BIENNIUM = 10; + int LOG2_YEARS_PER_BIENNIUM = 1; + + int approx_requested_biennia = + (SHR (year_requested, LOG2_YEARS_PER_BIENNIUM) + - SHR (EPOCH_YEAR - TM_YEAR_BASE, LOG2_YEARS_PER_BIENNIUM) + + SHR (mday, ALOG2_DAYS_PER_BIENNIUM) + + SHR (hour, ALOG2_HOURS_PER_BIENNIUM) + + SHR (min, ALOG2_MINUTES_PER_BIENNIUM) + + (LEAP_SECONDS_POSSIBLE + ? 0 + : SHR (sec, ALOG2_SECONDS_PER_BIENNIUM))); + + int approx_biennia = SHR (t0, ALOG2_SECONDS_PER_BIENNIUM); + int diff = approx_biennia - approx_requested_biennia; + int approx_abs_diff = diff < 0 ? -1 - diff : diff; + + /* IRIX 4.0.5 cc miscalculates TIME_T_MIN / 3: it erroneously + gives a positive value of 715827882. Setting a variable + first then doing math on it seems to work. + (ghazi@caip.rutgers.edu) */ + time_t time_t_max = TIME_T_MAX; + time_t time_t_min = TIME_T_MIN; + time_t overflow_threshold = + (time_t_max / 3 - time_t_min / 3) >> ALOG2_SECONDS_PER_BIENNIUM; + + if (overflow_threshold < approx_abs_diff) + { + /* Overflow occurred. Try repairing it; this might work if + the time zone offset is enough to undo the overflow. */ + time_t repaired_t0 = -1 - t0; + approx_biennia = SHR (repaired_t0, ALOG2_SECONDS_PER_BIENNIUM); + diff = approx_biennia - approx_requested_biennia; + approx_abs_diff = diff < 0 ? -1 - diff : diff; + if (overflow_threshold < approx_abs_diff) + return -1; + guessed_offset += repaired_t0 - t0; + t0 = repaired_t0; + } + } + + /* Repeatedly use the error to improve the guess. */ + + for (t = t1 = t2 = t0, dst2 = 0; + (gt = guess_time_tm (year, yday, hour, min, sec, &t, + ranged_convert (convert, &t, &tm)), + t != gt); + t1 = t2, t2 = t, t = gt, dst2 = tm.tm_isdst != 0) + if (t == t1 && t != t2 + && (tm.tm_isdst < 0 + || (isdst < 0 + ? dst2 <= (tm.tm_isdst != 0) + : (isdst != 0) != (tm.tm_isdst != 0)))) + /* We can't possibly find a match, as we are oscillating + between two values. The requested time probably falls + within a spring-forward gap of size GT - T. Follow the common + practice in this case, which is to return a time that is GT - T + away from the requested time, preferring a time whose + tm_isdst differs from the requested value. (If no tm_isdst + was requested and only one of the two values has a nonzero + tm_isdst, prefer that value.) In practice, this is more + useful than returning -1. */ + goto offset_found; + else if (--remaining_probes == 0) + return -1; + + /* We have a match. Check whether tm.tm_isdst has the requested + value, if any. */ + if (isdst_differ (isdst, tm.tm_isdst)) + { + /* tm.tm_isdst has the wrong value. Look for a neighboring + time with the right value, and use its UTC offset. + + Heuristic: probe the adjacent timestamps in both directions, + looking for the desired isdst. This should work for all real + time zone histories in the tz database. */ + + /* Distance between probes when looking for a DST boundary. In + tzdata2003a, the shortest period of DST is 601200 seconds + (e.g., America/Recife starting 2000-10-08 01:00), and the + shortest period of non-DST surrounded by DST is 694800 + seconds (Africa/Tunis starting 1943-04-17 01:00). Use the + minimum of these two values, so we don't miss these short + periods when probing. */ + int stride = 601200; + + /* The longest period of DST in tzdata2003a is 536454000 seconds + (e.g., America/Jujuy starting 1946-10-01 01:00). The longest + period of non-DST is much longer, but it makes no real sense + to search for more than a year of non-DST, so use the DST + max. */ + int duration_max = 536454000; + + /* Search in both directions, so the maximum distance is half + the duration; add the stride to avoid off-by-1 problems. */ + int delta_bound = duration_max / 2 + stride; + + int delta, direction; + + for (delta = stride; delta < delta_bound; delta += stride) + for (direction = -1; direction <= 1; direction += 2) + if (time_t_int_add_ok (t, delta * direction)) + { + time_t ot = t + delta * direction; + struct tm otm; + ranged_convert (convert, &ot, &otm); + if (! isdst_differ (isdst, otm.tm_isdst)) + { + /* We found the desired tm_isdst. + Extrapolate back to the desired time. */ + t = guess_time_tm (year, yday, hour, min, sec, &ot, &otm); + ranged_convert (convert, &t, &tm); + goto offset_found; + } + } + } + + offset_found: + *offset = guessed_offset + t - t0; + + if (LEAP_SECONDS_POSSIBLE && sec_requested != tm.tm_sec) + { + /* Adjust time to reflect the tm_sec requested, not the normalized value. + Also, repair any damage from a false match due to a leap second. */ + int sec_adjustment = (sec == 0 && tm.tm_sec == 60) - sec; + if (! time_t_int_add_ok (t, sec_requested)) + return -1; + t1 = t + sec_requested; + if (! time_t_int_add_ok (t1, sec_adjustment)) + return -1; + t2 = t1 + sec_adjustment; + if (! convert (&t2, &tm)) + return -1; + t = t2; + } + + *tp = tm; + return t; +} + + +/* FIXME: This should use a signed type wide enough to hold any UTC + offset in seconds. 'int' should be good enough for GNU code. We + can't fix this unilaterally though, as other modules invoke + __mktime_internal. */ +static time_t localtime_offset; + +/* Convert *TP to a time_t value. */ +time_t +mktime (struct tm *tp) +{ +#ifdef _LIBC + /* POSIX.1 8.1.1 requires that whenever mktime() is called, the + time zone names contained in the external variable 'tzname' shall + be set as if the tzset() function had been called. */ + __tzset (); +#endif + + return __mktime_internal (tp, __localtime_r, &localtime_offset); +} + +#ifdef weak_alias +weak_alias (mktime, timelocal) +#endif + +#ifdef _LIBC +libc_hidden_def (mktime) +libc_hidden_weak (timelocal) +#endif + +#if defined DEBUG && DEBUG + +static int +not_equal_tm (const struct tm *a, const struct tm *b) +{ + return ((a->tm_sec ^ b->tm_sec) + | (a->tm_min ^ b->tm_min) + | (a->tm_hour ^ b->tm_hour) + | (a->tm_mday ^ b->tm_mday) + | (a->tm_mon ^ b->tm_mon) + | (a->tm_year ^ b->tm_year) + | (a->tm_yday ^ b->tm_yday) + | isdst_differ (a->tm_isdst, b->tm_isdst)); +} + +static void +print_tm (const struct tm *tp) +{ + if (tp) + printf ("%04d-%02d-%02d %02d:%02d:%02d yday %03d wday %d isdst %d", + tp->tm_year + TM_YEAR_BASE, tp->tm_mon + 1, tp->tm_mday, + tp->tm_hour, tp->tm_min, tp->tm_sec, + tp->tm_yday, tp->tm_wday, tp->tm_isdst); + else + printf ("0"); +} + +static int +check_result (time_t tk, struct tm tmk, time_t tl, const struct tm *lt) +{ + if (tk != tl || !lt || not_equal_tm (&tmk, lt)) + { + printf ("mktime ("); + print_tm (lt); + printf (")\nyields ("); + print_tm (&tmk); + printf (") == %ld, should be %ld\n", (long int) tk, (long int) tl); + return 1; + } + + return 0; +} + +int +main (int argc, char **argv) +{ + int status = 0; + struct tm tm, tmk, tml; + struct tm *lt; + time_t tk, tl, tl1; + char trailer; + + if ((argc == 3 || argc == 4) + && (sscanf (argv[1], "%d-%d-%d%c", + &tm.tm_year, &tm.tm_mon, &tm.tm_mday, &trailer) + == 3) + && (sscanf (argv[2], "%d:%d:%d%c", + &tm.tm_hour, &tm.tm_min, &tm.tm_sec, &trailer) + == 3)) + { + tm.tm_year -= TM_YEAR_BASE; + tm.tm_mon--; + tm.tm_isdst = argc == 3 ? -1 : atoi (argv[3]); + tmk = tm; + tl = mktime (&tmk); + lt = localtime (&tl); + if (lt) + { + tml = *lt; + lt = &tml; + } + printf ("mktime returns %ld == ", (long int) tl); + print_tm (&tmk); + printf ("\n"); + status = check_result (tl, tmk, tl, lt); + } + else if (argc == 4 || (argc == 5 && strcmp (argv[4], "-") == 0)) + { + time_t from = atol (argv[1]); + time_t by = atol (argv[2]); + time_t to = atol (argv[3]); + + if (argc == 4) + for (tl = from; by < 0 ? to <= tl : tl <= to; tl = tl1) + { + lt = localtime (&tl); + if (lt) + { + tmk = tml = *lt; + tk = mktime (&tmk); + status |= check_result (tk, tmk, tl, &tml); + } + else + { + printf ("localtime (%ld) yields 0\n", (long int) tl); + status = 1; + } + tl1 = tl + by; + if ((tl1 < tl) != (by < 0)) + break; + } + else + for (tl = from; by < 0 ? to <= tl : tl <= to; tl = tl1) + { + /* Null benchmark. */ + lt = localtime (&tl); + if (lt) + { + tmk = tml = *lt; + tk = tl; + status |= check_result (tk, tmk, tl, &tml); + } + else + { + printf ("localtime (%ld) yields 0\n", (long int) tl); + status = 1; + } + tl1 = tl + by; + if ((tl1 < tl) != (by < 0)) + break; + } + } + else + printf ("Usage:\ +\t%s YYYY-MM-DD HH:MM:SS [ISDST] # Test given time.\n\ +\t%s FROM BY TO # Test values FROM, FROM+BY, ..., TO.\n\ +\t%s FROM BY TO - # Do not test those values (for benchmark).\n", + argv[0], argv[0], argv[0]); + + return status; +} + +#endif /* DEBUG */ + +/* +Local Variables: +compile-command: "gcc -DDEBUG -I. -Wall -W -O2 -g mktime.c -o mktime" +End: +*/ diff --git a/lib/msvc-inval.c b/lib/msvc-inval.c index 84190d097..7ee21e437 100644 --- a/lib/msvc-inval.c +++ b/lib/msvc-inval.c @@ -1,5 +1,5 @@ /* Invalid parameter handler for MSVC runtime libraries. - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/msvc-inval.h b/lib/msvc-inval.h index c6df57e93..c73511df2 100644 --- a/lib/msvc-inval.h +++ b/lib/msvc-inval.h @@ -1,5 +1,5 @@ /* Invalid parameter handler for MSVC runtime libraries. - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/msvc-nothrow.c b/lib/msvc-nothrow.c index 9b1eb598e..868388183 100644 --- a/lib/msvc-nothrow.c +++ b/lib/msvc-nothrow.c @@ -1,6 +1,6 @@ /* Wrappers that don't throw invalid parameter notifications with MSVC runtime libraries. - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/msvc-nothrow.h b/lib/msvc-nothrow.h index 1917325b3..f596aaf45 100644 --- a/lib/msvc-nothrow.h +++ b/lib/msvc-nothrow.h @@ -1,6 +1,6 @@ /* Wrappers that don't throw invalid parameter notifications with MSVC runtime libraries. - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/netdb.in.h b/lib/netdb.in.h index 3613fb5a5..530a5335a 100644 --- a/lib/netdb.in.h +++ b/lib/netdb.in.h @@ -1,5 +1,5 @@ /* Provide a netdb.h header file for systems lacking it (read: MinGW). - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. Written by Simon Josefsson. This program is free software; you can redistribute it and/or modify diff --git a/lib/netinet_in.in.h b/lib/netinet_in.in.h index 8ab66a1df..e4709bbaf 100644 --- a/lib/netinet_in.in.h +++ b/lib/netinet_in.in.h @@ -1,5 +1,5 @@ /* Substitute for . - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/nl_langinfo.c b/lib/nl_langinfo.c index 83d2c77af..ff0adc4b9 100644 --- a/lib/nl_langinfo.c +++ b/lib/nl_langinfo.c @@ -1,6 +1,6 @@ /* nl_langinfo() replacement: query locale dependent information. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -20,13 +20,72 @@ /* Specification. */ #include +#include +#include +#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ +# define WIN32_LEAN_AND_MEAN /* avoid including junk */ +# include +# include +#endif + +/* Return the codeset of the current locale, if this is easily deducible. + Otherwise, return "". */ +static char * +ctype_codeset (void) +{ + static char buf[2 + 10 + 1]; + size_t buflen = 0; + char const *locale = setlocale (LC_CTYPE, NULL); + char *codeset = buf; + size_t codesetlen; + codeset[0] = '\0'; + + if (locale && locale[0]) + { + /* If the locale name contains an encoding after the dot, return it. */ + char *dot = strchr (locale, '.'); + + if (dot) + { + /* Look for the possible @... trailer and remove it, if any. */ + char *codeset_start = dot + 1; + char const *modifier = strchr (codeset_start, '@'); + + if (! modifier) + codeset = codeset_start; + else + { + codesetlen = modifier - codeset_start; + if (codesetlen < sizeof buf) + { + codeset = memcpy (buf, codeset_start, codesetlen); + codeset[codesetlen] = '\0'; + } + } + } + } + +#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ + /* If setlocale is successful, it returns the number of the + codepage, as a string. Otherwise, fall back on Windows API + GetACP, which returns the locale's codepage as a number (although + this doesn't change according to what the 'setlocale' call specified). + Either way, prepend "CP" to make it a valid codeset name. */ + codesetlen = strlen (codeset); + if (0 < codesetlen && codesetlen < sizeof buf - 2) + memmove (buf + 2, codeset, codesetlen + 1); + else + sprintf (buf + 2, "%u", GetACP ()); + codeset = memcpy (buf, "CP", 2); +#endif + return codeset; +} + + #if REPLACE_NL_LANGINFO /* Override nl_langinfo with support for added nl_item values. */ -# include -# include - # undef nl_langinfo char * @@ -36,36 +95,7 @@ rpl_nl_langinfo (nl_item item) { # if GNULIB_defined_CODESET case CODESET: - { - const char *locale; - static char buf[2 + 10 + 1]; - - locale = setlocale (LC_CTYPE, NULL); - if (locale != NULL && locale[0] != '\0') - { - /* If the locale name contains an encoding after the dot, return - it. */ - const char *dot = strchr (locale, '.'); - - if (dot != NULL) - { - const char *modifier; - - dot++; - /* Look for the possible @... trailer and remove it, if any. */ - modifier = strchr (dot, '@'); - if (modifier == NULL) - return dot; - if (modifier - dot < sizeof (buf)) - { - memcpy (buf, dot, modifier - dot); - buf [modifier - dot] = '\0'; - return buf; - } - } - } - return ""; - } + return ctype_codeset (); # endif # if GNULIB_defined_T_FMT_AMPM case T_FMT_AMPM: @@ -111,42 +141,28 @@ rpl_nl_langinfo (nl_item item) #else -/* Provide nl_langinfo from scratch. */ +/* Provide nl_langinfo from scratch, either for native MS-Windows, or + for old Unix platforms without locales, such as Linux libc5 or + BeOS. */ -# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ - -/* Native Windows platforms. */ - -# define WIN32_LEAN_AND_MEAN /* avoid including junk */ -# include - -# include - -# else - -/* An old Unix platform without locales, such as Linux libc5 or BeOS. */ - -# endif - -# include +# include char * nl_langinfo (nl_item item) { + static char nlbuf[100]; + struct tm tmm = { 0 }; + switch (item) { /* nl_langinfo items of the LC_CTYPE category */ case CODESET: -# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ { - static char buf[2 + 10 + 1]; - - /* The Windows API has a function returning the locale's codepage as - a number. */ - sprintf (buf, "CP%u", GetACP ()); - return buf; + char *codeset = ctype_codeset (); + if (*codeset) + return codeset; } -# elif defined __BEOS__ +# ifdef __BEOS__ return "UTF-8"; # else return "ISO-8859-1"; @@ -156,6 +172,8 @@ nl_langinfo (nl_item item) return localeconv () ->decimal_point; case THOUSEP: return localeconv () ->thousands_sep; + case GROUPING: + return localeconv () ->grouping; /* nl_langinfo items of the LC_TIME category. TODO: Really use the locale. */ case D_T_FMT: @@ -170,93 +188,126 @@ nl_langinfo (nl_item item) case T_FMT_AMPM: return "%I:%M:%S %p"; case AM_STR: - return "AM"; + if (!strftime (nlbuf, sizeof nlbuf, "%p", &tmm)) + return "AM"; + return nlbuf; case PM_STR: - return "PM"; + tmm.tm_hour = 12; + if (!strftime (nlbuf, sizeof nlbuf, "%p", &tmm)) + return "PM"; + return nlbuf; case DAY_1: - return "Sunday"; case DAY_2: - return "Monday"; case DAY_3: - return "Tuesday"; case DAY_4: - return "Wednesday"; case DAY_5: - return "Thursday"; case DAY_6: - return "Friday"; case DAY_7: - return "Saturday"; + { + static char const days[][sizeof "Wednesday"] = { + "Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", + "Friday", "Saturday" + }; + tmm.tm_wday = item - DAY_1; + if (!strftime (nlbuf, sizeof nlbuf, "%A", &tmm)) + return (char *) days[item - DAY_1]; + return nlbuf; + } case ABDAY_1: - return "Sun"; case ABDAY_2: - return "Mon"; case ABDAY_3: - return "Tue"; case ABDAY_4: - return "Wed"; case ABDAY_5: - return "Thu"; case ABDAY_6: - return "Fri"; case ABDAY_7: - return "Sat"; + { + static char const abdays[][sizeof "Sun"] = { + "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" + }; + tmm.tm_wday = item - ABDAY_1; + if (!strftime (nlbuf, sizeof nlbuf, "%a", &tmm)) + return (char *) abdays[item - ABDAY_1]; + return nlbuf; + } case MON_1: - return "January"; case MON_2: - return "February"; case MON_3: - return "March"; case MON_4: - return "April"; case MON_5: - return "May"; case MON_6: - return "June"; case MON_7: - return "July"; case MON_8: - return "August"; case MON_9: - return "September"; case MON_10: - return "October"; case MON_11: - return "November"; case MON_12: - return "December"; + { + static char const months[][sizeof "September"] = { + "January", "February", "March", "April", "May", "June", "July", + "September", "October", "November", "December" + }; + tmm.tm_mon = item - MON_1; + if (!strftime (nlbuf, sizeof nlbuf, "%B", &tmm)) + return (char *) months[item - MON_1]; + return nlbuf; + } case ABMON_1: - return "Jan"; case ABMON_2: - return "Feb"; case ABMON_3: - return "Mar"; case ABMON_4: - return "Apr"; case ABMON_5: - return "May"; case ABMON_6: - return "Jun"; case ABMON_7: - return "Jul"; case ABMON_8: - return "Aug"; case ABMON_9: - return "Sep"; case ABMON_10: - return "Oct"; case ABMON_11: - return "Nov"; case ABMON_12: - return "Dec"; + { + static char const abmonths[][sizeof "Jan"] = { + "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", + "Sep", "Oct", "Nov", "Dec" + }; + tmm.tm_mon = item - ABMON_1; + if (!strftime (nlbuf, sizeof nlbuf, "%b", &tmm)) + return (char *) abmonths[item - ABMON_1]; + return nlbuf; + } case ERA: return ""; case ALT_DIGITS: return "\0\0\0\0\0\0\0\0\0\0"; - /* nl_langinfo items of the LC_MONETARY category - TODO: Really use the locale. */ + /* nl_langinfo items of the LC_MONETARY category. */ case CRNCYSTR: - return "-"; + return localeconv () ->currency_symbol; + case INT_CURR_SYMBOL: + return localeconv () ->int_curr_symbol; + case MON_DECIMAL_POINT: + return localeconv () ->mon_decimal_point; + case MON_THOUSANDS_SEP: + return localeconv () ->mon_thousands_sep; + case MON_GROUPING: + return localeconv () ->mon_grouping; + case POSITIVE_SIGN: + return localeconv () ->positive_sign; + case NEGATIVE_SIGN: + return localeconv () ->negative_sign; + case FRAC_DIGITS: + return & localeconv () ->frac_digits; + case INT_FRAC_DIGITS: + return & localeconv () ->int_frac_digits; + case P_CS_PRECEDES: + return & localeconv () ->p_cs_precedes; + case N_CS_PRECEDES: + return & localeconv () ->n_cs_precedes; + case P_SEP_BY_SPACE: + return & localeconv () ->p_sep_by_space; + case N_SEP_BY_SPACE: + return & localeconv () ->n_sep_by_space; + case P_SIGN_POSN: + return & localeconv () ->p_sign_posn; + case N_SIGN_POSN: + return & localeconv () ->n_sign_posn; /* nl_langinfo items of the LC_MESSAGES category TODO: Really use the locale. */ case YESEXPR: diff --git a/lib/nproc.c b/lib/nproc.c index 293c65169..b1c25b138 100644 --- a/lib/nproc.c +++ b/lib/nproc.c @@ -1,6 +1,6 @@ /* Detect the number of processors. - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/nproc.h b/lib/nproc.h index dbc315707..4c49777aa 100644 --- a/lib/nproc.h +++ b/lib/nproc.h @@ -1,6 +1,6 @@ /* Detect the number of processors. - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/open.c b/lib/open.c index f6fd06e4c..4345943d2 100644 --- a/lib/open.c +++ b/lib/open.c @@ -1,5 +1,5 @@ /* Open a descriptor to a file. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/pathmax.h b/lib/pathmax.h index 15ed6c28e..c4c94528f 100644 --- a/lib/pathmax.h +++ b/lib/pathmax.h @@ -1,5 +1,5 @@ /* Define PATH_MAX somehow. Requires sys/types.h. - Copyright (C) 1992, 1999, 2001, 2003, 2005, 2009-2014 Free Software + Copyright (C) 1992, 1999, 2001, 2003, 2005, 2009-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/pipe.c b/lib/pipe.c index 03aed5ef9..d733ed068 100644 --- a/lib/pipe.c +++ b/lib/pipe.c @@ -1,5 +1,5 @@ /* Create a pipe. - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/pipe2.c b/lib/pipe2.c index 4e4e894e7..94a79e219 100644 --- a/lib/pipe2.c +++ b/lib/pipe2.c @@ -1,5 +1,5 @@ /* Create a pipe, with specific opening flags. - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/poll.c b/lib/poll.c index 7b1e58266..e70e8b354 100644 --- a/lib/poll.c +++ b/lib/poll.c @@ -1,7 +1,7 @@ /* Emulation for poll(2) Contributed by Paolo Bonzini. - Copyright 2001-2003, 2006-2014 Free Software Foundation, Inc. + Copyright 2001-2003, 2006-2015 Free Software Foundation, Inc. This file is part of gnulib. @@ -33,7 +33,6 @@ #include #include -#include #if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ # define WINDOWS_NATIVE @@ -45,11 +44,12 @@ # include "msvc-nothrow.h" #else # include -# include -# include # include #endif +#include +#include + #ifdef HAVE_SYS_IOCTL_H # include #endif @@ -59,6 +59,8 @@ #include +#include "assure.h" + #ifndef INFTIM # define INFTIM (-1) #endif @@ -70,9 +72,11 @@ #ifdef WINDOWS_NATIVE -/* Optimized test whether a HANDLE refers to a console. - See . */ -#define IsConsoleHandle(h) (((intptr_t) (h) & 3) == 3) +static BOOL IsConsoleHandle (HANDLE h) +{ + DWORD mode; + return GetConsoleMode (h, &mode) != 0; +} static BOOL IsSocketHandle (HANDLE h) @@ -331,26 +335,15 @@ poll (struct pollfd *pfd, nfds_t nfd, int timeout) int maxfd, rc; nfds_t i; -# ifdef _SC_OPEN_MAX - static int sc_open_max = -1; - - if (nfd < 0 - || (nfd > sc_open_max - && (sc_open_max != -1 - || nfd > (sc_open_max = sysconf (_SC_OPEN_MAX))))) + if (nfd < 0) { errno = EINVAL; return -1; } -# else /* !_SC_OPEN_MAX */ -# ifdef OPEN_MAX - if (nfd < 0 || nfd > OPEN_MAX) - { - errno = EINVAL; - return -1; - } -# endif /* OPEN_MAX -- else, no check is needed */ -# endif /* !_SC_OPEN_MAX */ + /* Don't check directly for NFD too large. Any practical use of a + too-large NFD is caught by one of the other checks below, and + checking directly for getdtablesize is too much of a portability + and/or performance and/or correctness hassle. */ /* EFAULT is not necessary to implement, but let's do it in the simplest case. */ @@ -391,10 +384,17 @@ poll (struct pollfd *pfd, nfds_t nfd, int timeout) { if (pfd[i].fd < 0) continue; - + if (maxfd < pfd[i].fd) + { + maxfd = pfd[i].fd; + if (FD_SETSIZE <= maxfd) + { + errno = EINVAL; + return -1; + } + } if (pfd[i].events & (POLLIN | POLLRDNORM)) FD_SET (pfd[i].fd, &rfds); - /* see select(2): "the only exceptional condition detectable is out-of-band data received on a socket", hence we push POLLWRBAND events onto wfds instead of efds. */ @@ -402,18 +402,6 @@ poll (struct pollfd *pfd, nfds_t nfd, int timeout) FD_SET (pfd[i].fd, &wfds); if (pfd[i].events & (POLLPRI | POLLRDBAND)) FD_SET (pfd[i].fd, &efds); - if (pfd[i].fd >= maxfd - && (pfd[i].events & (POLLIN | POLLOUT | POLLPRI - | POLLRDNORM | POLLRDBAND - | POLLWRNORM | POLLWRBAND))) - { - maxfd = pfd[i].fd; - if (maxfd > FD_SETSIZE) - { - errno = EOVERFLOW; - return -1; - } - } } /* examine fd sets */ @@ -424,18 +412,13 @@ poll (struct pollfd *pfd, nfds_t nfd, int timeout) /* establish results */ rc = 0; for (i = 0; i < nfd; i++) - if (pfd[i].fd < 0) - pfd[i].revents = 0; - else - { - int happened = compute_revents (pfd[i].fd, pfd[i].events, - &rfds, &wfds, &efds); - if (happened) - { - pfd[i].revents = happened; - rc++; - } - } + { + pfd[i].revents = (pfd[i].fd < 0 + ? 0 + : compute_revents (pfd[i].fd, pfd[i].events, + &rfds, &wfds, &efds)); + rc += pfd[i].revents != 0; + } return rc; #else @@ -478,7 +461,7 @@ restart: continue; h = (HANDLE) _get_osfhandle (pfd[i].fd); - assert (h != NULL); + assure (h != NULL); if (IsSocketHandle (h)) { int requested = FD_CLOSE; diff --git a/lib/poll.in.h b/lib/poll.in.h index bde98064f..0a9950157 100644 --- a/lib/poll.in.h +++ b/lib/poll.in.h @@ -1,7 +1,7 @@ /* Header for poll(2) emulation Contributed by Paolo Bonzini. - Copyright 2001-2003, 2007, 2009-2014 Free Software Foundation, Inc. + Copyright 2001-2003, 2007, 2009-2015 Free Software Foundation, Inc. This file is part of gnulib. diff --git a/lib/printf-args.c b/lib/printf-args.c index 9673e6ddc..de7a6bf3f 100644 --- a/lib/printf-args.c +++ b/lib/printf-args.c @@ -1,5 +1,5 @@ /* Decomposed printf argument list. - Copyright (C) 1999, 2002-2003, 2005-2007, 2009-2014 Free Software + Copyright (C) 1999, 2002-2003, 2005-2007, 2009-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/printf-args.h b/lib/printf-args.h index 831c14738..a413b5270 100644 --- a/lib/printf-args.h +++ b/lib/printf-args.h @@ -1,5 +1,5 @@ /* Decomposed printf argument list. - Copyright (C) 1999, 2002-2003, 2006-2007, 2011-2014 Free Software + Copyright (C) 1999, 2002-2003, 2006-2007, 2011-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/printf-parse.c b/lib/printf-parse.c index e6a09a8de..b4592363b 100644 --- a/lib/printf-parse.c +++ b/lib/printf-parse.c @@ -1,5 +1,5 @@ /* Formatted output to strings. - Copyright (C) 1999-2000, 2002-2003, 2006-2014 Free Software Foundation, Inc. + Copyright (C) 1999-2000, 2002-2003, 2006-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/printf-parse.h b/lib/printf-parse.h index 44d6f5513..d35ffcaf1 100644 --- a/lib/printf-parse.h +++ b/lib/printf-parse.h @@ -1,5 +1,5 @@ /* Parse printf format string. - Copyright (C) 1999, 2002-2003, 2005, 2007, 2010-2014 Free Software + Copyright (C) 1999, 2002-2003, 2005, 2007, 2010-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/putenv.c b/lib/putenv.c index de8caa712..54687629c 100644 --- a/lib/putenv.c +++ b/lib/putenv.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1991, 1994, 1997-1998, 2000, 2003-2014 Free Software +/* Copyright (C) 1991, 1994, 1997-1998, 2000, 2003-2015 Free Software Foundation, Inc. NOTE: The canonical source of this file is maintained with the GNU C diff --git a/lib/raise.c b/lib/raise.c index 2f04eea9b..b099b58d1 100644 --- a/lib/raise.c +++ b/lib/raise.c @@ -1,6 +1,6 @@ /* Provide a non-threads replacement for the POSIX raise function. - Copyright (C) 2002-2003, 2005-2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2002-2003, 2005-2006, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/read.c b/lib/read.c index 4efe8ce23..7edb99110 100644 --- a/lib/read.c +++ b/lib/read.c @@ -1,5 +1,5 @@ /* POSIX compatible read() function. - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/readlink.c b/lib/readlink.c index ef502f57b..d86f822aa 100644 --- a/lib/readlink.c +++ b/lib/readlink.c @@ -1,5 +1,5 @@ /* Stub for readlink(). - Copyright (C) 2003-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2003-2007, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/recv.c b/lib/recv.c index fc7e12406..edb7e01f1 100644 --- a/lib/recv.c +++ b/lib/recv.c @@ -1,6 +1,6 @@ /* recv.c --- wrappers for Windows recv function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/recvfrom.c b/lib/recvfrom.c index 0d4fba076..4ecffb0e0 100644 --- a/lib/recvfrom.c +++ b/lib/recvfrom.c @@ -1,6 +1,6 @@ /* recvfrom.c --- wrappers for Windows recvfrom function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/ref-add.sin b/lib/ref-add.sin index 9adfb0df0..4d406a37d 100644 --- a/lib/ref-add.sin +++ b/lib/ref-add.sin @@ -1,6 +1,6 @@ # Add this package to a list of references stored in a text file. # -# Copyright (C) 2000, 2009-2014 Free Software Foundation, Inc. +# Copyright (C) 2000, 2009-2015 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/ref-del.sin b/lib/ref-del.sin index 45449cbba..5b4ff6246 100644 --- a/lib/ref-del.sin +++ b/lib/ref-del.sin @@ -1,6 +1,6 @@ # Remove this package from a list of references stored in a text file. # -# Copyright (C) 2000, 2009-2014 Free Software Foundation, Inc. +# Copyright (C) 2000, 2009-2015 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/regcomp.c b/lib/regcomp.c index 56faf11c4..4cbb1b2b9 100644 --- a/lib/regcomp.c +++ b/lib/regcomp.c @@ -1,5 +1,5 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2014 Free Software Foundation, Inc. + Copyright (C) 2002-2015 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa . @@ -17,6 +17,10 @@ License along with the GNU C Library; if not, see . */ +#ifdef _LIBC +# include +#endif + static reg_errcode_t re_compile_internal (regex_t *preg, const char * pattern, size_t length, reg_syntax_t syntax); static void re_compile_fastmap_iter (regex_t *bufp, @@ -335,7 +339,7 @@ re_compile_fastmap_iter (regex_t *bufp, const re_dfastate_t *init_state, memset (&state, '\0', sizeof (state)); if (__mbrtowc (&wc, (const char *) buf, p - buf, &state) == p - buf - && (__wcrtomb ((char *) buf, towlower (wc), &state) + && (__wcrtomb ((char *) buf, __towlower (wc), &state) != (size_t) -1)) re_set_fastmap (fastmap, false, buf[0]); } @@ -411,7 +415,7 @@ re_compile_fastmap_iter (regex_t *bufp, const re_dfastate_t *init_state, re_set_fastmap (fastmap, icase, *(unsigned char *) buf); if ((bufp->syntax & RE_ICASE) && dfa->mb_cur_max > 1) { - if (__wcrtomb (buf, towlower (cset->mbchars[i]), &state) + if (__wcrtomb (buf, __towlower (cset->mbchars[i]), &state) != (size_t) -1) re_set_fastmap (fastmap, false, *(unsigned char *) buf); } @@ -2187,6 +2191,7 @@ parse_reg_exp (re_string_t *regexp, regex_t *preg, re_token_t *token, { re_dfa_t *dfa = preg->buffer; bin_tree_t *tree, *branch = NULL; + bitset_word_t initial_bkref_map = dfa->completed_bkref_map; tree = parse_branch (regexp, preg, token, syntax, nest, err); if (BE (*err != REG_NOERROR && tree == NULL, 0)) return NULL; @@ -2197,9 +2202,16 @@ parse_reg_exp (re_string_t *regexp, regex_t *preg, re_token_t *token, if (token->type != OP_ALT && token->type != END_OF_RE && (nest == 0 || token->type != OP_CLOSE_SUBEXP)) { + bitset_word_t accumulated_bkref_map = dfa->completed_bkref_map; + dfa->completed_bkref_map = initial_bkref_map; branch = parse_branch (regexp, preg, token, syntax, nest, err); if (BE (*err != REG_NOERROR && branch == NULL, 0)) - return NULL; + { + if (tree != NULL) + postorder (tree, free_tree, NULL); + return NULL; + } + dfa->completed_bkref_map |= accumulated_bkref_map; } else branch = NULL; @@ -2460,14 +2472,22 @@ parse_expression (re_string_t *regexp, regex_t *preg, re_token_t *token, while (token->type == OP_DUP_ASTERISK || token->type == OP_DUP_PLUS || token->type == OP_DUP_QUESTION || token->type == OP_OPEN_DUP_NUM) { - tree = parse_dup_op (tree, regexp, dfa, token, syntax, err); - if (BE (*err != REG_NOERROR && tree == NULL, 0)) - return NULL; + bin_tree_t *dup_tree = parse_dup_op (tree, regexp, dfa, token, + syntax, err); + if (BE (*err != REG_NOERROR && dup_tree == NULL, 0)) + { + if (tree != NULL) + postorder (tree, free_tree, NULL); + return NULL; + } + tree = dup_tree; /* In BRE consecutive duplications are not allowed. */ if ((syntax & RE_CONTEXT_INVALID_DUP) && (token->type == OP_DUP_ASTERISK || token->type == OP_OPEN_DUP_NUM)) { + if (tree != NULL) + postorder (tree, free_tree, NULL); *err = REG_BADRPT; return NULL; } @@ -2623,6 +2643,8 @@ parse_dup_op (bin_tree_t *elem, re_string_t *regexp, re_dfa_t *dfa, /* Duplicate ELEM before it is marked optional. */ elem = duplicate_tree (elem, dfa); + if (BE (elem == NULL, 0)) + goto parse_dup_op_espace; old_tree = tree; } else @@ -3161,6 +3183,7 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token, re_token_t token2; start_elem.opr.name = start_name_buf; + start_elem.type = COLL_SYM; ret = parse_bracket_element (&start_elem, regexp, token, token_len, dfa, syntax, first_round); if (BE (ret != REG_NOERROR, 0)) @@ -3204,6 +3227,7 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token, if (is_range_exp == true) { end_elem.opr.name = end_name_buf; + end_elem.type = COLL_SYM; ret = parse_bracket_element (&end_elem, regexp, &token2, token_len2, dfa, syntax, true); if (BE (ret != REG_NOERROR, 0)) @@ -3478,8 +3502,6 @@ build_equiv_class (bitset_t sbcset, const unsigned char *name) int32_t idx1, idx2; unsigned int ch; size_t len; - /* This #include defines a local function! */ -# include /* Calculate the index for equivalence class. */ cp = name; table = (const int32_t *) _NL_CURRENT (LC_COLLATE, _NL_COLLATE_TABLEMB); @@ -3489,7 +3511,7 @@ build_equiv_class (bitset_t sbcset, const unsigned char *name) _NL_COLLATE_EXTRAMB); indirect = (const int32_t *) _NL_CURRENT (LC_COLLATE, _NL_COLLATE_INDIRECTMB); - idx1 = findidx (&cp, -1); + idx1 = findidx (table, indirect, extra, &cp, -1); if (BE (idx1 == 0 || *cp != '\0', 0)) /* This isn't a valid character. */ return REG_ECOLLATE; @@ -3500,7 +3522,7 @@ build_equiv_class (bitset_t sbcset, const unsigned char *name) { char_buf[0] = ch; cp = char_buf; - idx2 = findidx (&cp, 1); + idx2 = findidx (table, indirect, extra, &cp, 1); /* idx2 = table[ch]; */ diff --git a/lib/regex.c b/lib/regex.c index e44f55fd1..1adc8a8ae 100644 --- a/lib/regex.c +++ b/lib/regex.c @@ -1,5 +1,5 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2014 Free Software Foundation, Inc. + Copyright (C) 2002-2015 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa . diff --git a/lib/regex.h b/lib/regex.h index 54327c69e..6f3bae3ae 100644 --- a/lib/regex.h +++ b/lib/regex.h @@ -1,6 +1,6 @@ /* Definitions for data structures and routines for the regular expression library. - Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2014 Free Software + Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2015 Free Software Foundation, Inc. This file is part of the GNU C Library. @@ -244,19 +244,16 @@ extern reg_syntax_t re_syntax_options; | RE_INVALID_INTERVAL_ORD) # define RE_SYNTAX_GREP \ - (RE_BK_PLUS_QM | RE_CHAR_CLASSES \ - | RE_HAT_LISTS_NOT_NEWLINE | RE_INTERVALS \ - | RE_NEWLINE_ALT) + ((RE_SYNTAX_POSIX_BASIC | RE_NEWLINE_ALT) \ + & ~(RE_CONTEXT_INVALID_DUP | RE_DOT_NOT_NULL)) # define RE_SYNTAX_EGREP \ - (RE_CHAR_CLASSES | RE_CONTEXT_INDEP_ANCHORS \ - | RE_CONTEXT_INDEP_OPS | RE_HAT_LISTS_NOT_NEWLINE \ - | RE_NEWLINE_ALT | RE_NO_BK_PARENS \ - | RE_NO_BK_VBAR) + ((RE_SYNTAX_POSIX_EXTENDED | RE_INVALID_INTERVAL_ORD | RE_NEWLINE_ALT) \ + & ~(RE_CONTEXT_INVALID_OPS | RE_DOT_NOT_NULL)) +/* POSIX grep -E behavior is no longer incompatible with GNU. */ # define RE_SYNTAX_POSIX_EGREP \ - (RE_SYNTAX_EGREP | RE_INTERVALS | RE_NO_BK_BRACES \ - | RE_INVALID_INTERVAL_ORD) + RE_SYNTAX_EGREP /* P1003.2/D11.2, section 4.20.7.1, lines 5078ff. */ # define RE_SYNTAX_ED RE_SYNTAX_POSIX_BASIC @@ -608,7 +605,7 @@ extern void re_set_registers (struct re_pattern_buffer *__buffer, regoff_t *__starts, regoff_t *__ends); #endif /* Use GNU */ -#if defined _REGEX_RE_COMP || (defined _LIBC && defined __USE_BSD) +#if defined _REGEX_RE_COMP || (defined _LIBC && defined __USE_MISC) # ifndef _CRAY /* 4.2 bsd compatibility. */ extern char *re_comp (const char *); diff --git a/lib/regex_internal.c b/lib/regex_internal.c index 0343ee6e3..93d7ee964 100644 --- a/lib/regex_internal.c +++ b/lib/regex_internal.c @@ -1,5 +1,5 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2014 Free Software Foundation, Inc. + Copyright (C) 2002-2015 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa . @@ -311,13 +311,12 @@ build_wcs_upper_buffer (re_string_t *pstr) + byte_idx), remain_len, &pstr->cur_state); if (BE (mbclen < (size_t) -2, 1)) { - wchar_t wcu = wc; - if (iswlower (wc)) + wchar_t wcu = __towupper (wc); + if (wcu != wc) { size_t mbcdlen; - wcu = towupper (wc); - mbcdlen = wcrtomb (buf, wcu, &prev_st); + mbcdlen = __wcrtomb (buf, wcu, &prev_st); if (BE (mbclen == mbcdlen, 1)) memcpy (pstr->mbs + byte_idx, buf, mbclen); else @@ -381,12 +380,11 @@ build_wcs_upper_buffer (re_string_t *pstr) mbclen = __mbrtowc (&wc, p, remain_len, &pstr->cur_state); if (BE (mbclen < (size_t) -2, 1)) { - wchar_t wcu = wc; - if (iswlower (wc)) + wchar_t wcu = __towupper (wc); + if (wcu != wc) { size_t mbcdlen; - wcu = towupper (wc); mbcdlen = wcrtomb ((char *) buf, wcu, &prev_st); if (BE (mbclen == mbcdlen, 1)) memcpy (pstr->mbs + byte_idx, buf, mbclen); @@ -538,10 +536,7 @@ build_upper_buffer (re_string_t *pstr) int ch = pstr->raw_mbs[pstr->raw_mbs_idx + char_idx]; if (BE (pstr->trans != NULL, 0)) ch = pstr->trans[ch]; - if (islower (ch)) - pstr->mbs[char_idx] = toupper (ch); - else - pstr->mbs[char_idx] = ch; + pstr->mbs[char_idx] = toupper (ch); } pstr->valid_len = char_idx; pstr->valid_raw_len = char_idx; @@ -682,7 +677,7 @@ re_string_reconstruct (re_string_t *pstr, Idx idx, int eflags) pstr->valid_len - offset); pstr->valid_len -= offset; pstr->valid_raw_len -= offset; -#if DEBUG +#if defined DEBUG && DEBUG assert (pstr->valid_len > 0); #endif } @@ -941,7 +936,7 @@ re_string_context_at (const re_string_t *input, Idx idx, int eflags) Idx wc_idx = idx; while(input->wcs[wc_idx] == WEOF) { -#ifdef DEBUG +#if defined DEBUG && DEBUG /* It must not happen. */ assert (REG_VALID_INDEX (wc_idx)); #endif diff --git a/lib/regex_internal.h b/lib/regex_internal.h index a0eae33e9..0307a340f 100644 --- a/lib/regex_internal.h +++ b/lib/regex_internal.h @@ -1,5 +1,5 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2014 Free Software Foundation, Inc. + Copyright (C) 2002-2015 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa . @@ -34,13 +34,13 @@ #include #ifdef _LIBC -# include +# include # define lock_define(name) __libc_lock_define (, name) # define lock_init(lock) (__libc_lock_init (lock), 0) # define lock_fini(lock) 0 # define lock_lock(lock) __libc_lock_lock (lock) # define lock_unlock(lock) __libc_lock_unlock (lock) -#elif defined GNULIB_LOCK +#elif defined GNULIB_LOCK && !defined USE_UNLOCKED_IO # include "glthread/lock.h" /* Use gl_lock_define if empty macro arguments are known to work. Otherwise, fall back on less-portable substitutes. */ @@ -62,7 +62,7 @@ # define lock_fini(lock) glthread_lock_destroy (&(lock)) # define lock_lock(lock) glthread_lock_lock (&(lock)) # define lock_unlock(lock) glthread_lock_unlock (&(lock)) -#elif defined GNULIB_PTHREAD +#elif defined GNULIB_PTHREAD && !defined USE_UNLOCKED_IO # include # define lock_define(name) pthread_mutex_t name; # define lock_init(lock) pthread_mutex_init (&(lock), 0) @@ -87,7 +87,6 @@ # ifndef _RE_DEFINE_LOCALE_FUNCTIONS # define _RE_DEFINE_LOCALE_FUNCTIONS 1 # include -# include # include # endif #endif @@ -137,7 +136,10 @@ # undef __wctype # undef __iswctype # define __wctype wctype +# define __iswalnum iswalnum # define __iswctype iswctype +# define __towlower towlower +# define __towupper towupper # define __btowc btowc # define __mbrtowc mbrtowc # define __wcrtomb wcrtomb @@ -447,23 +449,23 @@ typedef struct re_dfa_t re_dfa_t; #ifndef _LIBC # define internal_function +# define IS_IN(libc) false #endif -#ifndef NOT_IN_libc static reg_errcode_t re_string_realloc_buffers (re_string_t *pstr, Idx new_buf_len) internal_function; -# ifdef RE_ENABLE_I18N +#ifdef RE_ENABLE_I18N static void build_wcs_buffer (re_string_t *pstr) internal_function; static reg_errcode_t build_wcs_upper_buffer (re_string_t *pstr) internal_function; -# endif /* RE_ENABLE_I18N */ +#endif /* RE_ENABLE_I18N */ static void build_upper_buffer (re_string_t *pstr) internal_function; static void re_string_translate_buffer (re_string_t *pstr) internal_function; static unsigned int re_string_context_at (const re_string_t *input, Idx idx, int eflags) internal_function __attribute__ ((pure)); -#endif + #define re_string_peek_byte(pstr, offset) \ ((pstr)->mbs[(pstr)->cur_idx + offset]) #define re_string_fetch_byte(pstr) \ @@ -556,7 +558,7 @@ typedef struct bin_tree_storage_t bin_tree_storage_t; #define IS_WORD_CHAR(ch) (isalnum (ch) || (ch) == '_') #define IS_NEWLINE(ch) ((ch) == NEWLINE_CHAR) -#define IS_WIDE_WORD_CHAR(ch) (iswalnum (ch) || (ch) == L'_') +#define IS_WIDE_WORD_CHAR(ch) (__iswalnum (ch) || (ch) == L'_') #define IS_WIDE_NEWLINE(ch) ((ch) == WIDE_NEWLINE_CHAR) #define NOT_SATISFY_PREV_CONSTRAINT(constraint,context) \ @@ -860,15 +862,17 @@ re_string_wchar_at (const re_string_t *pstr, Idx idx) return (wint_t) pstr->wcs[idx]; } -# ifndef NOT_IN_libc +# ifdef _LIBC +# include +# endif + static int internal_function __attribute__ ((pure, unused)) re_string_elem_size_at (const re_string_t *pstr, Idx idx) { -# ifdef _LIBC +# ifdef _LIBC const unsigned char *p, *extra; const int32_t *table, *indirect; -# include uint_fast32_t nrules = _NL_CURRENT_WORD (LC_COLLATE, _NL_COLLATE_NRULES); if (nrules != 0) @@ -879,14 +883,13 @@ re_string_elem_size_at (const re_string_t *pstr, Idx idx) indirect = (const int32_t *) _NL_CURRENT (LC_COLLATE, _NL_COLLATE_INDIRECTMB); p = pstr->mbs + idx; - findidx (&p, pstr->len - idx); + findidx (table, indirect, extra, &p, pstr->len - idx); return p - pstr->mbs - idx; } else -# endif /* _LIBC */ +# endif /* _LIBC */ return 1; } -# endif #endif /* RE_ENABLE_I18N */ #ifndef __GNUC_PREREQ diff --git a/lib/regexec.c b/lib/regexec.c index 05a8e807e..db50a564a 100644 --- a/lib/regexec.c +++ b/lib/regexec.c @@ -1,5 +1,5 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2014 Free Software Foundation, Inc. + Copyright (C) 2002-2015 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa . @@ -3776,6 +3776,10 @@ group_nodes_into_DFAstates (const re_dfa_t *dfa, const re_dfastate_t *state, one collating element like '.', '[a-z]', opposite to the other nodes can only accept one byte. */ +# ifdef _LIBC +# include +# endif + static int internal_function check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx, @@ -3895,8 +3899,6 @@ check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx, const int32_t *table, *indirect; const unsigned char *weights, *extra; const char *collseqwc; - /* This #include defines a local function! */ -# include /* match with collating_symbol? */ if (cset->ncoll_syms) @@ -3953,7 +3955,7 @@ check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx, _NL_CURRENT (LC_COLLATE, _NL_COLLATE_EXTRAMB); indirect = (const int32_t *) _NL_CURRENT (LC_COLLATE, _NL_COLLATE_INDIRECTMB); - int32_t idx = findidx (&cp, elem_len); + int32_t idx = findidx (table, indirect, extra, &cp, elem_len); if (idx > 0) for (i = 0; i < cset->nequiv_classes; ++i) { diff --git a/lib/rename.c b/lib/rename.c index 1cd4e6da3..feb2bd11f 100644 --- a/lib/rename.c +++ b/lib/rename.c @@ -1,6 +1,6 @@ /* Work around rename bugs in some systems. - Copyright (C) 2001-2003, 2005-2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2001-2003, 2005-2006, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -285,7 +285,7 @@ rpl_rename (char const *src, char const *dst) char *dst_temp = (char *) dst; bool src_slash; bool dst_slash; - bool dst_exists; + bool dst_exists _GL_UNUSED; int ret_val = -1; int rename_errno = ENOTDIR; struct stat src_st; @@ -462,7 +462,9 @@ rpl_rename (char const *src, char const *dst) ret_val = rename (src_temp, dst_temp); rename_errno = errno; - out: + + out: _GL_UNUSED_LABEL; + if (src_temp != src) free (src_temp); if (dst_temp != dst) diff --git a/lib/rmdir.c b/lib/rmdir.c index 964dd2028..98dc37f51 100644 --- a/lib/rmdir.c +++ b/lib/rmdir.c @@ -1,6 +1,6 @@ /* Work around rmdir bugs. - Copyright (C) 1988, 1990, 1999, 2003-2006, 2009-2014 Free Software + Copyright (C) 1988, 1990, 1999, 2003-2006, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/round.c b/lib/round.c index d1c2aac5a..ea43e2f7b 100644 --- a/lib/round.c +++ b/lib/round.c @@ -1,5 +1,5 @@ /* Round toward nearest, breaking ties away from zero. - Copyright (C) 2007, 2010-2014 Free Software Foundation, Inc. + Copyright (C) 2007, 2010-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/safe-read.c b/lib/safe-read.c index 6c9639f40..2b29d7b5a 100644 --- a/lib/safe-read.c +++ b/lib/safe-read.c @@ -1,6 +1,6 @@ /* An interface to read and write that retries after interrupts. - Copyright (C) 1993-1994, 1998, 2002-2006, 2009-2014 Free Software + Copyright (C) 1993-1994, 1998, 2002-2006, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/safe-read.h b/lib/safe-read.h index 6cd5f68fc..bdefa97f1 100644 --- a/lib/safe-read.h +++ b/lib/safe-read.h @@ -1,5 +1,5 @@ /* An interface to read() that retries after interrupts. - Copyright (C) 2002, 2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2002, 2006, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/safe-write.c b/lib/safe-write.c index 3e7ffd627..0828ccb36 100644 --- a/lib/safe-write.c +++ b/lib/safe-write.c @@ -1,5 +1,5 @@ /* An interface to write that retries after interrupts. - Copyright (C) 2002, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2002, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/safe-write.h b/lib/safe-write.h index 45a61463a..c156ae783 100644 --- a/lib/safe-write.h +++ b/lib/safe-write.h @@ -1,5 +1,5 @@ /* An interface to write() that retries after interrupts. - Copyright (C) 2002, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2002, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/same-inode.h b/lib/same-inode.h index f85a3cce8..b91a02b95 100644 --- a/lib/same-inode.h +++ b/lib/same-inode.h @@ -1,6 +1,6 @@ /* Determine whether two stat buffers refer to the same file. - Copyright (C) 2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2006, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/secure_getenv.c b/lib/secure_getenv.c index 7b86173bb..3a5216279 100644 --- a/lib/secure_getenv.c +++ b/lib/secure_getenv.c @@ -1,6 +1,6 @@ /* Look up an environment variable more securely. - Copyright 2013-2014 Free Software Foundation, Inc. + Copyright 2013-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/select.c b/lib/select.c index a31f90224..6f519878c 100644 --- a/lib/select.c +++ b/lib/select.c @@ -1,7 +1,7 @@ /* Emulation for select(2) Contributed by Paolo Bonzini. - Copyright 2008-2014 Free Software Foundation, Inc. + Copyright 2008-2015 Free Software Foundation, Inc. This file is part of gnulib. @@ -82,9 +82,11 @@ typedef DWORD (WINAPI *PNtQueryInformationFile) #define PIPE_BUF 512 #endif -/* Optimized test whether a HANDLE refers to a console. - See . */ -#define IsConsoleHandle(h) (((intptr_t) (h) & 3) == 3) +static BOOL IsConsoleHandle (HANDLE h) +{ + DWORD mode; + return GetConsoleMode (h, &mode) != 0; +} static BOOL IsSocketHandle (HANDLE h) @@ -252,6 +254,7 @@ rpl_select (int nfds, fd_set *rfds, fd_set *wfds, fd_set *xfds, DWORD ret, wait_timeout, nhandles, nsock, nbuffer; MSG msg; int i, fd, rc; + clock_t tend; if (nfds > FD_SETSIZE) nfds = FD_SETSIZE; @@ -388,6 +391,10 @@ rpl_select (int nfds, fd_set *rfds, fd_set *wfds, fd_set *xfds, /* Place a sentinel at the end of the array. */ handle_array[nhandles] = NULL; + /* When will the waiting period expire? */ + if (wait_timeout != INFINITE) + tend = clock () + wait_timeout; + restart: if (wait_timeout == 0 || nsock == 0) rc = 0; @@ -408,6 +415,16 @@ restart: wait_timeout = 0; } + /* How much is left to wait? */ + if (wait_timeout != INFINITE) + { + clock_t tnow = clock (); + if (tend >= tnow) + wait_timeout = tend - tnow; + else + wait_timeout = 0; + } + for (;;) { ret = MsgWaitForMultipleObjects (nhandles, handle_array, FALSE, @@ -453,7 +470,16 @@ restart: } } - if (rc == 0 && wait_timeout == INFINITE) + if (rc == 0 + && (wait_timeout == INFINITE + /* If NHANDLES > 1, but no bits are set, it means we've + been told incorrectly that some handle was signaled. + This happens with anonymous pipes, which always cause + MsgWaitForMultipleObjects to exit immediately, but no + data is found ready to be read by windows_poll_handle. + To avoid a total failure (whereby we return zero and + don't wait at all), let's poll in a more busy loop. */ + || (wait_timeout != 0 && nhandles > 1))) { /* Sleep 1 millisecond to avoid busy wait and retry with the original fd_sets. */ @@ -463,6 +489,8 @@ restart: SleepEx (1, TRUE); goto restart; } + if (timeout && wait_timeout == 0 && rc == 0) + timeout->tv_sec = timeout->tv_usec = 0; } /* Now fill in the results. */ diff --git a/lib/send.c b/lib/send.c index 9e70c91af..54315d359 100644 --- a/lib/send.c +++ b/lib/send.c @@ -1,6 +1,6 @@ /* send.c --- wrappers for Windows send function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sendto.c b/lib/sendto.c index 69b8ebc9f..f7f11d602 100644 --- a/lib/sendto.c +++ b/lib/sendto.c @@ -1,6 +1,6 @@ /* sendto.c --- wrappers for Windows sendto function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/setenv.c b/lib/setenv.c index 50e686025..689b404d0 100644 --- a/lib/setenv.c +++ b/lib/setenv.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1992, 1995-2003, 2005-2014 Free Software Foundation, Inc. +/* Copyright (C) 1992, 1995-2003, 2005-2015 Free Software Foundation, Inc. This file is part of the GNU C Library. This program is free software: you can redistribute it and/or modify diff --git a/lib/setsockopt.c b/lib/setsockopt.c index 2b905daa0..56b4827c2 100644 --- a/lib/setsockopt.c +++ b/lib/setsockopt.c @@ -1,6 +1,6 @@ /* setsockopt.c --- wrappers for Windows setsockopt function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/shutdown.c b/lib/shutdown.c index 54b7728dd..29c325ef0 100644 --- a/lib/shutdown.c +++ b/lib/shutdown.c @@ -1,6 +1,6 @@ /* shutdown.c --- wrappers for Windows shutdown function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/signal.in.h b/lib/signal.in.h index 057fa9ef5..3ea23eee5 100644 --- a/lib/signal.in.h +++ b/lib/signal.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 2006-2014 Free Software Foundation, Inc. + Copyright (C) 2006-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -55,11 +55,13 @@ #ifndef _@GUARD_PREFIX@_SIGNAL_H #define _@GUARD_PREFIX@_SIGNAL_H -/* Mac OS X 10.3, FreeBSD 6.4, OpenBSD 3.8, OSF/1 4.0, Solaris 2.6 declare - pthread_sigmask in , not in . +/* Mac OS X 10.3, FreeBSD 6.4, OpenBSD 3.8, OSF/1 4.0, Solaris 2.6, Android + declare pthread_sigmask in , not in . But avoid namespace pollution on glibc systems.*/ #if (@GNULIB_PTHREAD_SIGMASK@ || defined GNULIB_POSIXCHECK) \ - && ((defined __APPLE__ && defined __MACH__) || defined __FreeBSD__ || defined __OpenBSD__ || defined __osf__ || defined __sun) \ + && ((defined __APPLE__ && defined __MACH__) \ + || defined __FreeBSD__ || defined __OpenBSD__ || defined __osf__ \ + || defined __sun || defined __ANDROID__) \ && ! defined __GLIBC__ # include #endif diff --git a/lib/signbitd.c b/lib/signbitd.c index 1efb6e6a2..03beeecfb 100644 --- a/lib/signbitd.c +++ b/lib/signbitd.c @@ -1,5 +1,5 @@ /* signbit() macro: Determine the sign bit of a floating-point number. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/signbitf.c b/lib/signbitf.c index 3240e4ec0..51a685234 100644 --- a/lib/signbitf.c +++ b/lib/signbitf.c @@ -1,5 +1,5 @@ /* signbit() macro: Determine the sign bit of a floating-point number. - Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/signbitl.c b/lib/signbitl.c index 3f847257c..0142c33df 100644 --- a/lib/signbitl.c +++ b/lib/signbitl.c @@ -1,5 +1,5 @@ /* signbit() macro: Determine the sign bit of a floating-point number. - Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/size_max.h b/lib/size_max.h index 680ca0fff..935cf8978 100644 --- a/lib/size_max.h +++ b/lib/size_max.h @@ -1,5 +1,5 @@ /* size_max.h -- declare SIZE_MAX through system headers - Copyright (C) 2005-2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2005-2006, 2009-2015 Free Software Foundation, Inc. Written by Simon Josefsson. This program is free software; you can redistribute it and/or modify diff --git a/lib/snprintf.c b/lib/snprintf.c index 0b8cbf88f..f5a38629b 100644 --- a/lib/snprintf.c +++ b/lib/snprintf.c @@ -1,5 +1,5 @@ /* Formatted output to strings. - Copyright (C) 2004, 2006-2014 Free Software Foundation, Inc. + Copyright (C) 2004, 2006-2015 Free Software Foundation, Inc. Written by Simon Josefsson and Paul Eggert. This program is free software; you can redistribute it and/or modify diff --git a/lib/socket.c b/lib/socket.c index c10d4f6ad..da46cb907 100644 --- a/lib/socket.c +++ b/lib/socket.c @@ -1,6 +1,6 @@ /* socket.c --- wrappers for Windows socket function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sockets.c b/lib/sockets.c index 98fe879ee..acf41b526 100644 --- a/lib/sockets.c +++ b/lib/sockets.c @@ -1,6 +1,6 @@ /* sockets.c --- wrappers for Windows socket functions - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -121,8 +121,11 @@ gl_sockets_startup (int version _GL_UNUSED) if (err != 0) return 1; - if (data.wVersion < version) - return 2; + if (data.wVersion != version) + { + WSACleanup (); + return 2; + } if (initialized_sockets_version == 0) register_fd_hook (close_fd_maybe_socket, ioctl_fd_maybe_socket, diff --git a/lib/sockets.h b/lib/sockets.h index dd99ec172..66b947224 100644 --- a/lib/sockets.h +++ b/lib/sockets.h @@ -1,6 +1,6 @@ /* sockets.h - wrappers for Windows socket functions - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -20,11 +20,11 @@ #ifndef SOCKETS_H # define SOCKETS_H 1 -#define SOCKETS_1_0 0x100 /* don't use - does not work on Windows XP */ -#define SOCKETS_1_1 0x101 -#define SOCKETS_2_0 0x200 /* don't use - does not work on Windows XP */ -#define SOCKETS_2_1 0x201 -#define SOCKETS_2_2 0x202 +#define SOCKETS_1_0 0x0001 +#define SOCKETS_1_1 0x0101 +#define SOCKETS_2_0 0x0002 +#define SOCKETS_2_1 0x0102 +#define SOCKETS_2_2 0x0202 int gl_sockets_startup (int version) #if !WINDOWS_SOCKETS diff --git a/lib/stat-time.h b/lib/stat-time.h index 570001361..82b83acef 100644 --- a/lib/stat-time.h +++ b/lib/stat-time.h @@ -1,6 +1,6 @@ /* stat-related time functions. - Copyright (C) 2005, 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2005, 2007, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -54,7 +54,7 @@ _GL_INLINE_HEADER_BEGIN #endif /* Return the nanosecond component of *ST's access time. */ -_GL_STAT_TIME_INLINE long int +_GL_STAT_TIME_INLINE long int _GL_ATTRIBUTE_PURE get_stat_atime_ns (struct stat const *st) { # if defined STAT_TIMESPEC @@ -67,7 +67,7 @@ get_stat_atime_ns (struct stat const *st) } /* Return the nanosecond component of *ST's status change time. */ -_GL_STAT_TIME_INLINE long int +_GL_STAT_TIME_INLINE long int _GL_ATTRIBUTE_PURE get_stat_ctime_ns (struct stat const *st) { # if defined STAT_TIMESPEC @@ -80,7 +80,7 @@ get_stat_ctime_ns (struct stat const *st) } /* Return the nanosecond component of *ST's data modification time. */ -_GL_STAT_TIME_INLINE long int +_GL_STAT_TIME_INLINE long int _GL_ATTRIBUTE_PURE get_stat_mtime_ns (struct stat const *st) { # if defined STAT_TIMESPEC @@ -93,7 +93,7 @@ get_stat_mtime_ns (struct stat const *st) } /* Return the nanosecond component of *ST's birth time. */ -_GL_STAT_TIME_INLINE long int +_GL_STAT_TIME_INLINE long int _GL_ATTRIBUTE_PURE get_stat_birthtime_ns (struct stat const *st) { # if defined HAVE_STRUCT_STAT_ST_BIRTHTIMESPEC_TV_NSEC @@ -108,7 +108,7 @@ get_stat_birthtime_ns (struct stat const *st) } /* Return *ST's access time. */ -_GL_STAT_TIME_INLINE struct timespec +_GL_STAT_TIME_INLINE struct timespec _GL_ATTRIBUTE_PURE get_stat_atime (struct stat const *st) { #ifdef STAT_TIMESPEC @@ -122,7 +122,7 @@ get_stat_atime (struct stat const *st) } /* Return *ST's status change time. */ -_GL_STAT_TIME_INLINE struct timespec +_GL_STAT_TIME_INLINE struct timespec _GL_ATTRIBUTE_PURE get_stat_ctime (struct stat const *st) { #ifdef STAT_TIMESPEC @@ -136,7 +136,7 @@ get_stat_ctime (struct stat const *st) } /* Return *ST's data modification time. */ -_GL_STAT_TIME_INLINE struct timespec +_GL_STAT_TIME_INLINE struct timespec _GL_ATTRIBUTE_PURE get_stat_mtime (struct stat const *st) { #ifdef STAT_TIMESPEC @@ -151,7 +151,7 @@ get_stat_mtime (struct stat const *st) /* Return *ST's birth time, if available; otherwise return a value with tv_sec and tv_nsec both equal to -1. */ -_GL_STAT_TIME_INLINE struct timespec +_GL_STAT_TIME_INLINE struct timespec _GL_ATTRIBUTE_PURE get_stat_birthtime (struct stat const *st) { struct timespec t; diff --git a/lib/stat.c b/lib/stat.c index 60bbd693e..47f6c3b97 100644 --- a/lib/stat.c +++ b/lib/stat.c @@ -1,5 +1,5 @@ /* Work around platform bugs in stat. - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/stdalign.in.h b/lib/stdalign.in.h index 29861efe1..31bb7bce0 100644 --- a/lib/stdalign.in.h +++ b/lib/stdalign.in.h @@ -1,6 +1,6 @@ /* A substitute for ISO C11 . - Copyright 2011-2014 Free Software Foundation, Inc. + Copyright 2011-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -52,7 +52,10 @@ #undef _Alignas #undef _Alignof -#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112 +/* GCC releases before GCC 4.9 had a bug in _Alignof. See GCC bug 52023 + . */ +#if (!defined __STDC_VERSION__ || __STDC_VERSION__ < 201112 \ + || (defined __GNUC__ && __GNUC__ < 4 + (__GNUC_MINOR__ < 9))) # ifdef __cplusplus # if 201103 <= __cplusplus # define _Alignof(type) alignof (type) @@ -64,7 +67,9 @@ # define _Alignof(type) offsetof (struct { char __a; type __b; }, __b) # endif #endif -#define alignof _Alignof +#if ! (defined __cplusplus && 201103 <= __cplusplus) +# define alignof _Alignof +#endif #define __alignof_is_defined 1 /* alignas (A), also known as _Alignas (A), aligns a variable or type @@ -95,15 +100,21 @@ #if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112 # if defined __cplusplus && 201103 <= __cplusplus # define _Alignas(a) alignas (a) -# elif (__GNUC__ || __HP_cc || __HP_aCC || __IBMC__ || __IBMCPP__ \ +# elif ((defined __APPLE__ && defined __MACH__ \ + ? 4 < __GNUC__ + (1 <= __GNUC_MINOR__) \ + : __GNUC__) \ + || __HP_cc || __HP_aCC || __IBMC__ || __IBMCPP__ \ || __ICC || 0x5110 <= __SUNPRO_C) # define _Alignas(a) __attribute__ ((__aligned__ (a))) # elif 1300 <= _MSC_VER # define _Alignas(a) __declspec (align (a)) # endif #endif -#if defined _Alignas || (defined __STDC_VERSION && 201112 <= __STDC_VERSION__) +#if ((defined _Alignas && ! (defined __cplusplus && 201103 <= __cplusplus)) \ + || (defined __STDC_VERSION && 201112 <= __STDC_VERSION__)) # define alignas _Alignas +#endif +#if defined alignas || (defined __cplusplus && 201103 <= __cplusplus) # define __alignas_is_defined 1 #endif diff --git a/lib/stdbool.in.h b/lib/stdbool.in.h index 2f34a13fb..fb1cde05f 100644 --- a/lib/stdbool.in.h +++ b/lib/stdbool.in.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2001-2003, 2006-2014 Free Software Foundation, Inc. +/* Copyright (C) 2001-2003, 2006-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2001. This program is free software; you can redistribute it and/or modify diff --git a/lib/stddef.in.h b/lib/stddef.in.h index 204c4bcf0..383d44135 100644 --- a/lib/stddef.in.h +++ b/lib/stddef.in.h @@ -1,6 +1,6 @@ /* A substitute for POSIX 2008 , for platforms that have issues. - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -39,7 +39,6 @@ # if !(defined _@GUARD_PREFIX@_STDDEF_H && defined _GL_STDDEF_WINT_T) # ifdef __need_wint_t -# undef _@GUARD_PREFIX@_STDDEF_H # define _GL_STDDEF_WINT_T # endif # @INCLUDE_NEXT@ @NEXT_STDDEF_H@ @@ -54,33 +53,56 @@ # @INCLUDE_NEXT@ @NEXT_STDDEF_H@ -# ifndef _@GUARD_PREFIX@_STDDEF_H -# define _@GUARD_PREFIX@_STDDEF_H - /* On NetBSD 5.0, the definition of NULL lacks proper parentheses. */ -#if @REPLACE_NULL@ -# undef NULL -# ifdef __cplusplus +# if (@REPLACE_NULL@ \ + && (!defined _@GUARD_PREFIX@_STDDEF_H || defined _GL_STDDEF_WINT_T)) +# undef NULL +# ifdef __cplusplus /* ISO C++ says that the macro NULL must expand to an integer constant expression, hence '((void *) 0)' is not allowed in C++. */ -# if __GNUG__ >= 3 +# if __GNUG__ >= 3 /* GNU C++ has a __null macro that behaves like an integer ('int' or 'long') but has the same size as a pointer. Use that, to avoid warnings. */ -# define NULL __null -# else -# define NULL 0L +# define NULL __null +# else +# define NULL 0L +# endif +# else +# define NULL ((void *) 0) +# endif # endif -# else -# define NULL ((void *) 0) -# endif -#endif + +# ifndef _@GUARD_PREFIX@_STDDEF_H +# define _@GUARD_PREFIX@_STDDEF_H /* Some platforms lack wchar_t. */ #if !@HAVE_WCHAR_T@ # define wchar_t int #endif +/* Some platforms lack max_align_t. */ +#if !@HAVE_MAX_ALIGN_T@ +/* On the x86, the maximum storage alignment of double, long, etc. is 4, + but GCC's C11 ABI for x86 says that max_align_t has an alignment of 8, + and the C11 standard allows this. Work around this problem by + using __alignof__ (which returns 8 for double) rather than _Alignof + (which returns 4), and align each union member accordingly. */ +# ifdef __GNUC__ +# define _GL_STDDEF_ALIGNAS(type) \ + __attribute__ ((__aligned__ (__alignof__ (type)))) +# else +# define _GL_STDDEF_ALIGNAS(type) /* */ +# endif +typedef union +{ + char *__p _GL_STDDEF_ALIGNAS (char *); + double __d _GL_STDDEF_ALIGNAS (double); + long double __ld _GL_STDDEF_ALIGNAS (long double); + long int __i _GL_STDDEF_ALIGNAS (long int); +} max_align_t; +#endif + # endif /* _@GUARD_PREFIX@_STDDEF_H */ # endif /* _@GUARD_PREFIX@_STDDEF_H */ #endif /* __need_XXX */ diff --git a/lib/stdint.in.h b/lib/stdint.in.h index b1296f9ea..cf3655871 100644 --- a/lib/stdint.in.h +++ b/lib/stdint.in.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2001-2002, 2004-2014 Free Software Foundation, Inc. +/* Copyright (C) 2001-2002, 2004-2015 Free Software Foundation, Inc. Written by Paul Eggert, Bruno Haible, Sam Steingold, Peter Burwood. This file is part of gnulib. @@ -38,8 +38,7 @@ other system header files; just include the system's . Ideally we should test __BIONIC__ here, but it is only defined after has been included; hence test __ANDROID__ instead. */ -#if defined __ANDROID__ \ - && defined _SYS_TYPES_H_ && !defined __need_size_t +#if defined __ANDROID__ && defined _GL_INCLUDING_SYS_TYPES_H # @INCLUDE_NEXT@ @NEXT_STDINT_H@ #else diff --git a/lib/stdio.in.h b/lib/stdio.in.h index faa778b1d..d9fd18561 100644 --- a/lib/stdio.in.h +++ b/lib/stdio.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 2004, 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2004, 2007-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -84,8 +84,13 @@ except that it indicates to GCC that the supported format string directives are the ones of the system printf(), rather than the ones standardized by ISO C99 and POSIX. */ -#define _GL_ATTRIBUTE_FORMAT_PRINTF_SYSTEM(formatstring_parameter, first_argument) \ +#if GNULIB_PRINTF_ATTRIBUTE_FLAVOR_GNU +# define _GL_ATTRIBUTE_FORMAT_PRINTF_SYSTEM(formatstring_parameter, first_argument) \ + _GL_ATTRIBUTE_FORMAT_PRINTF (formatstring_parameter, first_argument) +#else +# define _GL_ATTRIBUTE_FORMAT_PRINTF_SYSTEM(formatstring_parameter, first_argument) \ _GL_ATTRIBUTE_FORMAT ((__printf__, formatstring_parameter, first_argument)) +#endif /* _GL_ATTRIBUTE_FORMAT_SCANF indicates to GCC that the function takes a format string and arguments, @@ -718,11 +723,10 @@ _GL_WARN_ON_USE (getline, "getline is unportable - " so any use of gets warrants an unconditional warning; besides, C11 removed it. */ #undef gets -#if HAVE_RAW_DECL_GETS +#if HAVE_RAW_DECL_GETS && !defined __cplusplus _GL_WARN_ON_USE (gets, "gets is a security hole - use fgets instead"); #endif - #if @GNULIB_OBSTACK_PRINTF@ || @GNULIB_OBSTACK_PRINTF_POSIX@ struct obstack; /* Grow an obstack with formatted output. Return the number of diff --git a/lib/stdlib.in.h b/lib/stdlib.in.h index 57d32cc48..fc46a2115 100644 --- a/lib/stdlib.in.h +++ b/lib/stdlib.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 1995, 2001-2004, 2006-2014 Free Software Foundation, Inc. + Copyright (C) 1995, 2001-2004, 2006-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -520,6 +520,29 @@ _GL_CXXALIAS_SYS (putenv, int, (char *string)); _GL_CXXALIASWARN (putenv); #endif +#if @GNULIB_QSORT_R@ +# if @REPLACE_QSORT_R@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef qsort_r +# define qsort_r rpl_qsort_r +# endif +_GL_FUNCDECL_RPL (qsort_r, void, (void *base, size_t nmemb, size_t size, + int (*compare) (void const *, void const *, + void *), + void *arg) _GL_ARG_NONNULL ((1, 4))); +_GL_CXXALIAS_RPL (qsort_r, void, (void *base, size_t nmemb, size_t size, + int (*compare) (void const *, void const *, + void *), + void *arg)); +# else +_GL_CXXALIAS_SYS (qsort_r, void, (void *base, size_t nmemb, size_t size, + int (*compare) (void const *, void const *, + void *), + void *arg)); +# endif +_GL_CXXALIASWARN (qsort_r); +#endif + #if @GNULIB_RANDOM_R@ # if !@HAVE_RANDOM_R@ diff --git a/lib/strdup.c b/lib/strdup.c index bde582927..7bbc59a74 100644 --- a/lib/strdup.c +++ b/lib/strdup.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1991, 1996-1998, 2002-2004, 2006-2007, 2009-2014 Free Software +/* Copyright (C) 1991, 1996-1998, 2002-2004, 2006-2007, 2009-2015 Free Software Foundation, Inc. This file is part of the GNU C Library. diff --git a/lib/streq.h b/lib/streq.h index 0f7bc72b2..85ce271ab 100644 --- a/lib/streq.h +++ b/lib/streq.h @@ -1,5 +1,5 @@ /* Optimized string comparison. - Copyright (C) 2001-2002, 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2001-2002, 2007, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/strftime.c b/lib/strftime.c index eb458d117..876d16e2b 100644 --- a/lib/strftime.c +++ b/lib/strftime.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1991-2001, 2003-2007, 2009-2014 Free Software Foundation, Inc. +/* Copyright (C) 1991-2001, 2003-2007, 2009-2015 Free Software Foundation, Inc. NOTE: The canonical source of this file is maintained with the GNU C Library. Bugs can be reported to bug-glibc@prep.ai.mit.edu. @@ -30,6 +30,7 @@ # else # include "strftime.h" # endif +# include "time-internal.h" #endif #include @@ -121,22 +122,11 @@ extern char *tzname[]; #ifdef _LIBC +# define mktime_z(tz, tm) mktime (tm) # define tzname __tzname # define tzset __tzset #endif -#if !HAVE_TM_GMTOFF -/* Portable standalone applications should supply a "time.h" that - declares a POSIX-compliant localtime_r, for the benefit of older - implementations that lack localtime_r or have a nonstandard one. - See the gnulib time_r module for one way to implement this. */ -# undef __gmtime_r -# undef __localtime_r -# define __gmtime_r gmtime_r -# define __localtime_r localtime_r -#endif - - #ifndef FPRINTFTIME # define FPRINTFTIME 0 #endif @@ -385,12 +375,7 @@ iso_week_days (int yday, int wday) /* When compiling this file, GNU applications can #define my_strftime to a symbol (typically nstrftime) to get an extended strftime with - extra arguments UT and NS. Emacs is a special case for now, but - this Emacs-specific code can be removed once Emacs's config.h - defines my_strftime. */ -#if defined emacs && !defined my_strftime -# define my_strftime nstrftime -#endif + extra arguments TZ and NS. */ #if FPRINTFTIME # undef my_strftime @@ -398,8 +383,9 @@ iso_week_days (int yday, int wday) #endif #ifdef my_strftime -# define extra_args , ut, ns -# define extra_args_spec , int ut, int ns +# undef HAVE_TZSET +# define extra_args , tz, ns +# define extra_args_spec , timezone_t tz, int ns #else # if defined COMPILE_WIDE # define my_strftime wcsftime @@ -411,7 +397,7 @@ iso_week_days (int yday, int wday) # define extra_args # define extra_args_spec /* We don't have this information in general. */ -# define ut 0 +# define tz 1 # define ns 0 #endif @@ -454,6 +440,9 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, # define aw_len STRLEN (a_wkday) # define am_len STRLEN (a_month) # define ap_len STRLEN (ampm) +#endif +#if HAVE_TZNAME + char **tzname_vec = tzname; #endif const char *zone; size_t i = 0; @@ -483,20 +472,29 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, zone = (const char *) tp->tm_zone; #endif #if HAVE_TZNAME - if (ut) + if (!tz) { if (! (zone && *zone)) zone = "GMT"; } else { +# if !HAVE_TM_ZONE + /* Infer the zone name from *TZ instead of from TZNAME. */ + tzname_vec = tz->tzname_copy; +# endif /* POSIX.1 requires that local time zone information be used as though strftime called tzset. */ # if HAVE_TZSET tzset (); # endif } + /* The tzset() call might have changed the value. */ + if (!(zone && *zone) && tp->tm_isdst >= 0) + zone = tzname_vec[tp->tm_isdst != 0]; #endif + if (! zone) + zone = ""; if (hour12 > 12) hour12 -= 12; @@ -681,24 +679,44 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, switch (format_char) { #define DO_NUMBER(d, v) \ - digits = d; \ - number_value = v; goto do_number + do \ + { \ + digits = d; \ + number_value = v; \ + goto do_number; \ + } \ + while (0) #define DO_SIGNED_NUMBER(d, negative, v) \ - digits = d; \ - negative_number = negative; \ - u_number_value = v; goto do_signed_number + do \ + { \ + digits = d; \ + negative_number = negative; \ + u_number_value = v; \ + goto do_signed_number; \ + } \ + while (0) /* The mask is not what you might think. When the ordinal i'th bit is set, insert a colon before the i'th digit of the time zone representation. */ #define DO_TZ_OFFSET(d, negative, mask, v) \ - digits = d; \ - negative_number = negative; \ - tz_colon_mask = mask; \ - u_number_value = v; goto do_tz_offset + do \ + { \ + digits = d; \ + negative_number = negative; \ + tz_colon_mask = mask; \ + u_number_value = v; \ + goto do_tz_offset; \ + } \ + while (0) #define DO_NUMBER_SPACEPAD(d, v) \ - digits = d; \ - number_value = v; goto do_number_spacepad + do \ + { \ + digits = d; \ + number_value = v; \ + goto do_number_spacepad; \ + } \ + while (0) case L_('%'): if (modifier != 0) @@ -1124,7 +1142,7 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, time_t t; ltm = *tp; - t = mktime (<m); + t = mktime_z (tz, <m); /* Generate string value for T using time_t arithmetic; this works even if sizeof (long) < sizeof (time_t). */ @@ -1265,9 +1283,9 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, } if (modifier == L_('O')) goto bad_format; - else - DO_SIGNED_NUMBER (4, tp->tm_year < -TM_YEAR_BASE, - tp->tm_year + (unsigned int) TM_YEAR_BASE); + + DO_SIGNED_NUMBER (4, tp->tm_year < -TM_YEAR_BASE, + tp->tm_year + (unsigned int) TM_YEAR_BASE); case L_('y'): if (modifier == L_('E')) @@ -1299,14 +1317,6 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, to_lowcase = true; } -#if HAVE_TZNAME - /* The tzset() call might have changed the value. */ - if (!(zone && *zone) && tp->tm_isdst >= 0) - zone = tzname[tp->tm_isdst != 0]; -#endif - if (! zone) - zone = ""; - #ifdef COMPILE_WIDE { /* The zone string is always given in multibyte form. We have @@ -1346,7 +1356,7 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, #if HAVE_TM_GMTOFF diff = tp->tm_gmtoff; #else - if (ut) + if (!tz) diff = 0; else { @@ -1355,7 +1365,7 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, time_t lt; ltm = *tp; - lt = mktime (<m); + lt = mktime_z (tz, <m); if (lt == (time_t) -1) { @@ -1364,7 +1374,7 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, occurred. */ struct tm tm; - if (! __localtime_r (<, &tm) + if (! localtime_rz (tz, <, &tm) || ((ltm.tm_sec ^ tm.tm_sec) | (ltm.tm_min ^ tm.tm_min) | (ltm.tm_hour ^ tm.tm_hour) @@ -1374,7 +1384,7 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, break; } - if (! __gmtime_r (<, >m)) + if (! localtime_rz (0, <, >m)) break; diff = tm_diff (<m, >m); @@ -1453,15 +1463,3 @@ my_strftime (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize) #if defined _LIBC && ! FPRINTFTIME libc_hidden_def (my_strftime) #endif - - -#if defined emacs && ! FPRINTFTIME -/* For Emacs we have a separate interface which corresponds to the normal - strftime function plus the ut argument, but without the ns argument. */ -size_t -emacs_strftimeu (char *s, size_t maxsize, const char *format, - const struct tm *tp, int ut) -{ - return my_strftime (s, maxsize, format, tp, ut, 0); -} -#endif diff --git a/lib/strftime.h b/lib/strftime.h index a394640e6..8756acd02 100644 --- a/lib/strftime.h +++ b/lib/strftime.h @@ -1,6 +1,6 @@ /* declarations for strftime.c - Copyright (C) 2002, 2004, 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2002, 2004, 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -23,11 +23,10 @@ extern "C" { /* Just like strftime, but with two more arguments: POSIX requires that strftime use the local timezone information. - When __UTC is nonzero and tm->tm_zone is NULL or the empty string, - use UTC instead. Use __NS as the number of nanoseconds in the - %N directive. */ + Use the timezone __TZ instead. Use __NS as the number of + nanoseconds in the %N directive. */ size_t nstrftime (char *, size_t, char const *, struct tm const *, - int __utc, int __ns); + timezone_t __tz, int __ns); #ifdef __cplusplus } diff --git a/lib/striconveh.c b/lib/striconveh.c index 1a2f62e44..a9c9b0020 100644 --- a/lib/striconveh.c +++ b/lib/striconveh.c @@ -1,5 +1,5 @@ /* Character set conversion with error handling. - Copyright (C) 2001-2014 Free Software Foundation, Inc. + Copyright (C) 2001-2015 Free Software Foundation, Inc. Written by Bruno Haible and Simon Josefsson. This program is free software: you can redistribute it and/or modify diff --git a/lib/striconveh.h b/lib/striconveh.h index a4e425aa2..bea457b86 100644 --- a/lib/striconveh.h +++ b/lib/striconveh.h @@ -1,5 +1,5 @@ /* Character set conversion with error handling. - Copyright (C) 2001-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2001-2007, 2009-2015 Free Software Foundation, Inc. Written by Bruno Haible and Simon Josefsson. This program is free software: you can redistribute it and/or modify diff --git a/lib/string.in.h b/lib/string.in.h index eaaaa9dda..9a630b163 100644 --- a/lib/string.in.h +++ b/lib/string.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 1995-1996, 2001-2014 Free Software Foundation, Inc. + Copyright (C) 1995-1996, 2001-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -15,16 +15,32 @@ You should have received a copy of the GNU Lesser General Public License along with this program; if not, see . */ -#ifndef _@GUARD_PREFIX@_STRING_H - #if __GNUC__ >= 3 @PRAGMA_SYSTEM_HEADER@ #endif @PRAGMA_COLUMNS@ +#if defined _GL_ALREADY_INCLUDING_STRING_H +/* Special invocation convention: + - On OS X/NetBSD we have a sequence of nested includes + -> -> "string.h" + In this situation system _chk variants due to -D_FORTIFY_SOURCE + might be used after any replacements defined here. */ + +#@INCLUDE_NEXT@ @NEXT_STRING_H@ + +#else +/* Normal invocation convention. */ + +#ifndef _@GUARD_PREFIX@_STRING_H + +#define _GL_ALREADY_INCLUDING_STRING_H + /* The include_next requires a split double-inclusion guard. */ #@INCLUDE_NEXT@ @NEXT_STRING_H@ +#undef _GL_ALREADY_INCLUDING_STRING_H + #ifndef _@GUARD_PREFIX@_STRING_H #define _@GUARD_PREFIX@_STRING_H @@ -1027,3 +1043,4 @@ _GL_WARN_ON_USE (strverscmp, "strverscmp is unportable - " #endif /* _@GUARD_PREFIX@_STRING_H */ #endif /* _@GUARD_PREFIX@_STRING_H */ +#endif diff --git a/lib/stripslash.c b/lib/stripslash.c index 22295e57a..86298d64f 100644 --- a/lib/stripslash.c +++ b/lib/stripslash.c @@ -1,6 +1,6 @@ /* stripslash.c -- remove redundant trailing slashes from a file name - Copyright (C) 1990, 2001, 2003-2006, 2009-2014 Free Software Foundation, + Copyright (C) 1990, 2001, 2003-2006, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/sys_file.in.h b/lib/sys_file.in.h index 1df6946a5..af5ba2f67 100644 --- a/lib/sys_file.in.h +++ b/lib/sys_file.in.h @@ -1,6 +1,6 @@ /* Provide a more complete sys/file.h. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sys_select.in.h b/lib/sys_select.in.h index 7e5c3a389..20cfc9be2 100644 --- a/lib/sys_select.in.h +++ b/lib/sys_select.in.h @@ -1,5 +1,5 @@ /* Substitute for . - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -24,8 +24,8 @@ On Cygwin, includes . Simply delegate to the system's header in this case. */ #if (@HAVE_SYS_SELECT_H@ \ + && !defined _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TYPES_H \ && ((defined __osf__ && defined _SYS_TYPES_H_ \ - && !defined _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TIME_H \ && defined _OSF_SOURCE) \ || (defined __sun && defined _SYS_TYPES_H \ && (! (defined _XOPEN_SOURCE || defined _POSIX_C_SOURCE) \ @@ -36,12 +36,13 @@ #elif (@HAVE_SYS_SELECT_H@ \ && (defined _CYGWIN_SYS_TIME_H \ - || (defined __osf__ && defined _SYS_TIME_H_ \ - && !defined _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TIME_H \ - && defined _OSF_SOURCE) \ - || (defined __sun && defined _SYS_TIME_H \ - && (! (defined _XOPEN_SOURCE || defined _POSIX_C_SOURCE) \ - || defined __EXTENSIONS__)))) + || (!defined _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TIME_H \ + && ((defined __osf__ && defined _SYS_TIME_H_ \ + && defined _OSF_SOURCE) \ + || (defined __sun && defined _SYS_TIME_H \ + && (! (defined _XOPEN_SOURCE \ + || defined _POSIX_C_SOURCE) \ + || defined __EXTENSIONS__)))))) # define _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TIME_H # @INCLUDE_NEXT@ @NEXT_SYS_SELECT_H@ diff --git a/lib/sys_socket.c b/lib/sys_socket.c index 3f017f8fc..3b261da03 100644 --- a/lib/sys_socket.c +++ b/lib/sys_socket.c @@ -1,3 +1,4 @@ #include #define _GL_SYS_SOCKET_INLINE _GL_EXTERN_INLINE #include "sys/socket.h" +typedef int dummy; diff --git a/lib/sys_socket.in.h b/lib/sys_socket.in.h index 0cbc3e4fe..7f1163506 100644 --- a/lib/sys_socket.in.h +++ b/lib/sys_socket.in.h @@ -1,6 +1,6 @@ /* Provide a sys/socket header file for systems lacking it (read: MinGW) and for systems where it is incomplete. - Copyright (C) 2005-2014 Free Software Foundation, Inc. + Copyright (C) 2005-2015 Free Software Foundation, Inc. Written by Simon Josefsson. This program is free software; you can redistribute it and/or modify diff --git a/lib/sys_stat.in.h b/lib/sys_stat.in.h index 32c23a055..c8cb6a5e5 100644 --- a/lib/sys_stat.in.h +++ b/lib/sys_stat.in.h @@ -1,5 +1,5 @@ /* Provide a more complete sys/stat header file. - Copyright (C) 2005-2014 Free Software Foundation, Inc. + Copyright (C) 2005-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sys_time.in.h b/lib/sys_time.in.h index f19326e02..e91bbfe19 100644 --- a/lib/sys_time.in.h +++ b/lib/sys_time.in.h @@ -1,6 +1,6 @@ /* Provide a more complete sys/time.h. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sys_times.in.h b/lib/sys_times.in.h index b3babfb80..9ca247c64 100644 --- a/lib/sys_times.in.h +++ b/lib/sys_times.in.h @@ -1,5 +1,5 @@ /* Provide a sys/times.h header file. - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sys_types.in.h b/lib/sys_types.in.h index c8d0bb48f..f313b85b3 100644 --- a/lib/sys_types.in.h +++ b/lib/sys_types.in.h @@ -1,6 +1,6 @@ /* Provide a more complete sys/types.h. - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -23,7 +23,9 @@ #ifndef _@GUARD_PREFIX@_SYS_TYPES_H /* The include_next requires a split double-inclusion guard. */ +# define _GL_INCLUDING_SYS_TYPES_H #@INCLUDE_NEXT@ @NEXT_SYS_TYPES_H@ +# undef _GL_INCLUDING_SYS_TYPES_H #ifndef _@GUARD_PREFIX@_SYS_TYPES_H #define _@GUARD_PREFIX@_SYS_TYPES_H diff --git a/lib/sys_uio.in.h b/lib/sys_uio.in.h index 8cad7de32..0646ed2bc 100644 --- a/lib/sys_uio.in.h +++ b/lib/sys_uio.in.h @@ -1,5 +1,5 @@ /* Substitute for . - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/tempname.c b/lib/tempname.c index f0f7e7f29..da0c41c16 100644 --- a/lib/tempname.c +++ b/lib/tempname.c @@ -1,6 +1,6 @@ /* tempname.c - generate the name of a temporary file. - Copyright (C) 1991-2003, 2005-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 1991-2003, 2005-2007, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -62,6 +62,7 @@ # define struct_stat64 struct stat64 #else # define struct_stat64 struct stat +# define __try_tempname try_tempname # define __gen_tempname gen_tempname # define __getpid getpid # define __gettimeofday gettimeofday @@ -176,21 +177,9 @@ __path_search (char *tmpl, size_t tmpl_len, const char *dir, const char *pfx, static const char letters[] = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"; -/* Generate a temporary file name based on TMPL. TMPL must match the - rules for mk[s]temp (i.e. end in "XXXXXX", possibly with a suffix). - The name constructed does not exist at the time of the call to - __gen_tempname. TMPL is overwritten with the result. - - KIND may be one of: - __GT_NOCREATE: simply verify that the name does not exist - at the time of the call. - __GT_FILE: create the file using open(O_CREAT|O_EXCL) - and return a read-write fd. The file is mode 0600. - __GT_DIR: create a directory, which will be mode 0700. - - We use a clever algorithm to get hard-to-predict names. */ int -__gen_tempname (char *tmpl, int suffixlen, int flags, int kind) +__try_tempname (char *tmpl, int suffixlen, void *args, + int (*tryfunc) (char *, void *)) { int len; char *XXXXXX; @@ -199,7 +188,6 @@ __gen_tempname (char *tmpl, int suffixlen, int flags, int kind) unsigned int count; int fd = -1; int save_errno = errno; - struct_stat64 st; /* A lower bound on the number of temporary files to attempt to generate. The maximum total number of temporary file names that @@ -256,41 +244,7 @@ __gen_tempname (char *tmpl, int suffixlen, int flags, int kind) v /= 62; XXXXXX[5] = letters[v % 62]; - switch (kind) - { - case __GT_FILE: - fd = __open (tmpl, - (flags & ~O_ACCMODE) - | O_RDWR | O_CREAT | O_EXCL, S_IRUSR | S_IWUSR); - break; - - case __GT_DIR: - fd = __mkdir (tmpl, S_IRUSR | S_IWUSR | S_IXUSR); - break; - - case __GT_NOCREATE: - /* This case is backward from the other three. __gen_tempname - succeeds if __xstat fails because the name does not exist. - Note the continue to bypass the common logic at the bottom - of the loop. */ - if (__lxstat64 (_STAT_VER, tmpl, &st) < 0) - { - if (errno == ENOENT) - { - __set_errno (save_errno); - return 0; - } - else - /* Give up now. */ - return -1; - } - continue; - - default: - assert (! "invalid KIND in __gen_tempname"); - abort (); - } - + fd = tryfunc (tmpl, args); if (fd >= 0) { __set_errno (save_errno); @@ -304,3 +258,67 @@ __gen_tempname (char *tmpl, int suffixlen, int flags, int kind) __set_errno (EEXIST); return -1; } + +static int +try_file (char *tmpl, void *flags) +{ + int *openflags = flags; + return __open (tmpl, + (*openflags & ~O_ACCMODE) + | O_RDWR | O_CREAT | O_EXCL, S_IRUSR | S_IWUSR); +} + +static int +try_dir (char *tmpl, void *flags _GL_UNUSED) +{ + return __mkdir (tmpl, S_IRUSR | S_IWUSR | S_IXUSR); +} + +static int +try_nocreate (char *tmpl, void *flags _GL_UNUSED) +{ + struct_stat64 st; + + if (__lxstat64 (_STAT_VER, tmpl, &st) == 0) + __set_errno (EEXIST); + return errno == ENOENT ? 0 : -1; +} + +/* Generate a temporary file name based on TMPL. TMPL must match the + rules for mk[s]temp (i.e. end in "XXXXXX", possibly with a suffix). + The name constructed does not exist at the time of the call to + __gen_tempname. TMPL is overwritten with the result. + + KIND may be one of: + __GT_NOCREATE: simply verify that the name does not exist + at the time of the call. + __GT_FILE: create the file using open(O_CREAT|O_EXCL) + and return a read-write fd. The file is mode 0600. + __GT_DIR: create a directory, which will be mode 0700. + + We use a clever algorithm to get hard-to-predict names. */ +int +__gen_tempname (char *tmpl, int suffixlen, int flags, int kind) +{ + int (*tryfunc) (char *, void *); + + switch (kind) + { + case __GT_FILE: + tryfunc = try_file; + break; + + case __GT_DIR: + tryfunc = try_dir; + break; + + case __GT_NOCREATE: + tryfunc = try_nocreate; + break; + + default: + assert (! "invalid KIND in __gen_tempname"); + abort (); + } + return __try_tempname (tmpl, suffixlen, &flags, tryfunc); +} diff --git a/lib/tempname.h b/lib/tempname.h index bd46f93f9..a33f3da75 100644 --- a/lib/tempname.h +++ b/lib/tempname.h @@ -1,6 +1,6 @@ /* Create a temporary file or directory. - Copyright (C) 2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2006, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -32,6 +32,10 @@ # define GT_NOCREATE 2 # endif +#ifdef __cplusplus +extern "C" { +#endif + /* Generate a temporary file name based on TMPL. TMPL must match the rules for mk[s]temp (i.e. end in "XXXXXX", possibly with a suffix). The name constructed does not exist at the time of the call to @@ -47,4 +51,15 @@ We use a clever algorithm to get hard-to-predict names. */ extern int gen_tempname (char *tmpl, int suffixlen, int flags, int kind); +/* Similar to gen_tempname, but TRYFUNC is called for each temporary + name to try. If TRYFUNC returns a non-negative number, TRY_GEN_TEMPNAME + returns with this value. Otherwise, if errno is set to EEXIST, another + name is tried, or else TRY_GEN_TEMPNAME returns -1. */ +extern int try_tempname (char *tmpl, int suffixlen, void *args, + int (*tryfunc) (char *, void *)); + +#ifdef __cplusplus +} +#endif + #endif /* GL_TEMPNAME_H */ diff --git a/lib/time-internal.h b/lib/time-internal.h new file mode 100644 index 000000000..7137a6716 --- /dev/null +++ b/lib/time-internal.h @@ -0,0 +1,49 @@ +/* Time internal interface + + Copyright 2015 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License along + with this program; if not, see . */ + +/* Written by Paul Eggert. */ + +/* A time zone rule. */ +struct tm_zone +{ + /* More abbreviations, should they be needed. Their TZ_IS_SET + members are zero. */ + struct tm_zone *next; + +#if HAVE_TZNAME && !HAVE_TM_ZONE + /* Copies of recent strings taken from tzname[0] and tzname[1]. + The copies are in ABBRS, so that they survive tzset. Null if unknown. */ + char *tzname_copy[2]; +#endif + + /* If nonzero, the rule represents the TZ environment variable set + to the first "abbreviation" (this may be the empty string). + Otherwise, it represents an unset TZ. */ + char tz_is_set; + + /* A sequence of null-terminated strings packed next to each other. + The strings are followed by an extra null byte. If TZ_IS_SET, + there must be at least one string and the first string (which is + actually a TZ environment value value) may be empty. Otherwise + all strings must be nonempty. + + Abbreviations are stored here because otherwise the values of + tm_zone and/or tzname would be dead after changing TZ and calling + tzset. Abbreviations never move once allocated, and are live + until tzfree is called. */ + char abbrs[FLEXIBLE_ARRAY_MEMBER]; +}; diff --git a/lib/time.in.h b/lib/time.in.h index 01681cc8c..7df4a6085 100644 --- a/lib/time.in.h +++ b/lib/time.in.h @@ -1,6 +1,6 @@ /* A more-standard . - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -22,11 +22,13 @@ /* Don't get in the way of glibc when it includes time.h merely to declare a few standard symbols, rather than to declare all the - symbols. Also, Solaris 8 eventually includes itself + symbols. (However, skip this for MinGW as it treats __need_time_t + incompatibly.) Also, Solaris 8 eventually includes itself recursively; if that is happening, just include the system without adding our own declarations. */ -#if (defined __need_time_t || defined __need_clock_t \ - || defined __need_timespec \ +#if (((defined __need_time_t || defined __need_clock_t \ + || defined __need_timespec) \ + && !defined __MINGW32__) \ || defined _@GUARD_PREFIX@_TIME_H) # @INCLUDE_NEXT@ @NEXT_TIME_H@ @@ -55,6 +57,8 @@ # include # elif @PTHREAD_H_DEFINES_STRUCT_TIMESPEC@ # include +# elif @UNISTD_H_DEFINES_STRUCT_TIMESPEC@ +# include # else # ifdef __cplusplus @@ -229,6 +233,25 @@ _GL_CXXALIAS_SYS (strptime, char *, (char const *restrict __buf, _GL_CXXALIASWARN (strptime); # endif +# if defined _GNU_SOURCE && @GNULIB_TIME_RZ@ && ! @HAVE_TIMEZONE_T@ +typedef struct tm_zone *timezone_t; +_GL_FUNCDECL_SYS (tzalloc, timezone_t, (char const *__name)); +_GL_CXXALIAS_SYS (tzalloc, timezone_t, (char const *__name)); +_GL_FUNCDECL_SYS (tzfree, void, (timezone_t __tz)); +_GL_CXXALIAS_SYS (tzfree, void, (timezone_t __tz)); +_GL_FUNCDECL_SYS (localtime_rz, struct tm *, + (timezone_t __tz, time_t const *restrict __timer, + struct tm *restrict __result) _GL_ARG_NONNULL ((2, 3))); +_GL_CXXALIAS_SYS (localtime_rz, struct tm *, + (timezone_t __tz, time_t const *restrict __timer, + struct tm *restrict __result)); +_GL_FUNCDECL_SYS (mktime_z, time_t, + (timezone_t __tz, struct tm *restrict __result) + _GL_ARG_NONNULL ((2))); +_GL_CXXALIAS_SYS (mktime_z, time_t, + (timezone_t __tz, struct tm *restrict __result)); +# endif + /* Convert TM to a time_t value, assuming UTC. */ # if @GNULIB_TIMEGM@ # if @REPLACE_TIMEGM@ diff --git a/lib/time_r.c b/lib/time_r.c index 0249750e8..2db2bc075 100644 --- a/lib/time_r.c +++ b/lib/time_r.c @@ -1,6 +1,6 @@ /* Reentrant time functions like localtime_r. - Copyright (C) 2003, 2006-2007, 2010-2014 Free Software Foundation, Inc. + Copyright (C) 2003, 2006-2007, 2010-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/time_rz.c b/lib/time_rz.c new file mode 100644 index 000000000..888eed227 --- /dev/null +++ b/lib/time_rz.c @@ -0,0 +1,323 @@ +/* Time zone functions such as tzalloc and localtime_rz + + Copyright 2015 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License along + with this program; if not, see . */ + +/* Written by Paul Eggert. */ + +/* Although this module is not thread-safe, any races should be fairly + rare and reasonably benign. For complete thread-safety, use a C + library with a working timezone_t type, so that this module is not + needed. */ + +#include + +#include + +#include +#include +#include +#include +#include + +#include "time-internal.h" + +#if !HAVE_TZSET +static void tzset (void) { } +#endif + +/* The approximate size to use for small allocation requests. This is + the largest "small" request for the GNU C library malloc. */ +enum { DEFAULT_MXFAST = 64 * sizeof (size_t) / 4 }; + +/* Minimum size of the ABBRS member of struct abbr. ABBRS is larger + only in the unlikely case where an abbreviation longer than this is + used. */ +enum { ABBR_SIZE_MIN = DEFAULT_MXFAST - offsetof (struct tm_zone, abbrs) }; + +static char const TZ[] = "TZ"; + +/* Magic cookie timezone_t value, for local time. It differs from + NULL and from all other timezone_t values. Only the address + matters; the pointer is never dereferenced. */ +static timezone_t const local_tz = (timezone_t) 1; + +#if HAVE_TM_ZONE || HAVE_TZNAME + +/* Return true if the values A and B differ according to the rules for + tm_isdst: A and B differ if one is zero and the other positive. */ +static bool +isdst_differ (int a, int b) +{ + return !a != !b && 0 <= a && 0 <= b; +} + +/* Return true if A and B are equal. */ +static int +equal_tm (const struct tm *a, const struct tm *b) +{ + return ! ((a->tm_sec ^ b->tm_sec) + | (a->tm_min ^ b->tm_min) + | (a->tm_hour ^ b->tm_hour) + | (a->tm_mday ^ b->tm_mday) + | (a->tm_mon ^ b->tm_mon) + | (a->tm_year ^ b->tm_year) + | isdst_differ (a->tm_isdst, b->tm_isdst)); +} + +#endif + +/* Copy to ABBRS the abbreviation at ABBR with size ABBR_SIZE (this + includes its trailing null byte). Append an extra null byte to + mark the end of ABBRS. */ +static void +extend_abbrs (char *abbrs, char const *abbr, size_t abbr_size) +{ + memcpy (abbrs, abbr, abbr_size); + abbrs[abbr_size] = '\0'; +} + +/* Return a newly allocated time zone for NAME, or NULL on failure. + A null NAME stands for wall clock time (which is like unset TZ). */ +timezone_t +tzalloc (char const *name) +{ + size_t name_size = name ? strlen (name) + 1 : 0; + size_t abbr_size = name_size < ABBR_SIZE_MIN ? ABBR_SIZE_MIN : name_size + 1; + timezone_t tz = malloc (offsetof (struct tm_zone, abbrs) + abbr_size); + if (tz) + { + tz->next = NULL; +#if HAVE_TZNAME && !HAVE_TM_ZONE + tz->tzname_copy[0] = tz->tzname_copy[1] = NULL; +#endif + tz->tz_is_set = !!name; + tz->abbrs[0] = '\0'; + if (name) + extend_abbrs (tz->abbrs, name, name_size); + } + return tz; +} + +/* Save into TZ any nontrivial time zone abbreviation used by TM, and + update *TM (if HAVE_TM_ZONE) or *TZ (if !HAVE_TM_ZONE && + HAVE_TZNAME) if they use the abbreviation. Return true if + successful, false (setting errno) otherwise. */ +static bool +save_abbr (timezone_t tz, struct tm *tm) +{ +#if HAVE_TM_ZONE || HAVE_TZNAME + char const *zone = NULL; + char *zone_copy = (char *) ""; + +# if HAVE_TZNAME + int tzname_index = -1; +# endif + +# if HAVE_TM_ZONE + zone = tm->tm_zone; +# endif + +# if HAVE_TZNAME + if (! (zone && *zone) && 0 <= tm->tm_isdst) + { + tzname_index = tm->tm_isdst != 0; + zone = tzname[tzname_index]; + } +# endif + + /* No need to replace null zones, or zones within the struct tm. */ + if (!zone || ((char *) tm <= zone && zone < (char *) (tm + 1))) + return true; + + if (*zone) + { + zone_copy = tz->abbrs; + + while (strcmp (zone_copy, zone) != 0) + { + if (! (*zone_copy || (zone_copy == tz->abbrs && tz->tz_is_set))) + { + size_t zone_size = strlen (zone) + 1; + if (zone_size < tz->abbrs + ABBR_SIZE_MIN - zone_copy) + extend_abbrs (zone_copy, zone, zone_size); + else + { + tz = tz->next = tzalloc (zone); + if (!tz) + return false; + tz->tz_is_set = 0; + zone_copy = tz->abbrs; + } + break; + } + + zone_copy += strlen (zone_copy) + 1; + if (!*zone_copy && tz->next) + { + tz = tz->next; + zone_copy = tz->abbrs; + } + } + } + + /* Replace the zone name so that its lifetime matches that of TZ. */ +# if HAVE_TM_ZONE + tm->tm_zone = zone_copy; +# else + if (0 <= tzname_index) + tz->tzname_copy[tzname_index] = zone_copy; +# endif +#endif + + return true; +} + +/* Free a time zone. */ +void +tzfree (timezone_t tz) +{ + if (tz != local_tz) + while (tz) + { + timezone_t next = tz->next; + free (tz); + tz = next; + } +} + +/* Get and set the TZ environment variable. These functions can be + overridden by programs like Emacs that manage their own environment. */ + +#ifndef getenv_TZ +static char * +getenv_TZ (void) +{ + return getenv (TZ); +} +#endif + +#ifndef setenv_TZ +static int +setenv_TZ (char const *tz) +{ + return tz ? setenv (TZ, tz, 1) : unsetenv (TZ); +} +#endif + +/* Change the environment to match the specified timezone_t value. + Return true if successful, false (setting errno) otherwise. */ +static bool +change_env (timezone_t tz) +{ + if (setenv_TZ (tz->tz_is_set ? tz->abbrs : NULL) != 0) + return false; + tzset (); + return true; +} + +/* Temporarily set the time zone to TZ, which must not be null. + Return LOCAL_TZ if the time zone setting is already correct. + Otherwise return a newly allocated time zone representing the old + setting, or NULL (setting errno) on failure. */ +static timezone_t +set_tz (timezone_t tz) +{ + char *env_tz = getenv_TZ (); + if (env_tz + ? tz->tz_is_set && strcmp (tz->abbrs, env_tz) == 0 + : !tz->tz_is_set) + return local_tz; + else + { + timezone_t old_tz = tzalloc (env_tz); + if (!old_tz) + return old_tz; + if (! change_env (tz)) + { + int saved_errno = errno; + tzfree (old_tz); + errno = saved_errno; + return NULL; + } + return old_tz; + } +} + +/* Restore an old setting returned by set_tz. It must not be null. + Return true (preserving errno) if successful, false (setting errno) + otherwise. */ +static bool +revert_tz (timezone_t tz) +{ + if (tz == local_tz) + return true; + else + { + int saved_errno = errno; + bool ok = change_env (tz); + if (!ok) + saved_errno = errno; + tzfree (tz); + errno = saved_errno; + return ok; + } +} + +/* Use time zone TZ to compute localtime_r (T, TM). */ +struct tm * +localtime_rz (timezone_t tz, time_t const *t, struct tm *tm) +{ + if (!tz) + return gmtime_r (t, tm); + else + { + timezone_t old_tz = set_tz (tz); + if (old_tz) + { + bool abbr_saved = localtime_r (t, tm) && save_abbr (tz, tm); + if (revert_tz (old_tz) && abbr_saved) + return tm; + } + return NULL; + } +} + +/* Use time zone TZ to compute mktime (TM). */ +time_t +mktime_z (timezone_t tz, struct tm *tm) +{ + if (!tz) + return timegm (tm); + else + { + timezone_t old_tz = set_tz (tz); + if (old_tz) + { + time_t t = mktime (tm); +#if HAVE_TM_ZONE || HAVE_TZNAME + time_t badtime = -1; + struct tm tm_1; + if ((t != badtime + || (localtime_r (&t, &tm_1) && equal_tm (tm, &tm_1))) + && !save_abbr (tz, tm)) + t = badtime; +#endif + if (revert_tz (old_tz)) + return t; + } + return -1; + } +} diff --git a/lib/timegm.c b/lib/timegm.c new file mode 100644 index 000000000..d1b355f2f --- /dev/null +++ b/lib/timegm.c @@ -0,0 +1,38 @@ +/* Convert UTC calendar time to simple time. Like mktime but assumes UTC. + + Copyright (C) 1994, 1997, 2003-2004, 2006-2007, 2009-2015 Free Software + Foundation, Inc. This file is part of the GNU C Library. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, see . */ + +#ifndef _LIBC +# include +#endif + +#include + +#ifndef _LIBC +# undef __gmtime_r +# define __gmtime_r gmtime_r +# define __mktime_internal mktime_internal +# include "mktime-internal.h" +#endif + +time_t +timegm (struct tm *tmp) +{ + static time_t gmtime_offset; + tmp->tm_isdst = 0; + return __mktime_internal (tmp, __gmtime_r, &gmtime_offset); +} diff --git a/lib/times.c b/lib/times.c index 605f2356f..3cfad2f09 100644 --- a/lib/times.c +++ b/lib/times.c @@ -1,6 +1,6 @@ /* Get process times - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -62,5 +62,5 @@ times (struct tms * buffer) buffer->tms_cutime = 0; buffer->tms_cstime = 0; - return filetime2clock (creation_time); + return clock (); } diff --git a/lib/trunc.c b/lib/trunc.c index e2857335b..b7b0aa2d0 100644 --- a/lib/trunc.c +++ b/lib/trunc.c @@ -1,5 +1,5 @@ /* Round towards zero. - Copyright (C) 2007, 2010-2014 Free Software Foundation, Inc. + Copyright (C) 2007, 2010-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/unistd.c b/lib/unistd.c index 6c6a8e268..72bad1c05 100644 --- a/lib/unistd.c +++ b/lib/unistd.c @@ -1,3 +1,4 @@ #include #define _GL_UNISTD_INLINE _GL_EXTERN_INLINE #include "unistd.h" +typedef int dummy; diff --git a/lib/unistd.in.h b/lib/unistd.in.h index 842025024..c0bc8c7fe 100644 --- a/lib/unistd.in.h +++ b/lib/unistd.in.h @@ -1,5 +1,5 @@ /* Substitute for and wrapper around . - Copyright (C) 2003-2014 Free Software Foundation, Inc. + Copyright (C) 2003-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -401,6 +401,12 @@ _GL_WARN_ON_USE (dup3, "dup3 is unportable - " /* Set of environment variables and values. An array of strings of the form "VARIABLE=VALUE", terminated with a NULL. */ # if defined __APPLE__ && defined __MACH__ +# include +# if !TARGET_OS_IPHONE && !TARGET_IPHONE_SIMULATOR +# define _GL_USE_CRT_EXTERNS +# endif +# endif +# ifdef _GL_USE_CRT_EXTERNS # include # define environ (*_NSGetEnviron ()) # else @@ -1287,13 +1293,24 @@ _GL_WARN_ON_USE (readlink, "readlink is unportable - " #if @GNULIB_READLINKAT@ -# if !@HAVE_READLINKAT@ +# if @REPLACE_READLINKAT@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# define readlinkat rpl_readlinkat +# endif +_GL_FUNCDECL_RPL (readlinkat, ssize_t, + (int fd, char const *file, char *buf, size_t len) + _GL_ARG_NONNULL ((2, 3))); +_GL_CXXALIAS_RPL (readlinkat, ssize_t, + (int fd, char const *file, char *buf, size_t len)); +# else +# if !@HAVE_READLINKAT@ _GL_FUNCDECL_SYS (readlinkat, ssize_t, (int fd, char const *file, char *buf, size_t len) _GL_ARG_NONNULL ((2, 3))); -# endif +# endif _GL_CXXALIAS_SYS (readlinkat, ssize_t, (int fd, char const *file, char *buf, size_t len)); +# endif _GL_CXXALIASWARN (readlinkat); #elif defined GNULIB_POSIXCHECK # undef readlinkat @@ -1407,13 +1424,25 @@ _GL_WARN_ON_USE (symlink, "symlink is not portable - " #if @GNULIB_SYMLINKAT@ -# if !@HAVE_SYMLINKAT@ +# if @REPLACE_SYMLINKAT@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef symlinkat +# define symlinkat rpl_symlinkat +# endif +_GL_FUNCDECL_RPL (symlinkat, int, + (char const *contents, int fd, char const *file) + _GL_ARG_NONNULL ((1, 3))); +_GL_CXXALIAS_RPL (symlinkat, int, + (char const *contents, int fd, char const *file)); +# else +# if !@HAVE_SYMLINKAT@ _GL_FUNCDECL_SYS (symlinkat, int, (char const *contents, int fd, char const *file) _GL_ARG_NONNULL ((1, 3))); -# endif +# endif _GL_CXXALIAS_SYS (symlinkat, int, (char const *contents, int fd, char const *file)); +# endif _GL_CXXALIASWARN (symlinkat); #elif defined GNULIB_POSIXCHECK # undef symlinkat diff --git a/lib/unistr.in.h b/lib/unistr.in.h index 73d2c23c0..90441493f 100644 --- a/lib/unistr.in.h +++ b/lib/unistr.in.h @@ -1,5 +1,5 @@ /* Elementary Unicode string functions. - Copyright (C) 2001-2002, 2005-2014 Free Software Foundation, Inc. + Copyright (C) 2001-2002, 2005-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/unistr/u8-mbtouc-aux.c b/lib/unistr/u8-mbtouc-aux.c index 02cdacd9d..834725fed 100644 --- a/lib/unistr/u8-mbtouc-aux.c +++ b/lib/unistr/u8-mbtouc-aux.c @@ -1,5 +1,5 @@ /* Conversion UTF-8 to UCS-4. - Copyright (C) 2001-2002, 2006-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2001-2002, 2006-2007, 2009-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2001. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-mbtouc-unsafe-aux.c b/lib/unistr/u8-mbtouc-unsafe-aux.c index bfa96f4ab..b406d3ebd 100644 --- a/lib/unistr/u8-mbtouc-unsafe-aux.c +++ b/lib/unistr/u8-mbtouc-unsafe-aux.c @@ -1,5 +1,5 @@ /* Conversion UTF-8 to UCS-4. - Copyright (C) 2001-2002, 2006-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2001-2002, 2006-2007, 2009-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2001. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-mbtouc-unsafe.c b/lib/unistr/u8-mbtouc-unsafe.c index 9c2095b68..01d12dc41 100644 --- a/lib/unistr/u8-mbtouc-unsafe.c +++ b/lib/unistr/u8-mbtouc-unsafe.c @@ -1,5 +1,5 @@ /* Look at first character in UTF-8 string. - Copyright (C) 1999-2002, 2006-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 1999-2002, 2006-2007, 2009-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2001. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-mbtouc.c b/lib/unistr/u8-mbtouc.c index 2b389deb7..dc4607f68 100644 --- a/lib/unistr/u8-mbtouc.c +++ b/lib/unistr/u8-mbtouc.c @@ -1,5 +1,5 @@ /* Look at first character in UTF-8 string. - Copyright (C) 1999-2002, 2006-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 1999-2002, 2006-2007, 2009-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2001. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-mbtoucr.c b/lib/unistr/u8-mbtoucr.c index 3a75a4118..3d8c05f76 100644 --- a/lib/unistr/u8-mbtoucr.c +++ b/lib/unistr/u8-mbtoucr.c @@ -1,5 +1,5 @@ /* Look at first character in UTF-8 string, returning an error code. - Copyright (C) 1999-2002, 2006-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 1999-2002, 2006-2007, 2009-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2001. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-prev.c b/lib/unistr/u8-prev.c index b2c2b9b41..e01551e57 100644 --- a/lib/unistr/u8-prev.c +++ b/lib/unistr/u8-prev.c @@ -1,5 +1,5 @@ /* Iterate over previous character in UTF-8 string. - Copyright (C) 2002, 2006-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2002, 2006-2007, 2009-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2002. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-uctomb-aux.c b/lib/unistr/u8-uctomb-aux.c index 8d94bf57a..cc9c5441c 100644 --- a/lib/unistr/u8-uctomb-aux.c +++ b/lib/unistr/u8-uctomb-aux.c @@ -1,5 +1,5 @@ /* Conversion UCS-4 to UTF-8. - Copyright (C) 2002, 2006-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2002, 2006-2007, 2009-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2002. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-uctomb.c b/lib/unistr/u8-uctomb.c index 1ce271fe8..43ef23d89 100644 --- a/lib/unistr/u8-uctomb.c +++ b/lib/unistr/u8-uctomb.c @@ -1,5 +1,5 @@ /* Store a character in UTF-8 string. - Copyright (C) 2002, 2005-2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2002, 2005-2006, 2009-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2002. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unitypes.in.h b/lib/unitypes.in.h index e5ff9923c..fb0ce68a1 100644 --- a/lib/unitypes.in.h +++ b/lib/unitypes.in.h @@ -1,5 +1,5 @@ /* Elementary types and macros for the GNU UniString library. - Copyright (C) 2002, 2005-2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2002, 2005-2006, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/unsetenv.c b/lib/unsetenv.c new file mode 100644 index 000000000..5bd9ab493 --- /dev/null +++ b/lib/unsetenv.c @@ -0,0 +1,127 @@ +/* Copyright (C) 1992, 1995-2002, 2005-2015 Free Software Foundation, Inc. + This file is part of the GNU C Library. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +/* Don't use __attribute__ __nonnull__ in this compilation unit. Otherwise gcc + optimizes away the name == NULL test below. */ +#define _GL_ARG_NONNULL(params) + +#include + +/* Specification. */ +#include + +#include +#if !_LIBC +# define __set_errno(ev) ((errno) = (ev)) +#endif + +#include +#include + +#if !_LIBC +# define __environ environ +#endif + +#if _LIBC +/* This lock protects against simultaneous modifications of 'environ'. */ +# include +__libc_lock_define_initialized (static, envlock) +# define LOCK __libc_lock_lock (envlock) +# define UNLOCK __libc_lock_unlock (envlock) +#else +# define LOCK +# define UNLOCK +#endif + +/* In the GNU C library we must keep the namespace clean. */ +#ifdef _LIBC +# define unsetenv __unsetenv +#endif + +#if _LIBC || !HAVE_UNSETENV + +int +unsetenv (const char *name) +{ + size_t len; + char **ep; + + if (name == NULL || *name == '\0' || strchr (name, '=') != NULL) + { + __set_errno (EINVAL); + return -1; + } + + len = strlen (name); + + LOCK; + + ep = __environ; + while (*ep != NULL) + if (!strncmp (*ep, name, len) && (*ep)[len] == '=') + { + /* Found it. Remove this pointer by moving later ones back. */ + char **dp = ep; + + do + dp[0] = dp[1]; + while (*dp++); + /* Continue the loop in case NAME appears again. */ + } + else + ++ep; + + UNLOCK; + + return 0; +} + +#ifdef _LIBC +# undef unsetenv +weak_alias (__unsetenv, unsetenv) +#endif + +#else /* HAVE_UNSETENV */ + +# undef unsetenv +# if !HAVE_DECL_UNSETENV +# if VOID_UNSETENV +extern void unsetenv (const char *); +# else +extern int unsetenv (const char *); +# endif +# endif + +/* Call the underlying unsetenv, in case there is hidden bookkeeping + that needs updating beyond just modifying environ. */ +int +rpl_unsetenv (const char *name) +{ + int result = 0; + if (!name || !*name || strchr (name, '=')) + { + errno = EINVAL; + return -1; + } + while (getenv (name)) +# if !VOID_UNSETENV + result = +# endif + unsetenv (name); + return result; +} + +#endif /* HAVE_UNSETENV */ diff --git a/lib/vasnprintf.c b/lib/vasnprintf.c index 7282b0504..daea81642 100644 --- a/lib/vasnprintf.c +++ b/lib/vasnprintf.c @@ -1,5 +1,5 @@ /* vsprintf with automatic memory allocation. - Copyright (C) 1999, 2002-2014 Free Software Foundation, Inc. + Copyright (C) 1999, 2002-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -1886,7 +1886,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, else { do - result[length++] = (unsigned char) *cp++; + result[length++] = *cp++; while (--n > 0); } } @@ -1957,15 +1957,14 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, if (!(a.arg[dp->width_arg_index].type == TYPE_INT)) abort (); arg = a.arg[dp->width_arg_index].a.a_int; + width = arg; if (arg < 0) { /* "A negative field width is taken as a '-' flag followed by a positive field width." */ flags |= FLAG_LEFT; - width = (unsigned int) (-arg); + width = -width; } - else - width = arg; } else { @@ -2073,8 +2072,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, characters = 0; } - if (has_width && width > characters - && !(dp->flags & FLAG_LEFT)) + if (characters < width && !(dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2127,8 +2125,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, } # endif - if (has_width && width > characters - && (dp->flags & FLAG_LEFT)) + if (characters < width && (dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2201,8 +2198,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, characters = 0; } - if (has_width && width > characters - && !(dp->flags & FLAG_LEFT)) + if (characters < width && !(dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2255,8 +2251,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, } # endif - if (has_width && width > characters - && (dp->flags & FLAG_LEFT)) + if (characters < width && (dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2329,8 +2324,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, characters = 0; } - if (has_width && width > characters - && !(dp->flags & FLAG_LEFT)) + if (characters < width && !(dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2383,8 +2377,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, } # endif - if (has_width && width > characters - && (dp->flags & FLAG_LEFT)) + if (characters < width && (dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2435,15 +2428,14 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, if (!(a.arg[dp->width_arg_index].type == TYPE_INT)) abort (); arg = a.arg[dp->width_arg_index].a.a_int; + width = arg; if (arg < 0) { /* "A negative field width is taken as a '-' flag followed by a positive field width." */ flags |= FLAG_LEFT; - width = (unsigned int) (-arg); + width = -width; } - else - width = arg; } else { @@ -2573,8 +2565,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, characters = 0; } - if (has_width && width > characters - && !(dp->flags & FLAG_LEFT)) + if (characters < width && !(dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2635,8 +2626,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, } } - if (has_width && width > characters - && (dp->flags & FLAG_LEFT)) + if (characters < width && (dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2827,8 +2817,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, /* w doesn't matter. */ w = 0; - if (has_width && width > w - && !(dp->flags & FLAG_LEFT)) + if (w < width && !(dp->flags & FLAG_LEFT)) { size_t n = width - w; ENSURE_ALLOCATION (xsum (length, n)); @@ -2911,8 +2900,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, length += tmpdst_len; # endif - if (has_width && width > w - && (dp->flags & FLAG_LEFT)) + if (w < width && (dp->flags & FLAG_LEFT)) { size_t n = width - w; ENSURE_ALLOCATION (xsum (length, n)); @@ -2939,17 +2927,16 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, { arg_type type = a.arg[dp->arg_index].type; int flags = dp->flags; - int has_width; size_t width; int has_precision; size_t precision; size_t tmp_length; + size_t count; DCHAR_T tmpbuf[700]; DCHAR_T *tmp; DCHAR_T *pad_ptr; DCHAR_T *p; - has_width = 0; width = 0; if (dp->width_start != dp->width_end) { @@ -2960,15 +2947,14 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, if (!(a.arg[dp->width_arg_index].type == TYPE_INT)) abort (); arg = a.arg[dp->width_arg_index].a.a_int; + width = arg; if (arg < 0) { /* "A negative field width is taken as a '-' flag followed by a positive field width." */ flags |= FLAG_LEFT; - width = (unsigned int) (-arg); + width = -width; } - else - width = arg; } else { @@ -2978,7 +2964,6 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, width = xsum (xtimes (width, 10), *digitp++ - '0'); while (digitp != dp->width_end); } - has_width = 1; } has_precision = 0; @@ -3354,11 +3339,14 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, abort (); # endif } + /* The generated string now extends from tmp to p, with the zero padding insertion point being at pad_ptr. */ - if (has_width && p - tmp < width) + count = p - tmp; + + if (count < width) { - size_t pad = width - (p - tmp); + size_t pad = width - count; DCHAR_T *end = p + pad; if (flags & FLAG_LEFT) @@ -3391,28 +3379,26 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, p = end; } - { - size_t count = p - tmp; + count = p - tmp; - if (count >= tmp_length) - /* tmp_length was incorrectly calculated - fix the - code above! */ - abort (); + if (count >= tmp_length) + /* tmp_length was incorrectly calculated - fix the + code above! */ + abort (); - /* Make room for the result. */ - if (count >= allocated - length) - { - size_t n = xsum (length, count); + /* Make room for the result. */ + if (count >= allocated - length) + { + size_t n = xsum (length, count); - ENSURE_ALLOCATION (n); - } + ENSURE_ALLOCATION (n); + } - /* Append the result. */ - memcpy (result + length, tmp, count * sizeof (DCHAR_T)); - if (tmp != tmpbuf) - free (tmp); - length += count; - } + /* Append the result. */ + memcpy (result + length, tmp, count * sizeof (DCHAR_T)); + if (tmp != tmpbuf) + free (tmp); + length += count; } #endif #if (NEED_PRINTF_INFINITE_DOUBLE || NEED_PRINTF_DOUBLE || NEED_PRINTF_INFINITE_LONG_DOUBLE || NEED_PRINTF_LONG_DOUBLE) && !defined IN_LIBINTL @@ -3446,8 +3432,8 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, arg_type type = a.arg[dp->arg_index].type; # endif int flags = dp->flags; - int has_width; size_t width; + size_t count; int has_precision; size_t precision; size_t tmp_length; @@ -3456,7 +3442,6 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, DCHAR_T *pad_ptr; DCHAR_T *p; - has_width = 0; width = 0; if (dp->width_start != dp->width_end) { @@ -3467,15 +3452,14 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, if (!(a.arg[dp->width_arg_index].type == TYPE_INT)) abort (); arg = a.arg[dp->width_arg_index].a.a_int; + width = arg; if (arg < 0) { /* "A negative field width is taken as a '-' flag followed by a positive field width." */ flags |= FLAG_LEFT; - width = (unsigned int) (-arg); + width = -width; } - else - width = arg; } else { @@ -3485,7 +3469,6 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, width = xsum (xtimes (width, 10), *digitp++ - '0'); while (digitp != dp->width_end); } - has_width = 1; } has_precision = 0; @@ -3925,9 +3908,9 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, digits without trailing zeroes. */ if (exponent >= 0) { - size_t count = exponent + 1; + size_t ecount = exponent + 1; /* Note: count <= precision = ndigits. */ - for (; count > 0; count--) + for (; ecount > 0; ecount--) *p++ = digits[--ndigits]; if ((flags & FLAG_ALT) || ndigits > nzeroes) { @@ -3941,10 +3924,10 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, } else { - size_t count = -exponent - 1; + size_t ecount = -exponent - 1; *p++ = '0'; *p++ = decimal_point_char (); - for (; count > 0; count--) + for (; ecount > 0; ecount--) *p++ = '0'; while (ndigits > nzeroes) { @@ -4395,9 +4378,9 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, digits without trailing zeroes. */ if (exponent >= 0) { - size_t count = exponent + 1; - /* Note: count <= precision = ndigits. */ - for (; count > 0; count--) + size_t ecount = exponent + 1; + /* Note: ecount <= precision = ndigits. */ + for (; ecount > 0; ecount--) *p++ = digits[--ndigits]; if ((flags & FLAG_ALT) || ndigits > nzeroes) { @@ -4411,10 +4394,10 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, } else { - size_t count = -exponent - 1; + size_t ecount = -exponent - 1; *p++ = '0'; *p++ = decimal_point_char (); - for (; count > 0; count--) + for (; ecount > 0; ecount--) *p++ = '0'; while (ndigits > nzeroes) { @@ -4542,9 +4525,11 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, /* The generated string now extends from tmp to p, with the zero padding insertion point being at pad_ptr. */ - if (has_width && p - tmp < width) + count = p - tmp; + + if (count < width) { - size_t pad = width - (p - tmp); + size_t pad = width - count; DCHAR_T *end = p + pad; if (flags & FLAG_LEFT) @@ -4577,36 +4562,36 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, p = end; } - { - size_t count = p - tmp; + count = p - tmp; - if (count >= tmp_length) - /* tmp_length was incorrectly calculated - fix the - code above! */ - abort (); + if (count >= tmp_length) + /* tmp_length was incorrectly calculated - fix the + code above! */ + abort (); - /* Make room for the result. */ - if (count >= allocated - length) - { - size_t n = xsum (length, count); + /* Make room for the result. */ + if (count >= allocated - length) + { + size_t n = xsum (length, count); - ENSURE_ALLOCATION (n); - } + ENSURE_ALLOCATION (n); + } - /* Append the result. */ - memcpy (result + length, tmp, count * sizeof (DCHAR_T)); - if (tmp != tmpbuf) - free (tmp); - length += count; - } + /* Append the result. */ + memcpy (result + length, tmp, count * sizeof (DCHAR_T)); + if (tmp != tmpbuf) + free (tmp); + length += count; } #endif else { arg_type type = a.arg[dp->arg_index].type; int flags = dp->flags; -#if !USE_SNPRINTF || !HAVE_SNPRINTF_RETVAL_C99 || !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_LEFTADJUST || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION +#if !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_LEFTADJUST || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION int has_width; +#endif +#if !USE_SNPRINTF || !HAVE_SNPRINTF_RETVAL_C99 || !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_LEFTADJUST || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION size_t width; #endif #if !USE_SNPRINTF || !HAVE_SNPRINTF_RETVAL_C99 || NEED_PRINTF_UNBOUNDED_PRECISION @@ -4635,8 +4620,10 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, TCHAR_T *tmp; #endif -#if !USE_SNPRINTF || !HAVE_SNPRINTF_RETVAL_C99 || !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_LEFTADJUST || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION +#if !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_LEFTADJUST || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION has_width = 0; +#endif +#if !USE_SNPRINTF || !HAVE_SNPRINTF_RETVAL_C99 || !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_LEFTADJUST || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION width = 0; if (dp->width_start != dp->width_end) { @@ -4647,15 +4634,14 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, if (!(a.arg[dp->width_arg_index].type == TYPE_INT)) abort (); arg = a.arg[dp->width_arg_index].a.a_int; + width = arg; if (arg < 0) { /* "A negative field width is taken as a '-' flag followed by a positive field width." */ flags |= FLAG_LEFT; - width = (unsigned int) (-arg); + width = -width; } - else - width = arg; } else { @@ -4665,7 +4651,9 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, width = xsum (xtimes (width, 10), *digitp++ - '0'); while (digitp != dp->width_end); } +#if !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_LEFTADJUST || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION has_width = 1; +#endif } #endif @@ -4805,7 +4793,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, { const FCHAR_T *mp = dp->width_start; do - *fbp++ = (unsigned char) *mp++; + *fbp++ = *mp++; while (--n > 0); } } @@ -4826,7 +4814,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, { const FCHAR_T *mp = dp->precision_start; do - *fbp++ = (unsigned char) *mp++; + *fbp++ = *mp++; while (--n > 0); } } @@ -5153,7 +5141,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, size_t tmp_length = MAX_ROOM_NEEDED (&a, dp->arg_index, dp->conversion, type, flags, - has_width ? width : 0, + width, has_precision, precision, pad_ourselves); @@ -5191,18 +5179,21 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, /* SNPRINTF or sprintf failed. Save and use the errno that it has set, if any. */ int saved_errno = errno; + if (saved_errno == 0) + { + if (dp->conversion == 'c' || dp->conversion == 's') + saved_errno = EILSEQ; + else + saved_errno = EINVAL; + } if (!(result == resultbuf || result == NULL)) free (result); if (buf_malloced != NULL) free (buf_malloced); CLEANUP (); - errno = - (saved_errno != 0 - ? saved_errno - : (dp->conversion == 'c' || dp->conversion == 's' - ? EILSEQ - : EINVAL)); + + errno = saved_errno; return NULL; } @@ -5391,7 +5382,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, tmpsrc += count; tmpdst += count; for (n = count; n > 0; n--) - *--tmpdst = (unsigned char) *--tmpsrc; + *--tmpdst = *--tmpsrc; } } #endif diff --git a/lib/vasnprintf.h b/lib/vasnprintf.h index a3f48e828..d691a5ffe 100644 --- a/lib/vasnprintf.h +++ b/lib/vasnprintf.h @@ -1,5 +1,5 @@ /* vsprintf with automatic memory allocation. - Copyright (C) 2002-2004, 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2002-2004, 2007-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/verify.h b/lib/verify.h index 78d543f04..db52900e1 100644 --- a/lib/verify.h +++ b/lib/verify.h @@ -1,6 +1,6 @@ /* Compile-time assert-like macros. - Copyright (C) 2005-2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2005-2006, 2009-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/vsnprintf.c b/lib/vsnprintf.c index 26b1887b0..96024096d 100644 --- a/lib/vsnprintf.c +++ b/lib/vsnprintf.c @@ -1,5 +1,5 @@ /* Formatted output to strings. - Copyright (C) 2004, 2006-2014 Free Software Foundation, Inc. + Copyright (C) 2004, 2006-2015 Free Software Foundation, Inc. Written by Simon Josefsson and Yoann Vandoorselaere . This program is free software; you can redistribute it and/or modify diff --git a/lib/w32sock.h b/lib/w32sock.h index 3946d4945..072a7f53d 100644 --- a/lib/w32sock.h +++ b/lib/w32sock.h @@ -1,6 +1,6 @@ /* w32sock.h --- internal auxiliary functions for Windows socket functions - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/wchar.in.h b/lib/wchar.in.h index 1874b4d7e..b15ad4b71 100644 --- a/lib/wchar.in.h +++ b/lib/wchar.in.h @@ -1,6 +1,6 @@ /* A substitute for ISO C99 , for platforms that have issues. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -30,9 +30,14 @@ #endif @PRAGMA_COLUMNS@ -#if defined __need_mbstate_t || defined __need_wint_t || (defined __hpux && ((defined _INTTYPES_INCLUDED && !defined strtoimax) || defined _GL_JUST_INCLUDE_SYSTEM_WCHAR_H)) || defined _GL_ALREADY_INCLUDING_WCHAR_H +#if (((defined __need_mbstate_t || defined __need_wint_t) \ + && !defined __MINGW32__) \ + || (defined __hpux \ + && ((defined _INTTYPES_INCLUDED && !defined strtoimax) \ + || defined _GL_JUST_INCLUDE_SYSTEM_WCHAR_H)) \ + || defined _GL_ALREADY_INCLUDING_WCHAR_H) /* Special invocation convention: - - Inside glibc and uClibc header files. + - Inside glibc and uClibc header files, but not MinGW. - On HP-UX 11.00 we have a sequence of nested includes -> -> , and the latter includes , once indirectly -> -> -> diff --git a/lib/wcrtomb.c b/lib/wcrtomb.c index ebbdddccc..bd7a7babb 100644 --- a/lib/wcrtomb.c +++ b/lib/wcrtomb.c @@ -1,5 +1,5 @@ /* Convert wide character to multibyte character. - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2008. This program is free software: you can redistribute it and/or modify diff --git a/lib/wctype.in.h b/lib/wctype.in.h index b5b6093d7..2c6fe4a79 100644 --- a/lib/wctype.in.h +++ b/lib/wctype.in.h @@ -1,6 +1,6 @@ /* A substitute for ISO C99 , for platforms that lack it. - Copyright (C) 2006-2014 Free Software Foundation, Inc. + Copyright (C) 2006-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/write.c b/lib/write.c index 51cc1d91e..dbc384008 100644 --- a/lib/write.c +++ b/lib/write.c @@ -1,5 +1,5 @@ /* POSIX compatible write() function. - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2015 Free Software Foundation, Inc. Written by Bruno Haible , 2008. This program is free software: you can redistribute it and/or modify diff --git a/lib/xsize.h b/lib/xsize.h index 83cb960b5..a34d3435d 100644 --- a/lib/xsize.h +++ b/lib/xsize.h @@ -1,6 +1,6 @@ /* xsize.h -- Checked size_t computations. - Copyright (C) 2003, 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2003, 2008-2015 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/m4/00gnulib.m4 b/m4/00gnulib.m4 index 8eca5518a..c7103ed52 100644 --- a/m4/00gnulib.m4 +++ b/m4/00gnulib.m4 @@ -1,5 +1,5 @@ # 00gnulib.m4 serial 3 -dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/absolute-header.m4 b/m4/absolute-header.m4 index ce3e39e9b..bc19dfc30 100644 --- a/m4/absolute-header.m4 +++ b/m4/absolute-header.m4 @@ -1,5 +1,5 @@ # absolute-header.m4 serial 16 -dnl Copyright (C) 2006-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/alloca.m4 b/m4/alloca.m4 index d7bdea631..8408bed28 100644 --- a/m4/alloca.m4 +++ b/m4/alloca.m4 @@ -1,5 +1,5 @@ # alloca.m4 serial 14 -dnl Copyright (C) 2002-2004, 2006-2007, 2009-2014 Free Software Foundation, +dnl Copyright (C) 2002-2004, 2006-2007, 2009-2015 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/arpa_inet_h.m4 b/m4/arpa_inet_h.m4 index f01699a9d..056bc7b4b 100644 --- a/m4/arpa_inet_h.m4 +++ b/m4/arpa_inet_h.m4 @@ -1,5 +1,5 @@ # arpa_inet_h.m4 serial 13 -dnl Copyright (C) 2006, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/autobuild.m4 b/m4/autobuild.m4 index 00d870930..239809cd5 100644 --- a/m4/autobuild.m4 +++ b/m4/autobuild.m4 @@ -1,5 +1,5 @@ # autobuild.m4 serial 7 -dnl Copyright (C) 2004, 2006-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2004, 2006-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/btowc.m4 b/m4/btowc.m4 index 99889445f..c1da65d43 100644 --- a/m4/btowc.m4 +++ b/m4/btowc.m4 @@ -1,5 +1,5 @@ # btowc.m4 serial 10 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/byteswap.m4 b/m4/byteswap.m4 index 6d6357cbe..ec5d46cde 100644 --- a/m4/byteswap.m4 +++ b/m4/byteswap.m4 @@ -1,5 +1,5 @@ # byteswap.m4 serial 4 -dnl Copyright (C) 2005, 2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2005, 2007, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/canonicalize.m4 b/m4/canonicalize.m4 index ace455661..6d932fd1a 100644 --- a/m4/canonicalize.m4 +++ b/m4/canonicalize.m4 @@ -1,6 +1,6 @@ # canonicalize.m4 serial 26 -dnl Copyright (C) 2003-2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2003-2007, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/ceil.m4 b/m4/ceil.m4 index 128353ae7..fb5f6f0d5 100644 --- a/m4/ceil.m4 +++ b/m4/ceil.m4 @@ -1,5 +1,5 @@ # ceil.m4 serial 9 -dnl Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/check-math-lib.m4 b/m4/check-math-lib.m4 index a3894aa64..1c83f8fcb 100644 --- a/m4/check-math-lib.m4 +++ b/m4/check-math-lib.m4 @@ -1,5 +1,5 @@ # check-math-lib.m4 serial 4 -dnl Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/clock_time.m4 b/m4/clock_time.m4 index be36a42b8..efb2ac583 100644 --- a/m4/clock_time.m4 +++ b/m4/clock_time.m4 @@ -1,5 +1,5 @@ # clock_time.m4 serial 10 -dnl Copyright (C) 2002-2006, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2006, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/close.m4 b/m4/close.m4 index 68510c5c5..d04aefbee 100644 --- a/m4/close.m4 +++ b/m4/close.m4 @@ -1,5 +1,5 @@ # close.m4 serial 8 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/configmake.m4 b/m4/configmake.m4 index 0cd86cf99..49d3a13e3 100644 --- a/m4/configmake.m4 +++ b/m4/configmake.m4 @@ -1,5 +1,5 @@ # configmake.m4 serial 2 -dnl Copyright (C) 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/copysign.m4 b/m4/copysign.m4 index 1bb2d6fb9..7cb33b666 100644 --- a/m4/copysign.m4 +++ b/m4/copysign.m4 @@ -1,5 +1,5 @@ # copysign.m4 serial 1 -dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/dirent_h.m4 b/m4/dirent_h.m4 index 3f2b16b12..7abd1d05e 100644 --- a/m4/dirent_h.m4 +++ b/m4/dirent_h.m4 @@ -1,5 +1,5 @@ # dirent_h.m4 serial 16 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/dirfd.m4 b/m4/dirfd.m4 index b42276948..ce56cff69 100644 --- a/m4/dirfd.m4 +++ b/m4/dirfd.m4 @@ -2,7 +2,7 @@ dnl Find out how to get the file descriptor associated with an open DIR*. -# Copyright (C) 2001-2006, 2008-2014 Free Software Foundation, Inc. +# Copyright (C) 2001-2006, 2008-2015 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/dirname.m4 b/m4/dirname.m4 index d2627b8a8..2a0be516e 100644 --- a/m4/dirname.m4 +++ b/m4/dirname.m4 @@ -1,5 +1,5 @@ #serial 10 -*- autoconf -*- -dnl Copyright (C) 2002-2006, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2006, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/double-slash-root.m4 b/m4/double-slash-root.m4 index 937f4bca9..f307eb2ff 100644 --- a/m4/double-slash-root.m4 +++ b/m4/double-slash-root.m4 @@ -1,5 +1,5 @@ # double-slash-root.m4 serial 4 -*- Autoconf -*- -dnl Copyright (C) 2006, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/dup2.m4 b/m4/dup2.m4 index 89638a0bf..59028e098 100644 --- a/m4/dup2.m4 +++ b/m4/dup2.m4 @@ -1,5 +1,5 @@ -#serial 20 -dnl Copyright (C) 2002, 2005, 2007, 2009-2014 Free Software Foundation, Inc. +#serial 24 +dnl Copyright (C) 2002, 2005, 2007, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -19,33 +19,50 @@ AC_DEFUN([gl_FUNC_DUP2], if test $HAVE_DUP2 = 1; then AC_CACHE_CHECK([whether dup2 works], [gl_cv_func_dup2_works], [AC_RUN_IFELSE([ - AC_LANG_PROGRAM([[#include -#include -#include ]], - [int result = 0; -#ifdef FD_CLOEXEC - if (fcntl (1, F_SETFD, FD_CLOEXEC) == -1) - result |= 1; -#endif - if (dup2 (1, 1) == 0) - result |= 2; -#ifdef FD_CLOEXEC - if (fcntl (1, F_GETFD) != FD_CLOEXEC) - result |= 4; -#endif - close (0); - if (dup2 (0, 0) != -1) - result |= 8; - /* Many gnulib modules require POSIX conformance of EBADF. */ - if (dup2 (2, 1000000) == -1 && errno != EBADF) - result |= 16; - /* Flush out some cygwin core dumps. */ - if (dup2 (2, -1) != -1 || errno != EBADF) - result |= 32; - dup2 (2, 255); - dup2 (2, 256); - return result; - ]) + AC_LANG_PROGRAM( + [[#include + #include + #include + #include + #include + #ifndef RLIM_SAVED_CUR + # define RLIM_SAVED_CUR RLIM_INFINITY + #endif + #ifndef RLIM_SAVED_MAX + # define RLIM_SAVED_MAX RLIM_INFINITY + #endif + ]], + [[int result = 0; + int bad_fd = INT_MAX; + struct rlimit rlim; + if (getrlimit (RLIMIT_NOFILE, &rlim) == 0 + && 0 <= rlim.rlim_cur && rlim.rlim_cur <= INT_MAX + && rlim.rlim_cur != RLIM_INFINITY + && rlim.rlim_cur != RLIM_SAVED_MAX + && rlim.rlim_cur != RLIM_SAVED_CUR) + bad_fd = rlim.rlim_cur; + #ifdef FD_CLOEXEC + if (fcntl (1, F_SETFD, FD_CLOEXEC) == -1) + result |= 1; + #endif + if (dup2 (1, 1) != 1) + result |= 2; + #ifdef FD_CLOEXEC + if (fcntl (1, F_GETFD) != FD_CLOEXEC) + result |= 4; + #endif + close (0); + if (dup2 (0, 0) != -1) + result |= 8; + /* Many gnulib modules require POSIX conformance of EBADF. */ + if (dup2 (2, bad_fd) == -1 && errno != EBADF) + result |= 16; + /* Flush out some cygwin core dumps. */ + if (dup2 (2, -1) != -1 || errno != EBADF) + result |= 32; + dup2 (2, 255); + dup2 (2, 256); + return result;]]) ], [gl_cv_func_dup2_works=yes], [gl_cv_func_dup2_works=no], [case "$host_os" in @@ -53,13 +70,14 @@ AC_DEFUN([gl_FUNC_DUP2], gl_cv_func_dup2_works="guessing no" ;; cygwin*) # on cygwin 1.5.x, dup2(1,1) returns 0 gl_cv_func_dup2_works="guessing no" ;; - linux*) # On linux between 2008-07-27 and 2009-05-11, dup2 of a - # closed fd may yield -EBADF instead of -1 / errno=EBADF. - gl_cv_func_dup2_works="guessing no" ;; - freebsd*) # on FreeBSD 6.1, dup2(1,1000000) gives EMFILE, not EBADF. + aix* | freebsd*) + # on AIX 7.1 and FreeBSD 6.1, dup2 (1,toobig) gives EMFILE, + # not EBADF. gl_cv_func_dup2_works="guessing no" ;; haiku*) # on Haiku alpha 2, dup2(1, 1) resets FD_CLOEXEC. gl_cv_func_dup2_works="guessing no" ;; + *-android*) # implemented using dup3(), which fails if oldfd == newfd + gl_cv_func_dup2_works="guessing no" ;; *) gl_cv_func_dup2_works="guessing yes" ;; esac]) ]) diff --git a/m4/duplocale.m4 b/m4/duplocale.m4 index d45891d4f..5f17769cd 100644 --- a/m4/duplocale.m4 +++ b/m4/duplocale.m4 @@ -1,5 +1,5 @@ # duplocale.m4 serial 7 -dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/eealloc.m4 b/m4/eealloc.m4 index 8a51fe7c5..322bdd50b 100644 --- a/m4/eealloc.m4 +++ b/m4/eealloc.m4 @@ -1,5 +1,5 @@ # eealloc.m4 serial 3 -dnl Copyright (C) 2003, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/environ.m4 b/m4/environ.m4 index cfabe46f5..4dbf9473e 100644 --- a/m4/environ.m4 +++ b/m4/environ.m4 @@ -1,5 +1,5 @@ # environ.m4 serial 6 -dnl Copyright (C) 2001-2004, 2006-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2004, 2006-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/errno_h.m4 b/m4/errno_h.m4 index 4ee9e6a14..cfaa68761 100644 --- a/m4/errno_h.m4 +++ b/m4/errno_h.m4 @@ -1,5 +1,5 @@ # errno_h.m4 serial 12 -dnl Copyright (C) 2004, 2006, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2004, 2006, 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/exponentd.m4 b/m4/exponentd.m4 index 7bee63571..84f1691a6 100644 --- a/m4/exponentd.m4 +++ b/m4/exponentd.m4 @@ -1,5 +1,5 @@ # exponentd.m4 serial 3 -dnl Copyright (C) 2007-2008, 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2008, 2010-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/exponentf.m4 b/m4/exponentf.m4 index b2dfeef96..95e32cdd9 100644 --- a/m4/exponentf.m4 +++ b/m4/exponentf.m4 @@ -1,5 +1,5 @@ # exponentf.m4 serial 2 -dnl Copyright (C) 2007-2008, 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2008, 2010-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/exponentl.m4 b/m4/exponentl.m4 index d6f4ba7ff..6b95e7372 100644 --- a/m4/exponentl.m4 +++ b/m4/exponentl.m4 @@ -1,5 +1,5 @@ # exponentl.m4 serial 3 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/extensions.m4 b/m4/extensions.m4 index 37f55ca3d..35bc49c97 100644 --- a/m4/extensions.m4 +++ b/m4/extensions.m4 @@ -1,7 +1,7 @@ # serial 13 -*- Autoconf -*- # Enable extensions on systems that normally disable them. -# Copyright (C) 2003, 2006-2014 Free Software Foundation, Inc. +# Copyright (C) 2003, 2006-2015 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. @@ -68,6 +68,10 @@ dnl configure.ac when using autoheader 2.62. #ifndef _GNU_SOURCE # undef _GNU_SOURCE #endif +/* Use GNU style printf and scanf. */ +#ifndef __USE_MINGW_ANSI_STDIO +# undef __USE_MINGW_ANSI_STDIO +#endif /* Enable threading extensions on Solaris. */ #ifndef _POSIX_PTHREAD_SEMANTICS # undef _POSIX_PTHREAD_SEMANTICS @@ -100,6 +104,7 @@ dnl configure.ac when using autoheader 2.62. AC_DEFINE([_ALL_SOURCE]) AC_DEFINE([_DARWIN_C_SOURCE]) AC_DEFINE([_GNU_SOURCE]) + AC_DEFINE([__USE_MINGW_ANSI_STDIO]) AC_DEFINE([_POSIX_PTHREAD_SEMANTICS]) AC_DEFINE([_TANDEM_SOURCE]) AC_CACHE_CHECK([whether _XOPEN_SOURCE should be defined], diff --git a/m4/extern-inline.m4 b/m4/extern-inline.m4 index 240150efb..72800650e 100644 --- a/m4/extern-inline.m4 +++ b/m4/extern-inline.m4 @@ -1,6 +1,6 @@ dnl 'extern inline' a la ISO C99. -dnl Copyright 2012-2014 Free Software Foundation, Inc. +dnl Copyright 2012-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -19,13 +19,28 @@ AC_DEFUN([gl_EXTERN_INLINE], 'reference to static identifier "f" in extern inline function'. This bug was observed with Sun C 5.12 SunOS_i386 2011/11/16. - Suppress the use of extern inline on problematic Apple configurations. - OS X 10.8 and earlier mishandle it; see, e.g., - . + Suppress extern inline (with or without __attribute__ ((__gnu_inline__))) + on configurations that mistakenly use 'static inline' to implement + functions or macros in standard C headers like . For example, + if isdigit is mistakenly implemented via a static inline function, + a program containing an extern inline function that calls isdigit + may not work since the C standard prohibits extern inline functions + from calling static functions. This bug is known to occur on: + + OS X 10.8 and earlier; see: + http://lists.gnu.org/archive/html/bug-gnulib/2012-12/msg00023.html + + DragonFly; see + http://muscles.dragonflybsd.org/bulk/bleeding-edge-potential/latest-per-pkg/ah-tty-0.3.12.log + + FreeBSD; see: + http://lists.gnu.org/archive/html/bug-gnulib/2014-07/msg00104.html + OS X 10.9 has a macro __header_inline indicating the bug is fixed for C and for clang but remains for g++; see . - Perhaps Apple will fix this some day. */ -#if (defined __APPLE__ \ + Assume DragonFly and FreeBSD will be similar. */ +#if (((defined __APPLE__ && defined __MACH__) \ + || defined __DragonFly__ || defined __FreeBSD__) \ && (defined __header_inline \ ? (defined __cplusplus && defined __GNUC_STDC_INLINE__ \ && ! defined __clang__) \ @@ -33,19 +48,19 @@ AC_DEFUN([gl_EXTERN_INLINE], && (defined __GNUC__ || defined __cplusplus)) \ || (defined _FORTIFY_SOURCE && 0 < _FORTIFY_SOURCE \ && defined __GNUC__ && ! defined __cplusplus)))) -# define _GL_EXTERN_INLINE_APPLE_BUG +# define _GL_EXTERN_INLINE_STDHEADER_BUG #endif #if ((__GNUC__ \ ? defined __GNUC_STDC_INLINE__ && __GNUC_STDC_INLINE__ \ : (199901L <= __STDC_VERSION__ \ && !defined __HP_cc \ && !(defined __SUNPRO_C && __STDC__))) \ - && !defined _GL_EXTERN_INLINE_APPLE_BUG) + && !defined _GL_EXTERN_INLINE_STDHEADER_BUG) # define _GL_INLINE inline # define _GL_EXTERN_INLINE extern inline # define _GL_EXTERN_INLINE_IN_USE #elif (2 < __GNUC__ + (7 <= __GNUC_MINOR__) && !defined __STRICT_ANSI__ \ - && !defined _GL_EXTERN_INLINE_APPLE_BUG) + && !defined _GL_EXTERN_INLINE_STDHEADER_BUG) # if defined __GNUC_GNU_INLINE__ && __GNUC_GNU_INLINE__ /* __gnu_inline__ suppresses a GCC 4.2 diagnostic. */ # define _GL_INLINE extern inline __attribute__ ((__gnu_inline__)) @@ -59,17 +74,19 @@ AC_DEFUN([gl_EXTERN_INLINE], # define _GL_EXTERN_INLINE static _GL_UNUSED #endif -#if 4 < __GNUC__ + (6 <= __GNUC_MINOR__) +/* In GCC 4.6 (inclusive) to 5.1 (exclusive), + suppress bogus "no previous prototype for 'FOO'" + and "no previous declaration for 'FOO'" diagnostics, + when FOO is an inline function in the header; see + and + . */ +#if __GNUC__ == 4 && 6 <= __GNUC_MINOR__ # if defined __GNUC_STDC_INLINE__ && __GNUC_STDC_INLINE__ # define _GL_INLINE_HEADER_CONST_PRAGMA # else # define _GL_INLINE_HEADER_CONST_PRAGMA \ _Pragma ("GCC diagnostic ignored \"-Wsuggest-attribute=const\"") # endif - /* Suppress GCC's bogus "no previous prototype for 'FOO'" - and "no previous declaration for 'FOO'" diagnostics, - when FOO is an inline function in the header; see - . */ # define _GL_INLINE_HEADER_BEGIN \ _Pragma ("GCC diagnostic push") \ _Pragma ("GCC diagnostic ignored \"-Wmissing-prototypes\"") \ diff --git a/m4/fcntl-o.m4 b/m4/fcntl-o.m4 index 43c93124e..891a62fb6 100644 --- a/m4/fcntl-o.m4 +++ b/m4/fcntl-o.m4 @@ -1,5 +1,5 @@ # fcntl-o.m4 serial 4 -dnl Copyright (C) 2006, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/fcntl_h.m4 b/m4/fcntl_h.m4 index fb2556d37..b279162a1 100644 --- a/m4/fcntl_h.m4 +++ b/m4/fcntl_h.m4 @@ -1,6 +1,6 @@ # serial 15 # Configure fcntl.h. -dnl Copyright (C) 2006-2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2007, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/flexmember.m4 b/m4/flexmember.m4 new file mode 100644 index 000000000..95500caf0 --- /dev/null +++ b/m4/flexmember.m4 @@ -0,0 +1,41 @@ +# serial 3 +# Check for flexible array member support. + +# Copyright (C) 2006, 2009-2015 Free Software Foundation, Inc. +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# Written by Paul Eggert. + +AC_DEFUN([AC_C_FLEXIBLE_ARRAY_MEMBER], +[ + AC_CACHE_CHECK([for flexible array member], + ac_cv_c_flexmember, + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM( + [[#include + #include + #include + struct s { int n; double d[]; };]], + [[int m = getchar (); + struct s *p = malloc (offsetof (struct s, d) + + m * sizeof (double)); + p->d[0] = 0.0; + return p->d != (double *) NULL;]])], + [ac_cv_c_flexmember=yes], + [ac_cv_c_flexmember=no])]) + if test $ac_cv_c_flexmember = yes; then + AC_DEFINE([FLEXIBLE_ARRAY_MEMBER], [], + [Define to nothing if C supports flexible array members, and to + 1 if it does not. That way, with a declaration like 'struct s + { int n; double d@<:@FLEXIBLE_ARRAY_MEMBER@:>@; };', the struct hack + can be used with pre-C99 compilers. + When computing the size of such an object, don't use 'sizeof (struct s)' + as it overestimates the size. Use 'offsetof (struct s, d)' instead. + Don't use 'offsetof (struct s, d@<:@0@:>@)', as this doesn't work with + MSVC and with C++ compilers.]) + else + AC_DEFINE([FLEXIBLE_ARRAY_MEMBER], [1]) + fi +]) diff --git a/m4/float_h.m4 b/m4/float_h.m4 index a27ef7f97..e4853f3b0 100644 --- a/m4/float_h.m4 +++ b/m4/float_h.m4 @@ -1,5 +1,5 @@ # float_h.m4 serial 9 -dnl Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/flock.m4 b/m4/flock.m4 index ad2d1290c..ee2941a33 100644 --- a/m4/flock.m4 +++ b/m4/flock.m4 @@ -1,5 +1,5 @@ # flock.m4 serial 3 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/floor.m4 b/m4/floor.m4 index a38c03d14..41195d9d2 100644 --- a/m4/floor.m4 +++ b/m4/floor.m4 @@ -1,5 +1,5 @@ # floor.m4 serial 8 -dnl Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/fpieee.m4 b/m4/fpieee.m4 index 729afe859..41c6033b3 100644 --- a/m4/fpieee.m4 +++ b/m4/fpieee.m4 @@ -1,5 +1,5 @@ -# fpieee.m4 serial 2 -dnl Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. +# fpieee.m4 serial 2 -*- coding: utf-8 -*- +dnl Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/frexp.m4 b/m4/frexp.m4 index 579826213..04f40679a 100644 --- a/m4/frexp.m4 +++ b/m4/frexp.m4 @@ -1,5 +1,5 @@ # frexp.m4 serial 15 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/fstat.m4 b/m4/fstat.m4 index ddd3fb976..d6a928827 100644 --- a/m4/fstat.m4 +++ b/m4/fstat.m4 @@ -1,5 +1,5 @@ # fstat.m4 serial 4 -dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/fsync.m4 b/m4/fsync.m4 index 888a65def..bc2b09352 100644 --- a/m4/fsync.m4 +++ b/m4/fsync.m4 @@ -1,5 +1,5 @@ # fsync.m4 serial 2 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/func.m4 b/m4/func.m4 index 0ab14c9e4..fcc74ff2c 100644 --- a/m4/func.m4 +++ b/m4/func.m4 @@ -1,5 +1,5 @@ # func.m4 serial 2 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/getaddrinfo.m4 b/m4/getaddrinfo.m4 index 2e6658486..f3e40c479 100644 --- a/m4/getaddrinfo.m4 +++ b/m4/getaddrinfo.m4 @@ -1,5 +1,5 @@ # getaddrinfo.m4 serial 30 -dnl Copyright (C) 2004-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2004-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/getlogin.m4 b/m4/getlogin.m4 index 47b8f0897..0db7d51be 100644 --- a/m4/getlogin.m4 +++ b/m4/getlogin.m4 @@ -1,5 +1,5 @@ # getlogin.m4 serial 3 -dnl Copyright (C) 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/gettimeofday.m4 b/m4/gettimeofday.m4 index 1c2d66ee2..ce246e18b 100644 --- a/m4/gettimeofday.m4 +++ b/m4/gettimeofday.m4 @@ -1,6 +1,6 @@ # serial 21 -# Copyright (C) 2001-2003, 2005, 2007, 2009-2014 Free Software Foundation, Inc. +# Copyright (C) 2001-2003, 2005, 2007, 2009-2015 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/glibc21.m4 b/m4/glibc21.m4 index ab58b7121..3a971c5a2 100644 --- a/m4/glibc21.m4 +++ b/m4/glibc21.m4 @@ -1,5 +1,5 @@ # glibc21.m4 serial 5 -dnl Copyright (C) 2000-2002, 2004, 2008, 2010-2014 Free Software Foundation, +dnl Copyright (C) 2000-2002, 2004, 2008, 2010-2015 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index 26c96b3e3..57d23662c 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -1,4 +1,4 @@ -# Copyright (C) 2002-2014 Free Software Foundation, Inc. +# Copyright (C) 2002-2015 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -76,7 +76,6 @@ gl_MODULES([ isfinite isinf isnan - largefile ldexp lib-symbol-versions lib-symbol-visibility @@ -127,7 +126,7 @@ gl_MODULES([ warnings wchar ]) -gl_AVOID([lock]) +gl_AVOID([ lock]) gl_SOURCE_BASE([lib]) gl_M4_BASE([m4]) gl_PO_BASE([]) diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4 index 20ce40e74..50ef97420 100644 --- a/m4/gnulib-common.m4 +++ b/m4/gnulib-common.m4 @@ -1,5 +1,5 @@ -# gnulib-common.m4 serial 34 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +# gnulib-common.m4 serial 36 +dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -49,6 +49,16 @@ AC_DEFUN([gl_COMMON_BODY], [ is a misnomer outside of parameter lists. */ #define _UNUSED_PARAMETER_ _GL_UNUSED +/* gcc supports the "unused" attribute on possibly unused labels, and + g++ has since version 4.5. Note to support C++ as well as C, + _GL_UNUSED_LABEL should be used with a trailing ; */ +#if !defined __cplusplus || __GNUC__ > 4 \ + || (__GNUC__ == 4 && __GNUC_MINOR__ >= 5) +# define _GL_UNUSED_LABEL _GL_UNUSED +#else +# define _GL_UNUSED_LABEL +#endif + /* The __pure__ attribute was added in gcc 2.96. */ #if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 96) # define _GL_ATTRIBUTE_PURE __attribute__ ((__pure__)) @@ -243,9 +253,10 @@ AC_DEFUN([gl_PROG_AR_RANLIB], [ dnl Minix 3 comes with two toolchains: The Amsterdam Compiler Kit compiler dnl as "cc", and GCC as "gcc". They have different object file formats and - dnl library formats. In particular, the GNU binutils programs ar, ranlib + dnl library formats. In particular, the GNU binutils programs ar and ranlib dnl produce libraries that work only with gcc, not with cc. AC_REQUIRE([AC_PROG_CC]) + AC_BEFORE([$0], [AM_PROG_AR]) AC_CACHE_CHECK([for Minix Amsterdam compiler], [gl_cv_c_amsterdam_compiler], [ AC_EGREP_CPP([Amsterdam], @@ -257,25 +268,37 @@ Amsterdam [gl_cv_c_amsterdam_compiler=yes], [gl_cv_c_amsterdam_compiler=no]) ]) - if test -z "$AR"; then - if test $gl_cv_c_amsterdam_compiler = yes; then + + dnl Don't compete with AM_PROG_AR's decision about AR/ARFLAGS if we are not + dnl building with __ACK__. + if test $gl_cv_c_amsterdam_compiler = yes; then + if test -z "$AR"; then AR='cc -c.a' - if test -z "$ARFLAGS"; then - ARFLAGS='-o' - fi - else - dnl Use the Automake-documented default values for AR and ARFLAGS, - dnl but prefer ${host}-ar over ar (useful for cross-compiling). - AC_CHECK_TOOL([AR], [ar], [ar]) - if test -z "$ARFLAGS"; then - ARFLAGS='cru' - fi + fi + if test -z "$ARFLAGS"; then + ARFLAGS='-o' fi else - if test -z "$ARFLAGS"; then - ARFLAGS='cru' - fi + dnl AM_PROG_AR was added in automake v1.11.2. AM_PROG_AR does not AC_SUBST + dnl ARFLAGS variable (it is filed into Makefile.in directly by automake + dnl script on-demand, if not specified by ./configure of course). + dnl Don't AC_REQUIRE the AM_PROG_AR otherwise the code for __ACK__ above + dnl will be ignored. Also, pay attention to call AM_PROG_AR in else block + dnl because AM_PROG_AR is written so it could re-set AR variable even for + dnl __ACK__. It may seem like its easier to avoid calling the macro here, + dnl but we need to AC_SUBST both AR/ARFLAGS (thus those must have some good + dnl default value and automake should usually know them). + m4_ifdef([AM_PROG_AR], [AM_PROG_AR], [:]) fi + + dnl In case the code above has not helped with setting AR/ARFLAGS, use + dnl Automake-documented default values for AR and ARFLAGS, but prefer + dnl ${host}-ar over ar (useful for cross-compiling). + AC_CHECK_TOOL([AR], [ar], [ar]) + if test -z "$ARFLAGS"; then + ARFLAGS='cr' + fi + AC_SUBST([AR]) AC_SUBST([ARFLAGS]) if test -z "$RANLIB"; then @@ -309,26 +332,28 @@ m4_ifdef([AC_PROG_MKDIR_P], [ ]) # AC_C_RESTRICT -# This definition overrides the AC_C_RESTRICT macro from autoconf 2.60..2.61, -# so that mixed use of GNU C and GNU C++ and mixed use of Sun C and Sun C++ -# works. -# This definition can be removed once autoconf >= 2.62 can be assumed. -# AC_AUTOCONF_VERSION was introduced in 2.62, so use that as the witness. -m4_ifndef([AC_AUTOCONF_VERSION],[ +# This definition is copied from post-2.69 Autoconf and overrides the +# AC_C_RESTRICT macro from autoconf 2.60..2.69. It can be removed +# once autoconf >= 2.70 can be assumed. It's painful to check version +# numbers, and in practice this macro is more up-to-date than Autoconf +# is, so override Autoconf unconditionally. AC_DEFUN([AC_C_RESTRICT], [AC_CACHE_CHECK([for C/C++ restrict keyword], [ac_cv_c_restrict], [ac_cv_c_restrict=no # The order here caters to the fact that C++ does not require restrict. for ac_kw in __restrict __restrict__ _Restrict restrict; do - AC_COMPILE_IFELSE([AC_LANG_PROGRAM( - [[typedef int * int_ptr; - int foo (int_ptr $ac_kw ip) { - return ip[0]; - }]], - [[int s[1]; - int * $ac_kw t = s; - t[0] = 0; - return foo(t)]])], + AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM( + [[typedef int *int_ptr; + int foo (int_ptr $ac_kw ip) { return ip[0]; } + int bar (int [$ac_kw]); /* Catch GCC bug 14050. */ + int bar (int ip[$ac_kw]) { return ip[0]; } + ]], + [[int s[1]; + int *$ac_kw t = s; + t[0] = 0; + return foo (t) + bar (t); + ]])], [ac_cv_c_restrict=$ac_kw]) test "$ac_cv_c_restrict" != no && break done @@ -338,21 +363,21 @@ AC_DEFUN([AC_C_RESTRICT], nothing if this is not supported. Do not define if restrict is supported directly. */ #undef restrict -/* Work around a bug in Sun C++: it does not support _Restrict, even - though the corresponding Sun C compiler does, which causes - "#define restrict _Restrict" in the previous line. Perhaps some future - version of Sun C++ will work with _Restrict; if so, it'll probably - define __RESTRICT, just as Sun C does. */ +/* Work around a bug in Sun C++: it does not support _Restrict or + __restrict__, even though the corresponding Sun C compiler ends up with + "#define restrict _Restrict" or "#define restrict __restrict__" in the + previous line. Perhaps some future version of Sun C++ will work with + restrict; if so, hopefully it defines __RESTRICT like Sun C does. */ #if defined __SUNPRO_CC && !defined __RESTRICT # define _Restrict +# define __restrict__ #endif]) case $ac_cv_c_restrict in restrict) ;; no) AC_DEFINE([restrict], []) ;; *) AC_DEFINE_UNQUOTED([restrict], [$ac_cv_c_restrict]) ;; esac -]) -]) +])# AC_C_RESTRICT # gl_BIGENDIAN # is like AC_C_BIGENDIAN, except that it can be AC_REQUIREd. diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 429fee422..a52f18593 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -1,5 +1,5 @@ # DO NOT EDIT! GENERATED AUTOMATICALLY! -# Copyright (C) 2002-2014 Free Software Foundation, Inc. +# Copyright (C) 2002-2015 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -37,7 +37,11 @@ AC_DEFUN([gl_EARLY], m4_pattern_allow([^gl_ES$])dnl a valid locale name m4_pattern_allow([^gl_LIBOBJS$])dnl a variable m4_pattern_allow([^gl_LTLIBOBJS$])dnl a variable + + # Pre-early section. + AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) AC_REQUIRE([gl_PROG_AR_RANLIB]) + AC_REQUIRE([AM_PROG_CC_C_O]) # Code from module absolute-header: # Code from module accept: @@ -46,6 +50,7 @@ AC_DEFUN([gl_EARLY], # Code from module alloca-opt: # Code from module announce-gen: # Code from module arpa_inet: + # Code from module assure: # Code from module autobuild: AB_INIT # Code from module binary-io: @@ -73,10 +78,10 @@ AC_DEFUN([gl_EARLY], # Code from module environ: # Code from module errno: # Code from module extensions: - AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) # Code from module extern-inline: # Code from module fcntl-h: # Code from module fd-hook: + # Code from module flexmember: # Code from module float: # Code from module flock: # Code from module floor: @@ -147,6 +152,8 @@ AC_DEFUN([gl_EARLY], # Code from module memchr: # Code from module mkdir: # Code from module mkstemp: + # Code from module mktime: + # Code from module mktime-internal: # Code from module msvc-inval: # Code from module msvc-nothrow: # Code from module multiarch: @@ -220,6 +227,8 @@ AC_DEFUN([gl_EARLY], # Code from module tempname: # Code from module time: # Code from module time_r: + # Code from module time_rz: + # Code from module timegm: # Code from module times: # Code from module trunc: # Code from module unistd: @@ -230,6 +239,7 @@ AC_DEFUN([gl_EARLY], # Code from module unistr/u8-prev: # Code from module unistr/u8-uctomb: # Code from module unitypes: + # Code from module unsetenv: # Code from module useless-if-before-free: # Code from module vasnprintf: # Code from module vc-list-files: @@ -337,6 +347,7 @@ AC_SUBST([LTALLOCA]) gl_HEADER_ERRNO_H AC_REQUIRE([gl_EXTERN_INLINE]) gl_FCNTL_H + AC_C_FLEXIBLE_ARRAY_MEMBER gl_FLOAT_H if test $REPLACE_FLOAT_LDBL = 1; then AC_LIBOBJ([float]) @@ -591,6 +602,17 @@ AC_SUBST([LTALLOCA]) gl_PREREQ_MKSTEMP fi gl_STDLIB_MODULE_INDICATOR([mkstemp]) + gl_FUNC_MKTIME + if test $REPLACE_MKTIME = 1; then + AC_LIBOBJ([mktime]) + gl_PREREQ_MKTIME + fi + gl_TIME_MODULE_INDICATOR([mktime]) + gl_FUNC_MKTIME_INTERNAL + if test $REPLACE_MKTIME = 1; then + AC_LIBOBJ([mktime]) + gl_PREREQ_MKTIME + fi gl_MSVC_INVAL if test $HAVE_MSVC_INVALID_PARAMETER_HANDLER = 1; then AC_LIBOBJ([msvc-inval]) @@ -749,8 +771,8 @@ AC_SUBST([LTALLOCA]) SYS_IOCTL_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS=1 fi gl_SYS_SOCKET_MODULE_INDICATOR([socket]) - gl_SOCKETLIB - gl_SOCKETS + AC_REQUIRE([gl_SOCKETLIB]) + AC_REQUIRE([gl_SOCKETS]) gl_TYPE_SOCKLEN_T gt_TYPE_SSIZE_T gl_FUNC_STAT @@ -783,7 +805,7 @@ AC_SUBST([LTALLOCA]) AC_PROG_MKDIR_P gl_HEADER_SYS_SELECT AC_PROG_MKDIR_P - gl_HEADER_SYS_SOCKET + AC_REQUIRE([gl_HEADER_SYS_SOCKET]) AC_PROG_MKDIR_P gl_HEADER_SYS_STAT_H AC_PROG_MKDIR_P @@ -803,6 +825,17 @@ AC_SUBST([LTALLOCA]) gl_PREREQ_TIME_R fi gl_TIME_MODULE_INDICATOR([time_r]) + gl_TIME_RZ + if test "$HAVE_TIMEZONE_T" = 0; then + AC_LIBOBJ([time_rz]) + fi + gl_TIME_MODULE_INDICATOR([time_rz]) + gl_FUNC_TIMEGM + if test $HAVE_TIMEGM = 0 || test $REPLACE_TIMEGM = 1; then + AC_LIBOBJ([timegm]) + gl_PREREQ_TIMEGM + fi + gl_TIME_MODULE_INDICATOR([timegm]) gl_FUNC_TIMES if test $HAVE_TIMES = 0; then AC_LIBOBJ([times]) @@ -814,7 +847,7 @@ AC_SUBST([LTALLOCA]) fi gl_MATH_MODULE_INDICATOR([trunc]) gl_UNISTD_H - gl_LIBUNISTRING_LIBHEADER([0.9.2], [unistr.h]) + gl_LIBUNISTRING_LIBHEADER([0.9.4], [unistr.h]) gl_MODULE_INDICATOR([unistr/u8-mbtouc]) gl_LIBUNISTRING_MODULE([0.9.4], [unistr/u8-mbtouc]) gl_MODULE_INDICATOR([unistr/u8-mbtouc-unsafe]) @@ -824,7 +857,13 @@ AC_SUBST([LTALLOCA]) gl_LIBUNISTRING_MODULE([0.9], [unistr/u8-prev]) gl_MODULE_INDICATOR([unistr/u8-uctomb]) gl_LIBUNISTRING_MODULE([0.9], [unistr/u8-uctomb]) - gl_LIBUNISTRING_LIBHEADER([0.9], [unitypes.h]) + gl_LIBUNISTRING_LIBHEADER([0.9.4], [unitypes.h]) + gl_FUNC_UNSETENV + if test $HAVE_UNSETENV = 0 || test $REPLACE_UNSETENV = 1; then + AC_LIBOBJ([unsetenv]) + gl_PREREQ_UNSETENV + fi + gl_STDLIB_MODULE_INDICATOR([unsetenv]) gl_FUNC_VASNPRINTF gl_FUNC_VSNPRINTF gl_STDIO_MODULE_INDICATOR([vsnprintf]) @@ -994,12 +1033,14 @@ AC_DEFUN([gl_FILE_LIST], [ build-aux/useless-if-before-free build-aux/vc-list-files doc/gendocs_template + doc/gendocs_template_min lib/accept.c lib/alignof.h lib/alloca.c lib/alloca.in.h lib/arpa_inet.in.h lib/asnprintf.c + lib/assure.h lib/basename-lgpl.c lib/binary-io.c lib/binary-io.h @@ -1096,6 +1137,8 @@ AC_DEFUN([gl_FILE_LIST], [ lib/memchr.valgrind lib/mkdir.c lib/mkstemp.c + lib/mktime-internal.h + lib/mktime.c lib/msvc-inval.c lib/msvc-inval.h lib/msvc-nothrow.c @@ -1181,8 +1224,11 @@ AC_DEFUN([gl_FILE_LIST], [ lib/sys_uio.in.h lib/tempname.c lib/tempname.h + lib/time-internal.h lib/time.in.h lib/time_r.c + lib/time_rz.c + lib/timegm.c lib/times.c lib/trunc.c lib/unistd.c @@ -1197,6 +1243,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/unistr/u8-uctomb-aux.c lib/unistr/u8-uctomb.c lib/unitypes.in.h + lib/unsetenv.c lib/vasnprintf.c lib/vasnprintf.h lib/verify.h @@ -1240,6 +1287,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/extern-inline.m4 m4/fcntl-o.m4 m4/fcntl_h.m4 + m4/flexmember.m4 m4/float_h.m4 m4/flock.m4 m4/floor.m4 @@ -1301,6 +1349,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/memchr.m4 m4/mkdir.m4 m4/mkstemp.m4 + m4/mktime.m4 m4/mmap-anon.m4 m4/mode_t.m4 m4/msvc-inval.m4 @@ -1365,6 +1414,8 @@ AC_DEFUN([gl_FILE_LIST], [ m4/tempname.m4 m4/time_h.m4 m4/time_r.m4 + m4/time_rz.m4 + m4/timegm.m4 m4/times.m4 m4/tm_gmtoff.m4 m4/trunc.m4 diff --git a/m4/gnulib-tool.m4 b/m4/gnulib-tool.m4 index a588e1519..fede1fc3b 100644 --- a/m4/gnulib-tool.m4 +++ b/m4/gnulib-tool.m4 @@ -1,5 +1,5 @@ # gnulib-tool.m4 serial 2 -dnl Copyright (C) 2004-2005, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2004-2005, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/hostent.m4 b/m4/hostent.m4 index dd8fc0709..6706d1f5c 100644 --- a/m4/hostent.m4 +++ b/m4/hostent.m4 @@ -1,5 +1,5 @@ # hostent.m4 serial 2 -dnl Copyright (C) 2008, 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008, 2010-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/iconv.m4 b/m4/iconv.m4 index 4b29c5f2c..4e3736315 100644 --- a/m4/iconv.m4 +++ b/m4/iconv.m4 @@ -1,4 +1,4 @@ -# iconv.m4 serial 18 (gettext-0.18.2) +# iconv.m4 serial 19 (gettext-0.18.2) dnl Copyright (C) 2000-2002, 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -72,27 +72,33 @@ AC_DEFUN([AM_ICONV_LINK], if test $am_cv_lib_iconv = yes; then LIBS="$LIBS $LIBICONV" fi - AC_RUN_IFELSE( - [AC_LANG_SOURCE([[ + am_cv_func_iconv_works=no + for ac_iconv_const in '' 'const'; do + AC_RUN_IFELSE( + [AC_LANG_PROGRAM( + [[ #include #include -int main () -{ - int result = 0; + +#ifndef ICONV_CONST +# define ICONV_CONST $ac_iconv_const +#endif + ]], + [[int result = 0; /* Test against AIX 5.1 bug: Failures are not distinguishable from successful returns. */ { iconv_t cd_utf8_to_88591 = iconv_open ("ISO8859-1", "UTF-8"); if (cd_utf8_to_88591 != (iconv_t)(-1)) { - static const char input[] = "\342\202\254"; /* EURO SIGN */ + static ICONV_CONST char input[] = "\342\202\254"; /* EURO SIGN */ char buf[10]; - const char *inptr = input; + ICONV_CONST char *inptr = input; size_t inbytesleft = strlen (input); char *outptr = buf; size_t outbytesleft = sizeof (buf); size_t res = iconv (cd_utf8_to_88591, - (char **) &inptr, &inbytesleft, + &inptr, &inbytesleft, &outptr, &outbytesleft); if (res == 0) result |= 1; @@ -105,14 +111,14 @@ int main () iconv_t cd_ascii_to_88591 = iconv_open ("ISO8859-1", "646"); if (cd_ascii_to_88591 != (iconv_t)(-1)) { - static const char input[] = "\263"; + static ICONV_CONST char input[] = "\263"; char buf[10]; - const char *inptr = input; + ICONV_CONST char *inptr = input; size_t inbytesleft = strlen (input); char *outptr = buf; size_t outbytesleft = sizeof (buf); size_t res = iconv (cd_ascii_to_88591, - (char **) &inptr, &inbytesleft, + &inptr, &inbytesleft, &outptr, &outbytesleft); if (res == 0) result |= 2; @@ -124,14 +130,14 @@ int main () iconv_t cd_88591_to_utf8 = iconv_open ("UTF-8", "ISO-8859-1"); if (cd_88591_to_utf8 != (iconv_t)(-1)) { - static const char input[] = "\304"; + static ICONV_CONST char input[] = "\304"; static char buf[2] = { (char)0xDE, (char)0xAD }; - const char *inptr = input; + ICONV_CONST char *inptr = input; size_t inbytesleft = 1; char *outptr = buf; size_t outbytesleft = 1; size_t res = iconv (cd_88591_to_utf8, - (char **) &inptr, &inbytesleft, + &inptr, &inbytesleft, &outptr, &outbytesleft); if (res != (size_t)(-1) || outptr - buf > 1 || buf[1] != (char)0xAD) result |= 4; @@ -144,14 +150,14 @@ int main () iconv_t cd_88591_to_utf8 = iconv_open ("utf8", "iso88591"); if (cd_88591_to_utf8 != (iconv_t)(-1)) { - static const char input[] = "\304rger mit b\366sen B\374bchen ohne Augenma\337"; + static ICONV_CONST char input[] = "\304rger mit b\366sen B\374bchen ohne Augenma\337"; char buf[50]; - const char *inptr = input; + ICONV_CONST char *inptr = input; size_t inbytesleft = strlen (input); char *outptr = buf; size_t outbytesleft = sizeof (buf); size_t res = iconv (cd_88591_to_utf8, - (char **) &inptr, &inbytesleft, + &inptr, &inbytesleft, &outptr, &outbytesleft); if ((int)res > 0) result |= 8; @@ -171,17 +177,14 @@ int main () && iconv_open ("utf8", "eucJP") == (iconv_t)(-1)) result |= 16; return result; -}]])], - [am_cv_func_iconv_works=yes], - [am_cv_func_iconv_works=no], - [ -changequote(,)dnl - case "$host_os" in - aix* | hpux*) am_cv_func_iconv_works="guessing no" ;; - *) am_cv_func_iconv_works="guessing yes" ;; - esac -changequote([,])dnl - ]) +]])], + [am_cv_func_iconv_works=yes], , + [case "$host_os" in + aix* | hpux*) am_cv_func_iconv_works="guessing no" ;; + *) am_cv_func_iconv_works="guessing yes" ;; + esac]) + test "$am_cv_func_iconv_works" = no || break + done LIBS="$am_save_LIBS" ]) case "$am_cv_func_iconv_works" in diff --git a/m4/iconv_h.m4 b/m4/iconv_h.m4 index e992fa399..c6878faa0 100644 --- a/m4/iconv_h.m4 +++ b/m4/iconv_h.m4 @@ -1,5 +1,5 @@ # iconv_h.m4 serial 8 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/iconv_open-utf.m4 b/m4/iconv_open-utf.m4 index 31ced265a..bd81e66d8 100644 --- a/m4/iconv_open-utf.m4 +++ b/m4/iconv_open-utf.m4 @@ -1,5 +1,5 @@ # iconv_open-utf.m4 serial 1 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/iconv_open.m4 b/m4/iconv_open.m4 index e0bfd7203..177fccba1 100644 --- a/m4/iconv_open.m4 +++ b/m4/iconv_open.m4 @@ -1,5 +1,5 @@ # iconv_open.m4 serial 14 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/include_next.m4 b/m4/include_next.m4 index 69ad3dbb0..233d254e8 100644 --- a/m4/include_next.m4 +++ b/m4/include_next.m4 @@ -1,5 +1,5 @@ # include_next.m4 serial 23 -dnl Copyright (C) 2006-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/inet_ntop.m4 b/m4/inet_ntop.m4 index 5b27759c5..df2bc746d 100644 --- a/m4/inet_ntop.m4 +++ b/m4/inet_ntop.m4 @@ -1,5 +1,5 @@ # inet_ntop.m4 serial 19 -dnl Copyright (C) 2005-2006, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2005-2006, 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/inet_pton.m4 b/m4/inet_pton.m4 index 136ed24d0..433faee0c 100644 --- a/m4/inet_pton.m4 +++ b/m4/inet_pton.m4 @@ -1,5 +1,5 @@ # inet_pton.m4 serial 17 -dnl Copyright (C) 2006, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/inline.m4 b/m4/inline.m4 index c49957f80..dc7063e7e 100644 --- a/m4/inline.m4 +++ b/m4/inline.m4 @@ -1,5 +1,5 @@ # inline.m4 serial 4 -dnl Copyright (C) 2006, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/intmax_t.m4 b/m4/intmax_t.m4 index af5561e5d..4bd8155c8 100644 --- a/m4/intmax_t.m4 +++ b/m4/intmax_t.m4 @@ -1,5 +1,5 @@ # intmax_t.m4 serial 8 -dnl Copyright (C) 1997-2004, 2006-2007, 2009-2014 Free Software Foundation, +dnl Copyright (C) 1997-2004, 2006-2007, 2009-2015 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/inttypes_h.m4 b/m4/inttypes_h.m4 index 87be9cfb5..d0b5f5d98 100644 --- a/m4/inttypes_h.m4 +++ b/m4/inttypes_h.m4 @@ -1,5 +1,5 @@ # inttypes_h.m4 serial 10 -dnl Copyright (C) 1997-2004, 2006, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 1997-2004, 2006, 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/isfinite.m4 b/m4/isfinite.m4 index 53ad9092a..00d7e8042 100644 --- a/m4/isfinite.m4 +++ b/m4/isfinite.m4 @@ -1,5 +1,5 @@ -# isfinite.m4 serial 13 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +# isfinite.m4 serial 15 +dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -34,13 +34,8 @@ AC_DEFUN([gl_ISFINITE], AC_SUBST([ISFINITE_LIBM]) ]) -dnl Test whether isfinite() on 'long double' recognizes all numbers which are -dnl neither finite nor infinite. This test fails e.g. on i686, x86_64, ia64, -dnl because of -dnl - pseudo-denormals on x86_64, -dnl - pseudo-zeroes, unnormalized numbers, and pseudo-denormals on i686, -dnl - pseudo-NaN, pseudo-Infinity, pseudo-zeroes, unnormalized numbers, and -dnl pseudo-denormals on ia64. +dnl Test whether isfinite() on 'long double' recognizes all canonical values +dnl which are neither finite nor infinite. AC_DEFUN([gl_ISFINITEL_WORKS], [ AC_REQUIRE([AC_PROG_CC]) @@ -94,7 +89,7 @@ int main () # ifdef WORDS_BIGENDIAN # define LDBL80_WORDS(exponent,manthi,mantlo) \ { ((unsigned int) (exponent) << 16) | ((unsigned int) (manthi) >> 16), \ - ((unsigned int) (manthi) << 16) | (unsigned int) (mantlo) >> 16), \ + ((unsigned int) (manthi) << 16) | ((unsigned int) (mantlo) >> 16), \ (unsigned int) (mantlo) << 16 \ } # else @@ -114,52 +109,41 @@ int main () if (isfinite (x.value)) result |= 2; } - /* The isfinite macro should recognize Pseudo-NaNs, Pseudo-Infinities, - Pseudo-Zeroes, Unnormalized Numbers, and Pseudo-Denormals, as defined in - Intel IA-64 Architecture Software Developer's Manual, Volume 1: - Application Architecture. - Table 5-2 "Floating-Point Register Encodings" - Figure 5-6 "Memory to Floating-Point Register Data Translation" - */ + /* isfinite should return something even for noncanonical values. */ { /* Pseudo-NaN. */ static memory_long_double x = { LDBL80_WORDS (0xFFFF, 0x40000001, 0x00000000) }; - if (isfinite (x.value)) + if (isfinite (x.value) && !isfinite (x.value)) result |= 4; } { /* Pseudo-Infinity. */ static memory_long_double x = { LDBL80_WORDS (0xFFFF, 0x00000000, 0x00000000) }; - if (isfinite (x.value)) + if (isfinite (x.value) && !isfinite (x.value)) result |= 8; } { /* Pseudo-Zero. */ static memory_long_double x = { LDBL80_WORDS (0x4004, 0x00000000, 0x00000000) }; - if (isfinite (x.value)) + if (isfinite (x.value) && !isfinite (x.value)) result |= 16; } { /* Unnormalized number. */ static memory_long_double x = { LDBL80_WORDS (0x4000, 0x63333333, 0x00000000) }; - if (isfinite (x.value)) + if (isfinite (x.value) && !isfinite (x.value)) result |= 32; } { /* Pseudo-Denormal. */ static memory_long_double x = { LDBL80_WORDS (0x0000, 0x83333333, 0x00000000) }; - if (isfinite (x.value)) + if (isfinite (x.value) && !isfinite (x.value)) result |= 64; } #endif return result; }]])], [gl_cv_func_isfinitel_works=yes], [gl_cv_func_isfinitel_works=no], - [case "$host_cpu" in - # Guess no on ia64, x86_64, i386. - ia64 | x86_64 | i*86) gl_cv_func_isfinitel_works="guessing no";; - *) gl_cv_func_isfinitel_works="guessing yes";; - esac - ]) + [gl_cv_func_isfinitel_works="guessing yes"]) ]) ]) diff --git a/m4/isinf.m4 b/m4/isinf.m4 index 7174acecd..b0a3da330 100644 --- a/m4/isinf.m4 +++ b/m4/isinf.m4 @@ -1,5 +1,5 @@ -# isinf.m4 serial 9 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +# isinf.m4 serial 11 +dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -37,13 +37,8 @@ AC_DEFUN([gl_ISINF], dnl Test whether isinf() works: dnl 1) Whether it correctly returns false for LDBL_MAX. -dnl 2) Whether on 'long double' recognizes all numbers which are neither -dnl finite nor infinite. This test fails on OpenBSD/x86, but could also -dnl fail e.g. on i686, x86_64, ia64, because of -dnl - pseudo-denormals on x86_64, -dnl - pseudo-zeroes, unnormalized numbers, and pseudo-denormals on i686, -dnl - pseudo-NaN, pseudo-Infinity, pseudo-zeroes, unnormalized numbers, and -dnl pseudo-denormals on ia64. +dnl 2) Whether on 'long double' recognizes all canonical values which are +dnl infinite. AC_DEFUN([gl_ISINFL_WORKS], [ AC_REQUIRE([AC_PROG_CC]) @@ -101,7 +96,7 @@ int main () # ifdef WORDS_BIGENDIAN # define LDBL80_WORDS(exponent,manthi,mantlo) \ { ((unsigned int) (exponent) << 16) | ((unsigned int) (manthi) >> 16), \ - ((unsigned int) (manthi) << 16) | (unsigned int) (mantlo) >> 16), \ + ((unsigned int) (manthi) << 16) | ((unsigned int) (mantlo) >> 16), \ (unsigned int) (mantlo) << 16 \ } # else @@ -121,55 +116,41 @@ int main () if (isinf (x.value)) result |= 2; } - /* The isinf macro should recognize Pseudo-NaNs, Pseudo-Infinities, - Pseudo-Zeroes, Unnormalized Numbers, and Pseudo-Denormals, as defined in - Intel IA-64 Architecture Software Developer's Manual, Volume 1: - Application Architecture. - Table 5-2 "Floating-Point Register Encodings" - Figure 5-6 "Memory to Floating-Point Register Data Translation" - */ + /* isinf should return something even for noncanonical values. */ { /* Pseudo-NaN. */ static memory_long_double x = { LDBL80_WORDS (0xFFFF, 0x40000001, 0x00000000) }; - if (isinf (x.value)) + if (isinf (x.value) && !isinf (x.value)) result |= 4; } { /* Pseudo-Infinity. */ static memory_long_double x = { LDBL80_WORDS (0xFFFF, 0x00000000, 0x00000000) }; - if (isinf (x.value)) + if (isinf (x.value) && !isinf (x.value)) result |= 8; } { /* Pseudo-Zero. */ static memory_long_double x = { LDBL80_WORDS (0x4004, 0x00000000, 0x00000000) }; - if (isinf (x.value)) + if (isinf (x.value) && !isinf (x.value)) result |= 16; } { /* Unnormalized number. */ static memory_long_double x = { LDBL80_WORDS (0x4000, 0x63333333, 0x00000000) }; - if (isinf (x.value)) + if (isinf (x.value) && !isinf (x.value)) result |= 32; } { /* Pseudo-Denormal. */ static memory_long_double x = { LDBL80_WORDS (0x0000, 0x83333333, 0x00000000) }; - if (isinf (x.value)) + if (isinf (x.value) && !isinf (x.value)) result |= 64; } #endif return result; }]])], [gl_cv_func_isinfl_works=yes], [gl_cv_func_isinfl_works=no], - [ - case "$host" in - # Guess no on OpenBSD ia64, x86_64, i386. - ia64-*-openbsd* | x86_64-*-openbsd* | i*86-*-openbsd*) - gl_cv_func_isinfl_works="guessing no";; - *) - gl_cv_func_isinfl_works="guessing yes";; - esac - ]) + [gl_cv_func_isinfl_works="guessing yes"]) ]) ]) diff --git a/m4/isnan.m4 b/m4/isnan.m4 index 579340312..618e56e67 100644 --- a/m4/isnan.m4 +++ b/m4/isnan.m4 @@ -1,5 +1,5 @@ # isnan.m4 serial 5 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/isnand.m4 b/m4/isnand.m4 index 36e4ea307..4d5c615bc 100644 --- a/m4/isnand.m4 +++ b/m4/isnand.m4 @@ -1,5 +1,5 @@ # isnand.m4 serial 11 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/isnanf.m4 b/m4/isnanf.m4 index 1f2717d5e..09c3e5edd 100644 --- a/m4/isnanf.m4 +++ b/m4/isnanf.m4 @@ -1,5 +1,5 @@ # isnanf.m4 serial 14 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/isnanl.m4 b/m4/isnanl.m4 index 98b2b69fc..b86ca9efe 100644 --- a/m4/isnanl.m4 +++ b/m4/isnanl.m4 @@ -1,5 +1,5 @@ -# isnanl.m4 serial 17 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +# isnanl.m4 serial 19 +dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -108,11 +108,8 @@ AC_DEFUN([gl_HAVE_ISNANL_IN_LIBM], ]) ]) -dnl Test whether isnanl() recognizes all numbers which are neither finite nor -dnl infinite. This test fails e.g. on NetBSD/i386 and on glibc/ia64. -dnl Also, the GCC >= 4.0 built-in __builtin_isnanl does not pass the tests -dnl - for pseudo-denormals on i686 and x86_64, -dnl - for pseudo-zeroes, unnormalized numbers, and pseudo-denormals on ia64. +dnl Test whether isnanl() recognizes all canonical numbers which are neither +dnl finite nor infinite. AC_DEFUN([gl_FUNC_ISNANL_WORKS], [ AC_REQUIRE([AC_PROG_CC]) @@ -177,7 +174,7 @@ int main () # ifdef WORDS_BIGENDIAN # define LDBL80_WORDS(exponent,manthi,mantlo) \ { ((unsigned int) (exponent) << 16) | ((unsigned int) (manthi) >> 16), \ - ((unsigned int) (manthi) << 16) | (unsigned int) (mantlo) >> 16), \ + ((unsigned int) (manthi) << 16) | ((unsigned int) (mantlo) >> 16), \ (unsigned int) (mantlo) << 16 \ } # else @@ -197,41 +194,35 @@ int main () if (!isnanl (x.value)) result |= 2; } - /* The isnanl function should recognize Pseudo-NaNs, Pseudo-Infinities, - Pseudo-Zeroes, Unnormalized Numbers, and Pseudo-Denormals, as defined in - Intel IA-64 Architecture Software Developer's Manual, Volume 1: - Application Architecture. - Table 5-2 "Floating-Point Register Encodings" - Figure 5-6 "Memory to Floating-Point Register Data Translation" - */ + /* isnanl should return something even for noncanonical values. */ { /* Pseudo-NaN. */ static memory_long_double x = { LDBL80_WORDS (0xFFFF, 0x40000001, 0x00000000) }; - if (!isnanl (x.value)) + if (isnanl (x.value) && !isnanl (x.value)) result |= 4; } { /* Pseudo-Infinity. */ static memory_long_double x = { LDBL80_WORDS (0xFFFF, 0x00000000, 0x00000000) }; - if (!isnanl (x.value)) + if (isnanl (x.value) && !isnanl (x.value)) result |= 8; } { /* Pseudo-Zero. */ static memory_long_double x = { LDBL80_WORDS (0x4004, 0x00000000, 0x00000000) }; - if (!isnanl (x.value)) + if (isnanl (x.value) && !isnanl (x.value)) result |= 16; } { /* Unnormalized number. */ static memory_long_double x = { LDBL80_WORDS (0x4000, 0x63333333, 0x00000000) }; - if (!isnanl (x.value)) + if (isnanl (x.value) && !isnanl (x.value)) result |= 32; } { /* Pseudo-Denormal. */ static memory_long_double x = { LDBL80_WORDS (0x0000, 0x83333333, 0x00000000) }; - if (!isnanl (x.value)) + if (isnanl (x.value) && !isnanl (x.value)) result |= 64; } #endif @@ -240,16 +231,6 @@ int main () }]])], [gl_cv_func_isnanl_works=yes], [gl_cv_func_isnanl_works=no], - [case "$host_cpu" in - # Guess no on ia64, x86_64, i386. - ia64 | x86_64 | i*86) gl_cv_func_isnanl_works="guessing no";; - *) - case "$host_os" in - netbsd*) gl_cv_func_isnanl_works="guessing no";; - *) gl_cv_func_isnanl_works="guessing yes";; - esac - ;; - esac - ]) + [gl_cv_func_isnanl_works="guessing yes"]) ]) ]) diff --git a/m4/langinfo_h.m4 b/m4/langinfo_h.m4 index e8d78f9d0..c3ecba66a 100644 --- a/m4/langinfo_h.m4 +++ b/m4/langinfo_h.m4 @@ -1,5 +1,5 @@ # langinfo_h.m4 serial 7 -dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/largefile.m4 b/m4/largefile.m4 index a1b564ad9..b7a6c48b6 100644 --- a/m4/largefile.m4 +++ b/m4/largefile.m4 @@ -1,6 +1,6 @@ # Enable large files on systems where this is not the default. -# Copyright 1992-1996, 1998-2014 Free Software Foundation, Inc. +# Copyright 1992-1996, 1998-2015 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/ld-version-script.m4 b/m4/ld-version-script.m4 index f8b4a5c51..211d67b96 100644 --- a/m4/ld-version-script.m4 +++ b/m4/ld-version-script.m4 @@ -1,5 +1,5 @@ -# ld-version-script.m4 serial 3 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +# ld-version-script.m4 serial 4 +dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -18,20 +18,18 @@ dnl From Simon Josefsson AC_DEFUN([gl_LD_VERSION_SCRIPT], [ AC_ARG_ENABLE([ld-version-script], - AS_HELP_STRING([--enable-ld-version-script], - [enable linker version script (default is enabled when possible)]), - [have_ld_version_script=$enableval], []) - if test -z "$have_ld_version_script"; then - AC_MSG_CHECKING([if LD -Wl,--version-script works]) - save_LDFLAGS="$LDFLAGS" - LDFLAGS="$LDFLAGS -Wl,--version-script=conftest.map" - cat > conftest.map < conftest.map <conftest.map + AC_LINK_IFELSE([AC_LANG_PROGRAM([], [])], + [], + [cat > conftest.map <conftest.file - if test "$as_ln_s" = "ln -s" && ln -s conftest.file conftest.sym; then - AC_RUN_IFELSE( - [AC_LANG_PROGRAM( - [AC_INCLUDES_DEFAULT], - [[struct stat sbuf; - /* Linux will dereference the symlink and fail, as required by - POSIX. That is better in the sense that it means we will not - have to compile and use the lstat wrapper. */ - return lstat ("conftest.sym/", &sbuf) == 0; - ]])], - [gl_cv_func_lstat_dereferences_slashed_symlink=yes], - [gl_cv_func_lstat_dereferences_slashed_symlink=no], - [case "$host_os" in - # Guess yes on glibc systems. - *-gnu*) gl_cv_func_lstat_dereferences_slashed_symlink="guessing yes" ;; - # If we don't know, assume the worst. - *) gl_cv_func_lstat_dereferences_slashed_symlink="guessing no" ;; - esac - ]) - else - # If the 'ln -s' command failed, then we probably don't even - # have an lstat function. - gl_cv_func_lstat_dereferences_slashed_symlink="guessing no" - fi + AC_RUN_IFELSE( + [AC_LANG_PROGRAM( + [AC_INCLUDES_DEFAULT], + [[struct stat sbuf; + if (symlink ("conftest.file", "conftest.sym") != 0) + return 1; + /* Linux will dereference the symlink and fail, as required by + POSIX. That is better in the sense that it means we will not + have to compile and use the lstat wrapper. */ + return lstat ("conftest.sym/", &sbuf) == 0; + ]])], + [gl_cv_func_lstat_dereferences_slashed_symlink=yes], + [gl_cv_func_lstat_dereferences_slashed_symlink=no], + [case "$host_os" in + *-gnu*) + # Guess yes on glibc systems. + gl_cv_func_lstat_dereferences_slashed_symlink="guessing yes" ;; + *) + # If we don't know, assume the worst. + gl_cv_func_lstat_dereferences_slashed_symlink="guessing no" ;; + esac + ]) rm -f conftest.sym conftest.file ]) case "$gl_cv_func_lstat_dereferences_slashed_symlink" in diff --git a/m4/malloc.m4 b/m4/malloc.m4 index 322ad6eff..31368ab97 100644 --- a/m4/malloc.m4 +++ b/m4/malloc.m4 @@ -1,5 +1,5 @@ # malloc.m4 serial 14 -dnl Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/malloca.m4 b/m4/malloca.m4 index dcc1a0843..724895174 100644 --- a/m4/malloca.m4 +++ b/m4/malloca.m4 @@ -1,5 +1,5 @@ # malloca.m4 serial 1 -dnl Copyright (C) 2003-2004, 2006-2007, 2009-2014 Free Software Foundation, +dnl Copyright (C) 2003-2004, 2006-2007, 2009-2015 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/math_h.m4 b/m4/math_h.m4 index 9e2adfbac..7d0f58346 100644 --- a/m4/math_h.m4 +++ b/m4/math_h.m4 @@ -1,5 +1,5 @@ # math_h.m4 serial 114 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mathfunc.m4 b/m4/mathfunc.m4 index 6f0e6aacd..743bafbca 100644 --- a/m4/mathfunc.m4 +++ b/m4/mathfunc.m4 @@ -1,5 +1,5 @@ # mathfunc.m4 serial 11 -dnl Copyright (C) 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mbrtowc.m4 b/m4/mbrtowc.m4 index a9d157092..640579e61 100644 --- a/m4/mbrtowc.m4 +++ b/m4/mbrtowc.m4 @@ -1,5 +1,5 @@ -# mbrtowc.m4 serial 25 -dnl Copyright (C) 2001-2002, 2004-2005, 2008-2014 Free Software Foundation, +# mbrtowc.m4 serial 26 -*- coding: utf-8 -*- +dnl Copyright (C) 2001-2002, 2004-2005, 2008-2015 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -39,6 +39,7 @@ AC_DEFUN([gl_FUNC_MBRTOWC], gl_MBRTOWC_NULL_ARG2 gl_MBRTOWC_RETVAL gl_MBRTOWC_NUL_RETVAL + gl_MBRTOWC_EMPTY_INPUT case "$gl_cv_func_mbrtowc_null_arg1" in *yes) ;; *) AC_DEFINE([MBRTOWC_NULL_ARG1_BUG], [1], @@ -67,6 +68,14 @@ AC_DEFUN([gl_FUNC_MBRTOWC], REPLACE_MBRTOWC=1 ;; esac + case "$gl_cv_func_mbrtowc_empty_input" in + *yes) ;; + *) AC_DEFINE([MBRTOWC_EMPTY_INPUT_BUG], [1], + [Define if the mbrtowc function does not return (size_t) -2 + for empty input.]) + REPLACE_MBRTOWC=1 + ;; + esac fi fi ]) @@ -533,6 +542,41 @@ int main () ]) ]) +dnl Test whether mbrtowc returns the correct value on empty input. + +AC_DEFUN([gl_MBRTOWC_EMPTY_INPUT], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CACHE_CHECK([whether mbrtowc works on empty input], + [gl_cv_func_mbrtowc_empty_input], + [ + dnl Initial guess, used when cross-compiling or when no suitable locale + dnl is present. +changequote(,)dnl + case "$host_os" in + # Guess no on AIX and glibc systems. + aix* | *-gnu*) + gl_cv_func_mbrtowc_empty_input="guessing no" ;; + *) gl_cv_func_mbrtowc_empty_input="guessing yes" ;; + esac +changequote([,])dnl + AC_RUN_IFELSE( + [AC_LANG_SOURCE([[ + #include + static wchar_t wc; + static mbstate_t mbs; + int + main (void) + { + return mbrtowc (&wc, "", 0, &mbs) == (size_t) -2; + }]])], + [gl_cv_func_mbrtowc_empty_input=no], + [gl_cv_func_mbrtowc_empty_input=yes], + [:]) + ]) +]) + # Prerequisites of lib/mbrtowc.c. AC_DEFUN([gl_PREREQ_MBRTOWC], [ : diff --git a/m4/mbsinit.m4 b/m4/mbsinit.m4 index e1598a1d7..61c403290 100644 --- a/m4/mbsinit.m4 +++ b/m4/mbsinit.m4 @@ -1,5 +1,5 @@ # mbsinit.m4 serial 8 -dnl Copyright (C) 2008, 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008, 2010-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mbstate_t.m4 b/m4/mbstate_t.m4 index 068155a52..42ad6cd63 100644 --- a/m4/mbstate_t.m4 +++ b/m4/mbstate_t.m4 @@ -1,5 +1,5 @@ # mbstate_t.m4 serial 13 -dnl Copyright (C) 2000-2002, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2000-2002, 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mbtowc.m4 b/m4/mbtowc.m4 index cacfe1610..88cdeeeff 100644 --- a/m4/mbtowc.m4 +++ b/m4/mbtowc.m4 @@ -1,5 +1,5 @@ # mbtowc.m4 serial 2 -dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/memchr.m4 b/m4/memchr.m4 index b9f126cfa..cb958d862 100644 --- a/m4/memchr.m4 +++ b/m4/memchr.m4 @@ -1,5 +1,5 @@ # memchr.m4 serial 12 -dnl Copyright (C) 2002-2004, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2004, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mkdir.m4 b/m4/mkdir.m4 index 51e78c13d..3d9868df1 100644 --- a/m4/mkdir.m4 +++ b/m4/mkdir.m4 @@ -1,6 +1,6 @@ # serial 11 -# Copyright (C) 2001, 2003-2004, 2006, 2008-2014 Free Software Foundation, Inc. +# Copyright (C) 2001, 2003-2004, 2006, 2008-2015 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/mkstemp.m4 b/m4/mkstemp.m4 index 9033a4e60..f5df0d0b0 100644 --- a/m4/mkstemp.m4 +++ b/m4/mkstemp.m4 @@ -1,6 +1,6 @@ #serial 23 -# Copyright (C) 2001, 2003-2007, 2009-2014 Free Software Foundation, Inc. +# Copyright (C) 2001, 2003-2007, 2009-2015 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/mktime.m4 b/m4/mktime.m4 new file mode 100644 index 000000000..3f0e1eee4 --- /dev/null +++ b/m4/mktime.m4 @@ -0,0 +1,253 @@ +# serial 25 +dnl Copyright (C) 2002-2003, 2005-2007, 2009-2015 Free Software Foundation, +dnl Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl From Jim Meyering. + +AC_DEFUN([gl_FUNC_MKTIME], +[ + AC_REQUIRE([gl_HEADER_TIME_H_DEFAULTS]) + + dnl We don't use AC_FUNC_MKTIME any more, because it is no longer maintained + dnl in Autoconf and because it invokes AC_LIBOBJ. + AC_CHECK_HEADERS_ONCE([unistd.h]) + AC_CHECK_DECLS_ONCE([alarm]) + AC_REQUIRE([gl_MULTIARCH]) + if test $APPLE_UNIVERSAL_BUILD = 1; then + # A universal build on Apple Mac OS X platforms. + # The test result would be 'yes' in 32-bit mode and 'no' in 64-bit mode. + # But we need a configuration result that is valid in both modes. + gl_cv_func_working_mktime=no + fi + AC_CACHE_CHECK([for working mktime], [gl_cv_func_working_mktime], + [AC_RUN_IFELSE( + [AC_LANG_SOURCE( +[[/* Test program from Paul Eggert and Tony Leneis. */ +#include +#include +#include + +#ifdef HAVE_UNISTD_H +# include +#endif + +#if HAVE_DECL_ALARM +# include +#endif + +/* Work around redefinition to rpl_putenv by other config tests. */ +#undef putenv + +static time_t time_t_max; +static time_t time_t_min; + +/* Values we'll use to set the TZ environment variable. */ +static char *tz_strings[] = { + (char *) 0, "TZ=GMT0", "TZ=JST-9", + "TZ=EST+3EDT+2,M10.1.0/00:00:00,M2.3.0/00:00:00" +}; +#define N_STRINGS (sizeof (tz_strings) / sizeof (tz_strings[0])) + +/* Return 0 if mktime fails to convert a date in the spring-forward gap. + Based on a problem report from Andreas Jaeger. */ +static int +spring_forward_gap () +{ + /* glibc (up to about 1998-10-07) failed this test. */ + struct tm tm; + + /* Use the portable POSIX.1 specification "TZ=PST8PDT,M4.1.0,M10.5.0" + instead of "TZ=America/Vancouver" in order to detect the bug even + on systems that don't support the Olson extension, or don't have the + full zoneinfo tables installed. */ + putenv ("TZ=PST8PDT,M4.1.0,M10.5.0"); + + tm.tm_year = 98; + tm.tm_mon = 3; + tm.tm_mday = 5; + tm.tm_hour = 2; + tm.tm_min = 0; + tm.tm_sec = 0; + tm.tm_isdst = -1; + return mktime (&tm) != (time_t) -1; +} + +static int +mktime_test1 (time_t now) +{ + struct tm *lt; + return ! (lt = localtime (&now)) || mktime (lt) == now; +} + +static int +mktime_test (time_t now) +{ + return (mktime_test1 (now) + && mktime_test1 ((time_t) (time_t_max - now)) + && mktime_test1 ((time_t) (time_t_min + now))); +} + +static int +irix_6_4_bug () +{ + /* Based on code from Ariel Faigon. */ + struct tm tm; + tm.tm_year = 96; + tm.tm_mon = 3; + tm.tm_mday = 0; + tm.tm_hour = 0; + tm.tm_min = 0; + tm.tm_sec = 0; + tm.tm_isdst = -1; + mktime (&tm); + return tm.tm_mon == 2 && tm.tm_mday == 31; +} + +static int +bigtime_test (int j) +{ + struct tm tm; + time_t now; + tm.tm_year = tm.tm_mon = tm.tm_mday = tm.tm_hour = tm.tm_min = tm.tm_sec = j; + now = mktime (&tm); + if (now != (time_t) -1) + { + struct tm *lt = localtime (&now); + if (! (lt + && lt->tm_year == tm.tm_year + && lt->tm_mon == tm.tm_mon + && lt->tm_mday == tm.tm_mday + && lt->tm_hour == tm.tm_hour + && lt->tm_min == tm.tm_min + && lt->tm_sec == tm.tm_sec + && lt->tm_yday == tm.tm_yday + && lt->tm_wday == tm.tm_wday + && ((lt->tm_isdst < 0 ? -1 : 0 < lt->tm_isdst) + == (tm.tm_isdst < 0 ? -1 : 0 < tm.tm_isdst)))) + return 0; + } + return 1; +} + +static int +year_2050_test () +{ + /* The correct answer for 2050-02-01 00:00:00 in Pacific time, + ignoring leap seconds. */ + unsigned long int answer = 2527315200UL; + + struct tm tm; + time_t t; + tm.tm_year = 2050 - 1900; + tm.tm_mon = 2 - 1; + tm.tm_mday = 1; + tm.tm_hour = tm.tm_min = tm.tm_sec = 0; + tm.tm_isdst = -1; + + /* Use the portable POSIX.1 specification "TZ=PST8PDT,M4.1.0,M10.5.0" + instead of "TZ=America/Vancouver" in order to detect the bug even + on systems that don't support the Olson extension, or don't have the + full zoneinfo tables installed. */ + putenv ("TZ=PST8PDT,M4.1.0,M10.5.0"); + + t = mktime (&tm); + + /* Check that the result is either a failure, or close enough + to the correct answer that we can assume the discrepancy is + due to leap seconds. */ + return (t == (time_t) -1 + || (0 < t && answer - 120 <= t && t <= answer + 120)); +} + +int +main () +{ + int result = 0; + time_t t, delta; + int i, j; + int time_t_signed_magnitude = (time_t) ~ (time_t) 0 < (time_t) -1; + int time_t_signed = ! ((time_t) 0 < (time_t) -1); + +#if HAVE_DECL_ALARM + /* This test makes some buggy mktime implementations loop. + Give up after 60 seconds; a mktime slower than that + isn't worth using anyway. */ + signal (SIGALRM, SIG_DFL); + alarm (60); +#endif + + time_t_max = (! time_t_signed + ? (time_t) -1 + : ((((time_t) 1 << (sizeof (time_t) * CHAR_BIT - 2)) - 1) + * 2 + 1)); + time_t_min = (! time_t_signed + ? (time_t) 0 + : time_t_signed_magnitude + ? ~ (time_t) 0 + : ~ time_t_max); + + delta = time_t_max / 997; /* a suitable prime number */ + for (i = 0; i < N_STRINGS; i++) + { + if (tz_strings[i]) + putenv (tz_strings[i]); + + for (t = 0; t <= time_t_max - delta && (result & 1) == 0; t += delta) + if (! mktime_test (t)) + result |= 1; + if ((result & 2) == 0 + && ! (mktime_test ((time_t) 1) + && mktime_test ((time_t) (60 * 60)) + && mktime_test ((time_t) (60 * 60 * 24)))) + result |= 2; + + for (j = 1; (result & 4) == 0; j <<= 1) + { + if (! bigtime_test (j)) + result |= 4; + if (INT_MAX / 2 < j) + break; + } + if ((result & 8) == 0 && ! bigtime_test (INT_MAX)) + result |= 8; + } + if (! irix_6_4_bug ()) + result |= 16; + if (! spring_forward_gap ()) + result |= 32; + if (! year_2050_test ()) + result |= 64; + return result; +}]])], + [gl_cv_func_working_mktime=yes], + [gl_cv_func_working_mktime=no], + [gl_cv_func_working_mktime=no]) + ]) + + if test $gl_cv_func_working_mktime = no; then + REPLACE_MKTIME=1 + else + REPLACE_MKTIME=0 + fi +]) + +AC_DEFUN([gl_FUNC_MKTIME_INTERNAL], [ + AC_REQUIRE([gl_FUNC_MKTIME]) + if test $REPLACE_MKTIME = 0; then + dnl BeOS has __mktime_internal in libc, but other platforms don't. + AC_CHECK_FUNC([__mktime_internal], + [AC_DEFINE([mktime_internal], [__mktime_internal], + [Define to the real name of the mktime_internal function.]) + ], + [dnl mktime works but it doesn't export __mktime_internal, + dnl so we need to substitute our own mktime implementation. + REPLACE_MKTIME=1 + ]) + fi +]) + +# Prerequisites of lib/mktime.c. +AC_DEFUN([gl_PREREQ_MKTIME], [:]) diff --git a/m4/mmap-anon.m4 b/m4/mmap-anon.m4 index 94ae2e2f2..92a88d05f 100644 --- a/m4/mmap-anon.m4 +++ b/m4/mmap-anon.m4 @@ -1,5 +1,5 @@ # mmap-anon.m4 serial 10 -dnl Copyright (C) 2005, 2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2005, 2007, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mode_t.m4 b/m4/mode_t.m4 index db6e192be..01badba7a 100644 --- a/m4/mode_t.m4 +++ b/m4/mode_t.m4 @@ -1,5 +1,5 @@ # mode_t.m4 serial 2 -dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/msvc-inval.m4 b/m4/msvc-inval.m4 index 7f26087e7..9446fa585 100644 --- a/m4/msvc-inval.m4 +++ b/m4/msvc-inval.m4 @@ -1,5 +1,5 @@ # msvc-inval.m4 serial 1 -dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/msvc-nothrow.m4 b/m4/msvc-nothrow.m4 index 9e32c171e..5d72a042d 100644 --- a/m4/msvc-nothrow.m4 +++ b/m4/msvc-nothrow.m4 @@ -1,5 +1,5 @@ # msvc-nothrow.m4 serial 1 -dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/multiarch.m4 b/m4/multiarch.m4 index 2cb956dee..fc575c1d4 100644 --- a/m4/multiarch.m4 +++ b/m4/multiarch.m4 @@ -1,5 +1,5 @@ # multiarch.m4 serial 7 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/netdb_h.m4 b/m4/netdb_h.m4 index cd7d48291..fce208014 100644 --- a/m4/netdb_h.m4 +++ b/m4/netdb_h.m4 @@ -1,5 +1,5 @@ # netdb_h.m4 serial 11 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/netinet_in_h.m4 b/m4/netinet_in_h.m4 index 1d447d6f1..42ac00844 100644 --- a/m4/netinet_in_h.m4 +++ b/m4/netinet_in_h.m4 @@ -1,5 +1,5 @@ # netinet_in_h.m4 serial 5 -dnl Copyright (C) 2006-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/nl_langinfo.m4 b/m4/nl_langinfo.m4 index 6976e7767..c8bf20fb3 100644 --- a/m4/nl_langinfo.m4 +++ b/m4/nl_langinfo.m4 @@ -1,5 +1,5 @@ # nl_langinfo.m4 serial 5 -dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/nocrash.m4 b/m4/nocrash.m4 index 5a5d77d63..56283180f 100644 --- a/m4/nocrash.m4 +++ b/m4/nocrash.m4 @@ -1,5 +1,5 @@ # nocrash.m4 serial 4 -dnl Copyright (C) 2005, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2005, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/nproc.m4 b/m4/nproc.m4 index 937c4a920..988404b1c 100644 --- a/m4/nproc.m4 +++ b/m4/nproc.m4 @@ -1,5 +1,5 @@ # nproc.m4 serial 4 -dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/off_t.m4 b/m4/off_t.m4 index f5885b34b..0eb14678b 100644 --- a/m4/off_t.m4 +++ b/m4/off_t.m4 @@ -1,5 +1,5 @@ # off_t.m4 serial 1 -dnl Copyright (C) 2012-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2012-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/open.m4 b/m4/open.m4 index 68f116f0a..2accbaa92 100644 --- a/m4/open.m4 +++ b/m4/open.m4 @@ -1,5 +1,5 @@ # open.m4 serial 14 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/pathmax.m4 b/m4/pathmax.m4 index 114f91f04..0e3db7a23 100644 --- a/m4/pathmax.m4 +++ b/m4/pathmax.m4 @@ -1,5 +1,5 @@ # pathmax.m4 serial 10 -dnl Copyright (C) 2002-2003, 2005-2006, 2009-2014 Free Software Foundation, +dnl Copyright (C) 2002-2003, 2005-2006, 2009-2015 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/pipe.m4 b/m4/pipe.m4 index d3532d5dd..730c53439 100644 --- a/m4/pipe.m4 +++ b/m4/pipe.m4 @@ -1,5 +1,5 @@ # pipe.m4 serial 2 -dnl Copyright (C) 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/pipe2.m4 b/m4/pipe2.m4 index 1cff1fef0..0b64651a5 100644 --- a/m4/pipe2.m4 +++ b/m4/pipe2.m4 @@ -1,5 +1,5 @@ # pipe2.m4 serial 2 -dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/poll.m4 b/m4/poll.m4 index f523b1873..403d7d1fc 100644 --- a/m4/poll.m4 +++ b/m4/poll.m4 @@ -1,5 +1,5 @@ # poll.m4 serial 17 -dnl Copyright (c) 2003, 2005-2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (c) 2003, 2005-2007, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/poll_h.m4 b/m4/poll_h.m4 index fcfe7fa4d..662b60344 100644 --- a/m4/poll_h.m4 +++ b/m4/poll_h.m4 @@ -1,5 +1,5 @@ # poll_h.m4 serial 2 -dnl Copyright (C) 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/printf.m4 b/m4/printf.m4 index 9346ab041..d06746aae 100644 --- a/m4/printf.m4 +++ b/m4/printf.m4 @@ -1,5 +1,5 @@ -# printf.m4 serial 50 -dnl Copyright (C) 2003, 2007-2014 Free Software Foundation, Inc. +# printf.m4 serial 52 +dnl Copyright (C) 2003, 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -61,7 +61,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_printf_sizes_c99="guessing yes";; # Guess yes on FreeBSD >= 5. - freebsd[1-4]*) gl_cv_func_printf_sizes_c99="guessing no";; + freebsd[1-4].*) gl_cv_func_printf_sizes_c99="guessing no";; freebsd* | kfreebsd*) gl_cv_func_printf_sizes_c99="guessing yes";; # Guess yes on Mac OS X >= 10.3. darwin[1-6].*) gl_cv_func_printf_sizes_c99="guessing no";; @@ -220,7 +220,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_printf_infinite="guessing yes";; # Guess yes on FreeBSD >= 6. - freebsd[1-5]*) gl_cv_func_printf_infinite="guessing no";; + freebsd[1-5].*) gl_cv_func_printf_infinite="guessing no";; freebsd* | kfreebsd*) gl_cv_func_printf_infinite="guessing yes";; # Guess yes on Mac OS X >= 10.3. darwin[1-6].*) gl_cv_func_printf_infinite="guessing no";; @@ -328,7 +328,7 @@ int main () # ifdef WORDS_BIGENDIAN # define LDBL80_WORDS(exponent,manthi,mantlo) \ { ((unsigned int) (exponent) << 16) | ((unsigned int) (manthi) >> 16), \ - ((unsigned int) (manthi) << 16) | (unsigned int) (mantlo) >> 16), \ + ((unsigned int) (manthi) << 16) | ((unsigned int) (mantlo) >> 16), \ (unsigned int) (mantlo) << 16 \ } # else @@ -365,66 +365,51 @@ int main () { /* Pseudo-NaN. */ static union { unsigned int word[4]; long double value; } x = { LDBL80_WORDS (0xFFFF, 0x40000001, 0x00000000) }; - if (sprintf (buf, "%Lf", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Lf", x.value) <= 0) result |= 4; - if (sprintf (buf, "%Le", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Le", x.value) <= 0) result |= 4; - if (sprintf (buf, "%Lg", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Lg", x.value) <= 0) result |= 4; } { /* Pseudo-Infinity. */ static union { unsigned int word[4]; long double value; } x = { LDBL80_WORDS (0xFFFF, 0x00000000, 0x00000000) }; - if (sprintf (buf, "%Lf", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Lf", x.value) <= 0) result |= 8; - if (sprintf (buf, "%Le", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Le", x.value) <= 0) result |= 8; - if (sprintf (buf, "%Lg", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Lg", x.value) <= 0) result |= 8; } { /* Pseudo-Zero. */ static union { unsigned int word[4]; long double value; } x = { LDBL80_WORDS (0x4004, 0x00000000, 0x00000000) }; - if (sprintf (buf, "%Lf", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Lf", x.value) <= 0) result |= 16; - if (sprintf (buf, "%Le", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Le", x.value) <= 0) result |= 16; - if (sprintf (buf, "%Lg", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Lg", x.value) <= 0) result |= 16; } { /* Unnormalized number. */ static union { unsigned int word[4]; long double value; } x = { LDBL80_WORDS (0x4000, 0x63333333, 0x00000000) }; - if (sprintf (buf, "%Lf", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Lf", x.value) <= 0) result |= 32; - if (sprintf (buf, "%Le", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Le", x.value) <= 0) result |= 32; - if (sprintf (buf, "%Lg", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Lg", x.value) <= 0) result |= 32; } { /* Pseudo-Denormal. */ static union { unsigned int word[4]; long double value; } x = { LDBL80_WORDS (0x0000, 0x83333333, 0x00000000) }; - if (sprintf (buf, "%Lf", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Lf", x.value) <= 0) result |= 64; - if (sprintf (buf, "%Le", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Le", x.value) <= 0) result |= 64; - if (sprintf (buf, "%Lg", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Lg", x.value) <= 0) result |= 64; } #endif @@ -442,7 +427,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_printf_infinite_long_double="guessing yes";; # Guess yes on FreeBSD >= 6. - freebsd[1-5]*) gl_cv_func_printf_infinite_long_double="guessing no";; + freebsd[1-5].*) gl_cv_func_printf_infinite_long_double="guessing no";; freebsd* | kfreebsd*) gl_cv_func_printf_infinite_long_double="guessing yes";; # Guess yes on HP-UX >= 11. hpux[7-9]* | hpux10*) gl_cv_func_printf_infinite_long_double="guessing no";; @@ -588,7 +573,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_printf_directive_f="guessing yes";; # Guess yes on FreeBSD >= 6. - freebsd[1-5]*) gl_cv_func_printf_directive_f="guessing no";; + freebsd[1-5].*) gl_cv_func_printf_directive_f="guessing no";; freebsd* | kfreebsd*) gl_cv_func_printf_directive_f="guessing yes";; # Guess yes on Mac OS X >= 10.3. darwin[1-6].*) gl_cv_func_printf_directive_f="guessing no";; @@ -1136,7 +1121,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_snprintf_truncation_c99="guessing yes";; # Guess yes on FreeBSD >= 5. - freebsd[1-4]*) gl_cv_func_snprintf_truncation_c99="guessing no";; + freebsd[1-4].*) gl_cv_func_snprintf_truncation_c99="guessing no";; freebsd* | kfreebsd*) gl_cv_func_snprintf_truncation_c99="guessing yes";; # Guess yes on Mac OS X >= 10.3. darwin[1-6].*) gl_cv_func_snprintf_truncation_c99="guessing no";; @@ -1235,7 +1220,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_snprintf_retval_c99="guessing yes";; # Guess yes on FreeBSD >= 5. - freebsd[1-4]*) gl_cv_func_snprintf_retval_c99="guessing no";; + freebsd[1-4].*) gl_cv_func_snprintf_retval_c99="guessing no";; freebsd* | kfreebsd*) gl_cv_func_snprintf_retval_c99="guessing yes";; # Guess yes on Mac OS X >= 10.3. darwin[1-6].*) gl_cv_func_snprintf_retval_c99="guessing no";; @@ -1316,7 +1301,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_snprintf_directive_n="guessing yes";; # Guess yes on FreeBSD >= 5. - freebsd[1-4]*) gl_cv_func_snprintf_directive_n="guessing no";; + freebsd[1-4].*) gl_cv_func_snprintf_directive_n="guessing no";; freebsd* | kfreebsd*) gl_cv_func_snprintf_directive_n="guessing yes";; # Guess yes on Mac OS X >= 10.3. darwin[1-6].*) gl_cv_func_snprintf_directive_n="guessing no";; @@ -1458,7 +1443,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_vsnprintf_zerosize_c99="guessing yes";; # Guess yes on FreeBSD >= 5. - freebsd[1-4]*) gl_cv_func_vsnprintf_zerosize_c99="guessing no";; + freebsd[1-4].*) gl_cv_func_vsnprintf_zerosize_c99="guessing no";; freebsd* | kfreebsd*) gl_cv_func_vsnprintf_zerosize_c99="guessing yes";; # Guess yes on Mac OS X >= 10.3. darwin[1-6].*) gl_cv_func_vsnprintf_zerosize_c99="guessing no";; diff --git a/m4/putenv.m4 b/m4/putenv.m4 index d79321be9..73a5f4691 100644 --- a/m4/putenv.m4 +++ b/m4/putenv.m4 @@ -1,5 +1,5 @@ # putenv.m4 serial 20 -dnl Copyright (C) 2002-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/raise.m4 b/m4/raise.m4 index 8656578ef..ed6aae036 100644 --- a/m4/raise.m4 +++ b/m4/raise.m4 @@ -1,5 +1,5 @@ # raise.m4 serial 3 -dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/read.m4 b/m4/read.m4 index 176b0b04d..9fdd7df13 100644 --- a/m4/read.m4 +++ b/m4/read.m4 @@ -1,5 +1,5 @@ # read.m4 serial 4 -dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/readlink.m4 b/m4/readlink.m4 index f9ce868c2..88c9bfef7 100644 --- a/m4/readlink.m4 +++ b/m4/readlink.m4 @@ -1,5 +1,5 @@ # readlink.m4 serial 12 -dnl Copyright (C) 2003, 2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2007, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/regex.m4 b/m4/regex.m4 index 08bd46a96..0fa7455df 100644 --- a/m4/regex.m4 +++ b/m4/regex.m4 @@ -1,6 +1,6 @@ # serial 65 -# Copyright (C) 1996-2001, 2003-2014 Free Software Foundation, Inc. +# Copyright (C) 1996-2001, 2003-2015 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, diff --git a/m4/rename.m4 b/m4/rename.m4 index ea5779491..b5e433457 100644 --- a/m4/rename.m4 +++ b/m4/rename.m4 @@ -1,6 +1,6 @@ # serial 26 -# Copyright (C) 2001, 2003, 2005-2006, 2009-2014 Free Software Foundation, Inc. +# Copyright (C) 2001, 2003, 2005-2006, 2009-2015 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/rmdir.m4 b/m4/rmdir.m4 index db6a9399c..09ed159e0 100644 --- a/m4/rmdir.m4 +++ b/m4/rmdir.m4 @@ -1,5 +1,5 @@ # rmdir.m4 serial 13 -dnl Copyright (C) 2002, 2005, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002, 2005, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/round.m4 b/m4/round.m4 index 13049b7cf..7fa1eb3fc 100644 --- a/m4/round.m4 +++ b/m4/round.m4 @@ -1,5 +1,5 @@ # round.m4 serial 16 -dnl Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/safe-read.m4 b/m4/safe-read.m4 index f0c42e08f..697a07cf8 100644 --- a/m4/safe-read.m4 +++ b/m4/safe-read.m4 @@ -1,5 +1,5 @@ # safe-read.m4 serial 6 -dnl Copyright (C) 2002-2003, 2005-2006, 2009-2014 Free Software Foundation, +dnl Copyright (C) 2002-2003, 2005-2006, 2009-2015 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/safe-write.m4 b/m4/safe-write.m4 index 66648bbb5..1cef87c5a 100644 --- a/m4/safe-write.m4 +++ b/m4/safe-write.m4 @@ -1,5 +1,5 @@ # safe-write.m4 serial 4 -dnl Copyright (C) 2002, 2005-2006, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002, 2005-2006, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/secure_getenv.m4 b/m4/secure_getenv.m4 index 149888df4..6afe89fda 100644 --- a/m4/secure_getenv.m4 +++ b/m4/secure_getenv.m4 @@ -1,5 +1,5 @@ # Look up an environment variable more securely. -dnl Copyright 2013-2014 Free Software Foundation, Inc. +dnl Copyright 2013-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/select.m4 b/m4/select.m4 index 1d2fcb373..2a2ee6f90 100644 --- a/m4/select.m4 +++ b/m4/select.m4 @@ -1,5 +1,5 @@ # select.m4 serial 7 -dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/servent.m4 b/m4/servent.m4 index 4dc7a9f70..e871d45ce 100644 --- a/m4/servent.m4 +++ b/m4/servent.m4 @@ -1,5 +1,5 @@ # servent.m4 serial 2 -dnl Copyright (C) 2008, 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008, 2010-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/setenv.m4 b/m4/setenv.m4 index 0f46a7bec..3aa38d895 100644 --- a/m4/setenv.m4 +++ b/m4/setenv.m4 @@ -1,5 +1,5 @@ # setenv.m4 serial 26 -dnl Copyright (C) 2001-2004, 2006-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2004, 2006-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/signal_h.m4 b/m4/signal_h.m4 index c8f664fbf..f737c36ba 100644 --- a/m4/signal_h.m4 +++ b/m4/signal_h.m4 @@ -1,5 +1,5 @@ # signal_h.m4 serial 18 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/signbit.m4 b/m4/signbit.m4 index 9ed48c780..21b9bf5e5 100644 --- a/m4/signbit.m4 +++ b/m4/signbit.m4 @@ -1,5 +1,5 @@ # signbit.m4 serial 13 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/size_max.m4 b/m4/size_max.m4 index 7e192d5e9..186e3fdda 100644 --- a/m4/size_max.m4 +++ b/m4/size_max.m4 @@ -1,5 +1,5 @@ # size_max.m4 serial 10 -dnl Copyright (C) 2003, 2005-2006, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2005-2006, 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/snprintf.m4 b/m4/snprintf.m4 index 888db35c0..8ae70050c 100644 --- a/m4/snprintf.m4 +++ b/m4/snprintf.m4 @@ -1,5 +1,5 @@ # snprintf.m4 serial 6 -dnl Copyright (C) 2002-2004, 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2004, 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/socketlib.m4 b/m4/socketlib.m4 index 041498baf..934173955 100644 --- a/m4/socketlib.m4 +++ b/m4/socketlib.m4 @@ -1,5 +1,5 @@ # socketlib.m4 serial 1 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sockets.m4 b/m4/sockets.m4 index da6ff7427..e75ac02b2 100644 --- a/m4/sockets.m4 +++ b/m4/sockets.m4 @@ -1,5 +1,5 @@ # sockets.m4 serial 7 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/socklen.m4 b/m4/socklen.m4 index 4c07f864c..bcabed3ef 100644 --- a/m4/socklen.m4 +++ b/m4/socklen.m4 @@ -1,5 +1,5 @@ # socklen.m4 serial 10 -dnl Copyright (C) 2005-2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2005-2007, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sockpfaf.m4 b/m4/sockpfaf.m4 index 31d436f0e..50eb7619d 100644 --- a/m4/sockpfaf.m4 +++ b/m4/sockpfaf.m4 @@ -1,5 +1,5 @@ # sockpfaf.m4 serial 8 -dnl Copyright (C) 2004, 2006, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2004, 2006, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/ssize_t.m4 b/m4/ssize_t.m4 index fbe1d0687..25bd45143 100644 --- a/m4/ssize_t.m4 +++ b/m4/ssize_t.m4 @@ -1,5 +1,5 @@ # ssize_t.m4 serial 5 (gettext-0.18.2) -dnl Copyright (C) 2001-2003, 2006, 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2003, 2006, 2010-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/stat-time.m4 b/m4/stat-time.m4 index ea5c4fc59..9c8ceec18 100644 --- a/m4/stat-time.m4 +++ b/m4/stat-time.m4 @@ -1,6 +1,6 @@ # Checks for stat-related time functions. -# Copyright (C) 1998-1999, 2001, 2003, 2005-2007, 2009-2014 Free Software +# Copyright (C) 1998-1999, 2001, 2003, 2005-2007, 2009-2015 Free Software # Foundation, Inc. # This file is free software; the Free Software Foundation diff --git a/m4/stat.m4 b/m4/stat.m4 index 1ae327b36..d1b376896 100644 --- a/m4/stat.m4 +++ b/m4/stat.m4 @@ -1,6 +1,6 @@ # serial 11 -# Copyright (C) 2009-2014 Free Software Foundation, Inc. +# Copyright (C) 2009-2015 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, diff --git a/m4/stdalign.m4 b/m4/stdalign.m4 index 9efafe5c5..033b0d39e 100644 --- a/m4/stdalign.m4 +++ b/m4/stdalign.m4 @@ -1,6 +1,6 @@ # Check for stdalign.h that conforms to C11. -dnl Copyright 2011-2014 Free Software Foundation, Inc. +dnl Copyright 2011-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -32,8 +32,12 @@ AC_DEFUN([gl_STDALIGN_H], /* Test _Alignas only on platforms where gnulib can help. */ #if \ ((defined __cplusplus && 201103 <= __cplusplus) \ - || __GNUC__ || __IBMC__ || __IBMCPP__ || __ICC \ - || 0x5110 <= __SUNPRO_C || 1300 <= _MSC_VER) + || (defined __APPLE__ && defined __MACH__ \ + ? 4 < __GNUC__ + (1 <= __GNUC_MINOR__) \ + : __GNUC__) \ + || __HP_cc || __HP_aCC || __IBMC__ || __IBMCPP__ \ + || __ICC || 0x5110 <= __SUNPRO_C \ + || 1300 <= _MSC_VER) struct alignas_test { char c; char alignas (8) alignas_8; }; char test_alignas[offsetof (struct alignas_test, alignas_8) == 8 ? 1 : -1]; diff --git a/m4/stdbool.m4 b/m4/stdbool.m4 index 006ed52de..7273b8224 100644 --- a/m4/stdbool.m4 +++ b/m4/stdbool.m4 @@ -1,6 +1,6 @@ # Check for stdbool.h that conforms to C99. -dnl Copyright (C) 2002-2006, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2006, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/stddef_h.m4 b/m4/stddef_h.m4 index c555e2952..231050274 100644 --- a/m4/stddef_h.m4 +++ b/m4/stddef_h.m4 @@ -1,6 +1,6 @@ -dnl A placeholder for POSIX 2008 , for platforms that have issues. -# stddef_h.m4 serial 4 -dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. +dnl A placeholder for , for platforms that have issues. +# stddef_h.m4 serial 5 +dnl Copyright (C) 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -10,6 +10,9 @@ AC_DEFUN([gl_STDDEF_H], AC_REQUIRE([gl_STDDEF_H_DEFAULTS]) AC_REQUIRE([gt_TYPE_WCHAR_T]) STDDEF_H= + AC_CHECK_TYPE([max_align_t], [], [HAVE_MAX_ALIGN_T=0; STDDEF_H=stddef.h], + [[#include + ]]) if test $gt_cv_c_wchar_t = no; then HAVE_WCHAR_T=0 STDDEF_H=stddef.h @@ -43,5 +46,6 @@ AC_DEFUN([gl_STDDEF_H_DEFAULTS], [ dnl Assume proper GNU behavior unless another module says otherwise. REPLACE_NULL=0; AC_SUBST([REPLACE_NULL]) + HAVE_MAX_ALIGN_T=1; AC_SUBST([HAVE_MAX_ALIGN_T]) HAVE_WCHAR_T=1; AC_SUBST([HAVE_WCHAR_T]) ]) diff --git a/m4/stdint.m4 b/m4/stdint.m4 index 1981d9dbc..4011a4942 100644 --- a/m4/stdint.m4 +++ b/m4/stdint.m4 @@ -1,5 +1,5 @@ # stdint.m4 serial 43 -dnl Copyright (C) 2001-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/stdint_h.m4 b/m4/stdint_h.m4 index 7fc2ce9a8..5097c0b0d 100644 --- a/m4/stdint_h.m4 +++ b/m4/stdint_h.m4 @@ -1,5 +1,5 @@ # stdint_h.m4 serial 9 -dnl Copyright (C) 1997-2004, 2006, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 1997-2004, 2006, 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/stdio_h.m4 b/m4/stdio_h.m4 index d15913a3c..f60cc2156 100644 --- a/m4/stdio_h.m4 +++ b/m4/stdio_h.m4 @@ -1,14 +1,41 @@ -# stdio_h.m4 serial 43 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +# stdio_h.m4 serial 46 +dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. AC_DEFUN([gl_STDIO_H], [ + dnl For __USE_MINGW_ANSI_STDIO + AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) + AC_REQUIRE([gl_STDIO_H_DEFAULTS]) gl_NEXT_HEADERS([stdio.h]) + dnl Determine whether __USE_MINGW_ANSI_STDIO makes printf and + dnl inttypes.h behave like gnu instead of system; we must give our + dnl printf wrapper the right attribute to match. + AC_CACHE_CHECK([which flavor of printf attribute matches inttypes macros], + [gl_cv_func_printf_attribute_flavor], + [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[ + #define __STDC_FORMAT_MACROS 1 + #include + #include + /* For non-mingw systems, compilation will trivially succeed. + For mingw, compilation will succeed for older mingw (system + printf, "I64d") and fail for newer mingw (gnu printf, "lld"). */ + #if ((defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__) && \ + (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4)) + extern char PRIdMAX_probe[sizeof PRIdMAX == sizeof "I64d" ? 1 : -1]; + #endif + ]])], [gl_cv_func_printf_attribute_flavor=system], + [gl_cv_func_printf_attribute_flavor=gnu])]) + if test "$gl_cv_func_printf_attribute_flavor" = gnu; then + AC_DEFINE([GNULIB_PRINTF_ATTRIBUTE_FLAVOR_GNU], [1], + [Define to 1 if printf and friends should be labeled with + attribute "__gnu_printf__" instead of "__printf__"]) + fi + dnl No need to create extra modules for these functions. Everyone who uses dnl likely needs them. GNULIB_FSCANF=1 diff --git a/m4/stdlib_h.m4 b/m4/stdlib_h.m4 index 03b448b94..0b4c623ec 100644 --- a/m4/stdlib_h.m4 +++ b/m4/stdlib_h.m4 @@ -1,5 +1,5 @@ # stdlib_h.m4 serial 42 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -55,6 +55,7 @@ AC_DEFUN([gl_STDLIB_H_DEFAULTS], GNULIB_PTSNAME=0; AC_SUBST([GNULIB_PTSNAME]) GNULIB_PTSNAME_R=0; AC_SUBST([GNULIB_PTSNAME_R]) GNULIB_PUTENV=0; AC_SUBST([GNULIB_PUTENV]) + GNULIB_QSORT_R=0; AC_SUBST([GNULIB_QSORT_R]) GNULIB_RANDOM=0; AC_SUBST([GNULIB_RANDOM]) GNULIB_RANDOM_R=0; AC_SUBST([GNULIB_RANDOM_R]) GNULIB_REALLOC_POSIX=0; AC_SUBST([GNULIB_REALLOC_POSIX]) @@ -107,6 +108,7 @@ AC_DEFUN([gl_STDLIB_H_DEFAULTS], REPLACE_PTSNAME=0; AC_SUBST([REPLACE_PTSNAME]) REPLACE_PTSNAME_R=0; AC_SUBST([REPLACE_PTSNAME_R]) REPLACE_PUTENV=0; AC_SUBST([REPLACE_PUTENV]) + REPLACE_QSORT_R=0; AC_SUBST([REPLACE_QSORT_R]) REPLACE_RANDOM_R=0; AC_SUBST([REPLACE_RANDOM_R]) REPLACE_REALLOC=0; AC_SUBST([REPLACE_REALLOC]) REPLACE_REALPATH=0; AC_SUBST([REPLACE_REALPATH]) diff --git a/m4/strdup.m4 b/m4/strdup.m4 index 1681a30eb..90ea29d22 100644 --- a/m4/strdup.m4 +++ b/m4/strdup.m4 @@ -1,6 +1,6 @@ # strdup.m4 serial 13 -dnl Copyright (C) 2002-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/strftime.m4 b/m4/strftime.m4 index 0ba3dd074..4557626ae 100644 --- a/m4/strftime.m4 +++ b/m4/strftime.m4 @@ -1,6 +1,6 @@ # serial 33 -# Copyright (C) 1996-1997, 1999-2007, 2009-2014 Free Software Foundation, Inc. +# Copyright (C) 1996-1997, 1999-2007, 2009-2015 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, diff --git a/m4/string_h.m4 b/m4/string_h.m4 index 64e683f9d..55d09ef40 100644 --- a/m4/string_h.m4 +++ b/m4/string_h.m4 @@ -1,6 +1,6 @@ # Configure a GNU-like replacement for . -# Copyright (C) 2007-2014 Free Software Foundation, Inc. +# Copyright (C) 2007-2015 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_file_h.m4 b/m4/sys_file_h.m4 index ad78efb9c..7b6a05a40 100644 --- a/m4/sys_file_h.m4 +++ b/m4/sys_file_h.m4 @@ -1,7 +1,7 @@ # Configure a replacement for . # serial 6 -# Copyright (C) 2008-2014 Free Software Foundation, Inc. +# Copyright (C) 2008-2015 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_select_h.m4 b/m4/sys_select_h.m4 index 1a502b4eb..5ec5919f2 100644 --- a/m4/sys_select_h.m4 +++ b/m4/sys_select_h.m4 @@ -1,5 +1,5 @@ # sys_select_h.m4 serial 20 -dnl Copyright (C) 2006-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_socket_h.m4 b/m4/sys_socket_h.m4 index 114d82817..eaeabe7d9 100644 --- a/m4/sys_socket_h.m4 +++ b/m4/sys_socket_h.m4 @@ -1,5 +1,5 @@ # sys_socket_h.m4 serial 23 -dnl Copyright (C) 2005-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2005-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_stat_h.m4 b/m4/sys_stat_h.m4 index eaa7642ba..6c909e816 100644 --- a/m4/sys_stat_h.m4 +++ b/m4/sys_stat_h.m4 @@ -1,5 +1,5 @@ # sys_stat_h.m4 serial 28 -*- Autoconf -*- -dnl Copyright (C) 2006-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_time_h.m4 b/m4/sys_time_h.m4 index 5c79300f8..28c8b1acb 100644 --- a/m4/sys_time_h.m4 +++ b/m4/sys_time_h.m4 @@ -1,7 +1,7 @@ # Configure a replacement for . # serial 8 -# Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. +# Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. @@ -105,6 +105,7 @@ AC_DEFUN([gl_HEADER_SYS_TIME_H_DEFAULTS], HAVE_GETTIMEOFDAY=1; AC_SUBST([HAVE_GETTIMEOFDAY]) HAVE_STRUCT_TIMEVAL=1; AC_SUBST([HAVE_STRUCT_TIMEVAL]) HAVE_SYS_TIME_H=1; AC_SUBST([HAVE_SYS_TIME_H]) + HAVE_TIMEZONE_T=0; AC_SUBST([HAVE_TIMEZONE_T]) REPLACE_GETTIMEOFDAY=0; AC_SUBST([REPLACE_GETTIMEOFDAY]) REPLACE_STRUCT_TIMEVAL=0; AC_SUBST([REPLACE_STRUCT_TIMEVAL]) ]) diff --git a/m4/sys_times_h.m4 b/m4/sys_times_h.m4 index fad63c4f0..fe927405c 100644 --- a/m4/sys_times_h.m4 +++ b/m4/sys_times_h.m4 @@ -1,7 +1,7 @@ # Configure a replacement for . # serial 8 -# Copyright (C) 2008-2014 Free Software Foundation, Inc. +# Copyright (C) 2008-2015 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_types_h.m4 b/m4/sys_types_h.m4 index 9748905b5..2232aece6 100644 --- a/m4/sys_types_h.m4 +++ b/m4/sys_types_h.m4 @@ -1,5 +1,5 @@ # sys_types_h.m4 serial 5 -dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_uio_h.m4 b/m4/sys_uio_h.m4 index ba6b4b5ed..3dfbcbe6e 100644 --- a/m4/sys_uio_h.m4 +++ b/m4/sys_uio_h.m4 @@ -1,5 +1,5 @@ # sys_uio_h.m4 serial 1 -dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/tempname.m4 b/m4/tempname.m4 index 1594e1f5d..b1694d684 100644 --- a/m4/tempname.m4 +++ b/m4/tempname.m4 @@ -1,6 +1,6 @@ #serial 5 -# Copyright (C) 2006-2007, 2009-2014 Free Software Foundation, Inc. +# Copyright (C) 2006-2007, 2009-2015 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/time_h.m4 b/m4/time_h.m4 index 9852778f9..754b469a0 100644 --- a/m4/time_h.m4 +++ b/m4/time_h.m4 @@ -1,8 +1,8 @@ # Configure a more-standard replacement for . -# Copyright (C) 2000-2001, 2003-2007, 2009-2014 Free Software Foundation, Inc. +# Copyright (C) 2000-2001, 2003-2007, 2009-2015 Free Software Foundation, Inc. -# serial 8 +# serial 9 # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -26,7 +26,7 @@ AC_DEFUN([gl_HEADER_TIME_H_BODY], ]) dnl Check whether 'struct timespec' is declared -dnl in time.h, sys/time.h, or pthread.h. +dnl in time.h, sys/time.h, pthread.h, or unistd.h. AC_DEFUN([gl_CHECK_TYPE_STRUCT_TIMESPEC], [ @@ -44,6 +44,7 @@ AC_DEFUN([gl_CHECK_TYPE_STRUCT_TIMESPEC], TIME_H_DEFINES_STRUCT_TIMESPEC=0 SYS_TIME_H_DEFINES_STRUCT_TIMESPEC=0 PTHREAD_H_DEFINES_STRUCT_TIMESPEC=0 + UNISTD_H_DEFINES_STRUCT_TIMESPEC=0 if test $gl_cv_sys_struct_timespec_in_time_h = yes; then TIME_H_DEFINES_STRUCT_TIMESPEC=1 else @@ -70,12 +71,26 @@ AC_DEFUN([gl_CHECK_TYPE_STRUCT_TIMESPEC], [gl_cv_sys_struct_timespec_in_pthread_h=no])]) if test $gl_cv_sys_struct_timespec_in_pthread_h = yes; then PTHREAD_H_DEFINES_STRUCT_TIMESPEC=1 + else + AC_CACHE_CHECK([for struct timespec in ], + [gl_cv_sys_struct_timespec_in_unistd_h], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM( + [[#include + ]], + [[static struct timespec x; x.tv_sec = x.tv_nsec;]])], + [gl_cv_sys_struct_timespec_in_unistd_h=yes], + [gl_cv_sys_struct_timespec_in_unistd_h=no])]) + if test $gl_cv_sys_struct_timespec_in_unistd_h = yes; then + UNISTD_H_DEFINES_STRUCT_TIMESPEC=1 + fi fi fi fi AC_SUBST([TIME_H_DEFINES_STRUCT_TIMESPEC]) AC_SUBST([SYS_TIME_H_DEFINES_STRUCT_TIMESPEC]) AC_SUBST([PTHREAD_H_DEFINES_STRUCT_TIMESPEC]) + AC_SUBST([UNISTD_H_DEFINES_STRUCT_TIMESPEC]) ]) AC_DEFUN([gl_TIME_MODULE_INDICATOR], @@ -94,6 +109,7 @@ AC_DEFUN([gl_HEADER_TIME_H_DEFAULTS], GNULIB_STRPTIME=0; AC_SUBST([GNULIB_STRPTIME]) GNULIB_TIMEGM=0; AC_SUBST([GNULIB_TIMEGM]) GNULIB_TIME_R=0; AC_SUBST([GNULIB_TIME_R]) + GNULIB_TIME_RZ=0; AC_SUBST([GNULIB_TIME_RZ]) dnl Assume proper GNU behavior unless another module says otherwise. HAVE_DECL_LOCALTIME_R=1; AC_SUBST([HAVE_DECL_LOCALTIME_R]) HAVE_NANOSLEEP=1; AC_SUBST([HAVE_NANOSLEEP]) diff --git a/m4/time_r.m4 b/m4/time_r.m4 index 7e15600f7..8df7e139c 100644 --- a/m4/time_r.m4 +++ b/m4/time_r.m4 @@ -1,6 +1,6 @@ dnl Reentrant time functions: localtime_r, gmtime_r. -dnl Copyright (C) 2003, 2006-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2006-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/time_rz.m4 b/m4/time_rz.m4 new file mode 100644 index 000000000..0c1f2c373 --- /dev/null +++ b/m4/time_rz.m4 @@ -0,0 +1,21 @@ +dnl Time zone functions: tzalloc, localtime_rz, etc. + +dnl Copyright (C) 2015 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl Written by Paul Eggert. + +AC_DEFUN([gl_TIME_RZ], +[ + AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) + AC_REQUIRE([gl_HEADER_SYS_TIME_H_DEFAULTS]) + AC_REQUIRE([AC_STRUCT_TIMEZONE]) + AC_CHECK_FUNCS_ONCE([tzset]) + + AC_CHECK_TYPES([timezone_t], [], [], [[#include ]]) + if test "$ac_cv_type_timezone_t" = yes; then + HAVE_TIMEZONE_T=1 + fi +]) diff --git a/m4/timegm.m4 b/m4/timegm.m4 new file mode 100644 index 000000000..8e68b99ba --- /dev/null +++ b/m4/timegm.m4 @@ -0,0 +1,26 @@ +# timegm.m4 serial 11 +dnl Copyright (C) 2003, 2007, 2009-2015 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_FUNC_TIMEGM], +[ + AC_REQUIRE([gl_HEADER_TIME_H_DEFAULTS]) + AC_REQUIRE([gl_FUNC_MKTIME]) + REPLACE_TIMEGM=0 + AC_CHECK_FUNCS_ONCE([timegm]) + if test $ac_cv_func_timegm = yes; then + if test $gl_cv_func_working_mktime = no; then + # Assume that timegm is buggy if mktime is. + REPLACE_TIMEGM=1 + fi + else + HAVE_TIMEGM=0 + fi +]) + +# Prerequisites of lib/timegm.c. +AC_DEFUN([gl_PREREQ_TIMEGM], [ + : +]) diff --git a/m4/times.m4 b/m4/times.m4 index 3ee364b8c..0359bbcee 100644 --- a/m4/times.m4 +++ b/m4/times.m4 @@ -1,5 +1,5 @@ # times.m4 serial 2 -dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/tm_gmtoff.m4 b/m4/tm_gmtoff.m4 index 486351b47..71a88f92f 100644 --- a/m4/tm_gmtoff.m4 +++ b/m4/tm_gmtoff.m4 @@ -1,5 +1,5 @@ # tm_gmtoff.m4 serial 3 -dnl Copyright (C) 2002, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002, 2009-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/trunc.m4 b/m4/trunc.m4 index ba87bd0c0..da276c1ff 100644 --- a/m4/trunc.m4 +++ b/m4/trunc.m4 @@ -1,5 +1,5 @@ # trunc.m4 serial 9 -dnl Copyright (C) 2007, 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2010-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/unistd_h.m4 b/m4/unistd_h.m4 index 1fa197e69..b3c581f7b 100644 --- a/m4/unistd_h.m4 +++ b/m4/unistd_h.m4 @@ -1,5 +1,5 @@ -# unistd_h.m4 serial 67 -dnl Copyright (C) 2006-2014 Free Software Foundation, Inc. +# unistd_h.m4 serial 68 +dnl Copyright (C) 2006-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -173,9 +173,11 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS], REPLACE_PWRITE=0; AC_SUBST([REPLACE_PWRITE]) REPLACE_READ=0; AC_SUBST([REPLACE_READ]) REPLACE_READLINK=0; AC_SUBST([REPLACE_READLINK]) + REPLACE_READLINKAT=0; AC_SUBST([REPLACE_READLINKAT]) REPLACE_RMDIR=0; AC_SUBST([REPLACE_RMDIR]) REPLACE_SLEEP=0; AC_SUBST([REPLACE_SLEEP]) REPLACE_SYMLINK=0; AC_SUBST([REPLACE_SYMLINK]) + REPLACE_SYMLINKAT=0; AC_SUBST([REPLACE_SYMLINKAT]) REPLACE_TTYNAME_R=0; AC_SUBST([REPLACE_TTYNAME_R]) REPLACE_UNLINK=0; AC_SUBST([REPLACE_UNLINK]) REPLACE_UNLINKAT=0; AC_SUBST([REPLACE_UNLINKAT]) diff --git a/m4/vasnprintf.m4 b/m4/vasnprintf.m4 index 106192ea2..4708f2b8e 100644 --- a/m4/vasnprintf.m4 +++ b/m4/vasnprintf.m4 @@ -1,5 +1,5 @@ # vasnprintf.m4 serial 36 -dnl Copyright (C) 2002-2004, 2006-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2004, 2006-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/visibility.m4 b/m4/visibility.m4 index 552e39772..6fff7459c 100644 --- a/m4/visibility.m4 +++ b/m4/visibility.m4 @@ -1,5 +1,5 @@ # visibility.m4 serial 5 (gettext-0.18.2) -dnl Copyright (C) 2005, 2008, 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2005, 2008, 2010-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/vsnprintf.m4 b/m4/vsnprintf.m4 index 07f739df9..28be6fd18 100644 --- a/m4/vsnprintf.m4 +++ b/m4/vsnprintf.m4 @@ -1,5 +1,5 @@ # vsnprintf.m4 serial 6 -dnl Copyright (C) 2002-2004, 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2004, 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/warn-on-use.m4 b/m4/warn-on-use.m4 index cc690f8e2..1e98dc9b7 100644 --- a/m4/warn-on-use.m4 +++ b/m4/warn-on-use.m4 @@ -1,5 +1,5 @@ # warn-on-use.m4 serial 5 -dnl Copyright (C) 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/warnings.m4 b/m4/warnings.m4 index 43156f450..5ae01def1 100644 --- a/m4/warnings.m4 +++ b/m4/warnings.m4 @@ -1,5 +1,5 @@ # warnings.m4 serial 11 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/wchar_h.m4 b/m4/wchar_h.m4 index 85db95286..9d1b0f8b6 100644 --- a/m4/wchar_h.m4 +++ b/m4/wchar_h.m4 @@ -1,6 +1,6 @@ dnl A placeholder for ISO C99 , for platforms that have issues. -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/wchar_t.m4 b/m4/wchar_t.m4 index 839a04c17..dc964e67e 100644 --- a/m4/wchar_t.m4 +++ b/m4/wchar_t.m4 @@ -1,5 +1,5 @@ # wchar_t.m4 serial 4 (gettext-0.18.2) -dnl Copyright (C) 2002-2003, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2003, 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/wcrtomb.m4 b/m4/wcrtomb.m4 index 844ef6a8c..7e3fe3f54 100644 --- a/m4/wcrtomb.m4 +++ b/m4/wcrtomb.m4 @@ -1,5 +1,5 @@ # wcrtomb.m4 serial 11 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/wctype_h.m4 b/m4/wctype_h.m4 index 3fac0ee09..95a4705b0 100644 --- a/m4/wctype_h.m4 +++ b/m4/wctype_h.m4 @@ -2,7 +2,7 @@ dnl A placeholder for ISO C99 , for platforms that lack it. -dnl Copyright (C) 2006-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/wint_t.m4 b/m4/wint_t.m4 index 9b07b0709..ca3fd449a 100644 --- a/m4/wint_t.m4 +++ b/m4/wint_t.m4 @@ -1,5 +1,5 @@ # wint_t.m4 serial 5 (gettext-0.18.2) -dnl Copyright (C) 2003, 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2007-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/write.m4 b/m4/write.m4 index 820dd4f77..ce7042ef1 100644 --- a/m4/write.m4 +++ b/m4/write.m4 @@ -1,5 +1,5 @@ # write.m4 serial 5 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/xsize.m4 b/m4/xsize.m4 index 3af23ec75..98faf7de0 100644 --- a/m4/xsize.m4 +++ b/m4/xsize.m4 @@ -1,5 +1,5 @@ # xsize.m4 serial 5 -dnl Copyright (C) 2003-2004, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2003-2004, 2008-2015 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/maint.mk b/maint.mk index 30f2e8e69..893874b45 100644 --- a/maint.mk +++ b/maint.mk @@ -2,7 +2,7 @@ # This Makefile fragment tries to be general-purpose enough to be # used by many projects via the gnulib maintainer-makefile module. -## Copyright (C) 2001-2014 Free Software Foundation, Inc. +## Copyright (C) 2001-2015 Free Software Foundation, Inc. ## ## This program is free software: you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by @@ -21,13 +21,6 @@ # ME := $(word $(words $(MAKEFILE_LIST)),$(MAKEFILE_LIST)) ME := maint.mk -# Diagnostic for continued use of deprecated variable. -# Remove in 2013 -ifneq ($(build_aux),) - $(error "$(ME): \ -set $$(_build-aux) relative to $$(srcdir) instead of $$(build_aux)") -endif - # Helper variables. _empty = _sp = $(_empty) $(_empty) @@ -155,6 +148,7 @@ export LC_ALL = C ## Sanity checks. ## ## --------------- ## +ifneq ($(_gl-Makefile),) _cfg_mk := $(wildcard $(srcdir)/cfg.mk) # Collect the names of rules starting with 'sc_'. @@ -196,6 +190,7 @@ local-check := \ $(filter-out $(local-checks-to-skip), $(local-checks-available))) syntax-check: $(local-check) +endif # _sc_search_regexp # @@ -445,7 +440,7 @@ sc_require_config_h: # You must include before including any other header file. # This can possibly be via a package-specific header, if given by cfg.mk. sc_require_config_h_first: - @if $(VC_LIST_EXCEPT) | grep -l '\.c$$' > /dev/null; then \ + @if $(VC_LIST_EXCEPT) | grep '\.c$$' > /dev/null; then \ fail=0; \ for i in $$($(VC_LIST_EXCEPT) | grep '\.c$$'); do \ grep '^# *include\>' $$i | $(SED) 1q \ @@ -469,7 +464,7 @@ sc_prohibit_HAVE_MBRTOWC: define _sc_header_without_use dummy=; : so we do not need a semicolon before each use; \ h_esc=`echo '[<"]'"$$h"'[">]'|$(SED) 's/\./\\\\./g'`; \ - if $(VC_LIST_EXCEPT) | grep -l '\.c$$' > /dev/null; then \ + if $(VC_LIST_EXCEPT) | grep '\.c$$' > /dev/null; then \ files=$$(grep -l '^# *include '"$$h_esc" \ $$($(VC_LIST_EXCEPT) | grep '\.c$$')) && \ grep -LE "$$re" $$files | grep . && \ @@ -716,7 +711,7 @@ sc_changelog: # Ensure that each .c file containing a "main" function also # calls set_program_name. sc_program_name: - @require='set_program_name *\(m?argv\[0\]\);' \ + @require='set_program_name *\(.*\);' \ in_vc_files='\.c$$' \ containing='\
&2; exit 1; } || : +# Except for shell files and for loops, double semicolon is probably a mistake +sc_prohibit_double_semicolon: + @prohibit='; *;[ {} \]*(/[/*]|$$)' \ + in_vc_files='\.[chly]$$' \ + exclude='\bfor *\(.*\)' \ + halt="Double semicolon detected" \ + $(_sc_search_regexp) + _ptm1 = use "test C1 && test C2", not "test C1 -''a C2" _ptm2 = use "test C1 || test C2", not "test C1 -''o C2" # Using test's -a and -o operators is not portable. @@ -1192,7 +1195,7 @@ sc_copyright_check: in_vc_files=$(sample-test) \ halt='out of date copyright in $(sample-test); update it' \ $(_sc_search_regexp) - @require='Copyright @copyright\{\} .*'$$(date +%Y)' Free' \ + @require='Copyright @copyright\{\} .*'$$(date +%Y) \ in_vc_files=$(texi) \ halt='out of date copyright in $(texi); update it' \ $(_sc_search_regexp) @@ -1597,7 +1600,7 @@ ifeq (a,b) # do not need to be marked. Symbols matching '__.*' are # reserved by the compiler, so are automatically excluded below. _gl_TS_unmarked_extern_functions ?= main usage -_gl_TS_function_match ?= /^(?:$(_gl_TS_extern)) +.*?(\S+) *\(/ +_gl_TS_function_match ?= /^(?:$(_gl_TS_extern)) +.*?(\w+) *\(/ # If your project uses a macro like "XTERN", then put # the following in cfg.mk to override this default: @@ -1630,6 +1633,7 @@ _gl_TS_other_headers ?= *.h .PHONY: _gl_tight_scope _gl_tight_scope: $(bin_PROGRAMS) + sed_wrap='s/^/^_?/;s/$$/$$/'; \ t=exceptions-$$$$; \ trap 's=$$?; rm -f $$t; exit $$s' 0; \ for sig in 1 2 3 13 15; do \ @@ -1639,20 +1643,20 @@ _gl_tight_scope: $(bin_PROGRAMS) test -f $$f && d= || d=$(srcdir)/; echo $$d$$f; done`; \ hdr=`for f in $(_gl_TS_headers); do \ test -f $$f && d= || d=$(srcdir)/; echo $$d$$f; done`; \ - ( printf '^%s$$\n' '__.*' $(_gl_TS_unmarked_extern_functions); \ + ( printf '%s\n' '__.*' $(_gl_TS_unmarked_extern_functions); \ grep -h -A1 '^extern .*[^;]$$' $$src \ - | grep -vE '^(extern |--)' | $(SED) 's/ .*//'; \ + | grep -vE '^(extern |--|#)' | $(SED) 's/ .*//; /^$$/d'; \ perl -lne \ - '$(_gl_TS_function_match) and print "^$$1\$$"' $$hdr; \ - ) | sort -u > $$t; \ - nm -e $(_gl_TS_obj_files)|$(SED) -n 's/.* T //p'|grep -Ev -f $$t \ + '$(_gl_TS_function_match) and print $$1' $$hdr; \ + ) | sort -u | $(SED) "$$sed_wrap" > $$t; \ + nm -g $(_gl_TS_obj_files)|$(SED) -n 's/.* T //p'|grep -Ev -f $$t \ && { echo the above functions should have static scope >&2; \ exit 1; } || : ; \ - ( printf '^%s$$\n' '__.*' $(_gl_TS_unmarked_extern_vars); \ - perl -lne '$(_gl_TS_var_match) and print "^$$1\$$"' \ + ( printf '%s\n' '__.*' main $(_gl_TS_unmarked_extern_vars); \ + perl -lne '$(_gl_TS_var_match) and print $$1' \ $$hdr $(_gl_TS_other_headers) \ - ) | sort -u > $$t; \ - nm -e $(_gl_TS_obj_files) | $(SED) -n 's/.* [BCDGRS] //p' \ + ) | sort -u | $(SED) "$$sed_wrap" > $$t; \ + nm -g $(_gl_TS_obj_files) | $(SED) -n 's/.* [BCDGRS] //p' \ | sort -u | grep -Ev -f $$t \ && { echo the above variables should have static scope >&2; \ exit 1; } || : From f169be9fc8c0b8c9a27476b59e683c8dfeea8aa6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 22 Oct 2015 17:44:17 +0000 Subject: [PATCH 068/865] Wire up `guild compile -O0 foo.scm' * module/scripts/compile.scm (%options): Resurrect -O option and make it follow GCC, more or less. The default is equivalent to -O2. * module/language/cps/compile-bytecode.scm (lower-cps): * module/language/cps/optimize.scm (optimize-higher-order-cps): Move split-rec to run unconditionally for now, as closure conversion fails without it. (define-optimizer): Only verify the result if we are debugging, to save time. (cps-default-optimization-options): New exported procedure. * module/language/tree-il/optimize.scm (tree-il-default-optimization-options): New exported procedure. --- module/language/cps/compile-bytecode.scm | 6 ++ module/language/cps/optimize.scm | 29 +++++++-- module/language/tree-il/optimize.scm | 8 ++- module/scripts/compile.scm | 77 +++++++++++++++++++++--- 4 files changed, 105 insertions(+), 15 deletions(-) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 5b0c32990..86c9d307d 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -34,6 +34,7 @@ #:use-module (language cps optimize) #:use-module (language cps reify-primitives) #:use-module (language cps renumber) + #:use-module (language cps split-rec) #:use-module (language cps intmap) #:use-module (language cps intset) #:use-module (system vm assembler) @@ -513,6 +514,11 @@ env))) (define (lower-cps exp opts) + ;; FIXME: For now the closure conversion pass relies on $rec instances + ;; being separated into SCCs. We should fix this to not be the case, + ;; and instead move the split-rec pass back to + ;; optimize-higher-order-cps. + (set! exp (split-rec exp)) (set! exp (optimize-higher-order-cps exp opts)) (set! exp (convert-closures exp)) (set! exp (optimize-first-order-cps exp opts)) diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm index c6576fc4a..8777222c9 100644 --- a/module/language/cps/optimize.scm +++ b/module/language/cps/optimize.scm @@ -37,11 +37,11 @@ #:use-module (language cps self-references) #:use-module (language cps simplify) #:use-module (language cps specialize-primcalls) - #:use-module (language cps split-rec) #:use-module (language cps type-fold) #:use-module (language cps verify) #:export (optimize-higher-order-cps - optimize-first-order-cps)) + optimize-first-order-cps + cps-default-optimization-options)) (define (kw-arg-ref args kw default) (match (memq kw args) @@ -75,8 +75,7 @@ (maybe-verify (pass program)) program)) ... - (verify program) - program)) + (maybe-verify program))) ;; Passes that are needed: ;; @@ -84,7 +83,11 @@ ;; calls, and eliding prompts if possible. ;; (define-optimizer optimize-higher-order-cps - (split-rec #:split-rec? #t) + ;; FIXME: split-rec call temporarily moved to compile-bytecode and run + ;; unconditionally, because closure conversion requires it. Move the + ;; pass back here when that's fixed. + ;; + ;; (split-rec #:split-rec? #t) (eliminate-dead-code #:eliminate-dead-code? #t) (prune-top-level-scopes #:prune-top-level-scopes? #t) (simplify #:simplify? #t) @@ -106,3 +109,19 @@ (eliminate-dead-code #:eliminate-dead-code? #t) (rotate-loops #:rotate-loops? #t) (simplify #:simplify? #t)) + +(define (cps-default-optimization-options) + (list ;; #:split-rec? #t + #:eliminate-dead-code? #t + #:prune-top-level-scopes? #t + #:contify? #t + #:inline-constructors? #t + #:specialize-primcalls? #t + #:elide-values? #t + #:prune-bailouts? #t + #:peel-loops? #t + #:cse? #t + #:type-fold? #t + #:resolve-self-references? #t + #:licm? #t + #:rotate-loops? #t)) diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index d5d4f43a0..8fa6a80e8 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -1,6 +1,6 @@ ;;; Tree-il optimizer -;; Copyright (C) 2009, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2009, 2011, 2012, 2013, 2014, 2015 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,8 @@ #:use-module (language tree-il fix-letrec) #:use-module (language tree-il debug) #:use-module (ice-9 match) - #:export (optimize)) + #:export (optimize + tree-il-default-optimization-options)) (define (optimize x env opts) (let ((peval (match (memq #:partial-eval? opts) @@ -37,3 +38,6 @@ (verify-tree-il (peval (expand-primitives (resolve-primitives x env)) env))))) + +(define (tree-il-default-optimization-options) + '(#:partial-eval? #t)) diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm index 5b644c3d4..939fb2564 100644 --- a/module/scripts/compile.scm +++ b/module/scripts/compile.scm @@ -1,6 +1,6 @@ ;;; Compile --- Command-line Guile Scheme compiler -*- coding: iso-8859-1 -*- -;; Copyright 2005, 2008-2011, 2013, 2014 Free Software Foundation, Inc. +;; Copyright 2005, 2008-2011, 2013, 2014, 2015 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -32,10 +32,13 @@ #:use-module ((system base compile) #:select (compile-file)) #:use-module (system base target) #:use-module (system base message) + #:use-module (language tree-il optimize) + #:use-module (language cps optimize) #:use-module (srfi srfi-1) #:use-module (srfi srfi-13) #:use-module (srfi srfi-37) #:use-module (ice-9 format) + #:use-module (ice-9 match) #:export (compile)) (define %summary "Compile a file.") @@ -45,6 +48,20 @@ (format (current-error-port) "error: ~{~a~}~%" messages) (exit 1)) +(define (available-optimizations) + (append (tree-il-default-optimization-options) + (cps-default-optimization-options))) + +;; Turn on all optimizations unless -O0. +(define (optimizations-for-level level) + (let lp ((options (available-optimizations))) + (match options + (() '()) + ((#:partial-eval? val . options) + (cons* #:partial-eval? (> level 0) (lp options))) + ((kw val . options) + (cons* kw (> level 1) (lp options)))))) + (define %options ;; Specifications of the command-line options. (list (option '(#\h "help") #f #f @@ -77,9 +94,28 @@ (cons (string->symbol arg) warnings) (alist-delete 'warnings result)))))) - (option '(#\O "optimize") #f #f + (option '(#\O "optimize") #t #f (lambda (opt name arg result) - (alist-cons 'optimize? #t result))) + (define (return val) + (alist-cons 'optimizations val result)) + (define (return-option name val) + (let ((kw (symbol->keyword + (string->symbol (string-append name "?"))))) + (unless (memq kw (available-optimizations)) + (fail "Unknown optimization pass `~a'" name)) + (return (list kw val)))) + (cond + ((string=? arg "help") + (show-optimization-help) + (exit 0)) + ((equal? arg "0") (return (optimizations-for-level 0))) + ((equal? arg "1") (return (optimizations-for-level 1))) + ((equal? arg "2") (return (optimizations-for-level 2))) + ((equal? arg "3") (return (optimizations-for-level 3))) + ((string-prefix? "no-" arg) + (return-option (substring arg 3) #f)) + (else + (return-option arg #t))))) (option '(#\f "from") #t #f (lambda (opt name arg result) (if (assoc-ref result 'from) @@ -129,15 +165,38 @@ There is NO WARRANTY, to the extent permitted by law.~%")) %warning-types) (format #t "~%")) +(define (show-optimization-help) + (format #t "The available optimizations are:~%~%") + (let lp ((options (available-optimizations))) + (match options + (() #t) + ((kw val . options) + (let ((name (string-trim-right (symbol->string (keyword->symbol kw)) + #\?))) + (format #t " -O~a~%" + (if val name (string-append "no-" name))) + (lp options))))) + (format #t "~%") + (format #t "To disable an optimization, prepend it with `no-', for example~%") + (format #t "`-Ono-cse.'~%~%") + (format #t "You may also specify optimization levels as `-O0', `-O1',~%") + (format #t "`-O2', or `-O3'. Currently `-O0' turns off all optimizations,~%") + (format #t "`-O1' turns on partial evaluation, and `-O2' and `-O3' turn on~%") + (format #t "everything. The default is equivalent to `-O2'.") + (format #t "~%")) + (define (compile . args) (let* ((options (parse-args args)) (help? (assoc-ref options 'help?)) - (compile-opts (let ((o `(#:warnings - ,(assoc-ref options 'warnings)))) - (if (assoc-ref options 'optimize?) - (cons #:O o) - o))) + (compile-opts `(#:warnings + ,(assoc-ref options 'warnings) + ,@(append-map + (lambda (opt) + (match opt + (('optimizations . opts) opts) + (_ '()))) + options))) (from (or (assoc-ref options 'from) 'scheme)) (to (or (assoc-ref options 'to) 'bytecode)) (target (or (assoc-ref options 'target) %host-type)) @@ -156,6 +215,8 @@ Compile each Guile source file FILE into a Guile object. -W, --warn=WARNING emit warnings of type WARNING; use `--warn=help' for a list of available warnings + -O, --optimize=OPT specify optimization passes to run; use `-Ohelp' + for a list of available optimizations -f, --from=LANG specify a source language other than `scheme' -t, --to=LANG specify a target language other than `bytecode' From 5f4ac529e16f4d8cb6c5df61c5aa47b6384ac98f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 23 Oct 2015 13:29:03 +0000 Subject: [PATCH 069/865] Use a bootstrapped -O0 compiler to compile the -O2 Guile This reduces total build time to around 30 minutes or so. * Makefile.am (SUBDIRS): Visit bootstrap/ before module/. * bootstrap/Makefile.am: New file. * configure.ac: Generate bootstrap/Makefile. * meta/uninstalled-env.in (top_builddir): Add bootstrap/ to the GUILE_LOAD_COMPILED_PATH. * module/Makefile.am: Simplify to just sort files in alphabetical order; since bootstrap/ was already compiled, we don't need to try to optimize compilation order. Although the compiler will get faster as more of the compiler itself is optimized, this isn't a significant enough effect to worry about. --- Makefile.am | 3 +- bootstrap/Makefile.am | 152 +++++++++++ configure.ac | 1 + meta/uninstalled-env.in | 4 +- module/Makefile.am | 577 ++++++++++++++++++---------------------- 5 files changed, 422 insertions(+), 315 deletions(-) create mode 100644 bootstrap/Makefile.am diff --git a/Makefile.am b/Makefile.am index 8f9e014c7..7918c7974 100644 --- a/Makefile.am +++ b/Makefile.am @@ -2,7 +2,7 @@ ## ## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2006, 2007, ## 2008, 2009, 2010, 2011, 2012, 2013, -## 2014 Free Software Foundation, Inc. +## 2014, 2015 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -30,6 +30,7 @@ SUBDIRS = \ lib \ meta \ libguile \ + bootstrap \ module \ guile-readline \ examples \ diff --git a/bootstrap/Makefile.am b/bootstrap/Makefile.am new file mode 100644 index 000000000..4f0bfac40 --- /dev/null +++ b/bootstrap/Makefile.am @@ -0,0 +1,152 @@ +## Process this file with automake to produce Makefile.in. +## +## Copyright (C) 2009, 2010, 2011, 2012, 2013, +## 2014, 2015 Free Software Foundation, Inc. +## +## This file is part of GUILE. +## +## GUILE is free software; you can redistribute it and/or modify it +## under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or +## (at your option) any later version. +## +## GUILE is distributed in the hope that it will be useful, but +## WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU Lesser General Public License for more details. +## +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA + + +GOBJECTS = $(SOURCES:%.scm=%.go) +GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat +GUILE_OPTIMIZATIONS = -O1 +nobase_noinst_DATA = $(GOBJECTS) ice-9/eval.go +CLEANFILES = $(GOBJECTS) ice-9/eval.go + +$(GOBJECTS): ice-9/eval.go + +VM_TARGETS := system/vm/assembler.go system/vm/disassembler.go +$(VM_TARGETS): $(top_builddir)/libguile/vm-operations.h + +AM_V_GUILEC = $(AM_V_GUILEC_$(V)) +AM_V_GUILEC_ = $(AM_V_GUILEC_$(AM_DEFAULT_VERBOSITY)) +AM_V_GUILEC_0 = @echo " BOOTSTRAP GUILEC" $@; + +vpath %.scm @srcdir@/../module + +SUFFIXES = .scm .go + +.scm.go: + $(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \ + $(top_builddir)/meta/uninstalled-env \ + guild compile --target="$(host)" \ + $(GUILE_WARNINGS) $(GUILE_OPTIMIZATIONS) \ + -L "$(abs_srcdir)" -L "$(abs_builddir)" \ + -L "$(abs_top_srcdir)/guile-readline" \ + -o "$@" "$<" + +# A subset of sources that are used by the compiler. We can compile +# these in any order; the order below is designed to hopefully result in +# the lowest total compile time. +SOURCES = \ + language/cps/intmap.scm \ + language/cps/intset.scm \ + language/cps/utils.scm \ + ice-9/vlist.scm \ + srfi/srfi-1.scm \ + \ + language/tree-il.scm \ + language/tree-il/analyze.scm \ + language/tree-il/canonicalize.scm \ + language/tree-il/compile-cps.scm \ + language/tree-il/debug.scm \ + language/tree-il/effects.scm \ + language/tree-il/fix-letrec.scm \ + language/tree-il/optimize.scm \ + language/tree-il/peval.scm \ + language/tree-il/primitives.scm \ + language/tree-il/spec.scm \ + \ + language/cps.scm \ + language/cps/closure-conversion.scm \ + language/cps/compile-bytecode.scm \ + language/cps/constructors.scm \ + language/cps/contification.scm \ + language/cps/cse.scm \ + language/cps/dce.scm \ + language/cps/effects-analysis.scm \ + language/cps/elide-values.scm \ + language/cps/licm.scm \ + language/cps/peel-loops.scm \ + language/cps/primitives.scm \ + language/cps/prune-bailouts.scm \ + language/cps/prune-top-level-scopes.scm \ + language/cps/reify-primitives.scm \ + language/cps/renumber.scm \ + language/cps/rotate-loops.scm \ + language/cps/optimize.scm \ + language/cps/simplify.scm \ + language/cps/self-references.scm \ + language/cps/slot-allocation.scm \ + language/cps/spec.scm \ + language/cps/specialize-primcalls.scm \ + language/cps/split-rec.scm \ + language/cps/type-checks.scm \ + language/cps/type-fold.scm \ + language/cps/types.scm \ + language/cps/verify.scm \ + language/cps/with-cps.scm \ + \ + language/scheme/spec.scm \ + language/scheme/compile-tree-il.scm \ + language/scheme/decompile-tree-il.scm \ + \ + language/bytecode.scm \ + language/bytecode/spec.scm \ + \ + language/value/spec.scm \ + \ + system/base/pmatch.scm \ + system/base/syntax.scm \ + system/base/compile.scm \ + system/base/language.scm \ + system/base/lalr.scm \ + system/base/message.scm \ + system/base/target.scm \ + system/base/types.scm \ + system/base/ck.scm \ + \ + ice-9/psyntax-pp.scm \ + ice-9/boot-9.scm \ + ice-9/r5rs.scm \ + ice-9/deprecated.scm \ + ice-9/binary-ports.scm \ + ice-9/command-line.scm \ + ice-9/control.scm \ + ice-9/format.scm \ + ice-9/getopt-long.scm \ + ice-9/i18n.scm \ + ice-9/match.scm \ + ice-9/networking.scm \ + ice-9/posix.scm \ + ice-9/rdelim.scm \ + ice-9/receive.scm \ + ice-9/regex.scm \ + ice-9/session.scm \ + ice-9/pretty-print.scm \ + \ + system/vm/assembler.scm \ + system/vm/debug.scm \ + system/vm/disassembler.scm \ + system/vm/dwarf.scm \ + system/vm/elf.scm \ + system/vm/frame.scm \ + system/vm/linker.scm \ + system/vm/loader.scm \ + system/vm/program.scm \ + system/vm/vm.scm \ + system/foreign.scm diff --git a/configure.ac b/configure.ac index 19e00d818..9e639d6da 100644 --- a/configure.ac +++ b/configure.ac @@ -1643,6 +1643,7 @@ AC_CONFIG_FILES([ test-suite/standalone/Makefile test-suite/vm/Makefile meta/Makefile + bootstrap/Makefile module/Makefile ]) diff --git a/meta/uninstalled-env.in b/meta/uninstalled-env.in index 567c6e243..f9f0dc78d 100644 --- a/meta/uninstalled-env.in +++ b/meta/uninstalled-env.in @@ -1,6 +1,6 @@ #!/bin/sh -# Copyright (C) 2003, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation +# Copyright (C) 2003, 2006, 2008, 2009, 2010, 2011, 2012, 2015 Free Software Foundation # # This file is part of GUILE. # @@ -84,7 +84,7 @@ then then GUILE_LOAD_COMPILED_PATH="${top_builddir}/module:${top_builddir}/guile-readline" else - for d in "/module" "/guile-readline" + for d in "/module" "/bootstrap" "/guile-readline" do # This hair prevents double inclusion. # The ":" prevents prefix aliasing. diff --git a/module/Makefile.am b/module/Makefile.am index 17e663241..f835ceb73 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -25,74 +25,13 @@ include $(top_srcdir)/am/guilec # We're at the root of the module hierarchy. modpath = -# Build eval.go first. Then build psyntax-pp.go, as the expander has to -# run on every loaded scheme file. It doesn't pay off at compile-time -# to interpret the expander in parallel. -BOOT_SOURCES = ice-9/psyntax-pp.scm -BOOT_GOBJECTS = $(BOOT_SOURCES:%.scm=%.go) -$(BOOT_GOBJECTS): ice-9/eval.go -$(GOBJECTS): $(BOOT_GOBJECTS) -CLEANFILES += ice-9/eval.go $(BOOT_GOBJECTS) -nobase_mod_DATA += ice-9/eval.scm $(BOOT_SOURCES) -nobase_ccache_DATA += ice-9/eval.go $(BOOT_GOBJECTS) -EXTRA_DIST += ice-9/eval.scm $(BOOT_SOURCES) -ETAGS_ARGS += ice-9/eval.scm $(BOOT_SOURCES) - VM_TARGETS := system/vm/assembler.go system/vm/disassembler.go $(VM_TARGETS): $(top_builddir)/libguile/vm-operations.h ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm ice-9/r6rs-libraries.scm ice-9/match.go: ice-9/match.scm ice-9/match.upstream.scm - -# We can compile these in any order, but it's fastest if we compile -# boot-9 first, then the compiler itself, then the rest of the code. -SOURCES = \ - ice-9/boot-9.scm \ - language/cps/intmap.scm \ - language/cps/intset.scm \ - language/tree-il/peval.scm \ - system/vm/elf.scm \ - ice-9/vlist.scm \ - srfi/srfi-1.scm \ - system/vm/linker.scm \ - system/vm/dwarf.scm \ - system/vm/assembler.scm \ - \ - language/tree-il.scm \ - $(TREE_IL_LANG_SOURCES) \ - $(CPS_LANG_SOURCES) \ - $(BYTECODE_LANG_SOURCES) \ - $(VALUE_LANG_SOURCES) \ - $(SCHEME_LANG_SOURCES) \ - $(SYSTEM_BASE_SOURCES) \ - \ - $(ICE_9_SOURCES) \ - $(SYSTEM_SOURCES) \ - $(SRFI_SOURCES) \ - $(RNRS_SOURCES) \ - $(OOP_SOURCES) \ - $(SCRIPTS_SOURCES) \ - $(ECMASCRIPT_LANG_SOURCES) \ - $(ELISP_LANG_SOURCES) \ - $(BRAINFUCK_LANG_SOURCES) \ - $(LIB_SOURCES) \ - $(WEB_SOURCES) - -## test.scm is not currently installed. -EXTRA_DIST += \ - ice-9/test.scm \ - ice-9/compile-psyntax.scm \ - ice-9/ChangeLog-2008 -ETAGS_ARGS += \ - ice-9/test.scm \ - ice-9/compile-psyntax.scm \ - ice-9/ChangeLog-2008 - -ice-9/psyntax-pp.scm.gen: - $(top_builddir_absolute)/meta/guile --no-auto-compile -s $(srcdir)/ice-9/compile-psyntax.scm \ - $(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm - -.PHONY: ice-9/psyntax-pp.scm.gen +srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm +$(nobase_ccache_DATA): ../bootstrap/ice-9/eval.go # Keep this rule in sync with that in `am/guilec'. ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm @@ -103,62 +42,121 @@ ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm -L "$(abs_top_srcdir)/guile-readline" \ -o "ice-9/psyntax-pp.go" "$(srcdir)/ice-9/psyntax.scm" -SCHEME_LANG_SOURCES = \ - language/scheme/spec.scm \ - language/scheme/compile-tree-il.scm \ - language/scheme/decompile-tree-il.scm - -TREE_IL_LANG_SOURCES = \ - language/tree-il/primitives.scm \ - language/tree-il/effects.scm \ - language/tree-il/fix-letrec.scm \ - language/tree-il/optimize.scm \ - language/tree-il/canonicalize.scm \ - language/tree-il/analyze.scm \ - language/tree-il/compile-cps.scm \ - language/tree-il/debug.scm \ - language/tree-il/spec.scm - -CPS_LANG_SOURCES = \ - language/cps.scm \ - language/cps/closure-conversion.scm \ - language/cps/compile-bytecode.scm \ - language/cps/constructors.scm \ - language/cps/contification.scm \ - language/cps/cse.scm \ - language/cps/dce.scm \ - language/cps/effects-analysis.scm \ - language/cps/elide-values.scm \ - language/cps/licm.scm \ - language/cps/peel-loops.scm \ - language/cps/primitives.scm \ - language/cps/prune-bailouts.scm \ - language/cps/prune-top-level-scopes.scm \ - language/cps/reify-primitives.scm \ - language/cps/renumber.scm \ - language/cps/rotate-loops.scm \ - language/cps/optimize.scm \ - language/cps/simplify.scm \ - language/cps/self-references.scm \ - language/cps/slot-allocation.scm \ - language/cps/spec.scm \ - language/cps/specialize-primcalls.scm \ - language/cps/split-rec.scm \ - language/cps/type-checks.scm \ - language/cps/type-fold.scm \ - language/cps/types.scm \ - language/cps/utils.scm \ - language/cps/verify.scm \ - language/cps/with-cps.scm - -BYTECODE_LANG_SOURCES = \ - language/bytecode.scm \ - language/bytecode/spec.scm - -VALUE_LANG_SOURCES = \ - language/value/spec.scm - -ECMASCRIPT_LANG_SOURCES = \ +SOURCES = \ + ice-9/and-let-star.scm \ + ice-9/binary-ports.scm \ + ice-9/boot-9.scm \ + ice-9/buffered-input.scm \ + ice-9/calling.scm \ + ice-9/channel.scm \ + ice-9/command-line.scm \ + ice-9/common-list.scm \ + ice-9/control.scm \ + ice-9/curried-definitions.scm \ + ice-9/debug.scm \ + ice-9/deprecated.scm \ + ice-9/documentation.scm \ + ice-9/eval-string.scm \ + ice-9/eval.scm \ + ice-9/expect.scm \ + ice-9/format.scm \ + ice-9/ftw.scm \ + ice-9/futures.scm \ + ice-9/gap-buffer.scm \ + ice-9/getopt-long.scm \ + ice-9/hash-table.scm \ + ice-9/hcons.scm \ + ice-9/history.scm \ + ice-9/i18n.scm \ + ice-9/iconv.scm \ + ice-9/lineio.scm \ + ice-9/list.scm \ + ice-9/local-eval.scm \ + ice-9/ls.scm \ + ice-9/mapping.scm \ + ice-9/match.scm \ + ice-9/networking.scm \ + ice-9/null.scm \ + ice-9/occam-channel.scm \ + ice-9/optargs.scm \ + ice-9/peg.scm \ + ice-9/peg/cache.scm \ + ice-9/peg/codegen.scm \ + ice-9/peg/simplify-tree.scm \ + ice-9/peg/string-peg.scm \ + ice-9/peg/using-parsers.scm \ + ice-9/poe.scm \ + ice-9/poll.scm \ + ice-9/popen.scm \ + ice-9/posix.scm \ + ice-9/pretty-print.scm \ + ice-9/psyntax-pp.scm \ + ice-9/q.scm \ + ice-9/r5rs.scm \ + ice-9/rdelim.scm \ + ice-9/receive.scm \ + ice-9/regex.scm \ + ice-9/runq.scm \ + ice-9/rw.scm \ + ice-9/safe-r5rs.scm \ + ice-9/safe.scm \ + ice-9/save-stack.scm \ + ice-9/scm-style-repl.scm \ + ice-9/serialize.scm \ + ice-9/session.scm \ + ice-9/slib.scm \ + ice-9/stack-catch.scm \ + ice-9/streams.scm \ + ice-9/string-fun.scm \ + ice-9/syncase.scm \ + ice-9/threads.scm \ + ice-9/time.scm \ + ice-9/top-repl.scm \ + ice-9/unicode.scm \ + ice-9/vlist.scm \ + ice-9/weak-vector.scm \ + \ + language/brainfuck/parse.scm \ + language/brainfuck/compile-scheme.scm \ + language/brainfuck/compile-tree-il.scm \ + language/brainfuck/spec.scm \ + \ + language/bytecode.scm \ + language/bytecode/spec.scm \ + \ + language/cps.scm \ + language/cps/closure-conversion.scm \ + language/cps/compile-bytecode.scm \ + language/cps/constructors.scm \ + language/cps/contification.scm \ + language/cps/cse.scm \ + language/cps/dce.scm \ + language/cps/effects-analysis.scm \ + language/cps/elide-values.scm \ + language/cps/intmap.scm \ + language/cps/intset.scm \ + language/cps/licm.scm \ + language/cps/optimize.scm \ + language/cps/peel-loops.scm \ + language/cps/primitives.scm \ + language/cps/prune-bailouts.scm \ + language/cps/prune-top-level-scopes.scm \ + language/cps/reify-primitives.scm \ + language/cps/renumber.scm \ + language/cps/rotate-loops.scm \ + language/cps/self-references.scm \ + language/cps/simplify.scm \ + language/cps/slot-allocation.scm \ + language/cps/spec.scm \ + language/cps/specialize-primcalls.scm \ + language/cps/split-rec.scm \ + language/cps/type-checks.scm \ + language/cps/type-fold.scm \ + language/cps/types.scm \ + language/cps/utils.scm \ + language/cps/verify.scm \ + language/cps/with-cps.scm \ + \ language/ecmascript/tokenize.scm \ language/ecmascript/parse.scm \ language/ecmascript/impl.scm \ @@ -166,9 +164,8 @@ ECMASCRIPT_LANG_SOURCES = \ language/ecmascript/function.scm \ language/ecmascript/array.scm \ language/ecmascript/compile-tree-il.scm \ - language/ecmascript/spec.scm - -ELISP_LANG_SOURCES = \ + language/ecmascript/spec.scm \ + \ language/elisp/falias.scm \ language/elisp/lexer.scm \ language/elisp/parser.scm \ @@ -177,157 +174,26 @@ ELISP_LANG_SOURCES = \ language/elisp/runtime.scm \ language/elisp/runtime/function-slot.scm \ language/elisp/runtime/value-slot.scm \ - language/elisp/spec.scm - -BRAINFUCK_LANG_SOURCES = \ - language/brainfuck/parse.scm \ - language/brainfuck/compile-scheme.scm \ - language/brainfuck/compile-tree-il.scm \ - language/brainfuck/spec.scm - -SCRIPTS_SOURCES = \ - scripts/compile.scm \ - scripts/disassemble.scm \ - scripts/display-commentary.scm \ - scripts/doc-snarf.scm \ - scripts/frisk.scm \ - scripts/generate-autoload.scm \ - scripts/help.scm \ - scripts/lint.scm \ - scripts/list.scm \ - scripts/punify.scm \ - scripts/read-scheme-source.scm \ - scripts/read-text-outline.scm \ - scripts/use2dot.scm \ - scripts/snarf-check-and-output-texi.scm \ - scripts/summarize-guile-TODO.scm \ - scripts/api-diff.scm \ - scripts/read-rfc822.scm \ - scripts/snarf-guile-m4-docs.scm \ - scripts/autofrisk.scm \ - scripts/scan-api.scm - -SYSTEM_BASE_SOURCES = \ - system/base/pmatch.scm \ - system/base/syntax.scm \ - system/base/compile.scm \ - system/base/language.scm \ - system/base/lalr.scm \ - system/base/message.scm \ - system/base/target.scm \ - system/base/types.scm \ - system/base/ck.scm - -ICE_9_SOURCES = \ - ice-9/r5rs.scm \ - ice-9/deprecated.scm \ - ice-9/and-let-star.scm \ - ice-9/binary-ports.scm \ - ice-9/calling.scm \ - ice-9/command-line.scm \ - ice-9/common-list.scm \ - ice-9/control.scm \ - ice-9/curried-definitions.scm \ - ice-9/debug.scm \ - ice-9/documentation.scm \ - ice-9/eval-string.scm \ - ice-9/expect.scm \ - ice-9/format.scm \ - ice-9/futures.scm \ - ice-9/getopt-long.scm \ - ice-9/hash-table.scm \ - ice-9/hcons.scm \ - ice-9/i18n.scm \ - ice-9/iconv.scm \ - ice-9/lineio.scm \ - ice-9/ls.scm \ - ice-9/mapping.scm \ - ice-9/match.scm \ - ice-9/networking.scm \ - ice-9/null.scm \ - ice-9/occam-channel.scm \ - ice-9/optargs.scm \ - ice-9/peg/simplify-tree.scm \ - ice-9/peg/codegen.scm \ - ice-9/peg/cache.scm \ - ice-9/peg/using-parsers.scm \ - ice-9/peg/string-peg.scm \ - ice-9/peg.scm \ - ice-9/poe.scm \ - ice-9/poll.scm \ - ice-9/popen.scm \ - ice-9/posix.scm \ - ice-9/q.scm \ - ice-9/rdelim.scm \ - ice-9/receive.scm \ - ice-9/regex.scm \ - ice-9/runq.scm \ - ice-9/rw.scm \ - ice-9/safe-r5rs.scm \ - ice-9/safe.scm \ - ice-9/save-stack.scm \ - ice-9/scm-style-repl.scm \ - ice-9/session.scm \ - ice-9/slib.scm \ - ice-9/stack-catch.scm \ - ice-9/streams.scm \ - ice-9/string-fun.scm \ - ice-9/syncase.scm \ - ice-9/threads.scm \ - ice-9/top-repl.scm \ - ice-9/buffered-input.scm \ - ice-9/time.scm \ - ice-9/history.scm \ - ice-9/channel.scm \ - ice-9/pretty-print.scm \ - ice-9/ftw.scm \ - ice-9/gap-buffer.scm \ - ice-9/weak-vector.scm \ - ice-9/list.scm \ - ice-9/serialize.scm \ - ice-9/local-eval.scm \ - ice-9/unicode.scm - -srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm - -SRFI_SOURCES = \ - srfi/srfi-2.scm \ - srfi/srfi-4.scm \ - srfi/srfi-4/gnu.scm \ - srfi/srfi-6.scm \ - srfi/srfi-8.scm \ - srfi/srfi-9.scm \ - srfi/srfi-9/gnu.scm \ - srfi/srfi-10.scm \ - srfi/srfi-11.scm \ - srfi/srfi-13.scm \ - srfi/srfi-14.scm \ - srfi/srfi-16.scm \ - srfi/srfi-17.scm \ - srfi/srfi-18.scm \ - srfi/srfi-19.scm \ - srfi/srfi-26.scm \ - srfi/srfi-27.scm \ - srfi/srfi-28.scm \ - srfi/srfi-31.scm \ - srfi/srfi-34.scm \ - srfi/srfi-35.scm \ - srfi/srfi-37.scm \ - srfi/srfi-38.scm \ - srfi/srfi-41.scm \ - srfi/srfi-42.scm \ - srfi/srfi-43.scm \ - srfi/srfi-39.scm \ - srfi/srfi-45.scm \ - srfi/srfi-60.scm \ - srfi/srfi-64.scm \ - srfi/srfi-67.scm \ - srfi/srfi-69.scm \ - srfi/srfi-88.scm \ - srfi/srfi-98.scm \ - srfi/srfi-111.scm - -RNRS_SOURCES = \ + language/elisp/spec.scm \ + \ + language/scheme/compile-tree-il.scm \ + language/scheme/decompile-tree-il.scm \ + language/scheme/spec.scm \ + \ + language/tree-il.scm \ + language/tree-il/analyze.scm \ + language/tree-il/canonicalize.scm \ + language/tree-il/compile-cps.scm \ + language/tree-il/debug.scm \ + language/tree-il/effects.scm \ + language/tree-il/fix-letrec.scm \ + language/tree-il/optimize.scm \ + language/tree-il/peval.scm \ + language/tree-il/primitives.scm \ + language/tree-il/spec.scm \ + \ + language/value/spec.scm \ + \ rnrs/base.scm \ rnrs/conditions.scm \ rnrs/control.scm \ @@ -353,47 +219,118 @@ RNRS_SOURCES = \ rnrs/records/inspection.scm \ rnrs/records/procedural.scm \ rnrs/records/syntactic.scm \ - rnrs.scm - -EXTRA_DIST += scripts/ChangeLog-2008 -EXTRA_DIST += scripts/README - -OOP_SOURCES = \ - oop/goops.scm \ - oop/goops/active-slot.scm \ - oop/goops/composite-slot.scm \ - oop/goops/describe.scm \ - oop/goops/internal.scm \ - oop/goops/save.scm \ - oop/goops/stklos.scm \ - oop/goops/accessors.scm \ - oop/goops/simple.scm - -SYSTEM_SOURCES = \ - system/vm/inspect.scm \ - system/vm/coverage.scm \ - system/vm/frame.scm \ - system/vm/loader.scm \ - system/vm/program.scm \ - system/vm/trace.scm \ - system/vm/traps.scm \ - system/vm/trap-state.scm \ - system/vm/debug.scm \ - system/vm/disassembler.scm \ - system/vm/vm.scm \ + rnrs.scm \ + \ + oop/goops.scm \ + oop/goops/active-slot.scm \ + oop/goops/composite-slot.scm \ + oop/goops/describe.scm \ + oop/goops/internal.scm \ + oop/goops/save.scm \ + oop/goops/stklos.scm \ + oop/goops/accessors.scm \ + oop/goops/simple.scm \ + \ + scripts/compile.scm \ + scripts/disassemble.scm \ + scripts/display-commentary.scm \ + scripts/doc-snarf.scm \ + scripts/frisk.scm \ + scripts/generate-autoload.scm \ + scripts/help.scm \ + scripts/lint.scm \ + scripts/list.scm \ + scripts/punify.scm \ + scripts/read-scheme-source.scm \ + scripts/read-text-outline.scm \ + scripts/use2dot.scm \ + scripts/snarf-check-and-output-texi.scm \ + scripts/summarize-guile-TODO.scm \ + scripts/api-diff.scm \ + scripts/read-rfc822.scm \ + scripts/snarf-guile-m4-docs.scm \ + scripts/autofrisk.scm \ + scripts/scan-api.scm \ + \ + srfi/srfi-1.scm \ + srfi/srfi-2.scm \ + srfi/srfi-4.scm \ + srfi/srfi-4/gnu.scm \ + srfi/srfi-6.scm \ + srfi/srfi-8.scm \ + srfi/srfi-9.scm \ + srfi/srfi-9/gnu.scm \ + srfi/srfi-10.scm \ + srfi/srfi-11.scm \ + srfi/srfi-13.scm \ + srfi/srfi-14.scm \ + srfi/srfi-16.scm \ + srfi/srfi-17.scm \ + srfi/srfi-18.scm \ + srfi/srfi-19.scm \ + srfi/srfi-26.scm \ + srfi/srfi-27.scm \ + srfi/srfi-28.scm \ + srfi/srfi-31.scm \ + srfi/srfi-34.scm \ + srfi/srfi-35.scm \ + srfi/srfi-37.scm \ + srfi/srfi-38.scm \ + srfi/srfi-41.scm \ + srfi/srfi-42.scm \ + srfi/srfi-43.scm \ + srfi/srfi-39.scm \ + srfi/srfi-45.scm \ + srfi/srfi-60.scm \ + srfi/srfi-64.scm \ + srfi/srfi-67.scm \ + srfi/srfi-69.scm \ + srfi/srfi-88.scm \ + srfi/srfi-98.scm \ + srfi/srfi-111.scm \ + \ + statprof.scm \ + \ + system/base/pmatch.scm \ + system/base/syntax.scm \ + system/base/compile.scm \ + system/base/language.scm \ + system/base/lalr.scm \ + system/base/message.scm \ + system/base/target.scm \ + system/base/types.scm \ + system/base/ck.scm \ + \ system/foreign.scm \ + \ system/foreign-object.scm \ - system/xref.scm \ + \ system/repl/debug.scm \ system/repl/error-handling.scm \ system/repl/common.scm \ system/repl/command.scm \ system/repl/repl.scm \ system/repl/server.scm \ - system/repl/coop-server.scm - -LIB_SOURCES = \ - statprof.scm \ + system/repl/coop-server.scm \ + \ + system/vm/assembler.scm \ + system/vm/coverage.scm \ + system/vm/debug.scm \ + system/vm/disassembler.scm \ + system/vm/dwarf.scm \ + system/vm/elf.scm \ + system/vm/frame.scm \ + system/vm/inspect.scm \ + system/vm/linker.scm \ + system/vm/loader.scm \ + system/vm/program.scm \ + system/vm/trace.scm \ + system/vm/trap-state.scm \ + system/vm/traps.scm \ + system/vm/vm.scm \ + \ + system/xref.scm \ + \ sxml/apply-templates.scm \ sxml/fold.scm \ sxml/match.scm \ @@ -402,6 +339,7 @@ LIB_SOURCES = \ sxml/ssax.scm \ sxml/transform.scm \ sxml/xpath.scm \ + \ texinfo.scm \ texinfo/docbook.scm \ texinfo/html.scm \ @@ -409,9 +347,8 @@ LIB_SOURCES = \ texinfo/string-utils.scm \ texinfo/plain-text.scm \ texinfo/reflection.scm \ - texinfo/serialize.scm - -WEB_SOURCES = \ + texinfo/serialize.scm \ + \ web/client.scm \ web/http.scm \ web/request.scm \ @@ -420,10 +357,8 @@ WEB_SOURCES = \ web/server/http.scm \ web/uri.scm -EXTRA_DIST += oop/ChangeLog-2008 - ELISP_SOURCES = \ - language/elisp/boot.el + language/elisp/boot.el NOCOMP_SOURCES = \ ice-9/match.upstream.scm \ @@ -441,3 +376,21 @@ NOCOMP_SOURCES = \ sxml/upstream/SXPath-old.scm \ sxml/upstream/assert.scm \ sxml/upstream/input-parse.scm + +## ice-9/test.scm is not currently installed. +EXTRA_DIST += \ + ice-9/test.scm \ + ice-9/compile-psyntax.scm \ + ice-9/ChangeLog-2008 \ + scripts/ChangeLog-2008 \ + scripts/README \ + oop/ChangeLog-2008 + +ETAGS_ARGS += \ + ice-9/test.scm \ + ice-9/compile-psyntax.scm + +ice-9/psyntax-pp.scm.gen: + $(top_builddir_absolute)/meta/guile --no-auto-compile -s $(srcdir)/ice-9/compile-psyntax.scm \ + $(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm +.PHONY: ice-9/psyntax-pp.scm.gen From 1c9e23c0901363ff24c1dc4e085e7ed68cb81e6d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 23 Oct 2015 16:38:49 +0200 Subject: [PATCH 070/865] Bootstrap makefile tweaks * bootstrap/Makefile.am (.scm.go): Fix -L options to point to /module. (SOURCES): Move up psyntax-pp.scm. Sadly a bug while I was developing the bootstrap makefile meant that there was a stale psyntax-pp.go from module/ that the build was picking up, leading to invalid bootstrap timing measurements. --- bootstrap/Makefile.am | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/bootstrap/Makefile.am b/bootstrap/Makefile.am index 4f0bfac40..441b72738 100644 --- a/bootstrap/Makefile.am +++ b/bootstrap/Makefile.am @@ -27,7 +27,12 @@ GUILE_OPTIMIZATIONS = -O1 nobase_noinst_DATA = $(GOBJECTS) ice-9/eval.go CLEANFILES = $(GOBJECTS) ice-9/eval.go -$(GOBJECTS): ice-9/eval.go +# We must build the evaluator first, so that we can be sure to control +# the stack. Then we really need to build the expander before other +# things, otherwise the compile time for everything else is dominated by +# the expander. +ice-9/psyntax-pp.go: ice-9/eval.go +$(GOBJECTS): ice-9/psyntax-pp.go VM_TARGETS := system/vm/assembler.go system/vm/disassembler.go $(VM_TARGETS): $(top_builddir)/libguile/vm-operations.h @@ -45,7 +50,7 @@ SUFFIXES = .scm .go $(top_builddir)/meta/uninstalled-env \ guild compile --target="$(host)" \ $(GUILE_WARNINGS) $(GUILE_OPTIMIZATIONS) \ - -L "$(abs_srcdir)" -L "$(abs_builddir)" \ + -L "$(abs_top_srcdir)/module" \ -L "$(abs_top_srcdir)/guile-readline" \ -o "$@" "$<" @@ -120,7 +125,6 @@ SOURCES = \ system/base/types.scm \ system/base/ck.scm \ \ - ice-9/psyntax-pp.scm \ ice-9/boot-9.scm \ ice-9/r5rs.scm \ ice-9/deprecated.scm \ From 95ac2204d9084a01677fff9eb2669c495bd07d3d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 25 Oct 2015 10:49:41 +0000 Subject: [PATCH 071/865] Revert "Update Gnulib to v0.1-603-g1d16a7b" This reverts commit 2d4da30fdefbcdb065d4b1f48f2a77d06f69e3c3. This Gnulib update was causing failures related to timezones in stime.c. I tried to fix it by adopting the time_rz module from gnulib but that then caused other failures. We can try again later. --- GNUmakefile | 2 +- build-aux/announce-gen | 24 +- build-aux/config.rpath | 18 +- build-aux/gendocs.sh | 115 ++- build-aux/git-version-gen | 11 +- build-aux/gitlog-to-changelog | 176 ++--- build-aux/gnu-web-doc-update | 19 +- build-aux/gnupload | 2 +- build-aux/snippet/arg-nonnull.h | 2 +- build-aux/snippet/c++defs.h | 2 +- build-aux/snippet/unused-parameter.h | 2 +- build-aux/snippet/warn-on-use.h | 2 +- build-aux/useless-if-before-free | 2 +- build-aux/vc-list-files | 2 +- doc/gendocs_template | 20 +- gnulib-local/build-aux/git-version-gen.diff | 14 +- lib/Makefile.am | 75 +- lib/accept.c | 2 +- lib/alignof.h | 2 +- lib/alloca.in.h | 2 +- lib/arpa_inet.in.h | 2 +- lib/asnprintf.c | 2 +- lib/assure.h | 37 - lib/basename-lgpl.c | 2 +- lib/binary-io.c | 1 - lib/binary-io.h | 2 +- lib/bind.c | 2 +- lib/btowc.c | 2 +- lib/byteswap.in.h | 2 +- lib/c-ctype.c | 394 ++++++++++- lib/c-ctype.h | 453 +++++------- lib/c-strcase.h | 2 +- lib/c-strcasecmp.c | 2 +- lib/c-strcaseeq.h | 5 +- lib/c-strncasecmp.c | 2 +- lib/canonicalize-lgpl.c | 2 +- lib/ceil.c | 2 +- lib/close.c | 2 +- lib/config.charset | 6 +- lib/connect.c | 2 +- lib/copysign.c | 2 +- lib/dirent.in.h | 4 +- lib/dirfd.c | 2 +- lib/dirname-lgpl.c | 2 +- lib/dirname.h | 10 +- lib/dosname.h | 2 +- lib/dup2.c | 2 +- lib/duplocale.c | 2 +- lib/errno.in.h | 2 +- lib/fcntl.in.h | 22 +- lib/fd-hook.c | 2 +- lib/fd-hook.h | 2 +- lib/float+.h | 2 +- lib/float.c | 2 +- lib/float.in.h | 2 +- lib/flock.c | 2 +- lib/floor.c | 2 +- lib/frexp.c | 2 +- lib/fstat.c | 2 +- lib/fsync.c | 2 +- lib/full-read.c | 2 +- lib/full-read.h | 3 +- lib/full-write.c | 2 +- lib/full-write.h | 2 +- lib/gai_strerror.c | 2 +- lib/getaddrinfo.c | 2 +- lib/getlogin.c | 2 +- lib/getpeername.c | 2 +- lib/getsockname.c | 2 +- lib/getsockopt.c | 2 +- lib/gettext.h | 2 +- lib/gettimeofday.c | 2 +- lib/glthread/lock.h | 2 +- lib/iconv.c | 2 +- lib/iconv.in.h | 2 +- lib/iconv_close.c | 2 +- lib/iconv_open-aix.h | 2 +- lib/iconv_open-hpux.h | 4 +- lib/iconv_open-irix.h | 4 +- lib/iconv_open-osf.h | 4 +- lib/iconv_open.c | 2 +- lib/iconveh.h | 2 +- lib/ignore-value.h | 37 + lib/inet_ntop.c | 2 +- lib/inet_pton.c | 2 +- lib/isfinite.c | 2 +- lib/isinf.c | 2 +- lib/isnan.c | 2 +- lib/isnand-nolibm.h | 2 +- lib/isnand.c | 2 +- lib/isnanf-nolibm.h | 2 +- lib/isnanf.c | 2 +- lib/isnanl-nolibm.h | 2 +- lib/isnanl.c | 2 +- lib/itold.c | 2 +- lib/langinfo.in.h | 20 +- lib/link.c | 2 +- lib/listen.c | 2 +- lib/localcharset.c | 81 +-- lib/localcharset.h | 2 +- lib/locale.in.h | 2 +- lib/localeconv.c | 2 +- lib/log.c | 2 +- lib/log1p.c | 2 +- lib/lstat.c | 2 +- lib/malloc.c | 2 +- lib/malloca.c | 2 +- lib/malloca.h | 2 +- lib/math.c | 1 - lib/math.in.h | 2 +- lib/mbrtowc.c | 9 +- lib/mbsinit.c | 2 +- lib/mbtowc-impl.h | 2 +- lib/mbtowc.c | 2 +- lib/memchr.c | 2 +- lib/mkdir.c | 2 +- lib/mkstemp.c | 2 +- lib/mktime-internal.h | 4 - lib/mktime.c | 741 -------------------- lib/msvc-inval.c | 2 +- lib/msvc-inval.h | 2 +- lib/msvc-nothrow.c | 2 +- lib/msvc-nothrow.h | 2 +- lib/netdb.in.h | 2 +- lib/netinet_in.in.h | 2 +- lib/nl_langinfo.c | 255 +++---- lib/nproc.c | 2 +- lib/nproc.h | 2 +- lib/open.c | 2 +- lib/pathmax.h | 2 +- lib/pipe.c | 2 +- lib/pipe2.c | 2 +- lib/poll.c | 83 ++- lib/poll.in.h | 2 +- lib/printf-args.c | 2 +- lib/printf-args.h | 2 +- lib/printf-parse.c | 2 +- lib/printf-parse.h | 2 +- lib/putenv.c | 2 +- lib/raise.c | 2 +- lib/read.c | 2 +- lib/readlink.c | 2 +- lib/recv.c | 2 +- lib/recvfrom.c | 2 +- lib/ref-add.sin | 2 +- lib/ref-del.sin | 2 +- lib/regcomp.c | 44 +- lib/regex.c | 2 +- lib/regex.h | 19 +- lib/regex_internal.c | 23 +- lib/regex_internal.h | 35 +- lib/regexec.c | 10 +- lib/rename.c | 8 +- lib/rmdir.c | 2 +- lib/round.c | 2 +- lib/safe-read.c | 2 +- lib/safe-read.h | 2 +- lib/safe-write.c | 2 +- lib/safe-write.h | 2 +- lib/same-inode.h | 2 +- lib/secure_getenv.c | 2 +- lib/select.c | 38 +- lib/send.c | 2 +- lib/sendto.c | 2 +- lib/setenv.c | 2 +- lib/setsockopt.c | 2 +- lib/shutdown.c | 2 +- lib/signal.in.h | 10 +- lib/signbitd.c | 2 +- lib/signbitf.c | 2 +- lib/signbitl.c | 2 +- lib/size_max.h | 2 +- lib/snprintf.c | 2 +- lib/socket.c | 2 +- lib/sockets.c | 9 +- lib/sockets.h | 12 +- lib/stat-time.h | 18 +- lib/stat.c | 2 +- lib/stdalign.in.h | 21 +- lib/stdbool.in.h | 2 +- lib/stddef.in.h | 54 +- lib/stdint.in.h | 5 +- lib/stdio.in.h | 12 +- lib/stdlib.in.h | 25 +- lib/strdup.c | 2 +- lib/streq.h | 2 +- lib/strftime.c | 122 ++-- lib/strftime.h | 9 +- lib/striconveh.c | 2 +- lib/striconveh.h | 2 +- lib/string.in.h | 23 +- lib/stripslash.c | 2 +- lib/sys_file.in.h | 2 +- lib/sys_select.in.h | 17 +- lib/sys_socket.c | 1 - lib/sys_socket.in.h | 2 +- lib/sys_stat.in.h | 2 +- lib/sys_time.in.h | 2 +- lib/sys_times.in.h | 2 +- lib/sys_types.in.h | 4 +- lib/sys_uio.in.h | 2 +- lib/tempname.c | 120 ++-- lib/tempname.h | 17 +- lib/time-internal.h | 49 -- lib/time.in.h | 31 +- lib/time_r.c | 2 +- lib/time_rz.c | 323 --------- lib/timegm.c | 38 - lib/times.c | 4 +- lib/trunc.c | 2 +- lib/unistd.c | 1 - lib/unistd.in.h | 39 +- lib/unistr.in.h | 2 +- lib/unistr/u8-mbtouc-aux.c | 2 +- lib/unistr/u8-mbtouc-unsafe-aux.c | 2 +- lib/unistr/u8-mbtouc-unsafe.c | 2 +- lib/unistr/u8-mbtouc.c | 2 +- lib/unistr/u8-mbtoucr.c | 2 +- lib/unistr/u8-prev.c | 2 +- lib/unistr/u8-uctomb-aux.c | 2 +- lib/unistr/u8-uctomb.c | 2 +- lib/unitypes.in.h | 2 +- lib/unsetenv.c | 127 ---- lib/vasnprintf.c | 199 +++--- lib/vasnprintf.h | 2 +- lib/verify.h | 2 +- lib/vsnprintf.c | 2 +- lib/w32sock.h | 2 +- lib/wchar.in.h | 11 +- lib/wcrtomb.c | 2 +- lib/wctype.in.h | 2 +- lib/write.c | 2 +- lib/xsize.h | 2 +- m4/00gnulib.m4 | 2 +- m4/absolute-header.m4 | 2 +- m4/alloca.m4 | 2 +- m4/arpa_inet_h.m4 | 2 +- m4/autobuild.m4 | 2 +- m4/btowc.m4 | 2 +- m4/byteswap.m4 | 2 +- m4/canonicalize.m4 | 2 +- m4/ceil.m4 | 2 +- m4/check-math-lib.m4 | 2 +- m4/clock_time.m4 | 2 +- m4/close.m4 | 2 +- m4/configmake.m4 | 2 +- m4/copysign.m4 | 2 +- m4/dirent_h.m4 | 2 +- m4/dirfd.m4 | 2 +- m4/dirname.m4 | 2 +- m4/double-slash-root.m4 | 2 +- m4/dup2.m4 | 84 +-- m4/duplocale.m4 | 2 +- m4/eealloc.m4 | 2 +- m4/environ.m4 | 2 +- m4/errno_h.m4 | 2 +- m4/exponentd.m4 | 2 +- m4/exponentf.m4 | 2 +- m4/exponentl.m4 | 2 +- m4/extensions.m4 | 7 +- m4/extern-inline.m4 | 45 +- m4/fcntl-o.m4 | 2 +- m4/fcntl_h.m4 | 2 +- m4/flexmember.m4 | 41 -- m4/float_h.m4 | 2 +- m4/flock.m4 | 2 +- m4/floor.m4 | 2 +- m4/fpieee.m4 | 4 +- m4/frexp.m4 | 2 +- m4/fstat.m4 | 2 +- m4/fsync.m4 | 2 +- m4/func.m4 | 2 +- m4/getaddrinfo.m4 | 2 +- m4/getlogin.m4 | 2 +- m4/gettimeofday.m4 | 2 +- m4/glibc21.m4 | 2 +- m4/gnulib-cache.m4 | 5 +- m4/gnulib-common.m4 | 105 ++- m4/gnulib-comp.m4 | 65 +- m4/gnulib-tool.m4 | 2 +- m4/hostent.m4 | 2 +- m4/iconv.m4 | 61 +- m4/iconv_h.m4 | 2 +- m4/iconv_open-utf.m4 | 2 +- m4/iconv_open.m4 | 2 +- m4/include_next.m4 | 2 +- m4/inet_ntop.m4 | 2 +- m4/inet_pton.m4 | 2 +- m4/inline.m4 | 2 +- m4/intmax_t.m4 | 2 +- m4/inttypes_h.m4 | 2 +- m4/isfinite.m4 | 40 +- m4/isinf.m4 | 43 +- m4/isnan.m4 | 2 +- m4/isnand.m4 | 2 +- m4/isnanf.m4 | 2 +- m4/isnanl.m4 | 43 +- m4/langinfo_h.m4 | 2 +- m4/largefile.m4 | 2 +- m4/ld-version-script.m4 | 47 +- m4/ldexp.m4 | 2 +- m4/lib-ld.m4 | 2 +- m4/lib-link.m4 | 2 +- m4/lib-prefix.m4 | 2 +- m4/libunistring-base.m4 | 2 +- m4/libunistring.m4 | 2 +- m4/link.m4 | 2 +- m4/localcharset.m4 | 2 +- m4/locale-fr.m4 | 2 +- m4/locale-ja.m4 | 2 +- m4/locale-zh.m4 | 2 +- m4/locale_h.m4 | 2 +- m4/localeconv.m4 | 2 +- m4/log.m4 | 2 +- m4/log1p.m4 | 2 +- m4/longlong.m4 | 2 +- m4/lstat.m4 | 50 +- m4/malloc.m4 | 2 +- m4/malloca.m4 | 2 +- m4/math_h.m4 | 2 +- m4/mathfunc.m4 | 2 +- m4/mbrtowc.m4 | 48 +- m4/mbsinit.m4 | 2 +- m4/mbstate_t.m4 | 2 +- m4/mbtowc.m4 | 2 +- m4/memchr.m4 | 2 +- m4/mkdir.m4 | 2 +- m4/mkstemp.m4 | 2 +- m4/mktime.m4 | 253 ------- m4/mmap-anon.m4 | 2 +- m4/mode_t.m4 | 2 +- m4/msvc-inval.m4 | 2 +- m4/msvc-nothrow.m4 | 2 +- m4/multiarch.m4 | 2 +- m4/netdb_h.m4 | 2 +- m4/netinet_in_h.m4 | 2 +- m4/nl_langinfo.m4 | 2 +- m4/nocrash.m4 | 2 +- m4/nproc.m4 | 2 +- m4/off_t.m4 | 2 +- m4/open.m4 | 2 +- m4/pathmax.m4 | 2 +- m4/pipe.m4 | 2 +- m4/pipe2.m4 | 2 +- m4/poll.m4 | 2 +- m4/poll_h.m4 | 2 +- m4/printf.m4 | 67 +- m4/putenv.m4 | 2 +- m4/raise.m4 | 2 +- m4/read.m4 | 2 +- m4/readlink.m4 | 2 +- m4/regex.m4 | 2 +- m4/rename.m4 | 2 +- m4/rmdir.m4 | 2 +- m4/round.m4 | 2 +- m4/safe-read.m4 | 2 +- m4/safe-write.m4 | 2 +- m4/secure_getenv.m4 | 2 +- m4/select.m4 | 2 +- m4/servent.m4 | 2 +- m4/setenv.m4 | 2 +- m4/signal_h.m4 | 2 +- m4/signbit.m4 | 2 +- m4/size_max.m4 | 2 +- m4/snprintf.m4 | 2 +- m4/socketlib.m4 | 2 +- m4/sockets.m4 | 2 +- m4/socklen.m4 | 2 +- m4/sockpfaf.m4 | 2 +- m4/ssize_t.m4 | 2 +- m4/stat-time.m4 | 2 +- m4/stat.m4 | 2 +- m4/stdalign.m4 | 10 +- m4/stdbool.m4 | 2 +- m4/stddef_h.m4 | 10 +- m4/stdint.m4 | 2 +- m4/stdint_h.m4 | 2 +- m4/stdio_h.m4 | 31 +- m4/stdlib_h.m4 | 4 +- m4/strdup.m4 | 2 +- m4/strftime.m4 | 2 +- m4/string_h.m4 | 2 +- m4/sys_file_h.m4 | 2 +- m4/sys_select_h.m4 | 2 +- m4/sys_socket_h.m4 | 2 +- m4/sys_stat_h.m4 | 2 +- m4/sys_time_h.m4 | 3 +- m4/sys_times_h.m4 | 2 +- m4/sys_types_h.m4 | 2 +- m4/sys_uio_h.m4 | 2 +- m4/tempname.m4 | 2 +- m4/time_h.m4 | 22 +- m4/time_r.m4 | 2 +- m4/time_rz.m4 | 21 - m4/timegm.m4 | 26 - m4/times.m4 | 2 +- m4/tm_gmtoff.m4 | 2 +- m4/trunc.m4 | 2 +- m4/unistd_h.m4 | 6 +- m4/vasnprintf.m4 | 2 +- m4/visibility.m4 | 2 +- m4/vsnprintf.m4 | 2 +- m4/warn-on-use.m4 | 2 +- m4/warnings.m4 | 2 +- m4/wchar_h.m4 | 2 +- m4/wchar_t.m4 | 2 +- m4/wcrtomb.m4 | 2 +- m4/wctype_h.m4 | 2 +- m4/wint_t.m4 | 2 +- m4/write.m4 | 2 +- m4/xsize.m4 | 2 +- maint.mk | 48 +- 412 files changed, 1998 insertions(+), 3959 deletions(-) delete mode 100644 lib/assure.h create mode 100644 lib/ignore-value.h delete mode 100644 lib/mktime-internal.h delete mode 100644 lib/mktime.c delete mode 100644 lib/time-internal.h delete mode 100644 lib/time_rz.c delete mode 100644 lib/timegm.c delete mode 100644 lib/unsetenv.c delete mode 100644 m4/flexmember.m4 delete mode 100644 m4/mktime.m4 delete mode 100644 m4/time_rz.m4 delete mode 100644 m4/timegm.m4 diff --git a/GNUmakefile b/GNUmakefile index 6617eec2e..4ab642943 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -5,7 +5,7 @@ # It is necessary if you want to build targets usually of interest # only to the maintainer. -# Copyright (C) 2001, 2003, 2006-2015 Free Software Foundation, Inc. +# Copyright (C) 2001, 2003, 2006-2014 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/build-aux/announce-gen b/build-aux/announce-gen index 8a6edb5d4..db9ed50a7 100755 --- a/build-aux/announce-gen +++ b/build-aux/announce-gen @@ -3,13 +3,13 @@ eval '(exit $?0)' && eval 'exec perl -wS "$0" ${1+"$@"}' if 0; # Generate a release announcement message. -my $VERSION = '2013-07-09 06:39'; # UTC +my $VERSION = '2012-06-08 06:53'; # UTC # The definition above must lie within the first 8 lines in order # for the Emacs time-stamp write hook (at end) to update it. # If you change this file with Emacs, please let the write hook # do its job. Otherwise, update this string manually. -# Copyright (C) 2002-2015 Free Software Foundation, Inc. +# Copyright (C) 2002-2014 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -29,18 +29,15 @@ my $VERSION = '2013-07-09 06:39'; # UTC use strict; use Getopt::Long; +use Digest::MD5; +eval { require Digest::SHA; } + or eval 'use Digest::SHA1'; use POSIX qw(strftime); (my $ME = $0) =~ s|.*/||; my %valid_release_types = map {$_ => 1} qw (alpha beta stable); my @archive_suffixes = ('tar.gz', 'tar.bz2', 'tar.lzma', 'tar.xz'); -my %digest_classes = - ( - 'md5' => (eval { require Digest::MD5; } and 'Digest::MD5'), - 'sha1' => ((eval { require Digest::SHA; } and 'Digest::SHA') - or (eval { require Digest::SHA1; } and 'Digest::SHA1')) - ); my $srcdir = '.'; sub usage ($) @@ -160,13 +157,15 @@ sub print_checksums (@) foreach my $meth (qw (md5 sha1)) { - my $class = $digest_classes{$meth} or next; foreach my $f (@file) { open IN, '<', $f or die "$ME: $f: cannot open for reading: $!\n"; binmode IN; - my $dig = $class->new->addfile(*IN)->hexdigest; + my $dig = + ($meth eq 'md5' + ? Digest::MD5->new->addfile(*IN)->hexdigest + : Digest::SHA1->new->addfile(*IN)->hexdigest); close IN; print "$dig $f\n"; } @@ -417,15 +416,14 @@ sub get_tool_versions ($$) @url_dir_list or (warn "URL directory name(s) not specified\n"), $fail = 1; - my @tool_list = split ',', $bootstrap_tools - if $bootstrap_tools; + my @tool_list = split ',', $bootstrap_tools; grep (/^gnulib$/, @tool_list) ^ defined $gnulib_version and (warn "when specifying gnulib as a tool, you must also specify\n" . "--gnulib-version=V, where V is the result of running git describe\n" . "in the gnulib source directory.\n"), $fail = 1; - !$release_type || exists $valid_release_types{$release_type} + exists $valid_release_types{$release_type} or (warn "'$release_type': invalid release type\n"), $fail = 1; @ARGV diff --git a/build-aux/config.rpath b/build-aux/config.rpath index a3e25c844..ab6fd995f 100755 --- a/build-aux/config.rpath +++ b/build-aux/config.rpath @@ -2,7 +2,7 @@ # Output a system dependent set of variables, describing how to set the # run time search path of shared libraries in an executable. # -# Copyright 1996-2015 Free Software Foundation, Inc. +# Copyright 1996-2014 Free Software Foundation, Inc. # Taken from GNU libtool, 2001 # Originally by Gordon Matzigkeit , 1996 # @@ -367,7 +367,11 @@ else dgux*) hardcode_libdir_flag_spec='-L$libdir' ;; - freebsd2.[01]*) + freebsd2.2*) + hardcode_libdir_flag_spec='-R$libdir' + hardcode_direct=yes + ;; + freebsd2*) hardcode_direct=yes hardcode_minus_L=yes ;; @@ -544,11 +548,13 @@ case "$host_os" in dgux*) library_names_spec='$libname$shrext' ;; - freebsd[23].*) - library_names_spec='$libname$shrext$versuffix' - ;; freebsd* | dragonfly*) - library_names_spec='$libname$shrext' + case "$host_os" in + freebsd[123]*) + library_names_spec='$libname$shrext$versuffix' ;; + *) + library_names_spec='$libname$shrext' ;; + esac ;; gnu*) library_names_spec='$libname$shrext' diff --git a/build-aux/gendocs.sh b/build-aux/gendocs.sh index c8ca1bbc4..f9ec9df76 100755 --- a/build-aux/gendocs.sh +++ b/build-aux/gendocs.sh @@ -2,9 +2,10 @@ # gendocs.sh -- generate a GNU manual in many formats. This script is # mentioned in maintain.texi. See the help message below for usage details. -scriptversion=2015-05-05.16 +scriptversion=2013-10-10.09 -# Copyright 2003-2015 Free Software Foundation, Inc. +# Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 +# Free Software Foundation, Inc. # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -20,16 +21,17 @@ scriptversion=2015-05-05.16 # along with this program. If not, see . # # Original author: Mohit Agarwal. -# Send bug reports and any other correspondence to bug-gnulib@gnu.org. +# Send bug reports and any other correspondence to bug-texinfo@gnu.org. # # The latest version of this script, and the companion template, is -# available from the Gnulib repository: +# available from Texinfo CVS: +# http://savannah.gnu.org/cgi-bin/viewcvs/texinfo/texinfo/util/gendocs.sh +# http://savannah.gnu.org/cgi-bin/viewcvs/texinfo/texinfo/util/gendocs_template # -# http://git.savannah.gnu.org/cgit/gnulib.git/tree/build-aux/gendocs.sh -# http://git.savannah.gnu.org/cgit/gnulib.git/tree/doc/gendocs_template +# An up-to-date copy is also maintained in Gnulib (gnu.org/software/gnulib). # TODO: -# - image importing was only implemented for HTML generated by +# - image importation was only implemented for HTML generated by # makeinfo. But it should be simple enough to adjust. # - images are not imported in the source tarball. All the needed # formats (PDF, PNG, etc.) should be included. @@ -37,12 +39,12 @@ scriptversion=2015-05-05.16 prog=`basename "$0"` srcdir=`pwd` -scripturl="http://git.savannah.gnu.org/cgit/gnulib.git/plain/build-aux/gendocs.sh" -templateurl="http://git.savannah.gnu.org/cgit/gnulib.git/plain/doc/gendocs_template" +scripturl="http://savannah.gnu.org/cgi-bin/viewcvs/~checkout~/texinfo/texinfo/util/gendocs.sh" +templateurl="http://savannah.gnu.org/cgi-bin/viewcvs/~checkout~/texinfo/texinfo/util/gendocs_template" : ${SETLANG="env LANG= LC_MESSAGES= LC_ALL= LANGUAGE="} : ${MAKEINFO="makeinfo"} -: ${TEXI2DVI="texi2dvi"} +: ${TEXI2DVI="texi2dvi -t @finalout"} : ${DOCBOOK2HTML="docbook2html"} : ${DOCBOOK2PDF="docbook2pdf"} : ${DOCBOOK2TXT="docbook2txt"} @@ -54,7 +56,7 @@ unset use_texi2html version="gendocs.sh $scriptversion -Copyright 2015 Free Software Foundation, Inc. +Copyright 2013 Free Software Foundation, Inc. There is NO warranty. You may redistribute this software under the terms of the GNU General Public License. For more information about these matters, see the files named COPYING." @@ -73,16 +75,11 @@ Options: -o OUTDIR write files into OUTDIR, instead of manual/. -I DIR append DIR to the Texinfo search path. --common ARG pass ARG in all invocations. - --html ARG pass ARG to makeinfo or texi2html for HTML targets, - instead of --css-ref=/software/gnulib/manual.css. + --html ARG pass ARG to makeinfo or texi2html for HTML targets. --info ARG pass ARG to makeinfo for Info, instead of --no-split. --no-ascii skip generating the plain text output. - --no-html skip generating the html output. - --no-info skip generating the info output. - --no-tex skip generating the dvi and pdf output. --source ARG include ARG in tar archive of sources. --split HOW make split HTML by node, section, chapter; default node. - --tex ARG pass ARG to texi2dvi for DVI and PDF, instead of -t @finalout. --texi2html use texi2html to make HTML target, with all split versions. --docbook convert through DocBook too (xml, txt, html, pdf). @@ -134,7 +131,7 @@ locale, since that's the language of most Texinfo manuals. If you happen to have a non-English manual and non-English web site, see the SETLANG setting in the source. -Email bug reports or enhancement requests to bug-gnulib@gnu.org. +Email bug reports or enhancement requests to bug-texinfo@gnu.org. " MANUAL_TITLE= @@ -142,18 +139,14 @@ PACKAGE= EMAIL=webmasters@gnu.org # please override with --email commonarg= # passed to all makeinfo/texi2html invcations. dirargs= # passed to all tools (-I dir). -dirs= # -I directories. -htmlarg=--css-ref=/software/gnulib/manual.css +dirs= # -I's directories. +htmlarg= infoarg=--no-split generate_ascii=true -generate_html=true -generate_info=true -generate_tex=true outdir=manual source_extra= split=node srcfile= -texarg="-t @finalout" while test $# -gt 0; do case $1 in @@ -166,12 +159,8 @@ while test $# -gt 0; do --html) shift; htmlarg=$1;; --info) shift; infoarg=$1;; --no-ascii) generate_ascii=false;; - --no-html) generate_ascii=false;; - --no-info) generate_info=false;; - --no-tex) generate_tex=false;; --source) shift; source_extra=$1;; --split) shift; split=$1;; - --tex) shift; texarg=$1;; --texi2html) use_texi2html=1;; --help) echo "$usage"; exit 0;; @@ -232,9 +221,8 @@ calcsize() # copy_images OUTDIR HTML-FILE... # ------------------------------- -# Copy all the images needed by the HTML-FILEs into OUTDIR. -# Look for them in . and the -I directories; this is simpler than what -# makeinfo supports with -I, but hopefully it will suffice. +# Copy all the images needed by the HTML-FILEs into OUTDIR. Look +# for them in the -I directories. copy_images() { local odir @@ -244,7 +232,7 @@ copy_images() BEGIN { \$me = '$prog'; \$odir = '$odir'; - @dirs = qw(. $dirs); + @dirs = qw($dirs); } " -e ' /${srcdir}/$PACKAGE-db.xml" @@ -457,8 +431,7 @@ if test -n "$docbook"; then mv $PACKAGE-db.pdf "$outdir/" fi -# -printf "\nMaking index.html for $PACKAGE...\n" +printf "\nMaking index file...\n" if test -z "$use_texi2html"; then CONDS="/%%IF *HTML_SECTION%%/,/%%ENDIF *HTML_SECTION%%/d;\ /%%IF *HTML_CHAPTER%%/,/%%ENDIF *HTML_CHAPTER%%/d" diff --git a/build-aux/git-version-gen b/build-aux/git-version-gen index 8e185a9d1..1e5d556e9 100755 --- a/build-aux/git-version-gen +++ b/build-aux/git-version-gen @@ -1,8 +1,8 @@ #!/bin/sh # Print a version string. -scriptversion=2014-12-02.19; # UTC +scriptversion=2012-12-31.23; # UTC -# Copyright (C) 2007-2015 Free Software Foundation, Inc. +# Copyright (C) 2007-2014 Free Software Foundation, Inc. # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -85,10 +85,9 @@ Print a version string. Options: - --prefix PREFIX prefix of git tags (default 'v') + --prefix prefix of git tags (default 'v') --match pattern for git tags to match (default: '\$prefix*') - --fallback VERSION - fallback version to use if \"git --version\" fails + --fallback fallback version to use if \"git --version\" fails --help display this help and exit --version output version information and exit @@ -221,7 +220,7 @@ if test "x$v_from_git" != x; then fi # Omit the trailing newline, so that m4_esyscmd can use the result directly. -printf %s "$v" +echo "$v" | tr -d "$nl" # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) diff --git a/build-aux/gitlog-to-changelog b/build-aux/gitlog-to-changelog index a0e0a05df..78afff4e8 100755 --- a/build-aux/gitlog-to-changelog +++ b/build-aux/gitlog-to-changelog @@ -3,13 +3,13 @@ eval '(exit $?0)' && eval 'exec perl -wS "$0" ${1+"$@"}' if 0; # Convert git log output to ChangeLog format. -my $VERSION = '2015-06-11 01:03'; # UTC +my $VERSION = '2012-07-29 06:11'; # UTC # The definition above must lie within the first 8 lines in order # for the Emacs time-stamp write hook (at end) to update it. # If you change this file with Emacs, please let the write hook # do its job. Otherwise, update this string manually. -# Copyright (C) 2008-2015 Free Software Foundation, Inc. +# Copyright (C) 2008-2014 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -72,9 +72,6 @@ OPTIONS: directory can be derived. --since=DATE convert only the logs since DATE; the default is to convert all log entries. - --until=DATE convert only the logs older than DATE. - --ignore-matching=PAT ignore commit messages whose first lines match PAT. - --ignore-line=PAT ignore lines of commit messages that match PAT. --format=FMT set format string for commit subject and body; see 'man git-log' for the list of format metacharacters; the default is '%s%n%b%n' @@ -223,13 +220,10 @@ sub git_dir_option($) { my $since_date; - my $until_date; my $format_string = '%s%n%b%n'; my $amend_file; my $append_dot = 0; my $cluster = 1; - my $ignore_matching; - my $ignore_line; my $strip_tab = 0; my $strip_cherry_pick = 0; my $srcdir; @@ -238,13 +232,10 @@ sub git_dir_option($) help => sub { usage 0 }, version => sub { print "$ME version $VERSION\n"; exit }, 'since=s' => \$since_date, - 'until=s' => \$until_date, 'format=s' => \$format_string, 'amend=s' => \$amend_file, 'append-dot' => \$append_dot, 'cluster!' => \$cluster, - 'ignore-matching=s' => \$ignore_matching, - 'ignore-line=s' => \$ignore_line, 'strip-tab' => \$strip_tab, 'strip-cherry-pick' => \$strip_cherry_pick, 'srcdir=s' => \$srcdir, @@ -252,8 +243,6 @@ sub git_dir_option($) defined $since_date and unshift @ARGV, "--since=$since_date"; - defined $until_date - and unshift @ARGV, "--until=$until_date"; # This is a hash that maps an SHA1 to perl code (i.e., s/old/new/) # that makes a correction in the log or attribution of that commit. @@ -270,7 +259,6 @@ sub git_dir_option($) my $prev_multi_paragraph; my $prev_date_line = ''; my @prev_coauthors = (); - my @skipshas = (); while (1) { defined (my $in = ) @@ -291,21 +279,6 @@ sub git_dir_option($) $sha =~ /^[0-9a-fA-F]{40}$/ or die "$ME:$.: invalid SHA1: $sha\n"; - my $skipflag = 0; - if (@skipshas) - { - foreach(@skipshas) - { - if ($sha =~ /^$_/) - { - $skipflag = 1; - ## Perhaps only warn if a pattern matches more than once? - warn "$ME: warning: skipping $sha due to $_\n"; - last; - } - } - } - # If this commit's log requires any transformation, do it now. my $code = $amend_code->{$sha}; if (defined $code) @@ -333,7 +306,7 @@ sub git_dir_option($) $rest =~ s/^\s*\(cherry picked from commit [\da-f]+\)\n//m; } - my @line = split /[ \t]*\n/, $rest; + my @line = split "\n", $rest; my $author_line = shift @line; defined $author_line or die "$ME:$.: unexpected EOF\n"; @@ -343,18 +316,17 @@ sub git_dir_option($) # Format 'Copyright-paperwork-exempt: Yes' as a standard ChangeLog # `(tiny change)' annotation. - my $tiny = (grep (/^(?:Copyright-paperwork-exempt|Tiny-change):\s+[Yy]es$/, @line) + my $tiny = (grep (/^Copyright-paperwork-exempt:\s+[Yy]es$/, @line) ? ' (tiny change)' : ''); my $date_line = sprintf "%s %s$tiny\n", - strftime ("%Y-%m-%d", localtime ($1)), $2; + strftime ("%F", localtime ($1)), $2; my @coauthors = grep /^Co-authored-by:.*$/, @line; # Omit meta-data lines we've already interpreted. @line = grep !/^(?:Signed-off-by:[ ].*>$ |Co-authored-by:[ ] |Copyright-paperwork-exempt:[ ] - |Tiny-change:[ ] )/x, @line; # Remove leading and trailing blank lines. @@ -364,100 +336,68 @@ sub git_dir_option($) while ($line[$#line] =~ /^\s*$/) { pop @line; } } - # Handle Emacs gitmerge.el "skipped" commits. - # Yes, this should be controlled by an option. So sue me. - if ( grep /^(; )?Merge from /, @line ) - { - my $found = 0; - foreach (@line) - { - if (grep /^The following commit.*skipped:$/, $_) - { - $found = 1; - ## Reset at each merge to reduce chance of false matches. - @skipshas = (); - next; - } - if ($found && $_ =~ /^([0-9a-fA-F]{7,}) [^ ]/) - { - push ( @skipshas, $1 ); - } - } - } + # Record whether there are two or more paragraphs. + my $multi_paragraph = grep /^\s*$/, @line; - # Ignore commits that match the --ignore-matching pattern, if specified. - if (! ($skipflag || (defined $ignore_matching - && @line && $line[0] =~ /$ignore_matching/))) + # Format 'Co-authored-by: A U Thor ' lines in + # standard multi-author ChangeLog format. + for (@coauthors) { - if (defined $ignore_line && @line) - { - @line = grep ! /$ignore_line/, @line; - while ($line[$#line] =~ /^\s*$/) { pop @line; } - } + s/^Co-authored-by:\s*/\t /; + s/\s*/ + or warn "$ME: warning: missing email address for " + . substr ($_, 5) . "\n"; + } - # Format 'Co-authored-by: A U Thor ' lines in - # standard multi-author ChangeLog format. - for (@coauthors) - { - s/^Co-authored-by:\s*/\t /; - s/\s*/ - or warn "$ME: warning: missing email address for " - . substr ($_, 5) . "\n"; - } - - # If clustering of commit messages has been disabled, if this header - # would be different from the previous date/name/etc. header, - # or if this or the previous entry consists of two or more paragraphs, - # then print the header. - if ( ! $cluster - || $date_line ne $prev_date_line - || "@coauthors" ne "@prev_coauthors" - || $multi_paragraph - || $prev_multi_paragraph) + # If there were any lines + if (@line == 0) + { + warn "$ME: warning: empty commit message:\n $date_line\n"; + } + else + { + if ($append_dot) { - $prev_date_line eq '' - or print "\n"; - print $date_line; - @coauthors - and print join ("\n", @coauthors), "\n"; - } - $prev_date_line = $date_line; - @prev_coauthors = @coauthors; - $prev_multi_paragraph = $multi_paragraph; - - # If there were any lines - if (@line == 0) - { - warn "$ME: warning: empty commit message:\n $date_line\n"; - } - else - { - if ($append_dot) + # If the first line of the message has enough room, then + if (length $line[0] < 72) { - # If the first line of the message has enough room, then - if (length $line[0] < 72) - { - # append a dot if there is no other punctuation or blank - # at the end. - $line[0] =~ /[[:punct:]\s]$/ - or $line[0] .= '.'; - } + # append a dot if there is no other punctuation or blank + # at the end. + $line[0] =~ /[[:punct:]\s]$/ + or $line[0] .= '.'; } - - # Remove one additional leading TAB from each line. - $strip_tab - and map { s/^\t// } @line; - - # Prefix each non-empty line with a TAB. - @line = map { length $_ ? "\t$_" : '' } @line; - - print "\n", join ("\n", @line), "\n"; } + + # Remove one additional leading TAB from each line. + $strip_tab + and map { s/^\t// } @line; + + # Prefix each non-empty line with a TAB. + @line = map { length $_ ? "\t$_" : '' } @line; + + print "\n", join ("\n", @line), "\n"; } defined ($in = ) diff --git a/build-aux/gnu-web-doc-update b/build-aux/gnu-web-doc-update index c8fc7e5de..7af2f185f 100755 --- a/build-aux/gnu-web-doc-update +++ b/build-aux/gnu-web-doc-update @@ -2,9 +2,9 @@ # Run this after each non-alpha release, to update the web documentation at # http://www.gnu.org/software/$pkg/manual/ -VERSION=2015-06-16.06; # UTC +VERSION=2012-12-16.14; # UTC -# Copyright (C) 2009-2015 Free Software Foundation, Inc. +# Copyright (C) 2009-2014 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -40,7 +40,6 @@ assumes all documentation is in the doc/ sub-directory. Options: -C, --builddir=DIR location of (configured) Makefile (default: .) -n, --dry-run don't actually commit anything - -m, --mirror remove out of date files from document server --help print this help, then exit --version print version number, then exit @@ -108,7 +107,6 @@ find_tool XARGS gxargs xargs builddir=. dryrun= -rm_stale='echo' while test $# != 0 do # Handle --option=value by splitting apart and putting back on argv. @@ -125,7 +123,6 @@ do --help|--version) ${1#--};; -C|--builddir) shift; builddir=$1; shift ;; -n|--dry-run) dryrun=echo; shift;; - -m|--mirror) rm_stale=''; shift;; --*) die "unrecognized option: $1";; *) break;; esac @@ -162,7 +159,6 @@ $GIT submodule update --recursive ./bootstrap srcdir=$(pwd) cd "$builddir" -builddir=$(pwd) ./config.status --recheck ./config.status make @@ -186,17 +182,6 @@ $RSYNC -avP "$builddir"/doc/manual/ $tmp/$pkg/manual find . -name CVS -prune -o -print \ | $XARGS --no-run-if-empty -- $dryrun $CVS add -ko - # Report/Remove stale files - # excluding doc server specific files like CVS/* and .symlinks - if test -n "$rm_stale"; then - echo 'Consider the --mirror option if all of the manual is generated,' >&2 - echo 'which will run `cvs remove` to remove stale files.' >&2 - fi - { find . \( -name CVS -o -type f -name '.*' \) -prune -o -type f -print - (cd "$builddir"/doc/manual/ && find . -type f -print | sed p) - } | sort | uniq -u \ - | $XARGS --no-run-if-empty -- ${rm_stale:-$dryrun} $CVS remove -f - $dryrun $CVS ci -m $version ) diff --git a/build-aux/gnupload b/build-aux/gnupload index f87c195dc..2da97d894 100755 --- a/build-aux/gnupload +++ b/build-aux/gnupload @@ -3,7 +3,7 @@ scriptversion=2013-03-19.17; # UTC -# Copyright (C) 2004-2015 Free Software Foundation, Inc. +# Copyright (C) 2004-2014 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/build-aux/snippet/arg-nonnull.h b/build-aux/snippet/arg-nonnull.h index 0d55e2bce..9ee8b1555 100644 --- a/build-aux/snippet/arg-nonnull.h +++ b/build-aux/snippet/arg-nonnull.h @@ -1,5 +1,5 @@ /* A C macro for declaring that specific arguments must not be NULL. - Copyright (C) 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published diff --git a/build-aux/snippet/c++defs.h b/build-aux/snippet/c++defs.h index 585b38ab3..67b12335d 100644 --- a/build-aux/snippet/c++defs.h +++ b/build-aux/snippet/c++defs.h @@ -1,5 +1,5 @@ /* C++ compatible function declaration macros. - Copyright (C) 2010-2015 Free Software Foundation, Inc. + Copyright (C) 2010-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published diff --git a/build-aux/snippet/unused-parameter.h b/build-aux/snippet/unused-parameter.h index f507eb745..41d9510ca 100644 --- a/build-aux/snippet/unused-parameter.h +++ b/build-aux/snippet/unused-parameter.h @@ -1,5 +1,5 @@ /* A C macro for declaring that specific function parameters are not used. - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published diff --git a/build-aux/snippet/warn-on-use.h b/build-aux/snippet/warn-on-use.h index 90f4985ce..1c4d7bd4e 100644 --- a/build-aux/snippet/warn-on-use.h +++ b/build-aux/snippet/warn-on-use.h @@ -1,5 +1,5 @@ /* A C macro for emitting warnings if a function is used. - Copyright (C) 2010-2015 Free Software Foundation, Inc. + Copyright (C) 2010-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published diff --git a/build-aux/useless-if-before-free b/build-aux/useless-if-before-free index 82a09b39e..4c76c75d7 100755 --- a/build-aux/useless-if-before-free +++ b/build-aux/useless-if-before-free @@ -10,7 +10,7 @@ my $VERSION = '2012-01-06 07:23'; # UTC # If you change this file with Emacs, please let the write hook # do its job. Otherwise, update this string manually. -# Copyright (C) 2008-2015 Free Software Foundation, Inc. +# Copyright (C) 2008-2014 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/build-aux/vc-list-files b/build-aux/vc-list-files index 3bf93c3c0..b2bca54c9 100755 --- a/build-aux/vc-list-files +++ b/build-aux/vc-list-files @@ -4,7 +4,7 @@ # Print a version string. scriptversion=2011-05-16.22; # UTC -# Copyright (C) 2006-2015 Free Software Foundation, Inc. +# Copyright (C) 2006-2014 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/doc/gendocs_template b/doc/gendocs_template index df7faa3d3..4836df787 100644 --- a/doc/gendocs_template +++ b/doc/gendocs_template @@ -1,6 +1,5 @@ - -%%TITLE%% - GNU Project - Free Software Foundation +%%TITLE%% - GNU Project - Free Software Foundation (FSF)

%%TITLE%%

@@ -68,22 +67,19 @@ script.)

diff --git a/gnulib-local/build-aux/git-version-gen.diff b/gnulib-local/build-aux/git-version-gen.diff index e15acf336..f875f49d9 100644 --- a/gnulib-local/build-aux/git-version-gen.diff +++ b/gnulib-local/build-aux/git-version-gen.diff @@ -4,15 +4,15 @@ Remove when integrated in Gnulib. --- a/build-aux/git-version-gen +++ b/build-aux/git-version-gen -@@ -86,6 +86,7 @@ +@@ -86,6 +86,7 @@ Print a version string. Options: - --prefix PREFIX prefix of git tags (default 'v') + --prefix prefix of git tags (default 'v') + --match pattern for git tags to match (default: '\$prefix*') - --fallback VERSION - fallback version to use if \"git --version\" fails + --fallback fallback version to use if \"git --version\" fails -@@ -97,11 +98,15 @@ + --help display this help and exit +@@ -96,11 +97,15 @@ Running without arguments will suffice in most cases." prefix=v fallback= @@ -28,7 +28,7 @@ Remove when integrated in Gnulib. --fallback) shift; fallback="$1";; -*) echo "$0: Unknown option '$1'." >&2 -@@ -125,6 +130,7 @@ +@@ -124,6 +129,7 @@ if test "x$tarball_version_file" = x; then exit 1 fi @@ -36,7 +36,7 @@ Remove when integrated in Gnulib. tag_sed_script="${tag_sed_script:-s/x/x/}" nl=' -@@ -155,7 +161,7 @@ +@@ -154,7 +160,7 @@ then # directory, and "git describe" output looks sensible, use that to # derive a version string. elif test "`git log -1 --pretty=format:x . 2>&1`" = x \ diff --git a/lib/Makefile.am b/lib/Makefile.am index e5a4aed8b..5d9c902fc 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -1,6 +1,6 @@ ## DO NOT EDIT! GENERATED AUTOMATICALLY! ## Process this file with automake to produce Makefile.in. -# Copyright (C) 2002-2015 Free Software Foundation, Inc. +# Copyright (C) 2002-2014 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -176,13 +176,6 @@ EXTRA_DIST += arpa_inet.in.h ## end gnulib module arpa_inet -## begin gnulib module assure - - -EXTRA_DIST += assure.h - -## end gnulib module assure - ## begin gnulib module binary-io libgnu_la_SOURCES += binary-io.h binary-io.c @@ -706,9 +699,6 @@ EXTRA_DIST += $(top_srcdir)/build-aux/gnupload ## begin gnulib module gperf GPERF = gperf -V_GPERF = $(V_GPERF_@AM_V@) -V_GPERF_ = $(V_GPERF_@AM_DEFAULT_V@) -V_GPERF_0 = @echo " GPERF " $@; ## end gnulib module gperf @@ -758,19 +748,19 @@ EXTRA_DIST += iconv.in.h ## begin gnulib module iconv_open iconv_open-aix.h: iconv_open-aix.gperf - $(V_GPERF)$(GPERF) -m 10 $(srcdir)/iconv_open-aix.gperf > $(srcdir)/iconv_open-aix.h-t && \ + $(GPERF) -m 10 $(srcdir)/iconv_open-aix.gperf > $(srcdir)/iconv_open-aix.h-t mv $(srcdir)/iconv_open-aix.h-t $(srcdir)/iconv_open-aix.h iconv_open-hpux.h: iconv_open-hpux.gperf - $(V_GPERF)$(GPERF) -m 10 $(srcdir)/iconv_open-hpux.gperf > $(srcdir)/iconv_open-hpux.h-t && \ + $(GPERF) -m 10 $(srcdir)/iconv_open-hpux.gperf > $(srcdir)/iconv_open-hpux.h-t mv $(srcdir)/iconv_open-hpux.h-t $(srcdir)/iconv_open-hpux.h iconv_open-irix.h: iconv_open-irix.gperf - $(V_GPERF)$(GPERF) -m 10 $(srcdir)/iconv_open-irix.gperf > $(srcdir)/iconv_open-irix.h-t && \ + $(GPERF) -m 10 $(srcdir)/iconv_open-irix.gperf > $(srcdir)/iconv_open-irix.h-t mv $(srcdir)/iconv_open-irix.h-t $(srcdir)/iconv_open-irix.h iconv_open-osf.h: iconv_open-osf.gperf - $(V_GPERF)$(GPERF) -m 10 $(srcdir)/iconv_open-osf.gperf > $(srcdir)/iconv_open-osf.h-t && \ + $(GPERF) -m 10 $(srcdir)/iconv_open-osf.gperf > $(srcdir)/iconv_open-osf.h-t mv $(srcdir)/iconv_open-osf.h-t $(srcdir)/iconv_open-osf.h iconv_open-solaris.h: iconv_open-solaris.gperf - $(V_GPERF)$(GPERF) -m 10 $(srcdir)/iconv_open-solaris.gperf > $(srcdir)/iconv_open-solaris.h-t && \ + $(GPERF) -m 10 $(srcdir)/iconv_open-solaris.gperf > $(srcdir)/iconv_open-solaris.h-t mv $(srcdir)/iconv_open-solaris.h-t $(srcdir)/iconv_open-solaris.h BUILT_SOURCES += iconv_open-aix.h iconv_open-hpux.h iconv_open-irix.h iconv_open-osf.h iconv_open-solaris.h MOSTLYCLEANFILES += iconv_open-aix.h-t iconv_open-hpux.h-t iconv_open-irix.h-t iconv_open-osf.h-t iconv_open-solaris.h-t @@ -1456,24 +1446,6 @@ EXTRA_libgnu_la_SOURCES += mkstemp.c ## end gnulib module mkstemp -## begin gnulib module mktime - - -EXTRA_DIST += mktime-internal.h mktime.c - -EXTRA_libgnu_la_SOURCES += mktime.c - -## end gnulib module mktime - -## begin gnulib module mktime-internal - - -EXTRA_DIST += mktime-internal.h mktime.c - -EXTRA_libgnu_la_SOURCES += mktime.c - -## end gnulib module mktime-internal - ## begin gnulib module msvc-inval @@ -2088,7 +2060,6 @@ stddef.h: stddef.in.h $(top_builddir)/config.status -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \ -e 's|@''PRAGMA_COLUMNS''@|@PRAGMA_COLUMNS@|g' \ -e 's|@''NEXT_STDDEF_H''@|$(NEXT_STDDEF_H)|g' \ - -e 's|@''HAVE_MAX_ALIGN_T''@|$(HAVE_MAX_ALIGN_T)|g' \ -e 's|@''HAVE_WCHAR_T''@|$(HAVE_WCHAR_T)|g' \ -e 's|@''REPLACE_NULL''@|$(REPLACE_NULL)|g' \ < $(srcdir)/stddef.in.h; \ @@ -2315,7 +2286,6 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \ -e 's/@''GNULIB_PTSNAME''@/$(GNULIB_PTSNAME)/g' \ -e 's/@''GNULIB_PTSNAME_R''@/$(GNULIB_PTSNAME_R)/g' \ -e 's/@''GNULIB_PUTENV''@/$(GNULIB_PUTENV)/g' \ - -e 's/@''GNULIB_QSORT_R''@/$(GNULIB_QSORT_R)/g' \ -e 's/@''GNULIB_RANDOM''@/$(GNULIB_RANDOM)/g' \ -e 's/@''GNULIB_RANDOM_R''@/$(GNULIB_RANDOM_R)/g' \ -e 's/@''GNULIB_REALLOC_POSIX''@/$(GNULIB_REALLOC_POSIX)/g' \ @@ -2367,7 +2337,6 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \ -e 's|@''REPLACE_PTSNAME''@|$(REPLACE_PTSNAME)|g' \ -e 's|@''REPLACE_PTSNAME_R''@|$(REPLACE_PTSNAME_R)|g' \ -e 's|@''REPLACE_PUTENV''@|$(REPLACE_PUTENV)|g' \ - -e 's|@''REPLACE_QSORT_R''@|$(REPLACE_QSORT_R)|g' \ -e 's|@''REPLACE_RANDOM_R''@|$(REPLACE_RANDOM_R)|g' \ -e 's|@''REPLACE_REALLOC''@|$(REPLACE_REALLOC)|g' \ -e 's|@''REPLACE_REALPATH''@|$(REPLACE_REALPATH)|g' \ @@ -2843,12 +2812,10 @@ time.h: time.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $( -e 's/@''GNULIB_STRPTIME''@/$(GNULIB_STRPTIME)/g' \ -e 's/@''GNULIB_TIMEGM''@/$(GNULIB_TIMEGM)/g' \ -e 's/@''GNULIB_TIME_R''@/$(GNULIB_TIME_R)/g' \ - -e 's/@''GNULIB_TIME_RZ''@/$(GNULIB_TIME_RZ)/g' \ -e 's|@''HAVE_DECL_LOCALTIME_R''@|$(HAVE_DECL_LOCALTIME_R)|g' \ -e 's|@''HAVE_NANOSLEEP''@|$(HAVE_NANOSLEEP)|g' \ -e 's|@''HAVE_STRPTIME''@|$(HAVE_STRPTIME)|g' \ -e 's|@''HAVE_TIMEGM''@|$(HAVE_TIMEGM)|g' \ - -e 's|@''HAVE_TIMEZONE_T''@|$(HAVE_TIMEZONE_T)|g' \ -e 's|@''REPLACE_GMTIME''@|$(REPLACE_GMTIME)|g' \ -e 's|@''REPLACE_LOCALTIME''@|$(REPLACE_LOCALTIME)|g' \ -e 's|@''REPLACE_LOCALTIME_R''@|$(REPLACE_LOCALTIME_R)|g' \ @@ -2858,7 +2825,6 @@ time.h: time.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $( -e 's|@''PTHREAD_H_DEFINES_STRUCT_TIMESPEC''@|$(PTHREAD_H_DEFINES_STRUCT_TIMESPEC)|g' \ -e 's|@''SYS_TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(SYS_TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \ -e 's|@''TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \ - -e 's|@''UNISTD_H_DEFINES_STRUCT_TIMESPEC''@|$(UNISTD_H_DEFINES_STRUCT_TIMESPEC)|g' \ -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \ -e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \ -e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \ @@ -2880,24 +2846,6 @@ EXTRA_libgnu_la_SOURCES += time_r.c ## end gnulib module time_r -## begin gnulib module time_rz - - -EXTRA_DIST += time-internal.h time_rz.c - -EXTRA_libgnu_la_SOURCES += time_rz.c - -## end gnulib module time_rz - -## begin gnulib module timegm - - -EXTRA_DIST += mktime-internal.h timegm.c - -EXTRA_libgnu_la_SOURCES += timegm.c - -## end gnulib module timegm - ## begin gnulib module times @@ -3047,11 +2995,9 @@ unistd.h: unistd.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H -e 's|@''REPLACE_PWRITE''@|$(REPLACE_PWRITE)|g' \ -e 's|@''REPLACE_READ''@|$(REPLACE_READ)|g' \ -e 's|@''REPLACE_READLINK''@|$(REPLACE_READLINK)|g' \ - -e 's|@''REPLACE_READLINKAT''@|$(REPLACE_READLINKAT)|g' \ -e 's|@''REPLACE_RMDIR''@|$(REPLACE_RMDIR)|g' \ -e 's|@''REPLACE_SLEEP''@|$(REPLACE_SLEEP)|g' \ -e 's|@''REPLACE_SYMLINK''@|$(REPLACE_SYMLINK)|g' \ - -e 's|@''REPLACE_SYMLINKAT''@|$(REPLACE_SYMLINKAT)|g' \ -e 's|@''REPLACE_TTYNAME_R''@|$(REPLACE_TTYNAME_R)|g' \ -e 's|@''REPLACE_UNLINK''@|$(REPLACE_UNLINK)|g' \ -e 's|@''REPLACE_UNLINKAT''@|$(REPLACE_UNLINKAT)|g' \ @@ -3142,15 +3088,6 @@ EXTRA_DIST += unitypes.in.h ## end gnulib module unitypes -## begin gnulib module unsetenv - - -EXTRA_DIST += unsetenv.c - -EXTRA_libgnu_la_SOURCES += unsetenv.c - -## end gnulib module unsetenv - ## begin gnulib module useless-if-before-free diff --git a/lib/accept.c b/lib/accept.c index 441c065db..b216c6bd6 100644 --- a/lib/accept.c +++ b/lib/accept.c @@ -1,6 +1,6 @@ /* accept.c --- wrappers for Windows accept function - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/alignof.h b/lib/alignof.h index 713f3bd89..280f3e384 100644 --- a/lib/alignof.h +++ b/lib/alignof.h @@ -1,5 +1,5 @@ /* Determine alignment of types. - Copyright (C) 2003-2004, 2006, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2003-2004, 2006, 2009-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/alloca.in.h b/lib/alloca.in.h index dc1b55060..e3aa62d2d 100644 --- a/lib/alloca.in.h +++ b/lib/alloca.in.h @@ -1,6 +1,6 @@ /* Memory allocation on the stack. - Copyright (C) 1995, 1999, 2001-2004, 2006-2015 Free Software Foundation, + Copyright (C) 1995, 1999, 2001-2004, 2006-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it diff --git a/lib/arpa_inet.in.h b/lib/arpa_inet.in.h index 6ad528cc6..3f5df4776 100644 --- a/lib/arpa_inet.in.h +++ b/lib/arpa_inet.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 2005-2006, 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2005-2006, 2008-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/asnprintf.c b/lib/asnprintf.c index 413b8d763..7806f6888 100644 --- a/lib/asnprintf.c +++ b/lib/asnprintf.c @@ -1,5 +1,5 @@ /* Formatted output to strings. - Copyright (C) 1999, 2002, 2006, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 1999, 2002, 2006, 2009-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/assure.h b/lib/assure.h deleted file mode 100644 index 867688e01..000000000 --- a/lib/assure.h +++ /dev/null @@ -1,37 +0,0 @@ -/* Run-time assert-like macros. - - Copyright (C) 2014-2015 Free Software Foundation, Inc. - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU Lesser General Public License as published by - the Free Software Foundation; either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public License - along with this program. If not, see . */ - -/* Written by Paul Eggert. */ - -#ifndef _GL_ASSURE_H -#define _GL_ASSURE_H - -#include - -/* Check E's value at runtime, and report an error and abort if not. - However, do nothng if NDEBUG is defined. - - Unlike standard 'assert', this macro always compiles E even when NDEBUG - is defined, so as to catch typos and avoid some GCC warnings. */ - -#ifdef NDEBUG -# define assure(E) ((void) (0 && (E))) -#else -# define assure(E) assert (E) -#endif - -#endif diff --git a/lib/basename-lgpl.c b/lib/basename-lgpl.c index 12d1e522b..fe007936f 100644 --- a/lib/basename-lgpl.c +++ b/lib/basename-lgpl.c @@ -1,6 +1,6 @@ /* basename.c -- return the last element in a file name - Copyright (C) 1990, 1998-2001, 2003-2006, 2009-2015 Free Software + Copyright (C) 1990, 1998-2001, 2003-2006, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/binary-io.c b/lib/binary-io.c index d828bcd01..8bbdb44d1 100644 --- a/lib/binary-io.c +++ b/lib/binary-io.c @@ -1,4 +1,3 @@ #include #define BINARY_IO_INLINE _GL_EXTERN_INLINE #include "binary-io.h" -typedef int dummy; diff --git a/lib/binary-io.h b/lib/binary-io.h index 1a87e8f3b..c276faa88 100644 --- a/lib/binary-io.h +++ b/lib/binary-io.h @@ -1,5 +1,5 @@ /* Binary mode I/O. - Copyright (C) 2001, 2003, 2005, 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2001, 2003, 2005, 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/bind.c b/lib/bind.c index 72263cc1b..36750c9a8 100644 --- a/lib/bind.c +++ b/lib/bind.c @@ -1,6 +1,6 @@ /* bind.c --- wrappers for Windows bind function - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/btowc.c b/lib/btowc.c index 01e80c50a..aad27f593 100644 --- a/lib/btowc.c +++ b/lib/btowc.c @@ -1,5 +1,5 @@ /* Convert unibyte character to wide character. - Copyright (C) 2008, 2010-2015 Free Software Foundation, Inc. + Copyright (C) 2008, 2010-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2008. This program is free software: you can redistribute it and/or modify diff --git a/lib/byteswap.in.h b/lib/byteswap.in.h index 673c53b25..130c79dfb 100644 --- a/lib/byteswap.in.h +++ b/lib/byteswap.in.h @@ -1,5 +1,5 @@ /* byteswap.h - Byte swapping - Copyright (C) 2005, 2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2005, 2007, 2009-2014 Free Software Foundation, Inc. Written by Oskar Liljeblad , 2005. This program is free software: you can redistribute it and/or modify diff --git a/lib/c-ctype.c b/lib/c-ctype.c index 5d9d4d87a..7fe3f7efa 100644 --- a/lib/c-ctype.c +++ b/lib/c-ctype.c @@ -1,3 +1,395 @@ +/* Character handling in C locale. + + Copyright 2000-2003, 2006, 2009-2014 Free Software Foundation, Inc. + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU Lesser General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU Lesser General Public License for more details. + +You should have received a copy of the GNU Lesser General Public License +along with this program; if not, see . */ + #include -#define C_CTYPE_INLINE _GL_EXTERN_INLINE + +/* Specification. */ +#define NO_C_CTYPE_MACROS #include "c-ctype.h" + +/* The function isascii is not locale dependent. Its use in EBCDIC is + questionable. */ +bool +c_isascii (int c) +{ + return (c >= 0x00 && c <= 0x7f); +} + +bool +c_isalnum (int c) +{ +#if C_CTYPE_CONSECUTIVE_DIGITS \ + && C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE +#if C_CTYPE_ASCII + return ((c >= '0' && c <= '9') + || ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'Z')); +#else + return ((c >= '0' && c <= '9') + || (c >= 'A' && c <= 'Z') + || (c >= 'a' && c <= 'z')); +#endif +#else + switch (c) + { + case '0': case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': + case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': + case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': + case 'Y': case 'Z': + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': + case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': + case 's': case 't': case 'u': case 'v': case 'w': case 'x': + case 'y': case 'z': + return 1; + default: + return 0; + } +#endif +} + +bool +c_isalpha (int c) +{ +#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE +#if C_CTYPE_ASCII + return ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'Z'); +#else + return ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')); +#endif +#else + switch (c) + { + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': + case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': + case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': + case 'Y': case 'Z': + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': + case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': + case 's': case 't': case 'u': case 'v': case 'w': case 'x': + case 'y': case 'z': + return 1; + default: + return 0; + } +#endif +} + +bool +c_isblank (int c) +{ + return (c == ' ' || c == '\t'); +} + +bool +c_iscntrl (int c) +{ +#if C_CTYPE_ASCII + return ((c & ~0x1f) == 0 || c == 0x7f); +#else + switch (c) + { + case ' ': case '!': case '"': case '#': case '$': case '%': + case '&': case '\'': case '(': case ')': case '*': case '+': + case ',': case '-': case '.': case '/': + case '0': case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + case ':': case ';': case '<': case '=': case '>': case '?': + case '@': + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': + case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': + case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': + case 'Y': case 'Z': + case '[': case '\\': case ']': case '^': case '_': case '`': + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': + case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': + case 's': case 't': case 'u': case 'v': case 'w': case 'x': + case 'y': case 'z': + case '{': case '|': case '}': case '~': + return 0; + default: + return 1; + } +#endif +} + +bool +c_isdigit (int c) +{ +#if C_CTYPE_CONSECUTIVE_DIGITS + return (c >= '0' && c <= '9'); +#else + switch (c) + { + case '0': case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + return 1; + default: + return 0; + } +#endif +} + +bool +c_islower (int c) +{ +#if C_CTYPE_CONSECUTIVE_LOWERCASE + return (c >= 'a' && c <= 'z'); +#else + switch (c) + { + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': + case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': + case 's': case 't': case 'u': case 'v': case 'w': case 'x': + case 'y': case 'z': + return 1; + default: + return 0; + } +#endif +} + +bool +c_isgraph (int c) +{ +#if C_CTYPE_ASCII + return (c >= '!' && c <= '~'); +#else + switch (c) + { + case '!': case '"': case '#': case '$': case '%': case '&': + case '\'': case '(': case ')': case '*': case '+': case ',': + case '-': case '.': case '/': + case '0': case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + case ':': case ';': case '<': case '=': case '>': case '?': + case '@': + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': + case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': + case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': + case 'Y': case 'Z': + case '[': case '\\': case ']': case '^': case '_': case '`': + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': + case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': + case 's': case 't': case 'u': case 'v': case 'w': case 'x': + case 'y': case 'z': + case '{': case '|': case '}': case '~': + return 1; + default: + return 0; + } +#endif +} + +bool +c_isprint (int c) +{ +#if C_CTYPE_ASCII + return (c >= ' ' && c <= '~'); +#else + switch (c) + { + case ' ': case '!': case '"': case '#': case '$': case '%': + case '&': case '\'': case '(': case ')': case '*': case '+': + case ',': case '-': case '.': case '/': + case '0': case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + case ':': case ';': case '<': case '=': case '>': case '?': + case '@': + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': + case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': + case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': + case 'Y': case 'Z': + case '[': case '\\': case ']': case '^': case '_': case '`': + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': + case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': + case 's': case 't': case 'u': case 'v': case 'w': case 'x': + case 'y': case 'z': + case '{': case '|': case '}': case '~': + return 1; + default: + return 0; + } +#endif +} + +bool +c_ispunct (int c) +{ +#if C_CTYPE_ASCII + return ((c >= '!' && c <= '~') + && !((c >= '0' && c <= '9') + || ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'Z'))); +#else + switch (c) + { + case '!': case '"': case '#': case '$': case '%': case '&': + case '\'': case '(': case ')': case '*': case '+': case ',': + case '-': case '.': case '/': + case ':': case ';': case '<': case '=': case '>': case '?': + case '@': + case '[': case '\\': case ']': case '^': case '_': case '`': + case '{': case '|': case '}': case '~': + return 1; + default: + return 0; + } +#endif +} + +bool +c_isspace (int c) +{ + return (c == ' ' || c == '\t' + || c == '\n' || c == '\v' || c == '\f' || c == '\r'); +} + +bool +c_isupper (int c) +{ +#if C_CTYPE_CONSECUTIVE_UPPERCASE + return (c >= 'A' && c <= 'Z'); +#else + switch (c) + { + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': + case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': + case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': + case 'Y': case 'Z': + return 1; + default: + return 0; + } +#endif +} + +bool +c_isxdigit (int c) +{ +#if C_CTYPE_CONSECUTIVE_DIGITS \ + && C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE +#if C_CTYPE_ASCII + return ((c >= '0' && c <= '9') + || ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'F')); +#else + return ((c >= '0' && c <= '9') + || (c >= 'A' && c <= 'F') + || (c >= 'a' && c <= 'f')); +#endif +#else + switch (c) + { + case '0': case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + return 1; + default: + return 0; + } +#endif +} + +int +c_tolower (int c) +{ +#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE + return (c >= 'A' && c <= 'Z' ? c - 'A' + 'a' : c); +#else + switch (c) + { + case 'A': return 'a'; + case 'B': return 'b'; + case 'C': return 'c'; + case 'D': return 'd'; + case 'E': return 'e'; + case 'F': return 'f'; + case 'G': return 'g'; + case 'H': return 'h'; + case 'I': return 'i'; + case 'J': return 'j'; + case 'K': return 'k'; + case 'L': return 'l'; + case 'M': return 'm'; + case 'N': return 'n'; + case 'O': return 'o'; + case 'P': return 'p'; + case 'Q': return 'q'; + case 'R': return 'r'; + case 'S': return 's'; + case 'T': return 't'; + case 'U': return 'u'; + case 'V': return 'v'; + case 'W': return 'w'; + case 'X': return 'x'; + case 'Y': return 'y'; + case 'Z': return 'z'; + default: return c; + } +#endif +} + +int +c_toupper (int c) +{ +#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE + return (c >= 'a' && c <= 'z' ? c - 'a' + 'A' : c); +#else + switch (c) + { + case 'a': return 'A'; + case 'b': return 'B'; + case 'c': return 'C'; + case 'd': return 'D'; + case 'e': return 'E'; + case 'f': return 'F'; + case 'g': return 'G'; + case 'h': return 'H'; + case 'i': return 'I'; + case 'j': return 'J'; + case 'k': return 'K'; + case 'l': return 'L'; + case 'm': return 'M'; + case 'n': return 'N'; + case 'o': return 'O'; + case 'p': return 'P'; + case 'q': return 'Q'; + case 'r': return 'R'; + case 's': return 'S'; + case 't': return 'T'; + case 'u': return 'U'; + case 'v': return 'V'; + case 'w': return 'W'; + case 'x': return 'X'; + case 'y': return 'Y'; + case 'z': return 'Z'; + default: return c; + } +#endif +} diff --git a/lib/c-ctype.h b/lib/c-ctype.h index c7da46f54..a258019f4 100644 --- a/lib/c-ctype.h +++ b/lib/c-ctype.h @@ -5,7 +5,7 @@ functions' behaviour depends on the current locale set via setlocale. - Copyright (C) 2000-2003, 2006, 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2000-2003, 2006, 2008-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -25,13 +25,6 @@ along with this program; if not, see . */ #include -#ifndef _GL_INLINE_HEADER_BEGIN - #error "Please include config.h first." -#endif -_GL_INLINE_HEADER_BEGIN -#ifndef C_CTYPE_INLINE -# define C_CTYPE_INLINE _GL_INLINE -#endif #ifdef __cplusplus extern "C" { @@ -46,6 +39,38 @@ extern "C" { characters. */ +/* Check whether the ASCII optimizations apply. */ + +/* ANSI C89 (and ISO C99 5.2.1.3 too) already guarantees that + '0', '1', ..., '9' have consecutive integer values. */ +#define C_CTYPE_CONSECUTIVE_DIGITS 1 + +#if ('A' <= 'Z') \ + && ('A' + 1 == 'B') && ('B' + 1 == 'C') && ('C' + 1 == 'D') \ + && ('D' + 1 == 'E') && ('E' + 1 == 'F') && ('F' + 1 == 'G') \ + && ('G' + 1 == 'H') && ('H' + 1 == 'I') && ('I' + 1 == 'J') \ + && ('J' + 1 == 'K') && ('K' + 1 == 'L') && ('L' + 1 == 'M') \ + && ('M' + 1 == 'N') && ('N' + 1 == 'O') && ('O' + 1 == 'P') \ + && ('P' + 1 == 'Q') && ('Q' + 1 == 'R') && ('R' + 1 == 'S') \ + && ('S' + 1 == 'T') && ('T' + 1 == 'U') && ('U' + 1 == 'V') \ + && ('V' + 1 == 'W') && ('W' + 1 == 'X') && ('X' + 1 == 'Y') \ + && ('Y' + 1 == 'Z') +#define C_CTYPE_CONSECUTIVE_UPPERCASE 1 +#endif + +#if ('a' <= 'z') \ + && ('a' + 1 == 'b') && ('b' + 1 == 'c') && ('c' + 1 == 'd') \ + && ('d' + 1 == 'e') && ('e' + 1 == 'f') && ('f' + 1 == 'g') \ + && ('g' + 1 == 'h') && ('h' + 1 == 'i') && ('i' + 1 == 'j') \ + && ('j' + 1 == 'k') && ('k' + 1 == 'l') && ('l' + 1 == 'm') \ + && ('m' + 1 == 'n') && ('n' + 1 == 'o') && ('o' + 1 == 'p') \ + && ('p' + 1 == 'q') && ('q' + 1 == 'r') && ('r' + 1 == 's') \ + && ('s' + 1 == 't') && ('t' + 1 == 'u') && ('u' + 1 == 'v') \ + && ('v' + 1 == 'w') && ('w' + 1 == 'x') && ('x' + 1 == 'y') \ + && ('y' + 1 == 'z') +#define C_CTYPE_CONSECUTIVE_LOWERCASE 1 +#endif + #if (' ' == 32) && ('!' == 33) && ('"' == 34) && ('#' == 35) \ && ('%' == 37) && ('&' == 38) && ('\'' == 39) && ('(' == 40) \ && (')' == 41) && ('*' == 42) && ('+' == 43) && (',' == 44) \ @@ -71,84 +96,11 @@ extern "C" { && ('{' == 123) && ('|' == 124) && ('}' == 125) && ('~' == 126) /* The character set is ASCII or one of its variants or extensions, not EBCDIC. Testing the value of '\n' and '\r' is not relevant. */ -# define C_CTYPE_ASCII 1 -#elif ! (' ' == '\x40' && '0' == '\xf0' \ - && 'A' == '\xc1' && 'J' == '\xd1' && 'S' == '\xe2' \ - && 'a' == '\x81' && 'j' == '\x91' && 's' == '\xa2') -# error "Only ASCII and EBCDIC are supported" +#define C_CTYPE_ASCII 1 #endif -#if 'A' < 0 -# error "EBCDIC and char is signed -- not supported" -#endif -/* Cases for control characters. */ - -#define _C_CTYPE_CNTRL \ - case '\a': case '\b': case '\f': case '\n': \ - case '\r': case '\t': case '\v': \ - _C_CTYPE_OTHER_CNTRL - -/* ASCII control characters other than those with \-letter escapes. */ - -#if C_CTYPE_ASCII -# define _C_CTYPE_OTHER_CNTRL \ - case '\x00': case '\x01': case '\x02': case '\x03': \ - case '\x04': case '\x05': case '\x06': case '\x0e': \ - case '\x0f': case '\x10': case '\x11': case '\x12': \ - case '\x13': case '\x14': case '\x15': case '\x16': \ - case '\x17': case '\x18': case '\x19': case '\x1a': \ - case '\x1b': case '\x1c': case '\x1d': case '\x1e': \ - case '\x1f': case '\x7f' -#else - /* Use EBCDIC code page 1047's assignments for ASCII control chars; - assume all EBCDIC code pages agree about these assignments. */ -# define _C_CTYPE_OTHER_CNTRL \ - case '\x00': case '\x01': case '\x02': case '\x03': \ - case '\x07': case '\x0e': case '\x0f': case '\x10': \ - case '\x11': case '\x12': case '\x13': case '\x18': \ - case '\x19': case '\x1c': case '\x1d': case '\x1e': \ - case '\x1f': case '\x26': case '\x27': case '\x2d': \ - case '\x2e': case '\x32': case '\x37': case '\x3c': \ - case '\x3d': case '\x3f' -#endif - -/* Cases for lowercase hex letters, and lowercase letters, all offset by N. */ - -#define _C_CTYPE_LOWER_A_THRU_F_N(n) \ - case 'a' + (n): case 'b' + (n): case 'c' + (n): case 'd' + (n): \ - case 'e' + (n): case 'f' + (n) -#define _C_CTYPE_LOWER_N(n) \ - _C_CTYPE_LOWER_A_THRU_F_N(n): \ - case 'g' + (n): case 'h' + (n): case 'i' + (n): case 'j' + (n): \ - case 'k' + (n): case 'l' + (n): case 'm' + (n): case 'n' + (n): \ - case 'o' + (n): case 'p' + (n): case 'q' + (n): case 'r' + (n): \ - case 's' + (n): case 't' + (n): case 'u' + (n): case 'v' + (n): \ - case 'w' + (n): case 'x' + (n): case 'y' + (n): case 'z' + (n) - -/* Cases for hex letters, digits, lower, punct, and upper. */ - -#define _C_CTYPE_A_THRU_F \ - _C_CTYPE_LOWER_A_THRU_F_N (0): \ - _C_CTYPE_LOWER_A_THRU_F_N ('A' - 'a') -#define _C_CTYPE_DIGIT \ - case '0': case '1': case '2': case '3': \ - case '4': case '5': case '6': case '7': \ - case '8': case '9' -#define _C_CTYPE_LOWER _C_CTYPE_LOWER_N (0) -#define _C_CTYPE_PUNCT \ - case '!': case '"': case '#': case '$': \ - case '%': case '&': case '\'': case '(': \ - case ')': case '*': case '+': case ',': \ - case '-': case '.': case '/': case ':': \ - case ';': case '<': case '=': case '>': \ - case '?': case '@': case '[': case '\\': \ - case ']': case '^': case '_': case '`': \ - case '{': case '|': case '}': case '~' -#define _C_CTYPE_UPPER _C_CTYPE_LOWER_N ('A' - 'a') - - -/* Function definitions. */ +/* Function declarations. */ /* Unlike the functions in , which require an argument in the range of the 'unsigned char' type, the functions here operate on values that are @@ -165,202 +117,179 @@ extern "C" { if (c_isalpha (*s)) ... */ -C_CTYPE_INLINE bool -c_isalnum (int c) -{ - switch (c) - { - _C_CTYPE_DIGIT: - _C_CTYPE_LOWER: - _C_CTYPE_UPPER: - return true; - default: - return false; - } -} +extern bool c_isascii (int c) _GL_ATTRIBUTE_CONST; /* not locale dependent */ -C_CTYPE_INLINE bool -c_isalpha (int c) -{ - switch (c) - { - _C_CTYPE_LOWER: - _C_CTYPE_UPPER: - return true; - default: - return false; - } -} +extern bool c_isalnum (int c) _GL_ATTRIBUTE_CONST; +extern bool c_isalpha (int c) _GL_ATTRIBUTE_CONST; +extern bool c_isblank (int c) _GL_ATTRIBUTE_CONST; +extern bool c_iscntrl (int c) _GL_ATTRIBUTE_CONST; +extern bool c_isdigit (int c) _GL_ATTRIBUTE_CONST; +extern bool c_islower (int c) _GL_ATTRIBUTE_CONST; +extern bool c_isgraph (int c) _GL_ATTRIBUTE_CONST; +extern bool c_isprint (int c) _GL_ATTRIBUTE_CONST; +extern bool c_ispunct (int c) _GL_ATTRIBUTE_CONST; +extern bool c_isspace (int c) _GL_ATTRIBUTE_CONST; +extern bool c_isupper (int c) _GL_ATTRIBUTE_CONST; +extern bool c_isxdigit (int c) _GL_ATTRIBUTE_CONST; -/* The function isascii is not locale dependent. - Its use in EBCDIC is questionable. */ -C_CTYPE_INLINE bool -c_isascii (int c) -{ - switch (c) - { - case ' ': - _C_CTYPE_CNTRL: - _C_CTYPE_DIGIT: - _C_CTYPE_LOWER: - _C_CTYPE_PUNCT: - _C_CTYPE_UPPER: - return true; - default: - return false; - } -} +extern int c_tolower (int c) _GL_ATTRIBUTE_CONST; +extern int c_toupper (int c) _GL_ATTRIBUTE_CONST; -C_CTYPE_INLINE bool -c_isblank (int c) -{ - return c == ' ' || c == '\t'; -} -C_CTYPE_INLINE bool -c_iscntrl (int c) -{ - switch (c) - { - _C_CTYPE_CNTRL: - return true; - default: - return false; - } -} +#if (defined __GNUC__ && !defined __STRICT_ANSI__ && defined __OPTIMIZE__ \ + && !defined __OPTIMIZE_SIZE__ && !defined NO_C_CTYPE_MACROS) -C_CTYPE_INLINE bool -c_isdigit (int c) -{ - switch (c) - { - _C_CTYPE_DIGIT: - return true; - default: - return false; - } -} +/* ASCII optimizations. */ -C_CTYPE_INLINE bool -c_isgraph (int c) -{ - switch (c) - { - _C_CTYPE_DIGIT: - _C_CTYPE_LOWER: - _C_CTYPE_PUNCT: - _C_CTYPE_UPPER: - return true; - default: - return false; - } -} +#undef c_isascii +#define c_isascii(c) \ + ({ int __c = (c); \ + (__c >= 0x00 && __c <= 0x7f); \ + }) -C_CTYPE_INLINE bool -c_islower (int c) -{ - switch (c) - { - _C_CTYPE_LOWER: - return true; - default: - return false; - } -} +#if C_CTYPE_CONSECUTIVE_DIGITS \ + && C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE +#if C_CTYPE_ASCII +#undef c_isalnum +#define c_isalnum(c) \ + ({ int __c = (c); \ + ((__c >= '0' && __c <= '9') \ + || ((__c & ~0x20) >= 'A' && (__c & ~0x20) <= 'Z')); \ + }) +#else +#undef c_isalnum +#define c_isalnum(c) \ + ({ int __c = (c); \ + ((__c >= '0' && __c <= '9') \ + || (__c >= 'A' && __c <= 'Z') \ + || (__c >= 'a' && __c <= 'z')); \ + }) +#endif +#endif -C_CTYPE_INLINE bool -c_isprint (int c) -{ - switch (c) - { - case ' ': - _C_CTYPE_DIGIT: - _C_CTYPE_LOWER: - _C_CTYPE_PUNCT: - _C_CTYPE_UPPER: - return true; - default: - return false; - } -} +#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE +#if C_CTYPE_ASCII +#undef c_isalpha +#define c_isalpha(c) \ + ({ int __c = (c); \ + ((__c & ~0x20) >= 'A' && (__c & ~0x20) <= 'Z'); \ + }) +#else +#undef c_isalpha +#define c_isalpha(c) \ + ({ int __c = (c); \ + ((__c >= 'A' && __c <= 'Z') || (__c >= 'a' && __c <= 'z')); \ + }) +#endif +#endif -C_CTYPE_INLINE bool -c_ispunct (int c) -{ - switch (c) - { - _C_CTYPE_PUNCT: - return true; - default: - return false; - } -} +#undef c_isblank +#define c_isblank(c) \ + ({ int __c = (c); \ + (__c == ' ' || __c == '\t'); \ + }) -C_CTYPE_INLINE bool -c_isspace (int c) -{ - switch (c) - { - case ' ': case '\t': case '\n': case '\v': case '\f': case '\r': - return true; - default: - return false; - } -} +#if C_CTYPE_ASCII +#undef c_iscntrl +#define c_iscntrl(c) \ + ({ int __c = (c); \ + ((__c & ~0x1f) == 0 || __c == 0x7f); \ + }) +#endif -C_CTYPE_INLINE bool -c_isupper (int c) -{ - switch (c) - { - _C_CTYPE_UPPER: - return true; - default: - return false; - } -} +#if C_CTYPE_CONSECUTIVE_DIGITS +#undef c_isdigit +#define c_isdigit(c) \ + ({ int __c = (c); \ + (__c >= '0' && __c <= '9'); \ + }) +#endif -C_CTYPE_INLINE bool -c_isxdigit (int c) -{ - switch (c) - { - _C_CTYPE_DIGIT: - _C_CTYPE_A_THRU_F: - return true; - default: - return false; - } -} +#if C_CTYPE_CONSECUTIVE_LOWERCASE +#undef c_islower +#define c_islower(c) \ + ({ int __c = (c); \ + (__c >= 'a' && __c <= 'z'); \ + }) +#endif -C_CTYPE_INLINE int -c_tolower (int c) -{ - switch (c) - { - _C_CTYPE_UPPER: - return c - 'A' + 'a'; - default: - return c; - } -} +#if C_CTYPE_ASCII +#undef c_isgraph +#define c_isgraph(c) \ + ({ int __c = (c); \ + (__c >= '!' && __c <= '~'); \ + }) +#endif + +#if C_CTYPE_ASCII +#undef c_isprint +#define c_isprint(c) \ + ({ int __c = (c); \ + (__c >= ' ' && __c <= '~'); \ + }) +#endif + +#if C_CTYPE_ASCII +#undef c_ispunct +#define c_ispunct(c) \ + ({ int _c = (c); \ + (c_isgraph (_c) && ! c_isalnum (_c)); \ + }) +#endif + +#undef c_isspace +#define c_isspace(c) \ + ({ int __c = (c); \ + (__c == ' ' || __c == '\t' \ + || __c == '\n' || __c == '\v' || __c == '\f' || __c == '\r'); \ + }) + +#if C_CTYPE_CONSECUTIVE_UPPERCASE +#undef c_isupper +#define c_isupper(c) \ + ({ int __c = (c); \ + (__c >= 'A' && __c <= 'Z'); \ + }) +#endif + +#if C_CTYPE_CONSECUTIVE_DIGITS \ + && C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE +#if C_CTYPE_ASCII +#undef c_isxdigit +#define c_isxdigit(c) \ + ({ int __c = (c); \ + ((__c >= '0' && __c <= '9') \ + || ((__c & ~0x20) >= 'A' && (__c & ~0x20) <= 'F')); \ + }) +#else +#undef c_isxdigit +#define c_isxdigit(c) \ + ({ int __c = (c); \ + ((__c >= '0' && __c <= '9') \ + || (__c >= 'A' && __c <= 'F') \ + || (__c >= 'a' && __c <= 'f')); \ + }) +#endif +#endif + +#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE +#undef c_tolower +#define c_tolower(c) \ + ({ int __c = (c); \ + (__c >= 'A' && __c <= 'Z' ? __c - 'A' + 'a' : __c); \ + }) +#undef c_toupper +#define c_toupper(c) \ + ({ int __c = (c); \ + (__c >= 'a' && __c <= 'z' ? __c - 'a' + 'A' : __c); \ + }) +#endif + +#endif /* optimizing for speed */ -C_CTYPE_INLINE int -c_toupper (int c) -{ - switch (c) - { - _C_CTYPE_LOWER: - return c - 'a' + 'A'; - default: - return c; - } -} #ifdef __cplusplus } #endif -_GL_INLINE_HEADER_END - #endif /* C_CTYPE_H */ diff --git a/lib/c-strcase.h b/lib/c-strcase.h index 55fd801ee..ee3bd3f72 100644 --- a/lib/c-strcase.h +++ b/lib/c-strcase.h @@ -1,5 +1,5 @@ /* Case-insensitive string comparison functions in C locale. - Copyright (C) 1995-1996, 2001, 2003, 2005, 2009-2015 Free Software + Copyright (C) 1995-1996, 2001, 2003, 2005, 2009-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/c-strcasecmp.c b/lib/c-strcasecmp.c index ce0223fcb..5059cc659 100644 --- a/lib/c-strcasecmp.c +++ b/lib/c-strcasecmp.c @@ -1,5 +1,5 @@ /* c-strcasecmp.c -- case insensitive string comparator in C locale - Copyright (C) 1998-1999, 2005-2006, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 1998-1999, 2005-2006, 2009-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/c-strcaseeq.h b/lib/c-strcaseeq.h index ce4b82dd1..44d375148 100644 --- a/lib/c-strcaseeq.h +++ b/lib/c-strcaseeq.h @@ -1,5 +1,5 @@ /* Optimized case-insensitive string comparison in C locale. - Copyright (C) 2001-2002, 2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2001-2002, 2007, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published @@ -33,6 +33,9 @@ # if C_CTYPE_ASCII # define CASEEQ(other,upper) \ (c_isupper (upper) ? ((other) & ~0x20) == (upper) : (other) == (upper)) +# elif C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE +# define CASEEQ(other,upper) \ + (c_isupper (upper) ? (other) == (upper) || (other) == (upper) - 'A' + 'a' : (other) == (upper)) # else # define CASEEQ(other,upper) \ (c_toupper (other) == (upper)) diff --git a/lib/c-strncasecmp.c b/lib/c-strncasecmp.c index 7a7f61df8..614598156 100644 --- a/lib/c-strncasecmp.c +++ b/lib/c-strncasecmp.c @@ -1,5 +1,5 @@ /* c-strncasecmp.c -- case insensitive string comparator in C locale - Copyright (C) 1998-1999, 2005-2006, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 1998-1999, 2005-2006, 2009-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/canonicalize-lgpl.c b/lib/canonicalize-lgpl.c index 624a40eb9..a999c9c84 100644 --- a/lib/canonicalize-lgpl.c +++ b/lib/canonicalize-lgpl.c @@ -1,5 +1,5 @@ /* Return the canonical absolute name of a given file. - Copyright (C) 1996-2015 Free Software Foundation, Inc. + Copyright (C) 1996-2014 Free Software Foundation, Inc. This file is part of the GNU C Library. This program is free software: you can redistribute it and/or modify diff --git a/lib/ceil.c b/lib/ceil.c index 236d258b1..7e810357b 100644 --- a/lib/ceil.c +++ b/lib/ceil.c @@ -1,5 +1,5 @@ /* Round towards positive infinity. - Copyright (C) 2007, 2010-2015 Free Software Foundation, Inc. + Copyright (C) 2007, 2010-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/close.c b/lib/close.c index c1f112590..9d2e0276a 100644 --- a/lib/close.c +++ b/lib/close.c @@ -1,5 +1,5 @@ /* close replacement. - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/config.charset b/lib/config.charset index 8083c6029..8fe2507d9 100644 --- a/lib/config.charset +++ b/lib/config.charset @@ -1,7 +1,7 @@ #! /bin/sh # Output a system dependent table of character encoding aliases. # -# Copyright (C) 2000-2004, 2006-2015 Free Software Foundation, Inc. +# Copyright (C) 2000-2004, 2006-2014 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU Lesser General Public License as published by @@ -348,10 +348,12 @@ case "$os" in #echo "sun_eu_greek ?" # what is this? echo "UTF-8 UTF-8" ;; - freebsd*) + freebsd* | os2*) # FreeBSD 4.2 doesn't have nl_langinfo(CODESET); therefore # localcharset.c falls back to using the full locale name # from the environment variables. + # Likewise for OS/2. OS/2 has XFree86 just like FreeBSD. Just + # reuse FreeBSD's locale data for OS/2. echo "C ASCII" echo "US-ASCII ASCII" for l in la_LN lt_LN; do diff --git a/lib/connect.c b/lib/connect.c index bde8a60bc..295fe95d8 100644 --- a/lib/connect.c +++ b/lib/connect.c @@ -1,6 +1,6 @@ /* connect.c --- wrappers for Windows connect function - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/copysign.c b/lib/copysign.c index 761320bc0..616ea356e 100644 --- a/lib/copysign.c +++ b/lib/copysign.c @@ -1,5 +1,5 @@ /* Copy sign into another 'double' number. - Copyright (C) 2011-2015 Free Software Foundation, Inc. + Copyright (C) 2011-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/dirent.in.h b/lib/dirent.in.h index e4490caf5..3418bd9dc 100644 --- a/lib/dirent.in.h +++ b/lib/dirent.in.h @@ -1,5 +1,5 @@ /* A GNU-like . - Copyright (C) 2006-2015 Free Software Foundation, Inc. + Copyright (C) 2006-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -77,7 +77,6 @@ typedef struct gl_directory DIR; # if !(defined __cplusplus && defined GNULIB_NAMESPACE) # undef opendir # define opendir rpl_opendir -# define GNULIB_defined_opendir 1 # endif _GL_FUNCDECL_RPL (opendir, DIR *, (const char *dir_name) _GL_ARG_NONNULL ((1))); _GL_CXXALIAS_RPL (opendir, DIR *, (const char *dir_name)); @@ -129,7 +128,6 @@ _GL_WARN_ON_USE (rewinddir, "rewinddir is not portable - " # if !(defined __cplusplus && defined GNULIB_NAMESPACE) # undef closedir # define closedir rpl_closedir -# define GNULIB_defined_closedir 1 # endif _GL_FUNCDECL_RPL (closedir, int, (DIR *dirp) _GL_ARG_NONNULL ((1))); _GL_CXXALIAS_RPL (closedir, int, (DIR *dirp)); diff --git a/lib/dirfd.c b/lib/dirfd.c index c196c6601..86f8e0a1a 100644 --- a/lib/dirfd.c +++ b/lib/dirfd.c @@ -1,6 +1,6 @@ /* dirfd.c -- return the file descriptor associated with an open DIR* - Copyright (C) 2001, 2006, 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2001, 2006, 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/dirname-lgpl.c b/lib/dirname-lgpl.c index c1e610109..121d38754 100644 --- a/lib/dirname-lgpl.c +++ b/lib/dirname-lgpl.c @@ -1,6 +1,6 @@ /* dirname.c -- return all but the last element in a file name - Copyright (C) 1990, 1998, 2000-2001, 2003-2006, 2009-2015 Free Software + Copyright (C) 1990, 1998, 2000-2001, 2003-2006, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/dirname.h b/lib/dirname.h index abb058497..e31cb6190 100644 --- a/lib/dirname.h +++ b/lib/dirname.h @@ -1,6 +1,6 @@ /* Take file names apart into directory and base names. - Copyright (C) 1998, 2001, 2003-2006, 2009-2015 Free Software Foundation, + Copyright (C) 1998, 2001, 2003-2006, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify @@ -31,10 +31,6 @@ # define DOUBLE_SLASH_IS_DISTINCT_ROOT 0 # endif -#ifdef __cplusplus -extern "C" { -#endif - # if GNULIB_DIRNAME char *base_name (char const *file); char *dir_name (char const *file); @@ -47,8 +43,4 @@ char *last_component (char const *file) _GL_ATTRIBUTE_PURE; bool strip_trailing_slashes (char *file); -#ifdef __cplusplus -} /* extern "C" */ -#endif - #endif /* not DIRNAME_H_ */ diff --git a/lib/dosname.h b/lib/dosname.h index 42e3186ab..b81163d4b 100644 --- a/lib/dosname.h +++ b/lib/dosname.h @@ -1,6 +1,6 @@ /* File names on MS-DOS/Windows systems. - Copyright (C) 2000-2001, 2004-2006, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2000-2001, 2004-2006, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/dup2.c b/lib/dup2.c index 7f984ccb0..9709b7a64 100644 --- a/lib/dup2.c +++ b/lib/dup2.c @@ -1,6 +1,6 @@ /* Duplicate an open file descriptor to a specified file descriptor. - Copyright (C) 1999, 2004-2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 1999, 2004-2007, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/duplocale.c b/lib/duplocale.c index 9fdb26811..86d5ce59a 100644 --- a/lib/duplocale.c +++ b/lib/duplocale.c @@ -1,5 +1,5 @@ /* Duplicate a locale object. - Copyright (C) 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/errno.in.h b/lib/errno.in.h index 5f1aa8dce..8dbb5f97a 100644 --- a/lib/errno.in.h +++ b/lib/errno.in.h @@ -1,6 +1,6 @@ /* A POSIX-like . - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/fcntl.in.h b/lib/fcntl.in.h index 1c3b2c83f..1cd197002 100644 --- a/lib/fcntl.in.h +++ b/lib/fcntl.in.h @@ -1,6 +1,6 @@ /* Like , but with non-working flags defined to 0. - Copyright (C) 2006-2015 Free Software Foundation, Inc. + Copyright (C) 2006-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -34,7 +34,7 @@ extern "C" { ... } block, which leads to errors in C++ mode with the overridden from gnulib. These errors are known to be gone with g++ version >= 4.3. */ -#if !(defined __GLIBC__ || defined __UCLIBC__) || (defined __cplusplus && defined GNULIB_NAMESPACE && (defined __ICC || !(__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3)))) +#if !(defined __GLIBC__ || defined __UCLIBC__) || (defined __cplusplus && defined GNULIB_NAMESPACE && !(__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3))) # include #endif #@INCLUDE_NEXT@ @NEXT_FCNTL_H@ @@ -53,7 +53,7 @@ extern "C" { ... } block, which leads to errors in C++ mode with the overridden from gnulib. These errors are known to be gone with g++ version >= 4.3. */ -#if !(defined __GLIBC__ || defined __UCLIBC__) || (defined __cplusplus && defined GNULIB_NAMESPACE && (defined __ICC || !(__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3)))) +#if !(defined __GLIBC__ || defined __UCLIBC__) || (defined __cplusplus && defined GNULIB_NAMESPACE && !(__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3))) # include #endif /* The include_next requires a split double-inclusion guard. */ @@ -186,22 +186,6 @@ _GL_WARN_ON_USE (openat, "openat is not portable - " /* Fix up the O_* macros. */ -/* AIX 7.1 with XL C 12.1 defines O_CLOEXEC, O_NOFOLLOW, and O_TTY_INIT - to values outside 'int' range, so omit these misdefinitions. - But avoid namespace pollution on non-AIX systems. */ -#ifdef _AIX -# include -# if defined O_CLOEXEC && ! (INT_MIN <= O_CLOEXEC && O_CLOEXEC <= INT_MAX) -# undef O_CLOEXEC -# endif -# if defined O_NOFOLLOW && ! (INT_MIN <= O_NOFOLLOW && O_NOFOLLOW <= INT_MAX) -# undef O_NOFOLLOW -# endif -# if defined O_TTY_INIT && ! (INT_MIN <= O_TTY_INIT && O_TTY_INIT <= INT_MAX) -# undef O_TTY_INIT -# endif -#endif - #if !defined O_DIRECT && defined O_DIRECTIO /* Tru64 spells it 'O_DIRECTIO'. */ # define O_DIRECT O_DIRECTIO diff --git a/lib/fd-hook.c b/lib/fd-hook.c index 158b1ecda..fd07578f1 100644 --- a/lib/fd-hook.c +++ b/lib/fd-hook.c @@ -1,5 +1,5 @@ /* Hook for making making file descriptor functions close(), ioctl() extensible. - Copyright (C) 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2009-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2009. This program is free software: you can redistribute it and/or modify it diff --git a/lib/fd-hook.h b/lib/fd-hook.h index 7010ccaef..5ff0f73fc 100644 --- a/lib/fd-hook.h +++ b/lib/fd-hook.h @@ -1,5 +1,5 @@ /* Hook for making making file descriptor functions close(), ioctl() extensible. - Copyright (C) 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/float+.h b/lib/float+.h index c3d28a598..085c379b1 100644 --- a/lib/float+.h +++ b/lib/float+.h @@ -1,5 +1,5 @@ /* Supplemental information about the floating-point formats. - Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2007. This program is free software; you can redistribute it and/or modify diff --git a/lib/float.c b/lib/float.c index 9a2d0f723..3faa5eede 100644 --- a/lib/float.c +++ b/lib/float.c @@ -1,5 +1,5 @@ /* Auxiliary definitions for . - Copyright (C) 2011-2015 Free Software Foundation, Inc. + Copyright (C) 2011-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/float.in.h b/lib/float.in.h index dab2a2b44..e814eaba5 100644 --- a/lib/float.in.h +++ b/lib/float.in.h @@ -1,6 +1,6 @@ /* A correct . - Copyright (C) 2007-2015 Free Software Foundation, Inc. + Copyright (C) 2007-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/flock.c b/lib/flock.c index a591f1e38..928e151b0 100644 --- a/lib/flock.c +++ b/lib/flock.c @@ -6,7 +6,7 @@ Written by Richard W.M. Jones - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 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 diff --git a/lib/floor.c b/lib/floor.c index 010131144..a00f937ed 100644 --- a/lib/floor.c +++ b/lib/floor.c @@ -1,5 +1,5 @@ /* Round towards negative infinity. - Copyright (C) 2007, 2010-2015 Free Software Foundation, Inc. + Copyright (C) 2007, 2010-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/frexp.c b/lib/frexp.c index 21edf0afb..6eff94574 100644 --- a/lib/frexp.c +++ b/lib/frexp.c @@ -1,5 +1,5 @@ /* Split a double into fraction and mantissa. - Copyright (C) 2007-2015 Free Software Foundation, Inc. + Copyright (C) 2007-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/fstat.c b/lib/fstat.c index 71ca7b0cb..17ccc8e29 100644 --- a/lib/fstat.c +++ b/lib/fstat.c @@ -1,5 +1,5 @@ /* fstat() replacement. - Copyright (C) 2011-2015 Free Software Foundation, Inc. + Copyright (C) 2011-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/fsync.c b/lib/fsync.c index 8ef6dbee8..99475ff65 100644 --- a/lib/fsync.c +++ b/lib/fsync.c @@ -7,7 +7,7 @@ Written by Richard W.M. Jones - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 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 diff --git a/lib/full-read.c b/lib/full-read.c index ac7fb5651..4d67afb92 100644 --- a/lib/full-read.c +++ b/lib/full-read.c @@ -1,5 +1,5 @@ /* An interface to read that retries after partial reads and interrupts. - Copyright (C) 2002-2003, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2002-2003, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/full-read.h b/lib/full-read.h index 950b9bd3f..954b94dce 100644 --- a/lib/full-read.h +++ b/lib/full-read.h @@ -1,6 +1,6 @@ /* An interface to read() that reads all it is asked to read. - Copyright (C) 2002, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2002, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -13,6 +13,7 @@ GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License + along with this program; if not, read to the Free Software Foundation, along with this program. If not, see . */ #include diff --git a/lib/full-write.c b/lib/full-write.c index df3bad0d5..6a77b7b45 100644 --- a/lib/full-write.c +++ b/lib/full-write.c @@ -1,6 +1,6 @@ /* An interface to read and write that retries (if necessary) until complete. - Copyright (C) 1993-1994, 1997-2006, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 1993-1994, 1997-2006, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/full-write.h b/lib/full-write.h index 607facd35..2fab6fa02 100644 --- a/lib/full-write.h +++ b/lib/full-write.h @@ -1,6 +1,6 @@ /* An interface to write() that writes all it is asked to write. - Copyright (C) 2002-2003, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2002-2003, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/gai_strerror.c b/lib/gai_strerror.c index fbef3bbe9..d0c589da1 100644 --- a/lib/gai_strerror.c +++ b/lib/gai_strerror.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1997, 2001-2002, 2004-2006, 2008-2015 Free Software +/* Copyright (C) 1997, 2001-2002, 2004-2006, 2008-2014 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Philip Blundell , 1997. diff --git a/lib/getaddrinfo.c b/lib/getaddrinfo.c index 9d3384f71..6581dd55a 100644 --- a/lib/getaddrinfo.c +++ b/lib/getaddrinfo.c @@ -1,5 +1,5 @@ /* Get address information (partial implementation). - Copyright (C) 1997, 2001-2002, 2004-2015 Free Software Foundation, Inc. + Copyright (C) 1997, 2001-2002, 2004-2014 Free Software Foundation, Inc. Contributed by Simon Josefsson . This program is free software; you can redistribute it and/or modify diff --git a/lib/getlogin.c b/lib/getlogin.c index 5fc54b851..f8cfe5d78 100644 --- a/lib/getlogin.c +++ b/lib/getlogin.c @@ -1,6 +1,6 @@ /* Provide a working getlogin for systems which lack it. - Copyright (C) 2010-2015 Free Software Foundation, Inc. + Copyright (C) 2010-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/getpeername.c b/lib/getpeername.c index ce2e105a6..e5b3eaea3 100644 --- a/lib/getpeername.c +++ b/lib/getpeername.c @@ -1,6 +1,6 @@ /* getpeername.c --- wrappers for Windows getpeername function - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/getsockname.c b/lib/getsockname.c index 6f24e7c18..d26bae592 100644 --- a/lib/getsockname.c +++ b/lib/getsockname.c @@ -1,6 +1,6 @@ /* getsockname.c --- wrappers for Windows getsockname function - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/getsockopt.c b/lib/getsockopt.c index ccd2e6fe7..0b2fb2b73 100644 --- a/lib/getsockopt.c +++ b/lib/getsockopt.c @@ -1,6 +1,6 @@ /* getsockopt.c --- wrappers for Windows getsockopt function - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/gettext.h b/lib/gettext.h index 3770ca0e8..330d8dad4 100644 --- a/lib/gettext.h +++ b/lib/gettext.h @@ -1,5 +1,5 @@ /* Convenience header for conditional use of GNU . - Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2009-2015 Free Software + Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2009-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/gettimeofday.c b/lib/gettimeofday.c index a615f3b25..c4e40fbe9 100644 --- a/lib/gettimeofday.c +++ b/lib/gettimeofday.c @@ -1,6 +1,6 @@ /* Provide gettimeofday for systems that don't have it or for which it's broken. - Copyright (C) 2001-2003, 2005-2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2001-2003, 2005-2007, 2009-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/glthread/lock.h b/lib/glthread/lock.h index 1aafd8bb4..66c78a6cd 100644 --- a/lib/glthread/lock.h +++ b/lib/glthread/lock.h @@ -1,7 +1,7 @@ #ifndef SCM_GLTHREADS_H #define SCM_GLTHREADS_H -/* Copyright (C) 2014, 2015 Free Software Foundation, Inc. +/* Copyright (C) 2014 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 License diff --git a/lib/iconv.c b/lib/iconv.c index 850c8b77b..a6dfed355 100644 --- a/lib/iconv.c +++ b/lib/iconv.c @@ -1,5 +1,5 @@ /* Character set conversion. - Copyright (C) 1999-2001, 2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 1999-2001, 2007, 2009-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/iconv.in.h b/lib/iconv.in.h index 6b3d245c9..ed95ed719 100644 --- a/lib/iconv.in.h +++ b/lib/iconv.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 2007-2015 Free Software Foundation, Inc. + Copyright (C) 2007-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/iconv_close.c b/lib/iconv_close.c index d728c0741..6e286734d 100644 --- a/lib/iconv_close.c +++ b/lib/iconv_close.c @@ -1,5 +1,5 @@ /* Character set conversion. - Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/iconv_open-aix.h b/lib/iconv_open-aix.h index 129e03084..a598e819d 100644 --- a/lib/iconv_open-aix.h +++ b/lib/iconv_open-aix.h @@ -1,4 +1,4 @@ -/* ANSI-C code produced by gperf version 3.0.4 */ +/* ANSI-C code produced by gperf version 3.0.3 */ /* Command-line: gperf -m 10 ./iconv_open-aix.gperf */ /* Computed positions: -k'4,$' */ diff --git a/lib/iconv_open-hpux.h b/lib/iconv_open-hpux.h index 3bcff76a7..8f9f0a9ad 100644 --- a/lib/iconv_open-hpux.h +++ b/lib/iconv_open-hpux.h @@ -1,4 +1,4 @@ -/* ANSI-C code produced by gperf version 3.0.4 */ +/* ANSI-C code produced by gperf version 3.0.3 */ /* Command-line: gperf -m 10 ./iconv_open-hpux.gperf */ /* Computed positions: -k'4,$' */ @@ -272,7 +272,7 @@ static const struct mapping mappings[] = #ifdef __GNUC__ __inline -#if defined __GNUC_STDC_INLINE__ || defined __GNUC_GNU_INLINE__ +#ifdef __GNUC_STDC_INLINE__ __attribute__ ((__gnu_inline__)) #endif #endif diff --git a/lib/iconv_open-irix.h b/lib/iconv_open-irix.h index 74ceb8f57..520582e52 100644 --- a/lib/iconv_open-irix.h +++ b/lib/iconv_open-irix.h @@ -1,4 +1,4 @@ -/* ANSI-C code produced by gperf version 3.0.4 */ +/* ANSI-C code produced by gperf version 3.0.3 */ /* Command-line: gperf -m 10 ./iconv_open-irix.gperf */ /* Computed positions: -k'1,$' */ @@ -172,7 +172,7 @@ static const struct mapping mappings[] = #ifdef __GNUC__ __inline -#if defined __GNUC_STDC_INLINE__ || defined __GNUC_GNU_INLINE__ +#ifdef __GNUC_STDC_INLINE__ __attribute__ ((__gnu_inline__)) #endif #endif diff --git a/lib/iconv_open-osf.h b/lib/iconv_open-osf.h index 4d3576495..85e4c0f8f 100644 --- a/lib/iconv_open-osf.h +++ b/lib/iconv_open-osf.h @@ -1,4 +1,4 @@ -/* ANSI-C code produced by gperf version 3.0.4 */ +/* ANSI-C code produced by gperf version 3.0.3 */ /* Command-line: gperf -m 10 ./iconv_open-osf.gperf */ /* Computed positions: -k'4,$' */ @@ -251,7 +251,7 @@ static const struct mapping mappings[] = #ifdef __GNUC__ __inline -#if defined __GNUC_STDC_INLINE__ || defined __GNUC_GNU_INLINE__ +#ifdef __GNUC_STDC_INLINE__ __attribute__ ((__gnu_inline__)) #endif #endif diff --git a/lib/iconv_open.c b/lib/iconv_open.c index 07174331f..fc19d44e2 100644 --- a/lib/iconv_open.c +++ b/lib/iconv_open.c @@ -1,5 +1,5 @@ /* Character set conversion. - Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/iconveh.h b/lib/iconveh.h index d02c97502..43b23eb39 100644 --- a/lib/iconveh.h +++ b/lib/iconveh.h @@ -1,5 +1,5 @@ /* Character set conversion handler type. - Copyright (C) 2001-2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2001-2007, 2009-2014 Free Software Foundation, Inc. Written by Bruno Haible. This program is free software: you can redistribute it and/or modify diff --git a/lib/ignore-value.h b/lib/ignore-value.h new file mode 100644 index 000000000..86cfad77b --- /dev/null +++ b/lib/ignore-value.h @@ -0,0 +1,37 @@ +/* ignore a function return without a compiler warning + + Copyright (C) 2008-2009 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/* Written by Jim Meyering. */ + +/* Use these functions to avoid a warning when using a function declared with + gcc's warn_unused_result attribute, but for which you really do want to + ignore the result. Traditionally, people have used a "(void)" cast to + indicate that a function's return value is deliberately unused. However, + if the function is declared with __attribute__((warn_unused_result)), + gcc issues a warning even with the cast. + + Caution: most of the time, you really should heed gcc's warning, and + check the return value. However, in those exceptional cases in which + you're sure you know what you're doing, use this function. + + For the record, here's one of the ignorable warnings: + "copy.c:233: warning: ignoring return value of 'fchown', + declared with attribute warn_unused_result". */ + +static inline void ignore_value (int i) { (void) i; } +static inline void ignore_ptr (void* p) { (void) p; } +/* FIXME: what about aggregate types? */ diff --git a/lib/inet_ntop.c b/lib/inet_ntop.c index 4620c2c09..462951968 100644 --- a/lib/inet_ntop.c +++ b/lib/inet_ntop.c @@ -1,6 +1,6 @@ /* inet_ntop.c -- convert IPv4 and IPv6 addresses from binary to text form - Copyright (C) 2005-2006, 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2005-2006, 2008-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/inet_pton.c b/lib/inet_pton.c index 1fc159a10..52ae31784 100644 --- a/lib/inet_pton.c +++ b/lib/inet_pton.c @@ -1,6 +1,6 @@ /* inet_pton.c -- convert IPv4 and IPv6 addresses from text to binary form - Copyright (C) 2006, 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2006, 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isfinite.c b/lib/isfinite.c index 3792b9974..18c1d217f 100644 --- a/lib/isfinite.c +++ b/lib/isfinite.c @@ -1,5 +1,5 @@ /* Test for finite value (zero, subnormal, or normal, and not infinite or NaN). - Copyright (C) 2007-2015 Free Software Foundation, Inc. + Copyright (C) 2007-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isinf.c b/lib/isinf.c index 4c79580e3..217de79df 100644 --- a/lib/isinf.c +++ b/lib/isinf.c @@ -1,5 +1,5 @@ /* Test for positive or negative infinity. - Copyright (C) 2007-2015 Free Software Foundation, Inc. + Copyright (C) 2007-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnan.c b/lib/isnan.c index d70c9348a..1557733bf 100644 --- a/lib/isnan.c +++ b/lib/isnan.c @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007-2015 Free Software Foundation, Inc. + Copyright (C) 2007-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnand-nolibm.h b/lib/isnand-nolibm.h index f5204f328..b0498ef08 100644 --- a/lib/isnand-nolibm.h +++ b/lib/isnand-nolibm.h @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007-2015 Free Software Foundation, Inc. + Copyright (C) 2007-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnand.c b/lib/isnand.c index 34e604fb7..11efbf8d8 100644 --- a/lib/isnand.c +++ b/lib/isnand.c @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnanf-nolibm.h b/lib/isnanf-nolibm.h index b3a280c70..9e2aa2f54 100644 --- a/lib/isnanf-nolibm.h +++ b/lib/isnanf-nolibm.h @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007-2015 Free Software Foundation, Inc. + Copyright (C) 2007-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnanf.c b/lib/isnanf.c index 7d21bddb4..c7a66ca3a 100644 --- a/lib/isnanf.c +++ b/lib/isnanf.c @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnanl-nolibm.h b/lib/isnanl-nolibm.h index 48a02b24e..9cf090caa 100644 --- a/lib/isnanl-nolibm.h +++ b/lib/isnanl-nolibm.h @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007-2015 Free Software Foundation, Inc. + Copyright (C) 2007-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnanl.c b/lib/isnanl.c index 9ec4eb31f..dbf9d5dd1 100644 --- a/lib/isnanl.c +++ b/lib/isnanl.c @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/itold.c b/lib/itold.c index 4963b9b2d..136742eab 100644 --- a/lib/itold.c +++ b/lib/itold.c @@ -1,5 +1,5 @@ /* Replacement for 'int' to 'long double' conversion routine. - Copyright (C) 2011-2015 Free Software Foundation, Inc. + Copyright (C) 2011-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/langinfo.in.h b/lib/langinfo.in.h index cf992cede..f4a281a33 100644 --- a/lib/langinfo.in.h +++ b/lib/langinfo.in.h @@ -1,5 +1,5 @@ /* Substitute for and wrapper around . - Copyright (C) 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2009-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -49,10 +49,7 @@ typedef int nl_item; # define CODESET 10000 /* nl_langinfo items of the LC_NUMERIC category */ # define RADIXCHAR 10001 -# define DECIMAL_POINT RADIXCHAR # define THOUSEP 10002 -# define THOUSANDS_SEP THOUSEP -# define GROUPING 10114 /* nl_langinfo items of the LC_TIME category */ # define D_T_FMT 10003 # define D_FMT 10004 @@ -105,21 +102,6 @@ typedef int nl_item; # define ALT_DIGITS 10051 /* nl_langinfo items of the LC_MONETARY category */ # define CRNCYSTR 10052 -# define CURRENCY_SYMBOL CRNCYSTR -# define INT_CURR_SYMBOL 10100 -# define MON_DECIMAL_POINT 10101 -# define MON_THOUSANDS_SEP 10102 -# define MON_GROUPING 10103 -# define POSITIVE_SIGN 10104 -# define NEGATIVE_SIGN 10105 -# define FRAC_DIGITS 10106 -# define INT_FRAC_DIGITS 10107 -# define P_CS_PRECEDES 10108 -# define N_CS_PRECEDES 10109 -# define P_SEP_BY_SPACE 10110 -# define N_SEP_BY_SPACE 10111 -# define P_SIGN_POSN 10112 -# define N_SIGN_POSN 10113 /* nl_langinfo items of the LC_MESSAGES category */ # define YESEXPR 10053 # define NOEXPR 10054 diff --git a/lib/link.c b/lib/link.c index ebdd9f4ef..9db1f8cef 100644 --- a/lib/link.c +++ b/lib/link.c @@ -1,6 +1,6 @@ /* Emulate link on platforms that lack it, namely native Windows platforms. - Copyright (C) 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2009-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/listen.c b/lib/listen.c index 7cf092587..912f1b7a7 100644 --- a/lib/listen.c +++ b/lib/listen.c @@ -1,6 +1,6 @@ /* listen.c --- wrappers for Windows listen function - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/localcharset.c b/lib/localcharset.c index 6dffe3454..7f09567ce 100644 --- a/lib/localcharset.c +++ b/lib/localcharset.c @@ -1,6 +1,6 @@ /* Determine a canonical name for the current locale's character encoding. - Copyright (C) 2000-2006, 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2000-2006, 2008-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -34,7 +34,6 @@ #if defined _WIN32 || defined __WIN32__ # define WINDOWS_NATIVE -# include #endif #if defined __EMX__ @@ -128,7 +127,7 @@ get_charset_aliases (void) cp = charset_aliases; if (cp == NULL) { -#if !(defined DARWIN7 || defined VMS || defined WINDOWS_NATIVE || defined __CYGWIN__ || defined OS2) +#if !(defined DARWIN7 || defined VMS || defined WINDOWS_NATIVE || defined __CYGWIN__) const char *dir; const char *base = "charset.alias"; char *file_name; @@ -342,36 +341,6 @@ get_charset_aliases (void) "CP54936" "\0" "GB18030" "\0" "CP65001" "\0" "UTF-8" "\0"; # endif -# if defined OS2 - /* To avoid the troubles of installing a separate file in the same - directory as the DLL and of retrieving the DLL's directory at - runtime, simply inline the aliases here. */ - - /* The list of encodings is taken from "List of OS/2 Codepages" - by Alex Taylor: - . - See also "IBM Globalization - Code page identifiers": - . */ - cp = "CP813" "\0" "ISO-8859-7" "\0" - "CP878" "\0" "KOI8-R" "\0" - "CP819" "\0" "ISO-8859-1" "\0" - "CP912" "\0" "ISO-8859-2" "\0" - "CP913" "\0" "ISO-8859-3" "\0" - "CP914" "\0" "ISO-8859-4" "\0" - "CP915" "\0" "ISO-8859-5" "\0" - "CP916" "\0" "ISO-8859-8" "\0" - "CP920" "\0" "ISO-8859-9" "\0" - "CP921" "\0" "ISO-8859-13" "\0" - "CP923" "\0" "ISO-8859-15" "\0" - "CP954" "\0" "EUC-JP" "\0" - "CP964" "\0" "EUC-TW" "\0" - "CP970" "\0" "EUC-KR" "\0" - "CP1089" "\0" "ISO-8859-6" "\0" - "CP1208" "\0" "UTF-8" "\0" - "CP1381" "\0" "GB2312" "\0" - "CP1386" "\0" "GBK" "\0" - "CP3372" "\0" "EUC-JP" "\0"; -# endif #endif charset_aliases = cp; @@ -492,34 +461,14 @@ locale_charset (void) static char buf[2 + 10 + 1]; - /* The Windows API has a function returning the locale's codepage as - a number, but the value doesn't change according to what the - 'setlocale' call specified. So we use it as a last resort, in - case the string returned by 'setlocale' doesn't specify the - codepage. */ - char *current_locale = setlocale (LC_ALL, NULL); - char *pdot; - - /* If they set different locales for different categories, - 'setlocale' will return a semi-colon separated list of locale - values. To make sure we use the correct one, we choose LC_CTYPE. */ - if (strchr (current_locale, ';')) - current_locale = setlocale (LC_CTYPE, NULL); - - pdot = strrchr (current_locale, '.'); - if (pdot) - sprintf (buf, "CP%s", pdot + 1); - else - { - /* The Windows API has a function returning the locale's codepage as a - number: GetACP(). - When the output goes to a console window, it needs to be provided in - GetOEMCP() encoding if the console is using a raster font, or in - GetConsoleOutputCP() encoding if it is using a TrueType font. - But in GUI programs and for output sent to files and pipes, GetACP() - encoding is the best bet. */ - sprintf (buf, "CP%u", GetACP ()); - } + /* The Windows API has a function returning the locale's codepage as a + number: GetACP(). + When the output goes to a console window, it needs to be provided in + GetOEMCP() encoding if the console is using a raster font, or in + GetConsoleOutputCP() encoding if it is using a TrueType font. + But in GUI programs and for output sent to files and pipes, GetACP() + encoding is the best bet. */ + sprintf (buf, "CP%u", GetACP ()); codeset = buf; #elif defined OS2 @@ -529,8 +478,6 @@ locale_charset (void) ULONG cp[3]; ULONG cplen; - codeset = NULL; - /* Allow user to override the codeset, as set in the operating system, with standard language environment variables. */ locale = getenv ("LC_ALL"); @@ -562,12 +509,10 @@ locale_charset (void) } } - /* For the POSIX locale, don't use the system's codepage. */ - if (strcmp (locale, "C") == 0 || strcmp (locale, "POSIX") == 0) - codeset = ""; + /* Resolve through the charset.alias file. */ + codeset = locale; } - - if (codeset == NULL) + else { /* OS/2 has a function returning the locale's codepage as a number. */ if (DosQueryCp (sizeof (cp), cp, &cplen)) diff --git a/lib/localcharset.h b/lib/localcharset.h index 86eaec198..4b104c304 100644 --- a/lib/localcharset.h +++ b/lib/localcharset.h @@ -1,5 +1,5 @@ /* Determine a canonical name for the current locale's character encoding. - Copyright (C) 2000-2003, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2000-2003, 2009-2014 Free Software Foundation, Inc. This file is part of the GNU CHARSET Library. This program is free software; you can redistribute it and/or modify diff --git a/lib/locale.in.h b/lib/locale.in.h index 4a1e229f3..a10b129ca 100644 --- a/lib/locale.in.h +++ b/lib/locale.in.h @@ -1,5 +1,5 @@ /* A POSIX . - Copyright (C) 2007-2015 Free Software Foundation, Inc. + Copyright (C) 2007-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/localeconv.c b/lib/localeconv.c index e8fe69d34..ed2767be0 100644 --- a/lib/localeconv.c +++ b/lib/localeconv.c @@ -1,5 +1,5 @@ /* Query locale dependent information for formatting numbers. - Copyright (C) 2012-2015 Free Software Foundation, Inc. + Copyright (C) 2012-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/log.c b/lib/log.c index e09b50c58..ef8d332f8 100644 --- a/lib/log.c +++ b/lib/log.c @@ -1,5 +1,5 @@ /* Logarithm. - Copyright (C) 2012-2015 Free Software Foundation, Inc. + Copyright (C) 2012-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/log1p.c b/lib/log1p.c index 10105f0a8..d1132d3e4 100644 --- a/lib/log1p.c +++ b/lib/log1p.c @@ -1,5 +1,5 @@ /* Natural logarithm of 1 plus argument. - Copyright (C) 2012-2015 Free Software Foundation, Inc. + Copyright (C) 2012-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/lstat.c b/lib/lstat.c index 221bd0a26..cff1188f3 100644 --- a/lib/lstat.c +++ b/lib/lstat.c @@ -1,6 +1,6 @@ /* Work around a bug of lstat on some systems - Copyright (C) 1997-2006, 2008-2015 Free Software Foundation, Inc. + Copyright (C) 1997-2006, 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/malloc.c b/lib/malloc.c index 7622f4d95..c6e292a74 100644 --- a/lib/malloc.c +++ b/lib/malloc.c @@ -1,6 +1,6 @@ /* malloc() function that is glibc compatible. - Copyright (C) 1997-1998, 2006-2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 1997-1998, 2006-2007, 2009-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/malloca.c b/lib/malloca.c index ef07acd7f..3e95f2333 100644 --- a/lib/malloca.c +++ b/lib/malloca.c @@ -1,5 +1,5 @@ /* Safe automatic memory allocation. - Copyright (C) 2003, 2006-2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2003, 2006-2007, 2009-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2003. This program is free software; you can redistribute it and/or modify diff --git a/lib/malloca.h b/lib/malloca.h index 37b106ffb..5810afa54 100644 --- a/lib/malloca.h +++ b/lib/malloca.h @@ -1,5 +1,5 @@ /* Safe automatic memory allocation. - Copyright (C) 2003-2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2003-2007, 2009-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2003. This program is free software; you can redistribute it and/or modify diff --git a/lib/math.c b/lib/math.c index ba2a6abd6..ddb2ded53 100644 --- a/lib/math.c +++ b/lib/math.c @@ -1,4 +1,3 @@ #include #define _GL_MATH_INLINE _GL_EXTERN_INLINE #include "math.h" -typedef int dummy; diff --git a/lib/math.in.h b/lib/math.in.h index b3803f8d0..4f2aa862b 100644 --- a/lib/math.in.h +++ b/lib/math.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 2002-2003, 2007-2015 Free Software Foundation, Inc. + Copyright (C) 2002-2003, 2007-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/mbrtowc.c b/lib/mbrtowc.c index a5d61a066..dff12962d 100644 --- a/lib/mbrtowc.c +++ b/lib/mbrtowc.c @@ -1,5 +1,5 @@ /* Convert multibyte character to wide character. - Copyright (C) 1999-2002, 2005-2015 Free Software Foundation, Inc. + Copyright (C) 1999-2002, 2005-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2008. This program is free software: you can redistribute it and/or modify @@ -328,7 +328,7 @@ mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps) size_t rpl_mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps) { -# if MBRTOWC_NULL_ARG2_BUG || MBRTOWC_RETVAL_BUG || MBRTOWC_EMPTY_INPUT_BUG +# if MBRTOWC_NULL_ARG2_BUG || MBRTOWC_RETVAL_BUG if (s == NULL) { pwc = NULL; @@ -337,11 +337,6 @@ rpl_mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps) } # endif -# if MBRTOWC_EMPTY_INPUT_BUG - if (n == 0) - return (size_t) -2; -# endif - # if MBRTOWC_RETVAL_BUG { static mbstate_t internal_state; diff --git a/lib/mbsinit.c b/lib/mbsinit.c index 59997834e..71bae341b 100644 --- a/lib/mbsinit.c +++ b/lib/mbsinit.c @@ -1,5 +1,5 @@ /* Test for initial conversion state. - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2008. This program is free software: you can redistribute it and/or modify diff --git a/lib/mbtowc-impl.h b/lib/mbtowc-impl.h index 737d7633a..df11ad2bf 100644 --- a/lib/mbtowc-impl.h +++ b/lib/mbtowc-impl.h @@ -1,5 +1,5 @@ /* Convert multibyte character to wide character. - Copyright (C) 2011-2015 Free Software Foundation, Inc. + Copyright (C) 2011-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/mbtowc.c b/lib/mbtowc.c index be0d60992..bd9d3aa6b 100644 --- a/lib/mbtowc.c +++ b/lib/mbtowc.c @@ -1,5 +1,5 @@ /* Convert multibyte character to wide character. - Copyright (C) 2011-2015 Free Software Foundation, Inc. + Copyright (C) 2011-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/memchr.c b/lib/memchr.c index a815ce78a..c1caad3a2 100644 --- a/lib/memchr.c +++ b/lib/memchr.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1991, 1993, 1996-1997, 1999-2000, 2003-2004, 2006, 2008-2015 +/* Copyright (C) 1991, 1993, 1996-1997, 1999-2000, 2003-2004, 2006, 2008-2014 Free Software Foundation, Inc. Based on strlen implementation by Torbjorn Granlund (tege@sics.se), diff --git a/lib/mkdir.c b/lib/mkdir.c index c76c57e1f..f1b802b57 100644 --- a/lib/mkdir.c +++ b/lib/mkdir.c @@ -1,7 +1,7 @@ /* On some systems, mkdir ("foo/", 0700) fails because of the trailing slash. On those systems, this wrapper removes the trailing slash. - Copyright (C) 2001, 2003, 2006, 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2001, 2003, 2006, 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/mkstemp.c b/lib/mkstemp.c index 3c0ee9eba..0af69f9c3 100644 --- a/lib/mkstemp.c +++ b/lib/mkstemp.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998-1999, 2001, 2005-2007, 2009-2015 Free Software +/* Copyright (C) 1998-1999, 2001, 2005-2007, 2009-2014 Free Software Foundation, Inc. This file is derived from the one in the GNU C Library. diff --git a/lib/mktime-internal.h b/lib/mktime-internal.h deleted file mode 100644 index 4287acf4a..000000000 --- a/lib/mktime-internal.h +++ /dev/null @@ -1,4 +0,0 @@ -#include -time_t mktime_internal (struct tm *, - struct tm * (*) (time_t const *, struct tm *), - time_t *); diff --git a/lib/mktime.c b/lib/mktime.c deleted file mode 100644 index 7b125a79e..000000000 --- a/lib/mktime.c +++ /dev/null @@ -1,741 +0,0 @@ -/* Convert a 'struct tm' to a time_t value. - Copyright (C) 1993-2015 Free Software Foundation, Inc. - This file is part of the GNU C Library. - Contributed by Paul Eggert . - - The GNU C Library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with the GNU C Library; if not, see - . */ - -/* Define this to have a standalone program to test this implementation of - mktime. */ -/* #define DEBUG 1 */ - -#ifndef _LIBC -# include -#endif - -/* Assume that leap seconds are possible, unless told otherwise. - If the host has a 'zic' command with a '-L leapsecondfilename' option, - then it supports leap seconds; otherwise it probably doesn't. */ -#ifndef LEAP_SECONDS_POSSIBLE -# define LEAP_SECONDS_POSSIBLE 1 -#endif - -#include - -#include - -#include /* For the real memcpy prototype. */ - -#if defined DEBUG && DEBUG -# include -# include -/* Make it work even if the system's libc has its own mktime routine. */ -# undef mktime -# define mktime my_mktime -#endif /* DEBUG */ - -/* Some of the code in this file assumes that signed integer overflow - silently wraps around. This assumption can't easily be programmed - around, nor can it be checked for portably at compile-time or - easily eliminated at run-time. - - Define WRAPV to 1 if the assumption is valid and if - #pragma GCC optimize ("wrapv") - does not trigger GCC bug 51793 - . - Otherwise, define it to 0; this forces the use of slower code that, - while not guaranteed by the C Standard, works on all production - platforms that we know about. */ -#ifndef WRAPV -# if (((__GNUC__ == 4 && 4 <= __GNUC_MINOR__) || 4 < __GNUC__) \ - && defined __GLIBC__) -# pragma GCC optimize ("wrapv") -# define WRAPV 1 -# else -# define WRAPV 0 -# endif -#endif - -/* Verify a requirement at compile-time (unlike assert, which is runtime). */ -#define verify(name, assertion) struct name { char a[(assertion) ? 1 : -1]; } - -/* A signed type that is at least one bit wider than int. */ -#if INT_MAX <= LONG_MAX / 2 -typedef long int long_int; -#else -typedef long long int long_int; -#endif -verify (long_int_is_wide_enough, INT_MAX == INT_MAX * (long_int) 2 / 2); - -/* Shift A right by B bits portably, by dividing A by 2**B and - truncating towards minus infinity. A and B should be free of side - effects, and B should be in the range 0 <= B <= INT_BITS - 2, where - INT_BITS is the number of useful bits in an int. GNU code can - assume that INT_BITS is at least 32. - - ISO C99 says that A >> B is implementation-defined if A < 0. Some - implementations (e.g., UNICOS 9.0 on a Cray Y-MP EL) don't shift - right in the usual way when A < 0, so SHR falls back on division if - ordinary A >> B doesn't seem to be the usual signed shift. */ -#define SHR(a, b) \ - ((-1 >> 1 == -1 \ - && (long_int) -1 >> 1 == -1 \ - && ((time_t) -1 >> 1 == -1 || ! TYPE_SIGNED (time_t))) \ - ? (a) >> (b) \ - : (a) / (1 << (b)) - ((a) % (1 << (b)) < 0)) - -/* The extra casts in the following macros work around compiler bugs, - e.g., in Cray C 5.0.3.0. */ - -/* True if the arithmetic type T is an integer type. bool counts as - an integer. */ -#define TYPE_IS_INTEGER(t) ((t) 1.5 == 1) - -/* True if negative values of the signed integer type T use two's - complement, or if T is an unsigned integer type. */ -#define TYPE_TWOS_COMPLEMENT(t) ((t) ~ (t) 0 == (t) -1) - -/* True if the arithmetic type T is signed. */ -#define TYPE_SIGNED(t) (! ((t) 0 < (t) -1)) - -/* The maximum and minimum values for the integer type T. These - macros have undefined behavior if T is signed and has padding bits. - If this is a problem for you, please let us know how to fix it for - your host. */ -#define TYPE_MINIMUM(t) \ - ((t) (! TYPE_SIGNED (t) \ - ? (t) 0 \ - : ~ TYPE_MAXIMUM (t))) -#define TYPE_MAXIMUM(t) \ - ((t) (! TYPE_SIGNED (t) \ - ? (t) -1 \ - : ((((t) 1 << (sizeof (t) * CHAR_BIT - 2)) - 1) * 2 + 1))) - -#ifndef TIME_T_MIN -# define TIME_T_MIN TYPE_MINIMUM (time_t) -#endif -#ifndef TIME_T_MAX -# define TIME_T_MAX TYPE_MAXIMUM (time_t) -#endif -#define TIME_T_MIDPOINT (SHR (TIME_T_MIN + TIME_T_MAX, 1) + 1) - -verify (time_t_is_integer, TYPE_IS_INTEGER (time_t)); -verify (twos_complement_arithmetic, - (TYPE_TWOS_COMPLEMENT (int) - && TYPE_TWOS_COMPLEMENT (long_int) - && TYPE_TWOS_COMPLEMENT (time_t))); - -#define EPOCH_YEAR 1970 -#define TM_YEAR_BASE 1900 -verify (base_year_is_a_multiple_of_100, TM_YEAR_BASE % 100 == 0); - -/* Return 1 if YEAR + TM_YEAR_BASE is a leap year. */ -static int -leapyear (long_int year) -{ - /* Don't add YEAR to TM_YEAR_BASE, as that might overflow. - Also, work even if YEAR is negative. */ - return - ((year & 3) == 0 - && (year % 100 != 0 - || ((year / 100) & 3) == (- (TM_YEAR_BASE / 100) & 3))); -} - -/* How many days come before each month (0-12). */ -#ifndef _LIBC -static -#endif -const unsigned short int __mon_yday[2][13] = - { - /* Normal years. */ - { 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365 }, - /* Leap years. */ - { 0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366 } - }; - - -#ifndef _LIBC -/* Portable standalone applications should supply a that - declares a POSIX-compliant localtime_r, for the benefit of older - implementations that lack localtime_r or have a nonstandard one. - See the gnulib time_r module for one way to implement this. */ -# undef __localtime_r -# define __localtime_r localtime_r -# define __mktime_internal mktime_internal -# include "mktime-internal.h" -#endif - -/* Return 1 if the values A and B differ according to the rules for - tm_isdst: A and B differ if one is zero and the other positive. */ -static int -isdst_differ (int a, int b) -{ - return (!a != !b) && (0 <= a) && (0 <= b); -} - -/* Return an integer value measuring (YEAR1-YDAY1 HOUR1:MIN1:SEC1) - - (YEAR0-YDAY0 HOUR0:MIN0:SEC0) in seconds, assuming that the clocks - were not adjusted between the time stamps. - - The YEAR values uses the same numbering as TP->tm_year. Values - need not be in the usual range. However, YEAR1 must not be less - than 2 * INT_MIN or greater than 2 * INT_MAX. - - The result may overflow. It is the caller's responsibility to - detect overflow. */ - -static time_t -ydhms_diff (long_int year1, long_int yday1, int hour1, int min1, int sec1, - int year0, int yday0, int hour0, int min0, int sec0) -{ - verify (C99_integer_division, -1 / 2 == 0); - - /* Compute intervening leap days correctly even if year is negative. - Take care to avoid integer overflow here. */ - int a4 = SHR (year1, 2) + SHR (TM_YEAR_BASE, 2) - ! (year1 & 3); - int b4 = SHR (year0, 2) + SHR (TM_YEAR_BASE, 2) - ! (year0 & 3); - int a100 = a4 / 25 - (a4 % 25 < 0); - int b100 = b4 / 25 - (b4 % 25 < 0); - int a400 = SHR (a100, 2); - int b400 = SHR (b100, 2); - int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400); - - /* Compute the desired time in time_t precision. Overflow might - occur here. */ - time_t tyear1 = year1; - time_t years = tyear1 - year0; - time_t days = 365 * years + yday1 - yday0 + intervening_leap_days; - time_t hours = 24 * days + hour1 - hour0; - time_t minutes = 60 * hours + min1 - min0; - time_t seconds = 60 * minutes + sec1 - sec0; - return seconds; -} - -/* Return the average of A and B, even if A + B would overflow. */ -static time_t -time_t_avg (time_t a, time_t b) -{ - return SHR (a, 1) + SHR (b, 1) + (a & b & 1); -} - -/* Return 1 if A + B does not overflow. If time_t is unsigned and if - B's top bit is set, assume that the sum represents A - -B, and - return 1 if the subtraction does not wrap around. */ -static int -time_t_add_ok (time_t a, time_t b) -{ - if (! TYPE_SIGNED (time_t)) - { - time_t sum = a + b; - return (sum < a) == (TIME_T_MIDPOINT <= b); - } - else if (WRAPV) - { - time_t sum = a + b; - return (sum < a) == (b < 0); - } - else - { - time_t avg = time_t_avg (a, b); - return TIME_T_MIN / 2 <= avg && avg <= TIME_T_MAX / 2; - } -} - -/* Return 1 if A + B does not overflow. */ -static int -time_t_int_add_ok (time_t a, int b) -{ - verify (int_no_wider_than_time_t, INT_MAX <= TIME_T_MAX); - if (WRAPV) - { - time_t sum = a + b; - return (sum < a) == (b < 0); - } - else - { - int a_odd = a & 1; - time_t avg = SHR (a, 1) + (SHR (b, 1) + (a_odd & b)); - return TIME_T_MIN / 2 <= avg && avg <= TIME_T_MAX / 2; - } -} - -/* Return a time_t value corresponding to (YEAR-YDAY HOUR:MIN:SEC), - assuming that *T corresponds to *TP and that no clock adjustments - occurred between *TP and the desired time. - If TP is null, return a value not equal to *T; this avoids false matches. - If overflow occurs, yield the minimal or maximal value, except do not - yield a value equal to *T. */ -static time_t -guess_time_tm (long_int year, long_int yday, int hour, int min, int sec, - const time_t *t, const struct tm *tp) -{ - if (tp) - { - time_t d = ydhms_diff (year, yday, hour, min, sec, - tp->tm_year, tp->tm_yday, - tp->tm_hour, tp->tm_min, tp->tm_sec); - if (time_t_add_ok (*t, d)) - return *t + d; - } - - /* Overflow occurred one way or another. Return the nearest result - that is actually in range, except don't report a zero difference - if the actual difference is nonzero, as that would cause a false - match; and don't oscillate between two values, as that would - confuse the spring-forward gap detector. */ - return (*t < TIME_T_MIDPOINT - ? (*t <= TIME_T_MIN + 1 ? *t + 1 : TIME_T_MIN) - : (TIME_T_MAX - 1 <= *t ? *t - 1 : TIME_T_MAX)); -} - -/* Use CONVERT to convert *T to a broken down time in *TP. - If *T is out of range for conversion, adjust it so that - it is the nearest in-range value and then convert that. */ -static struct tm * -ranged_convert (struct tm *(*convert) (const time_t *, struct tm *), - time_t *t, struct tm *tp) -{ - struct tm *r = convert (t, tp); - - if (!r && *t) - { - time_t bad = *t; - time_t ok = 0; - - /* BAD is a known unconvertible time_t, and OK is a known good one. - Use binary search to narrow the range between BAD and OK until - they differ by 1. */ - while (bad != ok + (bad < 0 ? -1 : 1)) - { - time_t mid = *t = time_t_avg (ok, bad); - r = convert (t, tp); - if (r) - ok = mid; - else - bad = mid; - } - - if (!r && ok) - { - /* The last conversion attempt failed; - revert to the most recent successful attempt. */ - *t = ok; - r = convert (t, tp); - } - } - - return r; -} - - -/* Convert *TP to a time_t value, inverting - the monotonic and mostly-unit-linear conversion function CONVERT. - Use *OFFSET to keep track of a guess at the offset of the result, - compared to what the result would be for UTC without leap seconds. - If *OFFSET's guess is correct, only one CONVERT call is needed. - This function is external because it is used also by timegm.c. */ -time_t -__mktime_internal (struct tm *tp, - struct tm *(*convert) (const time_t *, struct tm *), - time_t *offset) -{ - time_t t, gt, t0, t1, t2; - struct tm tm; - - /* The maximum number of probes (calls to CONVERT) should be enough - to handle any combinations of time zone rule changes, solar time, - leap seconds, and oscillations around a spring-forward gap. - POSIX.1 prohibits leap seconds, but some hosts have them anyway. */ - int remaining_probes = 6; - - /* Time requested. Copy it in case CONVERT modifies *TP; this can - occur if TP is localtime's returned value and CONVERT is localtime. */ - int sec = tp->tm_sec; - int min = tp->tm_min; - int hour = tp->tm_hour; - int mday = tp->tm_mday; - int mon = tp->tm_mon; - int year_requested = tp->tm_year; - int isdst = tp->tm_isdst; - - /* 1 if the previous probe was DST. */ - int dst2; - - /* Ensure that mon is in range, and set year accordingly. */ - int mon_remainder = mon % 12; - int negative_mon_remainder = mon_remainder < 0; - int mon_years = mon / 12 - negative_mon_remainder; - long_int lyear_requested = year_requested; - long_int year = lyear_requested + mon_years; - - /* The other values need not be in range: - the remaining code handles minor overflows correctly, - assuming int and time_t arithmetic wraps around. - Major overflows are caught at the end. */ - - /* Calculate day of year from year, month, and day of month. - The result need not be in range. */ - int mon_yday = ((__mon_yday[leapyear (year)] - [mon_remainder + 12 * negative_mon_remainder]) - - 1); - long_int lmday = mday; - long_int yday = mon_yday + lmday; - - time_t guessed_offset = *offset; - - int sec_requested = sec; - - if (LEAP_SECONDS_POSSIBLE) - { - /* Handle out-of-range seconds specially, - since ydhms_tm_diff assumes every minute has 60 seconds. */ - if (sec < 0) - sec = 0; - if (59 < sec) - sec = 59; - } - - /* Invert CONVERT by probing. First assume the same offset as last - time. */ - - t0 = ydhms_diff (year, yday, hour, min, sec, - EPOCH_YEAR - TM_YEAR_BASE, 0, 0, 0, - guessed_offset); - - if (TIME_T_MAX / INT_MAX / 366 / 24 / 60 / 60 < 3) - { - /* time_t isn't large enough to rule out overflows, so check - for major overflows. A gross check suffices, since if t0 - has overflowed, it is off by a multiple of TIME_T_MAX - - TIME_T_MIN + 1. So ignore any component of the difference - that is bounded by a small value. */ - - /* Approximate log base 2 of the number of time units per - biennium. A biennium is 2 years; use this unit instead of - years to avoid integer overflow. For example, 2 average - Gregorian years are 2 * 365.2425 * 24 * 60 * 60 seconds, - which is 63113904 seconds, and rint (log2 (63113904)) is - 26. */ - int ALOG2_SECONDS_PER_BIENNIUM = 26; - int ALOG2_MINUTES_PER_BIENNIUM = 20; - int ALOG2_HOURS_PER_BIENNIUM = 14; - int ALOG2_DAYS_PER_BIENNIUM = 10; - int LOG2_YEARS_PER_BIENNIUM = 1; - - int approx_requested_biennia = - (SHR (year_requested, LOG2_YEARS_PER_BIENNIUM) - - SHR (EPOCH_YEAR - TM_YEAR_BASE, LOG2_YEARS_PER_BIENNIUM) - + SHR (mday, ALOG2_DAYS_PER_BIENNIUM) - + SHR (hour, ALOG2_HOURS_PER_BIENNIUM) - + SHR (min, ALOG2_MINUTES_PER_BIENNIUM) - + (LEAP_SECONDS_POSSIBLE - ? 0 - : SHR (sec, ALOG2_SECONDS_PER_BIENNIUM))); - - int approx_biennia = SHR (t0, ALOG2_SECONDS_PER_BIENNIUM); - int diff = approx_biennia - approx_requested_biennia; - int approx_abs_diff = diff < 0 ? -1 - diff : diff; - - /* IRIX 4.0.5 cc miscalculates TIME_T_MIN / 3: it erroneously - gives a positive value of 715827882. Setting a variable - first then doing math on it seems to work. - (ghazi@caip.rutgers.edu) */ - time_t time_t_max = TIME_T_MAX; - time_t time_t_min = TIME_T_MIN; - time_t overflow_threshold = - (time_t_max / 3 - time_t_min / 3) >> ALOG2_SECONDS_PER_BIENNIUM; - - if (overflow_threshold < approx_abs_diff) - { - /* Overflow occurred. Try repairing it; this might work if - the time zone offset is enough to undo the overflow. */ - time_t repaired_t0 = -1 - t0; - approx_biennia = SHR (repaired_t0, ALOG2_SECONDS_PER_BIENNIUM); - diff = approx_biennia - approx_requested_biennia; - approx_abs_diff = diff < 0 ? -1 - diff : diff; - if (overflow_threshold < approx_abs_diff) - return -1; - guessed_offset += repaired_t0 - t0; - t0 = repaired_t0; - } - } - - /* Repeatedly use the error to improve the guess. */ - - for (t = t1 = t2 = t0, dst2 = 0; - (gt = guess_time_tm (year, yday, hour, min, sec, &t, - ranged_convert (convert, &t, &tm)), - t != gt); - t1 = t2, t2 = t, t = gt, dst2 = tm.tm_isdst != 0) - if (t == t1 && t != t2 - && (tm.tm_isdst < 0 - || (isdst < 0 - ? dst2 <= (tm.tm_isdst != 0) - : (isdst != 0) != (tm.tm_isdst != 0)))) - /* We can't possibly find a match, as we are oscillating - between two values. The requested time probably falls - within a spring-forward gap of size GT - T. Follow the common - practice in this case, which is to return a time that is GT - T - away from the requested time, preferring a time whose - tm_isdst differs from the requested value. (If no tm_isdst - was requested and only one of the two values has a nonzero - tm_isdst, prefer that value.) In practice, this is more - useful than returning -1. */ - goto offset_found; - else if (--remaining_probes == 0) - return -1; - - /* We have a match. Check whether tm.tm_isdst has the requested - value, if any. */ - if (isdst_differ (isdst, tm.tm_isdst)) - { - /* tm.tm_isdst has the wrong value. Look for a neighboring - time with the right value, and use its UTC offset. - - Heuristic: probe the adjacent timestamps in both directions, - looking for the desired isdst. This should work for all real - time zone histories in the tz database. */ - - /* Distance between probes when looking for a DST boundary. In - tzdata2003a, the shortest period of DST is 601200 seconds - (e.g., America/Recife starting 2000-10-08 01:00), and the - shortest period of non-DST surrounded by DST is 694800 - seconds (Africa/Tunis starting 1943-04-17 01:00). Use the - minimum of these two values, so we don't miss these short - periods when probing. */ - int stride = 601200; - - /* The longest period of DST in tzdata2003a is 536454000 seconds - (e.g., America/Jujuy starting 1946-10-01 01:00). The longest - period of non-DST is much longer, but it makes no real sense - to search for more than a year of non-DST, so use the DST - max. */ - int duration_max = 536454000; - - /* Search in both directions, so the maximum distance is half - the duration; add the stride to avoid off-by-1 problems. */ - int delta_bound = duration_max / 2 + stride; - - int delta, direction; - - for (delta = stride; delta < delta_bound; delta += stride) - for (direction = -1; direction <= 1; direction += 2) - if (time_t_int_add_ok (t, delta * direction)) - { - time_t ot = t + delta * direction; - struct tm otm; - ranged_convert (convert, &ot, &otm); - if (! isdst_differ (isdst, otm.tm_isdst)) - { - /* We found the desired tm_isdst. - Extrapolate back to the desired time. */ - t = guess_time_tm (year, yday, hour, min, sec, &ot, &otm); - ranged_convert (convert, &t, &tm); - goto offset_found; - } - } - } - - offset_found: - *offset = guessed_offset + t - t0; - - if (LEAP_SECONDS_POSSIBLE && sec_requested != tm.tm_sec) - { - /* Adjust time to reflect the tm_sec requested, not the normalized value. - Also, repair any damage from a false match due to a leap second. */ - int sec_adjustment = (sec == 0 && tm.tm_sec == 60) - sec; - if (! time_t_int_add_ok (t, sec_requested)) - return -1; - t1 = t + sec_requested; - if (! time_t_int_add_ok (t1, sec_adjustment)) - return -1; - t2 = t1 + sec_adjustment; - if (! convert (&t2, &tm)) - return -1; - t = t2; - } - - *tp = tm; - return t; -} - - -/* FIXME: This should use a signed type wide enough to hold any UTC - offset in seconds. 'int' should be good enough for GNU code. We - can't fix this unilaterally though, as other modules invoke - __mktime_internal. */ -static time_t localtime_offset; - -/* Convert *TP to a time_t value. */ -time_t -mktime (struct tm *tp) -{ -#ifdef _LIBC - /* POSIX.1 8.1.1 requires that whenever mktime() is called, the - time zone names contained in the external variable 'tzname' shall - be set as if the tzset() function had been called. */ - __tzset (); -#endif - - return __mktime_internal (tp, __localtime_r, &localtime_offset); -} - -#ifdef weak_alias -weak_alias (mktime, timelocal) -#endif - -#ifdef _LIBC -libc_hidden_def (mktime) -libc_hidden_weak (timelocal) -#endif - -#if defined DEBUG && DEBUG - -static int -not_equal_tm (const struct tm *a, const struct tm *b) -{ - return ((a->tm_sec ^ b->tm_sec) - | (a->tm_min ^ b->tm_min) - | (a->tm_hour ^ b->tm_hour) - | (a->tm_mday ^ b->tm_mday) - | (a->tm_mon ^ b->tm_mon) - | (a->tm_year ^ b->tm_year) - | (a->tm_yday ^ b->tm_yday) - | isdst_differ (a->tm_isdst, b->tm_isdst)); -} - -static void -print_tm (const struct tm *tp) -{ - if (tp) - printf ("%04d-%02d-%02d %02d:%02d:%02d yday %03d wday %d isdst %d", - tp->tm_year + TM_YEAR_BASE, tp->tm_mon + 1, tp->tm_mday, - tp->tm_hour, tp->tm_min, tp->tm_sec, - tp->tm_yday, tp->tm_wday, tp->tm_isdst); - else - printf ("0"); -} - -static int -check_result (time_t tk, struct tm tmk, time_t tl, const struct tm *lt) -{ - if (tk != tl || !lt || not_equal_tm (&tmk, lt)) - { - printf ("mktime ("); - print_tm (lt); - printf (")\nyields ("); - print_tm (&tmk); - printf (") == %ld, should be %ld\n", (long int) tk, (long int) tl); - return 1; - } - - return 0; -} - -int -main (int argc, char **argv) -{ - int status = 0; - struct tm tm, tmk, tml; - struct tm *lt; - time_t tk, tl, tl1; - char trailer; - - if ((argc == 3 || argc == 4) - && (sscanf (argv[1], "%d-%d-%d%c", - &tm.tm_year, &tm.tm_mon, &tm.tm_mday, &trailer) - == 3) - && (sscanf (argv[2], "%d:%d:%d%c", - &tm.tm_hour, &tm.tm_min, &tm.tm_sec, &trailer) - == 3)) - { - tm.tm_year -= TM_YEAR_BASE; - tm.tm_mon--; - tm.tm_isdst = argc == 3 ? -1 : atoi (argv[3]); - tmk = tm; - tl = mktime (&tmk); - lt = localtime (&tl); - if (lt) - { - tml = *lt; - lt = &tml; - } - printf ("mktime returns %ld == ", (long int) tl); - print_tm (&tmk); - printf ("\n"); - status = check_result (tl, tmk, tl, lt); - } - else if (argc == 4 || (argc == 5 && strcmp (argv[4], "-") == 0)) - { - time_t from = atol (argv[1]); - time_t by = atol (argv[2]); - time_t to = atol (argv[3]); - - if (argc == 4) - for (tl = from; by < 0 ? to <= tl : tl <= to; tl = tl1) - { - lt = localtime (&tl); - if (lt) - { - tmk = tml = *lt; - tk = mktime (&tmk); - status |= check_result (tk, tmk, tl, &tml); - } - else - { - printf ("localtime (%ld) yields 0\n", (long int) tl); - status = 1; - } - tl1 = tl + by; - if ((tl1 < tl) != (by < 0)) - break; - } - else - for (tl = from; by < 0 ? to <= tl : tl <= to; tl = tl1) - { - /* Null benchmark. */ - lt = localtime (&tl); - if (lt) - { - tmk = tml = *lt; - tk = tl; - status |= check_result (tk, tmk, tl, &tml); - } - else - { - printf ("localtime (%ld) yields 0\n", (long int) tl); - status = 1; - } - tl1 = tl + by; - if ((tl1 < tl) != (by < 0)) - break; - } - } - else - printf ("Usage:\ -\t%s YYYY-MM-DD HH:MM:SS [ISDST] # Test given time.\n\ -\t%s FROM BY TO # Test values FROM, FROM+BY, ..., TO.\n\ -\t%s FROM BY TO - # Do not test those values (for benchmark).\n", - argv[0], argv[0], argv[0]); - - return status; -} - -#endif /* DEBUG */ - -/* -Local Variables: -compile-command: "gcc -DDEBUG -I. -Wall -W -O2 -g mktime.c -o mktime" -End: -*/ diff --git a/lib/msvc-inval.c b/lib/msvc-inval.c index 7ee21e437..84190d097 100644 --- a/lib/msvc-inval.c +++ b/lib/msvc-inval.c @@ -1,5 +1,5 @@ /* Invalid parameter handler for MSVC runtime libraries. - Copyright (C) 2011-2015 Free Software Foundation, Inc. + Copyright (C) 2011-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/msvc-inval.h b/lib/msvc-inval.h index c73511df2..c6df57e93 100644 --- a/lib/msvc-inval.h +++ b/lib/msvc-inval.h @@ -1,5 +1,5 @@ /* Invalid parameter handler for MSVC runtime libraries. - Copyright (C) 2011-2015 Free Software Foundation, Inc. + Copyright (C) 2011-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/msvc-nothrow.c b/lib/msvc-nothrow.c index 868388183..9b1eb598e 100644 --- a/lib/msvc-nothrow.c +++ b/lib/msvc-nothrow.c @@ -1,6 +1,6 @@ /* Wrappers that don't throw invalid parameter notifications with MSVC runtime libraries. - Copyright (C) 2011-2015 Free Software Foundation, Inc. + Copyright (C) 2011-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/msvc-nothrow.h b/lib/msvc-nothrow.h index f596aaf45..1917325b3 100644 --- a/lib/msvc-nothrow.h +++ b/lib/msvc-nothrow.h @@ -1,6 +1,6 @@ /* Wrappers that don't throw invalid parameter notifications with MSVC runtime libraries. - Copyright (C) 2011-2015 Free Software Foundation, Inc. + Copyright (C) 2011-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/netdb.in.h b/lib/netdb.in.h index 530a5335a..3613fb5a5 100644 --- a/lib/netdb.in.h +++ b/lib/netdb.in.h @@ -1,5 +1,5 @@ /* Provide a netdb.h header file for systems lacking it (read: MinGW). - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. Written by Simon Josefsson. This program is free software; you can redistribute it and/or modify diff --git a/lib/netinet_in.in.h b/lib/netinet_in.in.h index e4709bbaf..8ab66a1df 100644 --- a/lib/netinet_in.in.h +++ b/lib/netinet_in.in.h @@ -1,5 +1,5 @@ /* Substitute for . - Copyright (C) 2007-2015 Free Software Foundation, Inc. + Copyright (C) 2007-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/nl_langinfo.c b/lib/nl_langinfo.c index ff0adc4b9..83d2c77af 100644 --- a/lib/nl_langinfo.c +++ b/lib/nl_langinfo.c @@ -1,6 +1,6 @@ /* nl_langinfo() replacement: query locale dependent information. - Copyright (C) 2007-2015 Free Software Foundation, Inc. + Copyright (C) 2007-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -20,72 +20,13 @@ /* Specification. */ #include -#include -#include -#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ -# define WIN32_LEAN_AND_MEAN /* avoid including junk */ -# include -# include -#endif - -/* Return the codeset of the current locale, if this is easily deducible. - Otherwise, return "". */ -static char * -ctype_codeset (void) -{ - static char buf[2 + 10 + 1]; - size_t buflen = 0; - char const *locale = setlocale (LC_CTYPE, NULL); - char *codeset = buf; - size_t codesetlen; - codeset[0] = '\0'; - - if (locale && locale[0]) - { - /* If the locale name contains an encoding after the dot, return it. */ - char *dot = strchr (locale, '.'); - - if (dot) - { - /* Look for the possible @... trailer and remove it, if any. */ - char *codeset_start = dot + 1; - char const *modifier = strchr (codeset_start, '@'); - - if (! modifier) - codeset = codeset_start; - else - { - codesetlen = modifier - codeset_start; - if (codesetlen < sizeof buf) - { - codeset = memcpy (buf, codeset_start, codesetlen); - codeset[codesetlen] = '\0'; - } - } - } - } - -#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ - /* If setlocale is successful, it returns the number of the - codepage, as a string. Otherwise, fall back on Windows API - GetACP, which returns the locale's codepage as a number (although - this doesn't change according to what the 'setlocale' call specified). - Either way, prepend "CP" to make it a valid codeset name. */ - codesetlen = strlen (codeset); - if (0 < codesetlen && codesetlen < sizeof buf - 2) - memmove (buf + 2, codeset, codesetlen + 1); - else - sprintf (buf + 2, "%u", GetACP ()); - codeset = memcpy (buf, "CP", 2); -#endif - return codeset; -} - - #if REPLACE_NL_LANGINFO /* Override nl_langinfo with support for added nl_item values. */ +# include +# include + # undef nl_langinfo char * @@ -95,7 +36,36 @@ rpl_nl_langinfo (nl_item item) { # if GNULIB_defined_CODESET case CODESET: - return ctype_codeset (); + { + const char *locale; + static char buf[2 + 10 + 1]; + + locale = setlocale (LC_CTYPE, NULL); + if (locale != NULL && locale[0] != '\0') + { + /* If the locale name contains an encoding after the dot, return + it. */ + const char *dot = strchr (locale, '.'); + + if (dot != NULL) + { + const char *modifier; + + dot++; + /* Look for the possible @... trailer and remove it, if any. */ + modifier = strchr (dot, '@'); + if (modifier == NULL) + return dot; + if (modifier - dot < sizeof (buf)) + { + memcpy (buf, dot, modifier - dot); + buf [modifier - dot] = '\0'; + return buf; + } + } + } + return ""; + } # endif # if GNULIB_defined_T_FMT_AMPM case T_FMT_AMPM: @@ -141,28 +111,42 @@ rpl_nl_langinfo (nl_item item) #else -/* Provide nl_langinfo from scratch, either for native MS-Windows, or - for old Unix platforms without locales, such as Linux libc5 or - BeOS. */ +/* Provide nl_langinfo from scratch. */ -# include +# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ + +/* Native Windows platforms. */ + +# define WIN32_LEAN_AND_MEAN /* avoid including junk */ +# include + +# include + +# else + +/* An old Unix platform without locales, such as Linux libc5 or BeOS. */ + +# endif + +# include char * nl_langinfo (nl_item item) { - static char nlbuf[100]; - struct tm tmm = { 0 }; - switch (item) { /* nl_langinfo items of the LC_CTYPE category */ case CODESET: +# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ { - char *codeset = ctype_codeset (); - if (*codeset) - return codeset; + static char buf[2 + 10 + 1]; + + /* The Windows API has a function returning the locale's codepage as + a number. */ + sprintf (buf, "CP%u", GetACP ()); + return buf; } -# ifdef __BEOS__ +# elif defined __BEOS__ return "UTF-8"; # else return "ISO-8859-1"; @@ -172,8 +156,6 @@ nl_langinfo (nl_item item) return localeconv () ->decimal_point; case THOUSEP: return localeconv () ->thousands_sep; - case GROUPING: - return localeconv () ->grouping; /* nl_langinfo items of the LC_TIME category. TODO: Really use the locale. */ case D_T_FMT: @@ -188,126 +170,93 @@ nl_langinfo (nl_item item) case T_FMT_AMPM: return "%I:%M:%S %p"; case AM_STR: - if (!strftime (nlbuf, sizeof nlbuf, "%p", &tmm)) - return "AM"; - return nlbuf; + return "AM"; case PM_STR: - tmm.tm_hour = 12; - if (!strftime (nlbuf, sizeof nlbuf, "%p", &tmm)) - return "PM"; - return nlbuf; + return "PM"; case DAY_1: + return "Sunday"; case DAY_2: + return "Monday"; case DAY_3: + return "Tuesday"; case DAY_4: + return "Wednesday"; case DAY_5: + return "Thursday"; case DAY_6: + return "Friday"; case DAY_7: - { - static char const days[][sizeof "Wednesday"] = { - "Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", - "Friday", "Saturday" - }; - tmm.tm_wday = item - DAY_1; - if (!strftime (nlbuf, sizeof nlbuf, "%A", &tmm)) - return (char *) days[item - DAY_1]; - return nlbuf; - } + return "Saturday"; case ABDAY_1: + return "Sun"; case ABDAY_2: + return "Mon"; case ABDAY_3: + return "Tue"; case ABDAY_4: + return "Wed"; case ABDAY_5: + return "Thu"; case ABDAY_6: + return "Fri"; case ABDAY_7: - { - static char const abdays[][sizeof "Sun"] = { - "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" - }; - tmm.tm_wday = item - ABDAY_1; - if (!strftime (nlbuf, sizeof nlbuf, "%a", &tmm)) - return (char *) abdays[item - ABDAY_1]; - return nlbuf; - } + return "Sat"; case MON_1: + return "January"; case MON_2: + return "February"; case MON_3: + return "March"; case MON_4: + return "April"; case MON_5: + return "May"; case MON_6: + return "June"; case MON_7: + return "July"; case MON_8: + return "August"; case MON_9: + return "September"; case MON_10: + return "October"; case MON_11: + return "November"; case MON_12: - { - static char const months[][sizeof "September"] = { - "January", "February", "March", "April", "May", "June", "July", - "September", "October", "November", "December" - }; - tmm.tm_mon = item - MON_1; - if (!strftime (nlbuf, sizeof nlbuf, "%B", &tmm)) - return (char *) months[item - MON_1]; - return nlbuf; - } + return "December"; case ABMON_1: + return "Jan"; case ABMON_2: + return "Feb"; case ABMON_3: + return "Mar"; case ABMON_4: + return "Apr"; case ABMON_5: + return "May"; case ABMON_6: + return "Jun"; case ABMON_7: + return "Jul"; case ABMON_8: + return "Aug"; case ABMON_9: + return "Sep"; case ABMON_10: + return "Oct"; case ABMON_11: + return "Nov"; case ABMON_12: - { - static char const abmonths[][sizeof "Jan"] = { - "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", - "Sep", "Oct", "Nov", "Dec" - }; - tmm.tm_mon = item - ABMON_1; - if (!strftime (nlbuf, sizeof nlbuf, "%b", &tmm)) - return (char *) abmonths[item - ABMON_1]; - return nlbuf; - } + return "Dec"; case ERA: return ""; case ALT_DIGITS: return "\0\0\0\0\0\0\0\0\0\0"; - /* nl_langinfo items of the LC_MONETARY category. */ + /* nl_langinfo items of the LC_MONETARY category + TODO: Really use the locale. */ case CRNCYSTR: - return localeconv () ->currency_symbol; - case INT_CURR_SYMBOL: - return localeconv () ->int_curr_symbol; - case MON_DECIMAL_POINT: - return localeconv () ->mon_decimal_point; - case MON_THOUSANDS_SEP: - return localeconv () ->mon_thousands_sep; - case MON_GROUPING: - return localeconv () ->mon_grouping; - case POSITIVE_SIGN: - return localeconv () ->positive_sign; - case NEGATIVE_SIGN: - return localeconv () ->negative_sign; - case FRAC_DIGITS: - return & localeconv () ->frac_digits; - case INT_FRAC_DIGITS: - return & localeconv () ->int_frac_digits; - case P_CS_PRECEDES: - return & localeconv () ->p_cs_precedes; - case N_CS_PRECEDES: - return & localeconv () ->n_cs_precedes; - case P_SEP_BY_SPACE: - return & localeconv () ->p_sep_by_space; - case N_SEP_BY_SPACE: - return & localeconv () ->n_sep_by_space; - case P_SIGN_POSN: - return & localeconv () ->p_sign_posn; - case N_SIGN_POSN: - return & localeconv () ->n_sign_posn; + return "-"; /* nl_langinfo items of the LC_MESSAGES category TODO: Really use the locale. */ case YESEXPR: diff --git a/lib/nproc.c b/lib/nproc.c index b1c25b138..293c65169 100644 --- a/lib/nproc.c +++ b/lib/nproc.c @@ -1,6 +1,6 @@ /* Detect the number of processors. - Copyright (C) 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2009-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/nproc.h b/lib/nproc.h index 4c49777aa..dbc315707 100644 --- a/lib/nproc.h +++ b/lib/nproc.h @@ -1,6 +1,6 @@ /* Detect the number of processors. - Copyright (C) 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2009-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/open.c b/lib/open.c index 4345943d2..f6fd06e4c 100644 --- a/lib/open.c +++ b/lib/open.c @@ -1,5 +1,5 @@ /* Open a descriptor to a file. - Copyright (C) 2007-2015 Free Software Foundation, Inc. + Copyright (C) 2007-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/pathmax.h b/lib/pathmax.h index c4c94528f..15ed6c28e 100644 --- a/lib/pathmax.h +++ b/lib/pathmax.h @@ -1,5 +1,5 @@ /* Define PATH_MAX somehow. Requires sys/types.h. - Copyright (C) 1992, 1999, 2001, 2003, 2005, 2009-2015 Free Software + Copyright (C) 1992, 1999, 2001, 2003, 2005, 2009-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/pipe.c b/lib/pipe.c index d733ed068..03aed5ef9 100644 --- a/lib/pipe.c +++ b/lib/pipe.c @@ -1,5 +1,5 @@ /* Create a pipe. - Copyright (C) 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2009-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/pipe2.c b/lib/pipe2.c index 94a79e219..4e4e894e7 100644 --- a/lib/pipe2.c +++ b/lib/pipe2.c @@ -1,5 +1,5 @@ /* Create a pipe, with specific opening flags. - Copyright (C) 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2009-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/poll.c b/lib/poll.c index e70e8b354..7b1e58266 100644 --- a/lib/poll.c +++ b/lib/poll.c @@ -1,7 +1,7 @@ /* Emulation for poll(2) Contributed by Paolo Bonzini. - Copyright 2001-2003, 2006-2015 Free Software Foundation, Inc. + Copyright 2001-2003, 2006-2014 Free Software Foundation, Inc. This file is part of gnulib. @@ -33,6 +33,7 @@ #include #include +#include #if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ # define WINDOWS_NATIVE @@ -44,12 +45,11 @@ # include "msvc-nothrow.h" #else # include +# include +# include # include #endif -#include -#include - #ifdef HAVE_SYS_IOCTL_H # include #endif @@ -59,8 +59,6 @@ #include -#include "assure.h" - #ifndef INFTIM # define INFTIM (-1) #endif @@ -72,11 +70,9 @@ #ifdef WINDOWS_NATIVE -static BOOL IsConsoleHandle (HANDLE h) -{ - DWORD mode; - return GetConsoleMode (h, &mode) != 0; -} +/* Optimized test whether a HANDLE refers to a console. + See . */ +#define IsConsoleHandle(h) (((intptr_t) (h) & 3) == 3) static BOOL IsSocketHandle (HANDLE h) @@ -335,15 +331,26 @@ poll (struct pollfd *pfd, nfds_t nfd, int timeout) int maxfd, rc; nfds_t i; - if (nfd < 0) +# ifdef _SC_OPEN_MAX + static int sc_open_max = -1; + + if (nfd < 0 + || (nfd > sc_open_max + && (sc_open_max != -1 + || nfd > (sc_open_max = sysconf (_SC_OPEN_MAX))))) { errno = EINVAL; return -1; } - /* Don't check directly for NFD too large. Any practical use of a - too-large NFD is caught by one of the other checks below, and - checking directly for getdtablesize is too much of a portability - and/or performance and/or correctness hassle. */ +# else /* !_SC_OPEN_MAX */ +# ifdef OPEN_MAX + if (nfd < 0 || nfd > OPEN_MAX) + { + errno = EINVAL; + return -1; + } +# endif /* OPEN_MAX -- else, no check is needed */ +# endif /* !_SC_OPEN_MAX */ /* EFAULT is not necessary to implement, but let's do it in the simplest case. */ @@ -384,17 +391,10 @@ poll (struct pollfd *pfd, nfds_t nfd, int timeout) { if (pfd[i].fd < 0) continue; - if (maxfd < pfd[i].fd) - { - maxfd = pfd[i].fd; - if (FD_SETSIZE <= maxfd) - { - errno = EINVAL; - return -1; - } - } + if (pfd[i].events & (POLLIN | POLLRDNORM)) FD_SET (pfd[i].fd, &rfds); + /* see select(2): "the only exceptional condition detectable is out-of-band data received on a socket", hence we push POLLWRBAND events onto wfds instead of efds. */ @@ -402,6 +402,18 @@ poll (struct pollfd *pfd, nfds_t nfd, int timeout) FD_SET (pfd[i].fd, &wfds); if (pfd[i].events & (POLLPRI | POLLRDBAND)) FD_SET (pfd[i].fd, &efds); + if (pfd[i].fd >= maxfd + && (pfd[i].events & (POLLIN | POLLOUT | POLLPRI + | POLLRDNORM | POLLRDBAND + | POLLWRNORM | POLLWRBAND))) + { + maxfd = pfd[i].fd; + if (maxfd > FD_SETSIZE) + { + errno = EOVERFLOW; + return -1; + } + } } /* examine fd sets */ @@ -412,13 +424,18 @@ poll (struct pollfd *pfd, nfds_t nfd, int timeout) /* establish results */ rc = 0; for (i = 0; i < nfd; i++) - { - pfd[i].revents = (pfd[i].fd < 0 - ? 0 - : compute_revents (pfd[i].fd, pfd[i].events, - &rfds, &wfds, &efds)); - rc += pfd[i].revents != 0; - } + if (pfd[i].fd < 0) + pfd[i].revents = 0; + else + { + int happened = compute_revents (pfd[i].fd, pfd[i].events, + &rfds, &wfds, &efds); + if (happened) + { + pfd[i].revents = happened; + rc++; + } + } return rc; #else @@ -461,7 +478,7 @@ restart: continue; h = (HANDLE) _get_osfhandle (pfd[i].fd); - assure (h != NULL); + assert (h != NULL); if (IsSocketHandle (h)) { int requested = FD_CLOSE; diff --git a/lib/poll.in.h b/lib/poll.in.h index 0a9950157..bde98064f 100644 --- a/lib/poll.in.h +++ b/lib/poll.in.h @@ -1,7 +1,7 @@ /* Header for poll(2) emulation Contributed by Paolo Bonzini. - Copyright 2001-2003, 2007, 2009-2015 Free Software Foundation, Inc. + Copyright 2001-2003, 2007, 2009-2014 Free Software Foundation, Inc. This file is part of gnulib. diff --git a/lib/printf-args.c b/lib/printf-args.c index de7a6bf3f..9673e6ddc 100644 --- a/lib/printf-args.c +++ b/lib/printf-args.c @@ -1,5 +1,5 @@ /* Decomposed printf argument list. - Copyright (C) 1999, 2002-2003, 2005-2007, 2009-2015 Free Software + Copyright (C) 1999, 2002-2003, 2005-2007, 2009-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/printf-args.h b/lib/printf-args.h index a413b5270..831c14738 100644 --- a/lib/printf-args.h +++ b/lib/printf-args.h @@ -1,5 +1,5 @@ /* Decomposed printf argument list. - Copyright (C) 1999, 2002-2003, 2006-2007, 2011-2015 Free Software + Copyright (C) 1999, 2002-2003, 2006-2007, 2011-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/printf-parse.c b/lib/printf-parse.c index b4592363b..e6a09a8de 100644 --- a/lib/printf-parse.c +++ b/lib/printf-parse.c @@ -1,5 +1,5 @@ /* Formatted output to strings. - Copyright (C) 1999-2000, 2002-2003, 2006-2015 Free Software Foundation, Inc. + Copyright (C) 1999-2000, 2002-2003, 2006-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/printf-parse.h b/lib/printf-parse.h index d35ffcaf1..44d6f5513 100644 --- a/lib/printf-parse.h +++ b/lib/printf-parse.h @@ -1,5 +1,5 @@ /* Parse printf format string. - Copyright (C) 1999, 2002-2003, 2005, 2007, 2010-2015 Free Software + Copyright (C) 1999, 2002-2003, 2005, 2007, 2010-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/putenv.c b/lib/putenv.c index 54687629c..de8caa712 100644 --- a/lib/putenv.c +++ b/lib/putenv.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1991, 1994, 1997-1998, 2000, 2003-2015 Free Software +/* Copyright (C) 1991, 1994, 1997-1998, 2000, 2003-2014 Free Software Foundation, Inc. NOTE: The canonical source of this file is maintained with the GNU C diff --git a/lib/raise.c b/lib/raise.c index b099b58d1..2f04eea9b 100644 --- a/lib/raise.c +++ b/lib/raise.c @@ -1,6 +1,6 @@ /* Provide a non-threads replacement for the POSIX raise function. - Copyright (C) 2002-2003, 2005-2006, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2002-2003, 2005-2006, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/read.c b/lib/read.c index 7edb99110..4efe8ce23 100644 --- a/lib/read.c +++ b/lib/read.c @@ -1,5 +1,5 @@ /* POSIX compatible read() function. - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/readlink.c b/lib/readlink.c index d86f822aa..ef502f57b 100644 --- a/lib/readlink.c +++ b/lib/readlink.c @@ -1,5 +1,5 @@ /* Stub for readlink(). - Copyright (C) 2003-2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2003-2007, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/recv.c b/lib/recv.c index edb7e01f1..fc7e12406 100644 --- a/lib/recv.c +++ b/lib/recv.c @@ -1,6 +1,6 @@ /* recv.c --- wrappers for Windows recv function - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/recvfrom.c b/lib/recvfrom.c index 4ecffb0e0..0d4fba076 100644 --- a/lib/recvfrom.c +++ b/lib/recvfrom.c @@ -1,6 +1,6 @@ /* recvfrom.c --- wrappers for Windows recvfrom function - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/ref-add.sin b/lib/ref-add.sin index 4d406a37d..9adfb0df0 100644 --- a/lib/ref-add.sin +++ b/lib/ref-add.sin @@ -1,6 +1,6 @@ # Add this package to a list of references stored in a text file. # -# Copyright (C) 2000, 2009-2015 Free Software Foundation, Inc. +# Copyright (C) 2000, 2009-2014 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/ref-del.sin b/lib/ref-del.sin index 5b4ff6246..45449cbba 100644 --- a/lib/ref-del.sin +++ b/lib/ref-del.sin @@ -1,6 +1,6 @@ # Remove this package from a list of references stored in a text file. # -# Copyright (C) 2000, 2009-2015 Free Software Foundation, Inc. +# Copyright (C) 2000, 2009-2014 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/regcomp.c b/lib/regcomp.c index 4cbb1b2b9..56faf11c4 100644 --- a/lib/regcomp.c +++ b/lib/regcomp.c @@ -1,5 +1,5 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2015 Free Software Foundation, Inc. + Copyright (C) 2002-2014 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa . @@ -17,10 +17,6 @@ License along with the GNU C Library; if not, see . */ -#ifdef _LIBC -# include -#endif - static reg_errcode_t re_compile_internal (regex_t *preg, const char * pattern, size_t length, reg_syntax_t syntax); static void re_compile_fastmap_iter (regex_t *bufp, @@ -339,7 +335,7 @@ re_compile_fastmap_iter (regex_t *bufp, const re_dfastate_t *init_state, memset (&state, '\0', sizeof (state)); if (__mbrtowc (&wc, (const char *) buf, p - buf, &state) == p - buf - && (__wcrtomb ((char *) buf, __towlower (wc), &state) + && (__wcrtomb ((char *) buf, towlower (wc), &state) != (size_t) -1)) re_set_fastmap (fastmap, false, buf[0]); } @@ -415,7 +411,7 @@ re_compile_fastmap_iter (regex_t *bufp, const re_dfastate_t *init_state, re_set_fastmap (fastmap, icase, *(unsigned char *) buf); if ((bufp->syntax & RE_ICASE) && dfa->mb_cur_max > 1) { - if (__wcrtomb (buf, __towlower (cset->mbchars[i]), &state) + if (__wcrtomb (buf, towlower (cset->mbchars[i]), &state) != (size_t) -1) re_set_fastmap (fastmap, false, *(unsigned char *) buf); } @@ -2191,7 +2187,6 @@ parse_reg_exp (re_string_t *regexp, regex_t *preg, re_token_t *token, { re_dfa_t *dfa = preg->buffer; bin_tree_t *tree, *branch = NULL; - bitset_word_t initial_bkref_map = dfa->completed_bkref_map; tree = parse_branch (regexp, preg, token, syntax, nest, err); if (BE (*err != REG_NOERROR && tree == NULL, 0)) return NULL; @@ -2202,16 +2197,9 @@ parse_reg_exp (re_string_t *regexp, regex_t *preg, re_token_t *token, if (token->type != OP_ALT && token->type != END_OF_RE && (nest == 0 || token->type != OP_CLOSE_SUBEXP)) { - bitset_word_t accumulated_bkref_map = dfa->completed_bkref_map; - dfa->completed_bkref_map = initial_bkref_map; branch = parse_branch (regexp, preg, token, syntax, nest, err); if (BE (*err != REG_NOERROR && branch == NULL, 0)) - { - if (tree != NULL) - postorder (tree, free_tree, NULL); - return NULL; - } - dfa->completed_bkref_map |= accumulated_bkref_map; + return NULL; } else branch = NULL; @@ -2472,22 +2460,14 @@ parse_expression (re_string_t *regexp, regex_t *preg, re_token_t *token, while (token->type == OP_DUP_ASTERISK || token->type == OP_DUP_PLUS || token->type == OP_DUP_QUESTION || token->type == OP_OPEN_DUP_NUM) { - bin_tree_t *dup_tree = parse_dup_op (tree, regexp, dfa, token, - syntax, err); - if (BE (*err != REG_NOERROR && dup_tree == NULL, 0)) - { - if (tree != NULL) - postorder (tree, free_tree, NULL); - return NULL; - } - tree = dup_tree; + tree = parse_dup_op (tree, regexp, dfa, token, syntax, err); + if (BE (*err != REG_NOERROR && tree == NULL, 0)) + return NULL; /* In BRE consecutive duplications are not allowed. */ if ((syntax & RE_CONTEXT_INVALID_DUP) && (token->type == OP_DUP_ASTERISK || token->type == OP_OPEN_DUP_NUM)) { - if (tree != NULL) - postorder (tree, free_tree, NULL); *err = REG_BADRPT; return NULL; } @@ -2643,8 +2623,6 @@ parse_dup_op (bin_tree_t *elem, re_string_t *regexp, re_dfa_t *dfa, /* Duplicate ELEM before it is marked optional. */ elem = duplicate_tree (elem, dfa); - if (BE (elem == NULL, 0)) - goto parse_dup_op_espace; old_tree = tree; } else @@ -3183,7 +3161,6 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token, re_token_t token2; start_elem.opr.name = start_name_buf; - start_elem.type = COLL_SYM; ret = parse_bracket_element (&start_elem, regexp, token, token_len, dfa, syntax, first_round); if (BE (ret != REG_NOERROR, 0)) @@ -3227,7 +3204,6 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token, if (is_range_exp == true) { end_elem.opr.name = end_name_buf; - end_elem.type = COLL_SYM; ret = parse_bracket_element (&end_elem, regexp, &token2, token_len2, dfa, syntax, true); if (BE (ret != REG_NOERROR, 0)) @@ -3502,6 +3478,8 @@ build_equiv_class (bitset_t sbcset, const unsigned char *name) int32_t idx1, idx2; unsigned int ch; size_t len; + /* This #include defines a local function! */ +# include /* Calculate the index for equivalence class. */ cp = name; table = (const int32_t *) _NL_CURRENT (LC_COLLATE, _NL_COLLATE_TABLEMB); @@ -3511,7 +3489,7 @@ build_equiv_class (bitset_t sbcset, const unsigned char *name) _NL_COLLATE_EXTRAMB); indirect = (const int32_t *) _NL_CURRENT (LC_COLLATE, _NL_COLLATE_INDIRECTMB); - idx1 = findidx (table, indirect, extra, &cp, -1); + idx1 = findidx (&cp, -1); if (BE (idx1 == 0 || *cp != '\0', 0)) /* This isn't a valid character. */ return REG_ECOLLATE; @@ -3522,7 +3500,7 @@ build_equiv_class (bitset_t sbcset, const unsigned char *name) { char_buf[0] = ch; cp = char_buf; - idx2 = findidx (table, indirect, extra, &cp, 1); + idx2 = findidx (&cp, 1); /* idx2 = table[ch]; */ diff --git a/lib/regex.c b/lib/regex.c index 1adc8a8ae..e44f55fd1 100644 --- a/lib/regex.c +++ b/lib/regex.c @@ -1,5 +1,5 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2015 Free Software Foundation, Inc. + Copyright (C) 2002-2014 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa . diff --git a/lib/regex.h b/lib/regex.h index 6f3bae3ae..54327c69e 100644 --- a/lib/regex.h +++ b/lib/regex.h @@ -1,6 +1,6 @@ /* Definitions for data structures and routines for the regular expression library. - Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2015 Free Software + Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2014 Free Software Foundation, Inc. This file is part of the GNU C Library. @@ -244,16 +244,19 @@ extern reg_syntax_t re_syntax_options; | RE_INVALID_INTERVAL_ORD) # define RE_SYNTAX_GREP \ - ((RE_SYNTAX_POSIX_BASIC | RE_NEWLINE_ALT) \ - & ~(RE_CONTEXT_INVALID_DUP | RE_DOT_NOT_NULL)) + (RE_BK_PLUS_QM | RE_CHAR_CLASSES \ + | RE_HAT_LISTS_NOT_NEWLINE | RE_INTERVALS \ + | RE_NEWLINE_ALT) # define RE_SYNTAX_EGREP \ - ((RE_SYNTAX_POSIX_EXTENDED | RE_INVALID_INTERVAL_ORD | RE_NEWLINE_ALT) \ - & ~(RE_CONTEXT_INVALID_OPS | RE_DOT_NOT_NULL)) + (RE_CHAR_CLASSES | RE_CONTEXT_INDEP_ANCHORS \ + | RE_CONTEXT_INDEP_OPS | RE_HAT_LISTS_NOT_NEWLINE \ + | RE_NEWLINE_ALT | RE_NO_BK_PARENS \ + | RE_NO_BK_VBAR) -/* POSIX grep -E behavior is no longer incompatible with GNU. */ # define RE_SYNTAX_POSIX_EGREP \ - RE_SYNTAX_EGREP + (RE_SYNTAX_EGREP | RE_INTERVALS | RE_NO_BK_BRACES \ + | RE_INVALID_INTERVAL_ORD) /* P1003.2/D11.2, section 4.20.7.1, lines 5078ff. */ # define RE_SYNTAX_ED RE_SYNTAX_POSIX_BASIC @@ -605,7 +608,7 @@ extern void re_set_registers (struct re_pattern_buffer *__buffer, regoff_t *__starts, regoff_t *__ends); #endif /* Use GNU */ -#if defined _REGEX_RE_COMP || (defined _LIBC && defined __USE_MISC) +#if defined _REGEX_RE_COMP || (defined _LIBC && defined __USE_BSD) # ifndef _CRAY /* 4.2 bsd compatibility. */ extern char *re_comp (const char *); diff --git a/lib/regex_internal.c b/lib/regex_internal.c index 93d7ee964..0343ee6e3 100644 --- a/lib/regex_internal.c +++ b/lib/regex_internal.c @@ -1,5 +1,5 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2015 Free Software Foundation, Inc. + Copyright (C) 2002-2014 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa . @@ -311,12 +311,13 @@ build_wcs_upper_buffer (re_string_t *pstr) + byte_idx), remain_len, &pstr->cur_state); if (BE (mbclen < (size_t) -2, 1)) { - wchar_t wcu = __towupper (wc); - if (wcu != wc) + wchar_t wcu = wc; + if (iswlower (wc)) { size_t mbcdlen; - mbcdlen = __wcrtomb (buf, wcu, &prev_st); + wcu = towupper (wc); + mbcdlen = wcrtomb (buf, wcu, &prev_st); if (BE (mbclen == mbcdlen, 1)) memcpy (pstr->mbs + byte_idx, buf, mbclen); else @@ -380,11 +381,12 @@ build_wcs_upper_buffer (re_string_t *pstr) mbclen = __mbrtowc (&wc, p, remain_len, &pstr->cur_state); if (BE (mbclen < (size_t) -2, 1)) { - wchar_t wcu = __towupper (wc); - if (wcu != wc) + wchar_t wcu = wc; + if (iswlower (wc)) { size_t mbcdlen; + wcu = towupper (wc); mbcdlen = wcrtomb ((char *) buf, wcu, &prev_st); if (BE (mbclen == mbcdlen, 1)) memcpy (pstr->mbs + byte_idx, buf, mbclen); @@ -536,7 +538,10 @@ build_upper_buffer (re_string_t *pstr) int ch = pstr->raw_mbs[pstr->raw_mbs_idx + char_idx]; if (BE (pstr->trans != NULL, 0)) ch = pstr->trans[ch]; - pstr->mbs[char_idx] = toupper (ch); + if (islower (ch)) + pstr->mbs[char_idx] = toupper (ch); + else + pstr->mbs[char_idx] = ch; } pstr->valid_len = char_idx; pstr->valid_raw_len = char_idx; @@ -677,7 +682,7 @@ re_string_reconstruct (re_string_t *pstr, Idx idx, int eflags) pstr->valid_len - offset); pstr->valid_len -= offset; pstr->valid_raw_len -= offset; -#if defined DEBUG && DEBUG +#if DEBUG assert (pstr->valid_len > 0); #endif } @@ -936,7 +941,7 @@ re_string_context_at (const re_string_t *input, Idx idx, int eflags) Idx wc_idx = idx; while(input->wcs[wc_idx] == WEOF) { -#if defined DEBUG && DEBUG +#ifdef DEBUG /* It must not happen. */ assert (REG_VALID_INDEX (wc_idx)); #endif diff --git a/lib/regex_internal.h b/lib/regex_internal.h index 0307a340f..a0eae33e9 100644 --- a/lib/regex_internal.h +++ b/lib/regex_internal.h @@ -1,5 +1,5 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2015 Free Software Foundation, Inc. + Copyright (C) 2002-2014 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa . @@ -34,13 +34,13 @@ #include #ifdef _LIBC -# include +# include # define lock_define(name) __libc_lock_define (, name) # define lock_init(lock) (__libc_lock_init (lock), 0) # define lock_fini(lock) 0 # define lock_lock(lock) __libc_lock_lock (lock) # define lock_unlock(lock) __libc_lock_unlock (lock) -#elif defined GNULIB_LOCK && !defined USE_UNLOCKED_IO +#elif defined GNULIB_LOCK # include "glthread/lock.h" /* Use gl_lock_define if empty macro arguments are known to work. Otherwise, fall back on less-portable substitutes. */ @@ -62,7 +62,7 @@ # define lock_fini(lock) glthread_lock_destroy (&(lock)) # define lock_lock(lock) glthread_lock_lock (&(lock)) # define lock_unlock(lock) glthread_lock_unlock (&(lock)) -#elif defined GNULIB_PTHREAD && !defined USE_UNLOCKED_IO +#elif defined GNULIB_PTHREAD # include # define lock_define(name) pthread_mutex_t name; # define lock_init(lock) pthread_mutex_init (&(lock), 0) @@ -87,6 +87,7 @@ # ifndef _RE_DEFINE_LOCALE_FUNCTIONS # define _RE_DEFINE_LOCALE_FUNCTIONS 1 # include +# include # include # endif #endif @@ -136,10 +137,7 @@ # undef __wctype # undef __iswctype # define __wctype wctype -# define __iswalnum iswalnum # define __iswctype iswctype -# define __towlower towlower -# define __towupper towupper # define __btowc btowc # define __mbrtowc mbrtowc # define __wcrtomb wcrtomb @@ -449,23 +447,23 @@ typedef struct re_dfa_t re_dfa_t; #ifndef _LIBC # define internal_function -# define IS_IN(libc) false #endif +#ifndef NOT_IN_libc static reg_errcode_t re_string_realloc_buffers (re_string_t *pstr, Idx new_buf_len) internal_function; -#ifdef RE_ENABLE_I18N +# ifdef RE_ENABLE_I18N static void build_wcs_buffer (re_string_t *pstr) internal_function; static reg_errcode_t build_wcs_upper_buffer (re_string_t *pstr) internal_function; -#endif /* RE_ENABLE_I18N */ +# endif /* RE_ENABLE_I18N */ static void build_upper_buffer (re_string_t *pstr) internal_function; static void re_string_translate_buffer (re_string_t *pstr) internal_function; static unsigned int re_string_context_at (const re_string_t *input, Idx idx, int eflags) internal_function __attribute__ ((pure)); - +#endif #define re_string_peek_byte(pstr, offset) \ ((pstr)->mbs[(pstr)->cur_idx + offset]) #define re_string_fetch_byte(pstr) \ @@ -558,7 +556,7 @@ typedef struct bin_tree_storage_t bin_tree_storage_t; #define IS_WORD_CHAR(ch) (isalnum (ch) || (ch) == '_') #define IS_NEWLINE(ch) ((ch) == NEWLINE_CHAR) -#define IS_WIDE_WORD_CHAR(ch) (__iswalnum (ch) || (ch) == L'_') +#define IS_WIDE_WORD_CHAR(ch) (iswalnum (ch) || (ch) == L'_') #define IS_WIDE_NEWLINE(ch) ((ch) == WIDE_NEWLINE_CHAR) #define NOT_SATISFY_PREV_CONSTRAINT(constraint,context) \ @@ -862,17 +860,15 @@ re_string_wchar_at (const re_string_t *pstr, Idx idx) return (wint_t) pstr->wcs[idx]; } -# ifdef _LIBC -# include -# endif - +# ifndef NOT_IN_libc static int internal_function __attribute__ ((pure, unused)) re_string_elem_size_at (const re_string_t *pstr, Idx idx) { -# ifdef _LIBC +# ifdef _LIBC const unsigned char *p, *extra; const int32_t *table, *indirect; +# include uint_fast32_t nrules = _NL_CURRENT_WORD (LC_COLLATE, _NL_COLLATE_NRULES); if (nrules != 0) @@ -883,13 +879,14 @@ re_string_elem_size_at (const re_string_t *pstr, Idx idx) indirect = (const int32_t *) _NL_CURRENT (LC_COLLATE, _NL_COLLATE_INDIRECTMB); p = pstr->mbs + idx; - findidx (table, indirect, extra, &p, pstr->len - idx); + findidx (&p, pstr->len - idx); return p - pstr->mbs - idx; } else -# endif /* _LIBC */ +# endif /* _LIBC */ return 1; } +# endif #endif /* RE_ENABLE_I18N */ #ifndef __GNUC_PREREQ diff --git a/lib/regexec.c b/lib/regexec.c index db50a564a..05a8e807e 100644 --- a/lib/regexec.c +++ b/lib/regexec.c @@ -1,5 +1,5 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2015 Free Software Foundation, Inc. + Copyright (C) 2002-2014 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa . @@ -3776,10 +3776,6 @@ group_nodes_into_DFAstates (const re_dfa_t *dfa, const re_dfastate_t *state, one collating element like '.', '[a-z]', opposite to the other nodes can only accept one byte. */ -# ifdef _LIBC -# include -# endif - static int internal_function check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx, @@ -3899,6 +3895,8 @@ check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx, const int32_t *table, *indirect; const unsigned char *weights, *extra; const char *collseqwc; + /* This #include defines a local function! */ +# include /* match with collating_symbol? */ if (cset->ncoll_syms) @@ -3955,7 +3953,7 @@ check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx, _NL_CURRENT (LC_COLLATE, _NL_COLLATE_EXTRAMB); indirect = (const int32_t *) _NL_CURRENT (LC_COLLATE, _NL_COLLATE_INDIRECTMB); - int32_t idx = findidx (table, indirect, extra, &cp, elem_len); + int32_t idx = findidx (&cp, elem_len); if (idx > 0) for (i = 0; i < cset->nequiv_classes; ++i) { diff --git a/lib/rename.c b/lib/rename.c index feb2bd11f..1cd4e6da3 100644 --- a/lib/rename.c +++ b/lib/rename.c @@ -1,6 +1,6 @@ /* Work around rename bugs in some systems. - Copyright (C) 2001-2003, 2005-2006, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2001-2003, 2005-2006, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -285,7 +285,7 @@ rpl_rename (char const *src, char const *dst) char *dst_temp = (char *) dst; bool src_slash; bool dst_slash; - bool dst_exists _GL_UNUSED; + bool dst_exists; int ret_val = -1; int rename_errno = ENOTDIR; struct stat src_st; @@ -462,9 +462,7 @@ rpl_rename (char const *src, char const *dst) ret_val = rename (src_temp, dst_temp); rename_errno = errno; - - out: _GL_UNUSED_LABEL; - + out: if (src_temp != src) free (src_temp); if (dst_temp != dst) diff --git a/lib/rmdir.c b/lib/rmdir.c index 98dc37f51..964dd2028 100644 --- a/lib/rmdir.c +++ b/lib/rmdir.c @@ -1,6 +1,6 @@ /* Work around rmdir bugs. - Copyright (C) 1988, 1990, 1999, 2003-2006, 2009-2015 Free Software + Copyright (C) 1988, 1990, 1999, 2003-2006, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/round.c b/lib/round.c index ea43e2f7b..d1c2aac5a 100644 --- a/lib/round.c +++ b/lib/round.c @@ -1,5 +1,5 @@ /* Round toward nearest, breaking ties away from zero. - Copyright (C) 2007, 2010-2015 Free Software Foundation, Inc. + Copyright (C) 2007, 2010-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/safe-read.c b/lib/safe-read.c index 2b29d7b5a..6c9639f40 100644 --- a/lib/safe-read.c +++ b/lib/safe-read.c @@ -1,6 +1,6 @@ /* An interface to read and write that retries after interrupts. - Copyright (C) 1993-1994, 1998, 2002-2006, 2009-2015 Free Software + Copyright (C) 1993-1994, 1998, 2002-2006, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/safe-read.h b/lib/safe-read.h index bdefa97f1..6cd5f68fc 100644 --- a/lib/safe-read.h +++ b/lib/safe-read.h @@ -1,5 +1,5 @@ /* An interface to read() that retries after interrupts. - Copyright (C) 2002, 2006, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2002, 2006, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/safe-write.c b/lib/safe-write.c index 0828ccb36..3e7ffd627 100644 --- a/lib/safe-write.c +++ b/lib/safe-write.c @@ -1,5 +1,5 @@ /* An interface to write that retries after interrupts. - Copyright (C) 2002, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2002, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/safe-write.h b/lib/safe-write.h index c156ae783..45a61463a 100644 --- a/lib/safe-write.h +++ b/lib/safe-write.h @@ -1,5 +1,5 @@ /* An interface to write() that retries after interrupts. - Copyright (C) 2002, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2002, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/same-inode.h b/lib/same-inode.h index b91a02b95..f85a3cce8 100644 --- a/lib/same-inode.h +++ b/lib/same-inode.h @@ -1,6 +1,6 @@ /* Determine whether two stat buffers refer to the same file. - Copyright (C) 2006, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2006, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/secure_getenv.c b/lib/secure_getenv.c index 3a5216279..7b86173bb 100644 --- a/lib/secure_getenv.c +++ b/lib/secure_getenv.c @@ -1,6 +1,6 @@ /* Look up an environment variable more securely. - Copyright 2013-2015 Free Software Foundation, Inc. + Copyright 2013-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/select.c b/lib/select.c index 6f519878c..a31f90224 100644 --- a/lib/select.c +++ b/lib/select.c @@ -1,7 +1,7 @@ /* Emulation for select(2) Contributed by Paolo Bonzini. - Copyright 2008-2015 Free Software Foundation, Inc. + Copyright 2008-2014 Free Software Foundation, Inc. This file is part of gnulib. @@ -82,11 +82,9 @@ typedef DWORD (WINAPI *PNtQueryInformationFile) #define PIPE_BUF 512 #endif -static BOOL IsConsoleHandle (HANDLE h) -{ - DWORD mode; - return GetConsoleMode (h, &mode) != 0; -} +/* Optimized test whether a HANDLE refers to a console. + See . */ +#define IsConsoleHandle(h) (((intptr_t) (h) & 3) == 3) static BOOL IsSocketHandle (HANDLE h) @@ -254,7 +252,6 @@ rpl_select (int nfds, fd_set *rfds, fd_set *wfds, fd_set *xfds, DWORD ret, wait_timeout, nhandles, nsock, nbuffer; MSG msg; int i, fd, rc; - clock_t tend; if (nfds > FD_SETSIZE) nfds = FD_SETSIZE; @@ -391,10 +388,6 @@ rpl_select (int nfds, fd_set *rfds, fd_set *wfds, fd_set *xfds, /* Place a sentinel at the end of the array. */ handle_array[nhandles] = NULL; - /* When will the waiting period expire? */ - if (wait_timeout != INFINITE) - tend = clock () + wait_timeout; - restart: if (wait_timeout == 0 || nsock == 0) rc = 0; @@ -415,16 +408,6 @@ restart: wait_timeout = 0; } - /* How much is left to wait? */ - if (wait_timeout != INFINITE) - { - clock_t tnow = clock (); - if (tend >= tnow) - wait_timeout = tend - tnow; - else - wait_timeout = 0; - } - for (;;) { ret = MsgWaitForMultipleObjects (nhandles, handle_array, FALSE, @@ -470,16 +453,7 @@ restart: } } - if (rc == 0 - && (wait_timeout == INFINITE - /* If NHANDLES > 1, but no bits are set, it means we've - been told incorrectly that some handle was signaled. - This happens with anonymous pipes, which always cause - MsgWaitForMultipleObjects to exit immediately, but no - data is found ready to be read by windows_poll_handle. - To avoid a total failure (whereby we return zero and - don't wait at all), let's poll in a more busy loop. */ - || (wait_timeout != 0 && nhandles > 1))) + if (rc == 0 && wait_timeout == INFINITE) { /* Sleep 1 millisecond to avoid busy wait and retry with the original fd_sets. */ @@ -489,8 +463,6 @@ restart: SleepEx (1, TRUE); goto restart; } - if (timeout && wait_timeout == 0 && rc == 0) - timeout->tv_sec = timeout->tv_usec = 0; } /* Now fill in the results. */ diff --git a/lib/send.c b/lib/send.c index 54315d359..9e70c91af 100644 --- a/lib/send.c +++ b/lib/send.c @@ -1,6 +1,6 @@ /* send.c --- wrappers for Windows send function - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sendto.c b/lib/sendto.c index f7f11d602..69b8ebc9f 100644 --- a/lib/sendto.c +++ b/lib/sendto.c @@ -1,6 +1,6 @@ /* sendto.c --- wrappers for Windows sendto function - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/setenv.c b/lib/setenv.c index 689b404d0..50e686025 100644 --- a/lib/setenv.c +++ b/lib/setenv.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1992, 1995-2003, 2005-2015 Free Software Foundation, Inc. +/* Copyright (C) 1992, 1995-2003, 2005-2014 Free Software Foundation, Inc. This file is part of the GNU C Library. This program is free software: you can redistribute it and/or modify diff --git a/lib/setsockopt.c b/lib/setsockopt.c index 56b4827c2..2b905daa0 100644 --- a/lib/setsockopt.c +++ b/lib/setsockopt.c @@ -1,6 +1,6 @@ /* setsockopt.c --- wrappers for Windows setsockopt function - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/shutdown.c b/lib/shutdown.c index 29c325ef0..54b7728dd 100644 --- a/lib/shutdown.c +++ b/lib/shutdown.c @@ -1,6 +1,6 @@ /* shutdown.c --- wrappers for Windows shutdown function - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/signal.in.h b/lib/signal.in.h index 3ea23eee5..057fa9ef5 100644 --- a/lib/signal.in.h +++ b/lib/signal.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 2006-2015 Free Software Foundation, Inc. + Copyright (C) 2006-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -55,13 +55,11 @@ #ifndef _@GUARD_PREFIX@_SIGNAL_H #define _@GUARD_PREFIX@_SIGNAL_H -/* Mac OS X 10.3, FreeBSD 6.4, OpenBSD 3.8, OSF/1 4.0, Solaris 2.6, Android - declare pthread_sigmask in , not in . +/* Mac OS X 10.3, FreeBSD 6.4, OpenBSD 3.8, OSF/1 4.0, Solaris 2.6 declare + pthread_sigmask in , not in . But avoid namespace pollution on glibc systems.*/ #if (@GNULIB_PTHREAD_SIGMASK@ || defined GNULIB_POSIXCHECK) \ - && ((defined __APPLE__ && defined __MACH__) \ - || defined __FreeBSD__ || defined __OpenBSD__ || defined __osf__ \ - || defined __sun || defined __ANDROID__) \ + && ((defined __APPLE__ && defined __MACH__) || defined __FreeBSD__ || defined __OpenBSD__ || defined __osf__ || defined __sun) \ && ! defined __GLIBC__ # include #endif diff --git a/lib/signbitd.c b/lib/signbitd.c index 03beeecfb..1efb6e6a2 100644 --- a/lib/signbitd.c +++ b/lib/signbitd.c @@ -1,5 +1,5 @@ /* signbit() macro: Determine the sign bit of a floating-point number. - Copyright (C) 2007-2015 Free Software Foundation, Inc. + Copyright (C) 2007-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/signbitf.c b/lib/signbitf.c index 51a685234..3240e4ec0 100644 --- a/lib/signbitf.c +++ b/lib/signbitf.c @@ -1,5 +1,5 @@ /* signbit() macro: Determine the sign bit of a floating-point number. - Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/signbitl.c b/lib/signbitl.c index 0142c33df..3f847257c 100644 --- a/lib/signbitl.c +++ b/lib/signbitl.c @@ -1,5 +1,5 @@ /* signbit() macro: Determine the sign bit of a floating-point number. - Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/size_max.h b/lib/size_max.h index 935cf8978..680ca0fff 100644 --- a/lib/size_max.h +++ b/lib/size_max.h @@ -1,5 +1,5 @@ /* size_max.h -- declare SIZE_MAX through system headers - Copyright (C) 2005-2006, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2005-2006, 2009-2014 Free Software Foundation, Inc. Written by Simon Josefsson. This program is free software; you can redistribute it and/or modify diff --git a/lib/snprintf.c b/lib/snprintf.c index f5a38629b..0b8cbf88f 100644 --- a/lib/snprintf.c +++ b/lib/snprintf.c @@ -1,5 +1,5 @@ /* Formatted output to strings. - Copyright (C) 2004, 2006-2015 Free Software Foundation, Inc. + Copyright (C) 2004, 2006-2014 Free Software Foundation, Inc. Written by Simon Josefsson and Paul Eggert. This program is free software; you can redistribute it and/or modify diff --git a/lib/socket.c b/lib/socket.c index da46cb907..c10d4f6ad 100644 --- a/lib/socket.c +++ b/lib/socket.c @@ -1,6 +1,6 @@ /* socket.c --- wrappers for Windows socket function - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sockets.c b/lib/sockets.c index acf41b526..98fe879ee 100644 --- a/lib/sockets.c +++ b/lib/sockets.c @@ -1,6 +1,6 @@ /* sockets.c --- wrappers for Windows socket functions - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -121,11 +121,8 @@ gl_sockets_startup (int version _GL_UNUSED) if (err != 0) return 1; - if (data.wVersion != version) - { - WSACleanup (); - return 2; - } + if (data.wVersion < version) + return 2; if (initialized_sockets_version == 0) register_fd_hook (close_fd_maybe_socket, ioctl_fd_maybe_socket, diff --git a/lib/sockets.h b/lib/sockets.h index 66b947224..dd99ec172 100644 --- a/lib/sockets.h +++ b/lib/sockets.h @@ -1,6 +1,6 @@ /* sockets.h - wrappers for Windows socket functions - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -20,11 +20,11 @@ #ifndef SOCKETS_H # define SOCKETS_H 1 -#define SOCKETS_1_0 0x0001 -#define SOCKETS_1_1 0x0101 -#define SOCKETS_2_0 0x0002 -#define SOCKETS_2_1 0x0102 -#define SOCKETS_2_2 0x0202 +#define SOCKETS_1_0 0x100 /* don't use - does not work on Windows XP */ +#define SOCKETS_1_1 0x101 +#define SOCKETS_2_0 0x200 /* don't use - does not work on Windows XP */ +#define SOCKETS_2_1 0x201 +#define SOCKETS_2_2 0x202 int gl_sockets_startup (int version) #if !WINDOWS_SOCKETS diff --git a/lib/stat-time.h b/lib/stat-time.h index 82b83acef..570001361 100644 --- a/lib/stat-time.h +++ b/lib/stat-time.h @@ -1,6 +1,6 @@ /* stat-related time functions. - Copyright (C) 2005, 2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2005, 2007, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -54,7 +54,7 @@ _GL_INLINE_HEADER_BEGIN #endif /* Return the nanosecond component of *ST's access time. */ -_GL_STAT_TIME_INLINE long int _GL_ATTRIBUTE_PURE +_GL_STAT_TIME_INLINE long int get_stat_atime_ns (struct stat const *st) { # if defined STAT_TIMESPEC @@ -67,7 +67,7 @@ get_stat_atime_ns (struct stat const *st) } /* Return the nanosecond component of *ST's status change time. */ -_GL_STAT_TIME_INLINE long int _GL_ATTRIBUTE_PURE +_GL_STAT_TIME_INLINE long int get_stat_ctime_ns (struct stat const *st) { # if defined STAT_TIMESPEC @@ -80,7 +80,7 @@ get_stat_ctime_ns (struct stat const *st) } /* Return the nanosecond component of *ST's data modification time. */ -_GL_STAT_TIME_INLINE long int _GL_ATTRIBUTE_PURE +_GL_STAT_TIME_INLINE long int get_stat_mtime_ns (struct stat const *st) { # if defined STAT_TIMESPEC @@ -93,7 +93,7 @@ get_stat_mtime_ns (struct stat const *st) } /* Return the nanosecond component of *ST's birth time. */ -_GL_STAT_TIME_INLINE long int _GL_ATTRIBUTE_PURE +_GL_STAT_TIME_INLINE long int get_stat_birthtime_ns (struct stat const *st) { # if defined HAVE_STRUCT_STAT_ST_BIRTHTIMESPEC_TV_NSEC @@ -108,7 +108,7 @@ get_stat_birthtime_ns (struct stat const *st) } /* Return *ST's access time. */ -_GL_STAT_TIME_INLINE struct timespec _GL_ATTRIBUTE_PURE +_GL_STAT_TIME_INLINE struct timespec get_stat_atime (struct stat const *st) { #ifdef STAT_TIMESPEC @@ -122,7 +122,7 @@ get_stat_atime (struct stat const *st) } /* Return *ST's status change time. */ -_GL_STAT_TIME_INLINE struct timespec _GL_ATTRIBUTE_PURE +_GL_STAT_TIME_INLINE struct timespec get_stat_ctime (struct stat const *st) { #ifdef STAT_TIMESPEC @@ -136,7 +136,7 @@ get_stat_ctime (struct stat const *st) } /* Return *ST's data modification time. */ -_GL_STAT_TIME_INLINE struct timespec _GL_ATTRIBUTE_PURE +_GL_STAT_TIME_INLINE struct timespec get_stat_mtime (struct stat const *st) { #ifdef STAT_TIMESPEC @@ -151,7 +151,7 @@ get_stat_mtime (struct stat const *st) /* Return *ST's birth time, if available; otherwise return a value with tv_sec and tv_nsec both equal to -1. */ -_GL_STAT_TIME_INLINE struct timespec _GL_ATTRIBUTE_PURE +_GL_STAT_TIME_INLINE struct timespec get_stat_birthtime (struct stat const *st) { struct timespec t; diff --git a/lib/stat.c b/lib/stat.c index 47f6c3b97..60bbd693e 100644 --- a/lib/stat.c +++ b/lib/stat.c @@ -1,5 +1,5 @@ /* Work around platform bugs in stat. - Copyright (C) 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/stdalign.in.h b/lib/stdalign.in.h index 31bb7bce0..29861efe1 100644 --- a/lib/stdalign.in.h +++ b/lib/stdalign.in.h @@ -1,6 +1,6 @@ /* A substitute for ISO C11 . - Copyright 2011-2015 Free Software Foundation, Inc. + Copyright 2011-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -52,10 +52,7 @@ #undef _Alignas #undef _Alignof -/* GCC releases before GCC 4.9 had a bug in _Alignof. See GCC bug 52023 - . */ -#if (!defined __STDC_VERSION__ || __STDC_VERSION__ < 201112 \ - || (defined __GNUC__ && __GNUC__ < 4 + (__GNUC_MINOR__ < 9))) +#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112 # ifdef __cplusplus # if 201103 <= __cplusplus # define _Alignof(type) alignof (type) @@ -67,9 +64,7 @@ # define _Alignof(type) offsetof (struct { char __a; type __b; }, __b) # endif #endif -#if ! (defined __cplusplus && 201103 <= __cplusplus) -# define alignof _Alignof -#endif +#define alignof _Alignof #define __alignof_is_defined 1 /* alignas (A), also known as _Alignas (A), aligns a variable or type @@ -100,21 +95,15 @@ #if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112 # if defined __cplusplus && 201103 <= __cplusplus # define _Alignas(a) alignas (a) -# elif ((defined __APPLE__ && defined __MACH__ \ - ? 4 < __GNUC__ + (1 <= __GNUC_MINOR__) \ - : __GNUC__) \ - || __HP_cc || __HP_aCC || __IBMC__ || __IBMCPP__ \ +# elif (__GNUC__ || __HP_cc || __HP_aCC || __IBMC__ || __IBMCPP__ \ || __ICC || 0x5110 <= __SUNPRO_C) # define _Alignas(a) __attribute__ ((__aligned__ (a))) # elif 1300 <= _MSC_VER # define _Alignas(a) __declspec (align (a)) # endif #endif -#if ((defined _Alignas && ! (defined __cplusplus && 201103 <= __cplusplus)) \ - || (defined __STDC_VERSION && 201112 <= __STDC_VERSION__)) +#if defined _Alignas || (defined __STDC_VERSION && 201112 <= __STDC_VERSION__) # define alignas _Alignas -#endif -#if defined alignas || (defined __cplusplus && 201103 <= __cplusplus) # define __alignas_is_defined 1 #endif diff --git a/lib/stdbool.in.h b/lib/stdbool.in.h index fb1cde05f..2f34a13fb 100644 --- a/lib/stdbool.in.h +++ b/lib/stdbool.in.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2001-2003, 2006-2015 Free Software Foundation, Inc. +/* Copyright (C) 2001-2003, 2006-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2001. This program is free software; you can redistribute it and/or modify diff --git a/lib/stddef.in.h b/lib/stddef.in.h index 383d44135..204c4bcf0 100644 --- a/lib/stddef.in.h +++ b/lib/stddef.in.h @@ -1,6 +1,6 @@ /* A substitute for POSIX 2008 , for platforms that have issues. - Copyright (C) 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2009-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -39,6 +39,7 @@ # if !(defined _@GUARD_PREFIX@_STDDEF_H && defined _GL_STDDEF_WINT_T) # ifdef __need_wint_t +# undef _@GUARD_PREFIX@_STDDEF_H # define _GL_STDDEF_WINT_T # endif # @INCLUDE_NEXT@ @NEXT_STDDEF_H@ @@ -53,56 +54,33 @@ # @INCLUDE_NEXT@ @NEXT_STDDEF_H@ +# ifndef _@GUARD_PREFIX@_STDDEF_H +# define _@GUARD_PREFIX@_STDDEF_H + /* On NetBSD 5.0, the definition of NULL lacks proper parentheses. */ -# if (@REPLACE_NULL@ \ - && (!defined _@GUARD_PREFIX@_STDDEF_H || defined _GL_STDDEF_WINT_T)) -# undef NULL -# ifdef __cplusplus +#if @REPLACE_NULL@ +# undef NULL +# ifdef __cplusplus /* ISO C++ says that the macro NULL must expand to an integer constant expression, hence '((void *) 0)' is not allowed in C++. */ -# if __GNUG__ >= 3 +# if __GNUG__ >= 3 /* GNU C++ has a __null macro that behaves like an integer ('int' or 'long') but has the same size as a pointer. Use that, to avoid warnings. */ -# define NULL __null -# else -# define NULL 0L -# endif -# else -# define NULL ((void *) 0) -# endif +# define NULL __null +# else +# define NULL 0L # endif - -# ifndef _@GUARD_PREFIX@_STDDEF_H -# define _@GUARD_PREFIX@_STDDEF_H +# else +# define NULL ((void *) 0) +# endif +#endif /* Some platforms lack wchar_t. */ #if !@HAVE_WCHAR_T@ # define wchar_t int #endif -/* Some platforms lack max_align_t. */ -#if !@HAVE_MAX_ALIGN_T@ -/* On the x86, the maximum storage alignment of double, long, etc. is 4, - but GCC's C11 ABI for x86 says that max_align_t has an alignment of 8, - and the C11 standard allows this. Work around this problem by - using __alignof__ (which returns 8 for double) rather than _Alignof - (which returns 4), and align each union member accordingly. */ -# ifdef __GNUC__ -# define _GL_STDDEF_ALIGNAS(type) \ - __attribute__ ((__aligned__ (__alignof__ (type)))) -# else -# define _GL_STDDEF_ALIGNAS(type) /* */ -# endif -typedef union -{ - char *__p _GL_STDDEF_ALIGNAS (char *); - double __d _GL_STDDEF_ALIGNAS (double); - long double __ld _GL_STDDEF_ALIGNAS (long double); - long int __i _GL_STDDEF_ALIGNAS (long int); -} max_align_t; -#endif - # endif /* _@GUARD_PREFIX@_STDDEF_H */ # endif /* _@GUARD_PREFIX@_STDDEF_H */ #endif /* __need_XXX */ diff --git a/lib/stdint.in.h b/lib/stdint.in.h index cf3655871..b1296f9ea 100644 --- a/lib/stdint.in.h +++ b/lib/stdint.in.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2001-2002, 2004-2015 Free Software Foundation, Inc. +/* Copyright (C) 2001-2002, 2004-2014 Free Software Foundation, Inc. Written by Paul Eggert, Bruno Haible, Sam Steingold, Peter Burwood. This file is part of gnulib. @@ -38,7 +38,8 @@ other system header files; just include the system's . Ideally we should test __BIONIC__ here, but it is only defined after has been included; hence test __ANDROID__ instead. */ -#if defined __ANDROID__ && defined _GL_INCLUDING_SYS_TYPES_H +#if defined __ANDROID__ \ + && defined _SYS_TYPES_H_ && !defined __need_size_t # @INCLUDE_NEXT@ @NEXT_STDINT_H@ #else diff --git a/lib/stdio.in.h b/lib/stdio.in.h index d9fd18561..faa778b1d 100644 --- a/lib/stdio.in.h +++ b/lib/stdio.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 2004, 2007-2015 Free Software Foundation, Inc. + Copyright (C) 2004, 2007-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -84,13 +84,8 @@ except that it indicates to GCC that the supported format string directives are the ones of the system printf(), rather than the ones standardized by ISO C99 and POSIX. */ -#if GNULIB_PRINTF_ATTRIBUTE_FLAVOR_GNU -# define _GL_ATTRIBUTE_FORMAT_PRINTF_SYSTEM(formatstring_parameter, first_argument) \ - _GL_ATTRIBUTE_FORMAT_PRINTF (formatstring_parameter, first_argument) -#else -# define _GL_ATTRIBUTE_FORMAT_PRINTF_SYSTEM(formatstring_parameter, first_argument) \ +#define _GL_ATTRIBUTE_FORMAT_PRINTF_SYSTEM(formatstring_parameter, first_argument) \ _GL_ATTRIBUTE_FORMAT ((__printf__, formatstring_parameter, first_argument)) -#endif /* _GL_ATTRIBUTE_FORMAT_SCANF indicates to GCC that the function takes a format string and arguments, @@ -723,10 +718,11 @@ _GL_WARN_ON_USE (getline, "getline is unportable - " so any use of gets warrants an unconditional warning; besides, C11 removed it. */ #undef gets -#if HAVE_RAW_DECL_GETS && !defined __cplusplus +#if HAVE_RAW_DECL_GETS _GL_WARN_ON_USE (gets, "gets is a security hole - use fgets instead"); #endif + #if @GNULIB_OBSTACK_PRINTF@ || @GNULIB_OBSTACK_PRINTF_POSIX@ struct obstack; /* Grow an obstack with formatted output. Return the number of diff --git a/lib/stdlib.in.h b/lib/stdlib.in.h index fc46a2115..57d32cc48 100644 --- a/lib/stdlib.in.h +++ b/lib/stdlib.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 1995, 2001-2004, 2006-2015 Free Software Foundation, Inc. + Copyright (C) 1995, 2001-2004, 2006-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -520,29 +520,6 @@ _GL_CXXALIAS_SYS (putenv, int, (char *string)); _GL_CXXALIASWARN (putenv); #endif -#if @GNULIB_QSORT_R@ -# if @REPLACE_QSORT_R@ -# if !(defined __cplusplus && defined GNULIB_NAMESPACE) -# undef qsort_r -# define qsort_r rpl_qsort_r -# endif -_GL_FUNCDECL_RPL (qsort_r, void, (void *base, size_t nmemb, size_t size, - int (*compare) (void const *, void const *, - void *), - void *arg) _GL_ARG_NONNULL ((1, 4))); -_GL_CXXALIAS_RPL (qsort_r, void, (void *base, size_t nmemb, size_t size, - int (*compare) (void const *, void const *, - void *), - void *arg)); -# else -_GL_CXXALIAS_SYS (qsort_r, void, (void *base, size_t nmemb, size_t size, - int (*compare) (void const *, void const *, - void *), - void *arg)); -# endif -_GL_CXXALIASWARN (qsort_r); -#endif - #if @GNULIB_RANDOM_R@ # if !@HAVE_RANDOM_R@ diff --git a/lib/strdup.c b/lib/strdup.c index 7bbc59a74..bde582927 100644 --- a/lib/strdup.c +++ b/lib/strdup.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1991, 1996-1998, 2002-2004, 2006-2007, 2009-2015 Free Software +/* Copyright (C) 1991, 1996-1998, 2002-2004, 2006-2007, 2009-2014 Free Software Foundation, Inc. This file is part of the GNU C Library. diff --git a/lib/streq.h b/lib/streq.h index 85ce271ab..0f7bc72b2 100644 --- a/lib/streq.h +++ b/lib/streq.h @@ -1,5 +1,5 @@ /* Optimized string comparison. - Copyright (C) 2001-2002, 2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2001-2002, 2007, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/strftime.c b/lib/strftime.c index 876d16e2b..eb458d117 100644 --- a/lib/strftime.c +++ b/lib/strftime.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1991-2001, 2003-2007, 2009-2015 Free Software Foundation, Inc. +/* Copyright (C) 1991-2001, 2003-2007, 2009-2014 Free Software Foundation, Inc. NOTE: The canonical source of this file is maintained with the GNU C Library. Bugs can be reported to bug-glibc@prep.ai.mit.edu. @@ -30,7 +30,6 @@ # else # include "strftime.h" # endif -# include "time-internal.h" #endif #include @@ -122,11 +121,22 @@ extern char *tzname[]; #ifdef _LIBC -# define mktime_z(tz, tm) mktime (tm) # define tzname __tzname # define tzset __tzset #endif +#if !HAVE_TM_GMTOFF +/* Portable standalone applications should supply a "time.h" that + declares a POSIX-compliant localtime_r, for the benefit of older + implementations that lack localtime_r or have a nonstandard one. + See the gnulib time_r module for one way to implement this. */ +# undef __gmtime_r +# undef __localtime_r +# define __gmtime_r gmtime_r +# define __localtime_r localtime_r +#endif + + #ifndef FPRINTFTIME # define FPRINTFTIME 0 #endif @@ -375,7 +385,12 @@ iso_week_days (int yday, int wday) /* When compiling this file, GNU applications can #define my_strftime to a symbol (typically nstrftime) to get an extended strftime with - extra arguments TZ and NS. */ + extra arguments UT and NS. Emacs is a special case for now, but + this Emacs-specific code can be removed once Emacs's config.h + defines my_strftime. */ +#if defined emacs && !defined my_strftime +# define my_strftime nstrftime +#endif #if FPRINTFTIME # undef my_strftime @@ -383,9 +398,8 @@ iso_week_days (int yday, int wday) #endif #ifdef my_strftime -# undef HAVE_TZSET -# define extra_args , tz, ns -# define extra_args_spec , timezone_t tz, int ns +# define extra_args , ut, ns +# define extra_args_spec , int ut, int ns #else # if defined COMPILE_WIDE # define my_strftime wcsftime @@ -397,7 +411,7 @@ iso_week_days (int yday, int wday) # define extra_args # define extra_args_spec /* We don't have this information in general. */ -# define tz 1 +# define ut 0 # define ns 0 #endif @@ -440,9 +454,6 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, # define aw_len STRLEN (a_wkday) # define am_len STRLEN (a_month) # define ap_len STRLEN (ampm) -#endif -#if HAVE_TZNAME - char **tzname_vec = tzname; #endif const char *zone; size_t i = 0; @@ -472,29 +483,20 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, zone = (const char *) tp->tm_zone; #endif #if HAVE_TZNAME - if (!tz) + if (ut) { if (! (zone && *zone)) zone = "GMT"; } else { -# if !HAVE_TM_ZONE - /* Infer the zone name from *TZ instead of from TZNAME. */ - tzname_vec = tz->tzname_copy; -# endif /* POSIX.1 requires that local time zone information be used as though strftime called tzset. */ # if HAVE_TZSET tzset (); # endif } - /* The tzset() call might have changed the value. */ - if (!(zone && *zone) && tp->tm_isdst >= 0) - zone = tzname_vec[tp->tm_isdst != 0]; #endif - if (! zone) - zone = ""; if (hour12 > 12) hour12 -= 12; @@ -679,44 +681,24 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, switch (format_char) { #define DO_NUMBER(d, v) \ - do \ - { \ - digits = d; \ - number_value = v; \ - goto do_number; \ - } \ - while (0) + digits = d; \ + number_value = v; goto do_number #define DO_SIGNED_NUMBER(d, negative, v) \ - do \ - { \ - digits = d; \ - negative_number = negative; \ - u_number_value = v; \ - goto do_signed_number; \ - } \ - while (0) + digits = d; \ + negative_number = negative; \ + u_number_value = v; goto do_signed_number /* The mask is not what you might think. When the ordinal i'th bit is set, insert a colon before the i'th digit of the time zone representation. */ #define DO_TZ_OFFSET(d, negative, mask, v) \ - do \ - { \ - digits = d; \ - negative_number = negative; \ - tz_colon_mask = mask; \ - u_number_value = v; \ - goto do_tz_offset; \ - } \ - while (0) + digits = d; \ + negative_number = negative; \ + tz_colon_mask = mask; \ + u_number_value = v; goto do_tz_offset #define DO_NUMBER_SPACEPAD(d, v) \ - do \ - { \ - digits = d; \ - number_value = v; \ - goto do_number_spacepad; \ - } \ - while (0) + digits = d; \ + number_value = v; goto do_number_spacepad case L_('%'): if (modifier != 0) @@ -1142,7 +1124,7 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, time_t t; ltm = *tp; - t = mktime_z (tz, <m); + t = mktime (<m); /* Generate string value for T using time_t arithmetic; this works even if sizeof (long) < sizeof (time_t). */ @@ -1283,9 +1265,9 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, } if (modifier == L_('O')) goto bad_format; - - DO_SIGNED_NUMBER (4, tp->tm_year < -TM_YEAR_BASE, - tp->tm_year + (unsigned int) TM_YEAR_BASE); + else + DO_SIGNED_NUMBER (4, tp->tm_year < -TM_YEAR_BASE, + tp->tm_year + (unsigned int) TM_YEAR_BASE); case L_('y'): if (modifier == L_('E')) @@ -1317,6 +1299,14 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, to_lowcase = true; } +#if HAVE_TZNAME + /* The tzset() call might have changed the value. */ + if (!(zone && *zone) && tp->tm_isdst >= 0) + zone = tzname[tp->tm_isdst != 0]; +#endif + if (! zone) + zone = ""; + #ifdef COMPILE_WIDE { /* The zone string is always given in multibyte form. We have @@ -1356,7 +1346,7 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, #if HAVE_TM_GMTOFF diff = tp->tm_gmtoff; #else - if (!tz) + if (ut) diff = 0; else { @@ -1365,7 +1355,7 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, time_t lt; ltm = *tp; - lt = mktime_z (tz, <m); + lt = mktime (<m); if (lt == (time_t) -1) { @@ -1374,7 +1364,7 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, occurred. */ struct tm tm; - if (! localtime_rz (tz, <, &tm) + if (! __localtime_r (<, &tm) || ((ltm.tm_sec ^ tm.tm_sec) | (ltm.tm_min ^ tm.tm_min) | (ltm.tm_hour ^ tm.tm_hour) @@ -1384,7 +1374,7 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, break; } - if (! localtime_rz (0, <, >m)) + if (! __gmtime_r (<, >m)) break; diff = tm_diff (<m, >m); @@ -1463,3 +1453,15 @@ my_strftime (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize) #if defined _LIBC && ! FPRINTFTIME libc_hidden_def (my_strftime) #endif + + +#if defined emacs && ! FPRINTFTIME +/* For Emacs we have a separate interface which corresponds to the normal + strftime function plus the ut argument, but without the ns argument. */ +size_t +emacs_strftimeu (char *s, size_t maxsize, const char *format, + const struct tm *tp, int ut) +{ + return my_strftime (s, maxsize, format, tp, ut, 0); +} +#endif diff --git a/lib/strftime.h b/lib/strftime.h index 8756acd02..a394640e6 100644 --- a/lib/strftime.h +++ b/lib/strftime.h @@ -1,6 +1,6 @@ /* declarations for strftime.c - Copyright (C) 2002, 2004, 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2002, 2004, 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -23,10 +23,11 @@ extern "C" { /* Just like strftime, but with two more arguments: POSIX requires that strftime use the local timezone information. - Use the timezone __TZ instead. Use __NS as the number of - nanoseconds in the %N directive. */ + When __UTC is nonzero and tm->tm_zone is NULL or the empty string, + use UTC instead. Use __NS as the number of nanoseconds in the + %N directive. */ size_t nstrftime (char *, size_t, char const *, struct tm const *, - timezone_t __tz, int __ns); + int __utc, int __ns); #ifdef __cplusplus } diff --git a/lib/striconveh.c b/lib/striconveh.c index a9c9b0020..1a2f62e44 100644 --- a/lib/striconveh.c +++ b/lib/striconveh.c @@ -1,5 +1,5 @@ /* Character set conversion with error handling. - Copyright (C) 2001-2015 Free Software Foundation, Inc. + Copyright (C) 2001-2014 Free Software Foundation, Inc. Written by Bruno Haible and Simon Josefsson. This program is free software: you can redistribute it and/or modify diff --git a/lib/striconveh.h b/lib/striconveh.h index bea457b86..a4e425aa2 100644 --- a/lib/striconveh.h +++ b/lib/striconveh.h @@ -1,5 +1,5 @@ /* Character set conversion with error handling. - Copyright (C) 2001-2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2001-2007, 2009-2014 Free Software Foundation, Inc. Written by Bruno Haible and Simon Josefsson. This program is free software: you can redistribute it and/or modify diff --git a/lib/string.in.h b/lib/string.in.h index 9a630b163..eaaaa9dda 100644 --- a/lib/string.in.h +++ b/lib/string.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 1995-1996, 2001-2015 Free Software Foundation, Inc. + Copyright (C) 1995-1996, 2001-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -15,32 +15,16 @@ You should have received a copy of the GNU Lesser General Public License along with this program; if not, see . */ +#ifndef _@GUARD_PREFIX@_STRING_H + #if __GNUC__ >= 3 @PRAGMA_SYSTEM_HEADER@ #endif @PRAGMA_COLUMNS@ -#if defined _GL_ALREADY_INCLUDING_STRING_H -/* Special invocation convention: - - On OS X/NetBSD we have a sequence of nested includes - -> -> "string.h" - In this situation system _chk variants due to -D_FORTIFY_SOURCE - might be used after any replacements defined here. */ - -#@INCLUDE_NEXT@ @NEXT_STRING_H@ - -#else -/* Normal invocation convention. */ - -#ifndef _@GUARD_PREFIX@_STRING_H - -#define _GL_ALREADY_INCLUDING_STRING_H - /* The include_next requires a split double-inclusion guard. */ #@INCLUDE_NEXT@ @NEXT_STRING_H@ -#undef _GL_ALREADY_INCLUDING_STRING_H - #ifndef _@GUARD_PREFIX@_STRING_H #define _@GUARD_PREFIX@_STRING_H @@ -1043,4 +1027,3 @@ _GL_WARN_ON_USE (strverscmp, "strverscmp is unportable - " #endif /* _@GUARD_PREFIX@_STRING_H */ #endif /* _@GUARD_PREFIX@_STRING_H */ -#endif diff --git a/lib/stripslash.c b/lib/stripslash.c index 86298d64f..22295e57a 100644 --- a/lib/stripslash.c +++ b/lib/stripslash.c @@ -1,6 +1,6 @@ /* stripslash.c -- remove redundant trailing slashes from a file name - Copyright (C) 1990, 2001, 2003-2006, 2009-2015 Free Software Foundation, + Copyright (C) 1990, 2001, 2003-2006, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/sys_file.in.h b/lib/sys_file.in.h index af5ba2f67..1df6946a5 100644 --- a/lib/sys_file.in.h +++ b/lib/sys_file.in.h @@ -1,6 +1,6 @@ /* Provide a more complete sys/file.h. - Copyright (C) 2007-2015 Free Software Foundation, Inc. + Copyright (C) 2007-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sys_select.in.h b/lib/sys_select.in.h index 20cfc9be2..7e5c3a389 100644 --- a/lib/sys_select.in.h +++ b/lib/sys_select.in.h @@ -1,5 +1,5 @@ /* Substitute for . - Copyright (C) 2007-2015 Free Software Foundation, Inc. + Copyright (C) 2007-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -24,8 +24,8 @@ On Cygwin, includes . Simply delegate to the system's header in this case. */ #if (@HAVE_SYS_SELECT_H@ \ - && !defined _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TYPES_H \ && ((defined __osf__ && defined _SYS_TYPES_H_ \ + && !defined _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TIME_H \ && defined _OSF_SOURCE) \ || (defined __sun && defined _SYS_TYPES_H \ && (! (defined _XOPEN_SOURCE || defined _POSIX_C_SOURCE) \ @@ -36,13 +36,12 @@ #elif (@HAVE_SYS_SELECT_H@ \ && (defined _CYGWIN_SYS_TIME_H \ - || (!defined _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TIME_H \ - && ((defined __osf__ && defined _SYS_TIME_H_ \ - && defined _OSF_SOURCE) \ - || (defined __sun && defined _SYS_TIME_H \ - && (! (defined _XOPEN_SOURCE \ - || defined _POSIX_C_SOURCE) \ - || defined __EXTENSIONS__)))))) + || (defined __osf__ && defined _SYS_TIME_H_ \ + && !defined _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TIME_H \ + && defined _OSF_SOURCE) \ + || (defined __sun && defined _SYS_TIME_H \ + && (! (defined _XOPEN_SOURCE || defined _POSIX_C_SOURCE) \ + || defined __EXTENSIONS__)))) # define _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TIME_H # @INCLUDE_NEXT@ @NEXT_SYS_SELECT_H@ diff --git a/lib/sys_socket.c b/lib/sys_socket.c index 3b261da03..3f017f8fc 100644 --- a/lib/sys_socket.c +++ b/lib/sys_socket.c @@ -1,4 +1,3 @@ #include #define _GL_SYS_SOCKET_INLINE _GL_EXTERN_INLINE #include "sys/socket.h" -typedef int dummy; diff --git a/lib/sys_socket.in.h b/lib/sys_socket.in.h index 7f1163506..0cbc3e4fe 100644 --- a/lib/sys_socket.in.h +++ b/lib/sys_socket.in.h @@ -1,6 +1,6 @@ /* Provide a sys/socket header file for systems lacking it (read: MinGW) and for systems where it is incomplete. - Copyright (C) 2005-2015 Free Software Foundation, Inc. + Copyright (C) 2005-2014 Free Software Foundation, Inc. Written by Simon Josefsson. This program is free software; you can redistribute it and/or modify diff --git a/lib/sys_stat.in.h b/lib/sys_stat.in.h index c8cb6a5e5..32c23a055 100644 --- a/lib/sys_stat.in.h +++ b/lib/sys_stat.in.h @@ -1,5 +1,5 @@ /* Provide a more complete sys/stat header file. - Copyright (C) 2005-2015 Free Software Foundation, Inc. + Copyright (C) 2005-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sys_time.in.h b/lib/sys_time.in.h index e91bbfe19..f19326e02 100644 --- a/lib/sys_time.in.h +++ b/lib/sys_time.in.h @@ -1,6 +1,6 @@ /* Provide a more complete sys/time.h. - Copyright (C) 2007-2015 Free Software Foundation, Inc. + Copyright (C) 2007-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sys_times.in.h b/lib/sys_times.in.h index 9ca247c64..b3babfb80 100644 --- a/lib/sys_times.in.h +++ b/lib/sys_times.in.h @@ -1,5 +1,5 @@ /* Provide a sys/times.h header file. - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sys_types.in.h b/lib/sys_types.in.h index f313b85b3..c8d0bb48f 100644 --- a/lib/sys_types.in.h +++ b/lib/sys_types.in.h @@ -1,6 +1,6 @@ /* Provide a more complete sys/types.h. - Copyright (C) 2011-2015 Free Software Foundation, Inc. + Copyright (C) 2011-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -23,9 +23,7 @@ #ifndef _@GUARD_PREFIX@_SYS_TYPES_H /* The include_next requires a split double-inclusion guard. */ -# define _GL_INCLUDING_SYS_TYPES_H #@INCLUDE_NEXT@ @NEXT_SYS_TYPES_H@ -# undef _GL_INCLUDING_SYS_TYPES_H #ifndef _@GUARD_PREFIX@_SYS_TYPES_H #define _@GUARD_PREFIX@_SYS_TYPES_H diff --git a/lib/sys_uio.in.h b/lib/sys_uio.in.h index 0646ed2bc..8cad7de32 100644 --- a/lib/sys_uio.in.h +++ b/lib/sys_uio.in.h @@ -1,5 +1,5 @@ /* Substitute for . - Copyright (C) 2011-2015 Free Software Foundation, Inc. + Copyright (C) 2011-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/tempname.c b/lib/tempname.c index da0c41c16..f0f7e7f29 100644 --- a/lib/tempname.c +++ b/lib/tempname.c @@ -1,6 +1,6 @@ /* tempname.c - generate the name of a temporary file. - Copyright (C) 1991-2003, 2005-2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 1991-2003, 2005-2007, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -62,7 +62,6 @@ # define struct_stat64 struct stat64 #else # define struct_stat64 struct stat -# define __try_tempname try_tempname # define __gen_tempname gen_tempname # define __getpid getpid # define __gettimeofday gettimeofday @@ -177,9 +176,21 @@ __path_search (char *tmpl, size_t tmpl_len, const char *dir, const char *pfx, static const char letters[] = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"; +/* Generate a temporary file name based on TMPL. TMPL must match the + rules for mk[s]temp (i.e. end in "XXXXXX", possibly with a suffix). + The name constructed does not exist at the time of the call to + __gen_tempname. TMPL is overwritten with the result. + + KIND may be one of: + __GT_NOCREATE: simply verify that the name does not exist + at the time of the call. + __GT_FILE: create the file using open(O_CREAT|O_EXCL) + and return a read-write fd. The file is mode 0600. + __GT_DIR: create a directory, which will be mode 0700. + + We use a clever algorithm to get hard-to-predict names. */ int -__try_tempname (char *tmpl, int suffixlen, void *args, - int (*tryfunc) (char *, void *)) +__gen_tempname (char *tmpl, int suffixlen, int flags, int kind) { int len; char *XXXXXX; @@ -188,6 +199,7 @@ __try_tempname (char *tmpl, int suffixlen, void *args, unsigned int count; int fd = -1; int save_errno = errno; + struct_stat64 st; /* A lower bound on the number of temporary files to attempt to generate. The maximum total number of temporary file names that @@ -244,7 +256,41 @@ __try_tempname (char *tmpl, int suffixlen, void *args, v /= 62; XXXXXX[5] = letters[v % 62]; - fd = tryfunc (tmpl, args); + switch (kind) + { + case __GT_FILE: + fd = __open (tmpl, + (flags & ~O_ACCMODE) + | O_RDWR | O_CREAT | O_EXCL, S_IRUSR | S_IWUSR); + break; + + case __GT_DIR: + fd = __mkdir (tmpl, S_IRUSR | S_IWUSR | S_IXUSR); + break; + + case __GT_NOCREATE: + /* This case is backward from the other three. __gen_tempname + succeeds if __xstat fails because the name does not exist. + Note the continue to bypass the common logic at the bottom + of the loop. */ + if (__lxstat64 (_STAT_VER, tmpl, &st) < 0) + { + if (errno == ENOENT) + { + __set_errno (save_errno); + return 0; + } + else + /* Give up now. */ + return -1; + } + continue; + + default: + assert (! "invalid KIND in __gen_tempname"); + abort (); + } + if (fd >= 0) { __set_errno (save_errno); @@ -258,67 +304,3 @@ __try_tempname (char *tmpl, int suffixlen, void *args, __set_errno (EEXIST); return -1; } - -static int -try_file (char *tmpl, void *flags) -{ - int *openflags = flags; - return __open (tmpl, - (*openflags & ~O_ACCMODE) - | O_RDWR | O_CREAT | O_EXCL, S_IRUSR | S_IWUSR); -} - -static int -try_dir (char *tmpl, void *flags _GL_UNUSED) -{ - return __mkdir (tmpl, S_IRUSR | S_IWUSR | S_IXUSR); -} - -static int -try_nocreate (char *tmpl, void *flags _GL_UNUSED) -{ - struct_stat64 st; - - if (__lxstat64 (_STAT_VER, tmpl, &st) == 0) - __set_errno (EEXIST); - return errno == ENOENT ? 0 : -1; -} - -/* Generate a temporary file name based on TMPL. TMPL must match the - rules for mk[s]temp (i.e. end in "XXXXXX", possibly with a suffix). - The name constructed does not exist at the time of the call to - __gen_tempname. TMPL is overwritten with the result. - - KIND may be one of: - __GT_NOCREATE: simply verify that the name does not exist - at the time of the call. - __GT_FILE: create the file using open(O_CREAT|O_EXCL) - and return a read-write fd. The file is mode 0600. - __GT_DIR: create a directory, which will be mode 0700. - - We use a clever algorithm to get hard-to-predict names. */ -int -__gen_tempname (char *tmpl, int suffixlen, int flags, int kind) -{ - int (*tryfunc) (char *, void *); - - switch (kind) - { - case __GT_FILE: - tryfunc = try_file; - break; - - case __GT_DIR: - tryfunc = try_dir; - break; - - case __GT_NOCREATE: - tryfunc = try_nocreate; - break; - - default: - assert (! "invalid KIND in __gen_tempname"); - abort (); - } - return __try_tempname (tmpl, suffixlen, &flags, tryfunc); -} diff --git a/lib/tempname.h b/lib/tempname.h index a33f3da75..bd46f93f9 100644 --- a/lib/tempname.h +++ b/lib/tempname.h @@ -1,6 +1,6 @@ /* Create a temporary file or directory. - Copyright (C) 2006, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2006, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -32,10 +32,6 @@ # define GT_NOCREATE 2 # endif -#ifdef __cplusplus -extern "C" { -#endif - /* Generate a temporary file name based on TMPL. TMPL must match the rules for mk[s]temp (i.e. end in "XXXXXX", possibly with a suffix). The name constructed does not exist at the time of the call to @@ -51,15 +47,4 @@ extern "C" { We use a clever algorithm to get hard-to-predict names. */ extern int gen_tempname (char *tmpl, int suffixlen, int flags, int kind); -/* Similar to gen_tempname, but TRYFUNC is called for each temporary - name to try. If TRYFUNC returns a non-negative number, TRY_GEN_TEMPNAME - returns with this value. Otherwise, if errno is set to EEXIST, another - name is tried, or else TRY_GEN_TEMPNAME returns -1. */ -extern int try_tempname (char *tmpl, int suffixlen, void *args, - int (*tryfunc) (char *, void *)); - -#ifdef __cplusplus -} -#endif - #endif /* GL_TEMPNAME_H */ diff --git a/lib/time-internal.h b/lib/time-internal.h deleted file mode 100644 index 7137a6716..000000000 --- a/lib/time-internal.h +++ /dev/null @@ -1,49 +0,0 @@ -/* Time internal interface - - Copyright 2015 Free Software Foundation, Inc. - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU Lesser General Public License as published by - the Free Software Foundation; either version 2, or (at your option) - any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public License along - with this program; if not, see . */ - -/* Written by Paul Eggert. */ - -/* A time zone rule. */ -struct tm_zone -{ - /* More abbreviations, should they be needed. Their TZ_IS_SET - members are zero. */ - struct tm_zone *next; - -#if HAVE_TZNAME && !HAVE_TM_ZONE - /* Copies of recent strings taken from tzname[0] and tzname[1]. - The copies are in ABBRS, so that they survive tzset. Null if unknown. */ - char *tzname_copy[2]; -#endif - - /* If nonzero, the rule represents the TZ environment variable set - to the first "abbreviation" (this may be the empty string). - Otherwise, it represents an unset TZ. */ - char tz_is_set; - - /* A sequence of null-terminated strings packed next to each other. - The strings are followed by an extra null byte. If TZ_IS_SET, - there must be at least one string and the first string (which is - actually a TZ environment value value) may be empty. Otherwise - all strings must be nonempty. - - Abbreviations are stored here because otherwise the values of - tm_zone and/or tzname would be dead after changing TZ and calling - tzset. Abbreviations never move once allocated, and are live - until tzfree is called. */ - char abbrs[FLEXIBLE_ARRAY_MEMBER]; -}; diff --git a/lib/time.in.h b/lib/time.in.h index 7df4a6085..01681cc8c 100644 --- a/lib/time.in.h +++ b/lib/time.in.h @@ -1,6 +1,6 @@ /* A more-standard . - Copyright (C) 2007-2015 Free Software Foundation, Inc. + Copyright (C) 2007-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -22,13 +22,11 @@ /* Don't get in the way of glibc when it includes time.h merely to declare a few standard symbols, rather than to declare all the - symbols. (However, skip this for MinGW as it treats __need_time_t - incompatibly.) Also, Solaris 8 eventually includes itself + symbols. Also, Solaris 8 eventually includes itself recursively; if that is happening, just include the system without adding our own declarations. */ -#if (((defined __need_time_t || defined __need_clock_t \ - || defined __need_timespec) \ - && !defined __MINGW32__) \ +#if (defined __need_time_t || defined __need_clock_t \ + || defined __need_timespec \ || defined _@GUARD_PREFIX@_TIME_H) # @INCLUDE_NEXT@ @NEXT_TIME_H@ @@ -57,8 +55,6 @@ # include # elif @PTHREAD_H_DEFINES_STRUCT_TIMESPEC@ # include -# elif @UNISTD_H_DEFINES_STRUCT_TIMESPEC@ -# include # else # ifdef __cplusplus @@ -233,25 +229,6 @@ _GL_CXXALIAS_SYS (strptime, char *, (char const *restrict __buf, _GL_CXXALIASWARN (strptime); # endif -# if defined _GNU_SOURCE && @GNULIB_TIME_RZ@ && ! @HAVE_TIMEZONE_T@ -typedef struct tm_zone *timezone_t; -_GL_FUNCDECL_SYS (tzalloc, timezone_t, (char const *__name)); -_GL_CXXALIAS_SYS (tzalloc, timezone_t, (char const *__name)); -_GL_FUNCDECL_SYS (tzfree, void, (timezone_t __tz)); -_GL_CXXALIAS_SYS (tzfree, void, (timezone_t __tz)); -_GL_FUNCDECL_SYS (localtime_rz, struct tm *, - (timezone_t __tz, time_t const *restrict __timer, - struct tm *restrict __result) _GL_ARG_NONNULL ((2, 3))); -_GL_CXXALIAS_SYS (localtime_rz, struct tm *, - (timezone_t __tz, time_t const *restrict __timer, - struct tm *restrict __result)); -_GL_FUNCDECL_SYS (mktime_z, time_t, - (timezone_t __tz, struct tm *restrict __result) - _GL_ARG_NONNULL ((2))); -_GL_CXXALIAS_SYS (mktime_z, time_t, - (timezone_t __tz, struct tm *restrict __result)); -# endif - /* Convert TM to a time_t value, assuming UTC. */ # if @GNULIB_TIMEGM@ # if @REPLACE_TIMEGM@ diff --git a/lib/time_r.c b/lib/time_r.c index 2db2bc075..0249750e8 100644 --- a/lib/time_r.c +++ b/lib/time_r.c @@ -1,6 +1,6 @@ /* Reentrant time functions like localtime_r. - Copyright (C) 2003, 2006-2007, 2010-2015 Free Software Foundation, Inc. + Copyright (C) 2003, 2006-2007, 2010-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/time_rz.c b/lib/time_rz.c deleted file mode 100644 index 888eed227..000000000 --- a/lib/time_rz.c +++ /dev/null @@ -1,323 +0,0 @@ -/* Time zone functions such as tzalloc and localtime_rz - - Copyright 2015 Free Software Foundation, Inc. - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU Lesser General Public License as published by - the Free Software Foundation; either version 2, or (at your option) - any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public License along - with this program; if not, see . */ - -/* Written by Paul Eggert. */ - -/* Although this module is not thread-safe, any races should be fairly - rare and reasonably benign. For complete thread-safety, use a C - library with a working timezone_t type, so that this module is not - needed. */ - -#include - -#include - -#include -#include -#include -#include -#include - -#include "time-internal.h" - -#if !HAVE_TZSET -static void tzset (void) { } -#endif - -/* The approximate size to use for small allocation requests. This is - the largest "small" request for the GNU C library malloc. */ -enum { DEFAULT_MXFAST = 64 * sizeof (size_t) / 4 }; - -/* Minimum size of the ABBRS member of struct abbr. ABBRS is larger - only in the unlikely case where an abbreviation longer than this is - used. */ -enum { ABBR_SIZE_MIN = DEFAULT_MXFAST - offsetof (struct tm_zone, abbrs) }; - -static char const TZ[] = "TZ"; - -/* Magic cookie timezone_t value, for local time. It differs from - NULL and from all other timezone_t values. Only the address - matters; the pointer is never dereferenced. */ -static timezone_t const local_tz = (timezone_t) 1; - -#if HAVE_TM_ZONE || HAVE_TZNAME - -/* Return true if the values A and B differ according to the rules for - tm_isdst: A and B differ if one is zero and the other positive. */ -static bool -isdst_differ (int a, int b) -{ - return !a != !b && 0 <= a && 0 <= b; -} - -/* Return true if A and B are equal. */ -static int -equal_tm (const struct tm *a, const struct tm *b) -{ - return ! ((a->tm_sec ^ b->tm_sec) - | (a->tm_min ^ b->tm_min) - | (a->tm_hour ^ b->tm_hour) - | (a->tm_mday ^ b->tm_mday) - | (a->tm_mon ^ b->tm_mon) - | (a->tm_year ^ b->tm_year) - | isdst_differ (a->tm_isdst, b->tm_isdst)); -} - -#endif - -/* Copy to ABBRS the abbreviation at ABBR with size ABBR_SIZE (this - includes its trailing null byte). Append an extra null byte to - mark the end of ABBRS. */ -static void -extend_abbrs (char *abbrs, char const *abbr, size_t abbr_size) -{ - memcpy (abbrs, abbr, abbr_size); - abbrs[abbr_size] = '\0'; -} - -/* Return a newly allocated time zone for NAME, or NULL on failure. - A null NAME stands for wall clock time (which is like unset TZ). */ -timezone_t -tzalloc (char const *name) -{ - size_t name_size = name ? strlen (name) + 1 : 0; - size_t abbr_size = name_size < ABBR_SIZE_MIN ? ABBR_SIZE_MIN : name_size + 1; - timezone_t tz = malloc (offsetof (struct tm_zone, abbrs) + abbr_size); - if (tz) - { - tz->next = NULL; -#if HAVE_TZNAME && !HAVE_TM_ZONE - tz->tzname_copy[0] = tz->tzname_copy[1] = NULL; -#endif - tz->tz_is_set = !!name; - tz->abbrs[0] = '\0'; - if (name) - extend_abbrs (tz->abbrs, name, name_size); - } - return tz; -} - -/* Save into TZ any nontrivial time zone abbreviation used by TM, and - update *TM (if HAVE_TM_ZONE) or *TZ (if !HAVE_TM_ZONE && - HAVE_TZNAME) if they use the abbreviation. Return true if - successful, false (setting errno) otherwise. */ -static bool -save_abbr (timezone_t tz, struct tm *tm) -{ -#if HAVE_TM_ZONE || HAVE_TZNAME - char const *zone = NULL; - char *zone_copy = (char *) ""; - -# if HAVE_TZNAME - int tzname_index = -1; -# endif - -# if HAVE_TM_ZONE - zone = tm->tm_zone; -# endif - -# if HAVE_TZNAME - if (! (zone && *zone) && 0 <= tm->tm_isdst) - { - tzname_index = tm->tm_isdst != 0; - zone = tzname[tzname_index]; - } -# endif - - /* No need to replace null zones, or zones within the struct tm. */ - if (!zone || ((char *) tm <= zone && zone < (char *) (tm + 1))) - return true; - - if (*zone) - { - zone_copy = tz->abbrs; - - while (strcmp (zone_copy, zone) != 0) - { - if (! (*zone_copy || (zone_copy == tz->abbrs && tz->tz_is_set))) - { - size_t zone_size = strlen (zone) + 1; - if (zone_size < tz->abbrs + ABBR_SIZE_MIN - zone_copy) - extend_abbrs (zone_copy, zone, zone_size); - else - { - tz = tz->next = tzalloc (zone); - if (!tz) - return false; - tz->tz_is_set = 0; - zone_copy = tz->abbrs; - } - break; - } - - zone_copy += strlen (zone_copy) + 1; - if (!*zone_copy && tz->next) - { - tz = tz->next; - zone_copy = tz->abbrs; - } - } - } - - /* Replace the zone name so that its lifetime matches that of TZ. */ -# if HAVE_TM_ZONE - tm->tm_zone = zone_copy; -# else - if (0 <= tzname_index) - tz->tzname_copy[tzname_index] = zone_copy; -# endif -#endif - - return true; -} - -/* Free a time zone. */ -void -tzfree (timezone_t tz) -{ - if (tz != local_tz) - while (tz) - { - timezone_t next = tz->next; - free (tz); - tz = next; - } -} - -/* Get and set the TZ environment variable. These functions can be - overridden by programs like Emacs that manage their own environment. */ - -#ifndef getenv_TZ -static char * -getenv_TZ (void) -{ - return getenv (TZ); -} -#endif - -#ifndef setenv_TZ -static int -setenv_TZ (char const *tz) -{ - return tz ? setenv (TZ, tz, 1) : unsetenv (TZ); -} -#endif - -/* Change the environment to match the specified timezone_t value. - Return true if successful, false (setting errno) otherwise. */ -static bool -change_env (timezone_t tz) -{ - if (setenv_TZ (tz->tz_is_set ? tz->abbrs : NULL) != 0) - return false; - tzset (); - return true; -} - -/* Temporarily set the time zone to TZ, which must not be null. - Return LOCAL_TZ if the time zone setting is already correct. - Otherwise return a newly allocated time zone representing the old - setting, or NULL (setting errno) on failure. */ -static timezone_t -set_tz (timezone_t tz) -{ - char *env_tz = getenv_TZ (); - if (env_tz - ? tz->tz_is_set && strcmp (tz->abbrs, env_tz) == 0 - : !tz->tz_is_set) - return local_tz; - else - { - timezone_t old_tz = tzalloc (env_tz); - if (!old_tz) - return old_tz; - if (! change_env (tz)) - { - int saved_errno = errno; - tzfree (old_tz); - errno = saved_errno; - return NULL; - } - return old_tz; - } -} - -/* Restore an old setting returned by set_tz. It must not be null. - Return true (preserving errno) if successful, false (setting errno) - otherwise. */ -static bool -revert_tz (timezone_t tz) -{ - if (tz == local_tz) - return true; - else - { - int saved_errno = errno; - bool ok = change_env (tz); - if (!ok) - saved_errno = errno; - tzfree (tz); - errno = saved_errno; - return ok; - } -} - -/* Use time zone TZ to compute localtime_r (T, TM). */ -struct tm * -localtime_rz (timezone_t tz, time_t const *t, struct tm *tm) -{ - if (!tz) - return gmtime_r (t, tm); - else - { - timezone_t old_tz = set_tz (tz); - if (old_tz) - { - bool abbr_saved = localtime_r (t, tm) && save_abbr (tz, tm); - if (revert_tz (old_tz) && abbr_saved) - return tm; - } - return NULL; - } -} - -/* Use time zone TZ to compute mktime (TM). */ -time_t -mktime_z (timezone_t tz, struct tm *tm) -{ - if (!tz) - return timegm (tm); - else - { - timezone_t old_tz = set_tz (tz); - if (old_tz) - { - time_t t = mktime (tm); -#if HAVE_TM_ZONE || HAVE_TZNAME - time_t badtime = -1; - struct tm tm_1; - if ((t != badtime - || (localtime_r (&t, &tm_1) && equal_tm (tm, &tm_1))) - && !save_abbr (tz, tm)) - t = badtime; -#endif - if (revert_tz (old_tz)) - return t; - } - return -1; - } -} diff --git a/lib/timegm.c b/lib/timegm.c deleted file mode 100644 index d1b355f2f..000000000 --- a/lib/timegm.c +++ /dev/null @@ -1,38 +0,0 @@ -/* Convert UTC calendar time to simple time. Like mktime but assumes UTC. - - Copyright (C) 1994, 1997, 2003-2004, 2006-2007, 2009-2015 Free Software - Foundation, Inc. This file is part of the GNU C Library. - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU Lesser General Public License as published by - the Free Software Foundation; either version 2, or (at your option) - any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public License - along with this program; if not, see . */ - -#ifndef _LIBC -# include -#endif - -#include - -#ifndef _LIBC -# undef __gmtime_r -# define __gmtime_r gmtime_r -# define __mktime_internal mktime_internal -# include "mktime-internal.h" -#endif - -time_t -timegm (struct tm *tmp) -{ - static time_t gmtime_offset; - tmp->tm_isdst = 0; - return __mktime_internal (tmp, __gmtime_r, &gmtime_offset); -} diff --git a/lib/times.c b/lib/times.c index 3cfad2f09..605f2356f 100644 --- a/lib/times.c +++ b/lib/times.c @@ -1,6 +1,6 @@ /* Get process times - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -62,5 +62,5 @@ times (struct tms * buffer) buffer->tms_cutime = 0; buffer->tms_cstime = 0; - return clock (); + return filetime2clock (creation_time); } diff --git a/lib/trunc.c b/lib/trunc.c index b7b0aa2d0..e2857335b 100644 --- a/lib/trunc.c +++ b/lib/trunc.c @@ -1,5 +1,5 @@ /* Round towards zero. - Copyright (C) 2007, 2010-2015 Free Software Foundation, Inc. + Copyright (C) 2007, 2010-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/unistd.c b/lib/unistd.c index 72bad1c05..6c6a8e268 100644 --- a/lib/unistd.c +++ b/lib/unistd.c @@ -1,4 +1,3 @@ #include #define _GL_UNISTD_INLINE _GL_EXTERN_INLINE #include "unistd.h" -typedef int dummy; diff --git a/lib/unistd.in.h b/lib/unistd.in.h index c0bc8c7fe..842025024 100644 --- a/lib/unistd.in.h +++ b/lib/unistd.in.h @@ -1,5 +1,5 @@ /* Substitute for and wrapper around . - Copyright (C) 2003-2015 Free Software Foundation, Inc. + Copyright (C) 2003-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -401,12 +401,6 @@ _GL_WARN_ON_USE (dup3, "dup3 is unportable - " /* Set of environment variables and values. An array of strings of the form "VARIABLE=VALUE", terminated with a NULL. */ # if defined __APPLE__ && defined __MACH__ -# include -# if !TARGET_OS_IPHONE && !TARGET_IPHONE_SIMULATOR -# define _GL_USE_CRT_EXTERNS -# endif -# endif -# ifdef _GL_USE_CRT_EXTERNS # include # define environ (*_NSGetEnviron ()) # else @@ -1293,24 +1287,13 @@ _GL_WARN_ON_USE (readlink, "readlink is unportable - " #if @GNULIB_READLINKAT@ -# if @REPLACE_READLINKAT@ -# if !(defined __cplusplus && defined GNULIB_NAMESPACE) -# define readlinkat rpl_readlinkat -# endif -_GL_FUNCDECL_RPL (readlinkat, ssize_t, - (int fd, char const *file, char *buf, size_t len) - _GL_ARG_NONNULL ((2, 3))); -_GL_CXXALIAS_RPL (readlinkat, ssize_t, - (int fd, char const *file, char *buf, size_t len)); -# else -# if !@HAVE_READLINKAT@ +# if !@HAVE_READLINKAT@ _GL_FUNCDECL_SYS (readlinkat, ssize_t, (int fd, char const *file, char *buf, size_t len) _GL_ARG_NONNULL ((2, 3))); -# endif +# endif _GL_CXXALIAS_SYS (readlinkat, ssize_t, (int fd, char const *file, char *buf, size_t len)); -# endif _GL_CXXALIASWARN (readlinkat); #elif defined GNULIB_POSIXCHECK # undef readlinkat @@ -1424,25 +1407,13 @@ _GL_WARN_ON_USE (symlink, "symlink is not portable - " #if @GNULIB_SYMLINKAT@ -# if @REPLACE_SYMLINKAT@ -# if !(defined __cplusplus && defined GNULIB_NAMESPACE) -# undef symlinkat -# define symlinkat rpl_symlinkat -# endif -_GL_FUNCDECL_RPL (symlinkat, int, - (char const *contents, int fd, char const *file) - _GL_ARG_NONNULL ((1, 3))); -_GL_CXXALIAS_RPL (symlinkat, int, - (char const *contents, int fd, char const *file)); -# else -# if !@HAVE_SYMLINKAT@ +# if !@HAVE_SYMLINKAT@ _GL_FUNCDECL_SYS (symlinkat, int, (char const *contents, int fd, char const *file) _GL_ARG_NONNULL ((1, 3))); -# endif +# endif _GL_CXXALIAS_SYS (symlinkat, int, (char const *contents, int fd, char const *file)); -# endif _GL_CXXALIASWARN (symlinkat); #elif defined GNULIB_POSIXCHECK # undef symlinkat diff --git a/lib/unistr.in.h b/lib/unistr.in.h index 90441493f..73d2c23c0 100644 --- a/lib/unistr.in.h +++ b/lib/unistr.in.h @@ -1,5 +1,5 @@ /* Elementary Unicode string functions. - Copyright (C) 2001-2002, 2005-2015 Free Software Foundation, Inc. + Copyright (C) 2001-2002, 2005-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/unistr/u8-mbtouc-aux.c b/lib/unistr/u8-mbtouc-aux.c index 834725fed..02cdacd9d 100644 --- a/lib/unistr/u8-mbtouc-aux.c +++ b/lib/unistr/u8-mbtouc-aux.c @@ -1,5 +1,5 @@ /* Conversion UTF-8 to UCS-4. - Copyright (C) 2001-2002, 2006-2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2001-2002, 2006-2007, 2009-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2001. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-mbtouc-unsafe-aux.c b/lib/unistr/u8-mbtouc-unsafe-aux.c index b406d3ebd..bfa96f4ab 100644 --- a/lib/unistr/u8-mbtouc-unsafe-aux.c +++ b/lib/unistr/u8-mbtouc-unsafe-aux.c @@ -1,5 +1,5 @@ /* Conversion UTF-8 to UCS-4. - Copyright (C) 2001-2002, 2006-2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2001-2002, 2006-2007, 2009-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2001. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-mbtouc-unsafe.c b/lib/unistr/u8-mbtouc-unsafe.c index 01d12dc41..9c2095b68 100644 --- a/lib/unistr/u8-mbtouc-unsafe.c +++ b/lib/unistr/u8-mbtouc-unsafe.c @@ -1,5 +1,5 @@ /* Look at first character in UTF-8 string. - Copyright (C) 1999-2002, 2006-2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 1999-2002, 2006-2007, 2009-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2001. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-mbtouc.c b/lib/unistr/u8-mbtouc.c index dc4607f68..2b389deb7 100644 --- a/lib/unistr/u8-mbtouc.c +++ b/lib/unistr/u8-mbtouc.c @@ -1,5 +1,5 @@ /* Look at first character in UTF-8 string. - Copyright (C) 1999-2002, 2006-2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 1999-2002, 2006-2007, 2009-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2001. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-mbtoucr.c b/lib/unistr/u8-mbtoucr.c index 3d8c05f76..3a75a4118 100644 --- a/lib/unistr/u8-mbtoucr.c +++ b/lib/unistr/u8-mbtoucr.c @@ -1,5 +1,5 @@ /* Look at first character in UTF-8 string, returning an error code. - Copyright (C) 1999-2002, 2006-2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 1999-2002, 2006-2007, 2009-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2001. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-prev.c b/lib/unistr/u8-prev.c index e01551e57..b2c2b9b41 100644 --- a/lib/unistr/u8-prev.c +++ b/lib/unistr/u8-prev.c @@ -1,5 +1,5 @@ /* Iterate over previous character in UTF-8 string. - Copyright (C) 2002, 2006-2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2002, 2006-2007, 2009-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2002. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-uctomb-aux.c b/lib/unistr/u8-uctomb-aux.c index cc9c5441c..8d94bf57a 100644 --- a/lib/unistr/u8-uctomb-aux.c +++ b/lib/unistr/u8-uctomb-aux.c @@ -1,5 +1,5 @@ /* Conversion UCS-4 to UTF-8. - Copyright (C) 2002, 2006-2007, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2002, 2006-2007, 2009-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2002. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-uctomb.c b/lib/unistr/u8-uctomb.c index 43ef23d89..1ce271fe8 100644 --- a/lib/unistr/u8-uctomb.c +++ b/lib/unistr/u8-uctomb.c @@ -1,5 +1,5 @@ /* Store a character in UTF-8 string. - Copyright (C) 2002, 2005-2006, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2002, 2005-2006, 2009-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2002. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unitypes.in.h b/lib/unitypes.in.h index fb0ce68a1..e5ff9923c 100644 --- a/lib/unitypes.in.h +++ b/lib/unitypes.in.h @@ -1,5 +1,5 @@ /* Elementary types and macros for the GNU UniString library. - Copyright (C) 2002, 2005-2006, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2002, 2005-2006, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/unsetenv.c b/lib/unsetenv.c deleted file mode 100644 index 5bd9ab493..000000000 --- a/lib/unsetenv.c +++ /dev/null @@ -1,127 +0,0 @@ -/* Copyright (C) 1992, 1995-2002, 2005-2015 Free Software Foundation, Inc. - This file is part of the GNU C Library. - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU Lesser General Public License as published by - the Free Software Foundation; either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public License - along with this program. If not, see . */ - -/* Don't use __attribute__ __nonnull__ in this compilation unit. Otherwise gcc - optimizes away the name == NULL test below. */ -#define _GL_ARG_NONNULL(params) - -#include - -/* Specification. */ -#include - -#include -#if !_LIBC -# define __set_errno(ev) ((errno) = (ev)) -#endif - -#include -#include - -#if !_LIBC -# define __environ environ -#endif - -#if _LIBC -/* This lock protects against simultaneous modifications of 'environ'. */ -# include -__libc_lock_define_initialized (static, envlock) -# define LOCK __libc_lock_lock (envlock) -# define UNLOCK __libc_lock_unlock (envlock) -#else -# define LOCK -# define UNLOCK -#endif - -/* In the GNU C library we must keep the namespace clean. */ -#ifdef _LIBC -# define unsetenv __unsetenv -#endif - -#if _LIBC || !HAVE_UNSETENV - -int -unsetenv (const char *name) -{ - size_t len; - char **ep; - - if (name == NULL || *name == '\0' || strchr (name, '=') != NULL) - { - __set_errno (EINVAL); - return -1; - } - - len = strlen (name); - - LOCK; - - ep = __environ; - while (*ep != NULL) - if (!strncmp (*ep, name, len) && (*ep)[len] == '=') - { - /* Found it. Remove this pointer by moving later ones back. */ - char **dp = ep; - - do - dp[0] = dp[1]; - while (*dp++); - /* Continue the loop in case NAME appears again. */ - } - else - ++ep; - - UNLOCK; - - return 0; -} - -#ifdef _LIBC -# undef unsetenv -weak_alias (__unsetenv, unsetenv) -#endif - -#else /* HAVE_UNSETENV */ - -# undef unsetenv -# if !HAVE_DECL_UNSETENV -# if VOID_UNSETENV -extern void unsetenv (const char *); -# else -extern int unsetenv (const char *); -# endif -# endif - -/* Call the underlying unsetenv, in case there is hidden bookkeeping - that needs updating beyond just modifying environ. */ -int -rpl_unsetenv (const char *name) -{ - int result = 0; - if (!name || !*name || strchr (name, '=')) - { - errno = EINVAL; - return -1; - } - while (getenv (name)) -# if !VOID_UNSETENV - result = -# endif - unsetenv (name); - return result; -} - -#endif /* HAVE_UNSETENV */ diff --git a/lib/vasnprintf.c b/lib/vasnprintf.c index daea81642..7282b0504 100644 --- a/lib/vasnprintf.c +++ b/lib/vasnprintf.c @@ -1,5 +1,5 @@ /* vsprintf with automatic memory allocation. - Copyright (C) 1999, 2002-2015 Free Software Foundation, Inc. + Copyright (C) 1999, 2002-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -1886,7 +1886,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, else { do - result[length++] = *cp++; + result[length++] = (unsigned char) *cp++; while (--n > 0); } } @@ -1957,14 +1957,15 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, if (!(a.arg[dp->width_arg_index].type == TYPE_INT)) abort (); arg = a.arg[dp->width_arg_index].a.a_int; - width = arg; if (arg < 0) { /* "A negative field width is taken as a '-' flag followed by a positive field width." */ flags |= FLAG_LEFT; - width = -width; + width = (unsigned int) (-arg); } + else + width = arg; } else { @@ -2072,7 +2073,8 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, characters = 0; } - if (characters < width && !(dp->flags & FLAG_LEFT)) + if (has_width && width > characters + && !(dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2125,7 +2127,8 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, } # endif - if (characters < width && (dp->flags & FLAG_LEFT)) + if (has_width && width > characters + && (dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2198,7 +2201,8 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, characters = 0; } - if (characters < width && !(dp->flags & FLAG_LEFT)) + if (has_width && width > characters + && !(dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2251,7 +2255,8 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, } # endif - if (characters < width && (dp->flags & FLAG_LEFT)) + if (has_width && width > characters + && (dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2324,7 +2329,8 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, characters = 0; } - if (characters < width && !(dp->flags & FLAG_LEFT)) + if (has_width && width > characters + && !(dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2377,7 +2383,8 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, } # endif - if (characters < width && (dp->flags & FLAG_LEFT)) + if (has_width && width > characters + && (dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2428,14 +2435,15 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, if (!(a.arg[dp->width_arg_index].type == TYPE_INT)) abort (); arg = a.arg[dp->width_arg_index].a.a_int; - width = arg; if (arg < 0) { /* "A negative field width is taken as a '-' flag followed by a positive field width." */ flags |= FLAG_LEFT; - width = -width; + width = (unsigned int) (-arg); } + else + width = arg; } else { @@ -2565,7 +2573,8 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, characters = 0; } - if (characters < width && !(dp->flags & FLAG_LEFT)) + if (has_width && width > characters + && !(dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2626,7 +2635,8 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, } } - if (characters < width && (dp->flags & FLAG_LEFT)) + if (has_width && width > characters + && (dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2817,7 +2827,8 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, /* w doesn't matter. */ w = 0; - if (w < width && !(dp->flags & FLAG_LEFT)) + if (has_width && width > w + && !(dp->flags & FLAG_LEFT)) { size_t n = width - w; ENSURE_ALLOCATION (xsum (length, n)); @@ -2900,7 +2911,8 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, length += tmpdst_len; # endif - if (w < width && (dp->flags & FLAG_LEFT)) + if (has_width && width > w + && (dp->flags & FLAG_LEFT)) { size_t n = width - w; ENSURE_ALLOCATION (xsum (length, n)); @@ -2927,16 +2939,17 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, { arg_type type = a.arg[dp->arg_index].type; int flags = dp->flags; + int has_width; size_t width; int has_precision; size_t precision; size_t tmp_length; - size_t count; DCHAR_T tmpbuf[700]; DCHAR_T *tmp; DCHAR_T *pad_ptr; DCHAR_T *p; + has_width = 0; width = 0; if (dp->width_start != dp->width_end) { @@ -2947,14 +2960,15 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, if (!(a.arg[dp->width_arg_index].type == TYPE_INT)) abort (); arg = a.arg[dp->width_arg_index].a.a_int; - width = arg; if (arg < 0) { /* "A negative field width is taken as a '-' flag followed by a positive field width." */ flags |= FLAG_LEFT; - width = -width; + width = (unsigned int) (-arg); } + else + width = arg; } else { @@ -2964,6 +2978,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, width = xsum (xtimes (width, 10), *digitp++ - '0'); while (digitp != dp->width_end); } + has_width = 1; } has_precision = 0; @@ -3339,14 +3354,11 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, abort (); # endif } - /* The generated string now extends from tmp to p, with the zero padding insertion point being at pad_ptr. */ - count = p - tmp; - - if (count < width) + if (has_width && p - tmp < width) { - size_t pad = width - count; + size_t pad = width - (p - tmp); DCHAR_T *end = p + pad; if (flags & FLAG_LEFT) @@ -3379,26 +3391,28 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, p = end; } - count = p - tmp; + { + size_t count = p - tmp; - if (count >= tmp_length) - /* tmp_length was incorrectly calculated - fix the - code above! */ - abort (); + if (count >= tmp_length) + /* tmp_length was incorrectly calculated - fix the + code above! */ + abort (); - /* Make room for the result. */ - if (count >= allocated - length) - { - size_t n = xsum (length, count); + /* Make room for the result. */ + if (count >= allocated - length) + { + size_t n = xsum (length, count); - ENSURE_ALLOCATION (n); - } + ENSURE_ALLOCATION (n); + } - /* Append the result. */ - memcpy (result + length, tmp, count * sizeof (DCHAR_T)); - if (tmp != tmpbuf) - free (tmp); - length += count; + /* Append the result. */ + memcpy (result + length, tmp, count * sizeof (DCHAR_T)); + if (tmp != tmpbuf) + free (tmp); + length += count; + } } #endif #if (NEED_PRINTF_INFINITE_DOUBLE || NEED_PRINTF_DOUBLE || NEED_PRINTF_INFINITE_LONG_DOUBLE || NEED_PRINTF_LONG_DOUBLE) && !defined IN_LIBINTL @@ -3432,8 +3446,8 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, arg_type type = a.arg[dp->arg_index].type; # endif int flags = dp->flags; + int has_width; size_t width; - size_t count; int has_precision; size_t precision; size_t tmp_length; @@ -3442,6 +3456,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, DCHAR_T *pad_ptr; DCHAR_T *p; + has_width = 0; width = 0; if (dp->width_start != dp->width_end) { @@ -3452,14 +3467,15 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, if (!(a.arg[dp->width_arg_index].type == TYPE_INT)) abort (); arg = a.arg[dp->width_arg_index].a.a_int; - width = arg; if (arg < 0) { /* "A negative field width is taken as a '-' flag followed by a positive field width." */ flags |= FLAG_LEFT; - width = -width; + width = (unsigned int) (-arg); } + else + width = arg; } else { @@ -3469,6 +3485,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, width = xsum (xtimes (width, 10), *digitp++ - '0'); while (digitp != dp->width_end); } + has_width = 1; } has_precision = 0; @@ -3908,9 +3925,9 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, digits without trailing zeroes. */ if (exponent >= 0) { - size_t ecount = exponent + 1; + size_t count = exponent + 1; /* Note: count <= precision = ndigits. */ - for (; ecount > 0; ecount--) + for (; count > 0; count--) *p++ = digits[--ndigits]; if ((flags & FLAG_ALT) || ndigits > nzeroes) { @@ -3924,10 +3941,10 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, } else { - size_t ecount = -exponent - 1; + size_t count = -exponent - 1; *p++ = '0'; *p++ = decimal_point_char (); - for (; ecount > 0; ecount--) + for (; count > 0; count--) *p++ = '0'; while (ndigits > nzeroes) { @@ -4378,9 +4395,9 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, digits without trailing zeroes. */ if (exponent >= 0) { - size_t ecount = exponent + 1; - /* Note: ecount <= precision = ndigits. */ - for (; ecount > 0; ecount--) + size_t count = exponent + 1; + /* Note: count <= precision = ndigits. */ + for (; count > 0; count--) *p++ = digits[--ndigits]; if ((flags & FLAG_ALT) || ndigits > nzeroes) { @@ -4394,10 +4411,10 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, } else { - size_t ecount = -exponent - 1; + size_t count = -exponent - 1; *p++ = '0'; *p++ = decimal_point_char (); - for (; ecount > 0; ecount--) + for (; count > 0; count--) *p++ = '0'; while (ndigits > nzeroes) { @@ -4525,11 +4542,9 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, /* The generated string now extends from tmp to p, with the zero padding insertion point being at pad_ptr. */ - count = p - tmp; - - if (count < width) + if (has_width && p - tmp < width) { - size_t pad = width - count; + size_t pad = width - (p - tmp); DCHAR_T *end = p + pad; if (flags & FLAG_LEFT) @@ -4562,36 +4577,36 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, p = end; } - count = p - tmp; + { + size_t count = p - tmp; - if (count >= tmp_length) - /* tmp_length was incorrectly calculated - fix the - code above! */ - abort (); + if (count >= tmp_length) + /* tmp_length was incorrectly calculated - fix the + code above! */ + abort (); - /* Make room for the result. */ - if (count >= allocated - length) - { - size_t n = xsum (length, count); + /* Make room for the result. */ + if (count >= allocated - length) + { + size_t n = xsum (length, count); - ENSURE_ALLOCATION (n); - } + ENSURE_ALLOCATION (n); + } - /* Append the result. */ - memcpy (result + length, tmp, count * sizeof (DCHAR_T)); - if (tmp != tmpbuf) - free (tmp); - length += count; + /* Append the result. */ + memcpy (result + length, tmp, count * sizeof (DCHAR_T)); + if (tmp != tmpbuf) + free (tmp); + length += count; + } } #endif else { arg_type type = a.arg[dp->arg_index].type; int flags = dp->flags; -#if !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_LEFTADJUST || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION - int has_width; -#endif #if !USE_SNPRINTF || !HAVE_SNPRINTF_RETVAL_C99 || !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_LEFTADJUST || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION + int has_width; size_t width; #endif #if !USE_SNPRINTF || !HAVE_SNPRINTF_RETVAL_C99 || NEED_PRINTF_UNBOUNDED_PRECISION @@ -4620,10 +4635,8 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, TCHAR_T *tmp; #endif -#if !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_LEFTADJUST || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION - has_width = 0; -#endif #if !USE_SNPRINTF || !HAVE_SNPRINTF_RETVAL_C99 || !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_LEFTADJUST || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION + has_width = 0; width = 0; if (dp->width_start != dp->width_end) { @@ -4634,14 +4647,15 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, if (!(a.arg[dp->width_arg_index].type == TYPE_INT)) abort (); arg = a.arg[dp->width_arg_index].a.a_int; - width = arg; if (arg < 0) { /* "A negative field width is taken as a '-' flag followed by a positive field width." */ flags |= FLAG_LEFT; - width = -width; + width = (unsigned int) (-arg); } + else + width = arg; } else { @@ -4651,9 +4665,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, width = xsum (xtimes (width, 10), *digitp++ - '0'); while (digitp != dp->width_end); } -#if !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_LEFTADJUST || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION has_width = 1; -#endif } #endif @@ -4793,7 +4805,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, { const FCHAR_T *mp = dp->width_start; do - *fbp++ = *mp++; + *fbp++ = (unsigned char) *mp++; while (--n > 0); } } @@ -4814,7 +4826,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, { const FCHAR_T *mp = dp->precision_start; do - *fbp++ = *mp++; + *fbp++ = (unsigned char) *mp++; while (--n > 0); } } @@ -5141,7 +5153,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, size_t tmp_length = MAX_ROOM_NEEDED (&a, dp->arg_index, dp->conversion, type, flags, - width, + has_width ? width : 0, has_precision, precision, pad_ourselves); @@ -5179,21 +5191,18 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, /* SNPRINTF or sprintf failed. Save and use the errno that it has set, if any. */ int saved_errno = errno; - if (saved_errno == 0) - { - if (dp->conversion == 'c' || dp->conversion == 's') - saved_errno = EILSEQ; - else - saved_errno = EINVAL; - } if (!(result == resultbuf || result == NULL)) free (result); if (buf_malloced != NULL) free (buf_malloced); CLEANUP (); - - errno = saved_errno; + errno = + (saved_errno != 0 + ? saved_errno + : (dp->conversion == 'c' || dp->conversion == 's' + ? EILSEQ + : EINVAL)); return NULL; } @@ -5382,7 +5391,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, tmpsrc += count; tmpdst += count; for (n = count; n > 0; n--) - *--tmpdst = *--tmpsrc; + *--tmpdst = (unsigned char) *--tmpsrc; } } #endif diff --git a/lib/vasnprintf.h b/lib/vasnprintf.h index d691a5ffe..a3f48e828 100644 --- a/lib/vasnprintf.h +++ b/lib/vasnprintf.h @@ -1,5 +1,5 @@ /* vsprintf with automatic memory allocation. - Copyright (C) 2002-2004, 2007-2015 Free Software Foundation, Inc. + Copyright (C) 2002-2004, 2007-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/verify.h b/lib/verify.h index db52900e1..78d543f04 100644 --- a/lib/verify.h +++ b/lib/verify.h @@ -1,6 +1,6 @@ /* Compile-time assert-like macros. - Copyright (C) 2005-2006, 2009-2015 Free Software Foundation, Inc. + Copyright (C) 2005-2006, 2009-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/vsnprintf.c b/lib/vsnprintf.c index 96024096d..26b1887b0 100644 --- a/lib/vsnprintf.c +++ b/lib/vsnprintf.c @@ -1,5 +1,5 @@ /* Formatted output to strings. - Copyright (C) 2004, 2006-2015 Free Software Foundation, Inc. + Copyright (C) 2004, 2006-2014 Free Software Foundation, Inc. Written by Simon Josefsson and Yoann Vandoorselaere . This program is free software; you can redistribute it and/or modify diff --git a/lib/w32sock.h b/lib/w32sock.h index 072a7f53d..3946d4945 100644 --- a/lib/w32sock.h +++ b/lib/w32sock.h @@ -1,6 +1,6 @@ /* w32sock.h --- internal auxiliary functions for Windows socket functions - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/wchar.in.h b/lib/wchar.in.h index b15ad4b71..1874b4d7e 100644 --- a/lib/wchar.in.h +++ b/lib/wchar.in.h @@ -1,6 +1,6 @@ /* A substitute for ISO C99 , for platforms that have issues. - Copyright (C) 2007-2015 Free Software Foundation, Inc. + Copyright (C) 2007-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -30,14 +30,9 @@ #endif @PRAGMA_COLUMNS@ -#if (((defined __need_mbstate_t || defined __need_wint_t) \ - && !defined __MINGW32__) \ - || (defined __hpux \ - && ((defined _INTTYPES_INCLUDED && !defined strtoimax) \ - || defined _GL_JUST_INCLUDE_SYSTEM_WCHAR_H)) \ - || defined _GL_ALREADY_INCLUDING_WCHAR_H) +#if defined __need_mbstate_t || defined __need_wint_t || (defined __hpux && ((defined _INTTYPES_INCLUDED && !defined strtoimax) || defined _GL_JUST_INCLUDE_SYSTEM_WCHAR_H)) || defined _GL_ALREADY_INCLUDING_WCHAR_H /* Special invocation convention: - - Inside glibc and uClibc header files, but not MinGW. + - Inside glibc and uClibc header files. - On HP-UX 11.00 we have a sequence of nested includes -> -> , and the latter includes , once indirectly -> -> -> diff --git a/lib/wcrtomb.c b/lib/wcrtomb.c index bd7a7babb..ebbdddccc 100644 --- a/lib/wcrtomb.c +++ b/lib/wcrtomb.c @@ -1,5 +1,5 @@ /* Convert wide character to multibyte character. - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2008. This program is free software: you can redistribute it and/or modify diff --git a/lib/wctype.in.h b/lib/wctype.in.h index 2c6fe4a79..b5b6093d7 100644 --- a/lib/wctype.in.h +++ b/lib/wctype.in.h @@ -1,6 +1,6 @@ /* A substitute for ISO C99 , for platforms that lack it. - Copyright (C) 2006-2015 Free Software Foundation, Inc. + Copyright (C) 2006-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/write.c b/lib/write.c index dbc384008..51cc1d91e 100644 --- a/lib/write.c +++ b/lib/write.c @@ -1,5 +1,5 @@ /* POSIX compatible write() function. - Copyright (C) 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2008-2014 Free Software Foundation, Inc. Written by Bruno Haible , 2008. This program is free software: you can redistribute it and/or modify diff --git a/lib/xsize.h b/lib/xsize.h index a34d3435d..83cb960b5 100644 --- a/lib/xsize.h +++ b/lib/xsize.h @@ -1,6 +1,6 @@ /* xsize.h -- Checked size_t computations. - Copyright (C) 2003, 2008-2015 Free Software Foundation, Inc. + Copyright (C) 2003, 2008-2014 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/m4/00gnulib.m4 b/m4/00gnulib.m4 index c7103ed52..8eca5518a 100644 --- a/m4/00gnulib.m4 +++ b/m4/00gnulib.m4 @@ -1,5 +1,5 @@ # 00gnulib.m4 serial 3 -dnl Copyright (C) 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/absolute-header.m4 b/m4/absolute-header.m4 index bc19dfc30..ce3e39e9b 100644 --- a/m4/absolute-header.m4 +++ b/m4/absolute-header.m4 @@ -1,5 +1,5 @@ # absolute-header.m4 serial 16 -dnl Copyright (C) 2006-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/alloca.m4 b/m4/alloca.m4 index 8408bed28..d7bdea631 100644 --- a/m4/alloca.m4 +++ b/m4/alloca.m4 @@ -1,5 +1,5 @@ # alloca.m4 serial 14 -dnl Copyright (C) 2002-2004, 2006-2007, 2009-2015 Free Software Foundation, +dnl Copyright (C) 2002-2004, 2006-2007, 2009-2014 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/arpa_inet_h.m4 b/m4/arpa_inet_h.m4 index 056bc7b4b..f01699a9d 100644 --- a/m4/arpa_inet_h.m4 +++ b/m4/arpa_inet_h.m4 @@ -1,5 +1,5 @@ # arpa_inet_h.m4 serial 13 -dnl Copyright (C) 2006, 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/autobuild.m4 b/m4/autobuild.m4 index 239809cd5..00d870930 100644 --- a/m4/autobuild.m4 +++ b/m4/autobuild.m4 @@ -1,5 +1,5 @@ # autobuild.m4 serial 7 -dnl Copyright (C) 2004, 2006-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2004, 2006-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/btowc.m4 b/m4/btowc.m4 index c1da65d43..99889445f 100644 --- a/m4/btowc.m4 +++ b/m4/btowc.m4 @@ -1,5 +1,5 @@ # btowc.m4 serial 10 -dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/byteswap.m4 b/m4/byteswap.m4 index ec5d46cde..6d6357cbe 100644 --- a/m4/byteswap.m4 +++ b/m4/byteswap.m4 @@ -1,5 +1,5 @@ # byteswap.m4 serial 4 -dnl Copyright (C) 2005, 2007, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2005, 2007, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/canonicalize.m4 b/m4/canonicalize.m4 index 6d932fd1a..ace455661 100644 --- a/m4/canonicalize.m4 +++ b/m4/canonicalize.m4 @@ -1,6 +1,6 @@ # canonicalize.m4 serial 26 -dnl Copyright (C) 2003-2007, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2003-2007, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/ceil.m4 b/m4/ceil.m4 index fb5f6f0d5..128353ae7 100644 --- a/m4/ceil.m4 +++ b/m4/ceil.m4 @@ -1,5 +1,5 @@ # ceil.m4 serial 9 -dnl Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/check-math-lib.m4 b/m4/check-math-lib.m4 index 1c83f8fcb..a3894aa64 100644 --- a/m4/check-math-lib.m4 +++ b/m4/check-math-lib.m4 @@ -1,5 +1,5 @@ # check-math-lib.m4 serial 4 -dnl Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/clock_time.m4 b/m4/clock_time.m4 index efb2ac583..be36a42b8 100644 --- a/m4/clock_time.m4 +++ b/m4/clock_time.m4 @@ -1,5 +1,5 @@ # clock_time.m4 serial 10 -dnl Copyright (C) 2002-2006, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2006, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/close.m4 b/m4/close.m4 index d04aefbee..68510c5c5 100644 --- a/m4/close.m4 +++ b/m4/close.m4 @@ -1,5 +1,5 @@ # close.m4 serial 8 -dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/configmake.m4 b/m4/configmake.m4 index 49d3a13e3..0cd86cf99 100644 --- a/m4/configmake.m4 +++ b/m4/configmake.m4 @@ -1,5 +1,5 @@ # configmake.m4 serial 2 -dnl Copyright (C) 2010-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/copysign.m4 b/m4/copysign.m4 index 7cb33b666..1bb2d6fb9 100644 --- a/m4/copysign.m4 +++ b/m4/copysign.m4 @@ -1,5 +1,5 @@ # copysign.m4 serial 1 -dnl Copyright (C) 2011-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/dirent_h.m4 b/m4/dirent_h.m4 index 7abd1d05e..3f2b16b12 100644 --- a/m4/dirent_h.m4 +++ b/m4/dirent_h.m4 @@ -1,5 +1,5 @@ # dirent_h.m4 serial 16 -dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/dirfd.m4 b/m4/dirfd.m4 index ce56cff69..b42276948 100644 --- a/m4/dirfd.m4 +++ b/m4/dirfd.m4 @@ -2,7 +2,7 @@ dnl Find out how to get the file descriptor associated with an open DIR*. -# Copyright (C) 2001-2006, 2008-2015 Free Software Foundation, Inc. +# Copyright (C) 2001-2006, 2008-2014 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/dirname.m4 b/m4/dirname.m4 index 2a0be516e..d2627b8a8 100644 --- a/m4/dirname.m4 +++ b/m4/dirname.m4 @@ -1,5 +1,5 @@ #serial 10 -*- autoconf -*- -dnl Copyright (C) 2002-2006, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2006, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/double-slash-root.m4 b/m4/double-slash-root.m4 index f307eb2ff..937f4bca9 100644 --- a/m4/double-slash-root.m4 +++ b/m4/double-slash-root.m4 @@ -1,5 +1,5 @@ # double-slash-root.m4 serial 4 -*- Autoconf -*- -dnl Copyright (C) 2006, 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/dup2.m4 b/m4/dup2.m4 index 59028e098..89638a0bf 100644 --- a/m4/dup2.m4 +++ b/m4/dup2.m4 @@ -1,5 +1,5 @@ -#serial 24 -dnl Copyright (C) 2002, 2005, 2007, 2009-2015 Free Software Foundation, Inc. +#serial 20 +dnl Copyright (C) 2002, 2005, 2007, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -19,50 +19,33 @@ AC_DEFUN([gl_FUNC_DUP2], if test $HAVE_DUP2 = 1; then AC_CACHE_CHECK([whether dup2 works], [gl_cv_func_dup2_works], [AC_RUN_IFELSE([ - AC_LANG_PROGRAM( - [[#include - #include - #include - #include - #include - #ifndef RLIM_SAVED_CUR - # define RLIM_SAVED_CUR RLIM_INFINITY - #endif - #ifndef RLIM_SAVED_MAX - # define RLIM_SAVED_MAX RLIM_INFINITY - #endif - ]], - [[int result = 0; - int bad_fd = INT_MAX; - struct rlimit rlim; - if (getrlimit (RLIMIT_NOFILE, &rlim) == 0 - && 0 <= rlim.rlim_cur && rlim.rlim_cur <= INT_MAX - && rlim.rlim_cur != RLIM_INFINITY - && rlim.rlim_cur != RLIM_SAVED_MAX - && rlim.rlim_cur != RLIM_SAVED_CUR) - bad_fd = rlim.rlim_cur; - #ifdef FD_CLOEXEC - if (fcntl (1, F_SETFD, FD_CLOEXEC) == -1) - result |= 1; - #endif - if (dup2 (1, 1) != 1) - result |= 2; - #ifdef FD_CLOEXEC - if (fcntl (1, F_GETFD) != FD_CLOEXEC) - result |= 4; - #endif - close (0); - if (dup2 (0, 0) != -1) - result |= 8; - /* Many gnulib modules require POSIX conformance of EBADF. */ - if (dup2 (2, bad_fd) == -1 && errno != EBADF) - result |= 16; - /* Flush out some cygwin core dumps. */ - if (dup2 (2, -1) != -1 || errno != EBADF) - result |= 32; - dup2 (2, 255); - dup2 (2, 256); - return result;]]) + AC_LANG_PROGRAM([[#include +#include +#include ]], + [int result = 0; +#ifdef FD_CLOEXEC + if (fcntl (1, F_SETFD, FD_CLOEXEC) == -1) + result |= 1; +#endif + if (dup2 (1, 1) == 0) + result |= 2; +#ifdef FD_CLOEXEC + if (fcntl (1, F_GETFD) != FD_CLOEXEC) + result |= 4; +#endif + close (0); + if (dup2 (0, 0) != -1) + result |= 8; + /* Many gnulib modules require POSIX conformance of EBADF. */ + if (dup2 (2, 1000000) == -1 && errno != EBADF) + result |= 16; + /* Flush out some cygwin core dumps. */ + if (dup2 (2, -1) != -1 || errno != EBADF) + result |= 32; + dup2 (2, 255); + dup2 (2, 256); + return result; + ]) ], [gl_cv_func_dup2_works=yes], [gl_cv_func_dup2_works=no], [case "$host_os" in @@ -70,14 +53,13 @@ AC_DEFUN([gl_FUNC_DUP2], gl_cv_func_dup2_works="guessing no" ;; cygwin*) # on cygwin 1.5.x, dup2(1,1) returns 0 gl_cv_func_dup2_works="guessing no" ;; - aix* | freebsd*) - # on AIX 7.1 and FreeBSD 6.1, dup2 (1,toobig) gives EMFILE, - # not EBADF. + linux*) # On linux between 2008-07-27 and 2009-05-11, dup2 of a + # closed fd may yield -EBADF instead of -1 / errno=EBADF. + gl_cv_func_dup2_works="guessing no" ;; + freebsd*) # on FreeBSD 6.1, dup2(1,1000000) gives EMFILE, not EBADF. gl_cv_func_dup2_works="guessing no" ;; haiku*) # on Haiku alpha 2, dup2(1, 1) resets FD_CLOEXEC. gl_cv_func_dup2_works="guessing no" ;; - *-android*) # implemented using dup3(), which fails if oldfd == newfd - gl_cv_func_dup2_works="guessing no" ;; *) gl_cv_func_dup2_works="guessing yes" ;; esac]) ]) diff --git a/m4/duplocale.m4 b/m4/duplocale.m4 index 5f17769cd..d45891d4f 100644 --- a/m4/duplocale.m4 +++ b/m4/duplocale.m4 @@ -1,5 +1,5 @@ # duplocale.m4 serial 7 -dnl Copyright (C) 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/eealloc.m4 b/m4/eealloc.m4 index 322bdd50b..8a51fe7c5 100644 --- a/m4/eealloc.m4 +++ b/m4/eealloc.m4 @@ -1,5 +1,5 @@ # eealloc.m4 serial 3 -dnl Copyright (C) 2003, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/environ.m4 b/m4/environ.m4 index 4dbf9473e..cfabe46f5 100644 --- a/m4/environ.m4 +++ b/m4/environ.m4 @@ -1,5 +1,5 @@ # environ.m4 serial 6 -dnl Copyright (C) 2001-2004, 2006-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2004, 2006-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/errno_h.m4 b/m4/errno_h.m4 index cfaa68761..4ee9e6a14 100644 --- a/m4/errno_h.m4 +++ b/m4/errno_h.m4 @@ -1,5 +1,5 @@ # errno_h.m4 serial 12 -dnl Copyright (C) 2004, 2006, 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2004, 2006, 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/exponentd.m4 b/m4/exponentd.m4 index 84f1691a6..7bee63571 100644 --- a/m4/exponentd.m4 +++ b/m4/exponentd.m4 @@ -1,5 +1,5 @@ # exponentd.m4 serial 3 -dnl Copyright (C) 2007-2008, 2010-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2008, 2010-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/exponentf.m4 b/m4/exponentf.m4 index 95e32cdd9..b2dfeef96 100644 --- a/m4/exponentf.m4 +++ b/m4/exponentf.m4 @@ -1,5 +1,5 @@ # exponentf.m4 serial 2 -dnl Copyright (C) 2007-2008, 2010-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2008, 2010-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/exponentl.m4 b/m4/exponentl.m4 index 6b95e7372..d6f4ba7ff 100644 --- a/m4/exponentl.m4 +++ b/m4/exponentl.m4 @@ -1,5 +1,5 @@ # exponentl.m4 serial 3 -dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/extensions.m4 b/m4/extensions.m4 index 35bc49c97..37f55ca3d 100644 --- a/m4/extensions.m4 +++ b/m4/extensions.m4 @@ -1,7 +1,7 @@ # serial 13 -*- Autoconf -*- # Enable extensions on systems that normally disable them. -# Copyright (C) 2003, 2006-2015 Free Software Foundation, Inc. +# Copyright (C) 2003, 2006-2014 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. @@ -68,10 +68,6 @@ dnl configure.ac when using autoheader 2.62. #ifndef _GNU_SOURCE # undef _GNU_SOURCE #endif -/* Use GNU style printf and scanf. */ -#ifndef __USE_MINGW_ANSI_STDIO -# undef __USE_MINGW_ANSI_STDIO -#endif /* Enable threading extensions on Solaris. */ #ifndef _POSIX_PTHREAD_SEMANTICS # undef _POSIX_PTHREAD_SEMANTICS @@ -104,7 +100,6 @@ dnl configure.ac when using autoheader 2.62. AC_DEFINE([_ALL_SOURCE]) AC_DEFINE([_DARWIN_C_SOURCE]) AC_DEFINE([_GNU_SOURCE]) - AC_DEFINE([__USE_MINGW_ANSI_STDIO]) AC_DEFINE([_POSIX_PTHREAD_SEMANTICS]) AC_DEFINE([_TANDEM_SOURCE]) AC_CACHE_CHECK([whether _XOPEN_SOURCE should be defined], diff --git a/m4/extern-inline.m4 b/m4/extern-inline.m4 index 72800650e..240150efb 100644 --- a/m4/extern-inline.m4 +++ b/m4/extern-inline.m4 @@ -1,6 +1,6 @@ dnl 'extern inline' a la ISO C99. -dnl Copyright 2012-2015 Free Software Foundation, Inc. +dnl Copyright 2012-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -19,28 +19,13 @@ AC_DEFUN([gl_EXTERN_INLINE], 'reference to static identifier "f" in extern inline function'. This bug was observed with Sun C 5.12 SunOS_i386 2011/11/16. - Suppress extern inline (with or without __attribute__ ((__gnu_inline__))) - on configurations that mistakenly use 'static inline' to implement - functions or macros in standard C headers like . For example, - if isdigit is mistakenly implemented via a static inline function, - a program containing an extern inline function that calls isdigit - may not work since the C standard prohibits extern inline functions - from calling static functions. This bug is known to occur on: - - OS X 10.8 and earlier; see: - http://lists.gnu.org/archive/html/bug-gnulib/2012-12/msg00023.html - - DragonFly; see - http://muscles.dragonflybsd.org/bulk/bleeding-edge-potential/latest-per-pkg/ah-tty-0.3.12.log - - FreeBSD; see: - http://lists.gnu.org/archive/html/bug-gnulib/2014-07/msg00104.html - + Suppress the use of extern inline on problematic Apple configurations. + OS X 10.8 and earlier mishandle it; see, e.g., + . OS X 10.9 has a macro __header_inline indicating the bug is fixed for C and for clang but remains for g++; see . - Assume DragonFly and FreeBSD will be similar. */ -#if (((defined __APPLE__ && defined __MACH__) \ - || defined __DragonFly__ || defined __FreeBSD__) \ + Perhaps Apple will fix this some day. */ +#if (defined __APPLE__ \ && (defined __header_inline \ ? (defined __cplusplus && defined __GNUC_STDC_INLINE__ \ && ! defined __clang__) \ @@ -48,19 +33,19 @@ AC_DEFUN([gl_EXTERN_INLINE], && (defined __GNUC__ || defined __cplusplus)) \ || (defined _FORTIFY_SOURCE && 0 < _FORTIFY_SOURCE \ && defined __GNUC__ && ! defined __cplusplus)))) -# define _GL_EXTERN_INLINE_STDHEADER_BUG +# define _GL_EXTERN_INLINE_APPLE_BUG #endif #if ((__GNUC__ \ ? defined __GNUC_STDC_INLINE__ && __GNUC_STDC_INLINE__ \ : (199901L <= __STDC_VERSION__ \ && !defined __HP_cc \ && !(defined __SUNPRO_C && __STDC__))) \ - && !defined _GL_EXTERN_INLINE_STDHEADER_BUG) + && !defined _GL_EXTERN_INLINE_APPLE_BUG) # define _GL_INLINE inline # define _GL_EXTERN_INLINE extern inline # define _GL_EXTERN_INLINE_IN_USE #elif (2 < __GNUC__ + (7 <= __GNUC_MINOR__) && !defined __STRICT_ANSI__ \ - && !defined _GL_EXTERN_INLINE_STDHEADER_BUG) + && !defined _GL_EXTERN_INLINE_APPLE_BUG) # if defined __GNUC_GNU_INLINE__ && __GNUC_GNU_INLINE__ /* __gnu_inline__ suppresses a GCC 4.2 diagnostic. */ # define _GL_INLINE extern inline __attribute__ ((__gnu_inline__)) @@ -74,19 +59,17 @@ AC_DEFUN([gl_EXTERN_INLINE], # define _GL_EXTERN_INLINE static _GL_UNUSED #endif -/* In GCC 4.6 (inclusive) to 5.1 (exclusive), - suppress bogus "no previous prototype for 'FOO'" - and "no previous declaration for 'FOO'" diagnostics, - when FOO is an inline function in the header; see - and - . */ -#if __GNUC__ == 4 && 6 <= __GNUC_MINOR__ +#if 4 < __GNUC__ + (6 <= __GNUC_MINOR__) # if defined __GNUC_STDC_INLINE__ && __GNUC_STDC_INLINE__ # define _GL_INLINE_HEADER_CONST_PRAGMA # else # define _GL_INLINE_HEADER_CONST_PRAGMA \ _Pragma ("GCC diagnostic ignored \"-Wsuggest-attribute=const\"") # endif + /* Suppress GCC's bogus "no previous prototype for 'FOO'" + and "no previous declaration for 'FOO'" diagnostics, + when FOO is an inline function in the header; see + . */ # define _GL_INLINE_HEADER_BEGIN \ _Pragma ("GCC diagnostic push") \ _Pragma ("GCC diagnostic ignored \"-Wmissing-prototypes\"") \ diff --git a/m4/fcntl-o.m4 b/m4/fcntl-o.m4 index 891a62fb6..43c93124e 100644 --- a/m4/fcntl-o.m4 +++ b/m4/fcntl-o.m4 @@ -1,5 +1,5 @@ # fcntl-o.m4 serial 4 -dnl Copyright (C) 2006, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/fcntl_h.m4 b/m4/fcntl_h.m4 index b279162a1..fb2556d37 100644 --- a/m4/fcntl_h.m4 +++ b/m4/fcntl_h.m4 @@ -1,6 +1,6 @@ # serial 15 # Configure fcntl.h. -dnl Copyright (C) 2006-2007, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2007, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/flexmember.m4 b/m4/flexmember.m4 deleted file mode 100644 index 95500caf0..000000000 --- a/m4/flexmember.m4 +++ /dev/null @@ -1,41 +0,0 @@ -# serial 3 -# Check for flexible array member support. - -# Copyright (C) 2006, 2009-2015 Free Software Foundation, Inc. -# This file is free software; the Free Software Foundation -# gives unlimited permission to copy and/or distribute it, -# with or without modifications, as long as this notice is preserved. - -# Written by Paul Eggert. - -AC_DEFUN([AC_C_FLEXIBLE_ARRAY_MEMBER], -[ - AC_CACHE_CHECK([for flexible array member], - ac_cv_c_flexmember, - [AC_COMPILE_IFELSE( - [AC_LANG_PROGRAM( - [[#include - #include - #include - struct s { int n; double d[]; };]], - [[int m = getchar (); - struct s *p = malloc (offsetof (struct s, d) - + m * sizeof (double)); - p->d[0] = 0.0; - return p->d != (double *) NULL;]])], - [ac_cv_c_flexmember=yes], - [ac_cv_c_flexmember=no])]) - if test $ac_cv_c_flexmember = yes; then - AC_DEFINE([FLEXIBLE_ARRAY_MEMBER], [], - [Define to nothing if C supports flexible array members, and to - 1 if it does not. That way, with a declaration like 'struct s - { int n; double d@<:@FLEXIBLE_ARRAY_MEMBER@:>@; };', the struct hack - can be used with pre-C99 compilers. - When computing the size of such an object, don't use 'sizeof (struct s)' - as it overestimates the size. Use 'offsetof (struct s, d)' instead. - Don't use 'offsetof (struct s, d@<:@0@:>@)', as this doesn't work with - MSVC and with C++ compilers.]) - else - AC_DEFINE([FLEXIBLE_ARRAY_MEMBER], [1]) - fi -]) diff --git a/m4/float_h.m4 b/m4/float_h.m4 index e4853f3b0..a27ef7f97 100644 --- a/m4/float_h.m4 +++ b/m4/float_h.m4 @@ -1,5 +1,5 @@ # float_h.m4 serial 9 -dnl Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/flock.m4 b/m4/flock.m4 index ee2941a33..ad2d1290c 100644 --- a/m4/flock.m4 +++ b/m4/flock.m4 @@ -1,5 +1,5 @@ # flock.m4 serial 3 -dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/floor.m4 b/m4/floor.m4 index 41195d9d2..a38c03d14 100644 --- a/m4/floor.m4 +++ b/m4/floor.m4 @@ -1,5 +1,5 @@ # floor.m4 serial 8 -dnl Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/fpieee.m4 b/m4/fpieee.m4 index 41c6033b3..729afe859 100644 --- a/m4/fpieee.m4 +++ b/m4/fpieee.m4 @@ -1,5 +1,5 @@ -# fpieee.m4 serial 2 -*- coding: utf-8 -*- -dnl Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. +# fpieee.m4 serial 2 +dnl Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/frexp.m4 b/m4/frexp.m4 index 04f40679a..579826213 100644 --- a/m4/frexp.m4 +++ b/m4/frexp.m4 @@ -1,5 +1,5 @@ # frexp.m4 serial 15 -dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/fstat.m4 b/m4/fstat.m4 index d6a928827..ddd3fb976 100644 --- a/m4/fstat.m4 +++ b/m4/fstat.m4 @@ -1,5 +1,5 @@ # fstat.m4 serial 4 -dnl Copyright (C) 2011-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/fsync.m4 b/m4/fsync.m4 index bc2b09352..888a65def 100644 --- a/m4/fsync.m4 +++ b/m4/fsync.m4 @@ -1,5 +1,5 @@ # fsync.m4 serial 2 -dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/func.m4 b/m4/func.m4 index fcc74ff2c..0ab14c9e4 100644 --- a/m4/func.m4 +++ b/m4/func.m4 @@ -1,5 +1,5 @@ # func.m4 serial 2 -dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/getaddrinfo.m4 b/m4/getaddrinfo.m4 index f3e40c479..2e6658486 100644 --- a/m4/getaddrinfo.m4 +++ b/m4/getaddrinfo.m4 @@ -1,5 +1,5 @@ # getaddrinfo.m4 serial 30 -dnl Copyright (C) 2004-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2004-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/getlogin.m4 b/m4/getlogin.m4 index 0db7d51be..47b8f0897 100644 --- a/m4/getlogin.m4 +++ b/m4/getlogin.m4 @@ -1,5 +1,5 @@ # getlogin.m4 serial 3 -dnl Copyright (C) 2010-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/gettimeofday.m4 b/m4/gettimeofday.m4 index ce246e18b..1c2d66ee2 100644 --- a/m4/gettimeofday.m4 +++ b/m4/gettimeofday.m4 @@ -1,6 +1,6 @@ # serial 21 -# Copyright (C) 2001-2003, 2005, 2007, 2009-2015 Free Software Foundation, Inc. +# Copyright (C) 2001-2003, 2005, 2007, 2009-2014 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/glibc21.m4 b/m4/glibc21.m4 index 3a971c5a2..ab58b7121 100644 --- a/m4/glibc21.m4 +++ b/m4/glibc21.m4 @@ -1,5 +1,5 @@ # glibc21.m4 serial 5 -dnl Copyright (C) 2000-2002, 2004, 2008, 2010-2015 Free Software Foundation, +dnl Copyright (C) 2000-2002, 2004, 2008, 2010-2014 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index 57d23662c..26c96b3e3 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -1,4 +1,4 @@ -# Copyright (C) 2002-2015 Free Software Foundation, Inc. +# Copyright (C) 2002-2014 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -76,6 +76,7 @@ gl_MODULES([ isfinite isinf isnan + largefile ldexp lib-symbol-versions lib-symbol-visibility @@ -126,7 +127,7 @@ gl_MODULES([ warnings wchar ]) -gl_AVOID([ lock]) +gl_AVOID([lock]) gl_SOURCE_BASE([lib]) gl_M4_BASE([m4]) gl_PO_BASE([]) diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4 index 50ef97420..20ce40e74 100644 --- a/m4/gnulib-common.m4 +++ b/m4/gnulib-common.m4 @@ -1,5 +1,5 @@ -# gnulib-common.m4 serial 36 -dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. +# gnulib-common.m4 serial 34 +dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -49,16 +49,6 @@ AC_DEFUN([gl_COMMON_BODY], [ is a misnomer outside of parameter lists. */ #define _UNUSED_PARAMETER_ _GL_UNUSED -/* gcc supports the "unused" attribute on possibly unused labels, and - g++ has since version 4.5. Note to support C++ as well as C, - _GL_UNUSED_LABEL should be used with a trailing ; */ -#if !defined __cplusplus || __GNUC__ > 4 \ - || (__GNUC__ == 4 && __GNUC_MINOR__ >= 5) -# define _GL_UNUSED_LABEL _GL_UNUSED -#else -# define _GL_UNUSED_LABEL -#endif - /* The __pure__ attribute was added in gcc 2.96. */ #if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 96) # define _GL_ATTRIBUTE_PURE __attribute__ ((__pure__)) @@ -253,10 +243,9 @@ AC_DEFUN([gl_PROG_AR_RANLIB], [ dnl Minix 3 comes with two toolchains: The Amsterdam Compiler Kit compiler dnl as "cc", and GCC as "gcc". They have different object file formats and - dnl library formats. In particular, the GNU binutils programs ar and ranlib + dnl library formats. In particular, the GNU binutils programs ar, ranlib dnl produce libraries that work only with gcc, not with cc. AC_REQUIRE([AC_PROG_CC]) - AC_BEFORE([$0], [AM_PROG_AR]) AC_CACHE_CHECK([for Minix Amsterdam compiler], [gl_cv_c_amsterdam_compiler], [ AC_EGREP_CPP([Amsterdam], @@ -268,37 +257,25 @@ Amsterdam [gl_cv_c_amsterdam_compiler=yes], [gl_cv_c_amsterdam_compiler=no]) ]) - - dnl Don't compete with AM_PROG_AR's decision about AR/ARFLAGS if we are not - dnl building with __ACK__. - if test $gl_cv_c_amsterdam_compiler = yes; then - if test -z "$AR"; then + if test -z "$AR"; then + if test $gl_cv_c_amsterdam_compiler = yes; then AR='cc -c.a' - fi - if test -z "$ARFLAGS"; then - ARFLAGS='-o' + if test -z "$ARFLAGS"; then + ARFLAGS='-o' + fi + else + dnl Use the Automake-documented default values for AR and ARFLAGS, + dnl but prefer ${host}-ar over ar (useful for cross-compiling). + AC_CHECK_TOOL([AR], [ar], [ar]) + if test -z "$ARFLAGS"; then + ARFLAGS='cru' + fi fi else - dnl AM_PROG_AR was added in automake v1.11.2. AM_PROG_AR does not AC_SUBST - dnl ARFLAGS variable (it is filed into Makefile.in directly by automake - dnl script on-demand, if not specified by ./configure of course). - dnl Don't AC_REQUIRE the AM_PROG_AR otherwise the code for __ACK__ above - dnl will be ignored. Also, pay attention to call AM_PROG_AR in else block - dnl because AM_PROG_AR is written so it could re-set AR variable even for - dnl __ACK__. It may seem like its easier to avoid calling the macro here, - dnl but we need to AC_SUBST both AR/ARFLAGS (thus those must have some good - dnl default value and automake should usually know them). - m4_ifdef([AM_PROG_AR], [AM_PROG_AR], [:]) + if test -z "$ARFLAGS"; then + ARFLAGS='cru' + fi fi - - dnl In case the code above has not helped with setting AR/ARFLAGS, use - dnl Automake-documented default values for AR and ARFLAGS, but prefer - dnl ${host}-ar over ar (useful for cross-compiling). - AC_CHECK_TOOL([AR], [ar], [ar]) - if test -z "$ARFLAGS"; then - ARFLAGS='cr' - fi - AC_SUBST([AR]) AC_SUBST([ARFLAGS]) if test -z "$RANLIB"; then @@ -332,28 +309,26 @@ m4_ifdef([AC_PROG_MKDIR_P], [ ]) # AC_C_RESTRICT -# This definition is copied from post-2.69 Autoconf and overrides the -# AC_C_RESTRICT macro from autoconf 2.60..2.69. It can be removed -# once autoconf >= 2.70 can be assumed. It's painful to check version -# numbers, and in practice this macro is more up-to-date than Autoconf -# is, so override Autoconf unconditionally. +# This definition overrides the AC_C_RESTRICT macro from autoconf 2.60..2.61, +# so that mixed use of GNU C and GNU C++ and mixed use of Sun C and Sun C++ +# works. +# This definition can be removed once autoconf >= 2.62 can be assumed. +# AC_AUTOCONF_VERSION was introduced in 2.62, so use that as the witness. +m4_ifndef([AC_AUTOCONF_VERSION],[ AC_DEFUN([AC_C_RESTRICT], [AC_CACHE_CHECK([for C/C++ restrict keyword], [ac_cv_c_restrict], [ac_cv_c_restrict=no # The order here caters to the fact that C++ does not require restrict. for ac_kw in __restrict __restrict__ _Restrict restrict; do - AC_COMPILE_IFELSE( - [AC_LANG_PROGRAM( - [[typedef int *int_ptr; - int foo (int_ptr $ac_kw ip) { return ip[0]; } - int bar (int [$ac_kw]); /* Catch GCC bug 14050. */ - int bar (int ip[$ac_kw]) { return ip[0]; } - ]], - [[int s[1]; - int *$ac_kw t = s; - t[0] = 0; - return foo (t) + bar (t); - ]])], + AC_COMPILE_IFELSE([AC_LANG_PROGRAM( + [[typedef int * int_ptr; + int foo (int_ptr $ac_kw ip) { + return ip[0]; + }]], + [[int s[1]; + int * $ac_kw t = s; + t[0] = 0; + return foo(t)]])], [ac_cv_c_restrict=$ac_kw]) test "$ac_cv_c_restrict" != no && break done @@ -363,21 +338,21 @@ AC_DEFUN([AC_C_RESTRICT], nothing if this is not supported. Do not define if restrict is supported directly. */ #undef restrict -/* Work around a bug in Sun C++: it does not support _Restrict or - __restrict__, even though the corresponding Sun C compiler ends up with - "#define restrict _Restrict" or "#define restrict __restrict__" in the - previous line. Perhaps some future version of Sun C++ will work with - restrict; if so, hopefully it defines __RESTRICT like Sun C does. */ +/* Work around a bug in Sun C++: it does not support _Restrict, even + though the corresponding Sun C compiler does, which causes + "#define restrict _Restrict" in the previous line. Perhaps some future + version of Sun C++ will work with _Restrict; if so, it'll probably + define __RESTRICT, just as Sun C does. */ #if defined __SUNPRO_CC && !defined __RESTRICT # define _Restrict -# define __restrict__ #endif]) case $ac_cv_c_restrict in restrict) ;; no) AC_DEFINE([restrict], []) ;; *) AC_DEFINE_UNQUOTED([restrict], [$ac_cv_c_restrict]) ;; esac -])# AC_C_RESTRICT +]) +]) # gl_BIGENDIAN # is like AC_C_BIGENDIAN, except that it can be AC_REQUIREd. diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index a52f18593..429fee422 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -1,5 +1,5 @@ # DO NOT EDIT! GENERATED AUTOMATICALLY! -# Copyright (C) 2002-2015 Free Software Foundation, Inc. +# Copyright (C) 2002-2014 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -37,11 +37,7 @@ AC_DEFUN([gl_EARLY], m4_pattern_allow([^gl_ES$])dnl a valid locale name m4_pattern_allow([^gl_LIBOBJS$])dnl a variable m4_pattern_allow([^gl_LTLIBOBJS$])dnl a variable - - # Pre-early section. - AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) AC_REQUIRE([gl_PROG_AR_RANLIB]) - AC_REQUIRE([AM_PROG_CC_C_O]) # Code from module absolute-header: # Code from module accept: @@ -50,7 +46,6 @@ AC_DEFUN([gl_EARLY], # Code from module alloca-opt: # Code from module announce-gen: # Code from module arpa_inet: - # Code from module assure: # Code from module autobuild: AB_INIT # Code from module binary-io: @@ -78,10 +73,10 @@ AC_DEFUN([gl_EARLY], # Code from module environ: # Code from module errno: # Code from module extensions: + AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) # Code from module extern-inline: # Code from module fcntl-h: # Code from module fd-hook: - # Code from module flexmember: # Code from module float: # Code from module flock: # Code from module floor: @@ -152,8 +147,6 @@ AC_DEFUN([gl_EARLY], # Code from module memchr: # Code from module mkdir: # Code from module mkstemp: - # Code from module mktime: - # Code from module mktime-internal: # Code from module msvc-inval: # Code from module msvc-nothrow: # Code from module multiarch: @@ -227,8 +220,6 @@ AC_DEFUN([gl_EARLY], # Code from module tempname: # Code from module time: # Code from module time_r: - # Code from module time_rz: - # Code from module timegm: # Code from module times: # Code from module trunc: # Code from module unistd: @@ -239,7 +230,6 @@ AC_DEFUN([gl_EARLY], # Code from module unistr/u8-prev: # Code from module unistr/u8-uctomb: # Code from module unitypes: - # Code from module unsetenv: # Code from module useless-if-before-free: # Code from module vasnprintf: # Code from module vc-list-files: @@ -347,7 +337,6 @@ AC_SUBST([LTALLOCA]) gl_HEADER_ERRNO_H AC_REQUIRE([gl_EXTERN_INLINE]) gl_FCNTL_H - AC_C_FLEXIBLE_ARRAY_MEMBER gl_FLOAT_H if test $REPLACE_FLOAT_LDBL = 1; then AC_LIBOBJ([float]) @@ -602,17 +591,6 @@ AC_SUBST([LTALLOCA]) gl_PREREQ_MKSTEMP fi gl_STDLIB_MODULE_INDICATOR([mkstemp]) - gl_FUNC_MKTIME - if test $REPLACE_MKTIME = 1; then - AC_LIBOBJ([mktime]) - gl_PREREQ_MKTIME - fi - gl_TIME_MODULE_INDICATOR([mktime]) - gl_FUNC_MKTIME_INTERNAL - if test $REPLACE_MKTIME = 1; then - AC_LIBOBJ([mktime]) - gl_PREREQ_MKTIME - fi gl_MSVC_INVAL if test $HAVE_MSVC_INVALID_PARAMETER_HANDLER = 1; then AC_LIBOBJ([msvc-inval]) @@ -771,8 +749,8 @@ AC_SUBST([LTALLOCA]) SYS_IOCTL_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS=1 fi gl_SYS_SOCKET_MODULE_INDICATOR([socket]) - AC_REQUIRE([gl_SOCKETLIB]) - AC_REQUIRE([gl_SOCKETS]) + gl_SOCKETLIB + gl_SOCKETS gl_TYPE_SOCKLEN_T gt_TYPE_SSIZE_T gl_FUNC_STAT @@ -805,7 +783,7 @@ AC_SUBST([LTALLOCA]) AC_PROG_MKDIR_P gl_HEADER_SYS_SELECT AC_PROG_MKDIR_P - AC_REQUIRE([gl_HEADER_SYS_SOCKET]) + gl_HEADER_SYS_SOCKET AC_PROG_MKDIR_P gl_HEADER_SYS_STAT_H AC_PROG_MKDIR_P @@ -825,17 +803,6 @@ AC_SUBST([LTALLOCA]) gl_PREREQ_TIME_R fi gl_TIME_MODULE_INDICATOR([time_r]) - gl_TIME_RZ - if test "$HAVE_TIMEZONE_T" = 0; then - AC_LIBOBJ([time_rz]) - fi - gl_TIME_MODULE_INDICATOR([time_rz]) - gl_FUNC_TIMEGM - if test $HAVE_TIMEGM = 0 || test $REPLACE_TIMEGM = 1; then - AC_LIBOBJ([timegm]) - gl_PREREQ_TIMEGM - fi - gl_TIME_MODULE_INDICATOR([timegm]) gl_FUNC_TIMES if test $HAVE_TIMES = 0; then AC_LIBOBJ([times]) @@ -847,7 +814,7 @@ AC_SUBST([LTALLOCA]) fi gl_MATH_MODULE_INDICATOR([trunc]) gl_UNISTD_H - gl_LIBUNISTRING_LIBHEADER([0.9.4], [unistr.h]) + gl_LIBUNISTRING_LIBHEADER([0.9.2], [unistr.h]) gl_MODULE_INDICATOR([unistr/u8-mbtouc]) gl_LIBUNISTRING_MODULE([0.9.4], [unistr/u8-mbtouc]) gl_MODULE_INDICATOR([unistr/u8-mbtouc-unsafe]) @@ -857,13 +824,7 @@ AC_SUBST([LTALLOCA]) gl_LIBUNISTRING_MODULE([0.9], [unistr/u8-prev]) gl_MODULE_INDICATOR([unistr/u8-uctomb]) gl_LIBUNISTRING_MODULE([0.9], [unistr/u8-uctomb]) - gl_LIBUNISTRING_LIBHEADER([0.9.4], [unitypes.h]) - gl_FUNC_UNSETENV - if test $HAVE_UNSETENV = 0 || test $REPLACE_UNSETENV = 1; then - AC_LIBOBJ([unsetenv]) - gl_PREREQ_UNSETENV - fi - gl_STDLIB_MODULE_INDICATOR([unsetenv]) + gl_LIBUNISTRING_LIBHEADER([0.9], [unitypes.h]) gl_FUNC_VASNPRINTF gl_FUNC_VSNPRINTF gl_STDIO_MODULE_INDICATOR([vsnprintf]) @@ -1033,14 +994,12 @@ AC_DEFUN([gl_FILE_LIST], [ build-aux/useless-if-before-free build-aux/vc-list-files doc/gendocs_template - doc/gendocs_template_min lib/accept.c lib/alignof.h lib/alloca.c lib/alloca.in.h lib/arpa_inet.in.h lib/asnprintf.c - lib/assure.h lib/basename-lgpl.c lib/binary-io.c lib/binary-io.h @@ -1137,8 +1096,6 @@ AC_DEFUN([gl_FILE_LIST], [ lib/memchr.valgrind lib/mkdir.c lib/mkstemp.c - lib/mktime-internal.h - lib/mktime.c lib/msvc-inval.c lib/msvc-inval.h lib/msvc-nothrow.c @@ -1224,11 +1181,8 @@ AC_DEFUN([gl_FILE_LIST], [ lib/sys_uio.in.h lib/tempname.c lib/tempname.h - lib/time-internal.h lib/time.in.h lib/time_r.c - lib/time_rz.c - lib/timegm.c lib/times.c lib/trunc.c lib/unistd.c @@ -1243,7 +1197,6 @@ AC_DEFUN([gl_FILE_LIST], [ lib/unistr/u8-uctomb-aux.c lib/unistr/u8-uctomb.c lib/unitypes.in.h - lib/unsetenv.c lib/vasnprintf.c lib/vasnprintf.h lib/verify.h @@ -1287,7 +1240,6 @@ AC_DEFUN([gl_FILE_LIST], [ m4/extern-inline.m4 m4/fcntl-o.m4 m4/fcntl_h.m4 - m4/flexmember.m4 m4/float_h.m4 m4/flock.m4 m4/floor.m4 @@ -1349,7 +1301,6 @@ AC_DEFUN([gl_FILE_LIST], [ m4/memchr.m4 m4/mkdir.m4 m4/mkstemp.m4 - m4/mktime.m4 m4/mmap-anon.m4 m4/mode_t.m4 m4/msvc-inval.m4 @@ -1414,8 +1365,6 @@ AC_DEFUN([gl_FILE_LIST], [ m4/tempname.m4 m4/time_h.m4 m4/time_r.m4 - m4/time_rz.m4 - m4/timegm.m4 m4/times.m4 m4/tm_gmtoff.m4 m4/trunc.m4 diff --git a/m4/gnulib-tool.m4 b/m4/gnulib-tool.m4 index fede1fc3b..a588e1519 100644 --- a/m4/gnulib-tool.m4 +++ b/m4/gnulib-tool.m4 @@ -1,5 +1,5 @@ # gnulib-tool.m4 serial 2 -dnl Copyright (C) 2004-2005, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2004-2005, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/hostent.m4 b/m4/hostent.m4 index 6706d1f5c..dd8fc0709 100644 --- a/m4/hostent.m4 +++ b/m4/hostent.m4 @@ -1,5 +1,5 @@ # hostent.m4 serial 2 -dnl Copyright (C) 2008, 2010-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2008, 2010-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/iconv.m4 b/m4/iconv.m4 index 4e3736315..4b29c5f2c 100644 --- a/m4/iconv.m4 +++ b/m4/iconv.m4 @@ -1,4 +1,4 @@ -# iconv.m4 serial 19 (gettext-0.18.2) +# iconv.m4 serial 18 (gettext-0.18.2) dnl Copyright (C) 2000-2002, 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -72,33 +72,27 @@ AC_DEFUN([AM_ICONV_LINK], if test $am_cv_lib_iconv = yes; then LIBS="$LIBS $LIBICONV" fi - am_cv_func_iconv_works=no - for ac_iconv_const in '' 'const'; do - AC_RUN_IFELSE( - [AC_LANG_PROGRAM( - [[ + AC_RUN_IFELSE( + [AC_LANG_SOURCE([[ #include #include - -#ifndef ICONV_CONST -# define ICONV_CONST $ac_iconv_const -#endif - ]], - [[int result = 0; +int main () +{ + int result = 0; /* Test against AIX 5.1 bug: Failures are not distinguishable from successful returns. */ { iconv_t cd_utf8_to_88591 = iconv_open ("ISO8859-1", "UTF-8"); if (cd_utf8_to_88591 != (iconv_t)(-1)) { - static ICONV_CONST char input[] = "\342\202\254"; /* EURO SIGN */ + static const char input[] = "\342\202\254"; /* EURO SIGN */ char buf[10]; - ICONV_CONST char *inptr = input; + const char *inptr = input; size_t inbytesleft = strlen (input); char *outptr = buf; size_t outbytesleft = sizeof (buf); size_t res = iconv (cd_utf8_to_88591, - &inptr, &inbytesleft, + (char **) &inptr, &inbytesleft, &outptr, &outbytesleft); if (res == 0) result |= 1; @@ -111,14 +105,14 @@ AC_DEFUN([AM_ICONV_LINK], iconv_t cd_ascii_to_88591 = iconv_open ("ISO8859-1", "646"); if (cd_ascii_to_88591 != (iconv_t)(-1)) { - static ICONV_CONST char input[] = "\263"; + static const char input[] = "\263"; char buf[10]; - ICONV_CONST char *inptr = input; + const char *inptr = input; size_t inbytesleft = strlen (input); char *outptr = buf; size_t outbytesleft = sizeof (buf); size_t res = iconv (cd_ascii_to_88591, - &inptr, &inbytesleft, + (char **) &inptr, &inbytesleft, &outptr, &outbytesleft); if (res == 0) result |= 2; @@ -130,14 +124,14 @@ AC_DEFUN([AM_ICONV_LINK], iconv_t cd_88591_to_utf8 = iconv_open ("UTF-8", "ISO-8859-1"); if (cd_88591_to_utf8 != (iconv_t)(-1)) { - static ICONV_CONST char input[] = "\304"; + static const char input[] = "\304"; static char buf[2] = { (char)0xDE, (char)0xAD }; - ICONV_CONST char *inptr = input; + const char *inptr = input; size_t inbytesleft = 1; char *outptr = buf; size_t outbytesleft = 1; size_t res = iconv (cd_88591_to_utf8, - &inptr, &inbytesleft, + (char **) &inptr, &inbytesleft, &outptr, &outbytesleft); if (res != (size_t)(-1) || outptr - buf > 1 || buf[1] != (char)0xAD) result |= 4; @@ -150,14 +144,14 @@ AC_DEFUN([AM_ICONV_LINK], iconv_t cd_88591_to_utf8 = iconv_open ("utf8", "iso88591"); if (cd_88591_to_utf8 != (iconv_t)(-1)) { - static ICONV_CONST char input[] = "\304rger mit b\366sen B\374bchen ohne Augenma\337"; + static const char input[] = "\304rger mit b\366sen B\374bchen ohne Augenma\337"; char buf[50]; - ICONV_CONST char *inptr = input; + const char *inptr = input; size_t inbytesleft = strlen (input); char *outptr = buf; size_t outbytesleft = sizeof (buf); size_t res = iconv (cd_88591_to_utf8, - &inptr, &inbytesleft, + (char **) &inptr, &inbytesleft, &outptr, &outbytesleft); if ((int)res > 0) result |= 8; @@ -177,14 +171,17 @@ AC_DEFUN([AM_ICONV_LINK], && iconv_open ("utf8", "eucJP") == (iconv_t)(-1)) result |= 16; return result; -]])], - [am_cv_func_iconv_works=yes], , - [case "$host_os" in - aix* | hpux*) am_cv_func_iconv_works="guessing no" ;; - *) am_cv_func_iconv_works="guessing yes" ;; - esac]) - test "$am_cv_func_iconv_works" = no || break - done +}]])], + [am_cv_func_iconv_works=yes], + [am_cv_func_iconv_works=no], + [ +changequote(,)dnl + case "$host_os" in + aix* | hpux*) am_cv_func_iconv_works="guessing no" ;; + *) am_cv_func_iconv_works="guessing yes" ;; + esac +changequote([,])dnl + ]) LIBS="$am_save_LIBS" ]) case "$am_cv_func_iconv_works" in diff --git a/m4/iconv_h.m4 b/m4/iconv_h.m4 index c6878faa0..e992fa399 100644 --- a/m4/iconv_h.m4 +++ b/m4/iconv_h.m4 @@ -1,5 +1,5 @@ # iconv_h.m4 serial 8 -dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/iconv_open-utf.m4 b/m4/iconv_open-utf.m4 index bd81e66d8..31ced265a 100644 --- a/m4/iconv_open-utf.m4 +++ b/m4/iconv_open-utf.m4 @@ -1,5 +1,5 @@ # iconv_open-utf.m4 serial 1 -dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/iconv_open.m4 b/m4/iconv_open.m4 index 177fccba1..e0bfd7203 100644 --- a/m4/iconv_open.m4 +++ b/m4/iconv_open.m4 @@ -1,5 +1,5 @@ # iconv_open.m4 serial 14 -dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/include_next.m4 b/m4/include_next.m4 index 233d254e8..69ad3dbb0 100644 --- a/m4/include_next.m4 +++ b/m4/include_next.m4 @@ -1,5 +1,5 @@ # include_next.m4 serial 23 -dnl Copyright (C) 2006-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/inet_ntop.m4 b/m4/inet_ntop.m4 index df2bc746d..5b27759c5 100644 --- a/m4/inet_ntop.m4 +++ b/m4/inet_ntop.m4 @@ -1,5 +1,5 @@ # inet_ntop.m4 serial 19 -dnl Copyright (C) 2005-2006, 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2005-2006, 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/inet_pton.m4 b/m4/inet_pton.m4 index 433faee0c..136ed24d0 100644 --- a/m4/inet_pton.m4 +++ b/m4/inet_pton.m4 @@ -1,5 +1,5 @@ # inet_pton.m4 serial 17 -dnl Copyright (C) 2006, 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/inline.m4 b/m4/inline.m4 index dc7063e7e..c49957f80 100644 --- a/m4/inline.m4 +++ b/m4/inline.m4 @@ -1,5 +1,5 @@ # inline.m4 serial 4 -dnl Copyright (C) 2006, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/intmax_t.m4 b/m4/intmax_t.m4 index 4bd8155c8..af5561e5d 100644 --- a/m4/intmax_t.m4 +++ b/m4/intmax_t.m4 @@ -1,5 +1,5 @@ # intmax_t.m4 serial 8 -dnl Copyright (C) 1997-2004, 2006-2007, 2009-2015 Free Software Foundation, +dnl Copyright (C) 1997-2004, 2006-2007, 2009-2014 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/inttypes_h.m4 b/m4/inttypes_h.m4 index d0b5f5d98..87be9cfb5 100644 --- a/m4/inttypes_h.m4 +++ b/m4/inttypes_h.m4 @@ -1,5 +1,5 @@ # inttypes_h.m4 serial 10 -dnl Copyright (C) 1997-2004, 2006, 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 1997-2004, 2006, 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/isfinite.m4 b/m4/isfinite.m4 index 00d7e8042..53ad9092a 100644 --- a/m4/isfinite.m4 +++ b/m4/isfinite.m4 @@ -1,5 +1,5 @@ -# isfinite.m4 serial 15 -dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. +# isfinite.m4 serial 13 +dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -34,8 +34,13 @@ AC_DEFUN([gl_ISFINITE], AC_SUBST([ISFINITE_LIBM]) ]) -dnl Test whether isfinite() on 'long double' recognizes all canonical values -dnl which are neither finite nor infinite. +dnl Test whether isfinite() on 'long double' recognizes all numbers which are +dnl neither finite nor infinite. This test fails e.g. on i686, x86_64, ia64, +dnl because of +dnl - pseudo-denormals on x86_64, +dnl - pseudo-zeroes, unnormalized numbers, and pseudo-denormals on i686, +dnl - pseudo-NaN, pseudo-Infinity, pseudo-zeroes, unnormalized numbers, and +dnl pseudo-denormals on ia64. AC_DEFUN([gl_ISFINITEL_WORKS], [ AC_REQUIRE([AC_PROG_CC]) @@ -89,7 +94,7 @@ int main () # ifdef WORDS_BIGENDIAN # define LDBL80_WORDS(exponent,manthi,mantlo) \ { ((unsigned int) (exponent) << 16) | ((unsigned int) (manthi) >> 16), \ - ((unsigned int) (manthi) << 16) | ((unsigned int) (mantlo) >> 16), \ + ((unsigned int) (manthi) << 16) | (unsigned int) (mantlo) >> 16), \ (unsigned int) (mantlo) << 16 \ } # else @@ -109,41 +114,52 @@ int main () if (isfinite (x.value)) result |= 2; } - /* isfinite should return something even for noncanonical values. */ + /* The isfinite macro should recognize Pseudo-NaNs, Pseudo-Infinities, + Pseudo-Zeroes, Unnormalized Numbers, and Pseudo-Denormals, as defined in + Intel IA-64 Architecture Software Developer's Manual, Volume 1: + Application Architecture. + Table 5-2 "Floating-Point Register Encodings" + Figure 5-6 "Memory to Floating-Point Register Data Translation" + */ { /* Pseudo-NaN. */ static memory_long_double x = { LDBL80_WORDS (0xFFFF, 0x40000001, 0x00000000) }; - if (isfinite (x.value) && !isfinite (x.value)) + if (isfinite (x.value)) result |= 4; } { /* Pseudo-Infinity. */ static memory_long_double x = { LDBL80_WORDS (0xFFFF, 0x00000000, 0x00000000) }; - if (isfinite (x.value) && !isfinite (x.value)) + if (isfinite (x.value)) result |= 8; } { /* Pseudo-Zero. */ static memory_long_double x = { LDBL80_WORDS (0x4004, 0x00000000, 0x00000000) }; - if (isfinite (x.value) && !isfinite (x.value)) + if (isfinite (x.value)) result |= 16; } { /* Unnormalized number. */ static memory_long_double x = { LDBL80_WORDS (0x4000, 0x63333333, 0x00000000) }; - if (isfinite (x.value) && !isfinite (x.value)) + if (isfinite (x.value)) result |= 32; } { /* Pseudo-Denormal. */ static memory_long_double x = { LDBL80_WORDS (0x0000, 0x83333333, 0x00000000) }; - if (isfinite (x.value) && !isfinite (x.value)) + if (isfinite (x.value)) result |= 64; } #endif return result; }]])], [gl_cv_func_isfinitel_works=yes], [gl_cv_func_isfinitel_works=no], - [gl_cv_func_isfinitel_works="guessing yes"]) + [case "$host_cpu" in + # Guess no on ia64, x86_64, i386. + ia64 | x86_64 | i*86) gl_cv_func_isfinitel_works="guessing no";; + *) gl_cv_func_isfinitel_works="guessing yes";; + esac + ]) ]) ]) diff --git a/m4/isinf.m4 b/m4/isinf.m4 index b0a3da330..7174acecd 100644 --- a/m4/isinf.m4 +++ b/m4/isinf.m4 @@ -1,5 +1,5 @@ -# isinf.m4 serial 11 -dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. +# isinf.m4 serial 9 +dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -37,8 +37,13 @@ AC_DEFUN([gl_ISINF], dnl Test whether isinf() works: dnl 1) Whether it correctly returns false for LDBL_MAX. -dnl 2) Whether on 'long double' recognizes all canonical values which are -dnl infinite. +dnl 2) Whether on 'long double' recognizes all numbers which are neither +dnl finite nor infinite. This test fails on OpenBSD/x86, but could also +dnl fail e.g. on i686, x86_64, ia64, because of +dnl - pseudo-denormals on x86_64, +dnl - pseudo-zeroes, unnormalized numbers, and pseudo-denormals on i686, +dnl - pseudo-NaN, pseudo-Infinity, pseudo-zeroes, unnormalized numbers, and +dnl pseudo-denormals on ia64. AC_DEFUN([gl_ISINFL_WORKS], [ AC_REQUIRE([AC_PROG_CC]) @@ -96,7 +101,7 @@ int main () # ifdef WORDS_BIGENDIAN # define LDBL80_WORDS(exponent,manthi,mantlo) \ { ((unsigned int) (exponent) << 16) | ((unsigned int) (manthi) >> 16), \ - ((unsigned int) (manthi) << 16) | ((unsigned int) (mantlo) >> 16), \ + ((unsigned int) (manthi) << 16) | (unsigned int) (mantlo) >> 16), \ (unsigned int) (mantlo) << 16 \ } # else @@ -116,41 +121,55 @@ int main () if (isinf (x.value)) result |= 2; } - /* isinf should return something even for noncanonical values. */ + /* The isinf macro should recognize Pseudo-NaNs, Pseudo-Infinities, + Pseudo-Zeroes, Unnormalized Numbers, and Pseudo-Denormals, as defined in + Intel IA-64 Architecture Software Developer's Manual, Volume 1: + Application Architecture. + Table 5-2 "Floating-Point Register Encodings" + Figure 5-6 "Memory to Floating-Point Register Data Translation" + */ { /* Pseudo-NaN. */ static memory_long_double x = { LDBL80_WORDS (0xFFFF, 0x40000001, 0x00000000) }; - if (isinf (x.value) && !isinf (x.value)) + if (isinf (x.value)) result |= 4; } { /* Pseudo-Infinity. */ static memory_long_double x = { LDBL80_WORDS (0xFFFF, 0x00000000, 0x00000000) }; - if (isinf (x.value) && !isinf (x.value)) + if (isinf (x.value)) result |= 8; } { /* Pseudo-Zero. */ static memory_long_double x = { LDBL80_WORDS (0x4004, 0x00000000, 0x00000000) }; - if (isinf (x.value) && !isinf (x.value)) + if (isinf (x.value)) result |= 16; } { /* Unnormalized number. */ static memory_long_double x = { LDBL80_WORDS (0x4000, 0x63333333, 0x00000000) }; - if (isinf (x.value) && !isinf (x.value)) + if (isinf (x.value)) result |= 32; } { /* Pseudo-Denormal. */ static memory_long_double x = { LDBL80_WORDS (0x0000, 0x83333333, 0x00000000) }; - if (isinf (x.value) && !isinf (x.value)) + if (isinf (x.value)) result |= 64; } #endif return result; }]])], [gl_cv_func_isinfl_works=yes], [gl_cv_func_isinfl_works=no], - [gl_cv_func_isinfl_works="guessing yes"]) + [ + case "$host" in + # Guess no on OpenBSD ia64, x86_64, i386. + ia64-*-openbsd* | x86_64-*-openbsd* | i*86-*-openbsd*) + gl_cv_func_isinfl_works="guessing no";; + *) + gl_cv_func_isinfl_works="guessing yes";; + esac + ]) ]) ]) diff --git a/m4/isnan.m4 b/m4/isnan.m4 index 618e56e67..579340312 100644 --- a/m4/isnan.m4 +++ b/m4/isnan.m4 @@ -1,5 +1,5 @@ # isnan.m4 serial 5 -dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/isnand.m4 b/m4/isnand.m4 index 4d5c615bc..36e4ea307 100644 --- a/m4/isnand.m4 +++ b/m4/isnand.m4 @@ -1,5 +1,5 @@ # isnand.m4 serial 11 -dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/isnanf.m4 b/m4/isnanf.m4 index 09c3e5edd..1f2717d5e 100644 --- a/m4/isnanf.m4 +++ b/m4/isnanf.m4 @@ -1,5 +1,5 @@ # isnanf.m4 serial 14 -dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/isnanl.m4 b/m4/isnanl.m4 index b86ca9efe..98b2b69fc 100644 --- a/m4/isnanl.m4 +++ b/m4/isnanl.m4 @@ -1,5 +1,5 @@ -# isnanl.m4 serial 19 -dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. +# isnanl.m4 serial 17 +dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -108,8 +108,11 @@ AC_DEFUN([gl_HAVE_ISNANL_IN_LIBM], ]) ]) -dnl Test whether isnanl() recognizes all canonical numbers which are neither -dnl finite nor infinite. +dnl Test whether isnanl() recognizes all numbers which are neither finite nor +dnl infinite. This test fails e.g. on NetBSD/i386 and on glibc/ia64. +dnl Also, the GCC >= 4.0 built-in __builtin_isnanl does not pass the tests +dnl - for pseudo-denormals on i686 and x86_64, +dnl - for pseudo-zeroes, unnormalized numbers, and pseudo-denormals on ia64. AC_DEFUN([gl_FUNC_ISNANL_WORKS], [ AC_REQUIRE([AC_PROG_CC]) @@ -174,7 +177,7 @@ int main () # ifdef WORDS_BIGENDIAN # define LDBL80_WORDS(exponent,manthi,mantlo) \ { ((unsigned int) (exponent) << 16) | ((unsigned int) (manthi) >> 16), \ - ((unsigned int) (manthi) << 16) | ((unsigned int) (mantlo) >> 16), \ + ((unsigned int) (manthi) << 16) | (unsigned int) (mantlo) >> 16), \ (unsigned int) (mantlo) << 16 \ } # else @@ -194,35 +197,41 @@ int main () if (!isnanl (x.value)) result |= 2; } - /* isnanl should return something even for noncanonical values. */ + /* The isnanl function should recognize Pseudo-NaNs, Pseudo-Infinities, + Pseudo-Zeroes, Unnormalized Numbers, and Pseudo-Denormals, as defined in + Intel IA-64 Architecture Software Developer's Manual, Volume 1: + Application Architecture. + Table 5-2 "Floating-Point Register Encodings" + Figure 5-6 "Memory to Floating-Point Register Data Translation" + */ { /* Pseudo-NaN. */ static memory_long_double x = { LDBL80_WORDS (0xFFFF, 0x40000001, 0x00000000) }; - if (isnanl (x.value) && !isnanl (x.value)) + if (!isnanl (x.value)) result |= 4; } { /* Pseudo-Infinity. */ static memory_long_double x = { LDBL80_WORDS (0xFFFF, 0x00000000, 0x00000000) }; - if (isnanl (x.value) && !isnanl (x.value)) + if (!isnanl (x.value)) result |= 8; } { /* Pseudo-Zero. */ static memory_long_double x = { LDBL80_WORDS (0x4004, 0x00000000, 0x00000000) }; - if (isnanl (x.value) && !isnanl (x.value)) + if (!isnanl (x.value)) result |= 16; } { /* Unnormalized number. */ static memory_long_double x = { LDBL80_WORDS (0x4000, 0x63333333, 0x00000000) }; - if (isnanl (x.value) && !isnanl (x.value)) + if (!isnanl (x.value)) result |= 32; } { /* Pseudo-Denormal. */ static memory_long_double x = { LDBL80_WORDS (0x0000, 0x83333333, 0x00000000) }; - if (isnanl (x.value) && !isnanl (x.value)) + if (!isnanl (x.value)) result |= 64; } #endif @@ -231,6 +240,16 @@ int main () }]])], [gl_cv_func_isnanl_works=yes], [gl_cv_func_isnanl_works=no], - [gl_cv_func_isnanl_works="guessing yes"]) + [case "$host_cpu" in + # Guess no on ia64, x86_64, i386. + ia64 | x86_64 | i*86) gl_cv_func_isnanl_works="guessing no";; + *) + case "$host_os" in + netbsd*) gl_cv_func_isnanl_works="guessing no";; + *) gl_cv_func_isnanl_works="guessing yes";; + esac + ;; + esac + ]) ]) ]) diff --git a/m4/langinfo_h.m4 b/m4/langinfo_h.m4 index c3ecba66a..e8d78f9d0 100644 --- a/m4/langinfo_h.m4 +++ b/m4/langinfo_h.m4 @@ -1,5 +1,5 @@ # langinfo_h.m4 serial 7 -dnl Copyright (C) 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/largefile.m4 b/m4/largefile.m4 index b7a6c48b6..a1b564ad9 100644 --- a/m4/largefile.m4 +++ b/m4/largefile.m4 @@ -1,6 +1,6 @@ # Enable large files on systems where this is not the default. -# Copyright 1992-1996, 1998-2015 Free Software Foundation, Inc. +# Copyright 1992-1996, 1998-2014 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/ld-version-script.m4 b/m4/ld-version-script.m4 index 211d67b96..f8b4a5c51 100644 --- a/m4/ld-version-script.m4 +++ b/m4/ld-version-script.m4 @@ -1,5 +1,5 @@ -# ld-version-script.m4 serial 4 -dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. +# ld-version-script.m4 serial 3 +dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -18,18 +18,20 @@ dnl From Simon Josefsson AC_DEFUN([gl_LD_VERSION_SCRIPT], [ AC_ARG_ENABLE([ld-version-script], - [AS_HELP_STRING([--enable-ld-version-script], - [enable linker version script (default is enabled when possible)])], - [have_ld_version_script=$enableval], - [AC_CACHE_CHECK([if LD -Wl,--version-script works], - [gl_cv_sys_ld_version_script], - [gl_cv_sys_ld_version_script=no - save_LDFLAGS=$LDFLAGS - LDFLAGS="$LDFLAGS -Wl,--version-script=conftest.map" - echo foo >conftest.map - AC_LINK_IFELSE([AC_LANG_PROGRAM([], [])], - [], - [cat > conftest.map < conftest.map < conftest.map <conftest.file - AC_RUN_IFELSE( - [AC_LANG_PROGRAM( - [AC_INCLUDES_DEFAULT], - [[struct stat sbuf; - if (symlink ("conftest.file", "conftest.sym") != 0) - return 1; - /* Linux will dereference the symlink and fail, as required by - POSIX. That is better in the sense that it means we will not - have to compile and use the lstat wrapper. */ - return lstat ("conftest.sym/", &sbuf) == 0; - ]])], - [gl_cv_func_lstat_dereferences_slashed_symlink=yes], - [gl_cv_func_lstat_dereferences_slashed_symlink=no], - [case "$host_os" in - *-gnu*) - # Guess yes on glibc systems. - gl_cv_func_lstat_dereferences_slashed_symlink="guessing yes" ;; - *) - # If we don't know, assume the worst. - gl_cv_func_lstat_dereferences_slashed_symlink="guessing no" ;; - esac - ]) + if test "$as_ln_s" = "ln -s" && ln -s conftest.file conftest.sym; then + AC_RUN_IFELSE( + [AC_LANG_PROGRAM( + [AC_INCLUDES_DEFAULT], + [[struct stat sbuf; + /* Linux will dereference the symlink and fail, as required by + POSIX. That is better in the sense that it means we will not + have to compile and use the lstat wrapper. */ + return lstat ("conftest.sym/", &sbuf) == 0; + ]])], + [gl_cv_func_lstat_dereferences_slashed_symlink=yes], + [gl_cv_func_lstat_dereferences_slashed_symlink=no], + [case "$host_os" in + # Guess yes on glibc systems. + *-gnu*) gl_cv_func_lstat_dereferences_slashed_symlink="guessing yes" ;; + # If we don't know, assume the worst. + *) gl_cv_func_lstat_dereferences_slashed_symlink="guessing no" ;; + esac + ]) + else + # If the 'ln -s' command failed, then we probably don't even + # have an lstat function. + gl_cv_func_lstat_dereferences_slashed_symlink="guessing no" + fi rm -f conftest.sym conftest.file ]) case "$gl_cv_func_lstat_dereferences_slashed_symlink" in diff --git a/m4/malloc.m4 b/m4/malloc.m4 index 31368ab97..322ad6eff 100644 --- a/m4/malloc.m4 +++ b/m4/malloc.m4 @@ -1,5 +1,5 @@ # malloc.m4 serial 14 -dnl Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/malloca.m4 b/m4/malloca.m4 index 724895174..dcc1a0843 100644 --- a/m4/malloca.m4 +++ b/m4/malloca.m4 @@ -1,5 +1,5 @@ # malloca.m4 serial 1 -dnl Copyright (C) 2003-2004, 2006-2007, 2009-2015 Free Software Foundation, +dnl Copyright (C) 2003-2004, 2006-2007, 2009-2014 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/math_h.m4 b/m4/math_h.m4 index 7d0f58346..9e2adfbac 100644 --- a/m4/math_h.m4 +++ b/m4/math_h.m4 @@ -1,5 +1,5 @@ # math_h.m4 serial 114 -dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mathfunc.m4 b/m4/mathfunc.m4 index 743bafbca..6f0e6aacd 100644 --- a/m4/mathfunc.m4 +++ b/m4/mathfunc.m4 @@ -1,5 +1,5 @@ # mathfunc.m4 serial 11 -dnl Copyright (C) 2010-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mbrtowc.m4 b/m4/mbrtowc.m4 index 640579e61..a9d157092 100644 --- a/m4/mbrtowc.m4 +++ b/m4/mbrtowc.m4 @@ -1,5 +1,5 @@ -# mbrtowc.m4 serial 26 -*- coding: utf-8 -*- -dnl Copyright (C) 2001-2002, 2004-2005, 2008-2015 Free Software Foundation, +# mbrtowc.m4 serial 25 +dnl Copyright (C) 2001-2002, 2004-2005, 2008-2014 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -39,7 +39,6 @@ AC_DEFUN([gl_FUNC_MBRTOWC], gl_MBRTOWC_NULL_ARG2 gl_MBRTOWC_RETVAL gl_MBRTOWC_NUL_RETVAL - gl_MBRTOWC_EMPTY_INPUT case "$gl_cv_func_mbrtowc_null_arg1" in *yes) ;; *) AC_DEFINE([MBRTOWC_NULL_ARG1_BUG], [1], @@ -68,14 +67,6 @@ AC_DEFUN([gl_FUNC_MBRTOWC], REPLACE_MBRTOWC=1 ;; esac - case "$gl_cv_func_mbrtowc_empty_input" in - *yes) ;; - *) AC_DEFINE([MBRTOWC_EMPTY_INPUT_BUG], [1], - [Define if the mbrtowc function does not return (size_t) -2 - for empty input.]) - REPLACE_MBRTOWC=1 - ;; - esac fi fi ]) @@ -542,41 +533,6 @@ int main () ]) ]) -dnl Test whether mbrtowc returns the correct value on empty input. - -AC_DEFUN([gl_MBRTOWC_EMPTY_INPUT], -[ - AC_REQUIRE([AC_PROG_CC]) - AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles - AC_CACHE_CHECK([whether mbrtowc works on empty input], - [gl_cv_func_mbrtowc_empty_input], - [ - dnl Initial guess, used when cross-compiling or when no suitable locale - dnl is present. -changequote(,)dnl - case "$host_os" in - # Guess no on AIX and glibc systems. - aix* | *-gnu*) - gl_cv_func_mbrtowc_empty_input="guessing no" ;; - *) gl_cv_func_mbrtowc_empty_input="guessing yes" ;; - esac -changequote([,])dnl - AC_RUN_IFELSE( - [AC_LANG_SOURCE([[ - #include - static wchar_t wc; - static mbstate_t mbs; - int - main (void) - { - return mbrtowc (&wc, "", 0, &mbs) == (size_t) -2; - }]])], - [gl_cv_func_mbrtowc_empty_input=no], - [gl_cv_func_mbrtowc_empty_input=yes], - [:]) - ]) -]) - # Prerequisites of lib/mbrtowc.c. AC_DEFUN([gl_PREREQ_MBRTOWC], [ : diff --git a/m4/mbsinit.m4 b/m4/mbsinit.m4 index 61c403290..e1598a1d7 100644 --- a/m4/mbsinit.m4 +++ b/m4/mbsinit.m4 @@ -1,5 +1,5 @@ # mbsinit.m4 serial 8 -dnl Copyright (C) 2008, 2010-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2008, 2010-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mbstate_t.m4 b/m4/mbstate_t.m4 index 42ad6cd63..068155a52 100644 --- a/m4/mbstate_t.m4 +++ b/m4/mbstate_t.m4 @@ -1,5 +1,5 @@ # mbstate_t.m4 serial 13 -dnl Copyright (C) 2000-2002, 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2000-2002, 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mbtowc.m4 b/m4/mbtowc.m4 index 88cdeeeff..cacfe1610 100644 --- a/m4/mbtowc.m4 +++ b/m4/mbtowc.m4 @@ -1,5 +1,5 @@ # mbtowc.m4 serial 2 -dnl Copyright (C) 2011-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/memchr.m4 b/m4/memchr.m4 index cb958d862..b9f126cfa 100644 --- a/m4/memchr.m4 +++ b/m4/memchr.m4 @@ -1,5 +1,5 @@ # memchr.m4 serial 12 -dnl Copyright (C) 2002-2004, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2004, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mkdir.m4 b/m4/mkdir.m4 index 3d9868df1..51e78c13d 100644 --- a/m4/mkdir.m4 +++ b/m4/mkdir.m4 @@ -1,6 +1,6 @@ # serial 11 -# Copyright (C) 2001, 2003-2004, 2006, 2008-2015 Free Software Foundation, Inc. +# Copyright (C) 2001, 2003-2004, 2006, 2008-2014 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/mkstemp.m4 b/m4/mkstemp.m4 index f5df0d0b0..9033a4e60 100644 --- a/m4/mkstemp.m4 +++ b/m4/mkstemp.m4 @@ -1,6 +1,6 @@ #serial 23 -# Copyright (C) 2001, 2003-2007, 2009-2015 Free Software Foundation, Inc. +# Copyright (C) 2001, 2003-2007, 2009-2014 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/mktime.m4 b/m4/mktime.m4 deleted file mode 100644 index 3f0e1eee4..000000000 --- a/m4/mktime.m4 +++ /dev/null @@ -1,253 +0,0 @@ -# serial 25 -dnl Copyright (C) 2002-2003, 2005-2007, 2009-2015 Free Software Foundation, -dnl Inc. -dnl This file is free software; the Free Software Foundation -dnl gives unlimited permission to copy and/or distribute it, -dnl with or without modifications, as long as this notice is preserved. - -dnl From Jim Meyering. - -AC_DEFUN([gl_FUNC_MKTIME], -[ - AC_REQUIRE([gl_HEADER_TIME_H_DEFAULTS]) - - dnl We don't use AC_FUNC_MKTIME any more, because it is no longer maintained - dnl in Autoconf and because it invokes AC_LIBOBJ. - AC_CHECK_HEADERS_ONCE([unistd.h]) - AC_CHECK_DECLS_ONCE([alarm]) - AC_REQUIRE([gl_MULTIARCH]) - if test $APPLE_UNIVERSAL_BUILD = 1; then - # A universal build on Apple Mac OS X platforms. - # The test result would be 'yes' in 32-bit mode and 'no' in 64-bit mode. - # But we need a configuration result that is valid in both modes. - gl_cv_func_working_mktime=no - fi - AC_CACHE_CHECK([for working mktime], [gl_cv_func_working_mktime], - [AC_RUN_IFELSE( - [AC_LANG_SOURCE( -[[/* Test program from Paul Eggert and Tony Leneis. */ -#include -#include -#include - -#ifdef HAVE_UNISTD_H -# include -#endif - -#if HAVE_DECL_ALARM -# include -#endif - -/* Work around redefinition to rpl_putenv by other config tests. */ -#undef putenv - -static time_t time_t_max; -static time_t time_t_min; - -/* Values we'll use to set the TZ environment variable. */ -static char *tz_strings[] = { - (char *) 0, "TZ=GMT0", "TZ=JST-9", - "TZ=EST+3EDT+2,M10.1.0/00:00:00,M2.3.0/00:00:00" -}; -#define N_STRINGS (sizeof (tz_strings) / sizeof (tz_strings[0])) - -/* Return 0 if mktime fails to convert a date in the spring-forward gap. - Based on a problem report from Andreas Jaeger. */ -static int -spring_forward_gap () -{ - /* glibc (up to about 1998-10-07) failed this test. */ - struct tm tm; - - /* Use the portable POSIX.1 specification "TZ=PST8PDT,M4.1.0,M10.5.0" - instead of "TZ=America/Vancouver" in order to detect the bug even - on systems that don't support the Olson extension, or don't have the - full zoneinfo tables installed. */ - putenv ("TZ=PST8PDT,M4.1.0,M10.5.0"); - - tm.tm_year = 98; - tm.tm_mon = 3; - tm.tm_mday = 5; - tm.tm_hour = 2; - tm.tm_min = 0; - tm.tm_sec = 0; - tm.tm_isdst = -1; - return mktime (&tm) != (time_t) -1; -} - -static int -mktime_test1 (time_t now) -{ - struct tm *lt; - return ! (lt = localtime (&now)) || mktime (lt) == now; -} - -static int -mktime_test (time_t now) -{ - return (mktime_test1 (now) - && mktime_test1 ((time_t) (time_t_max - now)) - && mktime_test1 ((time_t) (time_t_min + now))); -} - -static int -irix_6_4_bug () -{ - /* Based on code from Ariel Faigon. */ - struct tm tm; - tm.tm_year = 96; - tm.tm_mon = 3; - tm.tm_mday = 0; - tm.tm_hour = 0; - tm.tm_min = 0; - tm.tm_sec = 0; - tm.tm_isdst = -1; - mktime (&tm); - return tm.tm_mon == 2 && tm.tm_mday == 31; -} - -static int -bigtime_test (int j) -{ - struct tm tm; - time_t now; - tm.tm_year = tm.tm_mon = tm.tm_mday = tm.tm_hour = tm.tm_min = tm.tm_sec = j; - now = mktime (&tm); - if (now != (time_t) -1) - { - struct tm *lt = localtime (&now); - if (! (lt - && lt->tm_year == tm.tm_year - && lt->tm_mon == tm.tm_mon - && lt->tm_mday == tm.tm_mday - && lt->tm_hour == tm.tm_hour - && lt->tm_min == tm.tm_min - && lt->tm_sec == tm.tm_sec - && lt->tm_yday == tm.tm_yday - && lt->tm_wday == tm.tm_wday - && ((lt->tm_isdst < 0 ? -1 : 0 < lt->tm_isdst) - == (tm.tm_isdst < 0 ? -1 : 0 < tm.tm_isdst)))) - return 0; - } - return 1; -} - -static int -year_2050_test () -{ - /* The correct answer for 2050-02-01 00:00:00 in Pacific time, - ignoring leap seconds. */ - unsigned long int answer = 2527315200UL; - - struct tm tm; - time_t t; - tm.tm_year = 2050 - 1900; - tm.tm_mon = 2 - 1; - tm.tm_mday = 1; - tm.tm_hour = tm.tm_min = tm.tm_sec = 0; - tm.tm_isdst = -1; - - /* Use the portable POSIX.1 specification "TZ=PST8PDT,M4.1.0,M10.5.0" - instead of "TZ=America/Vancouver" in order to detect the bug even - on systems that don't support the Olson extension, or don't have the - full zoneinfo tables installed. */ - putenv ("TZ=PST8PDT,M4.1.0,M10.5.0"); - - t = mktime (&tm); - - /* Check that the result is either a failure, or close enough - to the correct answer that we can assume the discrepancy is - due to leap seconds. */ - return (t == (time_t) -1 - || (0 < t && answer - 120 <= t && t <= answer + 120)); -} - -int -main () -{ - int result = 0; - time_t t, delta; - int i, j; - int time_t_signed_magnitude = (time_t) ~ (time_t) 0 < (time_t) -1; - int time_t_signed = ! ((time_t) 0 < (time_t) -1); - -#if HAVE_DECL_ALARM - /* This test makes some buggy mktime implementations loop. - Give up after 60 seconds; a mktime slower than that - isn't worth using anyway. */ - signal (SIGALRM, SIG_DFL); - alarm (60); -#endif - - time_t_max = (! time_t_signed - ? (time_t) -1 - : ((((time_t) 1 << (sizeof (time_t) * CHAR_BIT - 2)) - 1) - * 2 + 1)); - time_t_min = (! time_t_signed - ? (time_t) 0 - : time_t_signed_magnitude - ? ~ (time_t) 0 - : ~ time_t_max); - - delta = time_t_max / 997; /* a suitable prime number */ - for (i = 0; i < N_STRINGS; i++) - { - if (tz_strings[i]) - putenv (tz_strings[i]); - - for (t = 0; t <= time_t_max - delta && (result & 1) == 0; t += delta) - if (! mktime_test (t)) - result |= 1; - if ((result & 2) == 0 - && ! (mktime_test ((time_t) 1) - && mktime_test ((time_t) (60 * 60)) - && mktime_test ((time_t) (60 * 60 * 24)))) - result |= 2; - - for (j = 1; (result & 4) == 0; j <<= 1) - { - if (! bigtime_test (j)) - result |= 4; - if (INT_MAX / 2 < j) - break; - } - if ((result & 8) == 0 && ! bigtime_test (INT_MAX)) - result |= 8; - } - if (! irix_6_4_bug ()) - result |= 16; - if (! spring_forward_gap ()) - result |= 32; - if (! year_2050_test ()) - result |= 64; - return result; -}]])], - [gl_cv_func_working_mktime=yes], - [gl_cv_func_working_mktime=no], - [gl_cv_func_working_mktime=no]) - ]) - - if test $gl_cv_func_working_mktime = no; then - REPLACE_MKTIME=1 - else - REPLACE_MKTIME=0 - fi -]) - -AC_DEFUN([gl_FUNC_MKTIME_INTERNAL], [ - AC_REQUIRE([gl_FUNC_MKTIME]) - if test $REPLACE_MKTIME = 0; then - dnl BeOS has __mktime_internal in libc, but other platforms don't. - AC_CHECK_FUNC([__mktime_internal], - [AC_DEFINE([mktime_internal], [__mktime_internal], - [Define to the real name of the mktime_internal function.]) - ], - [dnl mktime works but it doesn't export __mktime_internal, - dnl so we need to substitute our own mktime implementation. - REPLACE_MKTIME=1 - ]) - fi -]) - -# Prerequisites of lib/mktime.c. -AC_DEFUN([gl_PREREQ_MKTIME], [:]) diff --git a/m4/mmap-anon.m4 b/m4/mmap-anon.m4 index 92a88d05f..94ae2e2f2 100644 --- a/m4/mmap-anon.m4 +++ b/m4/mmap-anon.m4 @@ -1,5 +1,5 @@ # mmap-anon.m4 serial 10 -dnl Copyright (C) 2005, 2007, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2005, 2007, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mode_t.m4 b/m4/mode_t.m4 index 01badba7a..db6e192be 100644 --- a/m4/mode_t.m4 +++ b/m4/mode_t.m4 @@ -1,5 +1,5 @@ # mode_t.m4 serial 2 -dnl Copyright (C) 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/msvc-inval.m4 b/m4/msvc-inval.m4 index 9446fa585..7f26087e7 100644 --- a/m4/msvc-inval.m4 +++ b/m4/msvc-inval.m4 @@ -1,5 +1,5 @@ # msvc-inval.m4 serial 1 -dnl Copyright (C) 2011-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/msvc-nothrow.m4 b/m4/msvc-nothrow.m4 index 5d72a042d..9e32c171e 100644 --- a/m4/msvc-nothrow.m4 +++ b/m4/msvc-nothrow.m4 @@ -1,5 +1,5 @@ # msvc-nothrow.m4 serial 1 -dnl Copyright (C) 2011-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/multiarch.m4 b/m4/multiarch.m4 index fc575c1d4..2cb956dee 100644 --- a/m4/multiarch.m4 +++ b/m4/multiarch.m4 @@ -1,5 +1,5 @@ # multiarch.m4 serial 7 -dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/netdb_h.m4 b/m4/netdb_h.m4 index fce208014..cd7d48291 100644 --- a/m4/netdb_h.m4 +++ b/m4/netdb_h.m4 @@ -1,5 +1,5 @@ # netdb_h.m4 serial 11 -dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/netinet_in_h.m4 b/m4/netinet_in_h.m4 index 42ac00844..1d447d6f1 100644 --- a/m4/netinet_in_h.m4 +++ b/m4/netinet_in_h.m4 @@ -1,5 +1,5 @@ # netinet_in_h.m4 serial 5 -dnl Copyright (C) 2006-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/nl_langinfo.m4 b/m4/nl_langinfo.m4 index c8bf20fb3..6976e7767 100644 --- a/m4/nl_langinfo.m4 +++ b/m4/nl_langinfo.m4 @@ -1,5 +1,5 @@ # nl_langinfo.m4 serial 5 -dnl Copyright (C) 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/nocrash.m4 b/m4/nocrash.m4 index 56283180f..5a5d77d63 100644 --- a/m4/nocrash.m4 +++ b/m4/nocrash.m4 @@ -1,5 +1,5 @@ # nocrash.m4 serial 4 -dnl Copyright (C) 2005, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2005, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/nproc.m4 b/m4/nproc.m4 index 988404b1c..937c4a920 100644 --- a/m4/nproc.m4 +++ b/m4/nproc.m4 @@ -1,5 +1,5 @@ # nproc.m4 serial 4 -dnl Copyright (C) 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/off_t.m4 b/m4/off_t.m4 index 0eb14678b..f5885b34b 100644 --- a/m4/off_t.m4 +++ b/m4/off_t.m4 @@ -1,5 +1,5 @@ # off_t.m4 serial 1 -dnl Copyright (C) 2012-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2012-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/open.m4 b/m4/open.m4 index 2accbaa92..68f116f0a 100644 --- a/m4/open.m4 +++ b/m4/open.m4 @@ -1,5 +1,5 @@ # open.m4 serial 14 -dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/pathmax.m4 b/m4/pathmax.m4 index 0e3db7a23..114f91f04 100644 --- a/m4/pathmax.m4 +++ b/m4/pathmax.m4 @@ -1,5 +1,5 @@ # pathmax.m4 serial 10 -dnl Copyright (C) 2002-2003, 2005-2006, 2009-2015 Free Software Foundation, +dnl Copyright (C) 2002-2003, 2005-2006, 2009-2014 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/pipe.m4 b/m4/pipe.m4 index 730c53439..d3532d5dd 100644 --- a/m4/pipe.m4 +++ b/m4/pipe.m4 @@ -1,5 +1,5 @@ # pipe.m4 serial 2 -dnl Copyright (C) 2010-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/pipe2.m4 b/m4/pipe2.m4 index 0b64651a5..1cff1fef0 100644 --- a/m4/pipe2.m4 +++ b/m4/pipe2.m4 @@ -1,5 +1,5 @@ # pipe2.m4 serial 2 -dnl Copyright (C) 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/poll.m4 b/m4/poll.m4 index 403d7d1fc..f523b1873 100644 --- a/m4/poll.m4 +++ b/m4/poll.m4 @@ -1,5 +1,5 @@ # poll.m4 serial 17 -dnl Copyright (c) 2003, 2005-2007, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (c) 2003, 2005-2007, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/poll_h.m4 b/m4/poll_h.m4 index 662b60344..fcfe7fa4d 100644 --- a/m4/poll_h.m4 +++ b/m4/poll_h.m4 @@ -1,5 +1,5 @@ # poll_h.m4 serial 2 -dnl Copyright (C) 2010-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/printf.m4 b/m4/printf.m4 index d06746aae..9346ab041 100644 --- a/m4/printf.m4 +++ b/m4/printf.m4 @@ -1,5 +1,5 @@ -# printf.m4 serial 52 -dnl Copyright (C) 2003, 2007-2015 Free Software Foundation, Inc. +# printf.m4 serial 50 +dnl Copyright (C) 2003, 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -61,7 +61,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_printf_sizes_c99="guessing yes";; # Guess yes on FreeBSD >= 5. - freebsd[1-4].*) gl_cv_func_printf_sizes_c99="guessing no";; + freebsd[1-4]*) gl_cv_func_printf_sizes_c99="guessing no";; freebsd* | kfreebsd*) gl_cv_func_printf_sizes_c99="guessing yes";; # Guess yes on Mac OS X >= 10.3. darwin[1-6].*) gl_cv_func_printf_sizes_c99="guessing no";; @@ -220,7 +220,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_printf_infinite="guessing yes";; # Guess yes on FreeBSD >= 6. - freebsd[1-5].*) gl_cv_func_printf_infinite="guessing no";; + freebsd[1-5]*) gl_cv_func_printf_infinite="guessing no";; freebsd* | kfreebsd*) gl_cv_func_printf_infinite="guessing yes";; # Guess yes on Mac OS X >= 10.3. darwin[1-6].*) gl_cv_func_printf_infinite="guessing no";; @@ -328,7 +328,7 @@ int main () # ifdef WORDS_BIGENDIAN # define LDBL80_WORDS(exponent,manthi,mantlo) \ { ((unsigned int) (exponent) << 16) | ((unsigned int) (manthi) >> 16), \ - ((unsigned int) (manthi) << 16) | ((unsigned int) (mantlo) >> 16), \ + ((unsigned int) (manthi) << 16) | (unsigned int) (mantlo) >> 16), \ (unsigned int) (mantlo) << 16 \ } # else @@ -365,51 +365,66 @@ int main () { /* Pseudo-NaN. */ static union { unsigned int word[4]; long double value; } x = { LDBL80_WORDS (0xFFFF, 0x40000001, 0x00000000) }; - if (sprintf (buf, "%Lf", x.value) <= 0) + if (sprintf (buf, "%Lf", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) result |= 4; - if (sprintf (buf, "%Le", x.value) <= 0) + if (sprintf (buf, "%Le", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) result |= 4; - if (sprintf (buf, "%Lg", x.value) <= 0) + if (sprintf (buf, "%Lg", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) result |= 4; } { /* Pseudo-Infinity. */ static union { unsigned int word[4]; long double value; } x = { LDBL80_WORDS (0xFFFF, 0x00000000, 0x00000000) }; - if (sprintf (buf, "%Lf", x.value) <= 0) + if (sprintf (buf, "%Lf", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) result |= 8; - if (sprintf (buf, "%Le", x.value) <= 0) + if (sprintf (buf, "%Le", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) result |= 8; - if (sprintf (buf, "%Lg", x.value) <= 0) + if (sprintf (buf, "%Lg", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) result |= 8; } { /* Pseudo-Zero. */ static union { unsigned int word[4]; long double value; } x = { LDBL80_WORDS (0x4004, 0x00000000, 0x00000000) }; - if (sprintf (buf, "%Lf", x.value) <= 0) + if (sprintf (buf, "%Lf", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) result |= 16; - if (sprintf (buf, "%Le", x.value) <= 0) + if (sprintf (buf, "%Le", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) result |= 16; - if (sprintf (buf, "%Lg", x.value) <= 0) + if (sprintf (buf, "%Lg", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) result |= 16; } { /* Unnormalized number. */ static union { unsigned int word[4]; long double value; } x = { LDBL80_WORDS (0x4000, 0x63333333, 0x00000000) }; - if (sprintf (buf, "%Lf", x.value) <= 0) + if (sprintf (buf, "%Lf", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) result |= 32; - if (sprintf (buf, "%Le", x.value) <= 0) + if (sprintf (buf, "%Le", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) result |= 32; - if (sprintf (buf, "%Lg", x.value) <= 0) + if (sprintf (buf, "%Lg", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) result |= 32; } { /* Pseudo-Denormal. */ static union { unsigned int word[4]; long double value; } x = { LDBL80_WORDS (0x0000, 0x83333333, 0x00000000) }; - if (sprintf (buf, "%Lf", x.value) <= 0) + if (sprintf (buf, "%Lf", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) result |= 64; - if (sprintf (buf, "%Le", x.value) <= 0) + if (sprintf (buf, "%Le", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) result |= 64; - if (sprintf (buf, "%Lg", x.value) <= 0) + if (sprintf (buf, "%Lg", x.value) < 0 + || !strisnan (buf, 0, strlen (buf))) result |= 64; } #endif @@ -427,7 +442,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_printf_infinite_long_double="guessing yes";; # Guess yes on FreeBSD >= 6. - freebsd[1-5].*) gl_cv_func_printf_infinite_long_double="guessing no";; + freebsd[1-5]*) gl_cv_func_printf_infinite_long_double="guessing no";; freebsd* | kfreebsd*) gl_cv_func_printf_infinite_long_double="guessing yes";; # Guess yes on HP-UX >= 11. hpux[7-9]* | hpux10*) gl_cv_func_printf_infinite_long_double="guessing no";; @@ -573,7 +588,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_printf_directive_f="guessing yes";; # Guess yes on FreeBSD >= 6. - freebsd[1-5].*) gl_cv_func_printf_directive_f="guessing no";; + freebsd[1-5]*) gl_cv_func_printf_directive_f="guessing no";; freebsd* | kfreebsd*) gl_cv_func_printf_directive_f="guessing yes";; # Guess yes on Mac OS X >= 10.3. darwin[1-6].*) gl_cv_func_printf_directive_f="guessing no";; @@ -1121,7 +1136,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_snprintf_truncation_c99="guessing yes";; # Guess yes on FreeBSD >= 5. - freebsd[1-4].*) gl_cv_func_snprintf_truncation_c99="guessing no";; + freebsd[1-4]*) gl_cv_func_snprintf_truncation_c99="guessing no";; freebsd* | kfreebsd*) gl_cv_func_snprintf_truncation_c99="guessing yes";; # Guess yes on Mac OS X >= 10.3. darwin[1-6].*) gl_cv_func_snprintf_truncation_c99="guessing no";; @@ -1220,7 +1235,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_snprintf_retval_c99="guessing yes";; # Guess yes on FreeBSD >= 5. - freebsd[1-4].*) gl_cv_func_snprintf_retval_c99="guessing no";; + freebsd[1-4]*) gl_cv_func_snprintf_retval_c99="guessing no";; freebsd* | kfreebsd*) gl_cv_func_snprintf_retval_c99="guessing yes";; # Guess yes on Mac OS X >= 10.3. darwin[1-6].*) gl_cv_func_snprintf_retval_c99="guessing no";; @@ -1301,7 +1316,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_snprintf_directive_n="guessing yes";; # Guess yes on FreeBSD >= 5. - freebsd[1-4].*) gl_cv_func_snprintf_directive_n="guessing no";; + freebsd[1-4]*) gl_cv_func_snprintf_directive_n="guessing no";; freebsd* | kfreebsd*) gl_cv_func_snprintf_directive_n="guessing yes";; # Guess yes on Mac OS X >= 10.3. darwin[1-6].*) gl_cv_func_snprintf_directive_n="guessing no";; @@ -1443,7 +1458,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_vsnprintf_zerosize_c99="guessing yes";; # Guess yes on FreeBSD >= 5. - freebsd[1-4].*) gl_cv_func_vsnprintf_zerosize_c99="guessing no";; + freebsd[1-4]*) gl_cv_func_vsnprintf_zerosize_c99="guessing no";; freebsd* | kfreebsd*) gl_cv_func_vsnprintf_zerosize_c99="guessing yes";; # Guess yes on Mac OS X >= 10.3. darwin[1-6].*) gl_cv_func_vsnprintf_zerosize_c99="guessing no";; diff --git a/m4/putenv.m4 b/m4/putenv.m4 index 73a5f4691..d79321be9 100644 --- a/m4/putenv.m4 +++ b/m4/putenv.m4 @@ -1,5 +1,5 @@ # putenv.m4 serial 20 -dnl Copyright (C) 2002-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/raise.m4 b/m4/raise.m4 index ed6aae036..8656578ef 100644 --- a/m4/raise.m4 +++ b/m4/raise.m4 @@ -1,5 +1,5 @@ # raise.m4 serial 3 -dnl Copyright (C) 2011-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/read.m4 b/m4/read.m4 index 9fdd7df13..176b0b04d 100644 --- a/m4/read.m4 +++ b/m4/read.m4 @@ -1,5 +1,5 @@ # read.m4 serial 4 -dnl Copyright (C) 2011-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/readlink.m4 b/m4/readlink.m4 index 88c9bfef7..f9ce868c2 100644 --- a/m4/readlink.m4 +++ b/m4/readlink.m4 @@ -1,5 +1,5 @@ # readlink.m4 serial 12 -dnl Copyright (C) 2003, 2007, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2007, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/regex.m4 b/m4/regex.m4 index 0fa7455df..08bd46a96 100644 --- a/m4/regex.m4 +++ b/m4/regex.m4 @@ -1,6 +1,6 @@ # serial 65 -# Copyright (C) 1996-2001, 2003-2015 Free Software Foundation, Inc. +# Copyright (C) 1996-2001, 2003-2014 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, diff --git a/m4/rename.m4 b/m4/rename.m4 index b5e433457..ea5779491 100644 --- a/m4/rename.m4 +++ b/m4/rename.m4 @@ -1,6 +1,6 @@ # serial 26 -# Copyright (C) 2001, 2003, 2005-2006, 2009-2015 Free Software Foundation, Inc. +# Copyright (C) 2001, 2003, 2005-2006, 2009-2014 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/rmdir.m4 b/m4/rmdir.m4 index 09ed159e0..db6a9399c 100644 --- a/m4/rmdir.m4 +++ b/m4/rmdir.m4 @@ -1,5 +1,5 @@ # rmdir.m4 serial 13 -dnl Copyright (C) 2002, 2005, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2002, 2005, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/round.m4 b/m4/round.m4 index 7fa1eb3fc..13049b7cf 100644 --- a/m4/round.m4 +++ b/m4/round.m4 @@ -1,5 +1,5 @@ # round.m4 serial 16 -dnl Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/safe-read.m4 b/m4/safe-read.m4 index 697a07cf8..f0c42e08f 100644 --- a/m4/safe-read.m4 +++ b/m4/safe-read.m4 @@ -1,5 +1,5 @@ # safe-read.m4 serial 6 -dnl Copyright (C) 2002-2003, 2005-2006, 2009-2015 Free Software Foundation, +dnl Copyright (C) 2002-2003, 2005-2006, 2009-2014 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/safe-write.m4 b/m4/safe-write.m4 index 1cef87c5a..66648bbb5 100644 --- a/m4/safe-write.m4 +++ b/m4/safe-write.m4 @@ -1,5 +1,5 @@ # safe-write.m4 serial 4 -dnl Copyright (C) 2002, 2005-2006, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2002, 2005-2006, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/secure_getenv.m4 b/m4/secure_getenv.m4 index 6afe89fda..149888df4 100644 --- a/m4/secure_getenv.m4 +++ b/m4/secure_getenv.m4 @@ -1,5 +1,5 @@ # Look up an environment variable more securely. -dnl Copyright 2013-2015 Free Software Foundation, Inc. +dnl Copyright 2013-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/select.m4 b/m4/select.m4 index 2a2ee6f90..1d2fcb373 100644 --- a/m4/select.m4 +++ b/m4/select.m4 @@ -1,5 +1,5 @@ # select.m4 serial 7 -dnl Copyright (C) 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/servent.m4 b/m4/servent.m4 index e871d45ce..4dc7a9f70 100644 --- a/m4/servent.m4 +++ b/m4/servent.m4 @@ -1,5 +1,5 @@ # servent.m4 serial 2 -dnl Copyright (C) 2008, 2010-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2008, 2010-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/setenv.m4 b/m4/setenv.m4 index 3aa38d895..0f46a7bec 100644 --- a/m4/setenv.m4 +++ b/m4/setenv.m4 @@ -1,5 +1,5 @@ # setenv.m4 serial 26 -dnl Copyright (C) 2001-2004, 2006-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2004, 2006-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/signal_h.m4 b/m4/signal_h.m4 index f737c36ba..c8f664fbf 100644 --- a/m4/signal_h.m4 +++ b/m4/signal_h.m4 @@ -1,5 +1,5 @@ # signal_h.m4 serial 18 -dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/signbit.m4 b/m4/signbit.m4 index 21b9bf5e5..9ed48c780 100644 --- a/m4/signbit.m4 +++ b/m4/signbit.m4 @@ -1,5 +1,5 @@ # signbit.m4 serial 13 -dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/size_max.m4 b/m4/size_max.m4 index 186e3fdda..7e192d5e9 100644 --- a/m4/size_max.m4 +++ b/m4/size_max.m4 @@ -1,5 +1,5 @@ # size_max.m4 serial 10 -dnl Copyright (C) 2003, 2005-2006, 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2005-2006, 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/snprintf.m4 b/m4/snprintf.m4 index 8ae70050c..888db35c0 100644 --- a/m4/snprintf.m4 +++ b/m4/snprintf.m4 @@ -1,5 +1,5 @@ # snprintf.m4 serial 6 -dnl Copyright (C) 2002-2004, 2007-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2004, 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/socketlib.m4 b/m4/socketlib.m4 index 934173955..041498baf 100644 --- a/m4/socketlib.m4 +++ b/m4/socketlib.m4 @@ -1,5 +1,5 @@ # socketlib.m4 serial 1 -dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sockets.m4 b/m4/sockets.m4 index e75ac02b2..da6ff7427 100644 --- a/m4/sockets.m4 +++ b/m4/sockets.m4 @@ -1,5 +1,5 @@ # sockets.m4 serial 7 -dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/socklen.m4 b/m4/socklen.m4 index bcabed3ef..4c07f864c 100644 --- a/m4/socklen.m4 +++ b/m4/socklen.m4 @@ -1,5 +1,5 @@ # socklen.m4 serial 10 -dnl Copyright (C) 2005-2007, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2005-2007, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sockpfaf.m4 b/m4/sockpfaf.m4 index 50eb7619d..31d436f0e 100644 --- a/m4/sockpfaf.m4 +++ b/m4/sockpfaf.m4 @@ -1,5 +1,5 @@ # sockpfaf.m4 serial 8 -dnl Copyright (C) 2004, 2006, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2004, 2006, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/ssize_t.m4 b/m4/ssize_t.m4 index 25bd45143..fbe1d0687 100644 --- a/m4/ssize_t.m4 +++ b/m4/ssize_t.m4 @@ -1,5 +1,5 @@ # ssize_t.m4 serial 5 (gettext-0.18.2) -dnl Copyright (C) 2001-2003, 2006, 2010-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2003, 2006, 2010-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/stat-time.m4 b/m4/stat-time.m4 index 9c8ceec18..ea5c4fc59 100644 --- a/m4/stat-time.m4 +++ b/m4/stat-time.m4 @@ -1,6 +1,6 @@ # Checks for stat-related time functions. -# Copyright (C) 1998-1999, 2001, 2003, 2005-2007, 2009-2015 Free Software +# Copyright (C) 1998-1999, 2001, 2003, 2005-2007, 2009-2014 Free Software # Foundation, Inc. # This file is free software; the Free Software Foundation diff --git a/m4/stat.m4 b/m4/stat.m4 index d1b376896..1ae327b36 100644 --- a/m4/stat.m4 +++ b/m4/stat.m4 @@ -1,6 +1,6 @@ # serial 11 -# Copyright (C) 2009-2015 Free Software Foundation, Inc. +# Copyright (C) 2009-2014 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, diff --git a/m4/stdalign.m4 b/m4/stdalign.m4 index 033b0d39e..9efafe5c5 100644 --- a/m4/stdalign.m4 +++ b/m4/stdalign.m4 @@ -1,6 +1,6 @@ # Check for stdalign.h that conforms to C11. -dnl Copyright 2011-2015 Free Software Foundation, Inc. +dnl Copyright 2011-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -32,12 +32,8 @@ AC_DEFUN([gl_STDALIGN_H], /* Test _Alignas only on platforms where gnulib can help. */ #if \ ((defined __cplusplus && 201103 <= __cplusplus) \ - || (defined __APPLE__ && defined __MACH__ \ - ? 4 < __GNUC__ + (1 <= __GNUC_MINOR__) \ - : __GNUC__) \ - || __HP_cc || __HP_aCC || __IBMC__ || __IBMCPP__ \ - || __ICC || 0x5110 <= __SUNPRO_C \ - || 1300 <= _MSC_VER) + || __GNUC__ || __IBMC__ || __IBMCPP__ || __ICC \ + || 0x5110 <= __SUNPRO_C || 1300 <= _MSC_VER) struct alignas_test { char c; char alignas (8) alignas_8; }; char test_alignas[offsetof (struct alignas_test, alignas_8) == 8 ? 1 : -1]; diff --git a/m4/stdbool.m4 b/m4/stdbool.m4 index 7273b8224..006ed52de 100644 --- a/m4/stdbool.m4 +++ b/m4/stdbool.m4 @@ -1,6 +1,6 @@ # Check for stdbool.h that conforms to C99. -dnl Copyright (C) 2002-2006, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2006, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/stddef_h.m4 b/m4/stddef_h.m4 index 231050274..c555e2952 100644 --- a/m4/stddef_h.m4 +++ b/m4/stddef_h.m4 @@ -1,6 +1,6 @@ -dnl A placeholder for , for platforms that have issues. -# stddef_h.m4 serial 5 -dnl Copyright (C) 2009-2015 Free Software Foundation, Inc. +dnl A placeholder for POSIX 2008 , for platforms that have issues. +# stddef_h.m4 serial 4 +dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -10,9 +10,6 @@ AC_DEFUN([gl_STDDEF_H], AC_REQUIRE([gl_STDDEF_H_DEFAULTS]) AC_REQUIRE([gt_TYPE_WCHAR_T]) STDDEF_H= - AC_CHECK_TYPE([max_align_t], [], [HAVE_MAX_ALIGN_T=0; STDDEF_H=stddef.h], - [[#include - ]]) if test $gt_cv_c_wchar_t = no; then HAVE_WCHAR_T=0 STDDEF_H=stddef.h @@ -46,6 +43,5 @@ AC_DEFUN([gl_STDDEF_H_DEFAULTS], [ dnl Assume proper GNU behavior unless another module says otherwise. REPLACE_NULL=0; AC_SUBST([REPLACE_NULL]) - HAVE_MAX_ALIGN_T=1; AC_SUBST([HAVE_MAX_ALIGN_T]) HAVE_WCHAR_T=1; AC_SUBST([HAVE_WCHAR_T]) ]) diff --git a/m4/stdint.m4 b/m4/stdint.m4 index 4011a4942..1981d9dbc 100644 --- a/m4/stdint.m4 +++ b/m4/stdint.m4 @@ -1,5 +1,5 @@ # stdint.m4 serial 43 -dnl Copyright (C) 2001-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/stdint_h.m4 b/m4/stdint_h.m4 index 5097c0b0d..7fc2ce9a8 100644 --- a/m4/stdint_h.m4 +++ b/m4/stdint_h.m4 @@ -1,5 +1,5 @@ # stdint_h.m4 serial 9 -dnl Copyright (C) 1997-2004, 2006, 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 1997-2004, 2006, 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/stdio_h.m4 b/m4/stdio_h.m4 index f60cc2156..d15913a3c 100644 --- a/m4/stdio_h.m4 +++ b/m4/stdio_h.m4 @@ -1,41 +1,14 @@ -# stdio_h.m4 serial 46 -dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. +# stdio_h.m4 serial 43 +dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. AC_DEFUN([gl_STDIO_H], [ - dnl For __USE_MINGW_ANSI_STDIO - AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) - AC_REQUIRE([gl_STDIO_H_DEFAULTS]) gl_NEXT_HEADERS([stdio.h]) - dnl Determine whether __USE_MINGW_ANSI_STDIO makes printf and - dnl inttypes.h behave like gnu instead of system; we must give our - dnl printf wrapper the right attribute to match. - AC_CACHE_CHECK([which flavor of printf attribute matches inttypes macros], - [gl_cv_func_printf_attribute_flavor], - [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[ - #define __STDC_FORMAT_MACROS 1 - #include - #include - /* For non-mingw systems, compilation will trivially succeed. - For mingw, compilation will succeed for older mingw (system - printf, "I64d") and fail for newer mingw (gnu printf, "lld"). */ - #if ((defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__) && \ - (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4)) - extern char PRIdMAX_probe[sizeof PRIdMAX == sizeof "I64d" ? 1 : -1]; - #endif - ]])], [gl_cv_func_printf_attribute_flavor=system], - [gl_cv_func_printf_attribute_flavor=gnu])]) - if test "$gl_cv_func_printf_attribute_flavor" = gnu; then - AC_DEFINE([GNULIB_PRINTF_ATTRIBUTE_FLAVOR_GNU], [1], - [Define to 1 if printf and friends should be labeled with - attribute "__gnu_printf__" instead of "__printf__"]) - fi - dnl No need to create extra modules for these functions. Everyone who uses dnl likely needs them. GNULIB_FSCANF=1 diff --git a/m4/stdlib_h.m4 b/m4/stdlib_h.m4 index 0b4c623ec..03b448b94 100644 --- a/m4/stdlib_h.m4 +++ b/m4/stdlib_h.m4 @@ -1,5 +1,5 @@ # stdlib_h.m4 serial 42 -dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -55,7 +55,6 @@ AC_DEFUN([gl_STDLIB_H_DEFAULTS], GNULIB_PTSNAME=0; AC_SUBST([GNULIB_PTSNAME]) GNULIB_PTSNAME_R=0; AC_SUBST([GNULIB_PTSNAME_R]) GNULIB_PUTENV=0; AC_SUBST([GNULIB_PUTENV]) - GNULIB_QSORT_R=0; AC_SUBST([GNULIB_QSORT_R]) GNULIB_RANDOM=0; AC_SUBST([GNULIB_RANDOM]) GNULIB_RANDOM_R=0; AC_SUBST([GNULIB_RANDOM_R]) GNULIB_REALLOC_POSIX=0; AC_SUBST([GNULIB_REALLOC_POSIX]) @@ -108,7 +107,6 @@ AC_DEFUN([gl_STDLIB_H_DEFAULTS], REPLACE_PTSNAME=0; AC_SUBST([REPLACE_PTSNAME]) REPLACE_PTSNAME_R=0; AC_SUBST([REPLACE_PTSNAME_R]) REPLACE_PUTENV=0; AC_SUBST([REPLACE_PUTENV]) - REPLACE_QSORT_R=0; AC_SUBST([REPLACE_QSORT_R]) REPLACE_RANDOM_R=0; AC_SUBST([REPLACE_RANDOM_R]) REPLACE_REALLOC=0; AC_SUBST([REPLACE_REALLOC]) REPLACE_REALPATH=0; AC_SUBST([REPLACE_REALPATH]) diff --git a/m4/strdup.m4 b/m4/strdup.m4 index 90ea29d22..1681a30eb 100644 --- a/m4/strdup.m4 +++ b/m4/strdup.m4 @@ -1,6 +1,6 @@ # strdup.m4 serial 13 -dnl Copyright (C) 2002-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/strftime.m4 b/m4/strftime.m4 index 4557626ae..0ba3dd074 100644 --- a/m4/strftime.m4 +++ b/m4/strftime.m4 @@ -1,6 +1,6 @@ # serial 33 -# Copyright (C) 1996-1997, 1999-2007, 2009-2015 Free Software Foundation, Inc. +# Copyright (C) 1996-1997, 1999-2007, 2009-2014 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, diff --git a/m4/string_h.m4 b/m4/string_h.m4 index 55d09ef40..64e683f9d 100644 --- a/m4/string_h.m4 +++ b/m4/string_h.m4 @@ -1,6 +1,6 @@ # Configure a GNU-like replacement for . -# Copyright (C) 2007-2015 Free Software Foundation, Inc. +# Copyright (C) 2007-2014 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_file_h.m4 b/m4/sys_file_h.m4 index 7b6a05a40..ad78efb9c 100644 --- a/m4/sys_file_h.m4 +++ b/m4/sys_file_h.m4 @@ -1,7 +1,7 @@ # Configure a replacement for . # serial 6 -# Copyright (C) 2008-2015 Free Software Foundation, Inc. +# Copyright (C) 2008-2014 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_select_h.m4 b/m4/sys_select_h.m4 index 5ec5919f2..1a502b4eb 100644 --- a/m4/sys_select_h.m4 +++ b/m4/sys_select_h.m4 @@ -1,5 +1,5 @@ # sys_select_h.m4 serial 20 -dnl Copyright (C) 2006-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_socket_h.m4 b/m4/sys_socket_h.m4 index eaeabe7d9..114d82817 100644 --- a/m4/sys_socket_h.m4 +++ b/m4/sys_socket_h.m4 @@ -1,5 +1,5 @@ # sys_socket_h.m4 serial 23 -dnl Copyright (C) 2005-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2005-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_stat_h.m4 b/m4/sys_stat_h.m4 index 6c909e816..eaa7642ba 100644 --- a/m4/sys_stat_h.m4 +++ b/m4/sys_stat_h.m4 @@ -1,5 +1,5 @@ # sys_stat_h.m4 serial 28 -*- Autoconf -*- -dnl Copyright (C) 2006-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_time_h.m4 b/m4/sys_time_h.m4 index 28c8b1acb..5c79300f8 100644 --- a/m4/sys_time_h.m4 +++ b/m4/sys_time_h.m4 @@ -1,7 +1,7 @@ # Configure a replacement for . # serial 8 -# Copyright (C) 2007, 2009-2015 Free Software Foundation, Inc. +# Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. @@ -105,7 +105,6 @@ AC_DEFUN([gl_HEADER_SYS_TIME_H_DEFAULTS], HAVE_GETTIMEOFDAY=1; AC_SUBST([HAVE_GETTIMEOFDAY]) HAVE_STRUCT_TIMEVAL=1; AC_SUBST([HAVE_STRUCT_TIMEVAL]) HAVE_SYS_TIME_H=1; AC_SUBST([HAVE_SYS_TIME_H]) - HAVE_TIMEZONE_T=0; AC_SUBST([HAVE_TIMEZONE_T]) REPLACE_GETTIMEOFDAY=0; AC_SUBST([REPLACE_GETTIMEOFDAY]) REPLACE_STRUCT_TIMEVAL=0; AC_SUBST([REPLACE_STRUCT_TIMEVAL]) ]) diff --git a/m4/sys_times_h.m4 b/m4/sys_times_h.m4 index fe927405c..fad63c4f0 100644 --- a/m4/sys_times_h.m4 +++ b/m4/sys_times_h.m4 @@ -1,7 +1,7 @@ # Configure a replacement for . # serial 8 -# Copyright (C) 2008-2015 Free Software Foundation, Inc. +# Copyright (C) 2008-2014 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_types_h.m4 b/m4/sys_types_h.m4 index 2232aece6..9748905b5 100644 --- a/m4/sys_types_h.m4 +++ b/m4/sys_types_h.m4 @@ -1,5 +1,5 @@ # sys_types_h.m4 serial 5 -dnl Copyright (C) 2011-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_uio_h.m4 b/m4/sys_uio_h.m4 index 3dfbcbe6e..ba6b4b5ed 100644 --- a/m4/sys_uio_h.m4 +++ b/m4/sys_uio_h.m4 @@ -1,5 +1,5 @@ # sys_uio_h.m4 serial 1 -dnl Copyright (C) 2011-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/tempname.m4 b/m4/tempname.m4 index b1694d684..1594e1f5d 100644 --- a/m4/tempname.m4 +++ b/m4/tempname.m4 @@ -1,6 +1,6 @@ #serial 5 -# Copyright (C) 2006-2007, 2009-2015 Free Software Foundation, Inc. +# Copyright (C) 2006-2007, 2009-2014 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/time_h.m4 b/m4/time_h.m4 index 754b469a0..9852778f9 100644 --- a/m4/time_h.m4 +++ b/m4/time_h.m4 @@ -1,8 +1,8 @@ # Configure a more-standard replacement for . -# Copyright (C) 2000-2001, 2003-2007, 2009-2015 Free Software Foundation, Inc. +# Copyright (C) 2000-2001, 2003-2007, 2009-2014 Free Software Foundation, Inc. -# serial 9 +# serial 8 # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -26,7 +26,7 @@ AC_DEFUN([gl_HEADER_TIME_H_BODY], ]) dnl Check whether 'struct timespec' is declared -dnl in time.h, sys/time.h, pthread.h, or unistd.h. +dnl in time.h, sys/time.h, or pthread.h. AC_DEFUN([gl_CHECK_TYPE_STRUCT_TIMESPEC], [ @@ -44,7 +44,6 @@ AC_DEFUN([gl_CHECK_TYPE_STRUCT_TIMESPEC], TIME_H_DEFINES_STRUCT_TIMESPEC=0 SYS_TIME_H_DEFINES_STRUCT_TIMESPEC=0 PTHREAD_H_DEFINES_STRUCT_TIMESPEC=0 - UNISTD_H_DEFINES_STRUCT_TIMESPEC=0 if test $gl_cv_sys_struct_timespec_in_time_h = yes; then TIME_H_DEFINES_STRUCT_TIMESPEC=1 else @@ -71,26 +70,12 @@ AC_DEFUN([gl_CHECK_TYPE_STRUCT_TIMESPEC], [gl_cv_sys_struct_timespec_in_pthread_h=no])]) if test $gl_cv_sys_struct_timespec_in_pthread_h = yes; then PTHREAD_H_DEFINES_STRUCT_TIMESPEC=1 - else - AC_CACHE_CHECK([for struct timespec in ], - [gl_cv_sys_struct_timespec_in_unistd_h], - [AC_COMPILE_IFELSE( - [AC_LANG_PROGRAM( - [[#include - ]], - [[static struct timespec x; x.tv_sec = x.tv_nsec;]])], - [gl_cv_sys_struct_timespec_in_unistd_h=yes], - [gl_cv_sys_struct_timespec_in_unistd_h=no])]) - if test $gl_cv_sys_struct_timespec_in_unistd_h = yes; then - UNISTD_H_DEFINES_STRUCT_TIMESPEC=1 - fi fi fi fi AC_SUBST([TIME_H_DEFINES_STRUCT_TIMESPEC]) AC_SUBST([SYS_TIME_H_DEFINES_STRUCT_TIMESPEC]) AC_SUBST([PTHREAD_H_DEFINES_STRUCT_TIMESPEC]) - AC_SUBST([UNISTD_H_DEFINES_STRUCT_TIMESPEC]) ]) AC_DEFUN([gl_TIME_MODULE_INDICATOR], @@ -109,7 +94,6 @@ AC_DEFUN([gl_HEADER_TIME_H_DEFAULTS], GNULIB_STRPTIME=0; AC_SUBST([GNULIB_STRPTIME]) GNULIB_TIMEGM=0; AC_SUBST([GNULIB_TIMEGM]) GNULIB_TIME_R=0; AC_SUBST([GNULIB_TIME_R]) - GNULIB_TIME_RZ=0; AC_SUBST([GNULIB_TIME_RZ]) dnl Assume proper GNU behavior unless another module says otherwise. HAVE_DECL_LOCALTIME_R=1; AC_SUBST([HAVE_DECL_LOCALTIME_R]) HAVE_NANOSLEEP=1; AC_SUBST([HAVE_NANOSLEEP]) diff --git a/m4/time_r.m4 b/m4/time_r.m4 index 8df7e139c..7e15600f7 100644 --- a/m4/time_r.m4 +++ b/m4/time_r.m4 @@ -1,6 +1,6 @@ dnl Reentrant time functions: localtime_r, gmtime_r. -dnl Copyright (C) 2003, 2006-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2006-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/time_rz.m4 b/m4/time_rz.m4 deleted file mode 100644 index 0c1f2c373..000000000 --- a/m4/time_rz.m4 +++ /dev/null @@ -1,21 +0,0 @@ -dnl Time zone functions: tzalloc, localtime_rz, etc. - -dnl Copyright (C) 2015 Free Software Foundation, Inc. -dnl This file is free software; the Free Software Foundation -dnl gives unlimited permission to copy and/or distribute it, -dnl with or without modifications, as long as this notice is preserved. - -dnl Written by Paul Eggert. - -AC_DEFUN([gl_TIME_RZ], -[ - AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) - AC_REQUIRE([gl_HEADER_SYS_TIME_H_DEFAULTS]) - AC_REQUIRE([AC_STRUCT_TIMEZONE]) - AC_CHECK_FUNCS_ONCE([tzset]) - - AC_CHECK_TYPES([timezone_t], [], [], [[#include ]]) - if test "$ac_cv_type_timezone_t" = yes; then - HAVE_TIMEZONE_T=1 - fi -]) diff --git a/m4/timegm.m4 b/m4/timegm.m4 deleted file mode 100644 index 8e68b99ba..000000000 --- a/m4/timegm.m4 +++ /dev/null @@ -1,26 +0,0 @@ -# timegm.m4 serial 11 -dnl Copyright (C) 2003, 2007, 2009-2015 Free Software Foundation, Inc. -dnl This file is free software; the Free Software Foundation -dnl gives unlimited permission to copy and/or distribute it, -dnl with or without modifications, as long as this notice is preserved. - -AC_DEFUN([gl_FUNC_TIMEGM], -[ - AC_REQUIRE([gl_HEADER_TIME_H_DEFAULTS]) - AC_REQUIRE([gl_FUNC_MKTIME]) - REPLACE_TIMEGM=0 - AC_CHECK_FUNCS_ONCE([timegm]) - if test $ac_cv_func_timegm = yes; then - if test $gl_cv_func_working_mktime = no; then - # Assume that timegm is buggy if mktime is. - REPLACE_TIMEGM=1 - fi - else - HAVE_TIMEGM=0 - fi -]) - -# Prerequisites of lib/timegm.c. -AC_DEFUN([gl_PREREQ_TIMEGM], [ - : -]) diff --git a/m4/times.m4 b/m4/times.m4 index 0359bbcee..3ee364b8c 100644 --- a/m4/times.m4 +++ b/m4/times.m4 @@ -1,5 +1,5 @@ # times.m4 serial 2 -dnl Copyright (C) 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/tm_gmtoff.m4 b/m4/tm_gmtoff.m4 index 71a88f92f..486351b47 100644 --- a/m4/tm_gmtoff.m4 +++ b/m4/tm_gmtoff.m4 @@ -1,5 +1,5 @@ # tm_gmtoff.m4 serial 3 -dnl Copyright (C) 2002, 2009-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2002, 2009-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/trunc.m4 b/m4/trunc.m4 index da276c1ff..ba87bd0c0 100644 --- a/m4/trunc.m4 +++ b/m4/trunc.m4 @@ -1,5 +1,5 @@ # trunc.m4 serial 9 -dnl Copyright (C) 2007, 2010-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2010-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/unistd_h.m4 b/m4/unistd_h.m4 index b3c581f7b..1fa197e69 100644 --- a/m4/unistd_h.m4 +++ b/m4/unistd_h.m4 @@ -1,5 +1,5 @@ -# unistd_h.m4 serial 68 -dnl Copyright (C) 2006-2015 Free Software Foundation, Inc. +# unistd_h.m4 serial 67 +dnl Copyright (C) 2006-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -173,11 +173,9 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS], REPLACE_PWRITE=0; AC_SUBST([REPLACE_PWRITE]) REPLACE_READ=0; AC_SUBST([REPLACE_READ]) REPLACE_READLINK=0; AC_SUBST([REPLACE_READLINK]) - REPLACE_READLINKAT=0; AC_SUBST([REPLACE_READLINKAT]) REPLACE_RMDIR=0; AC_SUBST([REPLACE_RMDIR]) REPLACE_SLEEP=0; AC_SUBST([REPLACE_SLEEP]) REPLACE_SYMLINK=0; AC_SUBST([REPLACE_SYMLINK]) - REPLACE_SYMLINKAT=0; AC_SUBST([REPLACE_SYMLINKAT]) REPLACE_TTYNAME_R=0; AC_SUBST([REPLACE_TTYNAME_R]) REPLACE_UNLINK=0; AC_SUBST([REPLACE_UNLINK]) REPLACE_UNLINKAT=0; AC_SUBST([REPLACE_UNLINKAT]) diff --git a/m4/vasnprintf.m4 b/m4/vasnprintf.m4 index 4708f2b8e..106192ea2 100644 --- a/m4/vasnprintf.m4 +++ b/m4/vasnprintf.m4 @@ -1,5 +1,5 @@ # vasnprintf.m4 serial 36 -dnl Copyright (C) 2002-2004, 2006-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2004, 2006-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/visibility.m4 b/m4/visibility.m4 index 6fff7459c..552e39772 100644 --- a/m4/visibility.m4 +++ b/m4/visibility.m4 @@ -1,5 +1,5 @@ # visibility.m4 serial 5 (gettext-0.18.2) -dnl Copyright (C) 2005, 2008, 2010-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2005, 2008, 2010-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/vsnprintf.m4 b/m4/vsnprintf.m4 index 28be6fd18..07f739df9 100644 --- a/m4/vsnprintf.m4 +++ b/m4/vsnprintf.m4 @@ -1,5 +1,5 @@ # vsnprintf.m4 serial 6 -dnl Copyright (C) 2002-2004, 2007-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2004, 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/warn-on-use.m4 b/m4/warn-on-use.m4 index 1e98dc9b7..cc690f8e2 100644 --- a/m4/warn-on-use.m4 +++ b/m4/warn-on-use.m4 @@ -1,5 +1,5 @@ # warn-on-use.m4 serial 5 -dnl Copyright (C) 2010-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/warnings.m4 b/m4/warnings.m4 index 5ae01def1..43156f450 100644 --- a/m4/warnings.m4 +++ b/m4/warnings.m4 @@ -1,5 +1,5 @@ # warnings.m4 serial 11 -dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/wchar_h.m4 b/m4/wchar_h.m4 index 9d1b0f8b6..85db95286 100644 --- a/m4/wchar_h.m4 +++ b/m4/wchar_h.m4 @@ -1,6 +1,6 @@ dnl A placeholder for ISO C99 , for platforms that have issues. -dnl Copyright (C) 2007-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/wchar_t.m4 b/m4/wchar_t.m4 index dc964e67e..839a04c17 100644 --- a/m4/wchar_t.m4 +++ b/m4/wchar_t.m4 @@ -1,5 +1,5 @@ # wchar_t.m4 serial 4 (gettext-0.18.2) -dnl Copyright (C) 2002-2003, 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2003, 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/wcrtomb.m4 b/m4/wcrtomb.m4 index 7e3fe3f54..844ef6a8c 100644 --- a/m4/wcrtomb.m4 +++ b/m4/wcrtomb.m4 @@ -1,5 +1,5 @@ # wcrtomb.m4 serial 11 -dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/wctype_h.m4 b/m4/wctype_h.m4 index 95a4705b0..3fac0ee09 100644 --- a/m4/wctype_h.m4 +++ b/m4/wctype_h.m4 @@ -2,7 +2,7 @@ dnl A placeholder for ISO C99 , for platforms that lack it. -dnl Copyright (C) 2006-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/wint_t.m4 b/m4/wint_t.m4 index ca3fd449a..9b07b0709 100644 --- a/m4/wint_t.m4 +++ b/m4/wint_t.m4 @@ -1,5 +1,5 @@ # wint_t.m4 serial 5 (gettext-0.18.2) -dnl Copyright (C) 2003, 2007-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2007-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/write.m4 b/m4/write.m4 index ce7042ef1..820dd4f77 100644 --- a/m4/write.m4 +++ b/m4/write.m4 @@ -1,5 +1,5 @@ # write.m4 serial 5 -dnl Copyright (C) 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/xsize.m4 b/m4/xsize.m4 index 98faf7de0..3af23ec75 100644 --- a/m4/xsize.m4 +++ b/m4/xsize.m4 @@ -1,5 +1,5 @@ # xsize.m4 serial 5 -dnl Copyright (C) 2003-2004, 2008-2015 Free Software Foundation, Inc. +dnl Copyright (C) 2003-2004, 2008-2014 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/maint.mk b/maint.mk index 893874b45..30f2e8e69 100644 --- a/maint.mk +++ b/maint.mk @@ -2,7 +2,7 @@ # This Makefile fragment tries to be general-purpose enough to be # used by many projects via the gnulib maintainer-makefile module. -## Copyright (C) 2001-2015 Free Software Foundation, Inc. +## Copyright (C) 2001-2014 Free Software Foundation, Inc. ## ## This program is free software: you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by @@ -21,6 +21,13 @@ # ME := $(word $(words $(MAKEFILE_LIST)),$(MAKEFILE_LIST)) ME := maint.mk +# Diagnostic for continued use of deprecated variable. +# Remove in 2013 +ifneq ($(build_aux),) + $(error "$(ME): \ +set $$(_build-aux) relative to $$(srcdir) instead of $$(build_aux)") +endif + # Helper variables. _empty = _sp = $(_empty) $(_empty) @@ -148,7 +155,6 @@ export LC_ALL = C ## Sanity checks. ## ## --------------- ## -ifneq ($(_gl-Makefile),) _cfg_mk := $(wildcard $(srcdir)/cfg.mk) # Collect the names of rules starting with 'sc_'. @@ -190,7 +196,6 @@ local-check := \ $(filter-out $(local-checks-to-skip), $(local-checks-available))) syntax-check: $(local-check) -endif # _sc_search_regexp # @@ -440,7 +445,7 @@ sc_require_config_h: # You must include before including any other header file. # This can possibly be via a package-specific header, if given by cfg.mk. sc_require_config_h_first: - @if $(VC_LIST_EXCEPT) | grep '\.c$$' > /dev/null; then \ + @if $(VC_LIST_EXCEPT) | grep -l '\.c$$' > /dev/null; then \ fail=0; \ for i in $$($(VC_LIST_EXCEPT) | grep '\.c$$'); do \ grep '^# *include\>' $$i | $(SED) 1q \ @@ -464,7 +469,7 @@ sc_prohibit_HAVE_MBRTOWC: define _sc_header_without_use dummy=; : so we do not need a semicolon before each use; \ h_esc=`echo '[<"]'"$$h"'[">]'|$(SED) 's/\./\\\\./g'`; \ - if $(VC_LIST_EXCEPT) | grep '\.c$$' > /dev/null; then \ + if $(VC_LIST_EXCEPT) | grep -l '\.c$$' > /dev/null; then \ files=$$(grep -l '^# *include '"$$h_esc" \ $$($(VC_LIST_EXCEPT) | grep '\.c$$')) && \ grep -LE "$$re" $$files | grep . && \ @@ -711,7 +716,7 @@ sc_changelog: # Ensure that each .c file containing a "main" function also # calls set_program_name. sc_program_name: - @require='set_program_name *\(.*\);' \ + @require='set_program_name *\(m?argv\[0\]\);' \ in_vc_files='\.c$$' \ containing='\
&2; exit 1; } || : -# Except for shell files and for loops, double semicolon is probably a mistake -sc_prohibit_double_semicolon: - @prohibit='; *;[ {} \]*(/[/*]|$$)' \ - in_vc_files='\.[chly]$$' \ - exclude='\bfor *\(.*\)' \ - halt="Double semicolon detected" \ - $(_sc_search_regexp) - _ptm1 = use "test C1 && test C2", not "test C1 -''a C2" _ptm2 = use "test C1 || test C2", not "test C1 -''o C2" # Using test's -a and -o operators is not portable. @@ -1195,7 +1192,7 @@ sc_copyright_check: in_vc_files=$(sample-test) \ halt='out of date copyright in $(sample-test); update it' \ $(_sc_search_regexp) - @require='Copyright @copyright\{\} .*'$$(date +%Y) \ + @require='Copyright @copyright\{\} .*'$$(date +%Y)' Free' \ in_vc_files=$(texi) \ halt='out of date copyright in $(texi); update it' \ $(_sc_search_regexp) @@ -1600,7 +1597,7 @@ ifeq (a,b) # do not need to be marked. Symbols matching '__.*' are # reserved by the compiler, so are automatically excluded below. _gl_TS_unmarked_extern_functions ?= main usage -_gl_TS_function_match ?= /^(?:$(_gl_TS_extern)) +.*?(\w+) *\(/ +_gl_TS_function_match ?= /^(?:$(_gl_TS_extern)) +.*?(\S+) *\(/ # If your project uses a macro like "XTERN", then put # the following in cfg.mk to override this default: @@ -1633,7 +1630,6 @@ _gl_TS_other_headers ?= *.h .PHONY: _gl_tight_scope _gl_tight_scope: $(bin_PROGRAMS) - sed_wrap='s/^/^_?/;s/$$/$$/'; \ t=exceptions-$$$$; \ trap 's=$$?; rm -f $$t; exit $$s' 0; \ for sig in 1 2 3 13 15; do \ @@ -1643,20 +1639,20 @@ _gl_tight_scope: $(bin_PROGRAMS) test -f $$f && d= || d=$(srcdir)/; echo $$d$$f; done`; \ hdr=`for f in $(_gl_TS_headers); do \ test -f $$f && d= || d=$(srcdir)/; echo $$d$$f; done`; \ - ( printf '%s\n' '__.*' $(_gl_TS_unmarked_extern_functions); \ + ( printf '^%s$$\n' '__.*' $(_gl_TS_unmarked_extern_functions); \ grep -h -A1 '^extern .*[^;]$$' $$src \ - | grep -vE '^(extern |--|#)' | $(SED) 's/ .*//; /^$$/d'; \ + | grep -vE '^(extern |--)' | $(SED) 's/ .*//'; \ perl -lne \ - '$(_gl_TS_function_match) and print $$1' $$hdr; \ - ) | sort -u | $(SED) "$$sed_wrap" > $$t; \ - nm -g $(_gl_TS_obj_files)|$(SED) -n 's/.* T //p'|grep -Ev -f $$t \ + '$(_gl_TS_function_match) and print "^$$1\$$"' $$hdr; \ + ) | sort -u > $$t; \ + nm -e $(_gl_TS_obj_files)|$(SED) -n 's/.* T //p'|grep -Ev -f $$t \ && { echo the above functions should have static scope >&2; \ exit 1; } || : ; \ - ( printf '%s\n' '__.*' main $(_gl_TS_unmarked_extern_vars); \ - perl -lne '$(_gl_TS_var_match) and print $$1' \ + ( printf '^%s$$\n' '__.*' $(_gl_TS_unmarked_extern_vars); \ + perl -lne '$(_gl_TS_var_match) and print "^$$1\$$"' \ $$hdr $(_gl_TS_other_headers) \ - ) | sort -u | $(SED) "$$sed_wrap" > $$t; \ - nm -g $(_gl_TS_obj_files) | $(SED) -n 's/.* [BCDGRS] //p' \ + ) | sort -u > $$t; \ + nm -e $(_gl_TS_obj_files) | $(SED) -n 's/.* [BCDGRS] //p' \ | sort -u | grep -Ev -f $$t \ && { echo the above variables should have static scope >&2; \ exit 1; } || : From 4339cb9fc11ccdb3f1c660cbfebbf7e2a7c108cb Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 25 Oct 2015 11:46:58 +0000 Subject: [PATCH 072/865] Fix uninstalled-env bug that preferred bootstrap/ to module/ * meta/uninstalled-env.in (top_builddir): Whoops! We were preferring bootstrap/ unoptimized .go files to module/ optimized .go files. Fix! --- meta/uninstalled-env.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/meta/uninstalled-env.in b/meta/uninstalled-env.in index f9f0dc78d..3bcde8eb9 100644 --- a/meta/uninstalled-env.in +++ b/meta/uninstalled-env.in @@ -84,7 +84,7 @@ then then GUILE_LOAD_COMPILED_PATH="${top_builddir}/module:${top_builddir}/guile-readline" else - for d in "/module" "/bootstrap" "/guile-readline" + for d in "/bootstrap" "/module" "/guile-readline" do # This hair prevents double inclusion. # The ":" prevents prefix aliasing. From e5bccb6e5df3485152bc6501e1f36275e09c6352 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 25 Oct 2015 14:25:39 +0000 Subject: [PATCH 073/865] Fix distcheck issues * bootstrap/Makefile.am: * libguile/Makefile.am: Fix distcheck issues. --- bootstrap/Makefile.am | 2 +- libguile/Makefile.am | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/bootstrap/Makefile.am b/bootstrap/Makefile.am index 441b72738..093ee8540 100644 --- a/bootstrap/Makefile.am +++ b/bootstrap/Makefile.am @@ -25,7 +25,7 @@ GOBJECTS = $(SOURCES:%.scm=%.go) GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat GUILE_OPTIMIZATIONS = -O1 nobase_noinst_DATA = $(GOBJECTS) ice-9/eval.go -CLEANFILES = $(GOBJECTS) ice-9/eval.go +CLEANFILES = $(GOBJECTS) ice-9/eval.go ice-9/psyntax-pp.go # We must build the evaluator first, so that we can be sure to control # the stack. Then we really need to build the expander before other diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 8302a1805..3bc9952a9 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -694,7 +694,7 @@ EXTRA_DIST = ChangeLog-scm ChangeLog-threads \ cpp-E.syms cpp-E.c cpp-SIG.syms cpp-SIG.c \ c-tokenize.lex \ scmconfig.h.top libgettext.h unidata_to_charset.pl libguile.map \ - libguile-2.2-gdb.scm + vm-operations.h libguile-2.2-gdb.scm # $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \ # guile-procedures.txt guile.texi From c99f9ba9c8d6f24070e74852872165529d6bc572 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 25 Oct 2015 12:08:53 +0000 Subject: [PATCH 074/865] Release v2.1.1 * GUILE-VERSION (GUILE_MICRO_VERSION): Bump to v2.1.1. --- GUILE-VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index 4a3f4fcef..53588a87a 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -3,7 +3,7 @@ # Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'. GUILE_MAJOR_VERSION=2 GUILE_MINOR_VERSION=1 -GUILE_MICRO_VERSION=0 +GUILE_MICRO_VERSION=1 GUILE_EFFECTIVE_VERSION=2.2 From ce36fb16fff30ba1915dbd9d52d2325acedd54c7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 28 Oct 2015 08:38:46 +0000 Subject: [PATCH 075/865] Bootstrap build doesn't have to expand CPS optimizations * module/language/cps/optimize.scm (define-optimizer) (optimize-higher-order-cps, optimize-first-order-cps): Obfuscate a bit so that the bootstrap build won't have to expand optimization passes. Might marginally speed up the bootstrap process. --- module/language/cps/optimize.scm | 72 +++++++++++++++++--------------- 1 file changed, 38 insertions(+), 34 deletions(-) diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm index 8777222c9..515fc7963 100644 --- a/module/language/cps/optimize.scm +++ b/module/language/cps/optimize.scm @@ -24,20 +24,6 @@ (define-module (language cps optimize) #:use-module (ice-9 match) - #:use-module (language cps constructors) - #:use-module (language cps contification) - #:use-module (language cps cse) - #:use-module (language cps dce) - #:use-module (language cps elide-values) - #:use-module (language cps licm) - #:use-module (language cps peel-loops) - #:use-module (language cps prune-top-level-scopes) - #:use-module (language cps prune-bailouts) - #:use-module (language cps rotate-loops) - #:use-module (language cps self-references) - #:use-module (language cps simplify) - #:use-module (language cps specialize-primcalls) - #:use-module (language cps type-fold) #:use-module (language cps verify) #:export (optimize-higher-order-cps optimize-first-order-cps @@ -55,7 +41,7 @@ (verify program) program)) -(define-syntax-rule (define-optimizer optimize (pass kw default) ...) +(define-syntax-rule (define-optimizer optimize ((@ mod pass) kw default) ...) (define* (optimize program #:optional (opts '())) ;; This series of assignments to `program' used to be a series of ;; let* bindings of `program', as you would imagine. In compiled @@ -72,7 +58,7 @@ (maybe-verify program) (set! program (if (kw-arg-ref opts kw default) - (maybe-verify (pass program)) + (maybe-verify ((module-ref (resolve-interface 'mod) 'pass) program)) program)) ... (maybe-verify program))) @@ -88,27 +74,45 @@ ;; pass back here when that's fixed. ;; ;; (split-rec #:split-rec? #t) - (eliminate-dead-code #:eliminate-dead-code? #t) - (prune-top-level-scopes #:prune-top-level-scopes? #t) - (simplify #:simplify? #t) - (contify #:contify? #t) - (inline-constructors #:inline-constructors? #t) - (specialize-primcalls #:specialize-primcalls? #t) - (elide-values #:elide-values? #t) - (prune-bailouts #:prune-bailouts? #t) - (peel-loops #:peel-loops? #t) - (eliminate-common-subexpressions #:cse? #t) - (type-fold #:type-fold? #t) - (resolve-self-references #:resolve-self-references? #t) - (eliminate-dead-code #:eliminate-dead-code? #t) - (simplify #:simplify? #t)) + ((@ (language cps dce) eliminate-dead-code) + #:eliminate-dead-code? #t) + ((@ (language cps prune-top-level-scopes) prune-top-level-scopes) + #:prune-top-level-scopes? #t) + ((@ (language cps simplify) simplify) + #:simplify? #t) + ((@ (language cps contification) contify) + #:contify? #t) + ((@ (language cps constructors) inline-constructors) + #:inline-constructors? #t) + ((@ (language cps specialize-primcalls) specialize-primcalls) + #:specialize-primcalls? #t) + ((@ (language cps elide-values) elide-values) + #:elide-values? #t) + ((@ (language cps prune-bailouts) prune-bailouts) + #:prune-bailouts? #t) + ((@ (language cps peel-loops) peel-loops) + #:peel-loops? #t) + ((@ (language cps cse) eliminate-common-subexpressions) + #:cse? #t) + ((@ (language cps type-fold) type-fold) + #:type-fold? #t) + ((@ (language cps self-references) resolve-self-references) + #:resolve-self-references? #t) + ((@ (language cps dce) eliminate-dead-code) + #:eliminate-dead-code? #t) + ((@ (language cps simplify) simplify) + #:simplify? #t)) (define-optimizer optimize-first-order-cps - (hoist-loop-invariant-code #:licm? #t) + ((@ (language cps licm) hoist-loop-invariant-code) + #:licm? #t) ;; FIXME: CSE here to eliminate duplicate free-ref terms. - (eliminate-dead-code #:eliminate-dead-code? #t) - (rotate-loops #:rotate-loops? #t) - (simplify #:simplify? #t)) + ((@ (language cps dce) eliminate-dead-code) + #:eliminate-dead-code? #t) + ((@ (language cps rotate-loops) rotate-loops) + #:rotate-loops? #t) + ((@ (language cps simplify) simplify) + #:simplify? #t)) (define (cps-default-optimization-options) (list ;; #:split-rec? #t From 8d79dfddb6b57a202215ec632c693e110e502826 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 28 Oct 2015 09:12:02 +0000 Subject: [PATCH 076/865] Revert "Bootstrap build doesn't have to expand CPS optimizations" This reverts commit ce36fb16fff30ba1915dbd9d52d2325acedd54c7. --- module/language/cps/optimize.scm | 72 +++++++++++++++----------------- 1 file changed, 34 insertions(+), 38 deletions(-) diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm index 515fc7963..8777222c9 100644 --- a/module/language/cps/optimize.scm +++ b/module/language/cps/optimize.scm @@ -24,6 +24,20 @@ (define-module (language cps optimize) #:use-module (ice-9 match) + #:use-module (language cps constructors) + #:use-module (language cps contification) + #:use-module (language cps cse) + #:use-module (language cps dce) + #:use-module (language cps elide-values) + #:use-module (language cps licm) + #:use-module (language cps peel-loops) + #:use-module (language cps prune-top-level-scopes) + #:use-module (language cps prune-bailouts) + #:use-module (language cps rotate-loops) + #:use-module (language cps self-references) + #:use-module (language cps simplify) + #:use-module (language cps specialize-primcalls) + #:use-module (language cps type-fold) #:use-module (language cps verify) #:export (optimize-higher-order-cps optimize-first-order-cps @@ -41,7 +55,7 @@ (verify program) program)) -(define-syntax-rule (define-optimizer optimize ((@ mod pass) kw default) ...) +(define-syntax-rule (define-optimizer optimize (pass kw default) ...) (define* (optimize program #:optional (opts '())) ;; This series of assignments to `program' used to be a series of ;; let* bindings of `program', as you would imagine. In compiled @@ -58,7 +72,7 @@ (maybe-verify program) (set! program (if (kw-arg-ref opts kw default) - (maybe-verify ((module-ref (resolve-interface 'mod) 'pass) program)) + (maybe-verify (pass program)) program)) ... (maybe-verify program))) @@ -74,45 +88,27 @@ ;; pass back here when that's fixed. ;; ;; (split-rec #:split-rec? #t) - ((@ (language cps dce) eliminate-dead-code) - #:eliminate-dead-code? #t) - ((@ (language cps prune-top-level-scopes) prune-top-level-scopes) - #:prune-top-level-scopes? #t) - ((@ (language cps simplify) simplify) - #:simplify? #t) - ((@ (language cps contification) contify) - #:contify? #t) - ((@ (language cps constructors) inline-constructors) - #:inline-constructors? #t) - ((@ (language cps specialize-primcalls) specialize-primcalls) - #:specialize-primcalls? #t) - ((@ (language cps elide-values) elide-values) - #:elide-values? #t) - ((@ (language cps prune-bailouts) prune-bailouts) - #:prune-bailouts? #t) - ((@ (language cps peel-loops) peel-loops) - #:peel-loops? #t) - ((@ (language cps cse) eliminate-common-subexpressions) - #:cse? #t) - ((@ (language cps type-fold) type-fold) - #:type-fold? #t) - ((@ (language cps self-references) resolve-self-references) - #:resolve-self-references? #t) - ((@ (language cps dce) eliminate-dead-code) - #:eliminate-dead-code? #t) - ((@ (language cps simplify) simplify) - #:simplify? #t)) + (eliminate-dead-code #:eliminate-dead-code? #t) + (prune-top-level-scopes #:prune-top-level-scopes? #t) + (simplify #:simplify? #t) + (contify #:contify? #t) + (inline-constructors #:inline-constructors? #t) + (specialize-primcalls #:specialize-primcalls? #t) + (elide-values #:elide-values? #t) + (prune-bailouts #:prune-bailouts? #t) + (peel-loops #:peel-loops? #t) + (eliminate-common-subexpressions #:cse? #t) + (type-fold #:type-fold? #t) + (resolve-self-references #:resolve-self-references? #t) + (eliminate-dead-code #:eliminate-dead-code? #t) + (simplify #:simplify? #t)) (define-optimizer optimize-first-order-cps - ((@ (language cps licm) hoist-loop-invariant-code) - #:licm? #t) + (hoist-loop-invariant-code #:licm? #t) ;; FIXME: CSE here to eliminate duplicate free-ref terms. - ((@ (language cps dce) eliminate-dead-code) - #:eliminate-dead-code? #t) - ((@ (language cps rotate-loops) rotate-loops) - #:rotate-loops? #t) - ((@ (language cps simplify) simplify) - #:simplify? #t)) + (eliminate-dead-code #:eliminate-dead-code? #t) + (rotate-loops #:rotate-loops? #t) + (simplify #:simplify? #t)) (define (cps-default-optimization-options) (list ;; #:split-rec? #t From 04356dabb9c7729c7bbf045abec17af8a171c79d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 28 Oct 2015 09:13:20 +0000 Subject: [PATCH 077/865] CSE can run on first-order CPS * module/language/cps/cse.scm (compute-truthy-expressions): (compute-equivalent-subexpressions): (eliminate-common-subexpressions): Refactor to be able to work on first-order CPS. --- module/language/cps/cse.scm | 312 +++++++++++++++++------------------- 1 file changed, 148 insertions(+), 164 deletions(-) diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index def542063..894f7798e 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -123,7 +123,7 @@ an intset containing ancestor labels whose value is available at LABEL." (intset kfun) (intmap-add empty-intmap kfun empty-intset))) -(define (compute-truthy-expressions conts kfun boolv) +(define (compute-truthy-expressions conts kfun) "Compute a \"truth map\", indicating which expressions can be shown to be true and/or false at each label in the function starting at KFUN.. Returns an intmap of intsets. The even elements of the intset indicate @@ -177,24 +177,13 @@ false. It could be that both true and false proofs are available." (propagate1 kbody))) (($ $ktail) (propagate0))))) - (let ((boolv (worklist-fold* visit-cont - (intset kfun) - (intmap-add boolv kfun empty-intset)))) - ;; Now visit nested functions. We don't do this in the worklist - ;; folder because that would be exponential. - (define (recurse kfun boolv) - (compute-truthy-expressions conts kfun boolv)) - (intset-fold - (lambda (label boolv) - (match (intmap-ref conts label) - (($ $kargs _ _ ($ $continue _ _ exp)) - (match exp - (($ $fun kfun) (recurse kfun boolv)) - (($ $rec _ _ (($ $fun kfun) ...)) (fold recurse boolv kfun)) - (_ boolv))) - (_ boolv))) - (compute-function-body conts kfun) - boolv))) + (intset-fold + (lambda (kfun boolv) + (worklist-fold* visit-cont + (intset kfun) + (intmap-add boolv kfun empty-intset))) + (intmap-keys (compute-reachable-functions conts kfun)) + empty-intmap)) (define (intset-map f set) (persistent-intmap @@ -236,151 +225,147 @@ false. It could be that both true and false proofs are available." (intset-subtract (persistent-intset single) (persistent-intset multiple))))) -(define (compute-equivalent-subexpressions conts kfun effects - equiv-labels var-substs) - (let* ((succs (compute-successors conts kfun)) - (singly-referenced (compute-singly-referenced succs)) - (avail (compute-available-expressions conts kfun effects)) - (defs (compute-defs conts kfun)) - (equiv-set (make-hash-table))) - (define (subst-var var-substs var) - (intmap-ref var-substs var (lambda (var) var))) - (define (subst-vars var-substs vars) - (let lp ((vars vars)) - (match vars - (() '()) - ((var . vars) (cons (subst-var var-substs var) (lp vars)))))) +(define (compute-equivalent-subexpressions conts kfun effects) + (define (visit-fun kfun equiv-labels var-substs) + (let* ((succs (compute-successors conts kfun)) + (singly-referenced (compute-singly-referenced succs)) + (avail (compute-available-expressions conts kfun effects)) + (defs (compute-defs conts kfun)) + (equiv-set (make-hash-table))) + (define (subst-var var-substs var) + (intmap-ref var-substs var (lambda (var) var))) + (define (subst-vars var-substs vars) + (let lp ((vars vars)) + (match vars + (() '()) + ((var . vars) (cons (subst-var var-substs var) (lp vars)))))) - (define (compute-exp-key var-substs exp) - (match exp - (($ $const val) (cons 'const val)) - (($ $prim name) (cons 'prim name)) - (($ $fun body) #f) - (($ $rec names syms funs) #f) - (($ $call proc args) #f) - (($ $callk k proc args) #f) - (($ $primcall name args) - (cons* 'primcall name (subst-vars var-substs args))) - (($ $branch _ ($ $primcall name args)) - (cons* 'primcall name (subst-vars var-substs args))) - (($ $branch) #f) - (($ $values args) #f) - (($ $prompt escape? tag handler) #f))) + (define (compute-exp-key var-substs exp) + (match exp + (($ $const val) (cons 'const val)) + (($ $prim name) (cons 'prim name)) + (($ $fun body) #f) + (($ $rec names syms funs) #f) + (($ $closure label nfree) #f) + (($ $call proc args) #f) + (($ $callk k proc args) #f) + (($ $primcall name args) + (cons* 'primcall name (subst-vars var-substs args))) + (($ $branch _ ($ $primcall name args)) + (cons* 'primcall name (subst-vars var-substs args))) + (($ $branch) #f) + (($ $values args) #f) + (($ $prompt escape? tag handler) #f))) - (define (add-auxiliary-definitions! label var-substs exp-key) - (define (subst var) - (subst-var var-substs var)) - (let ((defs (intmap-ref defs label))) - (define (add-def! aux-key var) - (let ((equiv (hash-ref equiv-set aux-key '()))) - (hash-set! equiv-set aux-key - (acons label (list var) equiv)))) - (match exp-key - (('primcall 'box val) - (match defs - ((box) - (add-def! `(primcall box-ref ,(subst box)) val)))) - (('primcall 'box-set! box val) - (add-def! `(primcall box-ref ,box) val)) - (('primcall 'cons car cdr) - (match defs - ((pair) - (add-def! `(primcall car ,(subst pair)) car) - (add-def! `(primcall cdr ,(subst pair)) cdr)))) - (('primcall 'set-car! pair car) - (add-def! `(primcall car ,pair) car)) - (('primcall 'set-cdr! pair cdr) - (add-def! `(primcall cdr ,pair) cdr)) - (('primcall (or 'make-vector 'make-vector/immediate) len fill) - (match defs - ((vec) - (add-def! `(primcall vector-length ,(subst vec)) len)))) - (('primcall 'vector-set! vec idx val) - (add-def! `(primcall vector-ref ,vec ,idx) val)) - (('primcall 'vector-set!/immediate vec idx val) - (add-def! `(primcall vector-ref/immediate ,vec ,idx) val)) - (('primcall (or 'allocate-struct 'allocate-struct/immediate) - vtable size) - (match defs - ((struct) - (add-def! `(primcall struct-vtable ,(subst struct)) - vtable)))) - (('primcall 'struct-set! struct n val) - (add-def! `(primcall struct-ref ,struct ,n) val)) - (('primcall 'struct-set!/immediate struct n val) - (add-def! `(primcall struct-ref/immediate ,struct ,n) val)) - (_ #t)))) + (define (add-auxiliary-definitions! label var-substs exp-key) + (define (subst var) + (subst-var var-substs var)) + (let ((defs (intmap-ref defs label))) + (define (add-def! aux-key var) + (let ((equiv (hash-ref equiv-set aux-key '()))) + (hash-set! equiv-set aux-key + (acons label (list var) equiv)))) + (match exp-key + (('primcall 'box val) + (match defs + ((box) + (add-def! `(primcall box-ref ,(subst box)) val)))) + (('primcall 'box-set! box val) + (add-def! `(primcall box-ref ,box) val)) + (('primcall 'cons car cdr) + (match defs + ((pair) + (add-def! `(primcall car ,(subst pair)) car) + (add-def! `(primcall cdr ,(subst pair)) cdr)))) + (('primcall 'set-car! pair car) + (add-def! `(primcall car ,pair) car)) + (('primcall 'set-cdr! pair cdr) + (add-def! `(primcall cdr ,pair) cdr)) + (('primcall (or 'make-vector 'make-vector/immediate) len fill) + (match defs + ((vec) + (add-def! `(primcall vector-length ,(subst vec)) len)))) + (('primcall 'vector-set! vec idx val) + (add-def! `(primcall vector-ref ,vec ,idx) val)) + (('primcall 'vector-set!/immediate vec idx val) + (add-def! `(primcall vector-ref/immediate ,vec ,idx) val)) + (('primcall (or 'allocate-struct 'allocate-struct/immediate) + vtable size) + (match defs + ((struct) + (add-def! `(primcall struct-vtable ,(subst struct)) + vtable)))) + (('primcall 'struct-set! struct n val) + (add-def! `(primcall struct-ref ,struct ,n) val)) + (('primcall 'struct-set!/immediate struct n val) + (add-def! `(primcall struct-ref/immediate ,struct ,n) val)) + (_ #t)))) - (define (visit-label label equiv-labels var-substs) - (match (intmap-ref conts label) - (($ $kargs names vars ($ $continue k src exp)) - (let* ((exp-key (compute-exp-key var-substs exp)) - (equiv (hash-ref equiv-set exp-key '())) - (fx (intmap-ref effects label)) - (avail (intmap-ref avail label))) - (define (finish equiv-labels var-substs) - (define (recurse kfun equiv-labels var-substs) - (compute-equivalent-subexpressions conts kfun effects - equiv-labels var-substs)) - ;; If this expression defines auxiliary definitions, - ;; as `cons' does for the results of `car' and `cdr', - ;; define those. Do so after finding equivalent - ;; expressions, so that we can take advantage of - ;; subst'd output vars. - (add-auxiliary-definitions! label var-substs exp-key) - (match exp - ;; If we see a $fun, recurse to add to the result. - (($ $fun kfun) - (recurse kfun equiv-labels var-substs)) - (($ $rec names vars (($ $fun kfun) ...)) - (fold2 recurse kfun equiv-labels var-substs)) - (_ - (values equiv-labels var-substs)))) - (let lp ((candidates equiv)) - (match candidates - (() - ;; No matching expressions. Add our expression - ;; to the equivalence set, if appropriate. Note - ;; that expressions that allocate a fresh object - ;; or change the current fluid environment can't - ;; be eliminated by CSE (though DCE might do it - ;; if the value proves to be unused, in the - ;; allocation case). - (when (and exp-key - (not (causes-effect? fx &allocation)) - (not (effect-clobbers? fx (&read-object &fluid)))) - (let ((defs (and (intset-ref singly-referenced k) - (intmap-ref defs label)))) - (when defs - (hash-set! equiv-set exp-key - (acons label defs equiv))))) - (finish equiv-labels var-substs)) - (((and head (candidate . vars)) . candidates) - (cond - ((not (intset-ref avail candidate)) - ;; This expression isn't available here; try - ;; the next one. - (lp candidates)) - (else - ;; Yay, a match. Mark expression as equivalent. If - ;; we provide the definitions for the successor, mark - ;; the vars for substitution. - (finish (intmap-add equiv-labels label head) - (let ((defs (and (intset-ref singly-referenced k) - (intmap-ref defs label)))) - (if defs - (fold (lambda (def var var-substs) - (intmap-add var-substs def var)) - var-substs defs vars) - var-substs)))))))))) - (_ (values equiv-labels var-substs)))) + (define (visit-label label equiv-labels var-substs) + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src exp)) + (let* ((exp-key (compute-exp-key var-substs exp)) + (equiv (hash-ref equiv-set exp-key '())) + (fx (intmap-ref effects label)) + (avail (intmap-ref avail label))) + (define (finish equiv-labels var-substs) + ;; If this expression defines auxiliary definitions, + ;; as `cons' does for the results of `car' and `cdr', + ;; define those. Do so after finding equivalent + ;; expressions, so that we can take advantage of + ;; subst'd output vars. + (add-auxiliary-definitions! label var-substs exp-key) + (values equiv-labels var-substs)) + (let lp ((candidates equiv)) + (match candidates + (() + ;; No matching expressions. Add our expression + ;; to the equivalence set, if appropriate. Note + ;; that expressions that allocate a fresh object + ;; or change the current fluid environment can't + ;; be eliminated by CSE (though DCE might do it + ;; if the value proves to be unused, in the + ;; allocation case). + (when (and exp-key + (not (causes-effect? fx &allocation)) + (not (effect-clobbers? fx (&read-object &fluid)))) + (let ((defs (and (intset-ref singly-referenced k) + (intmap-ref defs label)))) + (when defs + (hash-set! equiv-set exp-key + (acons label defs equiv))))) + (finish equiv-labels var-substs)) + (((and head (candidate . vars)) . candidates) + (cond + ((not (intset-ref avail candidate)) + ;; This expression isn't available here; try + ;; the next one. + (lp candidates)) + (else + ;; Yay, a match. Mark expression as equivalent. If + ;; we provide the definitions for the successor, mark + ;; the vars for substitution. + (finish (intmap-add equiv-labels label head) + (let ((defs (and (intset-ref singly-referenced k) + (intmap-ref defs label)))) + (if defs + (fold (lambda (def var var-substs) + (intmap-add var-substs def var)) + var-substs defs vars) + var-substs)))))))))) + (_ (values equiv-labels var-substs)))) - ;; Traverse the labels in fun in reverse post-order, which will - ;; visit definitions before uses first. - (fold2 visit-label - (compute-reverse-post-order succs kfun) - equiv-labels - var-substs))) + ;; Traverse the labels in fun in reverse post-order, which will + ;; visit definitions before uses first. + (fold2 visit-label + (compute-reverse-post-order succs kfun) + equiv-labels + var-substs))) + + (intset-fold visit-fun + (intmap-keys (compute-reachable-functions conts kfun)) + empty-intmap + empty-intmap)) (define (apply-cse conts equiv-labels var-substs truthy-labels) (define (true-idx idx) (ash idx 1)) @@ -391,7 +376,7 @@ false. It could be that both true and false proofs are available." (define (visit-exp exp) (rewrite-exp exp - ((or ($ $const) ($ $prim) ($ $fun) ($ $rec)) ,exp) + ((or ($ $const) ($ $prim) ($ $fun) ($ $rec) ($ $closure)) ,exp) (($ $call proc args) ($call (subst-var proc) ,(map subst-var args))) (($ $callk k proc args) @@ -442,8 +427,7 @@ false. It could be that both true and false proofs are available." (call-with-values (lambda () (let ((effects (synthesize-definition-effects (compute-effects conts)))) - (compute-equivalent-subexpressions conts 0 effects - empty-intmap empty-intmap))) + (compute-equivalent-subexpressions conts 0 effects))) (lambda (equiv-labels var-substs) - (let ((truthy-labels (compute-truthy-expressions conts 0 empty-intmap))) + (let ((truthy-labels (compute-truthy-expressions conts 0))) (apply-cse conts equiv-labels var-substs truthy-labels))))) From 3f345f564f1d27a75bed9664ab6eaf738c19f364 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 28 Oct 2015 10:07:38 +0000 Subject: [PATCH 078/865] Run CSE to clean up after closure conversion * module/language/cps/optimize.scm: Enable CSE over first-order CPS. --- module/language/cps/optimize.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm index 8777222c9..571d5ffd8 100644 --- a/module/language/cps/optimize.scm +++ b/module/language/cps/optimize.scm @@ -105,7 +105,7 @@ (define-optimizer optimize-first-order-cps (hoist-loop-invariant-code #:licm? #t) - ;; FIXME: CSE here to eliminate duplicate free-ref terms. + (eliminate-common-subexpressions #:cse? #t) (eliminate-dead-code #:eliminate-dead-code? #t) (rotate-loops #:rotate-loops? #t) (simplify #:simplify? #t)) From 34f3fb78e09dd3220cfc615ffc0850d1bf344438 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 28 Oct 2015 10:14:30 +0000 Subject: [PATCH 079/865] Fix slot-allocation to make 'return' not need to alloc-frame * module/language/cps/slot-allocation.scm (compute-frame-sizes): Ensure that frames with `return' have space to shuffle the arg into return position. --- module/language/cps/slot-allocation.scm | 3 +++ 1 file changed, 3 insertions(+) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index b3068985c..423da2c4e 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -660,6 +660,9 @@ are comparable with eqv?. A tmp slot may be used." (call-size label (1+ (length args)) size)) (($ $values args) (shuffle-size (get-shuffles label) size)) + (($ $primcall 'return (arg)) + ;; Return will shuffle arg into fp-relative slot 1. + (max size 2)) (_ size))))) (($ $kreceive) (values frame-sizes clause From 7aee3c74f5f31c6f386c75506f43b42c786a41b4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 28 Oct 2015 10:47:18 +0000 Subject: [PATCH 080/865] return-values opcode resets the frame * libguile/vm-engine.c (return-values): Change to also reset the frame, if nlocals is nonzero. * doc/ref/vm.texi (Procedure Call and Return Instructions): Updated docs. * module/language/cps/compile-bytecode.scm (compile-function): Adapt to call emit-return-values with the right number of arguments. --- doc/ref/vm.texi | 7 ++++--- libguile/vm-engine.c | 12 +++++++++--- module/language/cps/compile-bytecode.scm | 4 ++-- 3 files changed, 15 insertions(+), 8 deletions(-) diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index e44f21169..420671adc 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -763,12 +763,13 @@ has run, the values can be copied down via @code{mov}, or used in place. Return a value. @end deftypefn -@deftypefn Instruction {} return-values x24:@var{_} +@deftypefn Instruction {} return-values c24:@var{nlocals} Return a number of values from a call frame. This opcode corresponds to an application of @code{values} in tail position. As with tail calls, we expect that the values have already been shuffled down to a -contiguous array starting at slot 1. We also expect the frame has -already been reset. +contiguous array starting at slot 1. If @var{nlocals} is nonzero, reset +the frame to hold that number of locals. Note that a frame reset to 1 +local returns 0 values. @end deftypefn @deftypefn Instruction {} call/cc x24:@var{_} diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index d5f68578d..45faa1495 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -747,20 +747,26 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, RETURN_ONE_VALUE (SP_REF (src)); } - /* return-values _:24 + /* return-values nlocals:24 * * Return a number of values from a call frame. This opcode * corresponds to an application of `values' in tail position. As * with tail calls, we expect that the values have already been * shuffled down to a contiguous array starting at slot 1. - * We also expect the frame has already been reset. + * If NLOCALS is not zero, we also reset the frame to hold NLOCALS + * values. */ - VM_DEFINE_OP (9, return_values, "return-values", OP1 (X32)) + VM_DEFINE_OP (9, return_values, "return-values", OP1 (X8_C24)) { union scm_vm_stack_element *old_fp; + scm_t_uint32 nlocals; VM_HANDLE_INTERRUPTS; + UNPACK_24 (op, nlocals); + if (nlocals) + RESET_FRAME (nlocals); + old_fp = vp->fp; ip = SCM_FRAME_RETURN_ADDRESS (vp->fp); vp->fp = SCM_FRAME_DYNAMIC_LINK (vp->fp); diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 86c9d307d..838fd4d07 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -124,7 +124,7 @@ (emit-tail-call-label asm (1+ (length args)) k)) (($ $values ()) (emit-reset-frame asm 1) - (emit-return-values asm)) + (emit-return-values asm 1)) (($ $values (arg)) (if (maybe-slot arg) (emit-return asm (from-sp (slot arg))) @@ -138,7 +138,7 @@ ((src . dst) (emit-mov asm (from-sp dst) (from-sp src)))) (lookup-parallel-moves label allocation)) (emit-reset-frame asm (1+ (length args))) - (emit-return-values asm)) + (emit-return-values asm (1+ (length args)))) (($ $primcall 'return (arg)) (emit-return asm (from-sp (slot arg)))))) From 7c9e477b82377834d126dcc6294922b8de9722bd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 28 Oct 2015 11:00:05 +0000 Subject: [PATCH 081/865] Don't emit redundant reset-frame before return * module/language/cps/compile-bytecode.scm (compile-function): Don't emit reset-frame before return-values. --- module/language/cps/compile-bytecode.scm | 2 -- 1 file changed, 2 deletions(-) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 838fd4d07..a313da7c6 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -123,7 +123,6 @@ (lookup-parallel-moves label allocation)) (emit-tail-call-label asm (1+ (length args)) k)) (($ $values ()) - (emit-reset-frame asm 1) (emit-return-values asm 1)) (($ $values (arg)) (if (maybe-slot arg) @@ -137,7 +136,6 @@ (for-each (match-lambda ((src . dst) (emit-mov asm (from-sp dst) (from-sp src)))) (lookup-parallel-moves label allocation)) - (emit-reset-frame asm (1+ (length args))) (emit-return-values asm (1+ (length args)))) (($ $primcall 'return (arg)) (emit-return asm (from-sp (slot arg)))))) From 2f08838cd66d67b1c6a58eb426f445ff6aa9eec5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 28 Oct 2015 11:11:23 +0000 Subject: [PATCH 082/865] Replace return primcalls with $values * module/language/cps/compile-bytecode.scm: * module/language/cps/contification.scm: * module/language/cps/slot-allocation.scm: * module/language/cps/type-fold.scm: * module/language/cps/verify.scm: * module/language/tree-il/compile-cps.scm: Never generate a return primcall. Instead use $values. --- module/language/cps/compile-bytecode.scm | 4 +--- module/language/cps/contification.scm | 7 ++----- module/language/cps/slot-allocation.scm | 3 --- module/language/cps/type-fold.scm | 2 +- module/language/cps/verify.scm | 4 +--- module/language/tree-il/compile-cps.scm | 4 ++-- 6 files changed, 7 insertions(+), 17 deletions(-) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index a313da7c6..22af8219e 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -136,9 +136,7 @@ (for-each (match-lambda ((src . dst) (emit-mov asm (from-sp dst) (from-sp src)))) (lookup-parallel-moves label allocation)) - (emit-return-values asm (1+ (length args)))) - (($ $primcall 'return (arg)) - (emit-return asm (from-sp (slot arg)))))) + (emit-return-values asm (1+ (length args)))))) (define (compile-value label exp dst) (match exp diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm index 4a398d7e5..c08cfbc2e 100644 --- a/module/language/cps/contification.scm +++ b/module/language/cps/contification.scm @@ -415,12 +415,9 @@ function set." ,(match (intmap-ref conts k*) (($ $kreceive) (match exp - (($ $primcall 'return (val)) - (build-exp ($primcall 'values (val)))) (($ $call) exp) - ;; Except for 'return, a primcall that can continue - ;; to $ktail can also continue to $kreceive. TODO: - ;; replace 'return with 'values, for consistency. + ;; A primcall that can continue to $ktail can also + ;; continue to $kreceive. (($ $primcall) exp) (($ $values vals) (build-exp ($primcall 'values vals))))) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 423da2c4e..b3068985c 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -660,9 +660,6 @@ are comparable with eqv?. A tmp slot may be used." (call-size label (1+ (length args)) size)) (($ $values args) (shuffle-size (get-shuffles label) size)) - (($ $primcall 'return (arg)) - ;; Return will shuffle arg into fp-relative slot 1. - (max size 2)) (_ size))))) (($ $kreceive) (values frame-sizes clause diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm index 2104b09ef..e7a343b05 100644 --- a/module/language/cps/type-fold.scm +++ b/module/language/cps/type-fold.scm @@ -276,7 +276,7 @@ (with-cps cps (letv bool) (letk kbool ($kargs (#f) (bool) - ($continue k src ($primcall 'return (bool))))) + ($continue k src ($values (bool))))) ($ (convert-to-logtest kbool))))) (with-cps cps #f)))) diff --git a/module/language/cps/verify.scm b/module/language/cps/verify.scm index f4413af0d..1a9eb72e3 100644 --- a/module/language/cps/verify.scm +++ b/module/language/cps/verify.scm @@ -258,9 +258,7 @@ definitions that are available at LABEL." (when (false-if-exception (prim-arity name)) (error "primitive should continue to $kargs, not $kreceive" name))) (($ $ktail) - (unless (eq? name 'return) - (when (false-if-exception (prim-arity name)) - (error "primitive should continue to $kargs, not $ktail" name)))))) + (error "primitive should continue to $kargs, not $ktail" name)))) (($ $prompt escape? tag handler) (assert-nullary) (match (intmap-ref conts handler) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 7f34e6b48..0664b2c4d 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -249,7 +249,7 @@ (with-cps cps (let$ body (with-cps-constants ((unspecified *unspecified*)) (build-term - ($continue k src ($primcall 'return (unspecified)))))) + ($continue k src ($values (unspecified)))))) (letk kvoid ($kargs () () ,body)) kvoid)) (($ $kreceive arity kargs) @@ -287,7 +287,7 @@ (with-cps cps (letv val) (letk kval ($kargs ('val) (val) - ($continue k src ($primcall 'return (val))))) + ($continue k src ($values (val))))) kval)) (($ $kreceive arity kargs) (match arity From 696339a603b08d2b6a8f87482f63ef41358988e7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 28 Oct 2015 11:20:00 +0000 Subject: [PATCH 083/865] Always emit return-values * module/language/cps/compile-bytecode.scm (compile-function): Remove special cases for nullary and unary returns; instead always use return-values and rely on hinting to try to place values in the right slot already. * module/system/vm/assembler.scm (emit-init-constants): Use return-values. * module/system/vm/disassembler.scm (code-annotation): Add annotation for return-values. --- module/language/cps/compile-bytecode.scm | 10 ---------- module/system/vm/assembler.scm | 4 ++-- module/system/vm/disassembler.scm | 4 ++++ 3 files changed, 6 insertions(+), 12 deletions(-) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 22af8219e..1f7c66422 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -122,16 +122,6 @@ ((src . dst) (emit-mov asm (from-sp dst) (from-sp src)))) (lookup-parallel-moves label allocation)) (emit-tail-call-label asm (1+ (length args)) k)) - (($ $values ()) - (emit-return-values asm 1)) - (($ $values (arg)) - (if (maybe-slot arg) - (emit-return asm (from-sp (slot arg))) - (begin - (when (< frame-size 2) - (emit-alloc-frame asm 2)) - (emit-load-constant asm (from-sp 1) (constant arg)) - (emit-return asm (from-sp 1))))) (($ $values args) (for-each (match-lambda ((src . dst) (emit-mov asm (from-sp dst) (from-sp src)))) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index d50ab13b5..c989ec6b7 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -1243,8 +1243,8 @@ a procedure to do that and return its label. Otherwise return `((begin-program ,label ()) (assert-nargs-ee/locals 1 1) ,@(reverse inits) - (load-constant 1 ,*unspecified*) - (return 1) + (load-constant 0 ,*unspecified*) + (return-values 2) (end-program))) label)))) diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index 233ba759b..5e8b0207c 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -224,6 +224,10 @@ address of that offset." (list "~a slot~:p" nlocals)) (('reset-frame nlocals) (list "~a slot~:p" nlocals)) + (('return-values nlocals) + (if (zero? nlocals) + (list "all values") + (list "~a value~:p" (1- nlocals)))) (('bind-rest dst) (list "~a slot~:p" (1+ dst))) (('tail-call nargs proc) From 8db54c80ceaa5ae4e2a6047028dd1ec3304e7f15 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 28 Oct 2015 11:33:17 +0000 Subject: [PATCH 084/865] rtl.test uses return-values * test-suite/tests/rtl.test: Fix up to use return-values. --- test-suite/tests/rtl.test | 71 ++++++++++++++++++++------------------- 1 file changed, 37 insertions(+), 34 deletions(-) diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test index 952916963..872c5f1ff 100644 --- a/test-suite/tests/rtl.test +++ b/test-suite/tests/rtl.test @@ -1,6 +1,6 @@ ;;;; Low-level tests of the bytecode assembler -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014, 2015 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 @@ -41,7 +41,7 @@ a procedure." ((name . foo))) (begin-standard-arity () 2 #f) (load-constant 0 ,val) - (return 0) + (return-values 2) (end-arity) (end-program)))) @@ -83,14 +83,14 @@ a procedure." ((name . foo))) (begin-standard-arity () 2 #f) (load-static-procedure 0 bar) - (return 0) + (return-values 2) (end-arity) (end-program) (begin-program bar ((name . bar))) (begin-standard-arity () 2 #f) (load-constant 0 42) - (return 0) + (return-values 2) (end-arity) (end-program))))))) @@ -116,7 +116,8 @@ a procedure." (load-constant 0 0) (br loop-head) (label out) - (return 0) + (mov 2 0) + (return-values 2) (end-arity) (end-program))))) (sumto 1000)))) @@ -135,7 +136,8 @@ a procedure." (box 1 1) (make-closure 0 accum 1) (free-set! 0 1 0) - (return 0) + (mov 1 0) + (return-values 2) (end-arity) (end-program) (begin-program accum @@ -146,7 +148,8 @@ a procedure." (box-ref 0 1) (add 0 0 2) (box-set! 1 0) - (return 0) + (mov 2 0) + (return-values 2) (end-arity) (end-program))))) (let ((accum (make-accum))) @@ -164,8 +167,8 @@ a procedure." (definition f 1) (mov 1 5) (call 5 1) - (receive 2 5 7) - (return 4) + (receive 1 5 7) + (return-values 2) (end-arity) (end-program))))) (call (lambda () 42)))) @@ -180,8 +183,8 @@ a procedure." (mov 1 5) (load-constant 0 3) (call 5 2) - (receive 2 5 7) - (return 4) + (receive 1 5 7) + (return-values 2) (end-arity) (end-program))))) (call-with-3 (lambda (x) (* x 2)))))) @@ -224,7 +227,7 @@ a procedure." (current-module 0) (cache-current-module! 0 sqrt-scope) (load-static-procedure 0 sqrt-trampoline) - (return 0) + (return-values 2) (end-arity) (end-program) @@ -252,7 +255,7 @@ a procedure." (current-module 0) (cache-current-module! 0 top-incrementor) (load-static-procedure 0 top-incrementor) - (return 0) + (return-values 2) (end-arity) (end-program) @@ -263,8 +266,7 @@ a procedure." (box-ref 0 1) (add1 0 0) (box-set! 1 0) - (reset-frame 1) - (return-values) + (return-values 1) (end-arity) (end-program))))) ((make-top-incrementor)) @@ -278,7 +280,7 @@ a procedure." ((name . get-sqrt-trampoline))) (begin-standard-arity () 2 #f) (load-static-procedure 0 sqrt-trampoline) - (return 0) + (return-values 2) (end-arity) (end-program) @@ -302,7 +304,7 @@ a procedure." ((name . make-top-incrementor))) (begin-standard-arity () 2 #f) (load-static-procedure 0 top-incrementor) - (return 0) + (return-values 2) (end-arity) (end-program) @@ -313,7 +315,8 @@ a procedure." (box-ref 0 1) (add1 0 0) (box-set! 1 0) - (return 0) + (mov 1 0) + (return-values 2) (end-arity) (end-program))))) ((make-top-incrementor)) @@ -324,7 +327,7 @@ a procedure." '((begin-program return-3 ((name . return-3))) (begin-standard-arity () 2 #f) (load-constant 0 3) - (return 0) + (return-values 2) (end-arity) (end-program))))) (pass-if "program name" @@ -346,7 +349,7 @@ a procedure." '((begin-program foo ((name . foo))) (begin-standard-arity () 2 #f) (load-constant 0 42) - (return 0) + (return-values 2) (end-arity) (end-program)))))) @@ -357,7 +360,7 @@ a procedure." '((begin-program foo ((name . foo))) (begin-standard-arity () 2 #f) (load-constant 0 42) - (return 0) + (return-values 2) (end-arity) (end-program))))) (pass-if-equal "#" @@ -368,7 +371,7 @@ a procedure." (definition x 1) (definition y 2) (load-constant 1 42) - (return 1) + (return-values 2) (end-arity) (end-program))))) @@ -380,8 +383,8 @@ a procedure." (definition x 1) (definition y 2) (definition z 3) - (load-constant 1 42) - (return 1) + (load-constant 2 42) + (return-values 2) (end-arity) (end-program)))))) @@ -391,8 +394,8 @@ a procedure." (assemble-program '((begin-program foo ((name . foo) (documentation . "qux qux"))) (begin-standard-arity () 2 #f) - (load-constant 1 42) - (return 1) + (load-constant 0 42) + (return-values 2) (end-arity) (end-program)))))) @@ -403,8 +406,8 @@ a procedure." (assemble-program '((begin-program foo ()) (begin-standard-arity () 2 #f) - (load-constant 1 42) - (return 1) + (load-constant 0 42) + (return-values 2) (end-arity) (end-program))))) @@ -415,8 +418,8 @@ a procedure." (assemble-program '((begin-program foo ((name . foo) (documentation . "qux qux"))) (begin-standard-arity () 2 #f) - (load-constant 1 42) - (return 1) + (load-constant 0 42) + (return-values 2) (end-arity) (end-program))))) @@ -430,8 +433,8 @@ a procedure." (documentation . "qux qux") (moo . "mooooooooooooo"))) (begin-standard-arity () 2 #f) - (load-constant 1 42) - (return 1) + (load-constant 0 42) + (return-values 2) (end-arity) (end-program))))) @@ -443,7 +446,7 @@ a procedure." (documentation . "qux qux") (moo . "mooooooooooooo"))) (begin-standard-arity () 2 #f) - (load-constant 1 42) - (return 1) + (load-constant 0 42) + (return-values 2) (end-arity) (end-program)))))) From c984432f60cf41f6b2e9fa3569000c15d8193526 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 28 Oct 2015 13:11:20 +0000 Subject: [PATCH 085/865] Remove use of return in disassembler.scm * module/system/vm/disassembler.scm (instruction-has-fallthrough?): Remove return from static opcode set. --- module/system/vm/disassembler.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index 5e8b0207c..f718a4c84 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -514,7 +514,7 @@ address of that offset." (define non-fallthrough-set (static-opcode-set halt tail-call tail-call-label tail-call/shuffle - return return-values + return-values subr-call foreign-call continuation-call tail-apply br)) From 95855087ec3d04ec0980cc2cdcc283c4c7bc20b0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 28 Oct 2015 13:11:40 +0000 Subject: [PATCH 086/865] Remove return opcode * libguile/vm-engine.c (return): Remove opcode. --- libguile/vm-engine.c | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 45faa1495..7919c4615 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -736,15 +736,10 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (2); } - /* return src:24 - * - * Return a value. - */ - VM_DEFINE_OP (8, return, "return", OP1 (X8_S24)) + VM_DEFINE_OP (8, unused_8, NULL, NOP) { - scm_t_uint32 src; - UNPACK_24 (op, src); - RETURN_ONE_VALUE (SP_REF (src)); + vm_error_bad_instruction (op); + abort (); /* never reached */ } /* return-values nlocals:24 From dd77a818ba6aefc98a78d03dec61454546992671 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 28 Oct 2015 13:33:37 +0000 Subject: [PATCH 087/865] Treat tail $values as generating lazy allocations * module/language/cps/slot-allocation.scm (compute-lazy-vars): Returning values in tail position also generates lazy vars. --- module/language/cps/slot-allocation.scm | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index b3068985c..1e349eea2 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -376,6 +376,10 @@ is an active call." (($ $kargs _ _ ($ $continue _ _ ($ $callk _ proc args))) (intset-subtract (intset-add (list->intset args) proc) (intmap-ref live-out label))) + (($ $kargs _ _ ($ $continue k _($ $values args))) + (match (intmap-ref cps k) + (($ $ktail) (list->intset args)) + (_ #f))) (_ #f))) cps)) (kills (intmap-map From e7660a607cabdb0061784ada2869e47db946275b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 28 Oct 2015 16:40:53 +0000 Subject: [PATCH 088/865] VM support for raw slots * libguile/loader.c (scm_find_slot_map_unlocked): Rename from scm_find_dead_slot_map_unlocked. * libguile/vm.c (struct slot_map_cache_entry, struct slot_map_cache) (find_slot_map): Rename, changing "dead_slot" to "slot". (enum slot_desc): New type. (scm_i_vm_mark_stack): Interpret slot maps as having two bits per slot, allowing us to indicate that a slot is live but not a pointer. * module/language/cps/compile-bytecode.scm (compile-function): Adapt to emit-slot-map name change. * module/system/vm/assembler.scm (): Rename dead-slot-maps field to slot-maps. (emit-slot-map): Rename from emit-dead-slot-map. (link-frame-maps): 2 bits per slot. * module/language/cps/slot-allocation.scm (lookup-slot-map): Rename from lookup-dead-slot-map. (compute-var-representations): New function. (allocate-slots): Adapt to encode two-bit slot representations. --- doc/ref/vm.texi | 4 ++ libguile/loader.c | 4 +- libguile/loader.h | 4 +- libguile/vm.c | 77 ++++++++++++--------- module/language/cps/compile-bytecode.scm | 3 +- module/language/cps/slot-allocation.scm | 85 ++++++++++++++++++++---- module/system/vm/assembler.scm | 26 ++++---- 7 files changed, 139 insertions(+), 64 deletions(-) diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 420671adc..f97a009b5 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -427,6 +427,10 @@ A table mapping addresses in the @code{.rtl-text} to procedure names. @itemx .guile.docstrs @itemx .guile.docstrs.strtab Side tables of procedure properties, arities, and docstrings. +@item .guile.docstrs.strtab +Side table of frame maps, describing the set of live slots for ever +return point in the program text, and whether those slots are pointers +are not. Used by the garbage collector. @item .debug_info @itemx .debug_abbrev @itemx .debug_str diff --git a/libguile/loader.c b/libguile/loader.c index a55bd15b0..97effb30d 100644 --- a/libguile/loader.c +++ b/libguile/loader.c @@ -1,5 +1,5 @@ /* Copyright (C) 2001, 2009, 2010, 2011, 2012 - * 2013, 2014 Free Software Foundation, Inc. + * 2013, 2014, 2015 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 License @@ -748,7 +748,7 @@ verify (sizeof (struct frame_map_prefix) == 8); verify (sizeof (struct frame_map_header) == 8); const scm_t_uint8 * -scm_find_dead_slot_map_unlocked (const scm_t_uint32 *ip) +scm_find_slot_map_unlocked (const scm_t_uint32 *ip) { struct mapped_elf_image *image; char *base; diff --git a/libguile/loader.h b/libguile/loader.h index 6fd950279..5c719cbce 100644 --- a/libguile/loader.h +++ b/libguile/loader.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014, 2015 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 License @@ -25,7 +25,7 @@ SCM_API SCM scm_load_thunk_from_file (SCM filename); SCM_API SCM scm_load_thunk_from_memory (SCM bv); SCM_INTERNAL const scm_t_uint8 * -scm_find_dead_slot_map_unlocked (const scm_t_uint32 *ip); +scm_find_slot_map_unlocked (const scm_t_uint32 *ip); SCM_INTERNAL void scm_bootstrap_loader (void); SCM_INTERNAL void scm_init_loader (void); diff --git a/libguile/vm.c b/libguile/vm.c index 9d9cc3129..5ea6b2bd4 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -895,31 +895,31 @@ return_unused_stack_to_os (struct scm_vm *vp) #endif } -#define DEAD_SLOT_MAP_CACHE_SIZE 32U -struct dead_slot_map_cache_entry +#define SLOT_MAP_CACHE_SIZE 32U +struct slot_map_cache_entry { scm_t_uint32 *ip; const scm_t_uint8 *map; }; -struct dead_slot_map_cache +struct slot_map_cache { - struct dead_slot_map_cache_entry entries[DEAD_SLOT_MAP_CACHE_SIZE]; + struct slot_map_cache_entry entries[SLOT_MAP_CACHE_SIZE]; }; static const scm_t_uint8 * -find_dead_slot_map (scm_t_uint32 *ip, struct dead_slot_map_cache *cache) +find_slot_map (scm_t_uint32 *ip, struct slot_map_cache *cache) { /* The lower two bits should be zero. FIXME: Use a better hash function; we don't expose scm_raw_hashq currently. */ - size_t slot = (((scm_t_uintptr) ip) >> 2) % DEAD_SLOT_MAP_CACHE_SIZE; + size_t slot = (((scm_t_uintptr) ip) >> 2) % SLOT_MAP_CACHE_SIZE; const scm_t_uint8 *map; if (cache->entries[slot].ip == ip) map = cache->entries[slot].map; else { - map = scm_find_dead_slot_map_unlocked (ip); + map = scm_find_slot_map_unlocked (ip); cache->entries[slot].ip = ip; cache->entries[slot].map = map; } @@ -927,21 +927,29 @@ find_dead_slot_map (scm_t_uint32 *ip, struct dead_slot_map_cache *cache) return map; } +enum slot_desc + { + SLOT_DESC_DEAD = 0, + SLOT_DESC_LIVE_RAW = 1, + SLOT_DESC_LIVE_SCM = 2, + SLOT_DESC_UNUSED = 3 + }; + /* Mark the active VM stack region. */ struct GC_ms_entry * scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr, struct GC_ms_entry *mark_stack_limit) { union scm_vm_stack_element *sp, *fp; - /* The first frame will be marked conservatively (without a dead - slot map). This is because GC can happen at any point within the - hottest activation, due to multiple threads or per-instruction - hooks, and providing dead slot maps for all points in a program - would take a prohibitive amount of space. */ - const scm_t_uint8 *dead_slots = NULL; + /* The first frame will be marked conservatively (without a slot map). + This is because GC can happen at any point within the hottest + activation, due to multiple threads or per-instruction hooks, and + providing slot maps for all points in a program would take a + prohibitive amount of space. */ + const scm_t_uint8 *slot_map = NULL; void *upper = (void *) GC_greatest_plausible_heap_addr; void *lower = (void *) GC_least_plausible_heap_addr; - struct dead_slot_map_cache cache; + struct slot_map_cache cache; memset (&cache, 0, sizeof (cache)); @@ -953,24 +961,29 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr, size_t slot = nlocals - 1; for (slot = nlocals - 1; sp < fp; sp++, slot--) { - if (SCM_NIMP (sp->as_scm) && - sp->as_ptr >= lower && sp->as_ptr <= upper) - { - if (dead_slots) - { - if (dead_slots[slot / 8U] & (1U << (slot % 8U))) - { - /* This value may become dead as a result of GC, - so we can't just leave it on the stack. */ - sp->as_scm = SCM_UNSPECIFIED; - continue; - } - } + enum slot_desc desc = SLOT_DESC_LIVE_SCM; - mark_stack_ptr = GC_mark_and_push (sp->as_ptr, - mark_stack_ptr, - mark_stack_limit, - NULL); + if (slot_map) + desc = (slot_map[slot / 4U] >> ((slot % 4U) * 2)) & 3U; + + switch (desc) + { + case SLOT_DESC_LIVE_RAW: + break; + case SLOT_DESC_UNUSED: + case SLOT_DESC_LIVE_SCM: + if (SCM_NIMP (sp->as_scm) && + sp->as_ptr >= lower && sp->as_ptr <= upper) + mark_stack_ptr = GC_mark_and_push (sp->as_ptr, + mark_stack_ptr, + mark_stack_limit, + NULL); + break; + case SLOT_DESC_DEAD: + /* This value may become dead as a result of GC, + so we can't just leave it on the stack. */ + sp->as_scm = SCM_UNSPECIFIED; + break; } } sp = SCM_FRAME_PREVIOUS_SP (fp); @@ -978,7 +991,7 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct GC_ms_entry *mark_stack_ptr, Note that there may be other reasons to not have a dead slots map, e.g. if all of the frame's slots below the callee frame are live. */ - dead_slots = find_dead_slot_map (SCM_FRAME_RETURN_ADDRESS (fp), &cache); + slot_map = find_slot_map (SCM_FRAME_RETURN_ADDRESS (fp), &cache); } return_unused_stack_to_os (vp); diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 1f7c66422..6830d753b 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -379,8 +379,7 @@ ((src . dst) (emit-mov asm (from-sp dst) (from-sp src)))) (lookup-parallel-moves label allocation)) (emit-call asm proc-slot nargs) - (emit-dead-slot-map asm proc-slot - (lookup-dead-slot-map label allocation)) + (emit-slot-map asm proc-slot (lookup-slot-map label allocation)) (cond ((and (= 1 nreq) (and rest-var) (not (maybe-slot rest-var)) (match (lookup-parallel-moves k allocation) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 1e349eea2..9189d86a0 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -40,7 +40,7 @@ lookup-nlocals lookup-call-proc-slot lookup-parallel-moves - lookup-dead-slot-map)) + lookup-slot-map)) (define-record-type $allocation (make-allocation slots constant-values call-allocs shuffles frame-sizes) @@ -84,10 +84,10 @@ (frame-sizes allocation-frame-sizes)) (define-record-type $call-alloc - (make-call-alloc proc-slot dead-slot-map) + (make-call-alloc proc-slot slot-map) call-alloc? (proc-slot call-alloc-proc-slot) - (dead-slot-map call-alloc-dead-slot-map)) + (slot-map call-alloc-slot-map)) (define (lookup-maybe-slot var allocation) (intmap-ref (allocation-slots allocation) var (lambda (_) #f))) @@ -121,9 +121,9 @@ (define (lookup-parallel-moves k allocation) (intmap-ref (allocation-shuffles allocation) k)) -(define (lookup-dead-slot-map k allocation) - (or (call-alloc-dead-slot-map (lookup-call-alloc k allocation)) - (error "Call has no dead slot map" k))) +(define (lookup-slot-map k allocation) + (or (call-alloc-slot-map (lookup-call-alloc k allocation)) + (error "Call has no slot map" k))) (define (lookup-nlocals k allocation) (intmap-ref (allocation-frame-sizes allocation) k)) @@ -764,8 +764,52 @@ are comparable with eqv?. A tmp slot may be used." (persistent-intmap (intmap-fold-right allocate-lazy cps slots))) +(define (compute-var-representations cps) + (define (get-defs k) + (match (intmap-ref cps k) + (($ $kargs names vars) vars) + (_ '()))) + (intmap-fold + (lambda (label cont representations) + (match cont + (($ $kargs _ _ ($ $continue k _ exp)) + (match (get-defs k) + (() representations) + ((var) + (match exp + (($ $values (arg)) + (intmap-add representations var + (intmap-ref representations arg))) + ;; FIXME: Placeholder for as-yet-unwritten primitive + ;; operations that define unboxed f64 values. + (($ $primcall 'scm->f64) + (intmap-add representations var 'f64)) + (_ + (intmap-add representations var 'scm)))) + (vars + (match exp + (($ $values args) + (fold (lambda (arg var representations) + (intmap-add representations var + (intmap-ref representations arg))) + representations args vars)))))) + (($ $kfun src meta self) + (intmap-add representations self 'scm)) + (($ $kclause arity body alt) + (fold1 (lambda (var representations) + (intmap-add representations var 'scm)) + (get-defs body) representations)) + (($ $kreceive arity kargs) + (fold1 (lambda (var representations) + (intmap-add representations var 'scm)) + (get-defs kargs) representations)) + (($ $ktail) representations))) + cps + empty-intmap)) + (define (allocate-slots cps) (let*-values (((defs uses) (compute-defs-and-uses cps)) + ((representations) (compute-var-representations cps)) ((live-in live-out) (compute-live-variables cps defs uses)) ((constants) (compute-constant-values cps)) ((needs-slot) (compute-needs-slot cps defs uses)) @@ -809,6 +853,23 @@ are comparable with eqv?. A tmp slot may be used." (define (compute-live-out-slots slots label) (compute-live-slots* slots label live-out)) + (define slot-desc-dead 0) + (define slot-desc-live-raw 1) + (define slot-desc-live-scm 2) + (define slot-desc-unused 3) + + (define (compute-slot-map slots live-vars nslots) + (intset-fold + (lambda (var slot-map) + (match (get-slot slots var) + (#f slot-map) + (slot + (let ((desc (match (intmap-ref representations var) + ('f64 slot-desc-live-raw) + ('scm slot-desc-live-scm)))) + (logior slot-map (ash desc (* 2 slot))))))) + live-vars 0)) + (define (allocate var hint slots live) (cond ((not (intset-ref needs-slot var)) @@ -874,9 +935,9 @@ are comparable with eqv?. A tmp slot may be used." (let ((result-slots (integers (+ proc-slot 2) (length results)))) (allocate* results result-slots slots post-live))))) - ((dead-slot-map) (logand (1- (ash 1 (- proc-slot 2))) - (lognot post-live))) - ((call) (make-call-alloc proc-slot dead-slot-map))) + ((slot-map) (compute-slot-map slots (intmap-ref live-out label) + (- proc-slot 2))) + ((call) (make-call-alloc proc-slot slot-map))) (values slots (intmap-add! call-allocs label call)))))) @@ -909,8 +970,8 @@ are comparable with eqv?. A tmp slot may be used." (let*-values (((handler-live) (compute-live-in-slots slots handler)) ((proc-slot) (compute-prompt-handler-proc-slot handler-live)) - ((dead-slot-map) (logand (1- (ash 1 (- proc-slot 2))) - (lognot handler-live))) + ((slot-map) (compute-slot-map slots (intmap-ref live-in handler) + (- proc-slot 2))) ((result-vars) (match (get-cont kargs) (($ $kargs names vars) vars))) ((value-slots) (integers (1+ proc-slot) (length result-vars))) @@ -918,7 +979,7 @@ are comparable with eqv?. A tmp slot may be used." slots handler-live))) (values slots (intmap-add! call-allocs label - (make-call-alloc proc-slot dead-slot-map))))))) + (make-call-alloc proc-slot slot-map))))))) (define (allocate-cont label cont slots call-allocs) (match cont diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index c989ec6b7..379539f6a 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -326,7 +326,7 @@ constants inits shstrtab next-section-number meta sources - dead-slot-maps) + slot-maps) asm? ;; We write bytecode into what is logically a growable vector, @@ -404,12 +404,11 @@ ;; (sources asm-sources set-asm-sources!) - ;; A list of (pos . dead-slot-map) pairs, indicating dead slot maps. - ;; POS is relative to the beginning of the text section. - ;; DEAD-SLOT-MAP is a bitfield of slots that are dead at call sites, - ;; as an integer. + ;; A list of (pos . slot-map) pairs, indicating slot maps. POS is + ;; relative to the beginning of the text section. SLOT-MAP is a + ;; bitfield describing the stack at call sites, as an integer. ;; - (dead-slot-maps asm-dead-slot-maps set-asm-dead-slot-maps!)) + (slot-maps asm-slot-maps set-asm-slot-maps!)) (define-inline (fresh-block) (make-u32vector *block-size*)) @@ -1187,12 +1186,11 @@ returned instead." (cell-label (intern-cache-cell asm key sym))) (emit-module-box asm dst cell-label mod-name-label sym-label bound?))) -(define-macro-assembler (dead-slot-map asm proc-slot dead-slot-map) - (unless (zero? dead-slot-map) - (set-asm-dead-slot-maps! asm - (cons - (cons* (asm-start asm) proc-slot dead-slot-map) - (asm-dead-slot-maps asm))))) +(define-macro-assembler (slot-map asm proc-slot slot-map) + (unless (zero? slot-map) + (set-asm-slot-maps! asm (cons + (cons* (asm-start asm) proc-slot slot-map) + (asm-slot-maps asm))))) @@ -1605,7 +1603,7 @@ needed." (define (link-frame-maps asm) (define (map-byte-length proc-slot) - (ceiling-quotient (- proc-slot 2) 8)) + (ceiling-quotient (* 2 (- proc-slot 2)) 8)) (define (make-frame-maps maps count map-len) (let* ((endianness (asm-endianness asm)) (header-pos frame-maps-prefix-len) @@ -1630,7 +1628,7 @@ needed." (bytevector-u8-set! bv map-pos (logand map #xff)) (write-bytes (1+ map-pos) (ash map -8) (1- byte-length)))))))))) - (match (asm-dead-slot-maps asm) + (match (asm-slot-maps asm) (() #f) (in (let lp ((in in) (out '()) (count 0) (map-len 0)) From e3cc0eeb3a9c94f018540e659c4686f5e986b48c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 28 Oct 2015 17:03:42 +0000 Subject: [PATCH 089/865] Reflection support for unboxed f64 slots * module/system/vm/assembler.scm (emit-definition): Add representation field. (write-arities): Emit representations into the arities section. * module/system/vm/debug.scm (arity-definitions): Read representations. * module/system/vm/frame.scm (): Add representation field and binding-representation getter. (available-bindings): Pass representation to make-binding. (frame-binding-set!, frame-binding-ref, frame-call-representation): Pass representation to frame-local-ref / frame-local-set!. * test-suite/tests/rtl.test: Update definition instructions. * module/language/cps/slot-allocation.scm ($allocation): Add representations field. (lookup-representation): New public function. (allocate-slots): Pass representations to make-$allocation. * module/language/cps/compile-bytecode.scm (compile-function): Adapt to emit-definition change. * libguile/frames.h: * libguile/frames.c (scm_frame_local_ref, scm_frame_local_set_x): Take representation argument. (scm_to_stack_item_representation): New internal helper. --- libguile/frames.c | 93 +++++++++++++++++------- libguile/frames.h | 5 +- module/language/cps/compile-bytecode.scm | 3 +- module/language/cps/slot-allocation.scm | 15 +++- module/system/repl/debug.scm | 6 +- module/system/vm/assembler.scm | 15 ++-- module/system/vm/debug.scm | 13 +++- module/system/vm/frame.scm | 50 +++++++------ test-suite/tests/rtl.test | 26 +++---- 9 files changed, 149 insertions(+), 77 deletions(-) diff --git a/libguile/frames.c b/libguile/frames.c index a1c7f3e71..d522e762a 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -220,45 +220,88 @@ SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 2, 0, 0, - (SCM frame, SCM index), +enum stack_item_representation + { + STACK_ITEM_SCM = 0, + STACK_ITEM_F64 = 1 + }; + +static enum stack_item_representation +scm_to_stack_item_representation (SCM x, const char *subr, int pos) +{ + if (scm_is_eq (x, scm_from_latin1_symbol ("scm"))) + return STACK_ITEM_SCM; + if (scm_is_eq (x, scm_from_latin1_symbol ("f64"))) + return STACK_ITEM_F64; + + scm_wrong_type_arg (subr, pos, x); + return 0; /* Not reached. */ +} + +SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 3, 0, 0, + (SCM frame, SCM index, SCM representation), "") #define FUNC_NAME s_scm_frame_local_ref { union scm_vm_stack_element *fp, *sp; unsigned int i; + enum stack_item_representation repr; SCM_VALIDATE_VM_FRAME (1, frame); SCM_VALIDATE_UINT_COPY (2, index, i); - - fp = SCM_VM_FRAME_FP (frame); - sp = SCM_VM_FRAME_SP (frame); - - if (i < SCM_FRAME_NUM_LOCALS (fp, sp)) - return SCM_FRAME_LOCAL (fp, i); - - SCM_OUT_OF_RANGE (SCM_ARG2, index); -} -#undef FUNC_NAME - -/* Need same not-yet-active frame logic here as in frame-num-locals */ -SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3, 0, 0, - (SCM frame, SCM index, SCM val), - "") -#define FUNC_NAME s_scm_frame_local_set_x -{ - union scm_vm_stack_element *fp, *sp; - unsigned int i; - - SCM_VALIDATE_VM_FRAME (1, frame); - SCM_VALIDATE_UINT_COPY (2, index, i); + repr = scm_to_stack_item_representation (representation, FUNC_NAME, SCM_ARG3); fp = SCM_VM_FRAME_FP (frame); sp = SCM_VM_FRAME_SP (frame); if (i < SCM_FRAME_NUM_LOCALS (fp, sp)) { - SCM_FRAME_LOCAL (fp, i) = val; + union scm_vm_stack_element *item = SCM_FRAME_SLOT (fp, i); + switch (repr) + { + case STACK_ITEM_SCM: + return item->as_scm; + case STACK_ITEM_F64: + /* return item->as_f64; */ + default: + abort(); + } + } + + SCM_OUT_OF_RANGE (SCM_ARG2, index); +} +#undef FUNC_NAME + +/* Need same not-yet-active frame logic here as in frame-num-locals */ +SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 4, 0, 0, + (SCM frame, SCM index, SCM val, SCM representation), + "") +#define FUNC_NAME s_scm_frame_local_set_x +{ + union scm_vm_stack_element *fp, *sp; + unsigned int i; + enum stack_item_representation repr; + + SCM_VALIDATE_VM_FRAME (1, frame); + SCM_VALIDATE_UINT_COPY (2, index, i); + repr = scm_to_stack_item_representation (representation, FUNC_NAME, SCM_ARG3); + + fp = SCM_VM_FRAME_FP (frame); + sp = SCM_VM_FRAME_SP (frame); + + if (i < SCM_FRAME_NUM_LOCALS (fp, sp)) + { + union scm_vm_stack_element *item = SCM_FRAME_SLOT (fp, i); + switch (repr) + { + case STACK_ITEM_SCM: + item->as_scm = val; + break; + case STACK_ITEM_F64: + /* item->as_f64 = scm_to_double (val); */ + default: + abort(); + } return SCM_UNSPECIFIED; } diff --git a/libguile/frames.h b/libguile/frames.h index e1130e94b..c965bbfb7 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -160,8 +160,9 @@ SCM_API SCM scm_frame_call_representation (SCM frame); SCM_API SCM scm_frame_arguments (SCM frame); SCM_API SCM scm_frame_source (SCM frame); SCM_API SCM scm_frame_num_locals (SCM frame); -SCM_API SCM scm_frame_local_ref (SCM frame, SCM index); -SCM_API SCM scm_frame_local_set_x (SCM frame, SCM index, SCM val); +SCM_API SCM scm_frame_local_ref (SCM frame, SCM index, SCM representation); +SCM_API SCM scm_frame_local_set_x (SCM frame, SCM index, SCM val, + SCM representation); SCM_API SCM scm_frame_address (SCM frame); SCM_API SCM scm_frame_stack_pointer (SCM frame); SCM_API SCM scm_frame_instruction_pointer (SCM frame); diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 6830d753b..96200a83d 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -475,7 +475,8 @@ (for-each (lambda (name var) (let ((slot (maybe-slot var))) (when slot - (emit-definition asm name slot)))) + (let ((repr (lookup-representation var allocation))) + (emit-definition asm name slot repr))))) names vars) (when src (emit-source asm src)) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 9189d86a0..ad4e524e7 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -35,6 +35,7 @@ #:export (allocate-slots lookup-slot lookup-maybe-slot + lookup-representation lookup-constant-value lookup-maybe-constant-value lookup-nlocals @@ -43,7 +44,8 @@ lookup-slot-map)) (define-record-type $allocation - (make-allocation slots constant-values call-allocs shuffles frame-sizes) + (make-allocation slots representations constant-values call-allocs + shuffles frame-sizes) allocation? ;; A map of VAR to slot allocation. A slot allocation is an integer, @@ -51,6 +53,11 @@ ;; (slots allocation-slots) + ;; A map of VAR to representation. A representation is either 'scm or + ;; 'f64. + ;; + (representations allocation-representations) + ;; A map of VAR to constant value, for variables with constant values. ;; (constant-values allocation-constant-values) @@ -95,6 +102,9 @@ (define (lookup-slot var allocation) (intmap-ref (allocation-slots allocation) var)) +(define (lookup-representation var allocation) + (intmap-ref (allocation-representations allocation) var)) + (define *absent* (list 'absent)) (define (lookup-constant-value var allocation) @@ -1006,4 +1016,5 @@ are comparable with eqv?. A tmp slot may be used." (let* ((slots (allocate-lazy-vars cps slots calls live-in lazy)) (shuffles (compute-shuffles cps slots calls live-in)) (frame-sizes (compute-frame-sizes cps slots calls shuffles))) - (make-allocation slots constants calls shuffles frame-sizes)))))) + (make-allocation slots representations constants calls + shuffles frame-sizes)))))) diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm index 6fff660e5..9516af622 100644 --- a/module/system/repl/debug.scm +++ b/module/system/repl/debug.scm @@ -113,7 +113,8 @@ (format port "~aLocal variables:~%" per-line-prefix) (for-each (lambda (binding) - (let ((v (frame-local-ref frame (binding-slot binding)))) + (let ((v (frame-local-ref frame (binding-slot binding) + (binding-representation binding)))) (display per-line-prefix port) (run-hook before-print-hook v) (format port "~a = ~v:@y\n" (binding-name binding) width v))) @@ -174,7 +175,8 @@ (module-use! mod* mod) (for-each (lambda (binding) - (let* ((x (frame-local-ref frame (binding-slot binding))) + (let* ((x (frame-local-ref frame (binding-slot binding) + (binding-representation binding))) (var (if (variable? x) x (make-variable x)))) (format #t "~:[Read-only~;Mutable~] local variable ~a = ~70:@y\n" diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 379539f6a..dd96709e5 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -1162,10 +1162,9 @@ returned instead." (define-macro-assembler (source asm source) (set-asm-sources! asm (acons (asm-start asm) source (asm-sources asm)))) -(define-macro-assembler (definition asm name slot) +(define-macro-assembler (definition asm name slot representation) (let* ((arity (car (meta-arities (car (asm-meta asm))))) - (def (vector name - slot + (def (vector name slot representation (* (- (asm-start asm) (arity-low-pc arity)) 4)))) (set-arity-definitions! arity (cons def (arity-definitions arity))))) @@ -1876,7 +1875,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If (let lp ((definitions (arity-definitions arity))) (match definitions (() relocs) - ((#(name slot def) . definitions) + ((#(name slot representation def) . definitions) (let ((sym (if (symbol? name) (string-table-intern! strtab (symbol->string name)) 0))) @@ -1886,9 +1885,13 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If (let lp ((definitions (arity-definitions arity))) (match definitions (() relocs) - ((#(name slot def) . definitions) + ((#(name slot representation def) . definitions) (put-uleb128 names-port def) - (put-uleb128 names-port slot) + (let ((tag (case representation + ((scm) 0) + ((f64) 1) + (else (error "what!" representation))))) + (put-uleb128 names-port (logior (ash slot 2) tag))) (lp definitions)))))) (let lp ((metas metas) (pos arities-prefix-len) (relocs '())) (match metas diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm index cd8c19e13..814472b7a 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -1,6 +1,6 @@ ;;; Guile runtime debug information -;;; Copyright (C) 2013, 2014 Free Software Foundation, Inc. +;;; Copyright (C) 2013, 2014, 2015 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 @@ -381,9 +381,14 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}." (call-with-values (lambda () (read-uleb128 bv pos)) (lambda (def-offset pos) (call-with-values (lambda () (read-uleb128 bv pos)) - (lambda (slot pos) - (cons (vector name def-offset slot) - (lp pos names)))))))))) + (lambda (slot+representation pos) + (let ((slot (ash slot+representation -2)) + (representation (case (logand slot+representation #x3) + ((0) 'scm) + ((1) 'f64) + (else 'unknown)))) + (cons (vector name def-offset slot representation) + (lp pos names))))))))))) (define (load-symbols pos) (let lp ((pos pos) (n nlocals) (out '())) (if (zero? n) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index 7f0211da8..6e4527956 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -1,6 +1,6 @@ ;;; Guile VM frame functions -;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012, 2013, 2014, 2015 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 @@ -31,6 +31,7 @@ #:export (binding-index binding-name binding-slot + binding-representation frame-bindings frame-lookup-binding @@ -40,11 +41,12 @@ frame-object-binding frame-object-name)) (define-record-type - (make-binding idx name slot) + (make-binding idx name slot representation) binding? (idx binding-index) (name binding-name) - (slot binding-slot)) + (slot binding-slot) + (representation binding-representation)) (define (parse-code code) (let ((len (bytevector-length code))) @@ -134,7 +136,7 @@ (let lp ((var 0) (pos 0) (pc-offset 0)) (when (< var (vector-length defs)) (match (vector-ref defs var) - (#(name offset slot) + (#(name offset slot representation) (when (< offset pc-offset) (error "mismatch between def offsets and parsed code")) (cond @@ -147,7 +149,7 @@ (define (compute-defs-by-slot defs) (let* ((nslots (match defs - (#(#(_ _ slot) ...) (1+ (apply max slot))))) + (#(#(_ _ slot _) ...) (1+ (apply max slot))))) (by-slot (make-vector nslots #f))) (let lp ((n 0)) (when (< n nslots) @@ -156,7 +158,7 @@ (let lp ((n 0)) (when (< n (vector-length defs)) (match (vector-ref defs n) - (#(_ _ slot) + (#(_ _ slot _) (bitvector-set! (vector-ref by-slot slot) n #t) (lp (1+ n)))))) by-slot)) @@ -179,7 +181,7 @@ (let lp ((var 0) (pos 0) (pc-offset 0)) (when (< var (vector-length defs)) (match (vector-ref defs var) - (#(name offset slot) + (#(name offset slot representation) (when (< offset pc-offset) (error "mismatch between def offsets and parsed code")) (cond @@ -274,10 +276,10 @@ (let ((n (bit-position #t live n))) (if n (match (vector-ref defs n) - (#(name def-offset slot) + (#(name def-offset slot representation) ;; Binding 0 is the closure, and is not present ;; in arity-definitions. - (cons (make-binding (1+ n) name slot) + (cons (make-binding (1+ n) name slot representation) (lp (1+ n))))) '())))) (lp (1+ n) (- offset (vector-ref parsed n))))))) @@ -300,17 +302,16 @@ (lp (cdr bindings)))))) (define (frame-binding-set! frame var val) - (frame-local-set! frame - (binding-slot - (or (frame-lookup-binding frame var) - (error "variable not bound in frame" var frame))) - val)) + (let ((binding (or (frame-lookup-binding frame var) + (error "variable not bound in frame" var frame)))) + (frame-local-set! frame (binding-slot binding) val + (binding-representation binding)))) (define (frame-binding-ref frame var) - (frame-local-ref frame - (binding-slot - (or (frame-lookup-binding frame var) - (error "variable not bound in frame" var frame))))) + (let ((binding (or (frame-lookup-binding frame var) + (error "variable not bound in frame" var frame)))) + (frame-local-ref frame (binding-slot binding) + (binding-representation binding)))) ;; This function is always called to get some sort of representation of the @@ -347,16 +348,21 @@ (closure (frame-procedure frame))) (define (find-slot i bindings) (match bindings - (#f (and (< i nlocals) i)) (() #f) - ((($ idx name slot) . bindings) + (((and binding ($ idx name slot)) . bindings) (if (< idx i) (find-slot i bindings) - (and (= idx i) slot))))) + (and (= idx i) binding))))) (define (local-ref i bindings) (cond + ((not bindings) + ;; This case is only hit for primitives and application + ;; arguments. + (frame-local-ref frame i 'scm)) ((find-slot i bindings) - => (lambda (slot) (frame-local-ref frame slot))) + => (lambda (binding) + (frame-local-ref frame (binding-slot binding) + (binding-representation binding)))) (else '_))) (define (application-arguments) diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test index 872c5f1ff..bae76825e 100644 --- a/test-suite/tests/rtl.test +++ b/test-suite/tests/rtl.test @@ -104,7 +104,7 @@ a procedure." '((begin-program countdown ((name . countdown))) (begin-standard-arity (x) 4 #f) - (definition x 1) + (definition x 1 scm) (br fix-body) (label loop-head) (br-if-= 1 2 #f out) @@ -143,7 +143,7 @@ a procedure." (begin-program accum ((name . accum))) (begin-standard-arity (x) 4 #f) - (definition x 1) + (definition x 1 scm) (free-ref 1 3 0) (box-ref 0 1) (add 0 0 2) @@ -164,7 +164,7 @@ a procedure." '((begin-program call ((name . call))) (begin-standard-arity (f) 7 #f) - (definition f 1) + (definition f 1 scm) (mov 1 5) (call 5 1) (receive 1 5 7) @@ -179,7 +179,7 @@ a procedure." '((begin-program call-with-3 ((name . call-with-3))) (begin-standard-arity (f) 7 #f) - (definition f 1) + (definition f 1 scm) (mov 1 5) (load-constant 0 3) (call 5 2) @@ -196,7 +196,7 @@ a procedure." '((begin-program call ((name . call))) (begin-standard-arity (f) 2 #f) - (definition f 1) + (definition f 1 scm) (mov 1 0) (tail-call 1) (end-arity) @@ -209,7 +209,7 @@ a procedure." '((begin-program call-with-3 ((name . call-with-3))) (begin-standard-arity (f) 2 #f) - (definition f 1) + (definition f 1 scm) (mov 1 0) ;; R0 <- R1 (load-constant 0 3) ;; R1 <- 3 (tail-call 2) @@ -234,7 +234,7 @@ a procedure." (begin-program sqrt-trampoline ((name . sqrt-trampoline))) (begin-standard-arity (x) 3 #f) - (definition x 1) + (definition x 1 scm) (cached-toplevel-box 0 sqrt-scope sqrt #t) (box-ref 2 0) (tail-call 2) @@ -287,7 +287,7 @@ a procedure." (begin-program sqrt-trampoline ((name . sqrt-trampoline))) (begin-standard-arity (x) 3 #f) - (definition x 1) + (definition x 1 scm) (cached-module-box 0 (guile) sqrt #t #t) (box-ref 2 0) (tail-call 2) @@ -368,8 +368,8 @@ a procedure." (assemble-program '((begin-program foo ((name . foo))) (begin-standard-arity (x y) 3 #f) - (definition x 1) - (definition y 2) + (definition x 1 scm) + (definition y 2 scm) (load-constant 1 42) (return-values 2) (end-arity) @@ -380,9 +380,9 @@ a procedure." (assemble-program '((begin-program foo ((name . foo))) (begin-opt-arity (x) (y) z 4 #f) - (definition x 1) - (definition y 2) - (definition z 3) + (definition x 1 scm) + (definition y 2 scm) + (definition z 3 scm) (load-constant 2 42) (return-values 2) (end-arity) From fc87033bf0fdc5530842cac8942dd1feaefcfd2a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 28 Oct 2015 17:47:48 +0000 Subject: [PATCH 090/865] Stack slots can hold a double * libguile/frames.h (union scm_vm_stack_element): Add double member. * libguile/frames.c (scm_frame_local_ref, scm_frame_local_set_x): Wire up f64 support. --- libguile/frames.c | 5 +++-- libguile/frames.h | 1 + 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/libguile/frames.c b/libguile/frames.c index d522e762a..48e963a0f 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -262,7 +262,7 @@ SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 3, 0, 0, case STACK_ITEM_SCM: return item->as_scm; case STACK_ITEM_F64: - /* return item->as_f64; */ + return scm_from_double (item->as_f64); default: abort(); } @@ -298,7 +298,8 @@ SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 4, 0, 0, item->as_scm = val; break; case STACK_ITEM_F64: - /* item->as_f64 = scm_to_double (val); */ + item->as_f64 = scm_to_double (val); + break; default: abort(); } diff --git a/libguile/frames.h b/libguile/frames.h index c965bbfb7..bb402ae71 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -91,6 +91,7 @@ union scm_vm_stack_element scm_t_uintptr as_uint; scm_t_uint32 *as_ip; SCM as_scm; + double as_f64; /* For GC purposes. */ void *as_ptr; From 5bbc47b06d9e236b8a2fa2d92cdc8234bc037838 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 28 Oct 2015 17:58:30 +0000 Subject: [PATCH 091/865] Add VM ops to pack and unpack raw f64 values. * libguile/vm-engine.c (scm->f64, f64->scm): New ops. --- libguile/vm-engine.c | 34 ++++++++++++++++++++++++++++++++-- 1 file changed, 32 insertions(+), 2 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 7919c4615..75e1694cd 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -251,6 +251,9 @@ #define SP_REF(i) (sp[i].as_scm) #define SP_SET(i,o) (sp[i].as_scm = o) +#define SP_REF_F64(i) (sp[i].as_f64) +#define SP_SET_F64(i,o) (sp[i].as_f64 = o) + #define VARIABLE_REF(v) SCM_VARIABLE_REF (v) #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o) #define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED)) @@ -3216,8 +3219,35 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, VM_DEFINE_OP (135, bv_f64_set, "bv-f64-set!", OP1 (X8_S8_S8_S8)) BV_FLOAT_SET (f64, ieee_double, double, 8); - VM_DEFINE_OP (136, unused_136, NULL, NOP) - VM_DEFINE_OP (137, unused_137, NULL, NOP) + /* scm->f64 dst:12 src:12 + * + * Unpack a raw double-precision floating-point value from SRC and + * place it in DST. Note that SRC can be any value on which + * scm_to_double can operate. + */ + VM_DEFINE_OP (136, scm_to_f64, "scm->f64", OP1 (X8_S12_S12) | OP_DST) + { + scm_t_uint16 dst, src; + UNPACK_12_12 (op, dst, src); + SYNC_IP (); + SP_SET_F64 (dst, scm_to_double (SP_REF (src))); + NEXT (1); + } + + /* f64->scm dst:12 src:12 + * + * Pack a raw double-precision floating point value into an inexact + * number allocated on the heap. + */ + VM_DEFINE_OP (137, f64_to_scm, "f64->scm", OP1 (X8_S12_S12) | OP_DST) + { + scm_t_uint16 dst, src; + UNPACK_12_12 (op, dst, src); + SYNC_IP (); + SP_SET (dst, scm_from_double (SP_REF_F64 (src))); + NEXT (1); + } + VM_DEFINE_OP (138, unused_138, NULL, NOP) VM_DEFINE_OP (139, unused_139, NULL, NOP) VM_DEFINE_OP (140, unused_140, NULL, NOP) From 608753982f012d40a466fe08a86041e92a85f908 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 11 Nov 2015 10:14:51 +0100 Subject: [PATCH 092/865] Type inference distinguishes between untagged and tagged flonums * module/language/cps/types.scm (&f64): New type, for untagged f64 values. Having a distinct type prevents type folding from replacing an untagged 3.0 with a tagged 3.0. (scm->f64, f64->scm): Support these new primcalls. --- module/language/cps/types.scm | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 55cde2744..fc23e1691 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -117,6 +117,9 @@ ;; Union types. &number &real + ;; Untagged types. + &f64 + infer-types lookup-pre-type lookup-post-type @@ -164,7 +167,9 @@ &bytevector &bitvector &array - &hash-table) + &hash-table + + &f64) (define-syntax &no-type (identifier-syntax 0)) @@ -670,6 +675,24 @@ minimum, and maximum." ((logior &number &false) -inf.0 +inf.0)) + + +;;; +;;; Unboxed double-precision floating-point numbers. +;;; + +(define-type-checker (scm->f64 scm) + (check-type scm &real -inf.0 +inf.0)) +(define-type-inferrer (scm->f64 scm result) + (restrict! scm &real -inf.0 +inf.0) + (define! result &f64 (&min scm) (&max scm))) + +(define-type-checker (f64->scm f64) + #t) +(define-type-inferrer (f64->scm f64 result) + (define! result &flonum (&min f64) (&max f64))) + + ;;; From b1ac8d68b5bb9e4bb21b3e42d6c8f3d67d7ab01e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 11 Nov 2015 10:17:08 +0100 Subject: [PATCH 093/865] bv-{f32,f64}-{ref,set!} operate on raw f64 values * module/language/tree-il/compile-cps.scm (convert): Box results of bv-f32-ref and bv-f64-ref. Unbox the argument to bv-f32-set! and bv-f64-set!. * libguile/vm-engine.c (bv-f32-ref, bv-f64-ref): Results are raw. (bv-f32-set!, bv-f64-set!): Take unboxed arguments. * module/system/vm/assembler.scm (emit-scm->f64, emit-f64->scm): Export. * module/language/cps/compile-bytecode.scm (compile-function): * module/language/cps/effects-analysis.scm: Add support for scm->f64 and f64->scm. * module/language/cps/slot-allocation.scm (compute-var-representations): Add cases for primops returning raw values. * module/language/cps/types.scm (bv-f32-ref, bv-f32-set!) (bv-f64-ref, bv-f64-set!): Deal in &f64 values instead of reals. --- libguile/vm-engine.c | 28 +++++++++++------ module/language/cps/compile-bytecode.scm | 4 +++ module/language/cps/effects-analysis.scm | 5 +++ module/language/cps/slot-allocation.scm | 4 +-- module/language/cps/types.scm | 4 +-- module/language/tree-il/compile-cps.scm | 39 +++++++++++++++++++++--- module/system/vm/assembler.scm | 2 ++ 7 files changed, 68 insertions(+), 18 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 75e1694cd..d7320059a 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -3032,14 +3032,22 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, i = SCM_I_INUM (idx); \ float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ \ - SYNC_IP (); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ && (i >= 0) \ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ && (ALIGNED_P (float_ptr, type)))) \ - RETURN (scm_from_double (*float_ptr)); \ + { \ + SP_SET_F64 (dst, *float_ptr); \ + NEXT (1); \ + } \ else \ - RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \ + { \ + SCM val; \ + SYNC_IP (); \ + val = scm_bytevector_ ## fn_stem ## _native_ref (bv, idx); \ + SP_SET_F64 (dst, scm_to_double (val)); \ + NEXT (1); \ + } \ } while (0) VM_DEFINE_OP (116, bv_u8_ref, "bv-u8-ref", OP1 (X8_S8_S8_S8) | OP_DST) @@ -3157,13 +3165,14 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, do { \ scm_t_uint8 dst, idx, src; \ scm_t_signed_bits i; \ - SCM bv, scm_idx, val; \ + SCM bv, scm_idx; \ + double val; \ type *float_ptr; \ \ UNPACK_8_8_8 (op, dst, idx, src); \ - bv = SP_REF (dst); \ - scm_idx = SP_REF (idx); \ - val = SP_REF (src); \ + bv = SP_REF (dst); \ + scm_idx = SP_REF (idx); \ + val = SP_REF_F64 (src); \ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ i = SCM_I_INUM (scm_idx); \ float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ @@ -3172,11 +3181,12 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, && (i >= 0) \ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ && (ALIGNED_P (float_ptr, type)))) \ - *float_ptr = scm_to_double (val); \ + *float_ptr = val; \ else \ { \ + SCM boxed = scm_from_double (val); \ SYNC_IP (); \ - scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, val); \ + scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, boxed); \ } \ NEXT (1); \ } while (0) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 96200a83d..49b684cc4 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -181,6 +181,10 @@ (constant n))) (($ $primcall 'builtin-ref (name)) (emit-builtin-ref asm (from-sp dst) (constant name))) + (($ $primcall 'scm->f64 (src)) + (emit-scm->f64 asm (from-sp dst) (from-sp (slot src)))) + (($ $primcall 'f64->scm (src)) + (emit-f64->scm asm (from-sp dst) (from-sp (slot src)))) (($ $primcall 'bv-u8-ref (bv idx)) (emit-bv-u8-ref asm (from-sp dst) (from-sp (slot bv)) (from-sp (slot idx)))) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 778855de5..3542a1e74 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -351,6 +351,11 @@ is or might be a read or a write to the same location as A." ((string->number _) (&read-object &string) &type-check) ((string-length s) &type-check)) +;; Unboxed floats. +(define-primitive-effects + ((scm->f64 _) &type-check) + ((f64->scm _))) + ;; Bytevectors. (define-primitive-effects ((bytevector-length _) &type-check) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index ad4e524e7..6fc2a5399 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -790,9 +790,7 @@ are comparable with eqv?. A tmp slot may be used." (($ $values (arg)) (intmap-add representations var (intmap-ref representations arg))) - ;; FIXME: Placeholder for as-yet-unwritten primitive - ;; operations that define unboxed f64 values. - (($ $primcall 'scm->f64) + (($ $primcall (or 'scm->f64 'bv-f32-ref 'bv-f64-ref)) (intmap-add representations var 'f64)) (_ (intmap-add representations var 'scm)))) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index fc23e1691..8a2cc86d3 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -740,8 +740,8 @@ minimum, and maximum." (define-bytevector-accessors bv-s32-ref bv-s32-set! &exact-integer 4 -inf.0 +inf.0) (define-bytevector-accessors bv-u64-ref bv-u64-set! &exact-integer 8 0 +inf.0) (define-bytevector-accessors bv-s64-ref bv-s64-set! &exact-integer 8 -inf.0 +inf.0) -(define-bytevector-accessors bv-f32-ref bv-f32-set! &real 4 -inf.0 +inf.0) -(define-bytevector-accessors bv-f64-ref bv-f64-set! &real 8 -inf.0 +inf.0) +(define-bytevector-accessors bv-f32-ref bv-f32-set! &f64 4 -inf.0 +inf.0) +(define-bytevector-accessors bv-f64-ref bv-f64-set! &f64 8 -inf.0 +inf.0) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 0664b2c4d..393b0a8f9 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -555,6 +555,33 @@ ($ (lp args ktail))))))))))) ((prim-instruction name) => (lambda (instruction) + (define (box+adapt-arity cps k src out) + (case instruction + ((bv-f32-ref bv-f64-ref) + (with-cps cps + (letv f64) + (let$ k (adapt-arity k src out)) + (letk kbox ($kargs ('f64) (f64) + ($continue k src ($primcall 'f64->scm (f64))))) + kbox)) + (else + (adapt-arity cps k src out)))) + (define (unbox-arg cps arg have-arg) + (with-cps cps + (letv f64) + (let$ body (have-arg f64)) + (letk kunboxed ($kargs ('f64) (f64) ,body)) + (build-term + ($continue kunboxed src ($primcall 'scm->f64 (arg)))))) + (define (unbox-args cps args have-args) + (case instruction + ((bv-f32-set! bv-f64-set!) + (match args + ((bv idx val) + (unbox-arg cps val + (lambda (cps val) + (have-args cps (list bv idx val))))))) + (else (have-args cps args)))) (convert-args cps args (lambda (cps args) ;; Tree-IL primcalls are sloppy, in that it could be @@ -566,10 +593,14 @@ ((out . in) (if (= in (length args)) (with-cps cps - (let$ k (adapt-arity k src out)) - (build-term - ($continue k src - ($primcall instruction args)))) + (let$ k (box+adapt-arity k src out)) + ($ (unbox-args + args + (lambda (cps args) + (with-cps cps + (build-term + ($continue k src + ($primcall instruction args)))))))) (with-cps cps (letv prim) (letk kprim ($kargs ('prim) (prim) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index dd96709e5..9cb04bbed 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -155,6 +155,8 @@ (emit-struct-set!* . emit-struct-set!) (emit-class-of* . emit-class-of) emit-make-array + (emit-scm->f64* . emit-scm->f64) + (emit-f64->scm* . emit-f64->scm) (emit-bv-u8-ref* . emit-bv-u8-ref) (emit-bv-s8-ref* . emit-bv-s8-ref) (emit-bv-u16-ref* . emit-bv-u16-ref) From c438998e481ae329c29bf70de4cc40a783e0baf0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 28 Oct 2015 22:27:46 +0000 Subject: [PATCH 094/865] Scalar replacement for f64->scm * module/language/cps/cse.scm (compute-equivalent-subexpressions): Scalar replacement for float boxes. --- module/language/cps/cse.scm | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index 894f7798e..2e47f379c 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -299,6 +299,14 @@ false. It could be that both true and false proofs are available." (add-def! `(primcall struct-ref ,struct ,n) val)) (('primcall 'struct-set!/immediate struct n val) (add-def! `(primcall struct-ref/immediate ,struct ,n) val)) + (('primcall 'scm->f64 scm) + (match defs + ((f64) + (add-def! `(primcall f64->scm ,f64) scm)))) + (('primcall 'f64->scm f64) + (match defs + ((scm) + (add-def! `(primcall scm->f64 ,scm) f64)))) (_ #t)))) (define (visit-label label equiv-labels var-substs) From 3b4941f3a9af0b656820ea613a4991323e9eae90 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 29 Oct 2015 08:27:15 +0000 Subject: [PATCH 095/865] Add fadd, fsub, fmul, fdiv instructions * libguile/vm-engine.c (fadd, fsub, fmul, fdiv): New instructions. * module/language/cps/effects-analysis.scm: * module/language/cps/types.scm: Wire up support for new instructions. * module/system/vm/assembler.scm: Export emit-fadd and friends. --- libguile/vm-engine.c | 56 +++++++++++- module/language/cps/effects-analysis.scm | 4 + module/language/cps/types.scm | 112 +++++++++++++++-------- module/system/vm/assembler.scm | 4 + 4 files changed, 133 insertions(+), 43 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index d7320059a..d33878d20 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -3258,10 +3258,58 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (1); } - VM_DEFINE_OP (138, unused_138, NULL, NOP) - VM_DEFINE_OP (139, unused_139, NULL, NOP) - VM_DEFINE_OP (140, unused_140, NULL, NOP) - VM_DEFINE_OP (141, unused_141, NULL, NOP) + /* fadd dst:8 a:8 b:8 + * + * Add A to B, and place the result in DST. The operands and the + * result are unboxed double-precision floating-point numbers. + */ + VM_DEFINE_OP (138, fadd, "fadd", OP1 (X8_S8_S8_S8) | OP_DST) + { + scm_t_uint8 dst, a, b; + UNPACK_8_8_8 (op, dst, a, b); + SP_SET_F64 (dst, SP_REF_F64 (a) + SP_REF_F64 (b)); + NEXT (1); + } + + /* fsub dst:8 a:8 b:8 + * + * Subtract B from A, and place the result in DST. The operands and + * the result are unboxed double-precision floating-point numbers. + */ + VM_DEFINE_OP (139, fsub, "fsub", OP1 (X8_S8_S8_S8) | OP_DST) + { + scm_t_uint8 dst, a, b; + UNPACK_8_8_8 (op, dst, a, b); + SP_SET_F64 (dst, SP_REF_F64 (a) - SP_REF_F64 (b)); + NEXT (1); + } + + /* fmul dst:8 a:8 b:8 + * + * Multiply A and B, and place the result in DST. The operands and + * the result are unboxed double-precision floating-point numbers. + */ + VM_DEFINE_OP (140, fmul, "fmul", OP1 (X8_S8_S8_S8) | OP_DST) + { + scm_t_uint8 dst, a, b; + UNPACK_8_8_8 (op, dst, a, b); + SP_SET_F64 (dst, SP_REF_F64 (a) * SP_REF_F64 (b)); + NEXT (1); + } + + /* fdiv dst:8 a:8 b:8 + * + * Divide A by B, and place the result in DST. The operands and the + * result are unboxed double-precision floating-point numbers. + */ + VM_DEFINE_OP (141, fdiv, "fdiv", OP1 (X8_S8_S8_S8) | OP_DST) + { + scm_t_uint8 dst, a, b; + UNPACK_8_8_8 (op, dst, a, b); + SP_SET_F64 (dst, SP_REF_F64 (a) / SP_REF_F64 (b)); + NEXT (1); + } + VM_DEFINE_OP (142, unused_142, NULL, NOP) VM_DEFINE_OP (143, unused_143, NULL, NOP) VM_DEFINE_OP (144, unused_144, NULL, NOP) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 3542a1e74..ae7a1a614 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -414,6 +414,10 @@ is or might be a read or a write to the same location as A." ((mul . _) &type-check) ((sub . _) &type-check) ((div . _) &type-check) + ((fadd . _)) + ((fsub . _)) + ((fmul . _)) + ((fdiv . _)) ((sub1 . _) &type-check) ((add1 . _) &type-check) ((quo . _) &type-check) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 8a2cc86d3..dac29f7d2 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -842,18 +842,48 @@ minimum, and maximum." min* max*)))))) (define-simple-type-checker (add &number &number)) +(define-type-checker (fadd a b) #t) (define-type-inferrer (add a b result) (define-binary-result! a b result #t (+ (&min a) (&min b)) (+ (&max a) (&max b)))) +(define-type-inferrer (fadd a b result) + (define! result &f64 + (+ (&min a) (&min b)) + (+ (&max a) (&max b)))) (define-simple-type-checker (sub &number &number)) +(define-type-checker (fsub a b) #t) (define-type-inferrer (sub a b result) (define-binary-result! a b result #t (- (&min a) (&max b)) (- (&max a) (&min b)))) +(define-type-inferrer (fsub a b result) + (define! result &f64 + (- (&min a) (&max b)) + (- (&max a) (&min b)))) (define-simple-type-checker (mul &number &number)) +(define-type-checker (fmul a b) #t) +(define (mul-result-range same? nan-impossible? min-a max-a min-b max-b) + (define (nan* a b) + (if (and (or (and (inf? a) (zero? b)) + (and (zero? a) (inf? b))) + nan-impossible?) + 0 + (* a b))) + (let ((-- (nan* min-a min-b)) + (-+ (nan* min-a max-b)) + (++ (nan* max-a max-b)) + (+- (nan* max-a min-b))) + (let ((has-nan? (or (nan? --) (nan? -+) (nan? ++) (nan? +-)))) + (values (cond + (same? 0) + (has-nan? -inf.0) + (else (min -- -+ ++ +-))) + (if has-nan? + +inf.0 + (max -- -+ ++ +-)))))) (define-type-inferrer (mul a b result) (let ((min-a (&min a)) (max-a (&max a)) (min-b (&min b)) (max-b (&max b)) @@ -863,25 +893,20 @@ minimum, and maximum." ;; range inference time is 0 and not +nan.0. (nan-impossible? (not (logtest (logior (&type a) (&type b)) (logior &flonum &complex))))) - (define (nan* a b) - (if (and (or (and (inf? a) (zero? b)) - (and (zero? a) (inf? b))) - nan-impossible?) - 0 - (* a b))) - (let ((-- (nan* min-a min-b)) - (-+ (nan* min-a max-b)) - (++ (nan* max-a max-b)) - (+- (nan* max-a min-b))) - (let ((has-nan? (or (nan? --) (nan? -+) (nan? ++) (nan? +-)))) - (define-binary-result! a b result #t - (cond - ((eqv? a b) 0) - (has-nan? -inf.0) - (else (min -- -+ ++ +-))) - (if has-nan? - +inf.0 - (max -- -+ ++ +-))))))) + (call-with-values (lambda () + (mul-result-range (eqv? a b) nan-impossible? + min-a max-a min-b max-b)) + (lambda (min max) + (define-binary-result! a b result #t min max))))) +(define-type-inferrer (fmul a b result) + (let ((min-a (&min a)) (max-a (&max a)) + (min-b (&min b)) (max-b (&max b)) + (nan-impossible? #f)) + (call-with-values (lambda () + (mul-result-range (eqv? a b) nan-impossible? + min-a max-a min-b max-b)) + (lambda (min max) + (define! result &f64 min max))))) (define-type-checker (div a b) (and (check-type a &number -inf.0 +inf.0) @@ -889,31 +914,40 @@ minimum, and maximum." ;; We only know that there will not be an exception if b is not ;; zero. (not (<= (&min b) 0 (&max b))))) +(define-type-checker (fdiv a b) #t) +(define (div-result-range min-a max-a min-b max-b) + (if (<= min-b 0 max-b) + ;; If the range of the divisor crosses 0, the result spans + ;; the whole range. + (values -inf.0 +inf.0) + ;; Otherwise min-b and max-b have the same sign, and cannot both + ;; be infinity. + (let ((--- (if (inf? min-b) 0 (floor/ min-a min-b))) + (-+- (if (inf? max-b) 0 (floor/ min-a max-b))) + (++- (if (inf? max-b) 0 (floor/ max-a max-b))) + (+-- (if (inf? min-b) 0 (floor/ max-a min-b))) + (--+ (if (inf? min-b) 0 (ceiling/ min-a min-b))) + (-++ (if (inf? max-b) 0 (ceiling/ min-a max-b))) + (+++ (if (inf? max-b) 0 (ceiling/ max-a max-b))) + (+-+ (if (inf? min-b) 0 (ceiling/ max-a min-b)))) + (values (min (min --- -+- ++- +--) + (min --+ -++ +++ +-+)) + (max (max --- -+- ++- +--) + (max --+ -++ +++ +-+)))))) (define-type-inferrer (div a b result) (let ((min-a (&min a)) (max-a (&max a)) (min-b (&min b)) (max-b (&max b))) - (call-with-values - (lambda () - (if (<= min-b 0 max-b) - ;; If the range of the divisor crosses 0, the result spans - ;; the whole range. - (values -inf.0 +inf.0) - ;; Otherwise min-b and max-b have the same sign, and cannot both - ;; be infinity. - (let ((--- (if (inf? min-b) 0 (floor/ min-a min-b))) - (-+- (if (inf? max-b) 0 (floor/ min-a max-b))) - (++- (if (inf? max-b) 0 (floor/ max-a max-b))) - (+-- (if (inf? min-b) 0 (floor/ max-a min-b))) - (--+ (if (inf? min-b) 0 (ceiling/ min-a min-b))) - (-++ (if (inf? max-b) 0 (ceiling/ min-a max-b))) - (+++ (if (inf? max-b) 0 (ceiling/ max-a max-b))) - (+-+ (if (inf? min-b) 0 (ceiling/ max-a min-b)))) - (values (min (min --- -+- ++- +--) - (min --+ -++ +++ +-+)) - (max (max --- -+- ++- +--) - (max --+ -++ +++ +-+)))))) + (call-with-values (lambda () + (div-result-range min-a max-a min-b max-b)) (lambda (min max) (define-binary-result! a b result #f min max))))) +(define-type-inferrer (fdiv a b result) + (let ((min-a (&min a)) (max-a (&max a)) + (min-b (&min b)) (max-b (&max b))) + (call-with-values (lambda () + (div-result-range min-a max-a min-b max-b)) + (lambda (min max) + (define! result &f64 min max))))) (define-simple-type-checker (add1 &number)) (define-type-inferrer (add1 a result) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 9cb04bbed..ae54d1303 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -136,6 +136,10 @@ (emit-rem* . emit-rem) (emit-mod* . emit-mod) (emit-ash* . emit-ash) + (emit-fadd* . emit-fadd) + (emit-fsub* . emit-fsub) + (emit-fmul* . emit-fmul) + (emit-fdiv* . emit-fdiv) (emit-logand* . emit-logand) (emit-logior* . emit-logior) (emit-logxor* . emit-logxor) From 12e9e2148ec43dc0cebc4bea94cdfebfc4261263 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 29 Oct 2015 09:15:38 +0000 Subject: [PATCH 096/865] Add new pass to specialize "add" into "fadd" where possible * module/language/cps/specialize-numbers.scm: New pass, to turn "add" into "fadd", and similarly for sub, mul, and div. * module/language/cps/optimize.scm: * module/Makefile.am: * bootstrap/Makefile.am: Wire up the new pass. --- bootstrap/Makefile.am | 1 + module/Makefile.am | 1 + module/language/cps/optimize.scm | 3 + module/language/cps/specialize-numbers.scm | 91 ++++++++++++++++++++++ 4 files changed, 96 insertions(+) create mode 100644 module/language/cps/specialize-numbers.scm diff --git a/bootstrap/Makefile.am b/bootstrap/Makefile.am index 093ee8540..2d9caac38 100644 --- a/bootstrap/Makefile.am +++ b/bootstrap/Makefile.am @@ -99,6 +99,7 @@ SOURCES = \ language/cps/slot-allocation.scm \ language/cps/spec.scm \ language/cps/specialize-primcalls.scm \ + language/cps/specialize-numbers.scm \ language/cps/split-rec.scm \ language/cps/type-checks.scm \ language/cps/type-fold.scm \ diff --git a/module/Makefile.am b/module/Makefile.am index f835ceb73..6cb160314 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -149,6 +149,7 @@ SOURCES = \ language/cps/slot-allocation.scm \ language/cps/spec.scm \ language/cps/specialize-primcalls.scm \ + language/cps/specialize-numbers.scm \ language/cps/split-rec.scm \ language/cps/type-checks.scm \ language/cps/type-fold.scm \ diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm index 571d5ffd8..7d4dc2fe2 100644 --- a/module/language/cps/optimize.scm +++ b/module/language/cps/optimize.scm @@ -37,6 +37,7 @@ #:use-module (language cps self-references) #:use-module (language cps simplify) #:use-module (language cps specialize-primcalls) + #:use-module (language cps specialize-numbers) #:use-module (language cps type-fold) #:use-module (language cps verify) #:export (optimize-higher-order-cps @@ -104,6 +105,7 @@ (simplify #:simplify? #t)) (define-optimizer optimize-first-order-cps + (specialize-numbers #:specialize-numbers? #t) (hoist-loop-invariant-code #:licm? #t) (eliminate-common-subexpressions #:cse? #t) (eliminate-dead-code #:eliminate-dead-code? #t) @@ -123,5 +125,6 @@ #:cse? #t #:type-fold? #t #:resolve-self-references? #t + #:specialize-numbers? #t #:licm? #t #:rotate-loops? #t)) diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm new file mode 100644 index 000000000..002abe59d --- /dev/null +++ b/module/language/cps/specialize-numbers.scm @@ -0,0 +1,91 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Some arithmetic operations have multiple implementations: one +;;; polymorphic implementation that works on all kinds of numbers, like +;;; `add', and one or more specialized variants for unboxed numbers of +;;; some kind, like `fadd'. If we can replace a polymorphic +;;; implementation with a monomorphic implementation, we should do so -- +;;; it will speed up the runtime and avoid boxing numbers. +;;; +;;; A polymorphic operation can be specialized if its result is +;;; specialized. To specialize an operation, we manually unbox its +;;; arguments and box its return value, relying on CSE to remove boxes +;;; where possible. +;;; +;;; Code: + +(define-module (language cps specialize-numbers) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps intmap) + #:use-module (language cps renumber) + #:use-module (language cps types) + #:use-module (language cps utils) + #:use-module (language cps with-cps) + #:export (specialize-numbers)) + +(define (specialize-f64-binop cps k src op a b) + (let ((fop (match op + ('add 'fadd) + ('sub 'fsub) + ('mul 'fmul) + ('div 'fdiv)))) + (with-cps cps + (letv f64-a f64-b result) + (letk kbox ($kargs ('result) (result) + ($continue k src + ($primcall 'f64->scm (result))))) + (letk kop ($kargs ('f64-b) (f64-b) + ($continue kbox src + ($primcall fop (f64-a f64-b))))) + (letk kunbox-b ($kargs ('f64-a) (f64-a) + ($continue kop src + ($primcall 'scm->f64 (b))))) + (build-term + ($continue kunbox-b src + ($primcall 'scm->f64 (a))))))) + +(define (specialize-numbers cps) + (define (visit-cont label cont cps types) + (match cont + (($ $kfun) + (values cps (infer-types cps label))) + (($ $kargs names vars + ($ $continue k src + ($ $primcall (and op (or 'add 'sub 'mul 'div)) (a b)))) + (match (intmap-ref cps k) + (($ $kargs (_) (result)) + (call-with-values (lambda () + (lookup-post-type types label result 0)) + (lambda (type min max) + (values + (if (eqv? type &flonum) + (with-cps cps + (let$ body (specialize-f64-binop k src op a b)) + (setk label ($kargs names vars ,body))) + cps) + types)))))) + (_ (values cps types)))) + + ;; Type inference wants a renumbered graph; OK. + (let ((cps (renumber cps))) + (with-fresh-name-state cps + (values (intmap-fold visit-cont cps cps #f))))) From f0594be035ebc53813a9a4c5d09cf8a3e61c8835 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 29 Oct 2015 14:06:11 +0000 Subject: [PATCH 097/865] Fix slot representation computation for fadd, fmul, etc * module/language/cps/slot-allocation.scm (compute-var-representations): fadd, fmul and so on also define f64 values. --- module/language/cps/slot-allocation.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 6fc2a5399..8d865d739 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -790,7 +790,8 @@ are comparable with eqv?. A tmp slot may be used." (($ $values (arg)) (intmap-add representations var (intmap-ref representations arg))) - (($ $primcall (or 'scm->f64 'bv-f32-ref 'bv-f64-ref)) + (($ $primcall (or 'scm->f64 'bv-f32-ref 'bv-f64-ref + 'fadd 'fsub 'fmul 'fdiv)) (intmap-add representations var 'f64)) (_ (intmap-add representations var 'scm)))) From 5b9835e1f81597221289534c2545b4fd4d999709 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 29 Oct 2015 14:06:51 +0000 Subject: [PATCH 098/865] The compiler can unbox float64 loop variables * module/language/cps/specialize-numbers.scm: Specialize phi variables as well. --- module/language/cps/specialize-numbers.scm | 253 ++++++++++++++++++++- 1 file changed, 251 insertions(+), 2 deletions(-) diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm index 002abe59d..6d61f5b35 100644 --- a/module/language/cps/specialize-numbers.scm +++ b/module/language/cps/specialize-numbers.scm @@ -30,12 +30,30 @@ ;;; arguments and box its return value, relying on CSE to remove boxes ;;; where possible. ;;; +;;; We also want to specialize phi variables. A phi variable is bound +;;; by a continuation with more than one predecessor. For example in +;;; this code: +;;; +;;; (+ 1.0 (if a 2.0 3.0)) +;;; +;;; We want to specialize this code to: +;;; +;;; (f64->scm (fl+ (scm->f64 1.0) (if a (scm->f64 2.0) (scm->f64 3.0)))) +;;; +;;; Hopefully later passes will remove the conversions. In any case, +;;; specialization will likely result in a lower heap-number allocation +;;; rate, and that cost is higher than the extra opcodes to do +;;; conversions. This transformation is especially important for loop +;;; variables. +;;; ;;; Code: (define-module (language cps specialize-numbers) #:use-module (ice-9 match) + #:use-module (srfi srfi-1) #:use-module (language cps) #:use-module (language cps intmap) + #:use-module (language cps intset) #:use-module (language cps renumber) #:use-module (language cps types) #:use-module (language cps utils) @@ -63,7 +81,7 @@ ($continue kunbox-b src ($primcall 'scm->f64 (a))))))) -(define (specialize-numbers cps) +(define (specialize-f64-operations cps) (define (visit-cont label cont cps types) (match cont (($ $kfun) @@ -85,7 +103,238 @@ types)))))) (_ (values cps types)))) + (values (intmap-fold visit-cont cps cps #f))) + +;; Compute a map from VAR -> LABEL, where LABEL indicates the cont that +;; binds VAR. +(define (compute-defs conts labels) + (intset-fold + (lambda (label defs) + (match (intmap-ref conts label) + (($ $kfun src meta self tail clause) + (intmap-add defs self label)) + (($ $kargs names vars) + (fold1 (lambda (var defs) + (intmap-add defs var label)) + vars defs)) + (_ defs))) + labels empty-intmap)) + +;; Compute vars whose definitions are all inexact reals and whose uses +;; include an unbox operation. +(define (compute-specializable-f64-vars cps body preds defs) + ;; Compute a map of VAR->LABEL... indicating the set of labels that + ;; define VAR with f64 values, given the set of vars F64-VARS which is + ;; known already to be f64-valued. + (define (collect-f64-def-labels f64-vars) + (define (add-f64-def f64-defs var label) + (intmap-add f64-defs var (intset label) intset-union)) + (intset-fold (lambda (label f64-defs) + (match (intmap-ref cps label) + (($ $kargs _ _ ($ $continue k _ exp)) + (match exp + ((or ($ $primcall 'f64->scm (_)) + ($ $const (and (? number?) (? inexact?) (? real?)))) + (match (intmap-ref cps k) + (($ $kargs (_) (def)) + (add-f64-def f64-defs def label)))) + (($ $values vars) + (match (intmap-ref cps k) + (($ $kargs _ defs) + (fold (lambda (var def f64-defs) + (if (intset-ref f64-vars var) + (add-f64-def f64-defs def label) + f64-defs)) + f64-defs vars defs)) + ;; Could be $ktail for $values. + (_ f64-defs))) + (_ f64-defs))) + (_ f64-defs))) + body empty-intmap)) + + ;; Compute the set of vars which are always f64-valued. + (define (compute-f64-defs) + (fixpoint + (lambda (f64-vars) + (intmap-fold + (lambda (def f64-pred-labels f64-vars) + (if (and (not (intset-ref f64-vars def)) + ;; Are all defining expressions f64-valued? + (and-map (lambda (pred) + (intset-ref f64-pred-labels pred)) + (intmap-ref preds (intmap-ref defs def)))) + (intset-add f64-vars def) + f64-vars)) + (collect-f64-def-labels f64-vars) + f64-vars)) + empty-intset)) + + ;; Compute the set of vars that may ever be unboxed. + (define (compute-f64-uses f64-defs) + (intset-fold + (lambda (label f64-uses) + (match (intmap-ref cps label) + (($ $kargs _ _ ($ $continue k _ exp)) + (match exp + (($ $primcall 'scm->f64 (var)) + (intset-add f64-uses var)) + (($ $values (var)) + (match (intmap-ref cps k) + (($ $kargs (_) (def)) + (if (intset-ref f64-defs def) + (intset-add f64-uses var) + f64-uses)) + ;; Could be $ktail. + (_ f64-uses))) + (_ f64-uses))) + (_ f64-uses))) + body empty-intset)) + + (let ((f64-defs (compute-f64-defs))) + (intset-intersect f64-defs (compute-f64-uses f64-defs)))) + +(define (compute-phi-vars cps preds) + (intmap-fold (lambda (label preds phis) + (match preds + (() phis) + ((_) phis) + (_ + (match (intmap-ref cps label) + (($ $kargs names vars) + (fold1 (lambda (var phis) + (intset-add phis var)) + vars phis)) + (_ phis))))) + preds empty-intset)) + +;; Compute the set of variables which have more than one definition, +;; whose definitions are always f64-valued, and which have at least one +;; use that is an unbox operation. +(define (compute-specializable-f64-phis cps body preds defs) + (intset-intersect + (compute-specializable-f64-vars cps body preds defs) + (compute-phi-vars cps preds))) + +;; Each definition of an f64 variable should unbox that variable. The +;; cont that binds the variable should re-box it under its original +;; name, and rely on CSE to remove the boxing as appropriate. +(define (apply-f64-specialization cps kfun body preds defs phis) + (define (compute-unbox-labels) + (intset-fold (lambda (phi labels) + (fold1 (lambda (pred labels) + (intset-add labels pred)) + (intmap-ref preds (intmap-ref defs phi)) + labels)) + phis empty-intset)) + (define (unbox-operands) + (define (unbox-arg cps arg def-var have-arg) + (if (intset-ref phis def-var) + (with-cps cps + (letv f64) + (let$ body (have-arg f64)) + (letk kunboxed ($kargs ('f64) (f64) ,body)) + (build-term + ($continue kunboxed #f ($primcall 'scm->f64 (arg))))) + (have-arg cps arg))) + (define (unbox-args cps args def-vars have-args) + (match args + (() (have-args cps '())) + ((arg . args) + (match def-vars + ((def-var . def-vars) + (unbox-arg cps arg def-var + (lambda (cps arg) + (unbox-args cps args def-vars + (lambda (cps args) + (have-args cps (cons arg args))))))))))) + (intset-fold + (lambda (label cps) + (match (intmap-ref cps label) + (($ $kargs names vars ($ $continue k src exp)) + ;; For expressions that define a single value, we know we need + ;; to unbox that value. For $values though we might have to + ;; unbox just a subset of values. + (match exp + (($ $values args) + (let ((def-vars (match (intmap-ref cps k) + (($ $kargs _ defs) defs)))) + (with-cps cps + (let$ term (unbox-args + args def-vars + (lambda (cps args) + (with-cps cps + (build-term + ($continue k src ($values args))))))) + (setk label ($kargs names vars ,term))))) + (_ + (with-cps cps + (letv const) + (letk kunbox ($kargs ('const) (const) + ($continue k src + ($primcall 'scm->f64 (const))))) + (setk label ($kargs names vars + ($continue k src ,exp))))))))) + (compute-unbox-labels) + cps)) + (define (compute-box-labels) + (intset-fold (lambda (phi labels) + (intset-add labels (intmap-ref defs phi))) + phis empty-intset)) + (define (box-results cps) + (intset-fold + (lambda (label cps) + (match (intmap-ref cps label) + (($ $kargs names vars term) + (let* ((boxed (fold1 (lambda (var boxed) + (if (intset-ref phis var) + (intmap-add boxed var (fresh-var)) + boxed)) + vars empty-intmap)) + (bound-vars (map (lambda (var) + (intmap-ref boxed var (lambda (var) var))) + vars))) + (define (box-var cps name var done) + (let ((f64 (intmap-ref boxed var (lambda (_) #f)))) + (if f64 + (with-cps cps + (let$ term (done)) + (letk kboxed ($kargs (name) (var) ,term)) + (build-term + ($continue kboxed #f ($primcall 'f64->scm (f64))))) + (done cps)))) + (define (box-vars cps names vars done) + (match vars + (() (done cps)) + ((var . vars) + (match names + ((name . names) + (box-var cps name var + (lambda (cps) + (box-vars cps names vars done)))))))) + (with-cps cps + (let$ box-term (box-vars names vars + (lambda (cps) + (with-cps cps term)))) + (setk label ($kargs names bound-vars ,box-term))))))) + (compute-box-labels) + cps)) + (pk 'specializing phis) + (box-results (unbox-operands))) + +(define (specialize-f64-phis cps) + (intmap-fold + (lambda (kfun body cps) + (let* ((preds (compute-predecessors cps kfun #:labels body)) + (defs (compute-defs cps body)) + (phis (compute-specializable-f64-phis cps body preds defs))) + (if (eq? phis empty-intset) + cps + (apply-f64-specialization cps kfun body preds defs phis)))) + (compute-reachable-functions cps) + cps)) + +(define (specialize-numbers cps) ;; Type inference wants a renumbered graph; OK. (let ((cps (renumber cps))) (with-fresh-name-state cps - (values (intmap-fold visit-cont cps cps #f))))) + (specialize-f64-phis (specialize-f64-operations cps))))) From 80f2726310c26f2efb64a8460352df19361130b0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 29 Oct 2015 14:50:59 +0000 Subject: [PATCH 099/865] Better f64 unboxing for loop vars that might flow to $ktail * module/language/cps/specialize-numbers.scm (compute-specializable-f64-vars): Tweak to allow f64 values to flow directly to return sites. --- module/language/cps/specialize-numbers.scm | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm index 6d61f5b35..9aa803533 100644 --- a/module/language/cps/specialize-numbers.scm +++ b/module/language/cps/specialize-numbers.scm @@ -178,14 +178,20 @@ (match exp (($ $primcall 'scm->f64 (var)) (intset-add f64-uses var)) - (($ $values (var)) + (($ $values vars) (match (intmap-ref cps k) - (($ $kargs (_) (def)) - (if (intset-ref f64-defs def) - (intset-add f64-uses var) - f64-uses)) - ;; Could be $ktail. - (_ f64-uses))) + (($ $kargs _ defs) + (fold (lambda (var def f64-uses) + (if (intset-ref f64-defs def) + (intset-add f64-uses var) + f64-uses)) + f64-uses vars defs)) + (($ $ktail) + ;; Assume return is rare and that any f64-valued def can + ;; be reboxed when leaving the procedure. + (fold (lambda (var f64-uses) + (intset-add f64-uses var)) + f64-uses vars)))) (_ f64-uses))) (_ f64-uses))) body empty-intset)) From 7dc3e4ba2333e5007729f7f63bfe27dee5d1939d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 29 Oct 2015 14:55:29 +0000 Subject: [PATCH 100/865] Remove debug printout in specialize-numbers * module/language/cps/specialize-numbers.scm (apply-f64-specialization): Remove printout. I didn't see any when compiling Guile, which means that probably this optimization doesn't hit for any code in Guile itself, sadly :P --- module/language/cps/specialize-numbers.scm | 1 - 1 file changed, 1 deletion(-) diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm index 9aa803533..5f15806a8 100644 --- a/module/language/cps/specialize-numbers.scm +++ b/module/language/cps/specialize-numbers.scm @@ -324,7 +324,6 @@ (setk label ($kargs names bound-vars ,box-term))))))) (compute-box-labels) cps)) - (pk 'specializing phis) (box-results (unbox-operands))) (define (specialize-f64-phis cps) From ac5a05d02eac2c3d54dbcf899d71a9786fdafc02 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 11 Nov 2015 10:25:23 +0100 Subject: [PATCH 101/865] Bump bytecode version * libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): * module/system/vm/assembler.scm (*bytecode-minor-version*): Bump bytecode version to prevent 2.1.1 users from thinking that they don't need to make clean after pulling. --- libguile/_scm.h | 2 +- module/system/vm/assembler.scm | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/_scm.h b/libguile/_scm.h index 97ddaf2ab..d84209c92 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -268,7 +268,7 @@ void scm_ia64_longjmp (scm_i_jmp_buf *, int); /* Major and minor versions must be single characters. */ #define SCM_OBJCODE_MAJOR_VERSION 3 -#define SCM_OBJCODE_MINOR_VERSION 6 +#define SCM_OBJCODE_MINOR_VERSION 7 #define SCM_OBJCODE_MAJOR_VERSION_STRING \ SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION) #define SCM_OBJCODE_MINOR_VERSION_STRING \ diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index ae54d1303..296b86c76 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -1653,7 +1653,7 @@ needed." ;; FIXME: Define these somewhere central, shared with C. (define *bytecode-major-version* #x0202) -(define *bytecode-minor-version* 6) +(define *bytecode-minor-version* 7) (define (link-dynamic-section asm text rw rw-init frame-maps) "Link the dynamic section for an ELF image with bytecode @var{text}, From 25738ec35d28437f5703147bc43cf0d45afff964 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 11 Nov 2015 14:51:19 +0100 Subject: [PATCH 102/865] Eval speedup for lexical-ref * module/ice-9/eval.scm (primitive-eval): Specialize lexical-ref for depths 0, 1, and 2. Speeds up this test by around 13%: (primitive-eval '(let lp ((n 0)) (when (< n #e1e7) (lp (1+ n))))) --- module/ice-9/eval.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm index 3b68f07ae..a2bab2065 100644 --- a/module/ice-9/eval.scm +++ b/module/ice-9/eval.scm @@ -119,8 +119,11 @@ (proc arg ...)))) (define (compile-lexical-ref depth width) - (lambda (env) - (env-ref env depth width))) + (case depth + ((0) (lambda (env) (env-ref env 0 width))) + ((1) (lambda (env) (env-ref env 1 width))) + ((2) (lambda (env) (env-ref env 2 width))) + (else (lambda (env) (env-ref env depth width))))) (define (primitive=? name loc module var) "Return true if VAR is the same as the primitive bound to NAME." From 13edcf57a0e39196507bfb76fae9b35b4079e03d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 11 Nov 2015 15:38:45 +0100 Subject: [PATCH 103/865] load-path will skip over stale .go files and keep going * libguile/load.c (compiled_is_fresh): Write warnings to warning port. Move up in the file. (search_path): Add ability to skip over matching files in the path that are stale, relative to some other corresponding file. (scm_search_path, scm_sys_search_load_path): Adapt to search_path changes. (do_try_auto_compile): Write status to warning port. (scm_primitive_load_path): Use new search_path ability to skip over stale files. Allows updates to source files to use freshly-compiled bootstrap files, when building Guile itself. Also allows simplification of fallback logic. (scm_init_eval_in_scheme): Skip stale eval.go files in the path. --- libguile/load.c | 197 ++++++++++++++++++++++++------------------------ 1 file changed, 100 insertions(+), 97 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index 74f3bb49b..d26f9fcf3 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -541,16 +541,53 @@ is_absolute_file_name (SCM filename) return 0; } +/* Return true if COMPILED_FILENAME is newer than source file + FULL_FILENAME, false otherwise. */ +static int +compiled_is_fresh (SCM full_filename, SCM compiled_filename, + struct stat *stat_source, struct stat *stat_compiled) +{ + int compiled_is_newer; + struct timespec source_mtime, compiled_mtime; + + source_mtime = get_stat_mtime (stat_source); + compiled_mtime = get_stat_mtime (stat_compiled); + + if (source_mtime.tv_sec < compiled_mtime.tv_sec + || (source_mtime.tv_sec == compiled_mtime.tv_sec + && source_mtime.tv_nsec <= compiled_mtime.tv_nsec)) + compiled_is_newer = 1; + else + { + compiled_is_newer = 0; + scm_puts_unlocked (";;; note: source file ", scm_current_warning_port ()); + scm_display (full_filename, scm_current_warning_port ()); + scm_puts_unlocked ("\n;;; newer than compiled ", scm_current_warning_port ()); + scm_display (compiled_filename, scm_current_warning_port ()); + scm_puts_unlocked ("\n", scm_current_warning_port ()); + } + + return compiled_is_newer; +} + /* Search PATH for a directory containing a file named FILENAME. The file must be readable, and not a directory. If we find one, return its full pathname; otherwise, return #f. If FILENAME is absolute, return it unchanged. We also fill *stat_buf corresponding to the returned pathname. If given, EXTENSIONS is a list of strings; for each directory - in PATH, we search for FILENAME concatenated with each EXTENSION. */ + in PATH, we search for FILENAME concatenated with each EXTENSION. + + If SOURCE_FILE_NAME is SCM_BOOL_F, then return the first matching + file name that we find in the path. Otherwise only return a file if + it is newer than SOURCE_STAT_BUF, otherwise issuing a warning if we + see a stale file earlier in the path, setting *FOUND_STALE_FILE to 1. + */ static SCM search_path (SCM path, SCM filename, SCM extensions, SCM require_exts, - struct stat *stat_buf) + struct stat *stat_buf, + SCM source_file_name, struct stat *source_stat_buf, + int *found_stale_file) { struct stringbuf buf; char *filename_chars; @@ -653,8 +690,27 @@ search_path (SCM path, SCM filename, SCM extensions, SCM require_exts, if (stat (buf.buf, stat_buf) == 0 && ! (stat_buf->st_mode & S_IFDIR)) { - result = + SCM found = scm_from_locale_string (scm_i_mirror_backslashes (buf.buf)); + + if (scm_is_true (source_file_name) && + !compiled_is_fresh (source_file_name, found, + source_stat_buf, stat_buf)) + { + if (found_stale_file) + *found_stale_file = 1; + continue; + } + + if (found_stale_file && *found_stale_file) + { + scm_puts_unlocked (";;; found fresh compiled file at ", + scm_current_warning_port ()); + scm_display (found, scm_current_warning_port ()); + scm_newline (scm_current_warning_port ()); + } + + result = found; goto end; } } @@ -724,7 +780,8 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 0, 1, if (SCM_UNBNDP (require_exts)) require_exts = SCM_BOOL_F; - return search_path (path, filename, extensions, require_exts, &stat_buf); + return search_path (path, filename, extensions, require_exts, &stat_buf, + SCM_BOOL_F, NULL, NULL); } #undef FUNC_NAME @@ -749,40 +806,11 @@ SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0, SCM_VALIDATE_STRING (1, filename); return search_path (*scm_loc_load_path, filename, *scm_loc_load_extensions, - SCM_BOOL_F, &stat_buf); + SCM_BOOL_F, &stat_buf, SCM_BOOL_F, NULL, NULL); } #undef FUNC_NAME -/* Return true if COMPILED_FILENAME is newer than source file - FULL_FILENAME, false otherwise. */ -static int -compiled_is_fresh (SCM full_filename, SCM compiled_filename, - struct stat *stat_source, struct stat *stat_compiled) -{ - int compiled_is_newer; - struct timespec source_mtime, compiled_mtime; - - source_mtime = get_stat_mtime (stat_source); - compiled_mtime = get_stat_mtime (stat_compiled); - - if (source_mtime.tv_sec < compiled_mtime.tv_sec - || (source_mtime.tv_sec == compiled_mtime.tv_sec - && source_mtime.tv_nsec <= compiled_mtime.tv_nsec)) - compiled_is_newer = 1; - else - { - compiled_is_newer = 0; - scm_puts_unlocked (";;; note: source file ", scm_current_error_port ()); - scm_display (full_filename, scm_current_error_port ()); - scm_puts_unlocked ("\n;;; newer than compiled ", scm_current_error_port ()); - scm_display (compiled_filename, scm_current_error_port ()); - scm_puts_unlocked ("\n", scm_current_error_port ()); - } - - return compiled_is_newer; -} - SCM_KEYWORD (kw_env, "env"); SCM_KEYWORD (kw_opts, "opts"); @@ -795,9 +823,9 @@ do_try_auto_compile (void *data) SCM source = SCM_PACK_POINTER (data); SCM comp_mod, compile_file; - scm_puts_unlocked (";;; compiling ", scm_current_error_port ()); - scm_display (source, scm_current_error_port ()); - scm_newline (scm_current_error_port ()); + scm_puts_unlocked (";;; compiling ", scm_current_warning_port ()); + scm_display (source, scm_current_warning_port ()); + scm_newline (scm_current_warning_port ()); comp_mod = scm_c_resolve_module ("system base compile"); compile_file = scm_module_variable (comp_mod, sym_compile_file); @@ -824,17 +852,17 @@ do_try_auto_compile (void *data) /* Assume `*current-warning-prefix*' has an appropriate value. */ res = scm_call_n (scm_variable_ref (compile_file), args, 5); - scm_puts_unlocked (";;; compiled ", scm_current_error_port ()); - scm_display (res, scm_current_error_port ()); - scm_newline (scm_current_error_port ()); + scm_puts_unlocked (";;; compiled ", scm_current_warning_port ()); + scm_display (res, scm_current_warning_port ()); + scm_newline (scm_current_warning_port ()); return res; } else { - scm_puts_unlocked (";;; it seems ", scm_current_error_port ()); - scm_display (source, scm_current_error_port ()); + scm_puts_unlocked (";;; it seems ", scm_current_warning_port ()); + scm_display (source, scm_current_warning_port ()); scm_puts_unlocked ("\n;;; is part of the compiler; skipping auto-compilation\n", - scm_current_error_port ()); + scm_current_warning_port ()); return SCM_BOOL_F; } } @@ -946,9 +974,9 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, { SCM filename, exception_on_not_found; SCM full_filename, compiled_filename; - int compiled_is_fallback = 0; SCM hook = *scm_loc_load_hook; struct stat stat_source, stat_compiled; + int found_stale_compiled_file = 0; if (scm_is_true (hook) && scm_is_false (scm_procedure_p (hook))) SCM_MISC_ERROR ("value of %load-hook is neither a procedure nor #f", @@ -982,12 +1010,13 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, full_filename = search_path (*scm_loc_load_path, filename, *scm_loc_load_extensions, SCM_BOOL_F, - &stat_source); + &stat_source, SCM_BOOL_F, NULL, NULL); compiled_filename = search_path (*scm_loc_load_compiled_path, filename, *scm_loc_load_compiled_extensions, SCM_BOOL_T, - &stat_compiled); + &stat_compiled, full_filename, &stat_source, + &found_stale_compiled_file); if (scm_is_false (compiled_filename) && scm_is_true (full_filename) @@ -1005,10 +1034,18 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, scm_car (*scm_loc_load_compiled_extensions))); fallback_chars = scm_to_locale_string (fallback); - if (stat (fallback_chars, &stat_compiled) == 0) + if (stat (fallback_chars, &stat_compiled) == 0 + && compiled_is_fresh (full_filename, fallback, + &stat_source, &stat_compiled)) { + if (found_stale_compiled_file) + { + scm_puts_unlocked (";;; found fresh local cache at ", + scm_current_warning_port ()); + scm_display (fallback, scm_current_warning_port ()); + scm_newline (scm_current_warning_port ()); + } compiled_filename = fallback; - compiled_is_fallback = 1; } free (fallback_chars); } @@ -1028,53 +1065,17 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, scm_call_1 (hook, (scm_is_true (full_filename) ? full_filename : compiled_filename)); - if (scm_is_false (full_filename) - || (scm_is_true (compiled_filename) - && compiled_is_fresh (full_filename, compiled_filename, - &stat_source, &stat_compiled))) + if (scm_is_true (compiled_filename)) return scm_load_compiled_with_vm (compiled_filename); - - /* Perhaps there was the installed .go that was stale, but our fallback is - fresh. Let's try that. Duplicating code, but perhaps that's OK. */ - - if (!compiled_is_fallback - && scm_is_true (*scm_loc_compile_fallback_path) - && scm_is_false (*scm_loc_fresh_auto_compile) - && scm_is_pair (*scm_loc_load_compiled_extensions) - && scm_is_string (scm_car (*scm_loc_load_compiled_extensions))) + else { - SCM fallback; - char *fallback_chars; - int stat_ret; - - fallback = scm_string_append - (scm_list_3 (*scm_loc_compile_fallback_path, - canonical_suffix (full_filename), - scm_car (*scm_loc_load_compiled_extensions))); + SCM freshly_compiled = scm_try_auto_compile (full_filename); - fallback_chars = scm_to_locale_string (fallback); - stat_ret = stat (fallback_chars, &stat_compiled); - free (fallback_chars); - - if (stat_ret == 0 && compiled_is_fresh (full_filename, fallback, - &stat_source, &stat_compiled)) - { - scm_puts_unlocked (";;; found fresh local cache at ", scm_current_warning_port ()); - scm_display (fallback, scm_current_warning_port ()); - scm_newline (scm_current_warning_port ()); - return scm_load_compiled_with_vm (fallback); - } + if (scm_is_true (freshly_compiled)) + return scm_load_compiled_with_vm (freshly_compiled); + else + return scm_primitive_load (full_filename); } - - /* Otherwise, we bottom out here. */ - { - SCM freshly_compiled = scm_try_auto_compile (full_filename); - - if (scm_is_true (freshly_compiled)) - return scm_load_compiled_with_vm (freshly_compiled); - else - return scm_primitive_load (full_filename); - } } #undef FUNC_NAME @@ -1089,20 +1090,22 @@ scm_init_eval_in_scheme (void) { SCM eval_scm, eval_go; struct stat stat_source, stat_compiled; + int found_stale_eval_go = 0; eval_scm = search_path (*scm_loc_load_path, scm_from_locale_string ("ice-9/eval.scm"), - SCM_EOL, SCM_BOOL_F, &stat_source); + SCM_EOL, SCM_BOOL_F, &stat_source, + SCM_BOOL_F, NULL, NULL); eval_go = search_path (*scm_loc_load_compiled_path, scm_from_locale_string ("ice-9/eval.go"), - SCM_EOL, SCM_BOOL_F, &stat_compiled); + SCM_EOL, SCM_BOOL_F, &stat_compiled, + eval_scm, &stat_source, &found_stale_eval_go); - if (scm_is_true (eval_scm) && scm_is_true (eval_go) - && compiled_is_fresh (eval_scm, eval_go, - &stat_source, &stat_compiled)) + if (scm_is_true (eval_go)) scm_load_compiled_with_vm (eval_go); else - /* if we have no eval.go, we shouldn't load any compiled code at all */ + /* If we have no eval.go, we shouldn't load any compiled code at all + because we can't guarantee that tail calls will work. */ *scm_loc_load_compiled_path = SCM_EOL; } From 92ed7f69894316247e78c29b953bb59b5c3953d7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 11 Nov 2015 16:30:59 +0100 Subject: [PATCH 104/865] Fix miscompilation of closures allocated as vectors * module/language/cps/closure-conversion.scm (convert-one): Fix miscompilation of vector closure initialization. --- module/language/cps/closure-conversion.scm | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm index 29577a99c..c6f941db3 100644 --- a/module/language/cps/closure-conversion.scm +++ b/module/language/cps/closure-conversion.scm @@ -587,12 +587,12 @@ bound to @var{var}, and continue to @var{k}." (letk k ($kargs () () ,body)) ($ (convert-arg v (lambda (cps v) - (with-cps cps - ($ (with-cps-constants ((idx idx)) - (let ((op (cond - ((not known?) 'free-set!) - ((<= idx #xff) 'vector-set!/immediate) - (else 'vector-set!)))) + (let ((op (cond + ((not known?) 'free-set!) + ((<= idx #xff) 'vector-set!/immediate) + (else 'vector-set!)))) + (with-cps cps + ($ (with-cps-constants ((idx idx)) (build-term ($continue k src ($primcall op (var idx v)))))))))))))))))) From 3e5d4131d2b8eecf72568bc94d626a7cdced7f5b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 12 Nov 2015 21:16:33 +0100 Subject: [PATCH 105/865] Don't compile equal? to br-if-equal * module/language/cps/compile-bytecode.scm (compile-function): * module/language/cps/primitives.scm (*branching-primcall-arities*): * module/language/cps/type-fold.scm (equal?): * module/language/cps/types.scm (equal?): * module/language/tree-il/compile-cps.scm (convert): `equal?' is no longer a branching primcall, because it isn't inline. The implementation could lead to bad backtraces also, as it didn't save the IP, and actually could lead to segfaults as it didn't reload the SP after the return. There is an eqv? fast-path, though. * module/system/vm/assembler.scm (br-if-equal): Remove interface. * module/system/vm/disassembler.scm (code-annotation): (compute-labels): No need to handle br-if-equal. --- module/language/cps/compile-bytecode.scm | 1 - module/language/cps/primitives.scm | 1 - module/language/cps/type-fold.scm | 1 - module/language/cps/types.scm | 2 +- module/language/tree-il/compile-cps.scm | 12 ++++++++++++ module/system/vm/assembler.scm | 1 - module/system/vm/disassembler.scm | 4 ++-- 7 files changed, 15 insertions(+), 7 deletions(-) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 49b684cc4..1c7b99bcc 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -366,7 +366,6 @@ ;; the set of macro-instructions in assembly.scm. (($ $primcall 'eq? (a b)) (binary emit-br-if-eq a b)) (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b)) - (($ $primcall 'equal? (a b)) (binary emit-br-if-equal a b)) (($ $primcall '< (a b)) (binary emit-br-if-< a b)) (($ $primcall '<= (a b)) (binary emit-br-if-<= a b)) (($ $primcall '= (a b)) (binary emit-br-if-= a b)) diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm index 5f7f474f8..5074fb90c 100644 --- a/module/language/cps/primitives.scm +++ b/module/language/cps/primitives.scm @@ -82,7 +82,6 @@ (char? . (1 . 1)) (eq? . (1 . 2)) (eqv? . (1 . 2)) - (equal? . (1 . 2)) (= . (1 . 2)) (< . (1 . 2)) (> . (1 . 2)) diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm index e7a343b05..c3703064c 100644 --- a/module/language/cps/type-fold.scm +++ b/module/language/cps/type-fold.scm @@ -91,7 +91,6 @@ (else (values #f #f)))) (define-branch-folder-alias eqv? eq?) -(define-branch-folder-alias equal? eq?) (define (compare-ranges type0 min0 max0 type1 min1 max1) (and (zero? (logand (logior type0 type1) (lognot &real))) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index dac29f7d2..08e8ec8de 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -483,7 +483,7 @@ minimum, and maximum." (max (min (&max a) (&max b)))) (restrict! a type min max) (restrict! b type min max)))) -(define-type-inferrer-aliases eq? eqv? equal?) +(define-type-inferrer-aliases eq? eqv?) (define-syntax-rule (define-simple-predicate-inferrer predicate type) (define-predicate-inferrer (predicate val true?) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 393b0a8f9..2ef751b84 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -506,6 +506,18 @@ (($ src name args) (cond + ((eq? name 'equal?) + (convert-args cps args + (lambda (cps args) + (with-cps cps + (let$ k* (adapt-arity k src 1)) + (letk kt ($kargs () () ($continue k* src ($const #t)))) + (letk kf* ($kargs () () + ;; Here we continue to the original $kreceive + ;; or $ktail, as equal? doesn't have a VM op. + ($continue k src ($primcall 'equal? args)))) + (build-term ($continue kf* src + ($branch kt ($primcall 'eqv? args)))))))) ((branching-primitive? name) (convert-args cps args (lambda (cps args) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 296b86c76..babe4796f 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -91,7 +91,6 @@ emit-br-if-tc7 emit-br-if-eq emit-br-if-eqv - emit-br-if-equal emit-br-if-= emit-br-if-< emit-br-if-<= diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index f718a4c84..d90c88505 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -193,7 +193,7 @@ address of that offset." (((or 'br 'br-if-nargs-ne 'br-if-nargs-lt 'br-if-nargs-gt 'br-if-true 'br-if-null 'br-if-nil 'br-if-pair 'br-if-struct - 'br-if-char 'br-if-eq 'br-if-eqv 'br-if-equal + 'br-if-char 'br-if-eq 'br-if-eqv 'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->= 'br-if-logtest) _ ... target) (list "-> ~A" (vector-ref labels (- (+ offset target) start)))) @@ -295,7 +295,7 @@ address of that offset." ((br br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt br-if-true br-if-null br-if-nil br-if-pair br-if-struct - br-if-char br-if-tc7 br-if-eq br-if-eqv br-if-equal + br-if-char br-if-tc7 br-if-eq br-if-eqv br-if-= br-if-< br-if-<= br-if-> br-if->= br-if-logtest) (match arg ((_ ... target) From d729a0dc757943c2bafb0cb300fc1ae7b3f56e91 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 12 Nov 2015 21:23:09 +0100 Subject: [PATCH 106/865] Remove br-if-equal opcode * libguile/vm-engine.c (br-if-equal): Remove opcode. --- libguile/vm-engine.c | 15 ++------------- 1 file changed, 2 insertions(+), 13 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index d33878d20..486585d4e 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -1464,20 +1464,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, && scm_is_true (scm_eqv_p (x, y)))); } - // FIXME: remove, have compiler inline eqv test instead - /* br-if-equal a:12 b:12 invert:1 _:7 offset:24 - * - * If the value in A is equal? to the value in B, add OFFSET, a signed - * 24-bit number, to the current instruction pointer. - */ - // FIXME: Should sync_ip before calling out and cache_sp before coming - // back! Another reason to remove this opcode! - VM_DEFINE_OP (43, br_if_equal, "br-if-equal", OP3 (X8_S24, X8_S24, B1_X7_L24)) + VM_DEFINE_OP (43, unused_43, NULL, NOP) { - BR_BINARY (x, y, - scm_is_eq (x, y) - || (SCM_NIMP (x) && SCM_NIMP (y) - && scm_is_true (scm_equal_p (x, y)))); + abort (); } /* br-if-logtest a:24 _:8 b:24 invert:1 _:7 offset:24 From 02fc5a772bc95bbd70a81b8589bf261a3822f9bd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 26 Nov 2015 16:36:22 +0100 Subject: [PATCH 107/865] Identify boot continuations by code, not closure * libguile/vm.h: * libguile/vm.c (scm_i_vm_is_boot_continuation_code): New internal procedure. * libguile/stacks.c (scm_make_stack): * libguile/frames.c (scm_c_frame_previous): Use new helper to identify boot frames. --- libguile/frames.c | 7 ++----- libguile/stacks.c | 3 +-- libguile/vm.c | 6 ++++++ libguile/vm.h | 1 + 4 files changed, 10 insertions(+), 7 deletions(-) diff --git a/libguile/frames.c b/libguile/frames.c index 48e963a0f..312d53b00 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -388,11 +388,8 @@ scm_c_frame_previous (enum scm_vm_frame_kind kind, struct scm_frame *frame) frame->sp_offset = stack_top - new_sp; frame->ip = SCM_FRAME_RETURN_ADDRESS (this_fp); - { - SCM proc = scm_c_frame_closure (kind, frame); - if (SCM_PROGRAM_P (proc) && SCM_PROGRAM_IS_BOOT (proc)) - goto again; - } + if (scm_i_vm_is_boot_continuation_code (frame->ip)) + goto again; return 1; } diff --git a/libguile/stacks.c b/libguile/stacks.c index 366176b10..958103ad6 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -361,8 +361,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, /* Skip initial boot frame, if any. This is possible if the frame originates from a captured continuation. */ - if (SCM_PROGRAM_P (scm_c_frame_closure (kind, &frame)) - && SCM_PROGRAM_IS_BOOT (scm_c_frame_closure (kind, &frame)) + if (scm_i_vm_is_boot_continuation_code (frame.ip) && !scm_c_frame_previous (kind, &frame)) return SCM_BOOL_F; diff --git a/libguile/vm.c b/libguile/vm.c index 5ea6b2bd4..014ee65f5 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -661,6 +661,12 @@ static const scm_t_uint32 vm_builtin_call_with_current_continuation_code[] = { }; +int +scm_i_vm_is_boot_continuation_code (scm_t_uint32 *ip) +{ + return ip == vm_boot_continuation_code; +} + static SCM scm_vm_builtin_ref (unsigned idx) { diff --git a/libguile/vm.h b/libguile/vm.h index 936633d21..2ca4f2ab4 100644 --- a/libguile/vm.h +++ b/libguile/vm.h @@ -106,6 +106,7 @@ SCM_INTERNAL SCM scm_i_vm_capture_stack (union scm_vm_stack_element *stack_top, SCM_INTERNAL int scm_i_vm_cont_to_frame (SCM cont, struct scm_frame *frame); SCM_INTERNAL void scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate); +SCM_INTERNAL int scm_i_vm_is_boot_continuation_code (scm_t_uint32 *ip); SCM_INTERNAL void scm_bootstrap_vm (void); SCM_INTERNAL void scm_init_vm (void); From e5d7c0f13b51b47115d98874c3a3cd51900ba8a3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 26 Nov 2015 16:47:17 +0100 Subject: [PATCH 108/865] All arities serialize a "closure" binding * module/language/cps/compile-bytecode.scm (compile-function): Always define a 'closure binding in slot 0. * module/system/vm/frame.scm (available-bindings): No need to futz around not having a closure binding. * module/system/vm/debug.scm (arity-arguments-alist): Expect a closure binding. * test-suite/tests/rtl.test: Emit definitions for the closure. --- module/language/cps/compile-bytecode.scm | 4 +++- module/system/vm/debug.scm | 24 +++++++++++++----------- module/system/vm/frame.scm | 4 +--- test-suite/tests/rtl.test | 17 ++++++++++++++--- 4 files changed, 31 insertions(+), 18 deletions(-) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 1c7b99bcc..7fa5a003c 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -472,7 +472,9 @@ (emit-label asm label) (set! frame-size (lookup-nlocals label allocation)) (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys? - frame-size alt))) + frame-size alt) + ;; All arities define a closure binding in slot 0. + (emit-definition asm 'closure 0 'scm))) (($ $kargs names vars ($ $continue k src exp)) (emit-label asm label) (for-each (lambda (name var) diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm index 814472b7a..4d9a047fe 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -468,19 +468,21 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}." (flags (arity-flags* bv header)) (nreq (arity-nreq* bv header)) (nopt (arity-nopt* bv header)) - (nargs (+ nreq nopt (if (has-rest? flags) 1 0)))) + (nargs (+ nreq nopt (if (has-rest? flags) 1 0))) + (nargs+closure (1+ nargs))) (when (is-case-lambda? flags) (error "invalid request for locals of case-lambda wrapper arity")) - (let ((args (arity-locals arity nargs))) - (call-with-values (lambda () (split-at args nreq)) - (lambda (req args) - (call-with-values (lambda () (split-at args nopt)) - (lambda (opt args) - `((required . ,req) - (optional . ,opt) - (keyword . ,(arity-keyword-args arity)) - (allow-other-keys? . ,(allow-other-keys? flags)) - (rest . ,(and (has-rest? flags) (car args))))))))))) + (match (arity-locals arity nargs+closure) + ((closure . args) + (call-with-values (lambda () (split-at args nreq)) + (lambda (req args) + (call-with-values (lambda () (split-at args nopt)) + (lambda (opt args) + `((required . ,req) + (optional . ,opt) + (keyword . ,(arity-keyword-args arity)) + (allow-other-keys? . ,(allow-other-keys? flags)) + (rest . ,(and (has-rest? flags) (car args)))))))))))) (define (find-first-arity context base addr) (let* ((bv (elf-bytes (debug-context-elf context))) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index 6e4527956..38850b61e 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -277,9 +277,7 @@ (if n (match (vector-ref defs n) (#(name def-offset slot representation) - ;; Binding 0 is the closure, and is not present - ;; in arity-definitions. - (cons (make-binding (1+ n) name slot representation) + (cons (make-binding n name slot representation) (lp (1+ n))))) '())))) (lp (1+ n) (- offset (vector-ref parsed n))))))) diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test index bae76825e..57047a2fb 100644 --- a/test-suite/tests/rtl.test +++ b/test-suite/tests/rtl.test @@ -104,12 +104,13 @@ a procedure." '((begin-program countdown ((name . countdown))) (begin-standard-arity (x) 4 #f) + (definition closure 0 scm) (definition x 1 scm) (br fix-body) (label loop-head) (br-if-= 1 2 #f out) (add 0 1 0) - (add1 1 1) + (add/immediate 1 1 1) (br loop-head) (label fix-body) (load-constant 1 0) @@ -143,6 +144,7 @@ a procedure." (begin-program accum ((name . accum))) (begin-standard-arity (x) 4 #f) + (definition closure 0 scm) (definition x 1 scm) (free-ref 1 3 0) (box-ref 0 1) @@ -164,6 +166,7 @@ a procedure." '((begin-program call ((name . call))) (begin-standard-arity (f) 7 #f) + (definition closure 0 scm) (definition f 1 scm) (mov 1 5) (call 5 1) @@ -179,6 +182,7 @@ a procedure." '((begin-program call-with-3 ((name . call-with-3))) (begin-standard-arity (f) 7 #f) + (definition closure 0 scm) (definition f 1 scm) (mov 1 5) (load-constant 0 3) @@ -196,6 +200,7 @@ a procedure." '((begin-program call ((name . call))) (begin-standard-arity (f) 2 #f) + (definition closure 0 scm) (definition f 1 scm) (mov 1 0) (tail-call 1) @@ -209,6 +214,7 @@ a procedure." '((begin-program call-with-3 ((name . call-with-3))) (begin-standard-arity (f) 2 #f) + (definition closure 0 scm) (definition f 1 scm) (mov 1 0) ;; R0 <- R1 (load-constant 0 3) ;; R1 <- 3 @@ -234,6 +240,7 @@ a procedure." (begin-program sqrt-trampoline ((name . sqrt-trampoline))) (begin-standard-arity (x) 3 #f) + (definition closure 0 scm) (definition x 1 scm) (cached-toplevel-box 0 sqrt-scope sqrt #t) (box-ref 2 0) @@ -264,7 +271,7 @@ a procedure." (begin-standard-arity () 3 #f) (cached-toplevel-box 1 top-incrementor *top-val* #t) (box-ref 0 1) - (add1 0 0) + (add/immediate 0 0 1) (box-set! 1 0) (return-values 1) (end-arity) @@ -287,6 +294,7 @@ a procedure." (begin-program sqrt-trampoline ((name . sqrt-trampoline))) (begin-standard-arity (x) 3 #f) + (definition closure 0 scm) (definition x 1 scm) (cached-module-box 0 (guile) sqrt #t #t) (box-ref 2 0) @@ -313,7 +321,7 @@ a procedure." (begin-standard-arity () 3 #f) (cached-module-box 1 (tests bytecode) *top-val* #f #t) (box-ref 0 1) - (add1 0 0) + (add/immediate 0 0 1) (box-set! 1 0) (mov 1 0) (return-values 2) @@ -359,6 +367,7 @@ a procedure." (assemble-program '((begin-program foo ((name . foo))) (begin-standard-arity () 2 #f) + (definition closure 0 scm) (load-constant 0 42) (return-values 2) (end-arity) @@ -368,6 +377,7 @@ a procedure." (assemble-program '((begin-program foo ((name . foo))) (begin-standard-arity (x y) 3 #f) + (definition closure 0 scm) (definition x 1 scm) (definition y 2 scm) (load-constant 1 42) @@ -380,6 +390,7 @@ a procedure." (assemble-program '((begin-program foo ((name . foo))) (begin-opt-arity (x) (y) z 4 #f) + (definition closure 0 scm) (definition x 1 scm) (definition y 2 scm) (definition z 3 scm) From 3b3405e5040ea5d264706bc82e2a5bb224c704cd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 26 Nov 2015 17:27:01 +0100 Subject: [PATCH 109/865] Apply of non-programs has IP that is not from prev frame * libguile/vm-engine.c (vm_engine) * libguile/vm.c (vm_apply_non_program_code): Arrange so that the code to apply a non-program has its own IP, so that frame-instruction-pointer for a non-program application doesn't point into the previously active frame. --- libguile/vm-engine.c | 114 ++++++++++++++++++++++++------------------- libguile/vm.c | 4 ++ 2 files changed, 67 insertions(+), 51 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 486585d4e..885ef72ef 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -463,36 +463,10 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, if (SCM_UNLIKELY (resume)) NEXT (0); - apply: - while (!SCM_PROGRAM_P (FP_REF (0))) - { - SCM proc = FP_REF (0); - - if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)) - { - FP_SET (0, SCM_STRUCT_PROCEDURE (proc)); - continue; - } - if (SCM_HAS_TYP7 (proc, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (proc)) - { - scm_t_uint32 n = FRAME_LOCALS_COUNT(); - - /* Shuffle args up. (FIXME: no real need to shuffle; just set - IP and go. ) */ - ALLOC_FRAME (n + 1); - while (n--) - FP_SET (n + 1, FP_REF (n)); - - FP_SET (0, SCM_SMOB_DESCRIPTOR (proc).apply_trampoline); - continue; - } - - SYNC_IP(); - vm_error_wrong_type_apply (proc); - } - - /* Let's go! */ - ip = SCM_PROGRAM_CODE (FP_REF (0)); + if (SCM_LIKELY (SCM_PROGRAM_P (FP_REF (0)))) + ip = SCM_PROGRAM_CODE (FP_REF (0)); + else + ip = (scm_t_uint32 *) vm_apply_non_program_code; APPLY_HOOK (); @@ -568,10 +542,10 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, RESET_FRAME (nlocals); - if (SCM_UNLIKELY (!SCM_PROGRAM_P (FP_REF (0)))) - goto apply; - - ip = SCM_PROGRAM_CODE (FP_REF (0)); + if (SCM_LIKELY (SCM_PROGRAM_P (FP_REF (0)))) + ip = SCM_PROGRAM_CODE (FP_REF (0)); + else + ip = (scm_t_uint32 *) vm_apply_non_program_code; APPLY_HOOK (); @@ -632,10 +606,10 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, RESET_FRAME (nlocals); - if (SCM_UNLIKELY (!SCM_PROGRAM_P (FP_REF (0)))) - goto apply; - - ip = SCM_PROGRAM_CODE (FP_REF (0)); + if (SCM_LIKELY (SCM_PROGRAM_P (FP_REF (0)))) + ip = SCM_PROGRAM_CODE (FP_REF (0)); + else + ip = (scm_t_uint32 *) vm_apply_non_program_code; APPLY_HOOK (); @@ -689,10 +663,10 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, RESET_FRAME (n + 1); - if (SCM_UNLIKELY (!SCM_PROGRAM_P (FP_REF (0)))) - goto apply; - - ip = SCM_PROGRAM_CODE (FP_REF (0)); + if (SCM_LIKELY (SCM_PROGRAM_P (FP_REF (0)))) + ip = SCM_PROGRAM_CODE (FP_REF (0)); + else + ip = (scm_t_uint32 *) vm_apply_non_program_code; APPLY_HOOK (); @@ -931,10 +905,10 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, for (i = 0; i < list_len; i++, list = SCM_CDR (list)) FP_SET (list_idx - 1 + i, SCM_CAR (list)); - if (SCM_UNLIKELY (!SCM_PROGRAM_P (FP_REF (0)))) - goto apply; - - ip = SCM_PROGRAM_CODE (FP_REF (0)); + if (SCM_LIKELY (SCM_PROGRAM_P (FP_REF (0)))) + ip = SCM_PROGRAM_CODE (FP_REF (0)); + else + ip = (scm_t_uint32 *) vm_apply_non_program_code; APPLY_HOOK (); @@ -977,10 +951,10 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, SP_SET (1, SP_REF (0)); SP_SET (0, cont); - if (SCM_UNLIKELY (!SCM_PROGRAM_P (SP_REF (1)))) - goto apply; - - ip = SCM_PROGRAM_CODE (SP_REF (1)); + if (SCM_LIKELY (SCM_PROGRAM_P (SP_REF (1)))) + ip = SCM_PROGRAM_CODE (SP_REF (1)); + else + ip = (scm_t_uint32 *) vm_apply_non_program_code; APPLY_HOOK (); @@ -3299,7 +3273,45 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (1); } - VM_DEFINE_OP (142, unused_142, NULL, NOP) + /* apply-non-program _:24 + * + * Used by the VM as a trampoline to apply non-programs. + */ + VM_DEFINE_OP (142, apply_non_program, "apply-non-program", OP1 (X32)) + { + SCM proc = FP_REF (0); + + while (!SCM_PROGRAM_P (proc)) + { + if (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)) + { + proc = SCM_STRUCT_PROCEDURE (proc); + FP_SET (0, proc); + continue; + } + if (SCM_HAS_TYP7 (proc, scm_tc7_smob) && SCM_SMOB_APPLICABLE_P (proc)) + { + scm_t_uint32 n = FRAME_LOCALS_COUNT(); + + /* Shuffle args up. (FIXME: no real need to shuffle; just set + IP and go. ) */ + ALLOC_FRAME (n + 1); + while (n--) + FP_SET (n + 1, FP_REF (n)); + + proc = SCM_SMOB_DESCRIPTOR (proc).apply_trampoline; + FP_SET (0, proc); + continue; + } + + SYNC_IP(); + vm_error_wrong_type_apply (proc); + } + + ip = SCM_PROGRAM_CODE (proc); + NEXT (0); + } + VM_DEFINE_OP (143, unused_143, NULL, NOP) VM_DEFINE_OP (144, unused_144, NULL, NOP) VM_DEFINE_OP (145, unused_145, NULL, NOP) diff --git a/libguile/vm.c b/libguile/vm.c index 014ee65f5..ece3c33e4 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -630,6 +630,10 @@ static const scm_t_uint32 vm_boot_continuation_code[] = { SCM_PACK_OP_24 (halt, 0) }; +static const scm_t_uint32 vm_apply_non_program_code[] = { + SCM_PACK_OP_24 (apply_non_program, 0) +}; + static const scm_t_uint32 vm_builtin_apply_code[] = { SCM_PACK_OP_24 (assert_nargs_ge, 3), SCM_PACK_OP_24 (tail_apply, 0), /* proc in r1, args from r2 */ From 8af3423efe1aa4168a097cf9ae11d3c4338894bb Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 27 Nov 2015 11:44:11 +0100 Subject: [PATCH 110/865] Remove primitive?, add primitive-code? We need to be able to identify frames that are primitive applications without assuming that slot 0 in a frame is an SCM value and without assuming that value is the procedure being applied. * libguile/gsubr.c (scm_i_primitive_code_p): New helper. (scm_i_primitive_arity): Use the new helper. * libguile/gsubr.h: Declare the new helper. * libguile/programs.h: * libguile/programs.c (scm_program_code_p): New function, replacing scm_primitive_p. (scm_primitive_call_ip): Fix FUNC_NAME definition. * module/statprof.scm (sample-stack-procs, count-call): Identify primitive frames from the IP, not the frame-procedure. Avoids the assumption that slot 0 in a frame is a SCM value. (statprof-proc-call-data): Adapt to primitive-code? change. * module/system/vm/frame.scm (frame-call-representation): Identify primitive frames from the IP, not the closure. Still more work to do here to avoid assuming slot 0 is a procedure. * module/system/vm/program.scm: Export primitive-code? instead of primitive?. (program-arguments-alist, program-arguments-alists): Identify primitives from the code instead of the flags on the program. Not sure this is a great change, but it does avoid having to define a primitive? predicate in Scheme. --- libguile/gsubr.c | 15 ++++++++-- libguile/gsubr.h | 1 + libguile/programs.c | 12 ++++---- libguile/programs.h | 2 +- module/statprof.scm | 33 ++++++++++++--------- module/system/vm/frame.scm | 2 +- module/system/vm/program.scm | 57 ++++++++++++++++-------------------- 7 files changed, 67 insertions(+), 55 deletions(-) diff --git a/libguile/gsubr.c b/libguile/gsubr.c index a3b804bb5..d80e5dd42 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -251,6 +251,17 @@ create_subr (int define, const char *name, return ret; } +int +scm_i_primitive_code_p (const scm_t_uint32 *code) +{ + if (code < subr_stub_code) + return 0; + if (code > subr_stub_code + (sizeof(subr_stub_code) / sizeof(scm_t_uint32))) + return 0; + + return 1; +} + /* Given a program that is a primitive, determine its minimum arity. This is possible because each primitive's code is 4 32-bit words long, and they are laid out contiguously in an ordered pattern. */ @@ -260,9 +271,7 @@ scm_i_primitive_arity (SCM prim, int *req, int *opt, int *rest) const scm_t_uint32 *code = SCM_PROGRAM_CODE (prim); unsigned idx, nargs, base, next; - if (code < subr_stub_code) - return 0; - if (code > subr_stub_code + (sizeof(subr_stub_code) / sizeof(scm_t_uint32))) + if (!scm_i_primitive_code_p (code)) return 0; idx = (code - subr_stub_code) / 4; diff --git a/libguile/gsubr.h b/libguile/gsubr.h index a9db85e44..725de2cbd 100644 --- a/libguile/gsubr.h +++ b/libguile/gsubr.h @@ -54,6 +54,7 @@ +SCM_INTERNAL int scm_i_primitive_code_p (const scm_t_uint32 *code); SCM_INTERNAL int scm_i_primitive_arity (SCM subr, int *req, int *opt, int *rest); SCM_INTERNAL scm_t_uintptr scm_i_primitive_call_ip (SCM subr); diff --git a/libguile/programs.c b/libguile/programs.c index 64c861a71..c03865de1 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -144,19 +144,21 @@ SCM_DEFINE (scm_program_p, "program?", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_primitive_p, "primitive?", 1, 0, 0, - (SCM obj), +SCM_DEFINE (scm_primitive_code_p, "primitive-code?", 1, 0, 0, + (SCM code), "") -#define FUNC_NAME s_scm_primitive_p +#define FUNC_NAME s_scm_primitive_code_p { - return scm_from_bool (SCM_PRIMITIVE_P (obj)); + const scm_t_uint32 * ptr = (const scm_t_uint32 *) scm_to_uintptr_t (code); + + return scm_from_bool (scm_i_primitive_code_p (ptr)); } #undef FUNC_NAME SCM_DEFINE (scm_primitive_call_ip, "primitive-call-ip", 1, 0, 0, (SCM prim), "") -#define FUNC_NAME s_scm_primitive_p +#define FUNC_NAME s_scm_primitive_call_ip { SCM_MAKE_VALIDATE (1, prim, PRIMITIVE_P); diff --git a/libguile/programs.h b/libguile/programs.h index d170c1b77..c962995eb 100644 --- a/libguile/programs.h +++ b/libguile/programs.h @@ -58,7 +58,7 @@ scm_i_make_program (const scm_t_uint32 *code) SCM_INTERNAL SCM scm_program_p (SCM obj); SCM_INTERNAL SCM scm_program_code (SCM program); -SCM_INTERNAL SCM scm_primitive_p (SCM obj); +SCM_INTERNAL SCM scm_primitive_code_p (SCM code); SCM_INTERNAL SCM scm_primitive_call_ip (SCM prim); SCM_INTERNAL SCM scm_i_program_name (SCM program); diff --git a/module/statprof.scm b/module/statprof.scm index e613aad2d..74b32c0ba 100644 --- a/module/statprof.scm +++ b/module/statprof.scm @@ -327,10 +327,13 @@ (set-buffer! state buffer) (set-buffer-pos! state (1+ pos))) (else - (let ((proc (frame-procedure frame))) - (write-sample-and-continue (if (primitive? proc) - (procedure-name proc) - (frame-instruction-pointer frame)))))))) + (let ((ip (frame-instruction-pointer frame))) + (write-sample-and-continue + (if (primitive-code? ip) + ;; Grovel and get the primitive name from the gsubr, which + ;; we know to be in slot 0. + (procedure-name (frame-local-ref frame 0 'scm)) + ip))))))) (define (reset-sigprof-timer usecs) ;; Guile's setitimer binding is terrible. @@ -376,11 +379,11 @@ (unless (inside-profiler? state) (accumulate-time state (get-internal-run-time)) - (let* ((key (let ((proc (frame-procedure frame))) - (cond - ((primitive? proc) (procedure-name proc)) - ((program? proc) (program-code proc)) - (else proc)))) + ;; We know local 0 is a SCM value: the c + (let* ((ip (frame-instruction-pointer frame)) + (key (if (primitive-code? ip) + (procedure-name (frame-local-ref frame 0 'scm)) + ip)) (handle (hashv-create-handle! (call-counts state) key 0))) (set-cdr! handle (1+ (cdr handle)))) @@ -594,11 +597,13 @@ it represents different functions with the same name." none is available." (when (statprof-active?) (error "Can't call statprof-proc-call-data while profiler is running.")) - (hashv-ref (stack-samples->procedure-data state) - (cond - ((primitive? proc) (procedure-name proc)) - ((program? proc) (program-code proc)) - (else (program-code proc))))) + (unless (program? proc) + (error "statprof-call-data only works for VM programs")) + (let* ((code (program-code proc)) + (key (if (primitive-code? code) + (procedure-name proc) + code))) + (hashv-ref (stack-samples->procedure-data state) key))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Stats diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index 38850b61e..8945e58fb 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -402,7 +402,7 @@ (arity-keyword-args arity) (arity-has-rest? arity) 1)))) - ((and (primitive? closure) + ((and (primitive-code? ip) (program-arguments-alist closure ip)) => (lambda (args) (match args diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index 59cb8c019..9f5b764d0 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -44,7 +44,7 @@ print-program - primitive?)) + primitive-code?)) (load-extension (string-append "libguile-" (effective-version)) "scm_init_programs") @@ -195,28 +195,25 @@ of integers." ;; the name "program-arguments" is taken by features.c... (define* (program-arguments-alist prog #:optional ip) "Returns the signature of the given procedure in the form of an association list." - (cond - ((primitive? prog) - (match (procedure-minimum-arity prog) - (#f #f) - ((nreq nopt rest?) - (let ((start (primitive-call-ip prog))) - ;; Assume that there is only one IP for the call. - (and (or (not ip) (= start ip)) - (arity->arguments-alist - prog - (list 0 0 nreq nopt rest? '(#f . ())))))))) - ((program? prog) - (or-map (lambda (arity) - (and (or (not ip) - (and (<= (arity-low-pc arity) ip) - (< ip (arity-high-pc arity)))) - (arity-arguments-alist arity))) - (or (find-program-arities (program-code prog)) '()))) - (else - (let ((arity (program-arity prog ip))) - (and arity - (arity->arguments-alist prog arity)))))) + (let ((code (program-code prog))) + (cond + ((primitive-code? code) + (match (procedure-minimum-arity prog) + (#f #f) + ((nreq nopt rest?) + (let ((start (primitive-call-ip prog))) + ;; Assume that there is only one IP for the call. + (and (or (not ip) (= start ip)) + (arity->arguments-alist + prog + (list 0 0 nreq nopt rest? '(#f . ())))))))) + (else + (or-map (lambda (arity) + (and (or (not ip) + (and (<= (arity-low-pc arity) ip) + (< ip (arity-high-pc arity)))) + (arity-arguments-alist arity))) + (or (find-program-arities code) '())))))) (define* (program-lambda-list prog #:optional ip) "Returns the signature of the given procedure in the form of an argument list." @@ -252,14 +249,12 @@ lists." (arity->arguments-alist prog (list 0 0 nreq nopt rest? '(#f . ()))))))) - (cond - ((primitive? prog) (fallback)) - ((program? prog) - (let ((arities (find-program-arities (program-code prog)))) - (if arities - (map arity-arguments-alist arities) - (fallback)))) - (else (error "expected a program" prog)))) + (let* ((code (program-code prog)) + (arities (and (not (primitive-code? code)) + (find-program-arities code)))) + (if arities + (map arity-arguments-alist arities) + (fallback)))) (define* (print-program #:optional program (port (current-output-port)) #:key (addr (program-code program)) From 39090e677eed54761e0952f2575ddef1504545d3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 27 Nov 2015 12:17:36 +0100 Subject: [PATCH 111/865] Add frame-procedure-name * libguile/frames.c (frame_procedure_name_var): New static definition. (init_frame_procedure_name_var): New helper. (scm_frame_procedure_name): New function that returns the name of the frame's procedure, as frame-procedure is to be deprecated. * libguile/frames.h (scm_frame_procedure_name): Export. * module/ice-9/boot-9.scm (exception-printers): Use frame-procedure-name instead of procedure-name on frame-procedure. * module/system/vm/frame.scm (frame-procedure-name): New private function, implementing scm_frame_procedure_name. (frame-call-representation): Use frame-procedure-name to get the procedure name to print. --- libguile/frames.c | 23 +++++++++++++++++++++++ libguile/frames.h | 1 + module/ice-9/boot-9.scm | 11 +++++------ module/system/vm/frame.scm | 26 +++++++++++++++++++++++--- 4 files changed, 52 insertions(+), 9 deletions(-) diff --git a/libguile/frames.c b/libguile/frames.c index 312d53b00..7432f8d84 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -149,6 +149,29 @@ SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0, } #undef FUNC_NAME +static SCM frame_procedure_name_var; + +static void +init_frame_procedure_name_var (void) +{ + frame_procedure_name_var + = scm_c_private_lookup ("system vm frame", "frame-procedure-name"); +} + +SCM_DEFINE (scm_frame_procedure_name, "frame-procedure-name", 1, 0, 0, + (SCM frame), + "") +#define FUNC_NAME s_scm_frame_procedure_name +{ + static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; + scm_i_pthread_once (&once, init_frame_procedure_name_var); + + SCM_VALIDATE_VM_FRAME (1, frame); + + return scm_call_1 (scm_variable_ref (frame_procedure_name_var), frame); +} +#undef FUNC_NAME + static SCM frame_arguments_var; static void diff --git a/libguile/frames.h b/libguile/frames.h index bb402ae71..241e3f3ad 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -157,6 +157,7 @@ SCM_INTERNAL int scm_c_frame_previous (enum scm_vm_frame_kind kind, SCM_API SCM scm_frame_p (SCM obj); SCM_API SCM scm_frame_procedure (SCM frame); +SCM_API SCM scm_frame_procedure_name (SCM frame); SCM_API SCM scm_frame_call_representation (SCM frame); SCM_API SCM scm_frame_arguments (SCM frame); SCM_API SCM scm_frame_source (SCM frame); diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index a5b3422bc..6da8085a0 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -893,12 +893,11 @@ for key @var{k}, then invoke @var{thunk}." (define (default-printer) (format port "Throw to key `~a' with args `~s'." key args)) - (if frame - (let ((proc (frame-procedure frame))) - (print-location frame port) - (format port "In procedure ~a:\n" - (or (false-if-exception (procedure-name proc)) - proc)))) + (when frame + (print-location frame port) + (let ((name (false-if-exception (frame-procedure-name frame)))) + (when name + (format port "In procedure ~a:\n" name)))) (print-location frame port) (catch #t diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index 8945e58fb..e9dc2ee33 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -312,6 +312,28 @@ (binding-representation binding)))) +(define* (frame-procedure-name frame #:key + (info (find-program-debug-info + (frame-instruction-pointer frame)))) + (cond + (info => program-debug-info-name) + ;; We can only try to get the name from the closure if we know that + ;; slot 0 corresponds to the frame's procedure. This isn't possible + ;; to know in general. If the frame has already begun executing and + ;; the closure binding is dead, it could have been replaced with any + ;; other random value, or an unboxed value. Even if we're catching + ;; the frame at its application, before it has started running, if + ;; the callee is well-known and has only one free variable, closure + ;; optimization could have chosen to represent its closure as that + ;; free variable, and that free variable might be some other program, + ;; or even an unboxed value. It would be an error to try to get the + ;; procedure name of some procedure that doesn't correspond to the + ;; one being applied. (Free variables are currently always boxed but + ;; that could change in the future.) + ((primitive-code? (frame-instruction-pointer frame)) + (procedure-name (frame-local-ref frame 0 'scm))) + (else #f))) + ;; This function is always called to get some sort of representation of the ;; frame to present to the user, so let's do the logical thing and dispatch to ;; frame-call-representation. @@ -388,9 +410,7 @@ (else '()))) (cons - (or (and=> info program-debug-info-name) - (and (procedure? closure) (procedure-name closure)) - closure) + (frame-procedure-name frame #:info info) (cond ((find-program-arity ip) => (lambda (arity) From 029af6f68ab7bbe02e1cc189c8f99e7e754daf74 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 27 Nov 2015 12:25:26 +0100 Subject: [PATCH 112/865] frame-call-representation avoids frame-procedure. * module/system/vm/frame.scm (frame-call-representation): Never use frame-procedure, as we don't know that slot 0 is a SCM value and even if it were, we don't know that it corresponds to the procedure being applied, except in the case of primcalls. Print _ as the procedure name if we don't know it, instead of #f. --- module/system/vm/frame.scm | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index e9dc2ee33..4ce4d7f3e 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -364,8 +364,7 @@ (define* (frame-call-representation frame #:key top-frame?) (let* ((ip (frame-instruction-pointer frame)) (info (find-program-debug-info ip)) - (nlocals (frame-num-locals frame)) - (closure (frame-procedure frame))) + (nlocals (frame-num-locals frame))) (define (find-slot i bindings) (match bindings (() #f) @@ -410,7 +409,7 @@ (else '()))) (cons - (frame-procedure-name frame #:info info) + (or (frame-procedure-name frame #:info info) '_) (cond ((find-program-arity ip) => (lambda (arity) @@ -423,7 +422,7 @@ (arity-has-rest? arity) 1)))) ((and (primitive-code? ip) - (program-arguments-alist closure ip)) + (program-arguments-alist (frame-local-ref frame 0 'scm) ip)) => (lambda (args) (match args ((('required . req) From 9a8c2995aefcbc39381215f18e2733c6943060e9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 27 Nov 2015 12:31:16 +0100 Subject: [PATCH 113/865] More robust low-level frame printer * libguile/frames.c (scm_i_frame_print): Print using frame-procedure-name, not frame-procedure. --- libguile/frames.c | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/libguile/frames.c b/libguile/frames.c index 7432f8d84..7492adfb2 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -43,9 +43,17 @@ scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate) { scm_puts_unlocked ("#", port); } From c960c76fe0dea22728a69923fa8cdaaaa5dc5edd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 27 Nov 2015 12:42:53 +0100 Subject: [PATCH 114/865] Better frame-call-representation printing of GC clobbers * module/system/vm/frame.scm (frame-call-representation): Assume that unspecified values are GC clobbers rather than actual arguments, and print as _. --- module/system/vm/frame.scm | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index 4ce4d7f3e..ccfc05745 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -380,8 +380,17 @@ (frame-local-ref frame i 'scm)) ((find-slot i bindings) => (lambda (binding) - (frame-local-ref frame (binding-slot binding) - (binding-representation binding)))) + (let ((val (frame-local-ref frame (binding-slot binding) + (binding-representation binding)))) + ;; It could be that there's a value that isn't clobbered + ;; by a call but that isn't live after a call either. In + ;; that case, if GC runs during the call, the value will + ;; be collected, and on the stack it will be replaced + ;; with the unspecified value. Assume that clobbering + ;; values is more likely than passing the unspecified + ;; value as an argument, and replace unspecified with _, + ;; as if the binding were not available. + (if (unspecified? val) '_ val)))) (else '_))) (define (application-arguments) From 2d0214a9b741083ca89d587016c86ad7b4c4bf1b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 27 Nov 2015 12:53:34 +0100 Subject: [PATCH 115/865] ,registers doesn't use frame-procedure * module/system/repl/debug.scm (print-registers): Avoid frame-procedure, and be more useful and print an offset in units of 4 bytes. --- module/system/repl/debug.scm | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm index 9516af622..e148d444f 100644 --- a/module/system/repl/debug.scm +++ b/module/system/repl/debug.scm @@ -24,6 +24,7 @@ #:use-module (system base language) #:use-module (system vm vm) #:use-module (system vm frame) + #:use-module (system vm debug) #:use-module (ice-9 rdelim) #:use-module (ice-9 pretty-print) #:use-module (ice-9 format) @@ -94,12 +95,13 @@ (format port fmt val)) (format port "~aRegisters:~%" per-line-prefix) - (print "ip = #x~x" (frame-instruction-pointer frame)) - (when (program? (frame-procedure frame)) - (let ((code (program-code (frame-procedure frame)))) - (format port " (#x~x~@d)" code - (- (frame-instruction-pointer frame) code)))) - (newline port) + (let ((ip (frame-instruction-pointer frame))) + (print "ip = #x~x" ip) + (let ((info (find-program-debug-info ip))) + (when info + (let ((addr (program-debug-info-addr info))) + (format port " (#x~x + ~d * 4)" addr (/ (- ip addr) 4))))) + (newline port)) (print "sp = ~a\n" (frame-stack-pointer frame)) (print "fp = ~a\n" (frame-address frame))) From adb23298637edb2365fd78e98020f9aeb457b6ec Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 27 Nov 2015 15:23:12 +0100 Subject: [PATCH 116/865] Remove `procedure' repl command * doc/ref/scheme-using.texi (Debug Commands): * module/system/repl/command.scm (procedure): Remove REPL command. Since there is a closure binding and we have improved the ,registers output, this is no longer necessary and by removing it we remove another bogus use of frame-procedure. --- doc/ref/scheme-using.texi | 4 ---- module/system/repl/command.scm | 5 ----- 2 files changed, 9 deletions(-) diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index 4422c1863..9334218b6 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -341,10 +341,6 @@ Show the selected frame. With an argument, select a frame by index, then show it. @end deffn -@deffn {REPL Command} procedure -Print the procedure for the selected frame. -@end deffn - @deffn {REPL Command} locals Show local variables. diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index 62bc2977a..e84586318 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -645,11 +645,6 @@ With an argument, select a frame by index, then show it." (format #t "No such frame.~%")))) (else (print-frame cur #:index index)))) -(define-stack-command (procedure repl) - "procedure -Print the procedure for the selected frame." - (repl-print repl (frame-procedure cur))) - (define-stack-command (locals repl #:key (width (terminal-width))) "locals Show local variables. From 3582787cb032da4d3a722bfb00882e6d992b0c87 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 27 Nov 2015 15:38:30 +0100 Subject: [PATCH 117/865] VM traps don't match on value of slot 0 * module/system/vm/traps.scm (frame-matcher): Always match on a procedure's code, instead of the value in slot 0. Prevents confusion with closure-optimized procedures, re-use of slot 0, and untagged values in slot 0. (trap-at-procedure-call, trap-in-procedure) (trap-instructions-in-procedure, trap-at-procedure-ip-in-range) (trap-at-source-location, trap-in-dynamic-extent) (trap-calls-in-dynamic-extent, trap-instructions-in-dynamic-extent): Update to adapt to frame-matcher change and remove #:closure? argument, effectively changing the default behavior to #:closure? #t. * doc/ref/api-debug.texi (Low-Level Traps): Update documentation. --- doc/ref/api-debug.texi | 19 +++++-------- module/system/vm/traps.scm | 57 ++++++++++++++++++-------------------- 2 files changed, 34 insertions(+), 42 deletions(-) diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi index bf25c74c9..958c92728 100644 --- a/doc/ref/api-debug.texi +++ b/doc/ref/api-debug.texi @@ -1088,11 +1088,6 @@ separately, we discuss them all together here: @table @code @item #:vm The VM to instrument. Defaults to the current thread's VM. -@item #:closure? -For traps that depend on the current frame's procedure, this argument -specifies whether to trap on the only the specific procedure given, or -on any closure that has the given procedure's code. Defaults to -@code{#f}. @item #:current-frame For traps that enable more hooks depending on their dynamic context, this argument gives the current frame that the trap is running in. @@ -1107,12 +1102,12 @@ To have access to these procedures, you'll need to have imported the @end lisp @deffn {Scheme Procedure} trap-at-procedure-call proc handler @ - [#:vm] [#:closure?] + [#:vm] A trap that calls @var{handler} when @var{proc} is applied. @end deffn @deffn {Scheme Procedure} trap-in-procedure proc @ - enter-handler exit-handler [#:current-frame] [#:vm] [#:closure?] + enter-handler exit-handler [#:current-frame] [#:vm] A trap that calls @var{enter-handler} when control enters @var{proc}, and @var{exit-handler} when control leaves @var{proc}. @@ -1140,13 +1135,13 @@ An abort. @end deffn @deffn {Scheme Procedure} trap-instructions-in-procedure proc @ - next-handler exit-handler [#:current-frame] [#:vm] [#:closure?] + next-handler exit-handler [#:current-frame] [#:vm] A trap that calls @var{next-handler} for every instruction executed in @var{proc}, and @var{exit-handler} when execution leaves @var{proc}. @end deffn @deffn {Scheme Procedure} trap-at-procedure-ip-in-range proc range @ - handler [#:current-frame] [#:vm] [#:closure?] + handler [#:current-frame] [#:vm] A trap that calls @var{handler} when execution enters a range of instructions in @var{proc}. @var{range} is a simple of pairs, @code{((@var{start} . @var{end}) ...)}. The @var{start} addresses are @@ -1169,7 +1164,7 @@ exit. @end deffn @deffn {Scheme Procedure} trap-in-dynamic-extent proc @ - enter-handler return-handler abort-handler [#:vm] [#:closure?] + enter-handler return-handler abort-handler [#:vm] A more traditional dynamic-wind trap, which fires @var{enter-handler} when control enters @var{proc}, @var{return-handler} on a normal return, and @var{abort-handler} on a nonlocal exit. @@ -1178,14 +1173,14 @@ Note that rewinds are not handled, so there is no rewind handler. @end deffn @deffn {Scheme Procedure} trap-calls-in-dynamic-extent proc @ - apply-handler return-handler [#:current-frame] [#:vm] [#:closure?] + apply-handler return-handler [#:current-frame] [#:vm] A trap that calls @var{apply-handler} every time a procedure is applied, and @var{return-handler} for returns, but only during the dynamic extent of an application of @var{proc}. @end deffn @deffn {Scheme Procedure} trap-instructions-in-dynamic-extent proc @ - next-handler [#:current-frame] [#:vm] [#:closure?] + next-handler [#:current-frame] [#:vm] A trap that calls @var{next-handler} for all retired instructions within the dynamic extent of a call to @var{proc}. @end deffn diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm index ca6acddfa..db82a0ab9 100644 --- a/module/system/vm/traps.scm +++ b/module/system/vm/traps.scm @@ -112,25 +112,26 @@ (let ((pdi (find-program-debug-info (program-code prog)))) (and pdi (program-debug-info-size pdi)))) -(define (frame-matcher proc match-code?) +(define (frame-matcher proc) (let ((proc (if (struct? proc) (procedure proc) proc))) - (if match-code? - (if (program? proc) - (let ((start (program-code proc)) - (end (program-last-ip proc))) - (lambda (frame) - (let ((ip (frame-instruction-pointer frame))) - (and (<= start ip) (< ip end))))) - (lambda (frame) #f)) + (cond + ((program? proc) + (let ((start (program-code proc)) + (end (program-last-ip proc))) (lambda (frame) - (eq? (frame-procedure frame) proc))))) + (let ((ip (frame-instruction-pointer frame))) + (and (<= start ip) (< ip end)))))) + ((struct? proc) + (frame-matcher (procedure proc))) + (else + (error "Not a VM program" proc))))) ;; A basic trap, fires when a procedure is called. ;; -(define* (trap-at-procedure-call proc handler #:key (closure? #f) - (our-frame? (frame-matcher proc closure?))) +(define* (trap-at-procedure-call proc handler #:key + (our-frame? (frame-matcher proc))) (arg-check proc procedure?) (arg-check handler procedure?) (let () @@ -160,8 +161,8 @@ ;; * An abort. ;; (define* (trap-in-procedure proc enter-handler exit-handler - #:key current-frame (closure? #f) - (our-frame? (frame-matcher proc closure?))) + #:key current-frame + (our-frame? (frame-matcher proc))) (arg-check proc procedure?) (arg-check enter-handler procedure?) (arg-check exit-handler procedure?) @@ -216,9 +217,8 @@ ;; Building on trap-in-procedure, we have trap-instructions-in-procedure ;; (define* (trap-instructions-in-procedure proc next-handler exit-handler - #:key current-frame (closure? #f) - (our-frame? - (frame-matcher proc closure?))) + #:key current-frame + (our-frame? (frame-matcher proc))) (arg-check proc procedure?) (arg-check next-handler procedure?) (arg-check exit-handler procedure?) @@ -263,9 +263,8 @@ ;; trap-at-procedure-ip-in-range. ;; (define* (trap-at-procedure-ip-in-range proc range handler - #:key current-frame (closure? #f) - (our-frame? - (frame-matcher proc closure?))) + #:key current-frame + (our-frame? (frame-matcher proc))) (arg-check proc procedure?) (arg-check range range?) (arg-check handler procedure?) @@ -376,8 +375,8 @@ (lambda (proc) (let ((range (source->ip-range proc file (1- user-line)))) (trap-at-procedure-ip-in-range proc range handler - #:current-frame current-frame - #:closure? closures?))) + #:current-frame + current-frame))) procs)) (if (null? traps) (error "No procedures found at ~a:~a." file user-line))) @@ -424,8 +423,8 @@ ;; based on the above trap-frame-finish? ;; (define* (trap-in-dynamic-extent proc enter-handler return-handler abort-handler - #:key current-frame (closure? #f) - (our-frame? (frame-matcher proc closure?))) + #:key current-frame + (our-frame? (frame-matcher proc))) (arg-check proc procedure?) (arg-check enter-handler procedure?) (arg-check return-handler procedure?) @@ -462,9 +461,8 @@ ;; depth of the call stack relative to the original procedure. ;; (define* (trap-calls-in-dynamic-extent proc apply-handler return-handler - #:key current-frame (closure? #f) - (our-frame? - (frame-matcher proc closure?))) + #:key current-frame + (our-frame? (frame-matcher proc))) (arg-check proc procedure?) (arg-check apply-handler procedure?) (arg-check return-handler procedure?) @@ -504,9 +502,8 @@ ;; Trapping all retired intructions within a dynamic extent. ;; (define* (trap-instructions-in-dynamic-extent proc next-handler - #:key current-frame (closure? #f) - (our-frame? - (frame-matcher proc closure?))) + #:key current-frame + (our-frame? (frame-matcher proc))) (arg-check proc procedure?) (arg-check next-handler procedure?) (let () From 58153e3a08c89fd9cc84dbf65e1df27119986cca Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 27 Nov 2015 15:54:51 +0100 Subject: [PATCH 118/865] Remove frame-procedure * libguile/frames.h: * libguile/frames.c (scm_frame_procedure): Remove. * test-suite/tests/eval.test ("stacks"): Adapt test. * NEWS: Add news item. * doc/ref/api-debug.texi (Frames): Document frame-procedure-name instead of frame-procedure. --- NEWS | 23 ++++++++++++++++++++++- doc/ref/api-debug.texi | 8 ++++---- libguile/frames.c | 13 ------------- libguile/frames.h | 1 - test-suite/tests/eval.test | 4 ++-- 5 files changed, 28 insertions(+), 21 deletions(-) diff --git a/NEWS b/NEWS index 604113470..ce3887920 100644 --- a/NEWS +++ b/NEWS @@ -6,7 +6,28 @@ Please send Guile bug reports to bug-guile@gnu.org. -Changes in 2.1.1 (changes since the 2.0.x series): +Changes in 2.1.2 (changes since the 2.1.1 alpha release): + +* Incompatible changes + +** Remove frame-procedure + +Several optimizations in Guile make `frame-procedure' an interface that +we can no longer support. For background, `frame-procedure' used to +return the value at slot 0 in a frame, which usually corresponds to the +SCM value of the procedure being applied. However it could be that this +slot is re-used for some other value, because the closure was not needed +in the function. Such a re-use might even be for an untagged value, in +which case treating slot 0 as a SCM value is quite dangerous. It's also +possible that so-called "well-known" closures (closures whose callers +are all known) are optimized in such a way that slot 0 is not a +procedure but some optimized representation of the procedure's free +variables. Instead, developers building debugging tools that would like +access to `frame-procedure' are invited to look at the source for the +`(system vm frame)' for alternate interfaces. + + +Changes in 2.1.x (changes since the 2.0.x series): * Notable changes diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi index 958c92728..459371fa7 100644 --- a/doc/ref/api-debug.texi +++ b/doc/ref/api-debug.texi @@ -177,10 +177,10 @@ Return the previous frame of @var{frame}, or @code{#f} if @var{frame} is the first frame in its stack. @end deffn -@deffn {Scheme Procedure} frame-procedure frame -@deffnx {C Function} scm_frame_procedure (frame) -Return the procedure for @var{frame}, or @code{#f} if no -procedure is associated with @var{frame}. +@deffn {Scheme Procedure} frame-procedure-name frame +@deffnx {C Function} scm_frame_procedure_name (frame) +Return the name of the procedure being applied in @var{frame}, as a +symbol, or @code{#f} if the procedure has no name. @end deffn @deffn {Scheme Procedure} frame-arguments frame diff --git a/libguile/frames.c b/libguile/frames.c index 7492adfb2..2eae45fcd 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -144,19 +144,6 @@ scm_c_frame_closure (enum scm_vm_frame_kind kind, const struct scm_frame *frame) return SCM_BOOL_F; } -SCM_DEFINE (scm_frame_procedure, "frame-procedure", 1, 0, 0, - (SCM frame), - "") -#define FUNC_NAME s_scm_frame_procedure -{ - SCM_VALIDATE_VM_FRAME (1, frame); - - /* FIXME: Retrieve procedure from address? */ - return scm_c_frame_closure (SCM_VM_FRAME_KIND (frame), - SCM_VM_FRAME_DATA (frame)); -} -#undef FUNC_NAME - static SCM frame_procedure_name_var; static void diff --git a/libguile/frames.h b/libguile/frames.h index 241e3f3ad..bf3844527 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -156,7 +156,6 @@ SCM_INTERNAL int scm_c_frame_previous (enum scm_vm_frame_kind kind, #endif SCM_API SCM scm_frame_p (SCM obj); -SCM_API SCM scm_frame_procedure (SCM frame); SCM_API SCM scm_frame_procedure_name (SCM frame); SCM_API SCM scm_frame_call_representation (SCM frame); SCM_API SCM scm_frame_arguments (SCM frame); diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index e1837fd38..26917d762 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -365,8 +365,8 @@ ;; stack. (let* ((stack (make-tagged-trimmed-stack tag '(#t))) (frames (stack->frames stack)) - (num (count (lambda (frame) (eq? (frame-procedure frame) - substring)) + (num (count (lambda (frame) (eq? (frame-procedure-name frame) + 'substring)) frames))) (= num 1))) From dfbe869e2421e6db03fd14c6fbfc0838e5e1988b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 12 Nov 2015 21:44:24 +0100 Subject: [PATCH 119/865] Add low-level support for unboxed 64-bit unsigned ints * libguile/frames.c (enum stack_item_representation) * libguile/frames.c (scm_to_stack_item_representation): (scm_frame_local_ref, scm_frame_local_set_x): Support 'u64 slots. * libguile/frames.h (union scm_vm_stack_element): Add as_u64 member. * libguile/vm-engine.c (SP_REF_U64, SP_SET_U64): New helpers. (scm->u64, u64->scm): New instructions. * module/language/cps/cse.scm (compute-equivalent-subexpressions): Scalar replacement for u64->scm and scm->u64. * module/language/cps/effects-analysis.scm (scm->u64, u64->scm): Add cases. * module/language/cps/slot-allocation.scm (compute-var-representations): (allocate-slots): Represent the result of scm->u64 as a "u64" slot. * module/language/cps/types.scm (&u64): New type. (scm->u64, u64->scm): Add support for these ops. * module/system/vm/assembler.scm (write-arities): * module/system/vm/debug.scm (arity-definitions): Support u64 representations. --- libguile/frames.c | 10 +++++++- libguile/frames.h | 1 + libguile/vm-engine.c | 31 ++++++++++++++++++++++-- module/language/cps/cse.scm | 8 ++++++ module/language/cps/effects-analysis.scm | 6 +++-- module/language/cps/slot-allocation.scm | 8 +++--- module/language/cps/types.scm | 17 +++++++++++-- module/system/vm/assembler.scm | 1 + module/system/vm/debug.scm | 1 + 9 files changed, 73 insertions(+), 10 deletions(-) diff --git a/libguile/frames.c b/libguile/frames.c index 2eae45fcd..e70b25212 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -241,7 +241,8 @@ SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0, enum stack_item_representation { STACK_ITEM_SCM = 0, - STACK_ITEM_F64 = 1 + STACK_ITEM_F64 = 1, + STACK_ITEM_U64 = 2 }; static enum stack_item_representation @@ -251,6 +252,8 @@ scm_to_stack_item_representation (SCM x, const char *subr, int pos) return STACK_ITEM_SCM; if (scm_is_eq (x, scm_from_latin1_symbol ("f64"))) return STACK_ITEM_F64; + if (scm_is_eq (x, scm_from_latin1_symbol ("u64"))) + return STACK_ITEM_U64; scm_wrong_type_arg (subr, pos, x); return 0; /* Not reached. */ @@ -281,6 +284,8 @@ SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 3, 0, 0, return item->as_scm; case STACK_ITEM_F64: return scm_from_double (item->as_f64); + case STACK_ITEM_U64: + return scm_from_uint64 (item->as_u64); default: abort(); } @@ -318,6 +323,9 @@ SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 4, 0, 0, case STACK_ITEM_F64: item->as_f64 = scm_to_double (val); break; + case STACK_ITEM_U64: + item->as_u64 = scm_to_uint64 (val); + break; default: abort(); } diff --git a/libguile/frames.h b/libguile/frames.h index bf3844527..2ece0c893 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -92,6 +92,7 @@ union scm_vm_stack_element scm_t_uint32 *as_ip; SCM as_scm; double as_f64; + scm_t_uint64 as_u64; /* For GC purposes. */ void *as_ptr; diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 885ef72ef..44bd2569b 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -254,6 +254,9 @@ #define SP_REF_F64(i) (sp[i].as_f64) #define SP_SET_F64(i,o) (sp[i].as_f64 = o) +#define SP_REF_U64(i) (sp[i].as_u64) +#define SP_SET_U64(i,o) (sp[i].as_u64 = o) + #define VARIABLE_REF(v) SCM_VARIABLE_REF (v) #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o) #define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED)) @@ -3312,8 +3315,32 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (0); } - VM_DEFINE_OP (143, unused_143, NULL, NOP) - VM_DEFINE_OP (144, unused_144, NULL, NOP) + /* scm->u64 dst:12 src:12 + * + * Unpack an unsigned 64-bit integer from SRC and place it in DST. + */ + VM_DEFINE_OP (143, scm_to_u64, "scm->u64", OP1 (X8_S12_S12) | OP_DST) + { + scm_t_uint16 dst, src; + UNPACK_12_12 (op, dst, src); + SYNC_IP (); + SP_SET_U64 (dst, scm_to_uint64 (SP_REF (src))); + NEXT (1); + } + + /* u64->scm dst:12 src:12 + * + * Pack an unsigned 64-bit integer into a SCM value. + */ + VM_DEFINE_OP (144, u64_to_scm, "u64->scm", OP1 (X8_S12_S12) | OP_DST) + { + scm_t_uint16 dst, src; + UNPACK_12_12 (op, dst, src); + SYNC_IP (); + SP_SET (dst, scm_from_uint64 (SP_REF_U64 (src))); + NEXT (1); + } + VM_DEFINE_OP (145, unused_145, NULL, NOP) VM_DEFINE_OP (146, unused_146, NULL, NOP) VM_DEFINE_OP (147, unused_147, NULL, NOP) diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index 2e47f379c..ad554faa0 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -307,6 +307,14 @@ false. It could be that both true and false proofs are available." (match defs ((scm) (add-def! `(primcall scm->f64 ,scm) f64)))) + (('primcall 'scm->u64 scm) + (match defs + ((u64) + (add-def! `(primcall u64->scm ,u64) scm)))) + (('primcall 'u64->scm u64) + (match defs + ((scm) + (add-def! `(primcall scm->u64 ,scm) u64)))) (_ #t)))) (define (visit-label label equiv-labels var-substs) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index ae7a1a614..9c9334671 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -351,10 +351,12 @@ is or might be a read or a write to the same location as A." ((string->number _) (&read-object &string) &type-check) ((string-length s) &type-check)) -;; Unboxed floats. +;; Unboxed floats and integers. (define-primitive-effects ((scm->f64 _) &type-check) - ((f64->scm _))) + ((f64->scm _)) + ((scm->u64 _) &type-check) + ((u64->scm _))) ;; Bytevectors. (define-primitive-effects diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 8d865d739..ca8e32123 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -53,8 +53,8 @@ ;; (slots allocation-slots) - ;; A map of VAR to representation. A representation is either 'scm or - ;; 'f64. + ;; A map of VAR to representation. A representation is 'scm, 'f64, or + ;; 'u64. ;; (representations allocation-representations) @@ -793,6 +793,8 @@ are comparable with eqv?. A tmp slot may be used." (($ $primcall (or 'scm->f64 'bv-f32-ref 'bv-f64-ref 'fadd 'fsub 'fmul 'fdiv)) (intmap-add representations var 'f64)) + (($ $primcall (or 'scm->u64)) + (intmap-add representations var 'u64)) (_ (intmap-add representations var 'scm)))) (vars @@ -874,7 +876,7 @@ are comparable with eqv?. A tmp slot may be used." (#f slot-map) (slot (let ((desc (match (intmap-ref representations var) - ('f64 slot-desc-live-raw) + ((or 'u64 'f64) slot-desc-live-raw) ('scm slot-desc-live-scm)))) (logior slot-map (ash desc (* 2 slot))))))) live-vars 0)) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 08e8ec8de..8482b9836 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -119,6 +119,7 @@ ;; Untagged types. &f64 + &u64 infer-types lookup-pre-type @@ -169,7 +170,8 @@ &array &hash-table - &f64) + &f64 + &u64) (define-syntax &no-type (identifier-syntax 0)) @@ -678,7 +680,7 @@ minimum, and maximum." ;;; -;;; Unboxed double-precision floating-point numbers. +;;; Unboxed numbers. ;;; (define-type-checker (scm->f64 scm) @@ -692,6 +694,17 @@ minimum, and maximum." (define-type-inferrer (f64->scm f64 result) (define! result &flonum (&min f64) (&max f64))) +(define-type-checker (scm->u64 scm) + (check-type scm &exact-integer 0 +inf.0)) +(define-type-inferrer (scm->u64 scm result) + (restrict! scm &exact-integer 0 +inf.0) + (define! result &u64 (&min scm) (&max scm))) + +(define-type-checker (u64->scm u64) + #t) +(define-type-inferrer (u64->scm u64 result) + (define! result &exact-integer (&min u64) (&max u64))) + diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index babe4796f..21f4353c8 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -1895,6 +1895,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If (let ((tag (case representation ((scm) 0) ((f64) 1) + ((u64) 2) (else (error "what!" representation))))) (put-uleb128 names-port (logior (ash slot 2) tag))) (lp definitions)))))) diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm index 4d9a047fe..78bf13a50 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -386,6 +386,7 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}." (representation (case (logand slot+representation #x3) ((0) 'scm) ((1) 'f64) + ((2) 'u64) (else 'unknown)))) (cons (vector name def-offset slot representation) (lp pos names))))))))))) From a7e1c392c27481f1f8bda11bd8ceb0fde9f06c14 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 27 Nov 2015 15:29:33 +0100 Subject: [PATCH 120/865] Remove frame->module * module/system/repl/debug.scm (frame->module): Remove. Has been broken for a while, had no callers, and was calling frame-procedure. We can revive again in a better way, like ice-9 local-eval. --- module/system/repl/debug.scm | 29 +---------------------------- 1 file changed, 1 insertion(+), 28 deletions(-) diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm index e148d444f..18ac10f5b 100644 --- a/module/system/repl/debug.scm +++ b/module/system/repl/debug.scm @@ -34,7 +34,7 @@ make-debug debug? debug-frames debug-index debug-error-message terminal-width - print-registers print-locals print-frame print-frames frame->module + print-registers print-locals print-frame print-frames stack->vector narrow-stack->vector frame->stack-vector)) @@ -164,33 +164,6 @@ (lp (+ i inc) (frame-source frame))))))) -;; Ideally here we would have something much more syntactic, in that a set! to a -;; local var that is not settable would raise an error, and export etc forms -;; would modify the module in question: but alack, this is what we have now. -;; Patches welcome! -(define (frame->module frame) - (let ((proc (frame-procedure frame))) - (if #f - ;; FIXME: program-module does not exist. - (let* ((mod (or (program-module proc) (current-module))) - (mod* (make-module))) - (module-use! mod* mod) - (for-each - (lambda (binding) - (let* ((x (frame-local-ref frame (binding-slot binding) - (binding-representation binding))) - (var (if (variable? x) x (make-variable x)))) - (format #t - "~:[Read-only~;Mutable~] local variable ~a = ~70:@y\n" - (not (variable? x)) - (binding-name binding) - (if (variable-bound? var) (variable-ref var) var)) - (module-add! mod* (binding-name binding) var))) - (frame-bindings frame)) - mod*) - (current-module)))) - - (define (stack->vector stack) (let* ((len (stack-length stack)) (v (make-vector len))) From 870ac91a4e6a8f75a6d0e246f034c9b4dcc70317 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 16 Nov 2015 22:32:09 +0100 Subject: [PATCH 121/865] Range inference over the full U64+S64 range * module/language/cps/types.scm (*min-s32*, *max-s32*): Remove unused definitions. (&range-min, &range-max): New definitions, replacing min-fixnum and max-fixnum as the bounds of precise range analysis. (type-entry-min, type-entry-max): Store inf values directly as -inf.0/+inf.0. (type-entry-clamped-min, type-entry-clamped-max): Remove, as they are no longer needed. (clamp-min, clamp-max, make-type-entry): Clamp minimum and maximum half-ranges in different ways. (type-entry-union, type-entry-saturating-union) (type-entry-intersection): Adapt to type-entry-min / type-entry-max change. (bv-u32-ref, bv-u32-set!): (bv-s32-ref, bv-s32-set!): (bv-u64-ref, bv-u64-set!): (bv-s64-ref, bv-s64-set!): Precise range inference. This will allow robust unboxing. (ash): Infer 64-bit shifts. --- module/language/cps/types.scm | 87 ++++++++++++++++++----------------- 1 file changed, 45 insertions(+), 42 deletions(-) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 8482b9836..ea89131a3 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -36,11 +36,11 @@ ;;; a minimum and a maximum. The precise meaning of a range depends on ;;; the type. For real numbers, the range indicates an inclusive lower ;;; and upper bound on the integer value of a type. For vectors, the -;;; range indicates the length of the vector. The range is limited to a -;;; signed 32-bit value, with the smallest and largest values indicating -;;; -inf.0 and +inf.0, respectively. For some types, like pairs, the -;;; concept of "range" makes no sense. In these cases we consider the -;;; range to be -inf.0 to +inf.0. +;;; range indicates the length of the vector. The range is the union of +;;; the signed and unsigned 64-bit ranges. Additionally, the minimum +;;; bound of a range may be -inf.0, and the maximum bound may be +inf.0. +;;; For some types, like pairs, the concept of "range" makes no sense. +;;; In these cases we consider the range to be -inf.0 to +inf.0. ;;; ;;; Types are represented as a bitfield. Fewer bits means a more precise ;;; type. Although normally only values that have a single type will @@ -57,7 +57,7 @@ ;;; determined to be the exact integer 0. The second time, it is an ;;; exact integer in the range [0, 1]; the third, [0, 2]; and so on. ;;; This analysis will terminate, but only after the positive half of -;;; the 32-bit range has been fully explored and we decide that the +;;; the 64-bit range has been fully explored and we decide that the ;;; range of N is [0, +inf.0]. At the same time, we want to do range ;;; analysis and type analysis at the same time, as there are ;;; interactions between them, notably in the case of `sqrt' which @@ -180,9 +180,6 @@ (define-syntax &real (identifier-syntax (logior &exact-integer &flonum &fraction))) -(define-syntax *max-s32* (identifier-syntax (- (ash 1 31) 1))) -(define-syntax *min-s32* (identifier-syntax (- 0 (ash 1 31)))) - ;; Versions of min and max that do not coerce exact numbers to become ;; inexact. (define min @@ -206,32 +203,36 @@ (var (identifier? #'var) (datum->syntax #'var val))))))) -(define-compile-time-value min-fixnum most-negative-fixnum) -(define-compile-time-value max-fixnum most-positive-fixnum) +(define-compile-time-value &range-min (- #x8000000000000000)) +(define-compile-time-value &range-max #xffffFFFFffffFFFF) (define-inlinable (make-unclamped-type-entry type min max) (vector type min max)) (define-inlinable (type-entry-type tentry) (vector-ref tentry 0)) -(define-inlinable (type-entry-clamped-min tentry) +(define-inlinable (type-entry-min tentry) (vector-ref tentry 1)) -(define-inlinable (type-entry-clamped-max tentry) +(define-inlinable (type-entry-max tentry) (vector-ref tentry 2)) -(define-syntax-rule (clamp-range val) +(define-inlinable (clamp-min val) (cond - ((< val min-fixnum) min-fixnum) - ((< max-fixnum val) max-fixnum) + ;; Fast path to avoid comparisons with bignums. + ((<= most-negative-fixnum val most-positive-fixnum) val) + ((< val &range-min) -inf.0) + ((< &range-max val) &range-max) + (else val))) + +(define-inlinable (clamp-max val) + (cond + ;; Fast path to avoid comparisons with bignums. + ((<= most-negative-fixnum val most-positive-fixnum) val) + ((< &range-max val) +inf.0) + ((< val &range-min) &range-min) (else val))) (define-inlinable (make-type-entry type min max) - (vector type (clamp-range min) (clamp-range max))) -(define-inlinable (type-entry-min tentry) - (let ((min (type-entry-clamped-min tentry))) - (if (eq? min min-fixnum) -inf.0 min))) -(define-inlinable (type-entry-max tentry) - (let ((max (type-entry-clamped-max tentry))) - (if (eq? max max-fixnum) +inf.0 max))) + (vector type (clamp-min min) (clamp-max max))) (define all-types-entry (make-type-entry &all-types -inf.0 +inf.0)) @@ -259,8 +260,8 @@ ((type-entry<=? a b) b) (else (make-type-entry (logior (type-entry-type a) (type-entry-type b)) - (min (type-entry-clamped-min a) (type-entry-clamped-min b)) - (max (type-entry-clamped-max a) (type-entry-clamped-max b)))))) + (min (type-entry-min a) (type-entry-min b)) + (max (type-entry-max a) (type-entry-max b)))))) (define (type-entry-saturating-union a b) (cond @@ -268,12 +269,12 @@ (else (make-type-entry (logior (type-entry-type a) (type-entry-type b)) - (let ((a-min (type-entry-clamped-min a)) - (b-min (type-entry-clamped-min b))) - (if (< b-min a-min) min-fixnum a-min)) - (let ((a-max (type-entry-clamped-max a)) - (b-max (type-entry-clamped-max b))) - (if (> b-max a-max) max-fixnum a-max)))))) + (let ((a-min (type-entry-min a)) + (b-min (type-entry-min b))) + (if (< b-min a-min) -inf.0 a-min)) + (let ((a-max (type-entry-max a)) + (b-max (type-entry-max b))) + (if (> b-max a-max) +inf.0 a-max)))))) (define (type-entry-intersection a b) (cond @@ -281,8 +282,8 @@ ((type-entry<=? b a) b) (else (make-type-entry (logand (type-entry-type a) (type-entry-type b)) - (max (type-entry-clamped-min a) (type-entry-clamped-min b)) - (min (type-entry-clamped-max a) (type-entry-clamped-max b)))))) + (max (type-entry-min a) (type-entry-min b)) + (min (type-entry-max a) (type-entry-max b)))))) (define (adjoin-var typeset var entry) (intmap-add typeset var entry type-entry-union)) @@ -747,12 +748,14 @@ minimum, and maximum." (define-short-bytevector-accessors bv-u16-ref bv-u16-set! 2 #f) (define-short-bytevector-accessors bv-s16-ref bv-s16-set! 2 #t) -;; The range analysis only works on signed 32-bit values, so some limits -;; are out of range. -(define-bytevector-accessors bv-u32-ref bv-u32-set! &exact-integer 4 0 +inf.0) -(define-bytevector-accessors bv-s32-ref bv-s32-set! &exact-integer 4 -inf.0 +inf.0) -(define-bytevector-accessors bv-u64-ref bv-u64-set! &exact-integer 8 0 +inf.0) -(define-bytevector-accessors bv-s64-ref bv-s64-set! &exact-integer 8 -inf.0 +inf.0) +(define-bytevector-accessors bv-u32-ref bv-u32-set! + &exact-integer 4 #x00000000 #xffffFFFF) +(define-bytevector-accessors bv-s32-ref bv-s32-set! + &exact-integer 4 (- #x80000000) #x7fffFFFF) +(define-bytevector-accessors bv-u64-ref bv-u64-set! + &exact-integer 8 #x0000000000000000 #xffffFFFFffffFFFF) +(define-bytevector-accessors bv-s64-ref bv-s64-set! + &exact-integer 8 (- #x8000000000000000) #x7fffFFFFffffFFFF) (define-bytevector-accessors bv-f32-ref bv-f32-set! &f64 4 -inf.0 +inf.0) (define-bytevector-accessors bv-f64-ref bv-f64-set! &f64 8 -inf.0 +inf.0) @@ -1071,11 +1074,11 @@ minimum, and maximum." (define-simple-type-checker (ash &exact-integer &exact-integer)) (define-type-inferrer (ash val count result) (define (ash* val count) - ;; As we can only represent a 32-bit range, don't bother inferring + ;; As we only precisely represent a 64-bit range, don't bother inferring ;; shifts that might exceed that range. (cond ((inf? val) val) ; Preserves sign. - ((< -32 count 32) (ash val count)) + ((< -64 count 64) (ash val count)) ((zero? val) 0) ((positive? val) +inf.0) (else -inf.0))) @@ -1272,7 +1275,7 @@ minimum, and maximum." entries. A type entry is a vector that describes the types of the values that -flow into and out of a labelled expressoin. The first slot in the type +flow into and out of a labelled expression. The first slot in the type entry vector corresponds to the types that flow in, and the rest of the slots correspond to the types that flow out. Each element of the type entry vector is an intmap mapping variable name to the variable's From 8464cc576c0fb9cf70a51450795338996cc785ce Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 19 Nov 2015 22:12:04 +0100 Subject: [PATCH 122/865] Add bv-length instruction * libguile/vm-engine.c (bv-length): New instruction. * module/language/cps/compile-bytecode.scm (compile-function): * module/language/cps/effects-analysis.scm (bv-length): * module/language/cps/primitives.scm (*instruction-aliases*): * module/language/cps/slot-allocation.scm (compute-var-representations): * module/language/cps/types.scm (bv-length): * module/language/tree-il/compile-cps.scm (convert): Add support for bv-length. * module/system/vm/assembler.scm: Export emit-bv-length. --- libguile/vm-engine.c | 14 +++++++++++++- module/language/cps/compile-bytecode.scm | 2 ++ module/language/cps/effects-analysis.scm | 2 +- module/language/cps/primitives.scm | 1 + module/language/cps/slot-allocation.scm | 2 +- module/language/cps/types.scm | 4 ++-- module/language/tree-il/compile-cps.scm | 7 +++++++ module/system/vm/assembler.scm | 1 + 8 files changed, 28 insertions(+), 5 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 44bd2569b..3e068a18a 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -3341,7 +3341,19 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (1); } - VM_DEFINE_OP (145, unused_145, NULL, NOP) + /* bv-length dst:12 src:12 + * + * Store the length of the bytevector in SRC in DST, as an untagged + * 64-bit integer. + */ + VM_DEFINE_OP (145, bv_length, "bv-length", OP1 (X8_S12_S12) | OP_DST) + { + ARGS1 (bv); + VM_VALIDATE_BYTEVECTOR (bv, "bytevector-length"); + SP_SET_U64 (dst, SCM_BYTEVECTOR_LENGTH (bv)); + NEXT (1); + } + VM_DEFINE_OP (146, unused_146, NULL, NOP) VM_DEFINE_OP (147, unused_147, NULL, NOP) VM_DEFINE_OP (148, unused_148, NULL, NOP) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 7fa5a003c..9e659e261 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -185,6 +185,8 @@ (emit-scm->f64 asm (from-sp dst) (from-sp (slot src)))) (($ $primcall 'f64->scm (src)) (emit-f64->scm asm (from-sp dst) (from-sp (slot src)))) + (($ $primcall 'bv-length (bv)) + (emit-bv-length asm (from-sp dst) (from-sp (slot bv)))) (($ $primcall 'bv-u8-ref (bv idx)) (emit-bv-u8-ref asm (from-sp dst) (from-sp (slot bv)) (from-sp (slot idx)))) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 9c9334671..5b5bf1720 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -360,7 +360,7 @@ is or might be a read or a write to the same location as A." ;; Bytevectors. (define-primitive-effects - ((bytevector-length _) &type-check) + ((bv-length _) &type-check) ((bv-u8-ref bv n) (&read-object &bytevector) &type-check) ((bv-s8-ref bv n) (&read-object &bytevector) &type-check) diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm index 5074fb90c..80c01f0e2 100644 --- a/module/language/cps/primitives.scm +++ b/module/language/cps/primitives.scm @@ -41,6 +41,7 @@ (modulo . mod) (variable-ref . box-ref) (variable-set! . box-set!) + (bytevector-length . bv-length) (bytevector-u8-ref . bv-u8-ref) (bytevector-u16-native-ref . bv-u16-ref) (bytevector-u32-native-ref . bv-u32-ref) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index ca8e32123..e54078027 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -793,7 +793,7 @@ are comparable with eqv?. A tmp slot may be used." (($ $primcall (or 'scm->f64 'bv-f32-ref 'bv-f64-ref 'fadd 'fsub 'fmul 'fdiv)) (intmap-add representations var 'f64)) - (($ $primcall (or 'scm->u64)) + (($ $primcall (or 'scm->u64 'bv-length)) (intmap-add representations var 'u64)) (_ (intmap-add representations var 'scm)))) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index ea89131a3..b99d0f4ab 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -713,8 +713,8 @@ minimum, and maximum." ;;; Bytevectors. ;;; -(define-simple-type-checker (bytevector-length &bytevector)) -(define-type-inferrer (bytevector-length bv result) +(define-simple-type-checker (bv-length &bytevector)) +(define-type-inferrer (bv-length bv result) (restrict! bv &bytevector 0 +inf.0) (define! result &exact-integer (max (&min bv) 0) (&max bv))) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 2ef751b84..7b220b5a9 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -576,6 +576,13 @@ (letk kbox ($kargs ('f64) (f64) ($continue k src ($primcall 'f64->scm (f64))))) kbox)) + ((bv-length) + (with-cps cps + (letv u64) + (let$ k (adapt-arity k src out)) + (letk kbox ($kargs ('u64) (u64) + ($continue k src ($primcall 'u64->scm (u64))))) + kbox)) (else (adapt-arity cps k src out)))) (define (unbox-arg cps arg have-arg) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 21f4353c8..8155ebe3a 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -160,6 +160,7 @@ emit-make-array (emit-scm->f64* . emit-scm->f64) (emit-f64->scm* . emit-f64->scm) + (emit-bv-length* . emit-bv-length) (emit-bv-u8-ref* . emit-bv-u8-ref) (emit-bv-s8-ref* . emit-bv-s8-ref) (emit-bv-u16-ref* . emit-bv-u16-ref) From 87cc8b0f97d231b056ffac0870db708bf996ddf9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 19 Nov 2015 22:13:57 +0100 Subject: [PATCH 123/865] bv-f{32,64}-{ref,set!} take unboxed u64 index * module/language/tree-il/compile-cps.scm (convert): bv-f32-ref, bv-f32-set!, bv-f64-ref, and bv-f64-set! take the index as an untagged u64 value. * module/language/cps/types.scm (define-bytevector-uaccessors): New helper, used while migrating bytevectors to take unboxed indexes. Adapt f32/f64 accessors to use this definition helper. * libguile/vm-engine.c (BV_FLOAT_REF, BV_FLOAT_SET): The index is unboxed. --- libguile/vm-engine.c | 44 ++++++++++++++----------- module/language/cps/types.scm | 24 ++++++++++++-- module/language/tree-il/compile-cps.scm | 27 ++++++++++----- 3 files changed, 65 insertions(+), 30 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 3e068a18a..2839763cb 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -2990,17 +2990,19 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, #define BV_FLOAT_REF(stem, fn_stem, type, size) \ do { \ - scm_t_signed_bits i; \ const type *float_ptr; \ - ARGS2 (bv, idx); \ + scm_t_uint8 dst, src, idx; \ + SCM bv; \ + scm_t_uint64 c_idx; \ + UNPACK_8_8_8 (op, dst, src, idx); \ + bv = SP_REF (src); \ + c_idx = SP_REF_U64 (idx); \ \ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \ - i = SCM_I_INUM (idx); \ - float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ + float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + c_idx); \ \ - if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && (i >= 0) \ - && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ + if (SCM_LIKELY (size <= SCM_BYTEVECTOR_LENGTH (bv) \ + && (c_idx <= SCM_BYTEVECTOR_LENGTH (bv) - size) \ && (ALIGNED_P (float_ptr, type)))) \ { \ SP_SET_F64 (dst, *float_ptr); \ @@ -3008,9 +3010,10 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, } \ else \ { \ - SCM val; \ + SCM scm_idx, val; \ SYNC_IP (); \ - val = scm_bytevector_ ## fn_stem ## _native_ref (bv, idx); \ + scm_idx = scm_from_uint64 (c_idx); \ + val = scm_bytevector_ ## fn_stem ## _native_ref (bv, scm_idx); \ SP_SET_F64 (dst, scm_to_double (val)); \ NEXT (1); \ } \ @@ -3130,29 +3133,30 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, #define BV_FLOAT_SET(stem, fn_stem, type, size) \ do { \ scm_t_uint8 dst, idx, src; \ - scm_t_signed_bits i; \ - SCM bv, scm_idx; \ + SCM bv; \ + scm_t_uint64 c_idx; \ double val; \ type *float_ptr; \ \ UNPACK_8_8_8 (op, dst, idx, src); \ bv = SP_REF (dst); \ - scm_idx = SP_REF (idx); \ + c_idx = SP_REF_U64 (idx); \ val = SP_REF_F64 (src); \ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ - i = SCM_I_INUM (scm_idx); \ - float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ + float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + c_idx); \ \ - if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \ - && (i >= 0) \ - && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ - && (ALIGNED_P (float_ptr, type)))) \ + if (SCM_LIKELY (size <= SCM_BYTEVECTOR_LENGTH (bv) \ + && c_idx <= SCM_BYTEVECTOR_LENGTH (bv) - size \ + && ALIGNED_P (float_ptr, type))) \ *float_ptr = val; \ else \ { \ - SCM boxed = scm_from_double (val); \ + SCM boxed_idx, boxed_val; \ + boxed_idx = scm_from_uint64 (c_idx); \ + boxed_val = scm_from_double (val); \ SYNC_IP (); \ - scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, boxed); \ + scm_bytevector_ ## fn_stem ## _native_set_x (bv, boxed_idx, \ + boxed_val); \ } \ NEXT (1); \ } while (0) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index b99d0f4ab..857a3724d 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -756,8 +756,28 @@ minimum, and maximum." &exact-integer 8 #x0000000000000000 #xffffFFFFffffFFFF) (define-bytevector-accessors bv-s64-ref bv-s64-set! &exact-integer 8 (- #x8000000000000000) #x7fffFFFFffffFFFF) -(define-bytevector-accessors bv-f32-ref bv-f32-set! &f64 4 -inf.0 +inf.0) -(define-bytevector-accessors bv-f64-ref bv-f64-set! &f64 8 -inf.0 +inf.0) + +(define-syntax-rule (define-bytevector-uaccessors ref set type size min max) + (begin + (define-type-checker (ref bv idx) + (and (check-type bv &bytevector 0 +inf.0) + (check-type idx &u64 0 +inf.0) + (< (&max idx) (- (&min bv) size)))) + (define-type-inferrer (ref bv idx result) + (restrict! bv &bytevector (+ (&min idx) size) +inf.0) + (restrict! idx &u64 0 (- (&max bv) size)) + (define! result type min max)) + (define-type-checker (set bv idx val) + (and (check-type bv &bytevector 0 +inf.0) + (check-type idx &u64 0 +inf.0) + (check-type val type min max) + (< (&max idx) (- (&min bv) size)))) + (define-type-inferrer (set! bv idx val) + (restrict! bv &bytevector (+ (&min idx) size) +inf.0) + (restrict! idx &exact-integer 0 (- (&max bv) size)) + (restrict! val type min max)))) +(define-bytevector-uaccessors bv-f32-ref bv-f32-set! &f64 4 -inf.0 +inf.0) +(define-bytevector-uaccessors bv-f64-ref bv-f64-set! &f64 8 -inf.0 +inf.0) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 7b220b5a9..2bde7c5d3 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -585,21 +585,32 @@ kbox)) (else (adapt-arity cps k src out)))) - (define (unbox-arg cps arg have-arg) + (define (unbox-arg cps arg unbox-op have-arg) (with-cps cps - (letv f64) - (let$ body (have-arg f64)) - (letk kunboxed ($kargs ('f64) (f64) ,body)) + (letv unboxed) + (let$ body (have-arg unboxed)) + (letk kunboxed ($kargs ('unboxed) (unboxed) ,body)) (build-term - ($continue kunboxed src ($primcall 'scm->f64 (arg)))))) + ($continue kunboxed src ($primcall unbox-op (arg)))))) (define (unbox-args cps args have-args) (case instruction + ((bv-f32-ref bv-f64-ref) + (match args + ((bv idx) + (unbox-arg + cps idx 'scm->u64 + (lambda (cps idx) + (have-args cps (list bv idx))))))) ((bv-f32-set! bv-f64-set!) (match args ((bv idx val) - (unbox-arg cps val - (lambda (cps val) - (have-args cps (list bv idx val))))))) + (unbox-arg + cps idx 'scm->u64 + (lambda (cps idx) + (unbox-arg + cps val 'scm->f64 + (lambda (cps val) + (have-args cps (list bv idx val))))))))) (else (have-args cps args)))) (convert-args cps args (lambda (cps args) From 07607f66b81f644077fc734b591da2aa84af10e2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 19 Nov 2015 22:49:54 +0100 Subject: [PATCH 124/865] Add instructions to branch on u64 comparisons * libguile/vm-engine.c (BR_U64_ARITHMETIC): New helper. (br-if-u64-=, br-if-u64-<, br-if-u64->=): New instructions. * module/language/cps/compile-bytecode.scm (compile-function): * module/language/cps/effects-analysis.scm: * module/language/cps/primitives.scm (*branching-primcall-arities*): * module/language/cps/type-fold.scm: * module/language/cps/types.scm (u64-=, infer-u64-comparison-ranges): (define-u64-comparison-inferrer, u64-<, u64-<=, u64->=, u64->): * module/system/vm/assembler.scm: * module/system/vm/disassembler.scm (code-annotation): (compute-labels): Compiler and toolchain support for the new instructions. --- libguile/vm-engine.c | 47 ++++++++++++++++++++++-- module/language/cps/compile-bytecode.scm | 5 +++ module/language/cps/effects-analysis.scm | 5 +++ module/language/cps/primitives.scm | 5 +++ module/language/cps/type-fold.scm | 9 ++++- module/language/cps/types.scm | 37 +++++++++++++++++++ module/system/vm/assembler.scm | 3 ++ module/system/vm/disassembler.scm | 4 +- 8 files changed, 110 insertions(+), 5 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 2839763cb..e7994cd32 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -376,6 +376,25 @@ } \ } +#define BR_U64_ARITHMETIC(crel,srel) \ + { \ + scm_t_uint32 a, b; \ + scm_t_uint64 x, y; \ + UNPACK_24 (op, a); \ + UNPACK_24 (ip[1], b); \ + x = SP_REF_U64 (a); \ + y = SP_REF_U64 (b); \ + if ((ip[2] & 0x1) ? !(x crel y) : (x crel y)) \ + { \ + scm_t_int32 offset = ip[2]; \ + offset >>= 8; /* Sign-extending shift. */ \ + if (offset <= 0) \ + VM_HANDLE_INTERRUPTS; \ + NEXT (offset); \ + } \ + NEXT (3); \ + } + #define ARGS1(a1) \ scm_t_uint16 dst, src; \ SCM a1; \ @@ -3358,9 +3377,31 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (1); } - VM_DEFINE_OP (146, unused_146, NULL, NOP) - VM_DEFINE_OP (147, unused_147, NULL, NOP) - VM_DEFINE_OP (148, unused_148, NULL, NOP) + /* br-if-= a:12 b:12 invert:1 _:7 offset:24 + * + * If the value in A is = to the value in B, add OFFSET, a signed + * 24-bit number, to the current instruction pointer. + */ + VM_DEFINE_OP (146, br_if_u64_ee, "br-if-u64-=", OP3 (X8_S24, X8_S24, B1_X7_L24)) + { + BR_U64_ARITHMETIC (==, scm_num_eq_p); + } + + /* br-if-< a:12 b:12 invert:1 _:7 offset:24 + * + * If the value in A is < to the value in B, add OFFSET, a signed + * 24-bit number, to the current instruction pointer. + */ + VM_DEFINE_OP (147, br_if_u64_lt, "br-if-u64-<", OP3 (X8_S24, X8_S24, B1_X7_L24)) + { + BR_U64_ARITHMETIC (<, scm_less_p); + } + + VM_DEFINE_OP (148, br_if_u64_le, "br-if-u64-<=", OP3 (X8_S24, X8_S24, B1_X7_L24)) + { + BR_U64_ARITHMETIC (<=, scm_leq_p); + } + VM_DEFINE_OP (149, unused_149, NULL, NOP) VM_DEFINE_OP (150, unused_150, NULL, NOP) VM_DEFINE_OP (151, unused_151, NULL, NOP) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 9e659e261..2a6370c25 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -373,6 +373,11 @@ (($ $primcall '= (a b)) (binary emit-br-if-= a b)) (($ $primcall '>= (a b)) (binary emit-br-if-<= b a)) (($ $primcall '> (a b)) (binary emit-br-if-< b a)) + (($ $primcall 'u64-< (a b)) (binary emit-br-if-u64-< a b)) + (($ $primcall 'u64-<= (a b)) (binary emit-br-if-u64-<= a b)) + (($ $primcall 'u64-= (a b)) (binary emit-br-if-u64-= a b)) + (($ $primcall 'u64->= (a b)) (binary emit-br-if-u64-<= b a)) + (($ $primcall 'u64-> (a b)) (binary emit-br-if-u64-< b a)) (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b)))) (define (compile-trunc label k exp nreq rest-var) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 5b5bf1720..fc8229386 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -411,6 +411,11 @@ is or might be a read or a write to the same location as A." ((> . _) &type-check) ((<= . _) &type-check) ((>= . _) &type-check) + ((u64-= . _)) + ((u64-< . _)) + ((u64-> . _)) + ((u64-<= . _)) + ((u64->= . _)) ((zero? . _) &type-check) ((add . _) &type-check) ((mul . _) &type-check) diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm index 80c01f0e2..3628b5cf7 100644 --- a/module/language/cps/primitives.scm +++ b/module/language/cps/primitives.scm @@ -88,6 +88,11 @@ (> . (1 . 2)) (<= . (1 . 2)) (>= . (1 . 2)) + (u64-= . (1 . 2)) + (u64-< . (1 . 2)) + (u64-> . (1 . 2)) + (u64-<= . (1 . 2)) + (u64->= . (1 . 2)) (logtest . (1 . 2)))) (define (compute-prim-instructions) diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm index c3703064c..e3939e0b6 100644 --- a/module/language/cps/type-fold.scm +++ b/module/language/cps/type-fold.scm @@ -93,7 +93,9 @@ (define-branch-folder-alias eqv? eq?) (define (compare-ranges type0 min0 max0 type1 min1 max1) - (and (zero? (logand (logior type0 type1) (lognot &real))) + ;; Since &real, &u64, and &f64 are disjoint, we can compare once + ;; against their mask instead of doing three "or" comparisons. + (and (zero? (logand (logior type0 type1) (lognot (logior &real &f64 &u64)))) (cond ((< max0 min1) '<) ((> min0 max1) '>) ((= min0 max0 min1 max1) '=) @@ -106,30 +108,35 @@ ((<) (values #t #t)) ((= >= >) (values #t #f)) (else (values #f #f)))) +(define-branch-folder-alias u64-< <) (define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1) (case (compare-ranges type0 min0 max0 type1 min1 max1) ((< <= =) (values #t #t)) ((>) (values #t #f)) (else (values #f #f)))) +(define-branch-folder-alias u64-<= <=) (define-binary-branch-folder (= type0 min0 max0 type1 min1 max1) (case (compare-ranges type0 min0 max0 type1 min1 max1) ((=) (values #t #t)) ((< >) (values #t #f)) (else (values #f #f)))) +(define-branch-folder-alias u64-= =) (define-binary-branch-folder (>= type0 min0 max0 type1 min1 max1) (case (compare-ranges type0 min0 max0 type1 min1 max1) ((> >= =) (values #t #t)) ((<) (values #t #f)) (else (values #f #f)))) +(define-branch-folder-alias u64->= >=) (define-binary-branch-folder (> type0 min0 max0 type1 min1 max1) (case (compare-ranges type0 min0 max0 type1 min1 max1) ((>) (values #t #t)) ((= <= <) (values #t #f)) (else (values #f #f)))) +(define-branch-folder-alias u64-> >) (define-binary-branch-folder (logtest type0 min0 max0 type1 min1 max1) (define (logand-min a b) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 857a3724d..81d2eb1eb 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -835,6 +835,43 @@ minimum, and maximum." (define-simple-type-checker (> &real &real)) (define-comparison-inferrer (> <=)) +(define-simple-type-checker (u64-= &u64 &u64)) +(define-predicate-inferrer (u64-= a b true?) + (when true? + (let ((min (max (&min a) (&min b))) + (max (min (&max a) (&max b)))) + (restrict! a &u64 min max) + (restrict! b &u64 min max)))) + +(define (infer-u64-comparison-ranges op min0 max0 min1 max1) + (match op + ('< (values min0 (min max0 (1- max1)) (max (1+ min0) min1) max1)) + ('<= (values min0 (min max0 max1) (max min0 min1) max1)) + ('>= (values (max min0 min1) max0 min1 (min max0 max1))) + ('> (values (max min0 (1+ min1)) max0 min1 (min (1- max0) max1))))) +(define-syntax-rule (define-u64-comparison-inferrer (u64-op op inverse)) + (define-predicate-inferrer (u64-op a b true?) + (call-with-values + (lambda () + (infer-u64-comparison-ranges (if true? 'op 'inverse) + (&min a) (&max a) + (&min b) (&max b))) + (lambda (min0 max0 min1 max1) + (restrict! a &u64 min0 max0) + (restrict! b &u64 min1 max1))))) + +(define-simple-type-checker (u64-< &u64 &u64)) +(define-u64-comparison-inferrer (u64-< < >=)) + +(define-simple-type-checker (u64-<= &u64 &u64)) +(define-u64-comparison-inferrer (u64-<= <= >)) + +(define-simple-type-checker (u64->= &u64 &u64)) +(define-u64-comparison-inferrer (u64-<= >= <)) + +(define-simple-type-checker (u64-> &u64 &u64)) +(define-u64-comparison-inferrer (u64-> > <=)) + ;; Arithmetic. (define-syntax-rule (define-unary-result! a result min max) (let ((min* min) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 8155ebe3a..0ee391822 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -95,6 +95,9 @@ emit-br-if-< emit-br-if-<= emit-br-if-logtest + emit-br-if-u64-= + emit-br-if-u64-< + emit-br-if-u64-<= (emit-mov* . emit-mov) (emit-fmov* . emit-fmov) (emit-box* . emit-box) diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index d90c88505..b0712540c 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -195,6 +195,7 @@ address of that offset." 'br-if-true 'br-if-null 'br-if-nil 'br-if-pair 'br-if-struct 'br-if-char 'br-if-eq 'br-if-eqv 'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->= + 'br-if-u64-= 'br-if-u64-< 'br-if-u64-<= 'br-if-logtest) _ ... target) (list "-> ~A" (vector-ref labels (- (+ offset target) start)))) (('br-if-tc7 slot invert? tc7 target) @@ -296,7 +297,8 @@ address of that offset." br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt br-if-true br-if-null br-if-nil br-if-pair br-if-struct br-if-char br-if-tc7 br-if-eq br-if-eqv - br-if-= br-if-< br-if-<= br-if-> br-if->= br-if-logtest) + br-if-= br-if-< br-if-<= br-if-> br-if->= br-if-logtest + br-if-u64-= br-if-u64-< br-if-u64-<=) (match arg ((_ ... target) (add-label! (+ offset target) "L")))) From 163fcf5adb5700c8d5fe2e9bd0a57ce7c7bf1c34 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 20 Nov 2015 09:26:56 +0100 Subject: [PATCH 125/865] Specialize u64 comparisons * module/language/cps/specialize-numbers.scm (specialize-u64-comparison): New function. * module/language/cps/specialize-numbers.scm (specialize-operations): Rename from specialize-f64-operations, as it will specialize both kinds. Add a case to specialize u64 comparisons. * module/language/cps/specialize-numbers.scm (specialize-numbers): Adapt to specialize-operations name change. --- module/language/cps/specialize-numbers.scm | 35 ++++++++++++++++++++-- 1 file changed, 33 insertions(+), 2 deletions(-) diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm index 5f15806a8..105086560 100644 --- a/module/language/cps/specialize-numbers.scm +++ b/module/language/cps/specialize-numbers.scm @@ -81,7 +81,22 @@ ($continue kunbox-b src ($primcall 'scm->f64 (a))))))) -(define (specialize-f64-operations cps) +(define (specialize-u64-comparison cps kf kt src op a b) + (pk 'specialize cps kf kt src op a b) + (let ((op (symbol-append 'u64- op))) + (with-cps cps + (letv u64-a u64-b) + (letk kop ($kargs ('u64-b) (u64-b) + ($continue kf src + ($branch kt ($primcall op (u64-a u64-b)))))) + (letk kunbox-b ($kargs ('u64-a) (u64-a) + ($continue kop src + ($primcall 'scm->u64 (b))))) + (build-term + ($continue kunbox-b src + ($primcall 'scm->u64 (a))))))) + +(define (specialize-operations cps) (define (visit-cont label cont cps types) (match cont (($ $kfun) @@ -101,6 +116,22 @@ (setk label ($kargs names vars ,body))) cps) types)))))) + (($ $kargs names vars + ($ $continue k src + ($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) (a b))))) + (call-with-values (lambda () (lookup-pre-type types label a)) + (lambda (a-type a-min a-max) + (call-with-values (lambda () (lookup-pre-type types label b)) + (lambda (b-type b-min b-max) + (values + (if (and (eqv? a-type b-type &exact-integer) + (<= 0 a-min a-max #xffffffffffffffff) + (<= 0 b-min b-max #xffffffffffffffff)) + (with-cps cps + (let$ body (specialize-u64-comparison k kt src op a b)) + (setk label ($kargs names vars ,body))) + cps) + types)))))) (_ (values cps types)))) (values (intmap-fold visit-cont cps cps #f))) @@ -342,4 +373,4 @@ ;; Type inference wants a renumbered graph; OK. (let ((cps (renumber cps))) (with-fresh-name-state cps - (specialize-f64-phis (specialize-f64-operations cps))))) + (specialize-f64-phis (specialize-operations cps))))) From 4305b39336aa536513ab581b33088cd440b9cba5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 20 Nov 2015 10:13:16 +0100 Subject: [PATCH 126/865] Beginning of u64 phi unboxing * module/language/cps/specialize-numbers.scm (compute-specializable-u64-vars): New stub. * module/language/cps/specialize-numbers.scm (compute-specializable-phis): Rename from compute-specializable-f64-phis, and return an intmap instead of an intset. The values distinguish f64 from u64 vars. * module/language/cps/specialize-numbers.scm (apply-specialization): Start of u64 phi unboxing. * module/language/cps/specialize-numbers.scm (specialize-phis): (specialize-numbers): Adapt. --- module/language/cps/specialize-numbers.scm | 107 ++++++++++++--------- 1 file changed, 62 insertions(+), 45 deletions(-) diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm index 105086560..7ab51860e 100644 --- a/module/language/cps/specialize-numbers.scm +++ b/module/language/cps/specialize-numbers.scm @@ -151,6 +151,10 @@ (_ defs))) labels empty-intmap)) +;; Placeholder until we add the real implementation. +(define (compute-specializable-u64-vars cps body preds defs) + empty-intset) + ;; Compute vars whose definitions are all inexact reals and whose uses ;; include an unbox operation. (define (compute-specializable-f64-vars cps body preds defs) @@ -245,33 +249,44 @@ preds empty-intset)) ;; Compute the set of variables which have more than one definition, -;; whose definitions are always f64-valued, and which have at least one -;; use that is an unbox operation. -(define (compute-specializable-f64-phis cps body preds defs) - (intset-intersect - (compute-specializable-f64-vars cps body preds defs) - (compute-phi-vars cps preds))) +;; whose definitions are always f64-valued or u64-valued, and which have +;; at least one use that is an unbox operation. +(define (compute-specializable-phis cps body preds defs) + (let ((f64-vars (compute-specializable-f64-vars cps body preds defs)) + (u64-vars (compute-specializable-u64-vars cps body preds defs)) + (phi-vars (compute-phi-vars cps preds))) + (unless (eq? empty-intset (intset-intersect f64-vars u64-vars)) + (error "expected f64 and u64 vars to be disjoint sets")) + (intset-fold (lambda (var out) (intmap-add out var 'u64)) + (intset-intersect u64-vars phi-vars) + (intset-fold (lambda (var out) (intmap-add out var 'f64)) + (intset-intersect f64-vars phi-vars) + empty-intmap)))) -;; Each definition of an f64 variable should unbox that variable. The -;; cont that binds the variable should re-box it under its original +;; Each definition of an f64/u64 variable should unbox that variable. +;; The cont that binds the variable should re-box it under its original ;; name, and rely on CSE to remove the boxing as appropriate. -(define (apply-f64-specialization cps kfun body preds defs phis) +(define (apply-specialization cps kfun body preds defs phis) (define (compute-unbox-labels) - (intset-fold (lambda (phi labels) + (intmap-fold (lambda (phi kind labels) (fold1 (lambda (pred labels) (intset-add labels pred)) (intmap-ref preds (intmap-ref defs phi)) labels)) phis empty-intset)) + (define (unbox-op var) + (match (intmap-ref phis var) + ('f64 'scm->f64) + ('u64 'scm->u64))) (define (unbox-operands) (define (unbox-arg cps arg def-var have-arg) - (if (intset-ref phis def-var) + (if (intmap-ref phis def-var (lambda (_) #f)) (with-cps cps - (letv f64) - (let$ body (have-arg f64)) - (letk kunboxed ($kargs ('f64) (f64) ,body)) + (letv unboxed) + (let$ body (have-arg unboxed)) + (letk kunboxed ($kargs ('unboxed) (unboxed) ,body)) (build-term - ($continue kunboxed #f ($primcall 'scm->f64 (arg))))) + ($continue kunboxed #f ($primcall (unbox-op def-var) (arg))))) (have-arg cps arg))) (define (unbox-args cps args def-vars have-args) (match args @@ -288,33 +303,35 @@ (lambda (label cps) (match (intmap-ref cps label) (($ $kargs names vars ($ $continue k src exp)) - ;; For expressions that define a single value, we know we need - ;; to unbox that value. For $values though we might have to - ;; unbox just a subset of values. - (match exp - (($ $values args) - (let ((def-vars (match (intmap-ref cps k) - (($ $kargs _ defs) defs)))) - (with-cps cps - (let$ term (unbox-args - args def-vars - (lambda (cps args) - (with-cps cps - (build-term - ($continue k src ($values args))))))) - (setk label ($kargs names vars ,term))))) - (_ - (with-cps cps - (letv const) - (letk kunbox ($kargs ('const) (const) - ($continue k src - ($primcall 'scm->f64 (const))))) - (setk label ($kargs names vars - ($continue k src ,exp))))))))) + (match (intmap-ref cps k) + (($ $kargs _ defs) + (match exp + ;; For expressions that define a single value, we know we need + ;; to unbox that value. For $values though we might have to + ;; unbox just a subset of values. + (($ $values args) + (with-cps cps + (let$ term (unbox-args + args defs + (lambda (cps args) + (with-cps cps + (build-term + ($continue k src ($values args))))))) + (setk label ($kargs names vars ,term)))) + (_ + (match defs + ((def) + (with-cps cps + (letv boxed) + (letk kunbox ($kargs ('boxed) (boxed) + ($continue k src + ($primcall (unbox-op def) (boxed))))) + (setk label ($kargs names vars + ($continue kunbox src ,exp))))))))))))) (compute-unbox-labels) cps)) (define (compute-box-labels) - (intset-fold (lambda (phi labels) + (intmap-fold (lambda (phi kind labels) (intset-add labels (intmap-ref defs phi))) phis empty-intset)) (define (box-results cps) @@ -323,7 +340,7 @@ (match (intmap-ref cps label) (($ $kargs names vars term) (let* ((boxed (fold1 (lambda (var boxed) - (if (intset-ref phis var) + (if (intmap-ref phis var (lambda (_) #f)) (intmap-add boxed var (fresh-var)) boxed)) vars empty-intmap)) @@ -357,15 +374,15 @@ cps)) (box-results (unbox-operands))) -(define (specialize-f64-phis cps) +(define (specialize-phis cps) (intmap-fold (lambda (kfun body cps) (let* ((preds (compute-predecessors cps kfun #:labels body)) (defs (compute-defs cps body)) - (phis (compute-specializable-f64-phis cps body preds defs))) - (if (eq? phis empty-intset) + (phis (compute-specializable-phis cps body preds defs))) + (if (eq? phis empty-intmap) cps - (apply-f64-specialization cps kfun body preds defs phis)))) + (apply-specialization cps kfun body preds defs phis)))) (compute-reachable-functions cps) cps)) @@ -373,4 +390,4 @@ ;; Type inference wants a renumbered graph; OK. (let ((cps (renumber cps))) (with-fresh-name-state cps - (specialize-f64-phis (specialize-operations cps))))) + (specialize-phis (specialize-operations cps))))) From 2906d963ea5472c09fbec60f70e3aa6393fe3bae Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 20 Nov 2015 10:41:31 +0100 Subject: [PATCH 127/865] Unbox u64 phi values * module/language/cps/specialize-numbers.scm (compute-specializable-vars): Refactor to work on any kind of unboxable value, not just f64 values. (compute-specializable-f64-vars, compute-specializable-u64-vars): New helpers. (apply-specialization): Support for u64 values. --- module/language/cps/specialize-numbers.scm | 187 ++++++++++++--------- 1 file changed, 108 insertions(+), 79 deletions(-) diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm index 7ab51860e..61c2b746f 100644 --- a/module/language/cps/specialize-numbers.scm +++ b/module/language/cps/specialize-numbers.scm @@ -151,88 +151,112 @@ (_ defs))) labels empty-intmap)) -;; Placeholder until we add the real implementation. -(define (compute-specializable-u64-vars cps body preds defs) - empty-intset) +;; Compute vars whose definitions are all unboxable and whose uses +;; include an unbox operation. +(define (compute-specializable-vars cps body preds defs + exp-result-unboxable? + unbox-op) + ;; Compute a map of VAR->LABEL... indicating the set of labels that + ;; define VAR with unboxable values, given the set of vars + ;; UNBOXABLE-VARS which is known already to be unboxable. + (define (collect-unboxable-def-labels unboxable-vars) + (define (add-unboxable-def unboxable-defs var label) + (intmap-add unboxable-defs var (intset label) intset-union)) + (intset-fold (lambda (label unboxable-defs) + (match (intmap-ref cps label) + (($ $kargs _ _ ($ $continue k _ exp)) + (match exp + ((? exp-result-unboxable?) + (match (intmap-ref cps k) + (($ $kargs (_) (def)) + (add-unboxable-def unboxable-defs def label)))) + (($ $values vars) + (match (intmap-ref cps k) + (($ $kargs _ defs) + (fold + (lambda (var def unboxable-defs) + (if (intset-ref unboxable-vars var) + (add-unboxable-def unboxable-defs def label) + unboxable-defs)) + unboxable-defs vars defs)) + ;; Could be $ktail for $values. + (_ unboxable-defs))) + (_ unboxable-defs))) + (_ unboxable-defs))) + body empty-intmap)) + + ;; Compute the set of vars which are always unboxable. + (define (compute-unboxable-defs) + (fixpoint + (lambda (unboxable-vars) + (intmap-fold + (lambda (def unboxable-pred-labels unboxable-vars) + (if (and (not (intset-ref unboxable-vars def)) + ;; Are all defining expressions unboxable? + (and-map (lambda (pred) + (intset-ref unboxable-pred-labels pred)) + (intmap-ref preds (intmap-ref defs def)))) + (intset-add unboxable-vars def) + unboxable-vars)) + (collect-unboxable-def-labels unboxable-vars) + unboxable-vars)) + empty-intset)) + + ;; Compute the set of vars that may ever be unboxed. + (define (compute-unbox-uses unboxable-defs) + (intset-fold + (lambda (label unbox-uses) + (match (intmap-ref cps label) + (($ $kargs _ _ ($ $continue k _ exp)) + (match exp + (($ $primcall (? (lambda (op) (eq? op unbox-op))) (var)) + (intset-add unbox-uses var)) + (($ $values vars) + (match (intmap-ref cps k) + (($ $kargs _ defs) + (fold (lambda (var def unbox-uses) + (if (intset-ref unboxable-defs def) + (intset-add unbox-uses var) + unbox-uses)) + unbox-uses vars defs)) + (($ $ktail) + ;; Assume return is rare and that any unboxable def can + ;; be reboxed when leaving the procedure. + (fold (lambda (var unbox-uses) + (intset-add unbox-uses var)) + unbox-uses vars)))) + (_ unbox-uses))) + (_ unbox-uses))) + body empty-intset)) + + (let ((unboxable-defs (compute-unboxable-defs))) + (intset-intersect unboxable-defs (compute-unbox-uses unboxable-defs)))) ;; Compute vars whose definitions are all inexact reals and whose uses ;; include an unbox operation. (define (compute-specializable-f64-vars cps body preds defs) - ;; Compute a map of VAR->LABEL... indicating the set of labels that - ;; define VAR with f64 values, given the set of vars F64-VARS which is - ;; known already to be f64-valued. - (define (collect-f64-def-labels f64-vars) - (define (add-f64-def f64-defs var label) - (intmap-add f64-defs var (intset label) intset-union)) - (intset-fold (lambda (label f64-defs) - (match (intmap-ref cps label) - (($ $kargs _ _ ($ $continue k _ exp)) - (match exp - ((or ($ $primcall 'f64->scm (_)) - ($ $const (and (? number?) (? inexact?) (? real?)))) - (match (intmap-ref cps k) - (($ $kargs (_) (def)) - (add-f64-def f64-defs def label)))) - (($ $values vars) - (match (intmap-ref cps k) - (($ $kargs _ defs) - (fold (lambda (var def f64-defs) - (if (intset-ref f64-vars var) - (add-f64-def f64-defs def label) - f64-defs)) - f64-defs vars defs)) - ;; Could be $ktail for $values. - (_ f64-defs))) - (_ f64-defs))) - (_ f64-defs))) - body empty-intmap)) + ;; Can the result of EXP definitely be unboxed as an f64? + (define (exp-result-f64? exp) + (match exp + ((or ($ $primcall 'f64->scm (_)) + ($ $const (and (? number?) (? inexact?) (? real?)))) + #t) + (_ #f))) + (compute-specializable-vars cps body preds defs exp-result-f64? 'scm->f64)) - ;; Compute the set of vars which are always f64-valued. - (define (compute-f64-defs) - (fixpoint - (lambda (f64-vars) - (intmap-fold - (lambda (def f64-pred-labels f64-vars) - (if (and (not (intset-ref f64-vars def)) - ;; Are all defining expressions f64-valued? - (and-map (lambda (pred) - (intset-ref f64-pred-labels pred)) - (intmap-ref preds (intmap-ref defs def)))) - (intset-add f64-vars def) - f64-vars)) - (collect-f64-def-labels f64-vars) - f64-vars)) - empty-intset)) +;; Compute vars whose definitions are all exact integers in the u64 +;; range and whose uses include an unbox operation. +(define (compute-specializable-u64-vars cps body preds defs) + ;; Can the result of EXP definitely be unboxed as a u64? + (define (exp-result-u64? exp) + (match exp + ((or ($ $primcall 'u64->scm (_)) + ($ $const (and (? number?) (? exact-integer?) + (? (lambda (n) (<= 0 n #xffffffffffffffff)))))) + #t) + (_ #f))) - ;; Compute the set of vars that may ever be unboxed. - (define (compute-f64-uses f64-defs) - (intset-fold - (lambda (label f64-uses) - (match (intmap-ref cps label) - (($ $kargs _ _ ($ $continue k _ exp)) - (match exp - (($ $primcall 'scm->f64 (var)) - (intset-add f64-uses var)) - (($ $values vars) - (match (intmap-ref cps k) - (($ $kargs _ defs) - (fold (lambda (var def f64-uses) - (if (intset-ref f64-defs def) - (intset-add f64-uses var) - f64-uses)) - f64-uses vars defs)) - (($ $ktail) - ;; Assume return is rare and that any f64-valued def can - ;; be reboxed when leaving the procedure. - (fold (lambda (var f64-uses) - (intset-add f64-uses var)) - f64-uses vars)))) - (_ f64-uses))) - (_ f64-uses))) - body empty-intset)) - - (let ((f64-defs (compute-f64-defs))) - (intset-intersect f64-defs (compute-f64-uses f64-defs)))) + (compute-specializable-vars cps body preds defs exp-result-u64? 'scm->u64)) (define (compute-phi-vars cps preds) (intmap-fold (lambda (label preds phis) @@ -278,6 +302,10 @@ (match (intmap-ref phis var) ('f64 'scm->f64) ('u64 'scm->u64))) + (define (box-op var) + (match (intmap-ref phis var) + ('f64 'f64->scm) + ('u64 'u64->scm))) (define (unbox-operands) (define (unbox-arg cps arg def-var have-arg) (if (intmap-ref phis def-var (lambda (_) #f)) @@ -348,13 +376,14 @@ (intmap-ref boxed var (lambda (var) var))) vars))) (define (box-var cps name var done) - (let ((f64 (intmap-ref boxed var (lambda (_) #f)))) - (if f64 + (let ((unboxed (intmap-ref boxed var (lambda (_) #f)))) + (if unboxed (with-cps cps (let$ term (done)) (letk kboxed ($kargs (name) (var) ,term)) (build-term - ($continue kboxed #f ($primcall 'f64->scm (f64))))) + ($continue kboxed #f + ($primcall (box-op var) (unboxed))))) (done cps)))) (define (box-vars cps names vars done) (match vars From d294d5d1e19f589dd910ec269ef360484ad754e5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 20 Nov 2015 10:58:21 +0100 Subject: [PATCH 128/865] Add unsigned 64-bit arithmetic operators: uadd, usub, umul * libguile/vm-engine.c (uadd, usub, umul): New ops. * module/language/cps/effects-analysis.scm (uadd, usub, umul): Add effects analysis. * module/language/cps/slot-allocation.scm (compute-var-representations): The new ops define 'u64 values. * module/language/cps/types.scm (uadd, usub, umul): Add type checkers and inferrers. * module/system/vm/assembler.scm (emit-uadd, emit-usub, emit-umul): New assemblers. --- libguile/vm-engine.c | 45 ++++++++++++++++++++++-- module/language/cps/effects-analysis.scm | 3 ++ module/language/cps/slot-allocation.scm | 3 +- module/language/cps/types.scm | 21 +++++++++++ module/system/vm/assembler.scm | 3 ++ 5 files changed, 71 insertions(+), 4 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index e7994cd32..d615af1aa 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -3402,9 +3402,48 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, BR_U64_ARITHMETIC (<=, scm_leq_p); } - VM_DEFINE_OP (149, unused_149, NULL, NOP) - VM_DEFINE_OP (150, unused_150, NULL, NOP) - VM_DEFINE_OP (151, unused_151, NULL, NOP) + /* uadd dst:8 a:8 b:8 + * + * Add A to B, and place the result in DST. The operands and the + * result are unboxed unsigned 64-bit integers. Overflow will wrap + * around. + */ + VM_DEFINE_OP (149, uadd, "uadd", OP1 (X8_S8_S8_S8) | OP_DST) + { + scm_t_uint8 dst, a, b; + UNPACK_8_8_8 (op, dst, a, b); + SP_SET_U64 (dst, SP_REF_U64 (a) + SP_REF_U64 (b)); + NEXT (1); + } + + /* usub dst:8 a:8 b:8 + * + * Subtract B from A, and place the result in DST. The operands and + * the result are unboxed unsigned 64-bit integers. Overflow will + * wrap around. + */ + VM_DEFINE_OP (150, usub, "usub", OP1 (X8_S8_S8_S8) | OP_DST) + { + scm_t_uint8 dst, a, b; + UNPACK_8_8_8 (op, dst, a, b); + SP_SET_U64 (dst, SP_REF_U64 (a) - SP_REF_U64 (b)); + NEXT (1); + } + + /* umul dst:8 a:8 b:8 + * + * Multiply A and B, and place the result in DST. The operands and + * the result are unboxed unsigned 64-bit integers. Overflow will + * wrap around. + */ + VM_DEFINE_OP (151, umul, "umul", OP1 (X8_S8_S8_S8) | OP_DST) + { + scm_t_uint8 dst, a, b; + UNPACK_8_8_8 (op, dst, a, b); + SP_SET_U64 (dst, SP_REF_U64 (a) * SP_REF_U64 (b)); + NEXT (1); + } + VM_DEFINE_OP (152, unused_152, NULL, NOP) VM_DEFINE_OP (153, unused_153, NULL, NOP) VM_DEFINE_OP (154, unused_154, NULL, NOP) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index fc8229386..9112c429b 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -425,6 +425,9 @@ is or might be a read or a write to the same location as A." ((fsub . _)) ((fmul . _)) ((fdiv . _)) + ((uadd . _)) + ((usub . _)) + ((umul . _)) ((sub1 . _) &type-check) ((add1 . _) &type-check) ((quo . _) &type-check) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index e54078027..e8519f0fa 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -793,7 +793,8 @@ are comparable with eqv?. A tmp slot may be used." (($ $primcall (or 'scm->f64 'bv-f32-ref 'bv-f64-ref 'fadd 'fsub 'fmul 'fdiv)) (intmap-add representations var 'f64)) - (($ $primcall (or 'scm->u64 'bv-length)) + (($ $primcall (or 'scm->u64 'bv-length + 'uadd 'usub 'umul)) (intmap-add representations var 'u64)) (_ (intmap-add representations var 'scm)))) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 81d2eb1eb..41d4f562c 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -916,6 +916,7 @@ minimum, and maximum." (define-simple-type-checker (add &number &number)) (define-type-checker (fadd a b) #t) +(define-type-checker (uadd a b) #t) (define-type-inferrer (add a b result) (define-binary-result! a b result #t (+ (&min a) (&min b)) @@ -924,9 +925,16 @@ minimum, and maximum." (define! result &f64 (+ (&min a) (&min b)) (+ (&max a) (&max b)))) +(define-type-inferrer (uadd a b result) + ;; Handle wraparound. + (let ((max (+ (&max a) (&max b)))) + (if (<= max #xffffffffffffffff) + (define! result &u64 (+ (&min a) (&min b)) max) + (define! result &u64 0 #xffffffffffffffff)))) (define-simple-type-checker (sub &number &number)) (define-type-checker (fsub a b) #t) +(define-type-checker (usub a b) #t) (define-type-inferrer (sub a b result) (define-binary-result! a b result #t (- (&min a) (&max b)) @@ -935,9 +943,16 @@ minimum, and maximum." (define! result &f64 (- (&min a) (&max b)) (- (&max a) (&min b)))) +(define-type-inferrer (usub a b result) + ;; Handle wraparound. + (let ((min (- (&min a) (&max b)))) + (if (< min 0) + (define! result &u64 0 #xffffffffffffffff) + (define! result &u64 min (- (&max a) (&min b)))))) (define-simple-type-checker (mul &number &number)) (define-type-checker (fmul a b) #t) +(define-type-checker (umul a b) #t) (define (mul-result-range same? nan-impossible? min-a max-a min-b max-b) (define (nan* a b) (if (and (or (and (inf? a) (zero? b)) @@ -980,6 +995,12 @@ minimum, and maximum." min-a max-a min-b max-b)) (lambda (min max) (define! result &f64 min max))))) +(define-type-inferrer (umul a b result) + ;; Handle wraparound. + (let ((max (* (&max a) (&max b)))) + (if (<= max #xffffffffffffffff) + (define! result &u64 (* (&min a) (&min b)) max) + (define! result &u64 0 #xffffffffffffffff)))) (define-type-checker (div a b) (and (check-type a &number -inf.0 +inf.0) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 0ee391822..76ae892a3 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -142,6 +142,9 @@ (emit-fsub* . emit-fsub) (emit-fmul* . emit-fmul) (emit-fdiv* . emit-fdiv) + (emit-uadd* . emit-uadd) + (emit-usub* . emit-usub) + (emit-umul* . emit-umul) (emit-logand* . emit-logand) (emit-logior* . emit-logior) (emit-logxor* . emit-logxor) From 672853657c3775bb822a53d65785c69c545201ab Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 20 Nov 2015 13:23:32 +0100 Subject: [PATCH 129/865] Slower range saturation in type inference * module/language/cps/types.scm (*max-size-t*): New definition. (type-entry-saturating-union): Saturate more slowly, first stopping at [0,*max-size-t*] then at [&range-min, &range-max] before saturating to [-inf.0, +inf.0]. This allows most offset phi variables to have their range inferred within the u64 range. --- module/language/cps/types.scm | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 41d4f562c..543f5504e 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -206,6 +206,15 @@ (define-compile-time-value &range-min (- #x8000000000000000)) (define-compile-time-value &range-max #xffffFFFFffffFFFF) +;; This is a hack that takes advantage of knowing that +;; most-positive-fixnum is the size of a word, but with two tag bits and +;; one sign bit. We also assume that the current common architectural +;; restriction of a maximum 48-bit address space means that we won't see +;; a size_t value above 2^48. +(define *max-size-t* + (min (+ (ash most-positive-fixnum 3) #b111) + (1- (ash 1 48)))) + (define-inlinable (make-unclamped-type-entry type min max) (vector type min max)) (define-inlinable (type-entry-type tentry) @@ -271,10 +280,18 @@ (logior (type-entry-type a) (type-entry-type b)) (let ((a-min (type-entry-min a)) (b-min (type-entry-min b))) - (if (< b-min a-min) -inf.0 a-min)) + (cond + ((not (< b-min a-min)) a-min) + ((> 0 b-min) 0) + ((> &range-min b-min) &range-min) + (else -inf.0))) (let ((a-max (type-entry-max a)) (b-max (type-entry-max b))) - (if (> b-max a-max) +inf.0 a-max)))))) + (cond + ((not (> b-max a-max)) a-max) + ((> *max-size-t* b-max) *max-size-t*) + ((> &range-max b-max) &range-max) + (else +inf.0))))))) (define (type-entry-intersection a b) (cond From d2808b16e5003282d53220158742421562f88924 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 20 Nov 2015 13:25:59 +0100 Subject: [PATCH 130/865] Better range inference for indexes of vector-ref, string-ref et al * module/language/cps/types.scm (vector-ref, vector-set!) (string-ref, string-set!, struct-ref, struct-set!) (define-bytevector-accessors, define-bytevector-uaccessors): Clamp range of object and index to be within the range of indices, with a maximum of *max-size-t*. --- module/language/cps/types.scm | 117 +++++++++++++++++----------------- 1 file changed, 59 insertions(+), 58 deletions(-) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 543f5504e..4fd5e569e 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -596,16 +596,16 @@ minimum, and maximum." (and (check-type v &vector 0 *max-vector-len*) (check-type idx &exact-integer 0 (1- (&min v))))) (define-type-inferrer (vector-ref v idx result) - (restrict! v &vector (1+ (&min idx)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max v))) + (restrict! v &vector (1+ (&min idx)) *max-vector-len*) + (restrict! idx &exact-integer 0 (1- (min (&max v) *max-vector-len*))) (define! result &all-types -inf.0 +inf.0)) (define-type-checker (vector-set! v idx val) (and (check-type v &vector 0 *max-vector-len*) (check-type idx &exact-integer 0 (1- (&min v))))) (define-type-inferrer (vector-set! v idx val) - (restrict! v &vector (1+ (&min idx)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max v)))) + (restrict! v &vector (1+ (&min idx)) *max-vector-len*) + (restrict! idx &exact-integer 0 (1- (min (&max v) *max-vector-len*)))) (define-type-aliases make-vector make-vector/immediate) (define-type-aliases vector-ref vector-ref/immediate) @@ -627,35 +627,35 @@ minimum, and maximum." ;; No type-checker for allocate-struct, as we can't currently check that ;; vt is actually a vtable. (define-type-inferrer (allocate-struct vt size result) - (restrict! vt &struct vtable-offset-user +inf.0) - (restrict! size &exact-integer 0 +inf.0) - (define! result &struct (max (&min size) 0) (&max size))) + (restrict! vt &struct vtable-offset-user *max-size-t*) + (restrict! size &exact-integer 0 *max-size-t*) + (define! result &struct (max (&min size) 0) (min (&max size) *max-size-t*))) (define-type-checker (struct-ref s idx) - (and (check-type s &struct 0 +inf.0) - (check-type idx &exact-integer 0 +inf.0) + (and (check-type s &struct 0 *max-size-t*) + (check-type idx &exact-integer 0 *max-size-t*) ;; FIXME: is the field readable? (< (&max idx) (&min s)))) (define-type-inferrer (struct-ref s idx result) - (restrict! s &struct (1+ (&min idx)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max s))) + (restrict! s &struct (1+ (&min idx)) *max-size-t*) + (restrict! idx &exact-integer 0 (1- (min (&max s) *max-size-t*))) (define! result &all-types -inf.0 +inf.0)) (define-type-checker (struct-set! s idx val) - (and (check-type s &struct 0 +inf.0) - (check-type idx &exact-integer 0 +inf.0) + (and (check-type s &struct 0 *max-size-t*) + (check-type idx &exact-integer 0 *max-size-t*) ;; FIXME: is the field writable? (< (&max idx) (&min s)))) (define-type-inferrer (struct-set! s idx val) - (restrict! s &struct (1+ (&min idx)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max s)))) + (restrict! s &struct (1+ (&min idx)) *max-size-t*) + (restrict! idx &exact-integer 0 (1- (min (&max s) *max-size-t*)))) (define-type-aliases allocate-struct allocate-struct/immediate) (define-type-aliases struct-ref struct-ref/immediate) (define-type-aliases struct-set! struct-set!/immediate) -(define-simple-type (struct-vtable (&struct 0 +inf.0)) - (&struct vtable-offset-user +inf.0)) +(define-simple-type (struct-vtable (&struct 0 *max-size-t*)) + (&struct vtable-offset-user *max-size-t*)) @@ -667,31 +667,31 @@ minimum, and maximum." (define *max-char* (1- (ash 1 24))) (define-type-checker (string-ref s idx) - (and (check-type s &string 0 +inf.0) - (check-type idx &exact-integer 0 +inf.0) + (and (check-type s &string 0 *max-size-t*) + (check-type idx &exact-integer 0 *max-size-t*) (< (&max idx) (&min s)))) (define-type-inferrer (string-ref s idx result) - (restrict! s &string (1+ (&min idx)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max s))) + (restrict! s &string (1+ (&min idx)) *max-size-t*) + (restrict! idx &exact-integer 0 (1- (min (&max s) *max-size-t*))) (define! result &char 0 *max-char*)) (define-type-checker (string-set! s idx val) - (and (check-type s &string 0 +inf.0) - (check-type idx &exact-integer 0 +inf.0) + (and (check-type s &string 0 *max-size-t*) + (check-type idx &exact-integer 0 *max-size-t*) (check-type val &char 0 *max-char*) (< (&max idx) (&min s)))) (define-type-inferrer (string-set! s idx val) - (restrict! s &string (1+ (&min idx)) +inf.0) - (restrict! idx &exact-integer 0 (1- (&max s))) + (restrict! s &string (1+ (&min idx)) *max-size-t*) + (restrict! idx &exact-integer 0 (1- (min (&max s) *max-size-t*))) (restrict! val &char 0 *max-char*)) (define-simple-type-checker (string-length &string)) (define-type-inferrer (string-length s result) - (restrict! s &string 0 +inf.0) - (define! result &exact-integer (max (&min s) 0) (&max s))) + (restrict! s &string 0 *max-size-t*) + (define! result &exact-integer (max (&min s) 0) (min (&max s) *max-size-t*))) -(define-simple-type (number->string &number) (&string 0 +inf.0)) -(define-simple-type (string->number (&string 0 +inf.0)) +(define-simple-type (number->string &number) (&string 0 *max-size-t*)) +(define-simple-type (string->number (&string 0 *max-size-t*)) ((logior &number &false) -inf.0 +inf.0)) @@ -713,10 +713,10 @@ minimum, and maximum." (define! result &flonum (&min f64) (&max f64))) (define-type-checker (scm->u64 scm) - (check-type scm &exact-integer 0 +inf.0)) + (check-type scm &exact-integer 0 #xffffffffffffffff)) (define-type-inferrer (scm->u64 scm result) - (restrict! scm &exact-integer 0 +inf.0) - (define! result &u64 (&min scm) (&max scm))) + (restrict! scm &exact-integer 0 #xffffffffffffffff) + (define! result &u64 (max (&min scm) 0) (min (&max scm) #xffffffffffffffff))) (define-type-checker (u64->scm u64) #t) @@ -732,28 +732,29 @@ minimum, and maximum." (define-simple-type-checker (bv-length &bytevector)) (define-type-inferrer (bv-length bv result) - (restrict! bv &bytevector 0 +inf.0) - (define! result &exact-integer (max (&min bv) 0) (&max bv))) + (restrict! bv &bytevector 0 *max-size-t*) + (define! result &exact-integer + (max (&min bv) 0) (min (&max bv) *max-size-t*))) -(define-syntax-rule (define-bytevector-accessors ref set type size min max) +(define-syntax-rule (define-bytevector-accessors ref set type size lo hi) (begin (define-type-checker (ref bv idx) - (and (check-type bv &bytevector 0 +inf.0) - (check-type idx &exact-integer 0 +inf.0) + (and (check-type bv &bytevector 0 *max-size-t*) + (check-type idx &exact-integer 0 *max-size-t*) (< (&max idx) (- (&min bv) size)))) (define-type-inferrer (ref bv idx result) - (restrict! bv &bytevector (+ (&min idx) size) +inf.0) - (restrict! idx &exact-integer 0 (- (&max bv) size)) - (define! result type min max)) + (restrict! bv &bytevector (+ (&min idx) size) *max-size-t*) + (restrict! idx &exact-integer 0 (- (min (&max bv) *max-size-t*) size)) + (define! result type lo hi)) (define-type-checker (set bv idx val) - (and (check-type bv &bytevector 0 +inf.0) - (check-type idx &exact-integer 0 +inf.0) - (check-type val type min max) + (and (check-type bv &bytevector 0 *max-size-t*) + (check-type idx &exact-integer 0 *max-size-t*) + (check-type val type lo hi) (< (&max idx) (- (&min bv) size)))) (define-type-inferrer (set! bv idx val) - (restrict! bv &bytevector (+ (&min idx) size) +inf.0) - (restrict! idx &exact-integer 0 (- (&max bv) size)) - (restrict! val type min max)))) + (restrict! bv &bytevector (+ (&min idx) size) *max-size-t*) + (restrict! idx &exact-integer 0 (- (min (&max bv) *max-size-t*) size)) + (restrict! val type lo hi)))) (define-syntax-rule (define-short-bytevector-accessors ref set size signed?) (define-bytevector-accessors ref set &exact-integer size @@ -774,25 +775,25 @@ minimum, and maximum." (define-bytevector-accessors bv-s64-ref bv-s64-set! &exact-integer 8 (- #x8000000000000000) #x7fffFFFFffffFFFF) -(define-syntax-rule (define-bytevector-uaccessors ref set type size min max) +(define-syntax-rule (define-bytevector-uaccessors ref set type size lo hi) (begin (define-type-checker (ref bv idx) - (and (check-type bv &bytevector 0 +inf.0) - (check-type idx &u64 0 +inf.0) + (and (check-type bv &bytevector 0 *max-size-t*) + (check-type idx &u64 0 *max-size-t*) (< (&max idx) (- (&min bv) size)))) (define-type-inferrer (ref bv idx result) - (restrict! bv &bytevector (+ (&min idx) size) +inf.0) - (restrict! idx &u64 0 (- (&max bv) size)) - (define! result type min max)) + (restrict! bv &bytevector (+ (&min idx) size) *max-size-t*) + (restrict! idx &u64 0 (- (min (&max bv) *max-size-t*) size)) + (define! result type lo hi)) (define-type-checker (set bv idx val) - (and (check-type bv &bytevector 0 +inf.0) - (check-type idx &u64 0 +inf.0) - (check-type val type min max) + (and (check-type bv &bytevector 0 *max-size-t*) + (check-type idx &u64 0 *max-size-t*) + (check-type val type lo hi) (< (&max idx) (- (&min bv) size)))) (define-type-inferrer (set! bv idx val) - (restrict! bv &bytevector (+ (&min idx) size) +inf.0) - (restrict! idx &exact-integer 0 (- (&max bv) size)) - (restrict! val type min max)))) + (restrict! bv &bytevector (+ (&min idx) size) *max-size-t*) + (restrict! idx &exact-integer 0 (- (min (&max bv) *max-size-t*) size)) + (restrict! val type lo hi)))) (define-bytevector-uaccessors bv-f32-ref bv-f32-set! &f64 4 -inf.0 +inf.0) (define-bytevector-uaccessors bv-f64-ref bv-f64-set! &f64 8 -inf.0 +inf.0) From e003466039da31cec9f8d4d7ea9dcb3805a5d670 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 20 Nov 2015 13:35:35 +0100 Subject: [PATCH 131/865] Specialize u64 arithmetic * module/language/cps/specialize-numbers.scm (specialize-operations): (specialize-u64-binop): Specialize u64 addition, subtraction, and multiplication. --- module/language/cps/specialize-numbers.scm | 67 ++++++++++++++++------ 1 file changed, 48 insertions(+), 19 deletions(-) diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm index 61c2b746f..8d6240f5f 100644 --- a/module/language/cps/specialize-numbers.scm +++ b/module/language/cps/specialize-numbers.scm @@ -81,8 +81,27 @@ ($continue kunbox-b src ($primcall 'scm->f64 (a))))))) +(define (specialize-u64-binop cps k src op a b) + (let ((uop (match op + ('add 'uadd) + ('sub 'usub) + ('mul 'umul)))) + (with-cps cps + (letv u64-a u64-b result) + (letk kbox ($kargs ('result) (result) + ($continue k src + ($primcall 'u64->scm (result))))) + (letk kop ($kargs ('u64-b) (u64-b) + ($continue kbox src + ($primcall uop (u64-a u64-b))))) + (letk kunbox-b ($kargs ('u64-a) (u64-a) + ($continue kop src + ($primcall 'scm->u64 (b))))) + (build-term + ($continue kunbox-b src + ($primcall 'scm->u64 (a))))))) + (define (specialize-u64-comparison cps kf kt src op a b) - (pk 'specialize cps kf kt src op a b) (let ((op (symbol-append 'u64- op))) (with-cps cps (letv u64-a u64-b) @@ -98,6 +117,13 @@ (define (specialize-operations cps) (define (visit-cont label cont cps types) + (define (operand-in-range? var &type &min &max) + (call-with-values (lambda () + (lookup-pre-type types label var)) + (lambda (type min max) + (and (eqv? type &type) (<= &min min max &max))))) + (define (u64-operand? var) + (operand-in-range? var &exact-integer 0 #xffffffffffffffff)) (match cont (($ $kfun) (values cps (infer-types cps label))) @@ -110,28 +136,31 @@ (lookup-post-type types label result 0)) (lambda (type min max) (values - (if (eqv? type &flonum) - (with-cps cps - (let$ body (specialize-f64-binop k src op a b)) - (setk label ($kargs names vars ,body))) - cps) + (cond + ((eqv? type &flonum) + (with-cps cps + (let$ body (specialize-f64-binop k src op a b)) + (setk label ($kargs names vars ,body)))) + ((and (eqv? type &exact-integer) + (<= 0 min max #xffffffffffffffff) + (u64-operand? a) (u64-operand? b) + (not (eq? op 'div))) + (with-cps cps + (let$ body (specialize-u64-binop k src op a b)) + (setk label ($kargs names vars ,body)))) + (else + cps)) types)))))) (($ $kargs names vars ($ $continue k src ($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) (a b))))) - (call-with-values (lambda () (lookup-pre-type types label a)) - (lambda (a-type a-min a-max) - (call-with-values (lambda () (lookup-pre-type types label b)) - (lambda (b-type b-min b-max) - (values - (if (and (eqv? a-type b-type &exact-integer) - (<= 0 a-min a-max #xffffffffffffffff) - (<= 0 b-min b-max #xffffffffffffffff)) - (with-cps cps - (let$ body (specialize-u64-comparison k kt src op a b)) - (setk label ($kargs names vars ,body))) - cps) - types)))))) + (values + (if (and (u64-operand? a) (u64-operand? b)) + (with-cps cps + (let$ body (specialize-u64-comparison k kt src op a b)) + (setk label ($kargs names vars ,body))) + cps) + types)) (_ (values cps types)))) (values (intmap-fold visit-cont cps cps #f))) From 8f18b71b7afcd475553f760f83af7d79fc34cf01 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 20 Nov 2015 14:03:32 +0100 Subject: [PATCH 132/865] Remove add1 and sub1 * libguile/vm-engine.c: Remove add1 and sub1 instructions. Will replace with add/immediate and sub/immediate. * module/language/tree-il/peval.scm (peval): If we reify a new , expand it. Removes 1- and similar primcalls. * module/language/tree-il/primitives.scm: Don't specialize (+ x 1) to 1+. (expand-primcall): New export, does a single primcall expansion. (expand-primitives): Use the new helper. * module/language/cps/effects-analysis.scm: * module/language/cps/primitives.scm: * module/language/cps/types.scm: * module/system/vm/assembler.scm: Remove support for add1 and sub1 CPS primitives. * test-suite/tests/peval.test ("partial evaluation"): Adapt tests that expect 1+/1- to expect +/-. --- libguile/vm-engine.c | 48 +----------------------- module/language/cps/effects-analysis.scm | 2 - module/language/cps/primitives.scm | 7 ++-- module/language/cps/types.scm | 8 ---- module/language/tree-il/peval.scm | 3 +- module/language/tree-il/primitives.scm | 40 +++++++++----------- module/system/vm/assembler.scm | 2 - test-suite/tests/peval.test | 8 ++-- 8 files changed, 30 insertions(+), 88 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index d615af1aa..80ab3afd8 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -2382,29 +2382,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, BINARY_INTEGER_OP (+, scm_sum); } - /* add1 dst:12 src:12 - * - * Add 1 to the value in SRC, and place the result in DST. - */ - VM_DEFINE_OP (87, add1, "add1", OP1 (X8_S12_S12) | OP_DST) - { - ARGS1 (x); - - /* Check for overflow. We must avoid overflow in the signed - addition below, even if X is not an inum. */ - if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) <= INUM_MAX - INUM_STEP)) - { - SCM result; - - /* Add 1 to the integer without untagging. */ - result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) + INUM_STEP); - - if (SCM_LIKELY (SCM_I_INUMP (result))) - RETURN (result); - } - - RETURN_EXP (scm_sum (x, SCM_I_MAKINUM (1))); - } + VM_DEFINE_OP (87, unused_87, NULL, NOP) /* sub dst:8 a:8 b:8 * @@ -2415,29 +2393,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, BINARY_INTEGER_OP (-, scm_difference); } - /* sub1 dst:12 src:12 - * - * Subtract 1 from SRC, and place the result in DST. - */ - VM_DEFINE_OP (89, sub1, "sub1", OP1 (X8_S12_S12) | OP_DST) - { - ARGS1 (x); - - /* Check for overflow. We must avoid overflow in the signed - subtraction below, even if X is not an inum. */ - if (SCM_LIKELY ((scm_t_signed_bits) SCM_UNPACK (x) >= INUM_MIN + INUM_STEP)) - { - SCM result; - - /* Substract 1 from the integer without untagging. */ - result = SCM_PACK ((scm_t_signed_bits) SCM_UNPACK (x) - INUM_STEP); - - if (SCM_LIKELY (SCM_I_INUMP (result))) - RETURN (result); - } - - RETURN_EXP (scm_difference (x, SCM_I_MAKINUM (1))); - } + VM_DEFINE_OP (89, unused_89, NULL, NOP) /* mul dst:8 a:8 b:8 * diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 9112c429b..21df42ccd 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -428,8 +428,6 @@ is or might be a read or a write to the same location as A." ((uadd . _)) ((usub . _)) ((umul . _)) - ((sub1 . _) &type-check) - ((add1 . _) &type-check) ((quo . _) &type-check) ((rem . _) &type-check) ((mod . _) &type-check) diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm index 3628b5cf7..d6488450d 100644 --- a/module/language/cps/primitives.scm +++ b/module/language/cps/primitives.scm @@ -34,9 +34,10 @@ )) (define *instruction-aliases* - '((+ . add) (1+ . add1) - (- . sub) (1- . sub1) - (* . mul) (/ . div) + '((+ . add) + (- . sub) + (* . mul) + (/ . div) (quotient . quo) (remainder . rem) (modulo . mod) (variable-ref . box-ref) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 4fd5e569e..1a0eebbe1 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -1061,14 +1061,6 @@ minimum, and maximum." (lambda (min max) (define! result &f64 min max))))) -(define-simple-type-checker (add1 &number)) -(define-type-inferrer (add1 a result) - (define-unary-result! a result (1+ (&min a)) (1+ (&max a)))) - -(define-simple-type-checker (sub1 &number)) -(define-type-inferrer (sub1 a result) - (define-unary-result! a result (1- (&min a)) (1- (&max a)))) - (define-type-checker (quo a b) (and (check-type a &exact-integer -inf.0 +inf.0) (check-type b &exact-integer -inf.0 +inf.0) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index fca849ec0..355d423dd 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -1357,7 +1357,8 @@ top-level bindings from ENV and return the resulting expression." (let revisit-proc ((proc (visit orig-proc 'operator))) (match proc (($ _ name) - (for-tail (make-primcall src name orig-args))) + (for-tail + (expand-primcall (make-primcall src name orig-args)))) (($ _ _ ($ _ req opt rest #f inits gensyms body #f)) ;; Simple case: no keyword arguments. diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 7bed7832c..57072d4d9 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -27,7 +27,7 @@ #:use-module (srfi srfi-4) #:use-module (srfi srfi-16) #:export (resolve-primitives add-interesting-primitive! - expand-primitives + expand-primcall expand-primitives effect-free-primitive? effect+exception-free-primitive? constructor-primitive? singly-valued-primitive? equality-primitive? @@ -313,16 +313,16 @@ (define *primitive-expand-table* (make-hash-table)) +(define (expand-primcall x) + (record-case x + (( src name args) + (let ((expand (hashq-ref *primitive-expand-table* name))) + (or (and expand (apply expand src args)) + x))) + (else x))) + (define (expand-primitives x) - (pre-order - (lambda (x) - (record-case x - (( src name args) - (let ((expand (hashq-ref *primitive-expand-table* name))) - (or (and expand (apply expand src args)) - x))) - (else x))) - x)) + (pre-order expand-primcall x)) ;;; I actually did spend about 10 minutes trying to redo this with ;;; syntax-rules. Patches appreciated. @@ -388,18 +388,16 @@ ;; FIXME: All the code that uses `const?' is redundant with `peval'. +(define-primitive-expander 1+ (x) + (+ x 1)) + +(define-primitive-expander 1- (x) + (- x 1)) + (define-primitive-expander + () 0 (x) (values x) - (x y) (if (and (const? y) (eqv? (const-exp y) 1)) - (1+ x) - (if (and (const? y) (eqv? (const-exp y) -1)) - (1- x) - (if (and (const? x) (eqv? (const-exp x) 1)) - (1+ y) - (if (and (const? x) (eqv? (const-exp x) -1)) - (1- y) - (+ x y))))) + (x y) (+ x y) (x y z ... last) (+ (+ x y . z) last)) (define-primitive-expander * @@ -409,9 +407,7 @@ (define-primitive-expander - (x) (- 0 x) - (x y) (if (and (const? y) (eqv? (const-exp y) 1)) - (1- x) - (- x y)) + (x y) (- x y) (x y z ... last) (- (- x y . z) last)) (define-primitive-expander / diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 76ae892a3..9dcd6dc79 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -129,9 +129,7 @@ (emit-set-car!* . emit-set-car!) (emit-set-cdr!* . emit-set-cdr!) (emit-add* . emit-add) - (emit-add1* . emit-add1) (emit-sub* . emit-sub) - (emit-sub1* . emit-sub1) (emit-mul* . emit-mul) (emit-div* . emit-div) (emit-quo* . emit-quo) diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test index 93988af14..547510311 100644 --- a/test-suite/tests/peval.test +++ b/test-suite/tests/peval.test @@ -534,7 +534,7 @@ ;; . (let ((fold (lambda (f g) (f (g top))))) (fold 1+ (lambda (x) x))) - (primcall 1+ (toplevel top))) + (primcall + (toplevel top) (const 1))) (pass-if-peval ;; Procedure not inlined when residual code contains recursive calls. @@ -557,7 +557,7 @@ (lambda () (lambda-case (((x2) #f #f #f () (_)) - (primcall 1- (lexical x2 _)))))))) + (primcall - (lexical x2 _) (const 1)))))))) (pass-if "inlined lambdas are alpha-renamed" ;; In this example, `make-adder' is inlined more than once; thus, @@ -788,8 +788,8 @@ (((x) #f #f #f () (_)) (if _ _ (call (lexical loop _) - (primcall 1- - (lexical x _)))))))) + (primcall - (lexical x _) + (const 1)))))))) (call (lexical loop _) (toplevel x)))) (pass-if-peval From bdfa1c1b424fc6d408c55e7db17cb3ed7117606a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 20 Nov 2015 14:52:35 +0100 Subject: [PATCH 133/865] Add tagged and untagged arithmetic ops with immediate operands * libguile/vm-engine.c (add/immediate, sub/immediate) (uadd/immediate, usub/immediate, umul/immediate): New instructions. * module/language/cps/compile-bytecode.scm (compile-function): * module/language/cps/slot-allocation.scm (compute-needs-slot): * module/language/cps/types.scm: * module/system/vm/assembler.scm (system): * module/language/cps/effects-analysis.scm: Support for new instructions. * module/language/cps/optimize.scm (optimize-first-order-cps): Move primcall specialization to the last step -- the only benefit of doing it earlier was easier reasoning about side effects, and we're already doing that in a more general way with (language cps types). * module/language/cps/specialize-primcalls.scm (specialize-primcalls): Specialize add and sub to add/immediate and sub/immediate, and specialize u64 addition as well. U64 specialization doesn't work now though because computing constant values doesn't work for U64s; oh well. --- libguile/vm-engine.c | 102 ++++++++++++++++++- module/language/cps/compile-bytecode.scm | 13 +++ module/language/cps/effects-analysis.scm | 5 + module/language/cps/optimize.scm | 4 +- module/language/cps/slot-allocation.scm | 7 +- module/language/cps/specialize-primcalls.scm | 31 ++++-- module/language/cps/types.scm | 5 + module/system/vm/assembler.scm | 5 + 8 files changed, 153 insertions(+), 19 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 80ab3afd8..2f3b3fd85 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -2382,7 +2382,29 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, BINARY_INTEGER_OP (+, scm_sum); } - VM_DEFINE_OP (87, unused_87, NULL, NOP) + /* add/immediate dst:8 src:8 imm:8 + * + * Add the unsigned 8-bit value IMM to the value from SRC, and place + * the result in DST. + */ + VM_DEFINE_OP (87, add_immediate, "add/immediate", OP1 (X8_S8_S8_C8) | OP_DST) + { + scm_t_uint8 dst, src, imm; + SCM x; + + UNPACK_8_8_8 (op, dst, src, imm); + x = SP_REF (src); + + if (SCM_LIKELY (SCM_I_INUMP (x))) + { + scm_t_signed_bits sum = SCM_I_INUM (x) + (scm_t_signed_bits) imm; + + if (SCM_LIKELY (SCM_POSFIXABLE (sum))) + RETURN (SCM_I_MAKINUM (sum)); + } + + RETURN_EXP (scm_sum (x, SCM_I_MAKINUM (imm))); + } /* sub dst:8 a:8 b:8 * @@ -2393,7 +2415,29 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, BINARY_INTEGER_OP (-, scm_difference); } - VM_DEFINE_OP (89, unused_89, NULL, NOP) + /* sub/immediate dst:8 src:8 imm:8 + * + * Subtract the unsigned 8-bit value IMM from the value in SRC, and + * place the result in DST. + */ + VM_DEFINE_OP (89, sub_immediate, "sub/immediate", OP1 (X8_S8_S8_C8) | OP_DST) + { + scm_t_uint8 dst, src, imm; + SCM x; + + UNPACK_8_8_8 (op, dst, src, imm); + x = SP_REF (src); + + if (SCM_LIKELY (SCM_I_INUMP (x))) + { + scm_t_signed_bits diff = SCM_I_INUM (x) - (scm_t_signed_bits) imm; + + if (SCM_LIKELY (SCM_NEGFIXABLE (diff))) + RETURN (SCM_I_MAKINUM (diff)); + } + + RETURN_EXP (scm_difference (x, SCM_I_MAKINUM (imm))); + } /* mul dst:8 a:8 b:8 * @@ -3400,9 +3444,57 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (1); } - VM_DEFINE_OP (152, unused_152, NULL, NOP) - VM_DEFINE_OP (153, unused_153, NULL, NOP) - VM_DEFINE_OP (154, unused_154, NULL, NOP) + /* uadd/immediate dst:8 src:8 imm:8 + * + * Add the unsigned 64-bit value from SRC with the unsigned 8-bit + * value IMM and place the raw unsigned 64-bit result in DST. + * Overflow will wrap around. + */ + VM_DEFINE_OP (152, uadd_immediate, "uadd/immediate", OP1 (X8_S8_S8_C8) | OP_DST) + { + scm_t_uint8 dst, src, imm; + scm_t_uint64 x; + + UNPACK_8_8_8 (op, dst, src, imm); + x = SP_REF_U64 (src); + SP_SET_U64 (dst, x + (scm_t_uint64) imm); + NEXT (1); + } + + /* usub/immediate dst:8 src:8 imm:8 + * + * Subtract the unsigned 8-bit value IMM from the unsigned 64-bit + * value in SRC and place the raw unsigned 64-bit result in DST. + * Overflow will wrap around. + */ + VM_DEFINE_OP (153, usub_immediate, "usub/immediate", OP1 (X8_S8_S8_C8) | OP_DST) + { + scm_t_uint8 dst, src, imm; + scm_t_uint64 x; + + UNPACK_8_8_8 (op, dst, src, imm); + x = SP_REF_U64 (src); + SP_SET_U64 (dst, x - (scm_t_uint64) imm); + NEXT (1); + } + + /* umul/immediate dst:8 src:8 imm:8 + * + * Multiply the unsigned 64-bit value from SRC by the unsigned 8-bit + * value IMM and place the raw unsigned 64-bit result in DST. + * Overflow will wrap around. + */ + VM_DEFINE_OP (154, umul_immediate, "umul/immediate", OP1 (X8_S8_S8_C8) | OP_DST) + { + scm_t_uint8 dst, src, imm; + scm_t_uint64 x; + + UNPACK_8_8_8 (op, dst, src, imm); + x = SP_REF_U64 (src); + SP_SET_U64 (dst, x * (scm_t_uint64) imm); + NEXT (1); + } + VM_DEFINE_OP (155, unused_155, NULL, NOP) VM_DEFINE_OP (156, unused_156, NULL, NOP) VM_DEFINE_OP (157, unused_157, NULL, NOP) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 2a6370c25..9dfee572a 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -179,6 +179,19 @@ (($ $primcall 'struct-ref/immediate (struct n)) (emit-struct-ref/immediate asm (from-sp dst) (from-sp (slot struct)) (constant n))) + (($ $primcall 'add/immediate (x y)) + (emit-add/immediate asm (from-sp dst) (from-sp (slot x)) (constant y))) + (($ $primcall 'sub/immediate (x y)) + (emit-sub/immediate asm (from-sp dst) (from-sp (slot x)) (constant y))) + (($ $primcall 'uadd/immediate (x y)) + (emit-uadd/immediate asm (from-sp dst) (from-sp (slot x)) + (constant y))) + (($ $primcall 'usub/immediate (x y)) + (emit-usub/immediate asm (from-sp dst) (from-sp (slot x)) + (constant y))) + (($ $primcall 'umul/immediate (x y)) + (emit-umul/immediate asm (from-sp dst) (from-sp (slot x)) + (constant y))) (($ $primcall 'builtin-ref (name)) (emit-builtin-ref asm (from-sp dst) (constant name))) (($ $primcall 'scm->f64 (src)) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 21df42ccd..43ec1b037 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -418,8 +418,10 @@ is or might be a read or a write to the same location as A." ((u64->= . _)) ((zero? . _) &type-check) ((add . _) &type-check) + ((add/immediate . _) &type-check) ((mul . _) &type-check) ((sub . _) &type-check) + ((sub/immediate . _) &type-check) ((div . _) &type-check) ((fadd . _)) ((fsub . _)) @@ -428,6 +430,9 @@ is or might be a read or a write to the same location as A." ((uadd . _)) ((usub . _)) ((umul . _)) + ((uadd/immediate . _)) + ((usub/immediate . _)) + ((umul/immediate . _)) ((quo . _) &type-check) ((rem . _) &type-check) ((mod . _) &type-check) diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm index 7d4dc2fe2..707b68d4e 100644 --- a/module/language/cps/optimize.scm +++ b/module/language/cps/optimize.scm @@ -94,7 +94,6 @@ (simplify #:simplify? #t) (contify #:contify? #t) (inline-constructors #:inline-constructors? #t) - (specialize-primcalls #:specialize-primcalls? #t) (elide-values #:elide-values? #t) (prune-bailouts #:prune-bailouts? #t) (peel-loops #:peel-loops? #t) @@ -110,7 +109,8 @@ (eliminate-common-subexpressions #:cse? #t) (eliminate-dead-code #:eliminate-dead-code? #t) (rotate-loops #:rotate-loops? #t) - (simplify #:simplify? #t)) + (simplify #:simplify? #t) + (specialize-primcalls #:specialize-primcalls? #t)) (define (cps-default-optimization-options) (list ;; #:split-rec? #t diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index e8519f0fa..d41013f28 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -347,6 +347,10 @@ the definitions that are live before and after LABEL, as intsets." (defs+ s)) (($ $primcall 'struct-set!/immediate (s n x)) (defs+* (intset s x))) + (($ $primcall (or 'add/immediate 'sub/immediate + 'uadd/immediate 'usub/immediate 'umul/immediate) + (x y)) + (defs+ x)) (($ $primcall 'builtin-ref (idx)) defs) (_ @@ -794,7 +798,8 @@ are comparable with eqv?. A tmp slot may be used." 'fadd 'fsub 'fmul 'fdiv)) (intmap-add representations var 'f64)) (($ $primcall (or 'scm->u64 'bv-length - 'uadd 'usub 'umul)) + 'uadd 'usub 'umul + 'uadd/immediate 'usub/immediate 'umul/immediate)) (intmap-add representations var 'u64)) (_ (intmap-add representations var 'scm)))) diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm index c15fbdb3b..0c234eed3 100644 --- a/module/language/cps/specialize-primcalls.scm +++ b/module/language/cps/specialize-primcalls.scm @@ -33,27 +33,36 @@ (define (specialize-primcalls conts) (let ((constants (compute-constant-values conts))) - (define (immediate-u8? var) + (define (u8? var) (let ((val (intmap-ref constants var (lambda (_) #f)))) (and (exact-integer? val) (<= 0 val 255)))) (define (specialize-primcall name args) + (define (rename name) + (build-exp ($primcall name args))) (match (cons name args) - (('make-vector (? immediate-u8? n) init) 'make-vector/immediate) - (('vector-ref v (? immediate-u8? n)) 'vector-ref/immediate) - (('vector-set! v (? immediate-u8? n) x) 'vector-set!/immediate) - (('allocate-struct v (? immediate-u8? n)) 'allocate-struct/immediate) - (('struct-ref s (? immediate-u8? n)) 'struct-ref/immediate) - (('struct-set! s (? immediate-u8? n) x) 'struct-set!/immediate) + (('make-vector (? u8? n) init) (rename 'make-vector/immediate)) + (('vector-ref v (? u8? n)) (rename 'vector-ref/immediate)) + (('vector-set! v (? u8? n) x) (rename 'vector-set!/immediate)) + (('allocate-struct v (? u8? n)) (rename 'allocate-struct/immediate)) + (('struct-ref s (? u8? n)) (rename 'struct-ref/immediate)) + (('struct-set! s (? u8? n) x) (rename 'struct-set!/immediate)) + (('add x (? u8? y)) (build-exp ($primcall 'add/immediate (x y)))) + (('add (? u8? x) y) (build-exp ($primcall 'add/immediate (y x)))) + (('sub x (? u8? y)) (build-exp ($primcall 'sub/immediate (x y)))) + (('uadd x (? u8? y)) (build-exp ($primcall 'uadd/immediate (x y)))) + (('uadd (? u8? x) y) (build-exp ($primcall 'uadd/immediate (y x)))) + (('usub x (? u8? y)) (build-exp ($primcall 'usub/immediate (x y)))) + (('umul x (? u8? y)) (build-exp ($primcall 'umul/immediate (x y)))) + (('umul (? u8? x) y) (build-exp ($primcall 'umul/immediate (y x)))) (_ #f))) (intmap-map (lambda (label cont) (match cont (($ $kargs names vars ($ $continue k src ($ $primcall name args))) - (let ((name* (specialize-primcall name args))) - (if name* + (let ((exp* (specialize-primcall name args))) + (if exp* (build-cont - ($kargs names vars - ($continue k src ($primcall name* args)))) + ($kargs names vars ($continue k src ,exp*))) cont))) (_ cont))) conts))) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 1a0eebbe1..6928589da 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -933,6 +933,7 @@ minimum, and maximum." min* max*)))))) (define-simple-type-checker (add &number &number)) +(define-type-aliases add add/immediate) (define-type-checker (fadd a b) #t) (define-type-checker (uadd a b) #t) (define-type-inferrer (add a b result) @@ -949,8 +950,10 @@ minimum, and maximum." (if (<= max #xffffffffffffffff) (define! result &u64 (+ (&min a) (&min b)) max) (define! result &u64 0 #xffffffffffffffff)))) +(define-type-aliases uadd uadd/immediate) (define-simple-type-checker (sub &number &number)) +(define-type-aliases sub sub/immediate) (define-type-checker (fsub a b) #t) (define-type-checker (usub a b) #t) (define-type-inferrer (sub a b result) @@ -967,6 +970,7 @@ minimum, and maximum." (if (< min 0) (define! result &u64 0 #xffffffffffffffff) (define! result &u64 min (- (&max a) (&min b)))))) +(define-type-aliases usub usub/immediate) (define-simple-type-checker (mul &number &number)) (define-type-checker (fmul a b) #t) @@ -1019,6 +1023,7 @@ minimum, and maximum." (if (<= max #xffffffffffffffff) (define! result &u64 (* (&min a) (&min b)) max) (define! result &u64 0 #xffffffffffffffff)))) +(define-type-aliases umul umul/immediate) (define-type-checker (div a b) (and (check-type a &number -inf.0 +inf.0) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 9dcd6dc79..07333112f 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -129,7 +129,9 @@ (emit-set-car!* . emit-set-car!) (emit-set-cdr!* . emit-set-cdr!) (emit-add* . emit-add) + (emit-add/immediate* . emit-add/immediate) (emit-sub* . emit-sub) + (emit-sub/immediate* . emit-sub/immediate) (emit-mul* . emit-mul) (emit-div* . emit-div) (emit-quo* . emit-quo) @@ -143,6 +145,9 @@ (emit-uadd* . emit-uadd) (emit-usub* . emit-usub) (emit-umul* . emit-umul) + (emit-uadd/immediate* . emit-uadd/immediate) + (emit-usub/immediate* . emit-usub/immediate) + (emit-umul/immediate* . emit-umul/immediate) (emit-logand* . emit-logand) (emit-logior* . emit-logior) (emit-logxor* . emit-logxor) From f34688ad25c8e4cb1ebc97734f255d36518d763f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 20 Nov 2015 16:14:32 +0100 Subject: [PATCH 134/865] New instructions load-f64, load-u64 * libguile/instructions.c (FOR_EACH_INSTRUCTION_WORD_TYPE): Add word types for immediate f64 and u64 values. (TYPE_WIDTH): Bump up by a bit, now that we have 32 word types. (NOP, parse_instruction): Use 64-bit meta type. * libguile/vm-engine.c (load-f64, load-u64): New instructions. * module/language/bytecode.scm (compute-instruction-arity): Add parser for new instruction word types. * module/language/cps/compile-bytecode.scm (compile-function): Add special-cased assemblers for new instructions, and also for scm->u64 and u64->scm which I missed before. * module/language/cps/effects-analysis.scm (load-f64, load-u64): New instructions. * module/language/cps/slot-allocation.scm (compute-needs-slot): load-f64 and load-u64 don't need slots. (compute-var-representations): Update for new instructions. * module/language/cps/specialize-primcalls.scm (specialize-primcalls): Specialize scm->f64 and scm->u64 to make-f64 and make-u64. * module/language/cps/types.scm (load-f64, load-u64): Wire up to type inference, though currently type inference only runs before specialization. * module/language/cps/utils.scm (compute-defining-expressions): For some reason I don't understand, it's possible to see two definitions that are equal but not equal? here. Allow for now. (compute-constant-values): Punch through type conversions to get constant u64/f64 values. * module/system/vm/assembler.scm (assembler): Support for new word types. Export the new assemblers. --- libguile/instructions.c | 14 +++--- libguile/vm-engine.c | 37 +++++++++++++++- module/language/bytecode.scm | 4 +- module/language/cps/compile-bytecode.scm | 8 ++++ module/language/cps/effects-analysis.scm | 2 + module/language/cps/slot-allocation.scm | 7 ++- module/language/cps/specialize-primcalls.scm | 8 ++++ module/language/cps/types.scm | 2 + module/language/cps/utils.scm | 45 +++++++++++++++----- module/system/vm/assembler.scm | 13 ++++++ module/system/vm/disassembler.scm | 2 +- 11 files changed, 119 insertions(+), 23 deletions(-) diff --git a/libguile/instructions.c b/libguile/instructions.c index 003fd5425..49b07d1dc 100644 --- a/libguile/instructions.c +++ b/libguile/instructions.c @@ -50,6 +50,10 @@ SCM_SYMBOL (sym_bang, "!"); M(I32) /* Immediate. */ \ M(A32) /* Immediate, high bits. */ \ M(B32) /* Immediate, low bits. */ \ + M(AF32) /* Immediate double, high bits. */ \ + M(BF32) /* Immediate double, low bits. */ \ + M(AU32) /* Immediate uint64, high bits. */ \ + M(BU32) /* Immediate uint64, low bits. */ \ M(N32) /* Non-immediate. */ \ M(R32) /* Scheme value (indirected). */ \ M(L32) /* Label. */ \ @@ -61,7 +65,7 @@ SCM_SYMBOL (sym_bang, "!"); M(B1_X7_F24) \ M(B1_X31) -#define TYPE_WIDTH 5 +#define TYPE_WIDTH 6 enum word_type { @@ -82,14 +86,14 @@ static SCM word_type_symbols[] = /* The VM_DEFINE_OP macro uses a CPP-based DSL to describe what kinds of arguments each instruction takes. This piece of code is the only bit that actually interprets that language. These macro definitions - encode the operand types into bits in a 32-bit integer. + encode the operand types into bits in a 64-bit integer. (instruction-list) parses those encoded values into lists of symbols, - one for each 32-bit word that the operator takes. This list is used + one for each 64-bit word that the operator takes. This list is used by Scheme to generate assemblers and disassemblers for the instructions. */ -#define NOP SCM_T_UINT32_MAX +#define NOP SCM_T_UINT64_MAX #define OP1(type0) \ (OP (0, type0)) #define OP2(type0, type1) \ @@ -113,7 +117,7 @@ static SCM word_type_symbols[] = /* Scheme interface */ static SCM -parse_instruction (scm_t_uint8 opcode, const char *name, scm_t_uint32 meta) +parse_instruction (scm_t_uint8 opcode, const char *name, scm_t_uint64 meta) { SCM tail = SCM_EOL; int len; diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 2f3b3fd85..d15fe3228 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -3495,8 +3495,41 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (1); } - VM_DEFINE_OP (155, unused_155, NULL, NOP) - VM_DEFINE_OP (156, unused_156, NULL, NOP) + /* load-f64 dst:24 high-bits:32 low-bits:32 + * + * Make a double-precision floating-point value with HIGH-BITS and + * LOW-BITS. + */ + VM_DEFINE_OP (155, load_f64, "load-f64", OP3 (X8_S24, AF32, BF32) | OP_DST) + { + scm_t_uint32 dst; + scm_t_uint64 val; + + UNPACK_24 (op, dst); + val = ip[1]; + val <<= 32; + val |= ip[2]; + SP_SET_U64 (dst, val); + NEXT (3); + } + + /* load-u64 dst:24 high-bits:32 low-bits:32 + * + * Make an unsigned 64-bit integer with HIGH-BITS and LOW-BITS. + */ + VM_DEFINE_OP (156, load_u64, "load-u64", OP3 (X8_S24, AU32, BU32) | OP_DST) + { + scm_t_uint32 dst; + scm_t_uint64 val; + + UNPACK_24 (op, dst); + val = ip[1]; + val <<= 32; + val |= ip[2]; + SP_SET_U64 (dst, val); + NEXT (3); + } + VM_DEFINE_OP (157, unused_157, NULL, NOP) VM_DEFINE_OP (158, unused_158, NULL, NOP) VM_DEFINE_OP (159, unused_159, NULL, NOP) diff --git a/module/language/bytecode.scm b/module/language/bytecode.scm index 089bf9e7e..fb7ef7348 100644 --- a/module/language/bytecode.scm +++ b/module/language/bytecode.scm @@ -51,8 +51,8 @@ (case word ((C32) 1) ((I32) 1) - ((A32) 1) - ((B32) 0) + ((A32 AU32 AF32) 1) + ((B32 BF32 BU32) 0) ((N32) 1) ((R32) 1) ((L32) 1) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 9dfee572a..615ae86f7 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -196,8 +196,16 @@ (emit-builtin-ref asm (from-sp dst) (constant name))) (($ $primcall 'scm->f64 (src)) (emit-scm->f64 asm (from-sp dst) (from-sp (slot src)))) + (($ $primcall 'load-f64 (src)) + (emit-load-f64 asm (from-sp dst) (constant src))) (($ $primcall 'f64->scm (src)) (emit-f64->scm asm (from-sp dst) (from-sp (slot src)))) + (($ $primcall 'scm->u64 (src)) + (emit-scm->u64 asm (from-sp dst) (from-sp (slot src)))) + (($ $primcall 'load-u64 (src)) + (emit-load-u64 asm (from-sp dst) (constant src))) + (($ $primcall 'u64->scm (src)) + (emit-u64->scm asm (from-sp dst) (from-sp (slot src)))) (($ $primcall 'bv-length (bv)) (emit-bv-length asm (from-sp dst) (from-sp (slot bv)))) (($ $primcall 'bv-u8-ref (bv idx)) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 43ec1b037..a53800c85 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -354,8 +354,10 @@ is or might be a read or a write to the same location as A." ;; Unboxed floats and integers. (define-primitive-effects ((scm->f64 _) &type-check) + ((load-f64 _)) ((f64->scm _)) ((scm->u64 _) &type-check) + ((load-u64 _)) ((u64->scm _))) ;; Bytevectors. diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index d41013f28..1edf703d8 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -323,6 +323,8 @@ the definitions that are live before and after LABEL, as intsets." (match exp (($ $const) empty-intset) + (($ $primcall (or 'load-f64 'load-u64) (val)) + empty-intset) (($ $primcall 'free-ref (closure slot)) (defs+ closure)) (($ $primcall 'free-set! (closure slot value)) @@ -794,10 +796,11 @@ are comparable with eqv?. A tmp slot may be used." (($ $values (arg)) (intmap-add representations var (intmap-ref representations arg))) - (($ $primcall (or 'scm->f64 'bv-f32-ref 'bv-f64-ref + (($ $primcall (or 'scm->f64 'load-f64 + 'bv-f32-ref 'bv-f64-ref 'fadd 'fsub 'fmul 'fdiv)) (intmap-add representations var 'f64)) - (($ $primcall (or 'scm->u64 'bv-length + (($ $primcall (or 'scm->u64 'load-u64 'bv-length 'uadd 'usub 'umul 'uadd/immediate 'usub/immediate 'umul/immediate)) (intmap-add representations var 'u64)) diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm index 0c234eed3..1df0b8eef 100644 --- a/module/language/cps/specialize-primcalls.scm +++ b/module/language/cps/specialize-primcalls.scm @@ -36,6 +36,12 @@ (define (u8? var) (let ((val (intmap-ref constants var (lambda (_) #f)))) (and (exact-integer? val) (<= 0 val 255)))) + (define (u64? var) + (let ((val (intmap-ref constants var (lambda (_) #f)))) + (and (exact-integer? val) (<= 0 val #xffffFFFFffffFFFF)))) + (define (f64? var) + (let ((val (intmap-ref constants var (lambda (_) #f)))) + (and (number? val) (inexact? val) (real? val)))) (define (specialize-primcall name args) (define (rename name) (build-exp ($primcall name args))) @@ -54,6 +60,8 @@ (('usub x (? u8? y)) (build-exp ($primcall 'usub/immediate (x y)))) (('umul x (? u8? y)) (build-exp ($primcall 'umul/immediate (x y)))) (('umul (? u8? x) y) (build-exp ($primcall 'umul/immediate (y x)))) + (('scm->f64 (? f64?)) (rename 'load-f64)) + (('scm->u64 (? u64?)) (rename 'load-u64)) (_ #f))) (intmap-map (lambda (label cont) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 6928589da..f5423658f 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -706,6 +706,7 @@ minimum, and maximum." (define-type-inferrer (scm->f64 scm result) (restrict! scm &real -inf.0 +inf.0) (define! result &f64 (&min scm) (&max scm))) +(define-type-aliases scm->f64 load-f64) (define-type-checker (f64->scm f64) #t) @@ -717,6 +718,7 @@ minimum, and maximum." (define-type-inferrer (scm->u64 scm result) (restrict! scm &exact-integer 0 #xffffffffffffffff) (define! result &u64 (max (&min scm) 0) (min (&max scm) #xffffffffffffffff))) +(define-type-aliases scm->u64 load-u64) (define-type-checker (u64->scm u64) #t) diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm index fcbda9e76..902860cee 100644 --- a/module/language/cps/utils.scm +++ b/module/language/cps/utils.scm @@ -182,9 +182,11 @@ disjoint, an error will be signalled." (define (compute-defining-expressions conts) (define (meet-defining-expressions old new) - ;; If there are multiple definitions, punt and - ;; record #f. - #f) + ;; If there are multiple definitions and they are different, punt + ;; and record #f. + (if (equal? old new) + old + #f)) (persistent-intmap (intmap-fold (lambda (label cont defs) (match cont @@ -198,14 +200,35 @@ disjoint, an error will be signalled." empty-intmap))) (define (compute-constant-values conts) - (persistent-intmap - (intmap-fold (lambda (var exp out) - (match exp - (($ $const val) - (intmap-add! out var val)) - (_ out))) - (compute-defining-expressions conts) - empty-intmap))) + (let ((defs (compute-defining-expressions conts))) + (persistent-intmap + (intmap-fold + (lambda (var exp out) + (match exp + (($ $primcall (or 'load-f64 'load-u64) (val)) + (intmap-add! out var (intmap-ref out val))) + ;; Punch through type conversions to allow uadd to specialize + ;; to uadd/immediate. + (($ $primcall 'scm->f64 (val)) + (let ((f64 (intmap-ref out val (lambda (_) #f)))) + (if (and f64 (number? f64) (inexact? f64) (real? f64)) + (intmap-add! out var f64) + out))) + (($ $primcall 'scm->u64 (val)) + (let ((u64 (intmap-ref out val (lambda (_) #f)))) + (if (and u64 (number? u64) (exact-integer? u64) + (<= 0 u64 #xffffFFFFffffFFFF)) + (intmap-add! out var u64) + out))) + (_ out))) + defs + (intmap-fold (lambda (var exp out) + (match exp + (($ $const val) + (intmap-add! out var val)) + (_ out))) + defs + empty-intmap))))) (define (compute-function-body conts kfun) (persistent-intset diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 07333112f..bbd4e5d3a 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -168,7 +168,11 @@ (emit-class-of* . emit-class-of) emit-make-array (emit-scm->f64* . emit-scm->f64) + emit-load-f64 (emit-f64->scm* . emit-f64->scm) + (emit-scm->u64* . emit-scm->u64) + emit-load-u64 + (emit-u64->scm* . emit-u64->scm) (emit-bv-length* . emit-bv-length) (emit-bv-u8-ref* . emit-bv-u8-ref) (emit-bv-s8-ref* . emit-bv-s8-ref) @@ -568,7 +572,16 @@ later by the linker." (error "make-long-immediate unavailable for this target")) (emit asm (ash (object-address imm) -32)) (emit asm (logand (object-address imm) (1- (ash 1 32))))) + ((AF32 f64) + (let ((u64 (u64vector-ref (f64vector f64) 0))) + (emit asm (ash u64 -32)) + (emit asm (logand u64 (1- (ash 1 32)))))) + ((AU32 u64) + (emit asm (ash u64 -32)) + (emit asm (logand u64 (1- (ash 1 32))))) ((B32)) + ((BU32)) + ((BF32)) ((N32 label) (record-far-label-reference asm label) (emit asm 0)) diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index b0712540c..794caa759 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -108,7 +108,7 @@ (define (parse-tail-word word type) (with-syntax ((word word)) (case type - ((C32 I32 A32 B32) + ((C32 I32 A32 B32 AU32 BU32 AF32 BF32) #'(word)) ((N32 R32 L32 LO32) #'((unpack-s32 word))) From 8bf77f7192dd319cf5391639310abb35b9e627d7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 21 Nov 2015 10:32:33 +0100 Subject: [PATCH 135/865] Add support for unboxed s64 values * libguile/frames.c (enum stack_item_representation): (scm_to_stack_item_representation): (scm_frame_local_ref, scm_frame_local_set_x): Support for S64 representations. * libguile/frames.h (union scm_vm_stack_element): Add signed 64-bit integer field. * libguile/vm-engine.c (scm->s64, s64->scm, load-s64): New instructions. * module/language/cps/compile-bytecode.scm (compile-function): * module/language/cps/cse.scm (compute-equivalent-subexpressions): * module/language/cps/effects-analysis.scm: * module/language/cps/slot-allocation.scm (compute-var-representations) (compute-needs-slot, allocate-slots): * module/language/cps/utils.scm (compute-constant-values): * module/language/cps/specialize-primcalls.scm (specialize-primcalls): Add support for new primcalls. * module/language/cps/types.scm (&s64): New type. (&s64-min, &s64-max, &u64-max): New convenience definitions. (&range-min, &range-max): Use &s64-min and &u64-max names. (scm->s64, load-s64, s64->scm): Add support for new primcalls. * module/system/vm/assembler.scm (emit-scm->s64, emit-s64->scm) (emit-load-s64): New exports. * module/system/vm/assembler.scm (write-arities): Support for s64 slots. * module/system/vm/debug.scm (arity-definitions): Support for s64 slots. --- libguile/frames.c | 10 +++- libguile/frames.h | 1 + libguile/vm-engine.c | 49 ++++++++++++++++++-- module/language/cps/compile-bytecode.scm | 6 +++ module/language/cps/cse.scm | 8 ++++ module/language/cps/effects-analysis.scm | 5 +- module/language/cps/slot-allocation.scm | 10 ++-- module/language/cps/specialize-primcalls.scm | 1 + module/language/cps/types.scm | 28 +++++++++-- module/language/cps/utils.scm | 8 +++- module/system/vm/assembler.scm | 4 ++ module/system/vm/debug.scm | 1 + 12 files changed, 116 insertions(+), 15 deletions(-) diff --git a/libguile/frames.c b/libguile/frames.c index e70b25212..e1d7cf872 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -242,7 +242,8 @@ enum stack_item_representation { STACK_ITEM_SCM = 0, STACK_ITEM_F64 = 1, - STACK_ITEM_U64 = 2 + STACK_ITEM_U64 = 2, + STACK_ITEM_S64 = 3 }; static enum stack_item_representation @@ -254,6 +255,8 @@ scm_to_stack_item_representation (SCM x, const char *subr, int pos) return STACK_ITEM_F64; if (scm_is_eq (x, scm_from_latin1_symbol ("u64"))) return STACK_ITEM_U64; + if (scm_is_eq (x, scm_from_latin1_symbol ("s64"))) + return STACK_ITEM_S64; scm_wrong_type_arg (subr, pos, x); return 0; /* Not reached. */ @@ -286,6 +289,8 @@ SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 3, 0, 0, return scm_from_double (item->as_f64); case STACK_ITEM_U64: return scm_from_uint64 (item->as_u64); + case STACK_ITEM_S64: + return scm_from_int64 (item->as_s64); default: abort(); } @@ -326,6 +331,9 @@ SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 4, 0, 0, case STACK_ITEM_U64: item->as_u64 = scm_to_uint64 (val); break; + case STACK_ITEM_S64: + item->as_s64 = scm_to_int64 (val); + break; default: abort(); } diff --git a/libguile/frames.h b/libguile/frames.h index 2ece0c893..5aa5499ba 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -93,6 +93,7 @@ union scm_vm_stack_element SCM as_scm; double as_f64; scm_t_uint64 as_u64; + scm_t_int64 as_s64; /* For GC purposes. */ void *as_ptr; diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index d15fe3228..b6d656b4e 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -257,6 +257,9 @@ #define SP_REF_U64(i) (sp[i].as_u64) #define SP_SET_U64(i,o) (sp[i].as_u64 = o) +#define SP_REF_S64(i) (sp[i].as_s64) +#define SP_SET_S64(i,o) (sp[i].as_s64 = o) + #define VARIABLE_REF(v) SCM_VARIABLE_REF (v) #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o) #define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED)) @@ -3530,9 +3533,49 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (3); } - VM_DEFINE_OP (157, unused_157, NULL, NOP) - VM_DEFINE_OP (158, unused_158, NULL, NOP) - VM_DEFINE_OP (159, unused_159, NULL, NOP) + /* scm->s64 dst:12 src:12 + * + * Unpack a signed 64-bit integer from SRC and place it in DST. + */ + VM_DEFINE_OP (157, scm_to_s64, "scm->s64", OP1 (X8_S12_S12) | OP_DST) + { + scm_t_uint16 dst, src; + UNPACK_12_12 (op, dst, src); + SYNC_IP (); + SP_SET_S64 (dst, scm_to_int64 (SP_REF (src))); + NEXT (1); + } + + /* s64->scm dst:12 src:12 + * + * Pack an signed 64-bit integer into a SCM value. + */ + VM_DEFINE_OP (158, s64_to_scm, "s64->scm", OP1 (X8_S12_S12) | OP_DST) + { + scm_t_uint16 dst, src; + UNPACK_12_12 (op, dst, src); + SYNC_IP (); + SP_SET (dst, scm_from_int64 (SP_REF_S64 (src))); + NEXT (1); + } + + /* load-s64 dst:24 high-bits:32 low-bits:32 + * + * Make an unsigned 64-bit integer with HIGH-BITS and LOW-BITS. + */ + VM_DEFINE_OP (159, load_s64, "load-s64", OP3 (X8_S24, AS32, BS32) | OP_DST) + { + scm_t_uint32 dst; + scm_t_uint64 val; + + UNPACK_24 (op, dst); + val = ip[1]; + val <<= 32; + val |= ip[2]; + SP_SET_U64 (dst, val); + NEXT (3); + } + VM_DEFINE_OP (160, unused_160, NULL, NOP) VM_DEFINE_OP (161, unused_161, NULL, NOP) VM_DEFINE_OP (162, unused_162, NULL, NOP) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 615ae86f7..ad7d8877b 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -206,6 +206,12 @@ (emit-load-u64 asm (from-sp dst) (constant src))) (($ $primcall 'u64->scm (src)) (emit-u64->scm asm (from-sp dst) (from-sp (slot src)))) + (($ $primcall 'scm->s64 (src)) + (emit-scm->s64 asm (from-sp dst) (from-sp (slot src)))) + (($ $primcall 'load-s64 (src)) + (emit-load-s64 asm (from-sp dst) (constant src))) + (($ $primcall 's64->scm (src)) + (emit-s64->scm asm (from-sp dst) (from-sp (slot src)))) (($ $primcall 'bv-length (bv)) (emit-bv-length asm (from-sp dst) (from-sp (slot bv)))) (($ $primcall 'bv-u8-ref (bv idx)) diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index ad554faa0..c8a5ad30c 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -315,6 +315,14 @@ false. It could be that both true and false proofs are available." (match defs ((scm) (add-def! `(primcall scm->u64 ,scm) u64)))) + (('primcall 'scm->s64 scm) + (match defs + ((s64) + (add-def! `(primcall s64->scm ,s64) scm)))) + (('primcall 's64->scm s64) + (match defs + ((scm) + (add-def! `(primcall scm->s64 ,scm) s64)))) (_ #t)))) (define (visit-label label equiv-labels var-substs) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index a53800c85..304d9f711 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -358,7 +358,10 @@ is or might be a read or a write to the same location as A." ((f64->scm _)) ((scm->u64 _) &type-check) ((load-u64 _)) - ((u64->scm _))) + ((u64->scm _)) + ((scm->s64 _) &type-check) + ((load-s64 _)) + ((s64->scm _))) ;; Bytevectors. (define-primitive-effects diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 1edf703d8..4123446fd 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -53,8 +53,8 @@ ;; (slots allocation-slots) - ;; A map of VAR to representation. A representation is 'scm, 'f64, or - ;; 'u64. + ;; A map of VAR to representation. A representation is 'scm, 'f64, + ;; 'u64, or 's64. ;; (representations allocation-representations) @@ -323,7 +323,7 @@ the definitions that are live before and after LABEL, as intsets." (match exp (($ $const) empty-intset) - (($ $primcall (or 'load-f64 'load-u64) (val)) + (($ $primcall (or 'load-f64 'load-u64 'load-s64) (val)) empty-intset) (($ $primcall 'free-ref (closure slot)) (defs+ closure)) @@ -804,6 +804,8 @@ are comparable with eqv?. A tmp slot may be used." 'uadd 'usub 'umul 'uadd/immediate 'usub/immediate 'umul/immediate)) (intmap-add representations var 'u64)) + (($ $primcall (or 'scm->s64 'load-s64)) + (intmap-add representations var 's64)) (_ (intmap-add representations var 'scm)))) (vars @@ -885,7 +887,7 @@ are comparable with eqv?. A tmp slot may be used." (#f slot-map) (slot (let ((desc (match (intmap-ref representations var) - ((or 'u64 'f64) slot-desc-live-raw) + ((or 'u64 'f64 's64) slot-desc-live-raw) ('scm slot-desc-live-scm)))) (logior slot-map (ash desc (* 2 slot))))))) live-vars 0)) diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm index 1df0b8eef..9a66917ba 100644 --- a/module/language/cps/specialize-primcalls.scm +++ b/module/language/cps/specialize-primcalls.scm @@ -62,6 +62,7 @@ (('umul (? u8? x) y) (build-exp ($primcall 'umul/immediate (y x)))) (('scm->f64 (? f64?)) (rename 'load-f64)) (('scm->u64 (? u64?)) (rename 'load-u64)) + (('scm->s64 (? s64?)) (rename 'load-s64)) (_ #f))) (intmap-map (lambda (label cont) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index f5423658f..72e4dd2aa 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -120,6 +120,7 @@ ;; Untagged types. &f64 &u64 + &s64 infer-types lookup-pre-type @@ -171,7 +172,8 @@ &hash-table &f64 - &u64) + &u64 + &s64) (define-syntax &no-type (identifier-syntax 0)) @@ -203,8 +205,12 @@ (var (identifier? #'var) (datum->syntax #'var val))))))) -(define-compile-time-value &range-min (- #x8000000000000000)) -(define-compile-time-value &range-max #xffffFFFFffffFFFF) +(define-compile-time-value &s64-min (- #x8000000000000000)) +(define-compile-time-value &s64-max #x7fffFFFFffffFFFF) +(define-compile-time-value &u64-max #xffffFFFFffffFFFF) + +(define-syntax &range-min (identifier-syntax &s64-min)) +(define-syntax &range-max (identifier-syntax &u64-max)) ;; This is a hack that takes advantage of knowing that ;; most-positive-fixnum is the size of a word, but with two tag bits and @@ -725,6 +731,18 @@ minimum, and maximum." (define-type-inferrer (u64->scm u64 result) (define! result &exact-integer (&min u64) (&max u64))) +(define-type-checker (scm->s64 scm) + (check-type scm &exact-integer &s64-min &s64-max)) +(define-type-inferrer (scm->s64 scm result) + (restrict! scm &exact-integer &s64-min &s64-max) + (define! result &s64 (max (&min scm) &s64-min) (min (&max scm) &s64-max))) +(define-type-aliases scm->s64 load-s64) + +(define-type-checker (s64->scm s64) + #t) +(define-type-inferrer (s64->scm s64 result) + (define! result &exact-integer (&min s64) (&max s64))) + @@ -773,9 +791,9 @@ minimum, and maximum." (define-bytevector-accessors bv-s32-ref bv-s32-set! &exact-integer 4 (- #x80000000) #x7fffFFFF) (define-bytevector-accessors bv-u64-ref bv-u64-set! - &exact-integer 8 #x0000000000000000 #xffffFFFFffffFFFF) + &exact-integer 8 0 &u64-max) (define-bytevector-accessors bv-s64-ref bv-s64-set! - &exact-integer 8 (- #x8000000000000000) #x7fffFFFFffffFFFF) + &exact-integer 8 &s64-min &s64-max) (define-syntax-rule (define-bytevector-uaccessors ref set type size lo hi) (begin diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm index 902860cee..e528ca338 100644 --- a/module/language/cps/utils.scm +++ b/module/language/cps/utils.scm @@ -205,7 +205,7 @@ disjoint, an error will be signalled." (intmap-fold (lambda (var exp out) (match exp - (($ $primcall (or 'load-f64 'load-u64) (val)) + (($ $primcall (or 'load-f64 'load-u64 'load-s64) (val)) (intmap-add! out var (intmap-ref out val))) ;; Punch through type conversions to allow uadd to specialize ;; to uadd/immediate. @@ -220,6 +220,12 @@ disjoint, an error will be signalled." (<= 0 u64 #xffffFFFFffffFFFF)) (intmap-add! out var u64) out))) + (($ $primcall 'scm->s64 (val)) + (let ((s64 (intmap-ref out val (lambda (_) #f)))) + (if (and s64 (number? s64) (exact-integer? s64) + (<= (- #x8000000000000000) u64 #x7fffFFFFffffFFFF)) + (intmap-add! out var s64) + out))) (_ out))) defs (intmap-fold (lambda (var exp out) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index bbd4e5d3a..59b194d16 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -173,6 +173,9 @@ (emit-scm->u64* . emit-scm->u64) emit-load-u64 (emit-u64->scm* . emit-u64->scm) + (emit-scm->s64* . emit-scm->s64) + emit-load-s64 + (emit-s64->scm* . emit-s64->scm) (emit-bv-length* . emit-bv-length) (emit-bv-u8-ref* . emit-bv-u8-ref) (emit-bv-s8-ref* . emit-bv-s8-ref) @@ -1919,6 +1922,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If ((scm) 0) ((f64) 1) ((u64) 2) + ((s64) 3) (else (error "what!" representation))))) (put-uleb128 names-port (logior (ash slot 2) tag))) (lp definitions)))))) diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm index 78bf13a50..09d076692 100644 --- a/module/system/vm/debug.scm +++ b/module/system/vm/debug.scm @@ -387,6 +387,7 @@ section of the ELF image. Returns an ELF symbol, or @code{#f}." ((0) 'scm) ((1) 'f64) ((2) 'u64) + ((3) 's64) (else 'unknown)))) (cons (vector name def-offset slot representation) (lp pos names))))))))))) From a08b3d40f8d1093b96ca4fc8aa440fd71bd0f20e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 21 Nov 2015 11:50:15 +0100 Subject: [PATCH 136/865] Untag values and indexes for all bytevector instructions * libguile/vm-engine.c (bv-s8-ref, bv-s16-ref, bv-s32-ref, bv-s64-ref): Unbox index and return unboxed S32 value. (bv-s8-set!, bv-s16-set!, bv-s32-set!, bv-s64-set!): Unbox index and take unboxed S32 value. (bv-u8-ref, bv-u16-ref, bv-u32-ref, bv-u64-ref) (bv-s8-set!, bv-s16-set!, bv-s32-set!, bv-s64-set!): Likewise, but with unsigned values. (bv-f32-ref, bv-f32-set!, bv-f64-ref, bv-f64-set!): Use memcpy to access the value so we don't have to think about alignment. GCC will inline this to a single instruction on architectures that support unaligned access. * libguile/vm.c (vm_error_out_of_range_uint64) (vm_error_out_of_range_int64): New helpers. * module/language/cps/slot-allocation.scm (compute-var-representations): All bytevector ref operations produce untagged values. * module/language/cps/types.scm (define-bytevector-accessors): Update for bytevector untagged indices and values. * module/language/cps/utils.scm (compute-constant-values): Fix s64 case. * module/language/tree-il/compile-cps.scm (convert): Box results of all bytevector accesses, and unbox incoming indices and values. --- libguile/instructions.c | 2 + libguile/vm-engine.c | 257 +++++-------------- libguile/vm.c | 14 + module/language/bytecode.scm | 4 +- module/language/cps/slot-allocation.scm | 6 +- module/language/cps/specialize-primcalls.scm | 4 + module/language/cps/types.scm | 57 ++-- module/language/cps/utils.scm | 2 +- module/language/tree-il/compile-cps.scm | 33 ++- module/system/vm/assembler.scm | 5 + module/system/vm/disassembler.scm | 2 +- 11 files changed, 151 insertions(+), 235 deletions(-) diff --git a/libguile/instructions.c b/libguile/instructions.c index 49b07d1dc..29e60983b 100644 --- a/libguile/instructions.c +++ b/libguile/instructions.c @@ -54,6 +54,8 @@ SCM_SYMBOL (sym_bang, "!"); M(BF32) /* Immediate double, low bits. */ \ M(AU32) /* Immediate uint64, high bits. */ \ M(BU32) /* Immediate uint64, low bits. */ \ + M(AS32) /* Immediate int64, high bits. */ \ + M(BS32) /* Immediate int64, low bits. */ \ M(N32) /* Non-immediate. */ \ M(R32) /* Scheme value (indirected). */ \ M(L32) /* Label. */ \ diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index b6d656b4e..ed39fed5c 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -2957,62 +2957,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Fetch the item at byte offset IDX in the bytevector SRC, and store * it in DST. All accesses use native endianness. */ -#define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \ +#define BV_REF(stem, type, size, slot) \ do { \ - scm_t_signed_bits i; \ - const scm_t_ ## type *int_ptr; \ - ARGS2 (bv, idx); \ - \ - VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \ - i = SCM_I_INUM (idx); \ - int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ - \ - if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && (i >= 0) \ - && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ - && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \ - RETURN (SCM_I_MAKINUM (*int_ptr)); \ - else \ - { \ - SYNC_IP (); \ - RETURN (scm_bytevector_ ## fn_stem ## _ref (bv, idx)); \ - } \ - } while (0) - -#define BV_INT_REF(stem, type, size) \ - do { \ - scm_t_signed_bits i; \ - const scm_t_ ## type *int_ptr; \ - ARGS2 (bv, idx); \ - \ - VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \ - i = SCM_I_INUM (idx); \ - int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ - \ - if (SCM_LIKELY (SCM_I_INUMP (idx) \ - && (i >= 0) \ - && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ - && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \ - { \ - scm_t_ ## type x = *int_ptr; \ - if (SCM_FIXABLE (x)) \ - RETURN (SCM_I_MAKINUM (x)); \ - else \ - { \ - SYNC_IP (); \ - RETURN (scm_from_ ## type (x)); \ - } \ - } \ - else \ - { \ - SYNC_IP (); \ - RETURN (scm_bytevector_ ## stem ## _native_ref (bv, idx)); \ - } \ - } while (0) - -#define BV_FLOAT_REF(stem, fn_stem, type, size) \ - do { \ - const type *float_ptr; \ + type result; \ scm_t_uint8 dst, src, idx; \ SCM bv; \ scm_t_uint64 c_idx; \ @@ -3021,63 +2968,45 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, c_idx = SP_REF_U64 (idx); \ \ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \ - float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + c_idx); \ \ - if (SCM_LIKELY (size <= SCM_BYTEVECTOR_LENGTH (bv) \ - && (c_idx <= SCM_BYTEVECTOR_LENGTH (bv) - size) \ - && (ALIGNED_P (float_ptr, type)))) \ - { \ - SP_SET_F64 (dst, *float_ptr); \ - NEXT (1); \ - } \ - else \ - { \ - SCM scm_idx, val; \ - SYNC_IP (); \ - scm_idx = scm_from_uint64 (c_idx); \ - val = scm_bytevector_ ## fn_stem ## _native_ref (bv, scm_idx); \ - SP_SET_F64 (dst, scm_to_double (val)); \ - NEXT (1); \ - } \ + if (SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (bv) < size) \ + || SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (bv) - size < c_idx)) \ + vm_error_out_of_range_uint64 ("bv-" #stem "-ref", c_idx); \ + \ + memcpy (&result, SCM_BYTEVECTOR_CONTENTS (bv) + c_idx, size); \ + SP_SET_ ## slot (dst, result); \ + NEXT (1); \ } while (0) VM_DEFINE_OP (116, bv_u8_ref, "bv-u8-ref", OP1 (X8_S8_S8_S8) | OP_DST) - BV_FIXABLE_INT_REF (u8, u8, uint8, 1); + BV_REF (u8, scm_t_uint8, 1, U64); VM_DEFINE_OP (117, bv_s8_ref, "bv-s8-ref", OP1 (X8_S8_S8_S8) | OP_DST) - BV_FIXABLE_INT_REF (s8, s8, int8, 1); + BV_REF (s8, scm_t_int8, 1, S64); VM_DEFINE_OP (118, bv_u16_ref, "bv-u16-ref", OP1 (X8_S8_S8_S8) | OP_DST) - BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2); + BV_REF (u16, scm_t_uint16, 2, U64); VM_DEFINE_OP (119, bv_s16_ref, "bv-s16-ref", OP1 (X8_S8_S8_S8) | OP_DST) - BV_FIXABLE_INT_REF (s16, s16_native, int16, 2); + BV_REF (s16, scm_t_int16, 2, S64); VM_DEFINE_OP (120, bv_u32_ref, "bv-u32-ref", OP1 (X8_S8_S8_S8) | OP_DST) -#if SIZEOF_VOID_P > 4 - BV_FIXABLE_INT_REF (u32, u32_native, uint32, 4); -#else - BV_INT_REF (u32, uint32, 4); -#endif + BV_REF (u32, scm_t_uint32, 4, U64); VM_DEFINE_OP (121, bv_s32_ref, "bv-s32-ref", OP1 (X8_S8_S8_S8) | OP_DST) -#if SIZEOF_VOID_P > 4 - BV_FIXABLE_INT_REF (s32, s32_native, int32, 4); -#else - BV_INT_REF (s32, int32, 4); -#endif + BV_REF (s32, scm_t_int32, 4, S64); VM_DEFINE_OP (122, bv_u64_ref, "bv-u64-ref", OP1 (X8_S8_S8_S8) | OP_DST) - BV_INT_REF (u64, uint64, 8); + BV_REF (u64, scm_t_uint64, 8, U64); VM_DEFINE_OP (123, bv_s64_ref, "bv-s64-ref", OP1 (X8_S8_S8_S8) | OP_DST) - BV_INT_REF (s64, int64, 8); + BV_REF (s64, scm_t_int64, 8, S64); VM_DEFINE_OP (124, bv_f32_ref, "bv-f32-ref", OP1 (X8_S8_S8_S8) | OP_DST) - BV_FLOAT_REF (f32, ieee_single, float, 4); + BV_REF (f32, float, 4, F64); VM_DEFINE_OP (125, bv_f64_ref, "bv-f64-ref", OP1 (X8_S8_S8_S8) | OP_DST) - BV_FLOAT_REF (f64, ieee_double, double, 8); + BV_REF (f64, double, 8, F64); /* bv-u8-set! dst:8 idx:8 src:8 * bv-s8-set! dst:8 idx:8 src:8 @@ -3093,133 +3022,89 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * Store SRC into the bytevector DST at byte offset IDX. Multibyte * values are written using native endianness. */ -#define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \ +#define BV_BOUNDED_SET(stem, type, min, max, size, slot_type, slot) \ do { \ - scm_t_uint8 dst, idx, src; \ - scm_t_signed_bits i, j = 0; \ - SCM bv, scm_idx, val; \ - scm_t_ ## type *int_ptr; \ - \ - UNPACK_8_8_8 (op, dst, idx, src); \ - bv = SP_REF (dst); \ - scm_idx = SP_REF (idx); \ - val = SP_REF (src); \ - VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ - i = SCM_I_INUM (scm_idx); \ - int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ - \ - if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \ - && (i >= 0) \ - && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ - && (ALIGNED_P (int_ptr, scm_t_ ## type)) \ - && (SCM_I_INUMP (val)) \ - && ((j = SCM_I_INUM (val)) >= min) \ - && (j <= max))) \ - *int_ptr = (scm_t_ ## type) j; \ - else \ - { \ - SYNC_IP (); \ - scm_bytevector_ ## fn_stem ## _set_x (bv, scm_idx, val); \ - } \ - NEXT (1); \ - } while (0) - -#define BV_INT_SET(stem, type, size) \ - do { \ - scm_t_uint8 dst, idx, src; \ - scm_t_signed_bits i; \ - SCM bv, scm_idx, val; \ - scm_t_ ## type *int_ptr; \ - \ - UNPACK_8_8_8 (op, dst, idx, src); \ - bv = SP_REF (dst); \ - scm_idx = SP_REF (idx); \ - val = SP_REF (src); \ - VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ - i = SCM_I_INUM (scm_idx); \ - int_ptr = (scm_t_ ## type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ - \ - if (SCM_LIKELY (SCM_I_INUMP (scm_idx) \ - && (i >= 0) \ - && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ - && (ALIGNED_P (int_ptr, scm_t_ ## type)))) \ - *int_ptr = scm_to_ ## type (val); \ - else \ - { \ - SYNC_IP (); \ - scm_bytevector_ ## stem ## _native_set_x (bv, scm_idx, val); \ - } \ - NEXT (1); \ - } while (0) - -#define BV_FLOAT_SET(stem, fn_stem, type, size) \ - do { \ + scm_t_ ## slot_type slot_val; \ + type val; \ scm_t_uint8 dst, idx, src; \ SCM bv; \ scm_t_uint64 c_idx; \ - double val; \ - type *float_ptr; \ - \ UNPACK_8_8_8 (op, dst, idx, src); \ bv = SP_REF (dst); \ c_idx = SP_REF_U64 (idx); \ - val = SP_REF_F64 (src); \ + slot_val = SP_REF_ ## slot (src); \ + \ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ - float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + c_idx); \ + \ + if (SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (bv) < size) \ + || SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (bv) - size < c_idx)) \ + vm_error_out_of_range_uint64 ("bv-" #stem "-set!", c_idx); \ \ - if (SCM_LIKELY (size <= SCM_BYTEVECTOR_LENGTH (bv) \ - && c_idx <= SCM_BYTEVECTOR_LENGTH (bv) - size \ - && ALIGNED_P (float_ptr, type))) \ - *float_ptr = val; \ - else \ - { \ - SCM boxed_idx, boxed_val; \ - boxed_idx = scm_from_uint64 (c_idx); \ - boxed_val = scm_from_double (val); \ - SYNC_IP (); \ - scm_bytevector_ ## fn_stem ## _native_set_x (bv, boxed_idx, \ - boxed_val); \ - } \ + if (SCM_UNLIKELY (slot_val < min) || SCM_UNLIKELY (slot_val > max)) \ + vm_error_out_of_range_ ## slot_type ("bv-" #stem "-set!", \ + slot_val); \ + \ + val = slot_val; \ + memcpy (SCM_BYTEVECTOR_CONTENTS (bv) + c_idx, &val, size); \ + NEXT (1); \ + } while (0) + +#define BV_SET(stem, type, size, slot) \ + do { \ + type val; \ + scm_t_uint8 dst, idx, src; \ + SCM bv; \ + scm_t_uint64 c_idx; \ + UNPACK_8_8_8 (op, dst, idx, src); \ + bv = SP_REF (dst); \ + c_idx = SP_REF_U64 (idx); \ + val = SP_REF_ ## slot (src); \ + \ + VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ + \ + if (SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (bv) < size) \ + || SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (bv) - size < c_idx)) \ + vm_error_out_of_range_uint64 ("bv-" #stem "-set!", c_idx); \ + \ + memcpy (SCM_BYTEVECTOR_CONTENTS (bv) + c_idx, &val, size); \ NEXT (1); \ } while (0) VM_DEFINE_OP (126, bv_u8_set, "bv-u8-set!", OP1 (X8_S8_S8_S8)) - BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1); + BV_BOUNDED_SET (u8, scm_t_uint8, + 0, SCM_T_UINT8_MAX, 1, uint64, U64); VM_DEFINE_OP (127, bv_s8_set, "bv-s8-set!", OP1 (X8_S8_S8_S8)) - BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1); + BV_BOUNDED_SET (s8, scm_t_int8, + SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1, int64, S64); VM_DEFINE_OP (128, bv_u16_set, "bv-u16-set!", OP1 (X8_S8_S8_S8)) - BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2); + BV_BOUNDED_SET (u16, scm_t_uint16, + 0, SCM_T_UINT16_MAX, 2, uint64, U64); VM_DEFINE_OP (129, bv_s16_set, "bv-s16-set!", OP1 (X8_S8_S8_S8)) - BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2); + BV_BOUNDED_SET (s16, scm_t_int16, + SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2, int64, S64); VM_DEFINE_OP (130, bv_u32_set, "bv-u32-set!", OP1 (X8_S8_S8_S8)) -#if SIZEOF_VOID_P > 4 - BV_FIXABLE_INT_SET (u32, u32_native, uint32, 0, SCM_T_UINT32_MAX, 4); -#else - BV_INT_SET (u32, uint32, 4); -#endif + BV_BOUNDED_SET (u32, scm_t_uint32, + 0, SCM_T_UINT32_MAX, 4, uint64, U64); VM_DEFINE_OP (131, bv_s32_set, "bv-s32-set!", OP1 (X8_S8_S8_S8)) -#if SIZEOF_VOID_P > 4 - BV_FIXABLE_INT_SET (s32, s32_native, int32, SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4); -#else - BV_INT_SET (s32, int32, 4); -#endif + BV_BOUNDED_SET (s32, scm_t_int32, + SCM_T_INT32_MIN, SCM_T_INT32_MAX, 4, int64, S64); VM_DEFINE_OP (132, bv_u64_set, "bv-u64-set!", OP1 (X8_S8_S8_S8)) - BV_INT_SET (u64, uint64, 8); + BV_SET (u64, scm_t_uint64, 8, U64); VM_DEFINE_OP (133, bv_s64_set, "bv-s64-set!", OP1 (X8_S8_S8_S8)) - BV_INT_SET (s64, int64, 8); + BV_SET (s64, scm_t_int64, 8, S64); VM_DEFINE_OP (134, bv_f32_set, "bv-f32-set!", OP1 (X8_S8_S8_S8)) - BV_FLOAT_SET (f32, ieee_single, float, 4); + BV_SET (f32, float, 4, F64); VM_DEFINE_OP (135, bv_f64_set, "bv-f64-set!", OP1 (X8_S8_S8_S8)) - BV_FLOAT_SET (f64, ieee_double, double, 8); + BV_SET (f6, double, 8, F64); /* scm->f64 dst:12 src:12 * diff --git a/libguile/vm.c b/libguile/vm.c index ece3c33e4..3bc59fc15 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -447,6 +447,8 @@ static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_vector (const char *subr, SCM v) SCM_NORETURN SCM_NOINLINE; static void vm_error_out_of_range (const char *subr, SCM k) SCM_NORETURN SCM_NOINLINE; +static void vm_error_out_of_range_uint64 (const char *subr, scm_t_uint64 idx) SCM_NORETURN SCM_NOINLINE; +static void vm_error_out_of_range_int64 (const char *subr, scm_t_int64 idx) SCM_NORETURN SCM_NOINLINE; static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE; static void vm_error_wrong_number_of_values (scm_t_uint32 expected) SCM_NORETURN SCM_NOINLINE; @@ -584,6 +586,18 @@ vm_error_out_of_range (const char *subr, SCM k) scm_out_of_range (subr, k); } +static void +vm_error_out_of_range_uint64 (const char *subr, scm_t_uint64 idx) +{ + scm_out_of_range (subr, scm_from_uint64 (idx)); +} + +static void +vm_error_out_of_range_int64 (const char *subr, scm_t_int64 idx) +{ + scm_out_of_range (subr, scm_from_int64 (idx)); +} + static void vm_error_no_values (void) { diff --git a/module/language/bytecode.scm b/module/language/bytecode.scm index fb7ef7348..c140b4bb3 100644 --- a/module/language/bytecode.scm +++ b/module/language/bytecode.scm @@ -51,8 +51,8 @@ (case word ((C32) 1) ((I32) 1) - ((A32 AU32 AF32) 1) - ((B32 BF32 BU32) 0) + ((A32 AU32 AS32 AF32) 1) + ((B32 BF32 BS32 BU32) 0) ((N32) 1) ((R32) 1) ((L32) 1) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 4123446fd..c378bd1f5 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -802,9 +802,11 @@ are comparable with eqv?. A tmp slot may be used." (intmap-add representations var 'f64)) (($ $primcall (or 'scm->u64 'load-u64 'bv-length 'uadd 'usub 'umul - 'uadd/immediate 'usub/immediate 'umul/immediate)) + 'uadd/immediate 'usub/immediate 'umul/immediate + 'bv-u8-ref 'bv-u16-ref 'bv-u32-ref 'bv-u64-ref)) (intmap-add representations var 'u64)) - (($ $primcall (or 'scm->s64 'load-s64)) + (($ $primcall (or 'scm->s64 'load-s64 + 'bv-s8-ref 'bv-s16-ref 'bv-s32-ref 'bv-s64-ref)) (intmap-add representations var 's64)) (_ (intmap-add representations var 'scm)))) diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm index 9a66917ba..59c3055c3 100644 --- a/module/language/cps/specialize-primcalls.scm +++ b/module/language/cps/specialize-primcalls.scm @@ -39,6 +39,10 @@ (define (u64? var) (let ((val (intmap-ref constants var (lambda (_) #f)))) (and (exact-integer? val) (<= 0 val #xffffFFFFffffFFFF)))) + (define (s64? var) + (let ((val (intmap-ref constants var (lambda (_) #f)))) + (and (exact-integer? val) + (<= (- #x8000000000000000) val #x7fffFFFFffffFFFF)))) (define (f64? var) (let ((val (intmap-ref constants var (lambda (_) #f)))) (and (number? val) (inexact? val) (real? val)))) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 72e4dd2aa..a5ea1bf72 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -757,45 +757,6 @@ minimum, and maximum." (max (&min bv) 0) (min (&max bv) *max-size-t*))) (define-syntax-rule (define-bytevector-accessors ref set type size lo hi) - (begin - (define-type-checker (ref bv idx) - (and (check-type bv &bytevector 0 *max-size-t*) - (check-type idx &exact-integer 0 *max-size-t*) - (< (&max idx) (- (&min bv) size)))) - (define-type-inferrer (ref bv idx result) - (restrict! bv &bytevector (+ (&min idx) size) *max-size-t*) - (restrict! idx &exact-integer 0 (- (min (&max bv) *max-size-t*) size)) - (define! result type lo hi)) - (define-type-checker (set bv idx val) - (and (check-type bv &bytevector 0 *max-size-t*) - (check-type idx &exact-integer 0 *max-size-t*) - (check-type val type lo hi) - (< (&max idx) (- (&min bv) size)))) - (define-type-inferrer (set! bv idx val) - (restrict! bv &bytevector (+ (&min idx) size) *max-size-t*) - (restrict! idx &exact-integer 0 (- (min (&max bv) *max-size-t*) size)) - (restrict! val type lo hi)))) - -(define-syntax-rule (define-short-bytevector-accessors ref set size signed?) - (define-bytevector-accessors ref set &exact-integer size - (if signed? (- (ash 1 (1- (* size 8)))) 0) - (1- (ash 1 (if signed? (1- (* size 8)) (* size 8)))))) - -(define-short-bytevector-accessors bv-u8-ref bv-u8-set! 1 #f) -(define-short-bytevector-accessors bv-s8-ref bv-s8-set! 1 #t) -(define-short-bytevector-accessors bv-u16-ref bv-u16-set! 2 #f) -(define-short-bytevector-accessors bv-s16-ref bv-s16-set! 2 #t) - -(define-bytevector-accessors bv-u32-ref bv-u32-set! - &exact-integer 4 #x00000000 #xffffFFFF) -(define-bytevector-accessors bv-s32-ref bv-s32-set! - &exact-integer 4 (- #x80000000) #x7fffFFFF) -(define-bytevector-accessors bv-u64-ref bv-u64-set! - &exact-integer 8 0 &u64-max) -(define-bytevector-accessors bv-s64-ref bv-s64-set! - &exact-integer 8 &s64-min &s64-max) - -(define-syntax-rule (define-bytevector-uaccessors ref set type size lo hi) (begin (define-type-checker (ref bv idx) (and (check-type bv &bytevector 0 *max-size-t*) @@ -814,8 +775,22 @@ minimum, and maximum." (restrict! bv &bytevector (+ (&min idx) size) *max-size-t*) (restrict! idx &exact-integer 0 (- (min (&max bv) *max-size-t*) size)) (restrict! val type lo hi)))) -(define-bytevector-uaccessors bv-f32-ref bv-f32-set! &f64 4 -inf.0 +inf.0) -(define-bytevector-uaccessors bv-f64-ref bv-f64-set! &f64 8 -inf.0 +inf.0) + +(define-bytevector-accessors bv-u8-ref bv-u8-set! &u64 1 0 #xff) +(define-bytevector-accessors bv-s8-ref bv-s8-set! &s64 1 (- #x80) #x7f) + +(define-bytevector-accessors bv-u16-ref bv-u16-set! &u64 2 0 #xffff) +(define-bytevector-accessors bv-s16-ref bv-s16-set! &s64 2 (- #x8000) #x7fff) + +(define-bytevector-accessors bv-u32-ref bv-u32-set! &u64 4 0 #xffffffff) +(define-bytevector-accessors bv-s32-ref bv-s32-set! &s64 4 + (- #x80000000) #x7fffffff) + +(define-bytevector-accessors bv-u64-ref bv-u64-set! &u64 8 0 &u64-max) +(define-bytevector-accessors bv-s64-ref bv-s64-set! &s64 8 &s64-min &s64-max) + +(define-bytevector-accessors bv-f32-ref bv-f32-set! &f64 4 -inf.0 +inf.0) +(define-bytevector-accessors bv-f64-ref bv-f64-set! &f64 8 -inf.0 +inf.0) diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm index e528ca338..750fd17b1 100644 --- a/module/language/cps/utils.scm +++ b/module/language/cps/utils.scm @@ -223,7 +223,7 @@ disjoint, an error will be signalled." (($ $primcall 'scm->s64 (val)) (let ((s64 (intmap-ref out val (lambda (_) #f)))) (if (and s64 (number? s64) (exact-integer? s64) - (<= (- #x8000000000000000) u64 #x7fffFFFFffffFFFF)) + (<= (- #x8000000000000000) s64 #x7fffFFFFffffFFFF)) (intmap-add! out var s64) out))) (_ out))) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 2bde7c5d3..c1f976ae0 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -576,13 +576,20 @@ (letk kbox ($kargs ('f64) (f64) ($continue k src ($primcall 'f64->scm (f64))))) kbox)) - ((bv-length) + ((bv-length bv-u8-ref bv-u16-ref bv-u32-ref bv-u64-ref) (with-cps cps (letv u64) (let$ k (adapt-arity k src out)) (letk kbox ($kargs ('u64) (u64) ($continue k src ($primcall 'u64->scm (u64))))) kbox)) + ((bv-s8-ref bv-s16-ref bv-s32-ref bv-s64-ref) + (with-cps cps + (letv s64) + (let$ k (adapt-arity k src out)) + (letk kbox ($kargs ('s64) (s64) + ($continue k src ($primcall 's64->scm (s64))))) + kbox)) (else (adapt-arity cps k src out)))) (define (unbox-arg cps arg unbox-op have-arg) @@ -594,7 +601,9 @@ ($continue kunboxed src ($primcall unbox-op (arg)))))) (define (unbox-args cps args have-args) (case instruction - ((bv-f32-ref bv-f64-ref) + ((bv-f32-ref bv-f64-ref + bv-s8-ref bv-s16-ref bv-s32-ref bv-s64-ref + bv-u8-ref bv-u16-ref bv-u32-ref bv-u64-ref) (match args ((bv idx) (unbox-arg @@ -611,6 +620,26 @@ cps val 'scm->f64 (lambda (cps val) (have-args cps (list bv idx val))))))))) + ((bv-s8-set! bv-s16-set! bv-s32-set! bv-s64-set!) + (match args + ((bv idx val) + (unbox-arg + cps idx 'scm->u64 + (lambda (cps idx) + (unbox-arg + cps val 'scm->s64 + (lambda (cps val) + (have-args cps (list bv idx val))))))))) + ((bv-u8-set! bv-u16-set! bv-u32-set! bv-u64-set!) + (match args + ((bv idx val) + (unbox-arg + cps idx 'scm->u64 + (lambda (cps idx) + (unbox-arg + cps val 'scm->u64 + (lambda (cps val) + (have-args cps (list bv idx val))))))))) (else (have-args cps args)))) (convert-args cps args (lambda (cps args) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 59b194d16..0e4bbf06c 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -582,8 +582,13 @@ later by the linker." ((AU32 u64) (emit asm (ash u64 -32)) (emit asm (logand u64 (1- (ash 1 32))))) + ((AS32 s64) + (let ((u64 (u64vector-ref (s64vector s64) 0))) + (emit asm (ash u64 -32)) + (emit asm (logand u64 (1- (ash 1 32)))))) ((B32)) ((BU32)) + ((BS32)) ((BF32)) ((N32 label) (record-far-label-reference asm label) diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index 794caa759..6c21ad609 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -108,7 +108,7 @@ (define (parse-tail-word word type) (with-syntax ((word word)) (case type - ((C32 I32 A32 B32 AU32 BU32 AF32 BF32) + ((C32 I32 A32 B32 AU32 BU32 AS32 BS32 AF32 BF32) #'(word)) ((N32 R32 L32 LO32) #'((unpack-s32 word))) From c3240d09b2d05d0c33d0dcfed076f944fcfa5de4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 24 Nov 2015 10:15:21 +0100 Subject: [PATCH 137/865] Unbox indexes of vectors, strings, and structs * libguile/vm-engine.c (string-length, string-ref) (make-vector, vector-ref, vector-set!) (allocate-struct, struct-ref, struct-set!): Take indexes and return lengths as untagged u64 values. * libguile/vm.c (vm_error_not_a_string): New helper. * module/language/tree-il/compile-cps.scm (convert): * module/language/cps/constructors.scm (inline-vector): * module/language/cps/closure-conversion.scm (convert-one): Untag arguments to {string,vector,struct}-{ref,set!}, make-vector, and allocate-struct. Tag return values from {string,vector}-length. * module/language/cps/slot-allocation.scm (compute-var-representations): vector-length and string-length define u64 slots. * module/language/cps/effects-analysis.scm: make-vector no longer causes a &type-check effect. * module/language/cps/types.scm: Update to expect &u64 values for lengths and indexes. --- libguile/vm-engine.c | 145 +++++++++++---------- libguile/vm.c | 7 + module/language/cps/closure-conversion.scm | 70 ++++++---- module/language/cps/constructors.scm | 16 ++- module/language/cps/effects-analysis.scm | 2 +- module/language/cps/slot-allocation.scm | 3 +- module/language/cps/types.scm | 34 ++--- module/language/tree-il/compile-cps.scm | 32 ++++- 8 files changed, 193 insertions(+), 116 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index ed39fed5c..6b2458f0b 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -2224,13 +2224,10 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, VM_DEFINE_OP (76, string_length, "string-length", OP1 (X8_S12_S12) | OP_DST) { ARGS1 (str); - if (SCM_LIKELY (scm_is_string (str))) - RETURN (SCM_I_MAKINUM (scm_i_string_length (str))); - else - { - SYNC_IP (); - RETURN (scm_string_length (str)); - } + VM_ASSERT (scm_is_string (str), + vm_error_not_a_string ("string-length", str)); + SP_SET_U64 (dst, scm_i_string_length (str)); + NEXT (1); } /* string-ref dst:8 src:8 idx:8 @@ -2240,18 +2237,20 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, */ VM_DEFINE_OP (77, string_ref, "string-ref", OP1 (X8_S8_S8_S8) | OP_DST) { - scm_t_signed_bits i = 0; - ARGS2 (str, idx); - if (SCM_LIKELY (scm_is_string (str) - && SCM_I_INUMP (idx) - && ((i = SCM_I_INUM (idx)) >= 0) - && i < scm_i_string_length (str))) - RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str, i))); - else - { - SYNC_IP (); - RETURN (scm_string_ref (str, idx)); - } + scm_t_uint8 dst, src, idx; + SCM str; + scm_t_uint32 c_idx; + + UNPACK_8_8_8 (op, dst, src, idx); + str = SP_REF (src); + c_idx = SP_REF_U64 (idx); + + VM_ASSERT (scm_is_string (str), + vm_error_not_a_string ("string-ref", str)); + VM_ASSERT (c_idx < scm_i_string_length (str), + vm_error_out_of_range_uint64 ("string-ref", c_idx)); + + RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str, c_idx))); } /* No string-set! instruction, as there is no good fast path there. */ @@ -2267,8 +2266,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_12_12 (op, dst, src); SYNC_IP (); SP_SET (dst, - scm_string_to_number (SP_REF (src), - SCM_UNDEFINED /* radix = 10 */)); + scm_string_to_number (SP_REF (src), + SCM_UNDEFINED /* radix = 10 */)); NEXT (1); } @@ -2574,11 +2573,17 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, */ VM_DEFINE_OP (99, make_vector, "make-vector", OP1 (X8_S8_S8_S8) | OP_DST) { - scm_t_uint8 dst, init, length; + scm_t_uint8 dst, length, init; + scm_t_uint64 length_val; UNPACK_8_8_8 (op, dst, length, init); + length_val = SP_REF_U64 (length); + VM_ASSERT (length_val < (size_t) -1, + vm_error_out_of_range_uint64 ("make-vector", length_val)); - SP_SET (dst, scm_make_vector (SP_REF (length), SP_REF (init))); + /* TODO: Inline this allocation. */ + SYNC_IP (); + SP_SET (dst, scm_c_make_vector (length_val, SP_REF (init))); NEXT (1); } @@ -2615,7 +2620,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, ARGS1 (vect); VM_ASSERT (SCM_I_IS_VECTOR (vect), vm_error_not_a_vector ("vector-ref", vect)); - RETURN (SCM_I_MAKINUM (SCM_I_VECTOR_LENGTH (vect))); + + SP_SET_U64 (dst, SCM_I_VECTOR_LENGTH (vect)); + NEXT (1); } /* vector-ref dst:8 src:8 idx:8 @@ -2625,15 +2632,19 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, */ VM_DEFINE_OP (102, vector_ref, "vector-ref", OP1 (X8_S8_S8_S8) | OP_DST) { - scm_t_signed_bits i = 0; - ARGS2 (vect, idx); + scm_t_uint8 dst, src, idx; + SCM vect; + scm_t_uint64 c_idx; + + UNPACK_8_8_8 (op, dst, src, idx); + vect = SP_REF (src); + c_idx = SP_REF_U64 (idx); + VM_ASSERT (SCM_I_IS_VECTOR (vect), vm_error_not_a_vector ("vector-ref", vect)); - VM_ASSERT ((SCM_I_INUMP (idx) - && ((i = SCM_I_INUM (idx)) >= 0) - && i < SCM_I_VECTOR_LENGTH (vect)), - vm_error_out_of_range ("vector-ref", idx)); - RETURN (SCM_I_VECTOR_ELTS (vect)[i]); + VM_ASSERT (c_idx < SCM_I_VECTOR_LENGTH (vect), + vm_error_out_of_range_uint64 ("vector-ref", c_idx)); + RETURN (SCM_I_VECTOR_ELTS (vect)[c_idx]); } /* vector-ref/immediate dst:8 src:8 idx:8 @@ -2644,15 +2655,15 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, VM_DEFINE_OP (103, vector_ref_immediate, "vector-ref/immediate", OP1 (X8_S8_S8_C8) | OP_DST) { scm_t_uint8 dst, src, idx; - SCM v; + SCM vect; UNPACK_8_8_8 (op, dst, src, idx); - v = SP_REF (src); - VM_ASSERT (SCM_I_IS_VECTOR (v), - vm_error_not_a_vector ("vector-ref", v)); - VM_ASSERT (idx < SCM_I_VECTOR_LENGTH (v), - vm_error_out_of_range ("vector-ref", scm_from_size_t (idx))); - SP_SET (dst, SCM_I_VECTOR_ELTS (SP_REF (src))[idx]); + vect = SP_REF (src); + VM_ASSERT (SCM_I_IS_VECTOR (vect), + vm_error_not_a_vector ("vector-ref", vect)); + VM_ASSERT (idx < SCM_I_VECTOR_LENGTH (vect), + vm_error_out_of_range_uint64 ("vector-ref", idx)); + SP_SET (dst, SCM_I_VECTOR_ELTS (vect)[idx]); NEXT (1); } @@ -2662,22 +2673,20 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, */ VM_DEFINE_OP (104, vector_set, "vector-set!", OP1 (X8_S8_S8_S8)) { - scm_t_uint8 dst, idx_var, src; - SCM vect, idx, val; - scm_t_signed_bits i = 0; + scm_t_uint8 dst, idx, src; + SCM vect, val; + scm_t_uint64 c_idx; - UNPACK_8_8_8 (op, dst, idx_var, src); + UNPACK_8_8_8 (op, dst, idx, src); vect = SP_REF (dst); - idx = SP_REF (idx_var); + c_idx = SP_REF_U64 (idx); val = SP_REF (src); VM_ASSERT (SCM_I_IS_VECTOR (vect), - vm_error_not_a_vector ("vector-ref", vect)); - VM_ASSERT ((SCM_I_INUMP (idx) - && ((i = SCM_I_INUM (idx)) >= 0) - && i < SCM_I_VECTOR_LENGTH (vect)), - vm_error_out_of_range ("vector-ref", idx)); - SCM_I_VECTOR_WELTS (vect)[i] = val; + vm_error_not_a_vector ("vector-set!", vect)); + VM_ASSERT (c_idx < SCM_I_VECTOR_LENGTH (vect), + vm_error_out_of_range_uint64 ("vector-set!", c_idx)); + SCM_I_VECTOR_WELTS (vect)[c_idx] = val; NEXT (1); } @@ -2698,7 +2707,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, VM_ASSERT (SCM_I_IS_VECTOR (vect), vm_error_not_a_vector ("vector-ref", vect)); VM_ASSERT (idx < SCM_I_VECTOR_LENGTH (vect), - vm_error_out_of_range ("vector-ref", scm_from_size_t (idx))); + vm_error_out_of_range_uint64 ("vector-ref", idx)); SCM_I_VECTOR_WELTS (vect)[idx] = val; NEXT (1); } @@ -2734,8 +2743,11 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_8_8_8 (op, dst, vtable, nfields); + /* TODO: Specify nfields as untagged value when calling + allocate-struct. */ SYNC_IP (); - ret = scm_allocate_struct (SP_REF (vtable), SP_REF (nfields)); + ret = scm_allocate_struct (SP_REF (vtable), + scm_from_uint64 (SP_REF_U64 (nfields))); SP_SET (dst, ret); NEXT (1); @@ -2750,25 +2762,22 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, { scm_t_uint8 dst, src, idx; SCM obj; - SCM index; + scm_t_uint64 index; UNPACK_8_8_8 (op, dst, src, idx); obj = SP_REF (src); - index = SP_REF (idx); + index = SP_REF_U64 (idx); if (SCM_LIKELY (SCM_STRUCTP (obj) && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, SCM_VTABLE_FLAG_SIMPLE) - && SCM_I_INUMP (index) - && SCM_I_INUM (index) >= 0 - && SCM_I_INUM (index) < (SCM_STRUCT_DATA_REF - (SCM_STRUCT_VTABLE (obj), - scm_vtable_index_size)))) - RETURN (SCM_STRUCT_SLOT_REF (obj, SCM_I_INUM (index))); + && index < (SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj), + scm_vtable_index_size)))) + RETURN (SCM_STRUCT_SLOT_REF (obj, index)); SYNC_IP (); - RETURN (scm_struct_ref (obj, index)); + RETURN (scm_struct_ref (obj, scm_from_uint64 (index))); } /* struct-set! dst:8 idx:8 src:8 @@ -2778,31 +2787,29 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, VM_DEFINE_OP (109, struct_set, "struct-set!", OP1 (X8_S8_S8_S8)) { scm_t_uint8 dst, idx, src; - SCM obj, val, index; + SCM obj, val; + scm_t_uint64 index; UNPACK_8_8_8 (op, dst, idx, src); obj = SP_REF (dst); val = SP_REF (src); - index = SP_REF (idx); + index = SP_REF_U64 (idx); if (SCM_LIKELY (SCM_STRUCTP (obj) && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, SCM_VTABLE_FLAG_SIMPLE) && SCM_STRUCT_VTABLE_FLAG_IS_SET (obj, SCM_VTABLE_FLAG_SIMPLE_RW) - && SCM_I_INUMP (index) - && SCM_I_INUM (index) >= 0 - && SCM_I_INUM (index) < (SCM_STRUCT_DATA_REF - (SCM_STRUCT_VTABLE (obj), - scm_vtable_index_size)))) + && index < (SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (obj), + scm_vtable_index_size)))) { - SCM_STRUCT_SLOT_SET (obj, SCM_I_INUM (index), val); + SCM_STRUCT_SLOT_SET (obj, index, val); NEXT (1); } SYNC_IP (); - scm_struct_set_x (obj, index, val); + scm_struct_set_x (obj, scm_from_uint64 (index), val); NEXT (1); } diff --git a/libguile/vm.c b/libguile/vm.c index 3bc59fc15..33f12b454 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -443,6 +443,7 @@ static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE; static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE; static void vm_error_improper_list (SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; +static void vm_error_not_a_string (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_vector (const char *subr, SCM v) SCM_NORETURN SCM_NOINLINE; @@ -561,6 +562,12 @@ vm_error_not_a_pair (const char *subr, SCM x) scm_wrong_type_arg_msg (subr, 1, x, "pair"); } +static void +vm_error_not_a_string (const char *subr, SCM x) +{ + scm_wrong_type_arg_msg (subr, 1, x, "string"); +} + static void vm_error_not_a_bytevector (const char *subr, SCM x) { diff --git a/module/language/cps/closure-conversion.scm b/module/language/cps/closure-conversion.scm index c6f941db3..2fe4d8030 100644 --- a/module/language/cps/closure-conversion.scm +++ b/module/language/cps/closure-conversion.scm @@ -490,18 +490,29 @@ Otherwise @var{var} is bound, so @var{k} is called with @var{var}." (letk k* ($kargs (#f) (var*) ,body)) (build-term ($continue k* #f ($primcall op (self))))))) (_ - (let* ((idx (intset-find free var)) - (op (cond - ((not self-known?) 'free-ref) - ((<= idx #xff) 'vector-ref/immediate) - (else 'vector-ref)))) - (with-cps cps - (letv var*) - (let$ body (k var*)) - (letk k* ($kargs (#f) (var*) ,body)) - ($ (with-cps-constants ((idx idx)) - (build-term - ($continue k* #f ($primcall op (self idx))))))))))) + (let ((idx (intset-find free var))) + (cond + (self-known? + (with-cps cps + (letv var* u64) + (let$ body (k var*)) + (letk k* ($kargs (#f) (var*) ,body)) + (letk kunbox ($kargs ('idx) (u64) + ($continue k* #f + ($primcall 'vector-ref (self u64))))) + ($ (with-cps-constants ((idx idx)) + (build-term + ($continue kunbox #f + ($primcall 'scm->u64 (idx)))))))) + (else + (with-cps cps + (letv var*) + (let$ body (k var*)) + (letk k* ($kargs (#f) (var*) ,body)) + ($ (with-cps-constants ((idx idx)) + (build-term + ($continue k* #f + ($primcall 'free-ref (self idx))))))))))))) (else (with-cps cps ($ (k var)))))) @@ -541,12 +552,15 @@ term." (#(#t nfree) (unless (> nfree 2) (error "unexpected well-known nullary, unary, or binary closure")) - (let ((op (if (<= nfree #xff) 'make-vector/immediate 'make-vector))) - (with-cps cps - ($ (with-cps-constants ((nfree nfree) - (false #f)) - (build-term - ($continue k src ($primcall op (nfree false))))))))))) + (with-cps cps + ($ (with-cps-constants ((nfree nfree) + (false #f)) + (letv u64) + (letk kunbox ($kargs ('nfree) (u64) + ($continue k src + ($primcall 'make-vector (u64 false))))) + (build-term + ($continue kunbox src ($primcall 'scm->u64 (nfree)))))))))) (define (init-closure cps k src var known? free) "Initialize the free variables @var{closure-free} in a closure @@ -587,15 +601,25 @@ bound to @var{var}, and continue to @var{k}." (letk k ($kargs () () ,body)) ($ (convert-arg v (lambda (cps v) - (let ((op (cond - ((not known?) 'free-set!) - ((<= idx #xff) 'vector-set!/immediate) - (else 'vector-set!)))) + (cond + (known? + (with-cps cps + (letv u64) + (letk kunbox + ($kargs ('idx) (u64) + ($continue k src + ($primcall 'vector-set! (var u64 v))))) + ($ (with-cps-constants ((idx idx)) + (build-term + ($continue kunbox src + ($primcall 'scm->u64 (idx)))))))) + (else (with-cps cps ($ (with-cps-constants ((idx idx)) (build-term ($continue k src - ($primcall op (var idx v)))))))))))))))))) + ($primcall 'free-set! + (var idx v))))))))))))))))))) (define (make-single-closure cps k src kfun) (let ((free (intmap-ref free-vars kfun))) diff --git a/module/language/cps/constructors.scm b/module/language/cps/constructors.scm index f86095198..170f0f17d 100644 --- a/module/language/cps/constructors.scm +++ b/module/language/cps/constructors.scm @@ -61,17 +61,25 @@ (with-cps out (let$ next (initialize vec args (1+ n))) (letk knext ($kargs () () ,next)) + (letv u64) + (letk kunbox ($kargs ('idx) (u64) + ($continue knext src + ($primcall 'vector-set! (vec u64 arg))))) ($ (with-cps-constants ((idx n)) - (build-term ($continue knext src - ($primcall 'vector-set! (vec idx arg)))))))))) + (build-term ($continue kunbox src + ($primcall 'scm->u64 (idx)))))))))) (with-cps out (letv vec) (let$ body (initialize vec args 0)) (letk kalloc ($kargs ('vec) (vec) ,body)) ($ (with-cps-constants ((len (length args)) (init #f)) - (build-term ($continue kalloc src - ($primcall 'make-vector (len init)))))))) + (letv u64) + (letk kunbox ($kargs ('len) (u64) + ($continue kalloc src + ($primcall 'make-vector (u64 init))))) + (build-term ($continue kunbox src + ($primcall 'scm->u64 (len)))))))) (define (find-constructor-inliner name) (match name diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 304d9f711..be0d1c2c5 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -317,7 +317,7 @@ is or might be a read or a write to the same location as A." (logior &write (vector-field n constants))) (define-primitive-effects* constants ((vector . _) (&allocate &vector)) - ((make-vector n init) (&allocate &vector) &type-check) + ((make-vector n init) (&allocate &vector)) ((make-vector/immediate n init) (&allocate &vector)) ((vector-ref v n) (read-vector-field n constants) &type-check) ((vector-ref/immediate v n) (read-vector-field n constants) &type-check) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index c378bd1f5..0f5a43d43 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -800,7 +800,8 @@ are comparable with eqv?. A tmp slot may be used." 'bv-f32-ref 'bv-f64-ref 'fadd 'fsub 'fmul 'fdiv)) (intmap-add representations var 'f64)) - (($ $primcall (or 'scm->u64 'load-u64 'bv-length + (($ $primcall (or 'scm->u64 'load-u64 + 'bv-length 'vector-length 'string-length 'uadd 'usub 'umul 'uadd/immediate 'usub/immediate 'umul/immediate 'bv-u8-ref 'bv-u16-ref 'bv-u32-ref 'bv-u64-ref)) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index a5ea1bf72..6daddf0ea 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -592,26 +592,26 @@ minimum, and maximum." ;; This max-vector-len computation is a hack. (define *max-vector-len* (ash most-positive-fixnum -5)) -(define-simple-type-checker (make-vector (&exact-integer 0 *max-vector-len*) +(define-simple-type-checker (make-vector (&u64 0 *max-vector-len*) &all-types)) (define-type-inferrer (make-vector size init result) - (restrict! size &exact-integer 0 *max-vector-len*) + (restrict! size &u64 0 *max-vector-len*) (define! result &vector (max (&min size) 0) (&max size))) (define-type-checker (vector-ref v idx) (and (check-type v &vector 0 *max-vector-len*) - (check-type idx &exact-integer 0 (1- (&min v))))) + (check-type idx &u64 0 (1- (&min v))))) (define-type-inferrer (vector-ref v idx result) (restrict! v &vector (1+ (&min idx)) *max-vector-len*) - (restrict! idx &exact-integer 0 (1- (min (&max v) *max-vector-len*))) + (restrict! idx &u64 0 (1- (min (&max v) *max-vector-len*))) (define! result &all-types -inf.0 +inf.0)) (define-type-checker (vector-set! v idx val) (and (check-type v &vector 0 *max-vector-len*) - (check-type idx &exact-integer 0 (1- (&min v))))) + (check-type idx &u64 0 (1- (&min v))))) (define-type-inferrer (vector-set! v idx val) (restrict! v &vector (1+ (&min idx)) *max-vector-len*) - (restrict! idx &exact-integer 0 (1- (min (&max v) *max-vector-len*)))) + (restrict! idx &u64 0 (1- (min (&max v) *max-vector-len*)))) (define-type-aliases make-vector make-vector/immediate) (define-type-aliases vector-ref vector-ref/immediate) @@ -620,7 +620,7 @@ minimum, and maximum." (define-simple-type-checker (vector-length &vector)) (define-type-inferrer (vector-length v result) (restrict! v &vector 0 *max-vector-len*) - (define! result &exact-integer (max (&min v) 0) + (define! result &u64 (max (&min v) 0) (min (&max v) *max-vector-len*))) @@ -634,27 +634,27 @@ minimum, and maximum." ;; vt is actually a vtable. (define-type-inferrer (allocate-struct vt size result) (restrict! vt &struct vtable-offset-user *max-size-t*) - (restrict! size &exact-integer 0 *max-size-t*) + (restrict! size &u64 0 *max-size-t*) (define! result &struct (max (&min size) 0) (min (&max size) *max-size-t*))) (define-type-checker (struct-ref s idx) (and (check-type s &struct 0 *max-size-t*) - (check-type idx &exact-integer 0 *max-size-t*) + (check-type idx &u64 0 *max-size-t*) ;; FIXME: is the field readable? (< (&max idx) (&min s)))) (define-type-inferrer (struct-ref s idx result) (restrict! s &struct (1+ (&min idx)) *max-size-t*) - (restrict! idx &exact-integer 0 (1- (min (&max s) *max-size-t*))) + (restrict! idx &u64 0 (1- (min (&max s) *max-size-t*))) (define! result &all-types -inf.0 +inf.0)) (define-type-checker (struct-set! s idx val) (and (check-type s &struct 0 *max-size-t*) - (check-type idx &exact-integer 0 *max-size-t*) + (check-type idx &u64 0 *max-size-t*) ;; FIXME: is the field writable? (< (&max idx) (&min s)))) (define-type-inferrer (struct-set! s idx val) (restrict! s &struct (1+ (&min idx)) *max-size-t*) - (restrict! idx &exact-integer 0 (1- (min (&max s) *max-size-t*)))) + (restrict! idx &u64 0 (1- (min (&max s) *max-size-t*)))) (define-type-aliases allocate-struct allocate-struct/immediate) (define-type-aliases struct-ref struct-ref/immediate) @@ -674,11 +674,11 @@ minimum, and maximum." (define-type-checker (string-ref s idx) (and (check-type s &string 0 *max-size-t*) - (check-type idx &exact-integer 0 *max-size-t*) + (check-type idx &u64 0 *max-size-t*) (< (&max idx) (&min s)))) (define-type-inferrer (string-ref s idx result) (restrict! s &string (1+ (&min idx)) *max-size-t*) - (restrict! idx &exact-integer 0 (1- (min (&max s) *max-size-t*))) + (restrict! idx &u64 0 (1- (min (&max s) *max-size-t*))) (define! result &char 0 *max-char*)) (define-type-checker (string-set! s idx val) @@ -694,7 +694,7 @@ minimum, and maximum." (define-simple-type-checker (string-length &string)) (define-type-inferrer (string-length s result) (restrict! s &string 0 *max-size-t*) - (define! result &exact-integer (max (&min s) 0) (min (&max s) *max-size-t*))) + (define! result &u64 (max (&min s) 0) (min (&max s) *max-size-t*))) (define-simple-type (number->string &number) (&string 0 *max-size-t*)) (define-simple-type (string->number (&string 0 *max-size-t*)) @@ -753,7 +753,7 @@ minimum, and maximum." (define-simple-type-checker (bv-length &bytevector)) (define-type-inferrer (bv-length bv result) (restrict! bv &bytevector 0 *max-size-t*) - (define! result &exact-integer + (define! result &u64 (max (&min bv) 0) (min (&max bv) *max-size-t*))) (define-syntax-rule (define-bytevector-accessors ref set type size lo hi) @@ -773,7 +773,7 @@ minimum, and maximum." (< (&max idx) (- (&min bv) size)))) (define-type-inferrer (set! bv idx val) (restrict! bv &bytevector (+ (&min idx) size) *max-size-t*) - (restrict! idx &exact-integer 0 (- (min (&max bv) *max-size-t*) size)) + (restrict! idx &u64 0 (- (min (&max bv) *max-size-t*) size)) (restrict! val type lo hi)))) (define-bytevector-accessors bv-u8-ref bv-u8-set! &u64 1 0 #xff) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index c1f976ae0..57c52aa1d 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -576,7 +576,9 @@ (letk kbox ($kargs ('f64) (f64) ($continue k src ($primcall 'f64->scm (f64))))) kbox)) - ((bv-length bv-u8-ref bv-u16-ref bv-u32-ref bv-u64-ref) + ((string-length + vector-length + bv-length bv-u8-ref bv-u16-ref bv-u32-ref bv-u64-ref) (with-cps cps (letv u64) (let$ k (adapt-arity k src out)) @@ -640,6 +642,34 @@ cps val 'scm->u64 (lambda (cps val) (have-args cps (list bv idx val))))))))) + ((vector-ref struct-ref string-ref) + (match args + ((obj idx) + (unbox-arg + cps idx 'scm->u64 + (lambda (cps idx) + (have-args cps (list obj idx))))))) + ((vector-set! struct-set!) + (match args + ((obj idx val) + (unbox-arg + cps idx 'scm->u64 + (lambda (cps idx) + (have-args cps (list obj idx val))))))) + ((make-vector) + (match args + ((length init) + (unbox-arg + cps length 'scm->u64 + (lambda (cps length) + (have-args cps (list length init))))))) + ((allocate-struct) + (match args + ((vtable nfields) + (unbox-arg + cps nfields 'scm->u64 + (lambda (cps nfields) + (have-args cps (list vtable nfields))))))) (else (have-args cps args)))) (convert-args cps args (lambda (cps args) From 8c75a5eb1b7d75e427953c061fbd8f445cfcc0d8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 27 Nov 2015 16:32:14 +0100 Subject: [PATCH 138/865] Add current-thread VM op * libguile/vm-engine.c (current-thread): New op. * module/language/cps/effects-analysis.scm (&thread): New memory kind. * module/language/cps/compile-bytecode.scm (compile-function): * module/language/cps/effects-analysis.scm (current-thread): * module/language/cps/types.scm (current-thread): * module/language/tree-il/primitives.scm (*interesting-primitive-names*): * module/system/vm/assembler.scm (emit-current-thread): Wire up the new op. --- libguile/vm-engine.c | 15 ++++++++++++++- module/language/cps/compile-bytecode.scm | 2 ++ module/language/cps/effects-analysis.scm | 10 ++++++++++ module/language/cps/types.scm | 10 ++++++++++ module/language/tree-il/primitives.scm | 2 +- module/system/vm/assembler.scm | 1 + 6 files changed, 38 insertions(+), 2 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 6b2458f0b..991280b0c 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -3468,7 +3468,20 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (3); } - VM_DEFINE_OP (160, unused_160, NULL, NOP) + /* current-thread dst:24 + * + * Write the current thread into DST. + */ + VM_DEFINE_OP (160, current_thread, "current-thread", OP1 (X8_S24) | OP_DST) + { + scm_t_uint32 dst; + + UNPACK_24 (op, dst); + SP_SET (dst, thread->handle); + + NEXT (1); + } + VM_DEFINE_OP (161, unused_161, NULL, NOP) VM_DEFINE_OP (162, unused_162, NULL, NOP) VM_DEFINE_OP (163, unused_163, NULL, NOP) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index ad7d8877b..8d1c8ee6f 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -140,6 +140,8 @@ (emit-make-closure asm (from-sp dst) k nfree)) (($ $primcall 'current-module) (emit-current-module asm (from-sp dst))) + (($ $primcall 'current-thread) + (emit-current-thread asm (from-sp dst))) (($ $primcall 'cached-toplevel-box (scope name bound?)) (emit-cached-toplevel-box asm (from-sp dst) (constant scope) (constant name) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index be0d1c2c5..5821c5d0a 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -62,6 +62,7 @@ &module &struct &string + &thread &bytevector &closure @@ -170,6 +171,9 @@ ;; Indicates that an expression depends on the current module. &module + ;; Indicates that an expression depends on the current thread. + &thread + ;; Indicates that an expression depends on the value of a struct ;; field. The effect field indicates the specific field, or zero for ;; an unknown field. @@ -285,6 +289,12 @@ is or might be a read or a write to the same location as A." ((push-fluid f v) (&write-object &fluid) &type-check) ((pop-fluid) (&write-object &fluid) &type-check)) +;; Threads. Calls cause &all-effects, which reflects the fact that any +;; call can capture a partial continuation and reinstate it on another +;; thread. +(define-primitive-effects + ((current-thread) (&read-object &thread))) + ;; Prompts. (define-primitive-effects ((make-prompt-tag #:optional arg) (&allocate &unknown-memory-kinds))) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 6daddf0ea..0c46d36f7 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -547,6 +547,16 @@ minimum, and maximum." ((pop-fluid))) + + +;;; +;;; Threads. We don't currently track threads as an object type. +;;; + +(define-simple-types + ((current-thread) &all-types)) + + ;;; diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 57072d4d9..724f38416 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -83,7 +83,7 @@ current-module define! - fluid-ref fluid-set! with-fluid* + current-thread fluid-ref fluid-set! with-fluid* call-with-prompt abort-to-prompt* abort-to-prompt diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 0e4bbf06c..564ec0665 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -116,6 +116,7 @@ emit-unwind (emit-push-fluid* . emit-push-fluid) emit-pop-fluid + emit-current-thread (emit-fluid-ref* . emit-fluid-ref) (emit-fluid-set* . emit-fluid-set) (emit-string-length* . emit-string-length) From 82085252ec278e3c12271a038e7ae96ae23e3673 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 30 Nov 2015 11:54:19 +0100 Subject: [PATCH 139/865] Add logsub op. * libguile/vm-engine.c (logsub): New op. * module/language/cps/effects-analysis.scm (logsub): * module/language/cps/types.scm (logsub): * module/system/vm/assembler.scm (system): Add support for the new op. * module/language/tree-il/compile-cps.scm (canonicalize): Rewrite (logand x (lognot y)) to (logsub x y). --- libguile/vm-engine.c | 22 ++++++++++++++++++++- module/language/cps/effects-analysis.scm | 1 + module/language/cps/types.scm | 25 ++++++++++++++++++++++++ module/language/tree-il/compile-cps.scm | 10 ++++++++++ module/system/vm/assembler.scm | 1 + 5 files changed, 58 insertions(+), 1 deletion(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 991280b0c..33d2b7b52 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -3482,7 +3482,27 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (1); } - VM_DEFINE_OP (161, unused_161, NULL, NOP) + /* logsub dst:8 a:8 b:8 + * + * Place the bitwise AND of A and the bitwise NOT of B into DST. + */ + VM_DEFINE_OP (161, logsub, "logsub", OP1 (X8_S8_S8_S8) | OP_DST) + { + ARGS2 (x, y); + + if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) + { + scm_t_signed_bits a, b; + + a = SCM_I_INUM (x); + b = SCM_I_INUM (y); + + RETURN (SCM_I_MAKINUM (a & ~b)); + } + + RETURN_EXP (scm_logand (x, scm_lognot (y))); + } + VM_DEFINE_OP (162, unused_162, NULL, NOP) VM_DEFINE_OP (163, unused_163, NULL, NOP) VM_DEFINE_OP (164, unused_164, NULL, NOP) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 5821c5d0a..7018a11f2 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -465,6 +465,7 @@ is or might be a read or a write to the same location as A." ((logand . _) &type-check) ((logior . _) &type-check) ((logxor . _) &type-check) + ((logsub . _) &type-check) ((lognot . _) &type-check) ((logtest a b) &type-check) ((logbit? a b) &type-check) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 0c46d36f7..3f13d92f5 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -1212,6 +1212,31 @@ minimum, and maximum." (logand-min (&min a) (&min b)) (logand-max (&max a) (&max b)))) +(define-simple-type-checker (logsub &exact-integer &exact-integer)) +(define-type-inferrer (logsub a b result) + (define (logsub-bounds min-a max-a min-b max-b) + (cond + ((negative? max-b) + ;; Sign bit always set on B, so result will never be negative. + ;; If A might be negative (all leftmost bits 1), we don't know + ;; how positive the result might be. + (values 0 (if (negative? min-a) +inf.0 max-a))) + ((negative? min-b) + ;; Sign bit might be set on B. + (values min-a (if (negative? min-a) +inf.0 max-a))) + ((negative? min-a) + ;; Sign bit never set on B -- result will have the sign of A. + (values min-a (if (negative? max-a) -1 max-a))) + (else + ;; Sign bit never set on A and never set on B -- the nice case. + (values 0 max-a)))) + (restrict! a &exact-integer -inf.0 +inf.0) + (restrict! b &exact-integer -inf.0 +inf.0) + (call-with-values (lambda () + (logsub-bounds (&min a) (&max a) (&min b) (&max b))) + (lambda (min max) + (define! result &exact-integer min max)))) + (define-simple-type-checker (logior &exact-integer &exact-integer)) (define-type-inferrer (logior a b result) ;; Saturate all bits of val. diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 57c52aa1d..5fa60109a 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -1012,6 +1012,16 @@ integer." (make-lexical-ref src 'v v))) (make-lexical-ref src 'v v))))) + ;; Lower (logand x (lognot y)) to (logsub x y). We do it here + ;; instead of in CPS because it gets rid of the lognot entirely; + ;; if type folding can't prove Y to be an exact integer, then DCE + ;; would have to leave it in the program for its possible + ;; effects. + (($ src 'logand (x ($ _ 'lognot (y)))) + (make-primcall src 'logsub (list x y))) + (($ src 'logand (($ _ 'lognot (y)) x)) + (make-primcall src 'logsub (list x y))) + (($ src escape-only? tag body ($ hsrc hmeta ($ _ hreq #f hrest #f () hsyms hbody #f))) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 564ec0665..3f08d7e68 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -152,6 +152,7 @@ (emit-logand* . emit-logand) (emit-logior* . emit-logior) (emit-logxor* . emit-logxor) + (emit-logsub* . emit-logsub) (emit-make-vector* . emit-make-vector) (emit-make-vector/immediate* . emit-make-vector/immediate) (emit-vector-length* . emit-vector-length) From eb86afcc7aaa8122cc1474c7246186d6bbe3c15c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Dec 2015 10:48:04 +0100 Subject: [PATCH 140/865] Disable warnings on bootstrap build * bootstrap/Makefile.am (GUILE_WARNINGS): Don't enable warnings for the bootstrap build, as they probably slow things down. --- bootstrap/Makefile.am | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/bootstrap/Makefile.am b/bootstrap/Makefile.am index 2d9caac38..e9b3895bf 100644 --- a/bootstrap/Makefile.am +++ b/bootstrap/Makefile.am @@ -22,7 +22,10 @@ GOBJECTS = $(SOURCES:%.scm=%.go) -GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat +# No warnings for the bootstrap build. Run +# make GUILE_WARNINGS="-Wunbound-variable -Warity-mismatch -Wformat" +# to get the normal set of warnings. +GUILE_WARNINGS = GUILE_OPTIMIZATIONS = -O1 nobase_noinst_DATA = $(GOBJECTS) ice-9/eval.go CLEANFILES = $(GOBJECTS) ice-9/eval.go ice-9/psyntax-pp.go From 3d6dd2f81c02c37ec027e49ad25ddc57c7fbf0d1 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Dec 2015 10:51:00 +0100 Subject: [PATCH 141/865] Add untagged bitwise operations * libguile/vm-engine.c (ulogand, ulogior, ulogsub, ulsh, ursh) (scm->u64/truncate): New ops. * module/language/cps/compile-bytecode.scm (compile-function): * module/language/cps/effects-analysis.scm: * module/language/cps/slot-allocation.scm (compute-var-representations): * module/language/cps/specialize-primcalls.scm (specialize-primcalls): * module/language/cps/types.scm: * module/language/cps/utils.scm (compute-constant-values): * module/system/vm/assembler.scm: Wire up support for the new ops. --- libguile/vm-engine.c | 112 ++++++++++++++++++- module/language/cps/compile-bytecode.scm | 2 + module/language/cps/effects-analysis.scm | 6 + module/language/cps/slot-allocation.scm | 3 +- module/language/cps/specialize-primcalls.scm | 1 + module/language/cps/types.scm | 47 +++++++- module/language/cps/utils.scm | 2 +- module/system/vm/assembler.scm | 6 + 8 files changed, 170 insertions(+), 9 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 33d2b7b52..99ff7804f 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -3503,12 +3503,112 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, RETURN_EXP (scm_logand (x, scm_lognot (y))); } - VM_DEFINE_OP (162, unused_162, NULL, NOP) - VM_DEFINE_OP (163, unused_163, NULL, NOP) - VM_DEFINE_OP (164, unused_164, NULL, NOP) - VM_DEFINE_OP (165, unused_165, NULL, NOP) - VM_DEFINE_OP (166, unused_166, NULL, NOP) - VM_DEFINE_OP (167, unused_167, NULL, NOP) + /* ulogand dst:8 a:8 b:8 + * + * Place the bitwise AND of the u64 values in A and B into DST. + */ + VM_DEFINE_OP (162, ulogand, "ulogand", OP1 (X8_S8_S8_S8) | OP_DST) + { + scm_t_uint8 dst, a, b; + + UNPACK_8_8_8 (op, dst, a, b); + + SP_SET_U64 (dst, SP_REF_U64 (a) & SP_REF_U64 (b)); + + NEXT (1); + } + + /* ulogior dst:8 a:8 b:8 + * + * Place the bitwise inclusive OR of the u64 values in A and B into + * DST. + */ + VM_DEFINE_OP (163, ulogior, "ulogior", OP1 (X8_S8_S8_S8) | OP_DST) + { + scm_t_uint8 dst, a, b; + + UNPACK_8_8_8 (op, dst, a, b); + + SP_SET_U64 (dst, SP_REF_U64 (a) | SP_REF_U64 (b)); + + NEXT (1); + } + + /* ulogsub dst:8 a:8 b:8 + * + * Place the (A & ~B) of the u64 values A and B into DST. + */ + VM_DEFINE_OP (164, ulogsub, "ulogsub", OP1 (X8_S8_S8_S8) | OP_DST) + { + scm_t_uint8 dst, a, b; + + UNPACK_8_8_8 (op, dst, a, b); + + SP_SET_U64 (dst, SP_REF_U64 (a) & ~SP_REF_U64 (b)); + + NEXT (1); + } + + /* ursh dst:8 a:8 b:8 + * + * Shift the u64 value in A right by B bits, and place the result in + * DST. Only the lower 6 bits of B are used. + */ + VM_DEFINE_OP (165, ursh, "ursh", OP1 (X8_S8_S8_S8) | OP_DST) + { + scm_t_uint8 dst, a, b; + + UNPACK_8_8_8 (op, dst, a, b); + + SP_SET_U64 (dst, SP_REF_U64 (a) >> (SP_REF_U64 (b) & 63)); + + NEXT (1); + } + + /* ulsh dst:8 a:8 b:8 + * + * Shift the u64 value in A left by B bits, and place the result in + * DST. Only the lower 6 bits of B are used. + */ + VM_DEFINE_OP (166, ulsh, "ulsh", OP1 (X8_S8_S8_S8) | OP_DST) + { + scm_t_uint8 dst, a, b; + + UNPACK_8_8_8 (op, dst, a, b); + + SP_SET_U64 (dst, SP_REF_U64 (a) << (SP_REF_U64 (b) & 63)); + + NEXT (1); + } + + /* scm->u64/truncate dst:12 src:12 + * + * Unpack an exact integer from SRC and place it in the unsigned + * 64-bit register DST, truncating any high bits. If the number in + * SRC is negative, all the high bits will be set. + */ + VM_DEFINE_OP (167, scm_to_u64_truncate, "scm->u64/truncate", OP1 (X8_S12_S12) | OP_DST) + { + scm_t_uint16 dst, src; + SCM x; + + UNPACK_12_12 (op, dst, src); + SYNC_IP (); + x = SP_REF (src); + + if (SCM_I_INUMP (x)) + SP_SET_U64 (dst, (scm_t_uint64) SCM_I_INUM (x)); + else + { + SYNC_IP (); + SP_SET_U64 (dst, + scm_to_uint64 + (scm_logand (x, scm_from_uint64 ((scm_t_uint64) -1)))); + } + + NEXT (1); + } + VM_DEFINE_OP (168, unused_168, NULL, NOP) VM_DEFINE_OP (169, unused_169, NULL, NOP) VM_DEFINE_OP (170, unused_170, NULL, NOP) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 8d1c8ee6f..d4a534598 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -204,6 +204,8 @@ (emit-f64->scm asm (from-sp dst) (from-sp (slot src)))) (($ $primcall 'scm->u64 (src)) (emit-scm->u64 asm (from-sp dst) (from-sp (slot src)))) + (($ $primcall 'scm->u64/truncate (src)) + (emit-scm->u64/truncate asm (from-sp dst) (from-sp (slot src)))) (($ $primcall 'load-u64 (src)) (emit-load-u64 asm (from-sp dst) (constant src))) (($ $primcall 'u64->scm (src)) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 7018a11f2..fb64cac21 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -367,6 +367,7 @@ is or might be a read or a write to the same location as A." ((load-f64 _)) ((f64->scm _)) ((scm->u64 _) &type-check) + ((scm->u64/truncate _) &type-check) ((load-u64 _)) ((u64->scm _)) ((scm->s64 _) &type-check) @@ -467,6 +468,11 @@ is or might be a read or a write to the same location as A." ((logxor . _) &type-check) ((logsub . _) &type-check) ((lognot . _) &type-check) + ((ulogand . _)) + ((ulogior . _)) + ((ulogsub . _)) + ((ursh . _)) + ((ulsh . _)) ((logtest a b) &type-check) ((logbit? a b) &type-check) ((sqrt _) &type-check) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 0f5a43d43..dd860bea7 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -800,9 +800,10 @@ are comparable with eqv?. A tmp slot may be used." 'bv-f32-ref 'bv-f64-ref 'fadd 'fsub 'fmul 'fdiv)) (intmap-add representations var 'f64)) - (($ $primcall (or 'scm->u64 'load-u64 + (($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64 'bv-length 'vector-length 'string-length 'uadd 'usub 'umul + 'ulogand 'ulogior 'ulogsub 'ursh 'ulsh 'uadd/immediate 'usub/immediate 'umul/immediate 'bv-u8-ref 'bv-u16-ref 'bv-u32-ref 'bv-u64-ref)) (intmap-add representations var 'u64)) diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm index 59c3055c3..710cc32a1 100644 --- a/module/language/cps/specialize-primcalls.scm +++ b/module/language/cps/specialize-primcalls.scm @@ -66,6 +66,7 @@ (('umul (? u8? x) y) (build-exp ($primcall 'umul/immediate (y x)))) (('scm->f64 (? f64?)) (rename 'load-f64)) (('scm->u64 (? u64?)) (rename 'load-u64)) + (('scm->u64/truncate (? u64?)) (rename 'load-u64)) (('scm->s64 (? s64?)) (rename 'load-s64)) (_ #f))) (intmap-map diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 3f13d92f5..6b035dc41 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -733,9 +733,15 @@ minimum, and maximum." (check-type scm &exact-integer 0 #xffffffffffffffff)) (define-type-inferrer (scm->u64 scm result) (restrict! scm &exact-integer 0 #xffffffffffffffff) - (define! result &u64 (max (&min scm) 0) (min (&max scm) #xffffffffffffffff))) + (define! result &u64 (max (&min scm) 0) (min (&max scm) &u64-max))) (define-type-aliases scm->u64 load-u64) +(define-type-checker (scm->u64/truncate scm) + (check-type scm &exact-integer &range-min &range-max)) +(define-type-inferrer (scm->u64/truncate scm result) + (restrict! scm &exact-integer &range-min &range-max) + (define! result &u64 0 &u64-max)) + (define-type-checker (u64->scm u64) #t) (define-type-inferrer (u64->scm u64 result) @@ -1190,6 +1196,25 @@ minimum, and maximum." (min -- -+ ++ +-) (max -- -+ ++ +-)))) +(define-simple-type-checker (ursh &u64 &u64)) +(define-type-inferrer (ursh a b result) + (restrict! a &u64 0 &u64-max) + (restrict! b &u64 0 &u64-max) + (define! result &u64 + (ash (&min a) (- (&max b))) + (ash (&max a) (- (&min b))))) + +(define-simple-type-checker (ulsh &u64 &u64)) +(define-type-inferrer (ulsh a b result) + (restrict! a &u64 0 &u64-max) + (restrict! b &u64 0 &u64-max) + (if (and (< (&max b) 64) + (<= (ash (&max a) (&max b)) &u64-max)) + ;; No overflow; we can be precise. + (define! result &u64 (ash (&min a) (&min b)) (ash (&max a) (&max b))) + ;; Otherwise assume the whole range. + (define! result &u64 0 &u64-max))) + (define (next-power-of-two n) (let lp ((out 1)) (if (< n out) @@ -1212,6 +1237,12 @@ minimum, and maximum." (logand-min (&min a) (&min b)) (logand-max (&max a) (&max b)))) +(define-simple-type-checker (ulogand &u64 &u64)) +(define-type-inferrer (ulogand a b result) + (restrict! a &u64 0 &u64-max) + (restrict! b &u64 0 &u64-max) + (define! result &u64 0 (max (&max a) (&max b)))) + (define-simple-type-checker (logsub &exact-integer &exact-integer)) (define-type-inferrer (logsub a b result) (define (logsub-bounds min-a max-a min-b max-b) @@ -1237,6 +1268,12 @@ minimum, and maximum." (lambda (min max) (define! result &exact-integer min max)))) +(define-simple-type-checker (ulogsub &u64 &u64)) +(define-type-inferrer (ulogsub a b result) + (restrict! a &u64 0 &u64-max) + (restrict! b &u64 0 &u64-max) + (define! result &u64 0 (&max a))) + (define-simple-type-checker (logior &exact-integer &exact-integer)) (define-type-inferrer (logior a b result) ;; Saturate all bits of val. @@ -1258,6 +1295,14 @@ minimum, and maximum." (logior-min (&min a) (&min b)) (logior-max (&max a) (&max b)))) +(define-simple-type-checker (ulogior &u64 &u64)) +(define-type-inferrer (ulogior a b result) + (restrict! a &u64 0 &u64-max) + (restrict! b &u64 0 &u64-max) + (define! result &u64 + (max (&min a) (&min b)) + (1- (next-power-of-two (logior (&max a) (&max b)))))) + ;; For our purposes, treat logxor the same as logior. (define-type-aliases logior logxor) diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm index 750fd17b1..64b403dbc 100644 --- a/module/language/cps/utils.scm +++ b/module/language/cps/utils.scm @@ -214,7 +214,7 @@ disjoint, an error will be signalled." (if (and f64 (number? f64) (inexact? f64) (real? f64)) (intmap-add! out var f64) out))) - (($ $primcall 'scm->u64 (val)) + (($ $primcall (or 'scm->u64 'scm->u64/truncate) (val)) (let ((u64 (intmap-ref out val (lambda (_) #f)))) (if (and u64 (number? u64) (exact-integer? u64) (<= 0 u64 #xffffFFFFffffFFFF)) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 3f08d7e68..f94d0f0a9 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -153,6 +153,11 @@ (emit-logior* . emit-logior) (emit-logxor* . emit-logxor) (emit-logsub* . emit-logsub) + (emit-ulogand* . emit-ulogand) + (emit-ulogior* . emit-ulogior) + (emit-ulogsub* . emit-ulogsub) + (emit-ursh* . emit-ursh) + (emit-ulsh* . emit-ulsh) (emit-make-vector* . emit-make-vector) (emit-make-vector/immediate* . emit-make-vector/immediate) (emit-vector-length* . emit-vector-length) @@ -173,6 +178,7 @@ emit-load-f64 (emit-f64->scm* . emit-f64->scm) (emit-scm->u64* . emit-scm->u64) + (emit-scm->u64/truncate* . emit-scm->u64/truncate) emit-load-u64 (emit-u64->scm* . emit-u64->scm) (emit-scm->s64* . emit-scm->s64) From 73065c7131df2bed82c32338767800192d6d5fc6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Dec 2015 10:53:25 +0100 Subject: [PATCH 142/865] Specialize u64 bit operations * module/language/cps/specialize-numbers.scm (specialize-u64-binop): (specialize-operations): Specialize u64 bit operations. --- module/language/cps/specialize-numbers.scm | 97 ++++++++++++++++++++-- 1 file changed, 89 insertions(+), 8 deletions(-) diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm index 8d6240f5f..6546c73c7 100644 --- a/module/language/cps/specialize-numbers.scm +++ b/module/language/cps/specialize-numbers.scm @@ -81,11 +81,18 @@ ($continue kunbox-b src ($primcall 'scm->f64 (a))))))) -(define (specialize-u64-binop cps k src op a b) +(define* (specialize-u64-binop cps k src op a b #:key + (unbox-a 'scm->u64) + (unbox-b 'scm->u64)) (let ((uop (match op ('add 'uadd) ('sub 'usub) - ('mul 'umul)))) + ('mul 'umul) + ('logand 'ulogand) + ('logior 'ulogior) + ('logsub 'ulogsub) + ('rsh 'ursh) + ('lsh 'ulsh)))) (with-cps cps (letv u64-a u64-b result) (letk kbox ($kargs ('result) (result) @@ -96,10 +103,10 @@ ($primcall uop (u64-a u64-b))))) (letk kunbox-b ($kargs ('u64-a) (u64-a) ($continue kop src - ($primcall 'scm->u64 (b))))) + ($primcall unbox-b (b))))) (build-term ($continue kunbox-b src - ($primcall 'scm->u64 (a))))))) + ($primcall unbox-a (a))))))) (define (specialize-u64-comparison cps kf kt src op a b) (let ((op (symbol-append 'u64- op))) @@ -151,6 +158,79 @@ (else cps)) types)))))) + (($ $kargs names vars + ($ $continue k src ($ $primcall 'ash (a b)))) + (match (intmap-ref cps k) + (($ $kargs (_) (result)) + (call-with-values (lambda () + (lookup-post-type types label result 0)) + (lambda (type min max) + (call-with-values (lambda () + (lookup-pre-type types label b)) + (lambda (b-type b-min b-max) + (values + (cond + ((or (not (eqv? type &exact-integer)) + (not (<= 0 min max #xffffffffffffffff)) + (not (u64-operand? a)) + (not (eqv? b-type &exact-integer)) + (< b-min 0 b-max) + (<= b-min -64) + (<= 64 b-max)) + cps) + ((and (< b-min 0) (= b-min b-max)) + (with-cps cps + (let$ body + (with-cps-constants ((bits (- b-min))) + ($ (specialize-u64-binop k src 'rsh a bits)))) + (setk label ($kargs names vars ,body)))) + ((< b-min 0) + (with-cps cps + (let$ body + (with-cps-constants ((zero 0)) + (letv bits) + (let$ body + (specialize-u64-binop k src 'rsh a bits)) + (letk kneg ($kargs ('bits) (bits) ,body)) + (build-term + ($continue kneg src + ($primcall 'sub (zero b)))))) + (setk label ($kargs names vars ,body)))) + (else + (with-cps cps + (let$ body (specialize-u64-binop k src 'lsh a b)) + (setk label ($kargs names vars ,body))))) + types)))))))) + (($ $kargs names vars + ($ $continue k src + ($ $primcall (and op (or 'logand 'logior 'logsub)) (a b)))) + (match (intmap-ref cps k) + (($ $kargs (_) (result)) + (call-with-values (lambda () + (lookup-post-type types label result 0)) + (lambda (type min max) + (values + (cond + ((and (eqv? type &exact-integer) + (<= 0 min max #xffffffffffffffff)) + ;; If we know the result is a u64, then any + ;; out-of-range bits won't affect the result and so we + ;; can project the operands onto u64. + (with-cps cps + (let$ body + (specialize-u64-binop k src op a b + #:unbox-a + (if (u64-operand? a) + 'scm->u64 + 'scm->u64/truncate) + #:unbox-b + (if (u64-operand? b) + 'scm->u64 + 'scm->u64/truncate))) + (setk label ($kargs names vars ,body)))) + (else + cps)) + types)))))) (($ $kargs names vars ($ $continue k src ($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) (a b))))) @@ -184,7 +264,7 @@ ;; include an unbox operation. (define (compute-specializable-vars cps body preds defs exp-result-unboxable? - unbox-op) + unbox-ops) ;; Compute a map of VAR->LABEL... indicating the set of labels that ;; define VAR with unboxable values, given the set of vars ;; UNBOXABLE-VARS which is known already to be unboxable. @@ -238,7 +318,7 @@ (match (intmap-ref cps label) (($ $kargs _ _ ($ $continue k _ exp)) (match exp - (($ $primcall (? (lambda (op) (eq? op unbox-op))) (var)) + (($ $primcall (? (lambda (op) (memq op unbox-ops))) (var)) (intset-add unbox-uses var)) (($ $values vars) (match (intmap-ref cps k) @@ -271,7 +351,7 @@ ($ $const (and (? number?) (? inexact?) (? real?)))) #t) (_ #f))) - (compute-specializable-vars cps body preds defs exp-result-f64? 'scm->f64)) + (compute-specializable-vars cps body preds defs exp-result-f64? '(scm->f64))) ;; Compute vars whose definitions are all exact integers in the u64 ;; range and whose uses include an unbox operation. @@ -285,7 +365,8 @@ #t) (_ #f))) - (compute-specializable-vars cps body preds defs exp-result-u64? 'scm->u64)) + (compute-specializable-vars cps body preds defs exp-result-u64? + '(scm->u64 'scm->u64/truncate))) (define (compute-phi-vars cps preds) (intmap-fold (lambda (label preds phis) From dbd9265cc0994c30429070136708b64a75ddf20a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Dec 2015 17:04:36 +0100 Subject: [PATCH 143/865] More efficient assembler instructions * module/system/vm/assembler.scm (pack-u8-u24, pack-u8-s24): (pack-u1-u7-u24, pack-u8-u12-u12, pack-u8-u8-u16): Tweak to expose more possibilities for untagging u64 values. --- module/system/vm/assembler.scm | 95 +++++++++++++++++++++------------- 1 file changed, 60 insertions(+), 35 deletions(-) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index f94d0f0a9..e5f464ba3 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -229,57 +229,82 @@ ;;; These helpers create one 32-bit unit from multiple components. (define-inline (pack-u8-u24 x y) - (unless (<= 0 x 255) - (error "out of range" x)) - (logior x (ash y 8))) + (let ((x* (logand x #xff)) + (y* (logand y #xffffff))) + (unless (= x x*) + (error "out of range" x)) + (unless (= y y*) + (error "out of range" y)) + (logior x* (ash y* 8)))) (define-inline (pack-u8-s24 x y) - (unless (<= 0 x 255) - (error "out of range" x)) - (logior x (ash (cond - ((< 0 (- y) #x800000) - (+ y #x1000000)) - ((<= 0 y #xffffff) - y) - (else (error "out of range" y))) - 8))) + (let ((x* (logand x #xff)) + (y* (logand y #xffffff))) + (unless (= x x*) + (error "out of range" x)) + (unless (if (< y* #x800000) + (= y y*) + (= (+ y #x1000000) y*)) + (error "out of range" y)) + (logior x* (ash y* 8)))) (define-inline (pack-u1-u7-u24 x y z) - (unless (<= 0 x 1) - (error "out of range" x)) - (unless (<= 0 y 127) - (error "out of range" y)) - (logior x (ash y 1) (ash z 8))) + (let ((x* (logand x #x1)) + (y* (logand y #x7f)) + (z* (logand z #xffffff))) + (unless (= x x*) + (error "out of range" x)) + (unless (= y y*) + (error "out of range" y)) + (unless (= z z*) + (error "out of range" z)) + (logior x* (ash y* 1) (ash z* 8)))) (define-inline (pack-u8-u12-u12 x y z) - (unless (<= 0 x 255) - (error "out of range" x)) - (unless (<= 0 y 4095) - (error "out of range" y)) - (logior x (ash y 8) (ash z 20))) + (let ((x* (logand x #xff)) + (y* (logand y #xfff)) + (z* (logand z #xfff))) + (unless (= x x*) + (error "out of range" x)) + (unless (= y y*) + (error "out of range" y)) + (unless (= z z*) + (error "out of range" z)) + (logior x* (ash y* 8) (ash z* 20)))) (define-inline (pack-u8-u8-u16 x y z) - (unless (<= 0 x 255) - (error "out of range" x)) - (unless (<= 0 y 255) - (error "out of range" y)) - (logior x (ash y 8) (ash z 16))) + (let ((x* (logand x #xff)) + (y* (logand y #xff)) + (z* (logand z #xffff))) + (unless (= x x*) + (error "out of range" x)) + (unless (= y y*) + (error "out of range" y)) + (unless (= z z*) + (error "out of range" z)) + (logior x* (ash y* 8) (ash z* 16)))) (define-inline (pack-u8-u8-u8-u8 x y z w) - (unless (<= 0 x 255) - (error "out of range" x)) - (unless (<= 0 y 255) - (error "out of range" y)) - (unless (<= 0 z 255) - (error "out of range" z)) - (logior x (ash y 8) (ash z 16) (ash w 24))) + (let ((x* (logand x #xff)) + (y* (logand y #xff)) + (z* (logand z #xff)) + (w* (logand w #xff))) + (unless (= x x*) + (error "out of range" x)) + (unless (= y y*) + (error "out of range" y)) + (unless (= z z*) + (error "out of range" z)) + (unless (= w w*) + (error "out of range" w)) + (logior x* (ash y* 8) (ash z* 16) (ash w* 24)))) (eval-when (expand) (define-syntax pack-flags (syntax-rules () ;; Add clauses as needed. ((pack-flags f1 f2) (logior (if f1 (ash 1 0) 0) - (if f2 (ash 2 0) 0)))))) + (if f2 (ash 1 1) 0)))))) ;;; Helpers to read and write 32-bit units in a buffer. From 246887171c436f7276464f4c84e19a21194050a2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Dec 2015 18:38:02 +0100 Subject: [PATCH 144/865] Assembler has a single growable vector * module/system/vm/assembler.scm (): Instead of writing words into a list of fixed-size buffers, use a growable vector. (expand, emit): Instead of assuming that there is enough space for only one word, check that there is space for the entire instruction at the beginning. --- module/system/vm/assembler.scm | 84 ++++++++++++---------------------- 1 file changed, 30 insertions(+), 54 deletions(-) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index e5f464ba3..ff7e53cb4 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -363,9 +363,6 @@ (high-pc arity-high-pc set-arity-high-pc!) (definitions arity-definitions set-arity-definitions!)) -(eval-when (expand) - (define-syntax *block-size* (identifier-syntax 32))) - ;;; An assembler collects all of the words emitted during assembly, and ;;; also maintains ancillary information such as the constant table, a ;;; relocation list, and so on. @@ -375,7 +372,7 @@ ;;; the bytevector as a whole instead of conditionalizing each access. ;;; (define-record-type - (make-asm cur idx start prev written + (make-asm buf pos start labels relocs word-size endianness constants inits @@ -386,10 +383,10 @@ ;; We write bytecode into what is logically a growable vector, ;; implemented as a list of blocks. asm-cur is the current block, and - ;; asm-idx is the current index into that block, in 32-bit units. + ;; asm-pos is the current index into that block, in 32-bit units. ;; - (cur asm-cur set-asm-cur!) - (idx asm-idx set-asm-idx!) + (buf asm-buf set-asm-buf!) + (pos asm-pos set-asm-pos!) ;; asm-start is an absolute position, indicating the offset of the ;; beginning of an instruction (in u32 units). It is updated after @@ -401,15 +398,6 @@ ;; (start asm-start set-asm-start!) - ;; The list of previously written blocks. - ;; - (prev asm-prev set-asm-prev!) - - ;; The number of u32 words written in asm-prev, which is the same as - ;; the offset of the current block. - ;; - (written asm-written set-asm-written!) - ;; An alist of symbol -> position pairs, indicating the labels defined ;; in this compilation unit. ;; @@ -465,15 +453,12 @@ ;; (slot-maps asm-slot-maps set-asm-slot-maps!)) -(define-inline (fresh-block) - (make-u32vector *block-size*)) - (define* (make-assembler #:key (word-size (target-word-size)) (endianness (target-endianness))) "Create an assembler for a given target @var{word-size} and @var{endianness}, falling back to appropriate values for the configured target." - (make-asm (fresh-block) 0 0 '() 0 + (make-asm (make-u32vector 1000) 0 0 (make-hash-table) '() word-size endianness vlist-null '() @@ -484,28 +469,20 @@ target." "Add a string to the section name table (shstrtab)." (string-table-intern! (asm-shstrtab asm) string)) -(define-inline (asm-pos asm) - "The offset of the next word to be written into the code buffer, in -32-bit units." - (+ (asm-idx asm) (asm-written asm))) - -(define (allocate-new-block asm) - "Close off the current block, and arrange for the next word to be -written to a fresh block." - (let ((new (fresh-block))) - (set-asm-prev! asm (cons (asm-cur asm) (asm-prev asm))) - (set-asm-written! asm (asm-pos asm)) - (set-asm-cur! asm new) - (set-asm-idx! asm 0))) +(define (grow-buffer! asm) + "Grow the code buffer of the asm." + (let* ((buf (asm-buf asm)) + (len (bytevector-length buf)) + (new (make-u32vector (ash len -1) 0))) + (bytevector-copy! buf 0 new 0 len) + (set-asm-buf! asm new) + #f)) (define-inline (emit asm u32) "Emit one 32-bit word into the instruction stream. Assumes that there -is space for the word, and ensures that there is space for the next -word." - (u32-set! (asm-cur asm) (asm-idx asm) u32) - (set-asm-idx! asm (1+ (asm-idx asm))) - (if (= (asm-idx asm) *block-size*) - (allocate-new-block asm))) +is space for the word." + (u32-set! (asm-buf asm) (asm-pos asm) u32) + (set-asm-pos! asm (1+ (asm-pos asm)))) (define-inline (make-reloc type label base word) "Make an internal relocation of type @var{type} referencing symbol @@ -674,7 +651,12 @@ later by the linker." (map (lambda (word) (pack-tail-word #'asm word)) (syntax->datum #'(word* ...))))) #'(lambda (asm formal0 ... formal* ... ...) - (unless (asm? asm) (error "not an asm")) + (let lp () + (let ((words (length '(word0 word* ...)))) + (unless (<= (* 4 (+ (asm-pos asm) words)) + (bytevector-length (asm-buf asm))) + (grow-buffer! asm) + (lp)))) code0 ... code* ... ... (reset-asm-start! asm)))))))) @@ -1630,20 +1612,14 @@ The offsets are expected to be expressed in words." "Link the .rtl-text section, swapping the endianness of the bytes if needed." (let ((buf (make-u32vector (asm-pos asm)))) - (let lp ((pos 0) (prev (reverse (asm-prev asm)))) - (if (null? prev) - (let ((byte-size (* (asm-idx asm) 4))) - (bytevector-copy! (asm-cur asm) 0 buf pos byte-size) - (unless (eq? (asm-endianness asm) (native-endianness)) - (swap-bytes! buf)) - (make-object asm '.rtl-text - buf - (process-relocs buf (asm-relocs asm) - (asm-labels asm)) - (process-labels (asm-labels asm)))) - (let ((len (* *block-size* 4))) - (bytevector-copy! (car prev) 0 buf pos len) - (lp (+ pos len) (cdr prev))))))) + (bytevector-copy! (asm-buf asm) 0 buf 0 (bytevector-length buf)) + (unless (eq? (asm-endianness asm) (native-endianness)) + (swap-bytes! buf)) + (make-object asm '.rtl-text + buf + (process-relocs buf (asm-relocs asm) + (asm-labels asm)) + (process-labels (asm-labels asm))))) From 9514dc7b95c1e8041dd1ddc84e46a2a37b178d20 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 2 Dec 2015 21:48:10 +0100 Subject: [PATCH 145/865] Add ursh/immediate and ulsh/immediate ops * libguile/vm-engine.c (ursh/immediate, ulsh/immediate): New ops. * module/language/cps/effects-analysis.scm: * module/language/cps/slot-allocation.scm (compute-var-representations) (compute-needs-slot): * module/language/cps/specialize-primcalls.scm (specialize-primcalls): * module/language/cps/compile-bytecode.scm (compile-function): * module/system/vm/assembler.scm: * module/language/cps/types.scm: Add support for new ops, and specialize ursh and ulsh. --- libguile/vm-engine.c | 34 ++++++++++++++++++-- module/language/cps/compile-bytecode.scm | 6 ++++ module/language/cps/effects-analysis.scm | 2 ++ module/language/cps/slot-allocation.scm | 4 ++- module/language/cps/specialize-primcalls.scm | 5 +++ module/language/cps/types.scm | 2 ++ module/system/vm/assembler.scm | 2 ++ 7 files changed, 52 insertions(+), 3 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 99ff7804f..c3663150f 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -3609,8 +3609,38 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (1); } - VM_DEFINE_OP (168, unused_168, NULL, NOP) - VM_DEFINE_OP (169, unused_169, NULL, NOP) + /* ursh/immediate dst:8 a:8 b:8 + * + * Shift the u64 value in A right by the immediate B bits, and place + * the result in DST. Only the lower 6 bits of B are used. + */ + VM_DEFINE_OP (168, ursh_immediate, "ursh/immediate", OP1 (X8_S8_S8_C8) | OP_DST) + { + scm_t_uint8 dst, a, b; + + UNPACK_8_8_8 (op, dst, a, b); + + SP_SET_U64 (dst, SP_REF_U64 (a) >> (b & 63)); + + NEXT (1); + } + + /* ulsh/immediate dst:8 a:8 b:8 + * + * Shift the u64 value in A left by the immediate B bits, and place + * the result in DST. Only the lower 6 bits of B are used. + */ + VM_DEFINE_OP (169, ulsh_immediate, "ulsh/immediate", OP1 (X8_S8_S8_C8) | OP_DST) + { + scm_t_uint8 dst, a, b; + + UNPACK_8_8_8 (op, dst, a, b); + + SP_SET_U64 (dst, SP_REF_U64 (a) << (b & 63)); + + NEXT (1); + } + VM_DEFINE_OP (170, unused_170, NULL, NOP) VM_DEFINE_OP (171, unused_171, NULL, NOP) VM_DEFINE_OP (172, unused_172, NULL, NOP) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index d4a534598..dc2894821 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -194,6 +194,12 @@ (($ $primcall 'umul/immediate (x y)) (emit-umul/immediate asm (from-sp dst) (from-sp (slot x)) (constant y))) + (($ $primcall 'ursh/immediate (x y)) + (emit-ursh/immediate asm (from-sp dst) (from-sp (slot x)) + (constant y))) + (($ $primcall 'ulsh/immediate (x y)) + (emit-ulsh/immediate asm (from-sp dst) (from-sp (slot x)) + (constant y))) (($ $primcall 'builtin-ref (name)) (emit-builtin-ref asm (from-sp dst) (constant name))) (($ $primcall 'scm->f64 (src)) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index fb64cac21..37fb7406d 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -473,6 +473,8 @@ is or might be a read or a write to the same location as A." ((ulogsub . _)) ((ursh . _)) ((ulsh . _)) + ((ursh/immediate . _)) + ((ulsh/immediate . _)) ((logtest a b) &type-check) ((logbit? a b) &type-check) ((sqrt _) &type-check) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index dd860bea7..6e9188aa0 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -350,7 +350,8 @@ the definitions that are live before and after LABEL, as intsets." (($ $primcall 'struct-set!/immediate (s n x)) (defs+* (intset s x))) (($ $primcall (or 'add/immediate 'sub/immediate - 'uadd/immediate 'usub/immediate 'umul/immediate) + 'uadd/immediate 'usub/immediate 'umul/immediate + 'ursh/immediate 'ulsh/immediate) (x y)) (defs+ x)) (($ $primcall 'builtin-ref (idx)) @@ -805,6 +806,7 @@ are comparable with eqv?. A tmp slot may be used." 'uadd 'usub 'umul 'ulogand 'ulogior 'ulogsub 'ursh 'ulsh 'uadd/immediate 'usub/immediate 'umul/immediate + 'ursh/immediate 'ulsh/immediate 'bv-u8-ref 'bv-u16-ref 'bv-u32-ref 'bv-u64-ref)) (intmap-add representations var 'u64)) (($ $primcall (or 'scm->s64 'load-s64 diff --git a/module/language/cps/specialize-primcalls.scm b/module/language/cps/specialize-primcalls.scm index 710cc32a1..a52e34456 100644 --- a/module/language/cps/specialize-primcalls.scm +++ b/module/language/cps/specialize-primcalls.scm @@ -33,6 +33,9 @@ (define (specialize-primcalls conts) (let ((constants (compute-constant-values conts))) + (define (u6? var) + (let ((val (intmap-ref constants var (lambda (_) #f)))) + (and (exact-integer? val) (<= 0 val 63)))) (define (u8? var) (let ((val (intmap-ref constants var (lambda (_) #f)))) (and (exact-integer? val) (<= 0 val 255)))) @@ -64,6 +67,8 @@ (('usub x (? u8? y)) (build-exp ($primcall 'usub/immediate (x y)))) (('umul x (? u8? y)) (build-exp ($primcall 'umul/immediate (x y)))) (('umul (? u8? x) y) (build-exp ($primcall 'umul/immediate (y x)))) + (('ursh x (? u6? y)) (build-exp ($primcall 'ursh/immediate (x y)))) + (('ulsh x (? u6? y)) (build-exp ($primcall 'ulsh/immediate (x y)))) (('scm->f64 (? f64?)) (rename 'load-f64)) (('scm->u64 (? u64?)) (rename 'load-u64)) (('scm->u64/truncate (? u64?)) (rename 'load-u64)) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 6b035dc41..a85617062 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -1203,6 +1203,7 @@ minimum, and maximum." (define! result &u64 (ash (&min a) (- (&max b))) (ash (&max a) (- (&min b))))) +(define-type-aliases ursh ursh/immediate) (define-simple-type-checker (ulsh &u64 &u64)) (define-type-inferrer (ulsh a b result) @@ -1214,6 +1215,7 @@ minimum, and maximum." (define! result &u64 (ash (&min a) (&min b)) (ash (&max a) (&max b))) ;; Otherwise assume the whole range. (define! result &u64 0 &u64-max))) +(define-type-aliases ulsh ulsh/immediate) (define (next-power-of-two n) (let lp ((out 1)) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index ff7e53cb4..012d6eed2 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -158,6 +158,8 @@ (emit-ulogsub* . emit-ulogsub) (emit-ursh* . emit-ursh) (emit-ulsh* . emit-ulsh) + (emit-ursh/immediate* . emit-ursh/immediate) + (emit-ulsh/immediate* . emit-ulsh/immediate) (emit-make-vector* . emit-make-vector) (emit-make-vector/immediate* . emit-make-vector/immediate) (emit-vector-length* . emit-vector-length) From 7a43a3a1813ca5a1666b2049064132a6219ef6f3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 2 Dec 2015 22:12:30 +0100 Subject: [PATCH 146/865] Refactor range checking in assembler instruction packers * module/system/vm/assembler.scm (check-urange, check-srange): New helpers. (pack-u8-u24, pack-u8-s24, pack-u1-u7-u24, pack-u8-u12-u12): (pack-u8-u8-u16, pack-u8-u8-u8-u8): Use the new helpers. Not only makes the code nicer but also reduces register pressure. --- module/system/vm/assembler.scm | 94 +++++++++++++--------------------- 1 file changed, 36 insertions(+), 58 deletions(-) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 012d6eed2..a4d5efc30 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -230,76 +230,54 @@ ;;; Bytecode consists of 32-bit units, often subdivided in some way. ;;; These helpers create one 32-bit unit from multiple components. -(define-inline (pack-u8-u24 x y) - (let ((x* (logand x #xff)) - (y* (logand y #xffffff))) +(define-inline (check-urange x mask) + (let ((x* (logand x mask))) (unless (= x x*) (error "out of range" x)) - (unless (= y y*) - (error "out of range" y)) - (logior x* (ash y* 8)))) + x*)) + +(define-inline (check-srange x mask) + (let ((x* (logand x mask))) + (unless (if (negative? x) + (= (+ x mask 1) x*) + (= x x*)) + (error "out of range" x)) + x*)) + +(define-inline (pack-u8-u24 x y) + (let ((x (check-urange x #xff)) + (y (check-urange y #xffffff))) + (logior x (ash y 8)))) (define-inline (pack-u8-s24 x y) - (let ((x* (logand x #xff)) - (y* (logand y #xffffff))) - (unless (= x x*) - (error "out of range" x)) - (unless (if (< y* #x800000) - (= y y*) - (= (+ y #x1000000) y*)) - (error "out of range" y)) - (logior x* (ash y* 8)))) + (let ((x (check-urange x #xff)) + (y (check-srange y #xffffff))) + (logior x (ash y 8)))) (define-inline (pack-u1-u7-u24 x y z) - (let ((x* (logand x #x1)) - (y* (logand y #x7f)) - (z* (logand z #xffffff))) - (unless (= x x*) - (error "out of range" x)) - (unless (= y y*) - (error "out of range" y)) - (unless (= z z*) - (error "out of range" z)) - (logior x* (ash y* 1) (ash z* 8)))) + (let ((x (check-urange x #x1)) + (y (check-urange y #x7f)) + (z (check-urange z #xffffff))) + (logior x (ash y 1) (ash z 8)))) (define-inline (pack-u8-u12-u12 x y z) - (let ((x* (logand x #xff)) - (y* (logand y #xfff)) - (z* (logand z #xfff))) - (unless (= x x*) - (error "out of range" x)) - (unless (= y y*) - (error "out of range" y)) - (unless (= z z*) - (error "out of range" z)) - (logior x* (ash y* 8) (ash z* 20)))) + (let ((x (check-urange x #xff)) + (y (check-urange y #xfff)) + (z (check-urange z #xfff))) + (logior x (ash y 8) (ash z 20)))) (define-inline (pack-u8-u8-u16 x y z) - (let ((x* (logand x #xff)) - (y* (logand y #xff)) - (z* (logand z #xffff))) - (unless (= x x*) - (error "out of range" x)) - (unless (= y y*) - (error "out of range" y)) - (unless (= z z*) - (error "out of range" z)) - (logior x* (ash y* 8) (ash z* 16)))) + (let ((x (check-urange x #xff)) + (y (check-urange y #xff)) + (z (check-urange z #xffff))) + (logior x (ash y 8) (ash z 16)))) (define-inline (pack-u8-u8-u8-u8 x y z w) - (let ((x* (logand x #xff)) - (y* (logand y #xff)) - (z* (logand z #xff)) - (w* (logand w #xff))) - (unless (= x x*) - (error "out of range" x)) - (unless (= y y*) - (error "out of range" y)) - (unless (= z z*) - (error "out of range" z)) - (unless (= w w*) - (error "out of range" w)) - (logior x* (ash y* 8) (ash z* 16) (ash w* 24)))) + (let ((x (check-urange x #xff)) + (y (check-urange y #xff)) + (z (check-urange z #xff)) + (w (check-urange w #xff))) + (logior x (ash y 8) (ash z 16) (ash w 24)))) (eval-when (expand) (define-syntax pack-flags From 97755a1adecbb5af084f33b1ca816c70cb8cb2de Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 3 Dec 2015 08:28:22 +0100 Subject: [PATCH 147/865] Small VM cleanups * libguile/vm-engine.c (BR_U64_ARITHMETIC): No need for a second argument. Adapt callers. (scm->u64/truncate): Remove extra SYNC_IP. --- libguile/vm-engine.c | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index c3663150f..34b95fbd6 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -379,7 +379,7 @@ } \ } -#define BR_U64_ARITHMETIC(crel,srel) \ +#define BR_U64_ARITHMETIC(crel) \ { \ scm_t_uint32 a, b; \ scm_t_uint64 x, y; \ @@ -3279,7 +3279,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, */ VM_DEFINE_OP (146, br_if_u64_ee, "br-if-u64-=", OP3 (X8_S24, X8_S24, B1_X7_L24)) { - BR_U64_ARITHMETIC (==, scm_num_eq_p); + BR_U64_ARITHMETIC (==); } /* br-if-< a:12 b:12 invert:1 _:7 offset:24 @@ -3289,12 +3289,12 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, */ VM_DEFINE_OP (147, br_if_u64_lt, "br-if-u64-<", OP3 (X8_S24, X8_S24, B1_X7_L24)) { - BR_U64_ARITHMETIC (<, scm_less_p); + BR_U64_ARITHMETIC (<); } VM_DEFINE_OP (148, br_if_u64_le, "br-if-u64-<=", OP3 (X8_S24, X8_S24, B1_X7_L24)) { - BR_U64_ARITHMETIC (<=, scm_leq_p); + BR_U64_ARITHMETIC (<=); } /* uadd dst:8 a:8 b:8 @@ -3593,7 +3593,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, SCM x; UNPACK_12_12 (op, dst, src); - SYNC_IP (); x = SP_REF (src); if (SCM_I_INUMP (x)) From 1d4b4ec39cc7a7fa18c9e352e5ff4cc59874e039 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 3 Dec 2015 09:01:24 +0100 Subject: [PATCH 148/865] Add support for comparing u64 values with SCM values * libguile/vm-engine.c (BR_U64_SCM_COMPARISON): New helper. (br-if-u64-<=-scm, br-if-u64-<-scm, br-if-u64-=-scm) (br-if-u64->-scm, br-if-u64->=-scm): New instructions, to compare an untagged u64 with a tagged SCM. Avoids many u64->scm operations. * module/language/cps/compile-bytecode.scm (compile-function): * module/language/cps/effects-analysis.scm: * module/language/cps/type-fold.scm: * module/system/vm/assembler.scm: * module/system/vm/disassembler.scm (code-annotation, compute-labels): * module/language/cps/primitives.scm (*branching-primcall-arities*): Add support for new opcodes. * module/language/cps/specialize-numbers.scm (specialize-u64-scm-comparison): New helper. * module/language/cps/specialize-numbers.scm (specialize-operations): Specialize u64 comparisons. * module/language/cps/types.scm (true-comparison-restrictions): New helper. (define-comparison-inferrer): Use the new helper. Add support for u64-<-scm et al. --- libguile/vm-engine.c | 98 ++++++++++++++++++++-- module/language/cps/compile-bytecode.scm | 5 ++ module/language/cps/effects-analysis.scm | 5 ++ module/language/cps/primitives.scm | 5 ++ module/language/cps/specialize-numbers.scm | 30 +++++-- module/language/cps/type-fold.scm | 5 ++ module/language/cps/types.scm | 47 +++++++++-- module/system/vm/assembler.scm | 5 ++ module/system/vm/disassembler.scm | 6 +- 9 files changed, 187 insertions(+), 19 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 34b95fbd6..0bd3e78e9 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -3640,11 +3640,99 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (1); } - VM_DEFINE_OP (170, unused_170, NULL, NOP) - VM_DEFINE_OP (171, unused_171, NULL, NOP) - VM_DEFINE_OP (172, unused_172, NULL, NOP) - VM_DEFINE_OP (173, unused_173, NULL, NOP) - VM_DEFINE_OP (174, unused_174, NULL, NOP) +#define BR_U64_SCM_COMPARISON(x, y, unboxed, boxed) \ + do { \ + scm_t_uint32 a, b; \ + scm_t_uint64 x; \ + SCM y_scm; \ + \ + UNPACK_24 (op, a); \ + UNPACK_24 (ip[1], b); \ + x = SP_REF_U64 (a); \ + y_scm = SP_REF (b); \ + \ + if (SCM_I_INUMP (y_scm)) \ + { \ + scm_t_signed_bits y = SCM_I_INUM (y_scm); \ + \ + if ((ip[2] & 0x1) ? !(unboxed) : (unboxed)) \ + { \ + scm_t_int32 offset = ip[2]; \ + offset >>= 8; /* Sign-extending shift. */ \ + if (offset <= 0) \ + VM_HANDLE_INTERRUPTS; \ + NEXT (offset); \ + } \ + NEXT (3); \ + } \ + else \ + { \ + SCM res; \ + SYNC_IP (); \ + res = boxed (scm_from_uint64 (x), y_scm); \ + CACHE_SP (); \ + if ((ip[2] & 0x1) ? scm_is_false (res) : scm_is_true (res)) \ + { \ + scm_t_int32 offset = ip[2]; \ + offset >>= 8; /* Sign-extending shift. */ \ + if (offset <= 0) \ + VM_HANDLE_INTERRUPTS; \ + NEXT (offset); \ + } \ + NEXT (3); \ + } \ + } while (0) + + /* br-if-u64-=-scm a:24 _:8 b:24 invert:1 _:7 offset:24 + * + * If the U64 value in A is = to the SCM value in B, add OFFSET, a + * signed 24-bit number, to the current instruction pointer. + */ + VM_DEFINE_OP (170, br_if_u64_ee_scm, "br-if-u64-=-scm", OP3 (X8_S24, X8_S24, B1_X7_L24)) + { + BR_U64_SCM_COMPARISON(x, y, y >= 0 && (scm_t_uint64) y == x, scm_num_eq_p); + } + + /* br-if-u64-<-scm a:24 _:8 b:24 invert:1 _:7 offset:24 + * + * If the U64 value in A is < than the SCM value in B, add OFFSET, a + * signed 24-bit number, to the current instruction pointer. + */ + VM_DEFINE_OP (171, br_if_u64_lt_scm, "br-if-u64-<-scm", OP3 (X8_S24, X8_S24, B1_X7_L24)) + { + BR_U64_SCM_COMPARISON(x, y, y >= 0 && (scm_t_uint64) y > x, scm_less_p); + } + + /* br-if-u64-=-scm a:24 _:8 b:24 invert:1 _:7 offset:24 + * + * If the U64 value in A is <= than the SCM value in B, add OFFSET, a + * signed 24-bit number, to the current instruction pointer. + */ + VM_DEFINE_OP (172, br_if_u64_le_scm, "br-if-u64-<=-scm", OP3 (X8_S24, X8_S24, B1_X7_L24)) + { + BR_U64_SCM_COMPARISON(x, y, y >= 0 && (scm_t_uint64) y >= x, scm_leq_p); + } + + /* br-if-u64->-scm a:24 _:8 b:24 invert:1 _:7 offset:24 + * + * If the U64 value in A is > than the SCM value in B, add OFFSET, a + * signed 24-bit number, to the current instruction pointer. + */ + VM_DEFINE_OP (173, br_if_u64_gt_scm, "br-if-u64->-scm", OP3 (X8_S24, X8_S24, B1_X7_L24)) + { + BR_U64_SCM_COMPARISON(x, y, y < 0 || (scm_t_uint64) y < x, scm_gr_p); + } + + /* br-if-u64->=-scm a:24 _:8 b:24 invert:1 _:7 offset:24 + * + * If the U64 value in A is >= than the SCM value in B, add OFFSET, a + * signed 24-bit number, to the current instruction pointer. + */ + VM_DEFINE_OP (174, br_if_u64_ge_scm, "br-if-u64->=-scm", OP3 (X8_S24, X8_S24, B1_X7_L24)) + { + BR_U64_SCM_COMPARISON(x, y, y <= 0 || (scm_t_uint64) y <= x, scm_geq_p); + } + VM_DEFINE_OP (175, unused_175, NULL, NOP) VM_DEFINE_OP (176, unused_176, NULL, NOP) VM_DEFINE_OP (177, unused_177, NULL, NOP) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index dc2894821..1cb85ad7b 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -415,6 +415,11 @@ (($ $primcall 'u64-= (a b)) (binary emit-br-if-u64-= a b)) (($ $primcall 'u64->= (a b)) (binary emit-br-if-u64-<= b a)) (($ $primcall 'u64-> (a b)) (binary emit-br-if-u64-< b a)) + (($ $primcall 'u64-<-scm (a b)) (binary emit-br-if-u64-<-scm a b)) + (($ $primcall 'u64-<=-scm (a b)) (binary emit-br-if-u64-<=-scm a b)) + (($ $primcall 'u64-=-scm (a b)) (binary emit-br-if-u64-=-scm a b)) + (($ $primcall 'u64->=-scm (a b)) (binary emit-br-if-u64->=-scm a b)) + (($ $primcall 'u64->-scm (a b)) (binary emit-br-if-u64->-scm a b)) (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b)))) (define (compile-trunc label k exp nreq rest-var) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 37fb7406d..70344a286 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -432,6 +432,11 @@ is or might be a read or a write to the same location as A." ((u64-> . _)) ((u64-<= . _)) ((u64->= . _)) + ((u64-<-scm . _) &type-check) + ((u64-<=-scm . _) &type-check) + ((u64-=-scm . _) &type-check) + ((u64->=-scm . _) &type-check) + ((u64->-scm . _) &type-check) ((zero? . _) &type-check) ((add . _) &type-check) ((add/immediate . _) &type-check) diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm index d6488450d..bc03c983e 100644 --- a/module/language/cps/primitives.scm +++ b/module/language/cps/primitives.scm @@ -94,6 +94,11 @@ (u64-> . (1 . 2)) (u64-<= . (1 . 2)) (u64->= . (1 . 2)) + (u64-<-scm . (1 . 2)) + (u64-<=-scm . (1 . 2)) + (u64-=-scm . (1 . 2)) + (u64->=-scm . (1 . 2)) + (u64->-scm . (1 . 2)) (logtest . (1 . 2)))) (define (compute-prim-instructions) diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm index 6546c73c7..24ce2095b 100644 --- a/module/language/cps/specialize-numbers.scm +++ b/module/language/cps/specialize-numbers.scm @@ -122,6 +122,17 @@ ($continue kunbox-b src ($primcall 'scm->u64 (a))))))) +(define (specialize-u64-scm-comparison cps kf kt src op a-u64 b-scm) + (let ((op (symbol-append 'u64- op '-scm))) + (with-cps cps + (letv u64) + (letk kop ($kargs ('u64) (u64) + ($continue kf src + ($branch kt ($primcall op (u64 b-scm)))))) + (build-term + ($continue kop src + ($primcall 'scm->u64 (a-u64))))))) + (define (specialize-operations cps) (define (visit-cont label cont cps types) (define (operand-in-range? var &type &min &max) @@ -235,11 +246,20 @@ ($ $continue k src ($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) (a b))))) (values - (if (and (u64-operand? a) (u64-operand? b)) - (with-cps cps - (let$ body (specialize-u64-comparison k kt src op a b)) - (setk label ($kargs names vars ,body))) - cps) + (if (u64-operand? a) + (let ((specialize (if (u64-operand? b) + specialize-u64-comparison + specialize-u64-scm-comparison))) + (with-cps cps + (let$ body (specialize k kt src op a b)) + (setk label ($kargs names vars ,body)))) + (if (u64-operand? b) + (let ((op (match op + ('< '>) ('<= '>=) ('= '=) ('>= '<=) ('> '<)))) + (with-cps cps + (let$ body (specialize-u64-scm-comparison k kt src op b a)) + (setk label ($kargs names vars ,body)))) + cps)) types)) (_ (values cps types)))) diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm index e3939e0b6..d935ea251 100644 --- a/module/language/cps/type-fold.scm +++ b/module/language/cps/type-fold.scm @@ -109,6 +109,7 @@ ((= >= >) (values #t #f)) (else (values #f #f)))) (define-branch-folder-alias u64-< <) +(define-branch-folder-alias u64-<-scm <) (define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1) (case (compare-ranges type0 min0 max0 type1 min1 max1) @@ -116,6 +117,7 @@ ((>) (values #t #f)) (else (values #f #f)))) (define-branch-folder-alias u64-<= <=) +(define-branch-folder-alias u64-<=-scm <=) (define-binary-branch-folder (= type0 min0 max0 type1 min1 max1) (case (compare-ranges type0 min0 max0 type1 min1 max1) @@ -123,6 +125,7 @@ ((< >) (values #t #f)) (else (values #f #f)))) (define-branch-folder-alias u64-= =) +(define-branch-folder-alias u64-=-scm =) (define-binary-branch-folder (>= type0 min0 max0 type1 min1 max1) (case (compare-ranges type0 min0 max0 type1 min1 max1) @@ -130,6 +133,7 @@ ((<) (values #t #f)) (else (values #f #f)))) (define-branch-folder-alias u64->= >=) +(define-branch-folder-alias u64->=-scm >=) (define-binary-branch-folder (> type0 min0 max0 type1 min1 max1) (case (compare-ranges type0 min0 max0 type1 min1 max1) @@ -137,6 +141,7 @@ ((= <= <) (values #t #f)) (else (values #f #f)))) (define-branch-folder-alias u64-> >) +(define-branch-folder-alias u64->-scm >) (define-binary-branch-folder (logtest type0 min0 max0 type1 min1 max1) (define (logand-min a b) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index a85617062..2c2a775d0 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -840,17 +840,20 @@ minimum, and maximum." (infer-integer-ranges) (infer-real-ranges))) +(define-syntax-rule (true-comparison-restrictions op a b a-type b-type) + (call-with-values + (lambda () + (restricted-comparison-ranges op + (&type a) (&min a) (&max a) + (&type b) (&min b) (&max b))) + (lambda (min0 max0 min1 max1) + (restrict! a a-type min0 max0) + (restrict! b b-type min1 max1)))) + (define-syntax-rule (define-comparison-inferrer (op inverse)) (define-predicate-inferrer (op a b true?) (when (zero? (logand (logior (&type a) (&type b)) (lognot &number))) - (call-with-values - (lambda () - (restricted-comparison-ranges (if true? 'op 'inverse) - (&type a) (&min a) (&max a) - (&type b) (&min b) (&max b))) - (lambda (min0 max0 min1 max1) - (restrict! a &real min0 max0) - (restrict! b &real min1 max1)))))) + (true-comparison-restrictions (if true? 'op 'inverse) a b &real &real)))) (define-simple-type-checker (< &real &real)) (define-comparison-inferrer (< >=)) @@ -872,6 +875,34 @@ minimum, and maximum." (restrict! a &u64 min max) (restrict! b &u64 min max)))) +(define-simple-type-checker (u64-=-scm &u64 &real)) +(define-predicate-inferrer (u64-=-scm a b true?) + (when (and true? (zero? (logand (&type b) (lognot &real)))) + (let ((min (max (&min a) (&min b))) + (max (min (&max a) (&max b)))) + (restrict! a &u64 min max) + (restrict! b &real min max)))) + +(define-simple-type-checker (u64-<-scm &u64 &real)) +(define-predicate-inferrer (u64-<-scm a b true?) + (when (and true? (zero? (logand (&type b) (lognot &real)))) + (true-comparison-restrictions '< a b &u64 &real))) + +(define-simple-type-checker (u64-<=-scm &u64 &real)) +(define-predicate-inferrer (u64-<=-scm a b true?) + (when (and true? (zero? (logand (&type b) (lognot &real)))) + (true-comparison-restrictions '<= a b &u64 &real))) + +(define-simple-type-checker (u64->=-scm &u64 &real)) +(define-predicate-inferrer (u64->=-scm a b true?) + (when (and true? (zero? (logand (&type b) (lognot &real)))) + (true-comparison-restrictions '>= a b &u64 &real))) + +(define-simple-type-checker (u64->-scm &u64 &real)) +(define-predicate-inferrer (u64->-scm a b true?) + (when (and true? (zero? (logand (&type b) (lognot &real)))) + (true-comparison-restrictions '> a b &u64 &real))) + (define (infer-u64-comparison-ranges op min0 max0 min1 max1) (match op ('< (values min0 (min max0 (1- max1)) (max (1+ min0) min1) max1)) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index a4d5efc30..4fcf17296 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -98,6 +98,11 @@ emit-br-if-u64-= emit-br-if-u64-< emit-br-if-u64-<= + emit-br-if-u64-<-scm + emit-br-if-u64-<=-scm + emit-br-if-u64-=-scm + emit-br-if-u64->=-scm + emit-br-if-u64->-scm (emit-mov* . emit-mov) (emit-fmov* . emit-fmov) (emit-box* . emit-box) diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index 6c21ad609..b0867e665 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -196,6 +196,8 @@ address of that offset." 'br-if-char 'br-if-eq 'br-if-eqv 'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->= 'br-if-u64-= 'br-if-u64-< 'br-if-u64-<= + 'br-if-u64-<-scm 'br-if-u64-<=-scm 'br-if-u64-=-scm + 'br-if-u64->-scm 'br-if-u64->=-scm 'br-if-logtest) _ ... target) (list "-> ~A" (vector-ref labels (- (+ offset target) start)))) (('br-if-tc7 slot invert? tc7 target) @@ -298,7 +300,9 @@ address of that offset." br-if-true br-if-null br-if-nil br-if-pair br-if-struct br-if-char br-if-tc7 br-if-eq br-if-eqv br-if-= br-if-< br-if-<= br-if-> br-if->= br-if-logtest - br-if-u64-= br-if-u64-< br-if-u64-<=) + br-if-u64-= br-if-u64-< br-if-u64-<= + br-if-u64-<-scm br-if-u64-<=-scm br-if-u64-=-scm + br-if-u64->-scm br-if-u64->=-scm) (match arg ((_ ... target) (add-label! (+ offset target) "L")))) From a1471e024468e4c8a39d9fcf2508ea73e1f4a9d8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 3 Dec 2015 09:10:41 +0000 Subject: [PATCH 149/865] Add another simplification pass to make rotate-loops work better * module/language/cps/optimize.scm (optimize-first-order-cps): Toss in another simplification pass. --- module/language/cps/optimize.scm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm index 707b68d4e..cc1d95147 100644 --- a/module/language/cps/optimize.scm +++ b/module/language/cps/optimize.scm @@ -108,6 +108,8 @@ (hoist-loop-invariant-code #:licm? #t) (eliminate-common-subexpressions #:cse? #t) (eliminate-dead-code #:eliminate-dead-code? #t) + ;; Running simplify here enables rotate-loops to do a better job. + (simplify #:simplify? #t) (rotate-loops #:rotate-loops? #t) (simplify #:simplify? #t) (specialize-primcalls #:specialize-primcalls? #t)) From 3c271457f10d05b1f37c4b89c5cdcc4adec337ba Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 16 Dec 2015 09:48:37 +0000 Subject: [PATCH 150/865] Fix build when threads are disabled * module/language/cps/intmap.scm: Remove srfi-18 import. We just need current-thread which is actually defined in (guile), and importing (srfi srfi-18) raises an error if Guile is compiled without threads support. --- module/language/cps/intmap.scm | 1 - 1 file changed, 1 deletion(-) diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm index ba9d1c0bf..c29fa9ef4 100644 --- a/module/language/cps/intmap.scm +++ b/module/language/cps/intmap.scm @@ -33,7 +33,6 @@ (define-module (language cps intmap) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) - #:use-module (srfi srfi-18) #:use-module (ice-9 match) #:export (empty-intmap intmap? From 9e1c07bda6bb5ea51eb687c63a4fc53fd0de1a6a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 3 Dec 2015 22:10:31 +0100 Subject: [PATCH 151/865] Assembler works on byte offsets, not u32 offsets * module/system/vm/assembler.scm (u32-ref, u32-set!, s32-ref, s32-set!): Remove these helpers. * module/system/vm/assembler.scm (): Track offsets in bytes, not u32 units. (emit, assembler, process-relocs, process-labels, link-text-object) (link-frame-maps, link-symtab, write-arities, link-docstrs) (link-procprops, link-debug): Adapt. * module/system/vm/linker.scm (process-reloc): Add addend before dividing by 4 for rel32/4 symbols. --- module/system/vm/assembler.scm | 98 ++++++++++++++++------------------ module/system/vm/linker.scm | 6 +-- 2 files changed, 48 insertions(+), 56 deletions(-) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 4fcf17296..311cf3ae6 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -291,20 +291,6 @@ ((pack-flags f1 f2) (logior (if f1 (ash 1 0) 0) (if f2 (ash 1 1) 0)))))) -;;; Helpers to read and write 32-bit units in a buffer. - -(define-inline (u32-ref buf n) - (bytevector-u32-native-ref buf (* n 4))) - -(define-inline (u32-set! buf n val) - (bytevector-u32-native-set! buf (* n 4) val)) - -(define-inline (s32-ref buf n) - (bytevector-s32-native-ref buf (* n 4))) - -(define-inline (s32-set! buf n val) - (bytevector-s32-native-set! buf (* n 4) val)) - @@ -366,20 +352,19 @@ slot-maps) asm? - ;; We write bytecode into what is logically a growable vector, - ;; implemented as a list of blocks. asm-cur is the current block, and - ;; asm-pos is the current index into that block, in 32-bit units. + ;; We write bytecode into a bytevector, growing the bytevector as + ;; needed. asm-cur is that bytevector, and asm-pos is the byte offset + ;; into the vector at which the next word should be written. ;; (buf asm-buf set-asm-buf!) (pos asm-pos set-asm-pos!) - ;; asm-start is an absolute position, indicating the offset of the - ;; beginning of an instruction (in u32 units). It is updated after - ;; writing all the words for one primitive instruction. It models the - ;; position of the instruction pointer during execution, given that - ;; the VM updates the IP only at the end of executing the instruction, - ;; and is thus useful for computing offsets between two points in a - ;; program. + ;; asm-start is an absolute position, indicating the byte offset of + ;; the beginning of an instruction. It is updated after writing all + ;; the words for one primitive instruction. It models the position of + ;; the instruction pointer during execution, given that the VM updates + ;; the IP only at the end of executing the instruction, and is thus + ;; useful for computing offsets between two points in a program. ;; (start asm-start set-asm-start!) @@ -466,8 +451,8 @@ target." (define-inline (emit asm u32) "Emit one 32-bit word into the instruction stream. Assumes that there is space for the word." - (u32-set! (asm-buf asm) (asm-pos asm) u32) - (set-asm-pos! asm (1+ (asm-pos asm)))) + (bytevector-u32-native-set! (asm-buf asm) (asm-pos asm) u32) + (set-asm-pos! asm (+ (asm-pos asm) 4))) (define-inline (make-reloc type label base word) "Make an internal relocation of type @var{type} referencing symbol @@ -596,7 +581,7 @@ later by the linker." (emit asm 0)) ((LO32 label offset) (record-far-label-reference asm label - (* offset (/ (asm-word-size asm) 4))) + (* offset (asm-word-size asm))) (emit asm 0)) ((C8_C24 a b) (emit asm (pack-u8-u24 a b))) @@ -638,7 +623,7 @@ later by the linker." #'(lambda (asm formal0 ... formal* ... ...) (let lp () (let ((words (length '(word0 word* ...)))) - (unless (<= (* 4 (+ (asm-pos asm) words)) + (unless (<= (+ (asm-pos asm) (* 4 words)) (bytevector-length (asm-buf asm))) (grow-buffer! asm) (lp)))) @@ -1201,7 +1186,7 @@ returned instead." (define-macro-assembler (definition asm name slot representation) (let* ((arity (car (meta-arities (car (asm-meta asm))))) (def (vector name slot representation - (* (- (asm-start asm) (arity-low-pc arity)) 4)))) + (- (asm-start asm) (arity-low-pc arity))))) (set-arity-definitions! arity (cons def (arity-definitions arity))))) (define-macro-assembler (cache-current-module! asm module scope) @@ -1550,23 +1535,29 @@ relocations for references to symbols defined outside the text section." (fold (lambda (reloc tail) (match reloc - ((type label base word) + ((type label base offset) (let ((abs (hashq-ref labels label)) - (dst (+ base word))) + (dst (+ base offset))) (case type ((s32) (if abs (let ((rel (- abs base))) - (s32-set! buf dst rel) + (unless (zero? (logand rel #x3)) + (error "reloc not in 32-bit units!")) + (bytevector-s32-native-set! buf dst (ash rel -2)) tail) - (cons (make-linker-reloc 'rel32/4 (* dst 4) word label) + (cons (make-linker-reloc 'rel32/4 dst offset label) tail))) ((x8-s24) (unless abs (error "unbound near relocation" reloc)) (let ((rel (- abs base)) - (u32 (u32-ref buf dst))) - (u32-set! buf dst (pack-u8-s24 (logand u32 #xff) rel)) + (u32 (bytevector-u32-native-ref buf dst))) + (unless (zero? (logand rel #x3)) + (error "reloc not in 32-bit units!")) + (bytevector-u32-native-set! buf dst + (pack-u8-s24 (logand u32 #xff) + (ash rel -2))) tail)) (else (error "bad relocation kind" reloc))))))) '() @@ -1576,7 +1567,7 @@ relocations for references to symbols defined outside the text section." "Define linker symbols for the label-offset map in @var{labels}. The offsets are expected to be expressed in words." (hash-map->list (lambda (label loc) - (make-linker-symbol label (* loc 4))) + (make-linker-symbol label loc)) labels)) (define (swap-bytes! buf) @@ -1596,7 +1587,7 @@ The offsets are expected to be expressed in words." (define (link-text-object asm) "Link the .rtl-text section, swapping the endianness of the bytes if needed." - (let ((buf (make-u32vector (asm-pos asm)))) + (let ((buf (make-bytevector (asm-pos asm)))) (bytevector-copy! (asm-buf asm) 0 buf 0 (bytevector-length buf)) (unless (eq? (asm-endianness asm) (native-endianness)) (swap-bytes! buf)) @@ -1646,7 +1637,7 @@ needed." (list (make-linker-reloc 'abs32/1 0 0 '.rtl-text)) '() #:type SHT_PROGBITS #:flags SHF_ALLOC)) (((pos proc-slot . map) . maps) - (bytevector-u32-set! bv header-pos (* pos 4) endianness) + (bytevector-u32-set! bv header-pos pos endianness) (bytevector-u32-set! bv (+ header-pos 4) map-pos endianness) (let write-bytes ((map-pos map-pos) (map map) @@ -1753,9 +1744,9 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If #:name name ;; Symbol value and size are measured in ;; bytes, not u32s. - #:value (* 4 (meta-low-pc meta)) - #:size (* 4 (- (meta-high-pc meta) - (meta-low-pc meta))) + #:value (meta-low-pc meta) + #:size (- (meta-high-pc meta) + (meta-low-pc meta)) #:type STT_FUNC #:visibility STV_HIDDEN #:shndx (elf-section-index text-section))))) @@ -1870,8 +1861,8 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If (define (write-header pos low-pc high-pc offset flags nreq nopt nlocals) (unless (<= (+ nreq nopt) nlocals) (error "forgot to emit definition instructions?")) - (bytevector-u32-set! headers pos (* low-pc 4) (asm-endianness asm)) - (bytevector-u32-set! headers (+ pos 4) (* high-pc 4) (asm-endianness asm)) + (bytevector-u32-set! headers pos low-pc (asm-endianness asm)) + (bytevector-u32-set! headers (+ pos 4) high-pc (asm-endianness asm)) (bytevector-u32-set! headers (+ pos 8) offset (asm-endianness asm)) (bytevector-u32-set! headers (+ pos 12) flags (asm-endianness asm)) (bytevector-u32-set! headers (+ pos 16) nreq (asm-endianness asm)) @@ -2018,7 +2009,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If (and tail (not (find-tail is-documentation? (cdr tail))) (string? (cdar tail)) - (cons (* 4 (meta-low-pc meta)) (cdar tail))))) + (cons (meta-low-pc meta) (cdar tail))))) (reverse (asm-meta asm)))) (let* ((endianness (asm-endianness asm)) (docstrings (find-docstrings)) @@ -2084,7 +2075,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If (filter-map (lambda (meta) (let ((props (props-without-name-or-docstring meta))) (and (pair? props) - (cons (* 4 (meta-low-pc meta)) props)))) + (cons (meta-low-pc meta) props)))) (reverse (asm-meta asm)))) (let* ((endianness (asm-endianness asm)) (procprops (find-procprops)) @@ -2145,14 +2136,14 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If (else '())) (low-pc ,(meta-label meta)) - (high-pc ,(* 4 (- (meta-high-pc meta) (meta-low-pc meta))))))) + (high-pc ,(- (meta-high-pc meta) (meta-low-pc meta)))))) (define (make-compile-unit-die asm) `(compile-unit (@ (producer ,(string-append "Guile " (version))) (language ,(asm-language asm)) (low-pc .rtl-text) - (high-pc ,(* 4 (asm-pos asm))) + (high-pc ,(asm-pos asm)) (stmt-list 0)) ,@(map meta->subprogram-die (reverse (asm-meta asm))))) @@ -2200,6 +2191,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If ;; from 10 to 255, so 246 values. (define base -4) (define range 15) + (define min-inc 4) ; Minimum PC increment. (let lp ((sources (asm-sources asm)) (out '())) (match sources @@ -2225,7 +2217,7 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If (put-u32 line-port 0) ; Length; will patch later. (put-u16 line-port 2) ; DWARF 2 format. (put-u32 line-port 0) ; Prologue length; will patch later. - (put-u8 line-port 4) ; Minimum instruction length: 4 bytes. + (put-u8 line-port min-inc) ; Minimum instruction length: 4 bytes. (put-u8 line-port 1) ; Default is-stmt: true. (put-s8 line-port base) ; Line base. See the DWARF standard. @@ -2297,12 +2289,14 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If (add-reloc! 'abs64/1) (put-u64 line-port 0)))) (define (end-sequence pc) - (let ((pc-inc (- (asm-pos asm) pc))) + (let ((pc-inc (/ (- (asm-pos asm) pc) min-inc))) (put-u8 line-port 2) ; advance-pc (put-uleb128 line-port pc-inc)) (extended-op 1 0)) (define (advance-pc pc-inc line-inc) - (let ((spec (+ (- line-inc base) (* pc-inc range) 10))) + (let ((spec (+ (- line-inc base) + (* (/ pc-inc min-inc) range) + 10))) (cond ((or (< line-inc base) (>= line-inc (+ base range))) (advance-line line-inc) @@ -2311,11 +2305,11 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If (put-u8 line-port spec)) ((< spec 500) (put-u8 line-port 8) ; const-advance-pc - (advance-pc (- pc-inc (floor/ (- 255 10) range)) + (advance-pc (- pc-inc (* (floor/ (- 255 10) range) min-inc)) line-inc)) (else (put-u8 line-port 2) ; advance-pc - (put-uleb128 line-port pc-inc) + (put-uleb128 line-port (/ pc-inc min-inc)) (advance-pc 0 line-inc))))) (define (advance-line inc) (put-u8 line-port 3) diff --git a/module/system/vm/linker.scm b/module/system/vm/linker.scm index 8151462d5..952837737 100644 --- a/module/system/vm/linker.scm +++ b/module/system/vm/linker.scm @@ -394,12 +394,10 @@ symbol, as present in @var{symtab}." (target (linker-symbol-address symbol))) (case (linker-reloc-type reloc) ((rel32/4) - (let ((diff (- target offset))) + (let ((diff (+ (- target offset) (linker-reloc-addend reloc)))) (unless (zero? (modulo diff 4)) (error "Bad offset" reloc symbol offset)) - (bytevector-s32-set! bv offset - (+ (/ diff 4) (linker-reloc-addend reloc)) - endianness))) + (bytevector-s32-set! bv offset (/ diff 4) endianness))) ((rel32/1) (let ((diff (- target offset))) (bytevector-s32-set! bv offset From 362907810bbe9a20cf5097363d959cb67db67b36 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 26 Dec 2015 15:11:01 +0100 Subject: [PATCH 152/865] Fix emit-receive* for many locals * module/system/vm/assembler.scm (emit-receive*): Fix to use FP-relative move instead of SP-relative move. --- module/system/vm/assembler.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 311cf3ae6..8d9b90c35 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -842,7 +842,7 @@ later by the linker." (emit-receive asm dst proc nlocals) (begin (emit-receive-values asm proc #t 1) - (emit-mov* asm dst (1+ proc)) + (emit-fmov* asm dst (1+ proc)) (emit-reset-frame asm nlocals)))) (define (emit-text asm instructions) From 8a3916216054c09b1f53de632ee3690b2da8c764 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 26 Dec 2015 15:11:44 +0100 Subject: [PATCH 153/865] Assembler O(n) in instruction encodings, not instruction count * module/system/vm/assembler.scm: Change define encoders for all of the kinds of instructions and have the emit-foo procedures call the common encoders. No change to public interface. This decreases the amount of generated code in the assembler. --- module/system/vm/assembler.scm | 600 ++++++++++++++++++--------------- 1 file changed, 324 insertions(+), 276 deletions(-) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 8d9b90c35..2d11d8808 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -58,17 +58,20 @@ #:use-module (srfi srfi-11) #:export (make-assembler + (emit-receive* . emit-receive) + (emit-mov* . emit-mov) + (emit-fmov* . emit-fmov) + emit-call emit-call-label emit-tail-call emit-tail-call-label - (emit-receive* . emit-receive) emit-receive-values emit-return emit-return-values emit-call/cc emit-abort - (emit-builtin-ref* . emit-builtin-ref) + emit-builtin-ref emit-br-if-nargs-ne emit-br-if-nargs-lt emit-br-if-nargs-gt @@ -103,115 +106,113 @@ emit-br-if-u64-=-scm emit-br-if-u64->=-scm emit-br-if-u64->-scm - (emit-mov* . emit-mov) - (emit-fmov* . emit-fmov) - (emit-box* . emit-box) - (emit-box-ref* . emit-box-ref) - (emit-box-set!* . emit-box-set!) + emit-box + emit-box-ref + emit-box-set! emit-make-closure - (emit-free-ref* . emit-free-ref) - (emit-free-set!* . emit-free-set!) + emit-free-ref + emit-free-set! emit-current-module emit-resolve - (emit-define!* . emit-define!) + emit-define! emit-toplevel-box emit-module-box emit-prompt - (emit-wind* . emit-wind) + emit-wind emit-unwind - (emit-push-fluid* . emit-push-fluid) + emit-push-fluid emit-pop-fluid emit-current-thread - (emit-fluid-ref* . emit-fluid-ref) - (emit-fluid-set* . emit-fluid-set) - (emit-string-length* . emit-string-length) - (emit-string-ref* . emit-string-ref) - (emit-string->number* . emit-string->number) - (emit-string->symbol* . emit-string->symbol) - (emit-symbol->keyword* . emit-symbol->keyword) - (emit-cons* . emit-cons) - (emit-car* . emit-car) - (emit-cdr* . emit-cdr) - (emit-set-car!* . emit-set-car!) - (emit-set-cdr!* . emit-set-cdr!) - (emit-add* . emit-add) - (emit-add/immediate* . emit-add/immediate) - (emit-sub* . emit-sub) - (emit-sub/immediate* . emit-sub/immediate) - (emit-mul* . emit-mul) - (emit-div* . emit-div) - (emit-quo* . emit-quo) - (emit-rem* . emit-rem) - (emit-mod* . emit-mod) - (emit-ash* . emit-ash) - (emit-fadd* . emit-fadd) - (emit-fsub* . emit-fsub) - (emit-fmul* . emit-fmul) - (emit-fdiv* . emit-fdiv) - (emit-uadd* . emit-uadd) - (emit-usub* . emit-usub) - (emit-umul* . emit-umul) - (emit-uadd/immediate* . emit-uadd/immediate) - (emit-usub/immediate* . emit-usub/immediate) - (emit-umul/immediate* . emit-umul/immediate) - (emit-logand* . emit-logand) - (emit-logior* . emit-logior) - (emit-logxor* . emit-logxor) - (emit-logsub* . emit-logsub) - (emit-ulogand* . emit-ulogand) - (emit-ulogior* . emit-ulogior) - (emit-ulogsub* . emit-ulogsub) - (emit-ursh* . emit-ursh) - (emit-ulsh* . emit-ulsh) - (emit-ursh/immediate* . emit-ursh/immediate) - (emit-ulsh/immediate* . emit-ulsh/immediate) - (emit-make-vector* . emit-make-vector) - (emit-make-vector/immediate* . emit-make-vector/immediate) - (emit-vector-length* . emit-vector-length) - (emit-vector-ref* . emit-vector-ref) - (emit-vector-ref/immediate* . emit-vector-ref/immediate) - (emit-vector-set!* . emit-vector-set!) - (emit-vector-set!/immediate* . emit-vector-set!/immediate) - (emit-struct-vtable* . emit-struct-vtable) - (emit-allocate-struct/immediate* . emit-allocate-struct/immediate) - (emit-struct-ref/immediate* . emit-struct-ref/immediate) - (emit-struct-set!/immediate* . emit-struct-set!/immediate) - (emit-allocate-struct* . emit-allocate-struct) - (emit-struct-ref* . emit-struct-ref) - (emit-struct-set!* . emit-struct-set!) - (emit-class-of* . emit-class-of) + emit-fluid-ref + emit-fluid-set + emit-string-length + emit-string-ref + emit-string->number + emit-string->symbol + emit-symbol->keyword + emit-cons + emit-car + emit-cdr + emit-set-car! + emit-set-cdr! + emit-add + emit-add/immediate + emit-sub + emit-sub/immediate + emit-mul + emit-div + emit-quo + emit-rem + emit-mod + emit-ash + emit-fadd + emit-fsub + emit-fmul + emit-fdiv + emit-uadd + emit-usub + emit-umul + emit-uadd/immediate + emit-usub/immediate + emit-umul/immediate + emit-logand + emit-logior + emit-logxor + emit-logsub + emit-ulogand + emit-ulogior + emit-ulogsub + emit-ursh + emit-ulsh + emit-ursh/immediate + emit-ulsh/immediate + emit-make-vector + emit-make-vector/immediate + emit-vector-length + emit-vector-ref + emit-vector-ref/immediate + emit-vector-set! + emit-vector-set!/immediate + emit-struct-vtable + emit-allocate-struct/immediate + emit-struct-ref/immediate + emit-struct-set!/immediate + emit-allocate-struct + emit-struct-ref + emit-struct-set! + emit-class-of emit-make-array - (emit-scm->f64* . emit-scm->f64) + emit-scm->f64 emit-load-f64 - (emit-f64->scm* . emit-f64->scm) - (emit-scm->u64* . emit-scm->u64) - (emit-scm->u64/truncate* . emit-scm->u64/truncate) + emit-f64->scm + emit-scm->u64 + emit-scm->u64/truncate emit-load-u64 - (emit-u64->scm* . emit-u64->scm) - (emit-scm->s64* . emit-scm->s64) + emit-u64->scm + emit-scm->s64 emit-load-s64 - (emit-s64->scm* . emit-s64->scm) - (emit-bv-length* . emit-bv-length) - (emit-bv-u8-ref* . emit-bv-u8-ref) - (emit-bv-s8-ref* . emit-bv-s8-ref) - (emit-bv-u16-ref* . emit-bv-u16-ref) - (emit-bv-s16-ref* . emit-bv-s16-ref) - (emit-bv-u32-ref* . emit-bv-u32-ref) - (emit-bv-s32-ref* . emit-bv-s32-ref) - (emit-bv-u64-ref* . emit-bv-u64-ref) - (emit-bv-s64-ref* . emit-bv-s64-ref) - (emit-bv-f32-ref* . emit-bv-f32-ref) - (emit-bv-f64-ref* . emit-bv-f64-ref) - (emit-bv-u8-set!* . emit-bv-u8-set!) - (emit-bv-s8-set!* . emit-bv-s8-set!) - (emit-bv-u16-set!* . emit-bv-u16-set!) - (emit-bv-s16-set!* . emit-bv-s16-set!) - (emit-bv-u32-set!* . emit-bv-u32-set!) - (emit-bv-s32-set!* . emit-bv-s32-set!) - (emit-bv-u64-set!* . emit-bv-u64-set!) - (emit-bv-s64-set!* . emit-bv-s64-set!) - (emit-bv-f32-set!* . emit-bv-f32-set!) - (emit-bv-f64-set!* . emit-bv-f64-set!) + emit-s64->scm + emit-bv-length + emit-bv-u8-ref + emit-bv-s8-ref + emit-bv-u16-ref + emit-bv-s16-ref + emit-bv-u32-ref + emit-bv-s32-ref + emit-bv-u64-ref + emit-bv-s64-ref + emit-bv-f32-ref + emit-bv-f64-ref + emit-bv-u8-set! + emit-bv-s8-set! + emit-bv-u16-set! + emit-bv-s16-set! + emit-bv-u32-set! + emit-bv-s32-set! + emit-bv-u64-set! + emit-bv-s64-set! + emit-bv-f32-set! + emit-bv-f64-set! emit-text link-assembly)) @@ -494,7 +495,7 @@ later by the linker." (define (id-append ctx a b) (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))) - (define-syntax assembler + (define-syntax encoder (lambda (x) (define-syntax op-case (lambda (x) @@ -610,17 +611,19 @@ later by the linker." (emit asm 0)))) (syntax-case x () - ((_ name opcode word0 word* ...) + ((_ word0 word* ...) (with-syntax ((((formal0 ...) code0 ...) - (pack-first-word #'asm - (syntax->datum #'opcode) + (pack-first-word #'asm #'opcode (syntax->datum #'word0))) ((((formal* ...) code* ...) ...) (map (lambda (word) (pack-tail-word #'asm word)) (syntax->datum #'(word* ...))))) - #'(lambda (asm formal0 ... formal* ... ...) + ;; The opcode is the last argument, so that assemblers don't + ;; have to shuffle their arguments before tail-calling an + ;; encoder. + #'(lambda (asm formal0 ... formal* ... ... opcode) (let lp () (let ((words (length '(word0 word* ...)))) (unless (<= (+ (asm-pos asm) (* 4 words)) @@ -629,7 +632,219 @@ later by the linker." (lp)))) code0 ... code* ... ... - (reset-asm-start! asm)))))))) + (reset-asm-start! asm))))))) + + (define (encoder-name operands) + (let lp ((operands operands) (out #'encode)) + (syntax-case operands () + (() out) + ((operand . operands) + (lp #'operands + (id-append #'operand (id-append out out #'-) #'operand)))))) + + (define-syntax define-encoder + (lambda (x) + (syntax-case x () + ((_ operand ...) + (with-syntax ((encode (encoder-name #'(operand ...)))) + #'(define encode (encoder operand ...))))))) + + (define-syntax visit-instruction-kinds + (lambda (x) + (syntax-case x () + ((visit-instruction-kinds macro arg ...) + (with-syntax (((operands ...) + (delete-duplicates + (map (match-lambda + ((name opcode kind . operands) + (datum->syntax #'macro operands))) + (instruction-list))))) + #'(begin + (macro arg ... . operands) + ...))))))) + +(visit-instruction-kinds define-encoder) + +;; In Guile's VM, locals are usually addressed via the stack pointer +;; (SP). There can be up to 2^24 slots for local variables in a +;; frame. Some instructions encode their operands using a restricted +;; subset of the full 24-bit local address space, in order to make the +;; bytecode more dense in the usual case that a function needs few +;; local slots. To allow these instructions to be used when there are +;; many local slots, we can temporarily push the values on the stack, +;; operate on them there, and then store back any result as we pop the +;; SP to its original position. +;; +;; We implement this shuffling via wrapper encoders that have the same +;; arity as the encoder they wrap, e.g. encode-X8_S12_S12/shuffle that +;; wraps encode-X8_S12_S12. We make the emit-cons public interface +;; use the shuffling encoder. That way we solve the problem fully and +;; in just one place. + +(define (encode-X8_S12_S12!/shuffle asm a b opcode) + (cond + ((< (logior a b) (ash 1 12)) + (encode-X8_S12_S12 asm a b opcode)) + (else + (emit-push asm a) + (emit-push asm (1+ b)) + (encode-X8_S12_S12 asm 1 0 opcode) + (emit-drop asm 2)))) +(define (encode-X8_S12_S12<-/shuffle asm dst a opcode) + (cond + ((< (logior dst a) (ash 1 12)) + (encode-X8_S12_S12 asm dst a opcode)) + (else + (emit-push asm a) + (encode-X8_S12_S12 asm 0 0 opcode) + (emit-pop asm dst)))) +(define (encode-X8_S12_S12-X8_C24!/shuffle asm a b c opcode) + (cond + ((< (logior a b) (ash 1 12)) + (encode-X8_S12_S12-X8_C24 asm a b c opcode)) + (else + (emit-push asm a) + (emit-push asm (1+ b)) + (encode-X8_S12_S12-X8_C24 asm 1 0 c opcode) + (emit-drop asm 2)))) +(define (encode-X8_S12_S12-X8_C24<-/shuffle asm dst a const opcode) + (cond + ((< (logior dst a) (ash 1 12)) + (encode-X8_S12_S12-X8_C24 asm dst a const opcode)) + (else + (emit-push asm a) + (encode-X8_S12_S12-X8_C24 asm 0 0 const opcode) + (emit-pop asm dst)))) +(define (encode-X8_S12_C12<-/shuffle asm dst const opcode) + (cond + ((< dst (ash 1 12)) + (encode-X8_S12_C12 asm dst const opcode)) + (else + ;; Push garbage value to make space for dst. + (emit-push asm dst) + (encode-X8_S12_C12 asm 0 const opcode) + (emit-pop asm dst)))) +(define (encode-X8_S8_I16<-/shuffle asm dst imm opcode) + (cond + ((< dst (ash 1 8)) + (encode-X8_S8_I16 asm dst imm opcode)) + (else + ;; Push garbage value to make space for dst. + (emit-push asm dst) + (encode-X8_S8_I16 asm 0 imm opcode) + (emit-pop asm dst)))) +(define (encode-X8_S8_S8_S8!/shuffle asm a b c opcode) + (cond + ((< (logior a b c) (ash 1 8)) + (encode-X8_S8_S8_S8 asm a b c opcode)) + (else + (emit-push asm a) + (emit-push asm (+ b 1)) + (emit-push asm (+ c 2)) + (encode-X8_S8_S8_S8 asm 2 1 0 opcode) + (emit-drop asm 3)))) +(define (encode-X8_S8_S8_S8<-/shuffle asm dst a b opcode) + (cond + ((< (logior dst a b) (ash 1 8)) + (encode-X8_S8_S8_S8 asm dst a b opcode)) + (else + (emit-push asm a) + (emit-push asm (1+ b)) + (encode-X8_S8_S8_S8 asm 1 1 0 opcode) + (emit-drop asm 1) + (emit-pop asm dst)))) +(define (encode-X8_S8_S8_C8<-/shuffle asm dst a const opcode) + (cond + ((< (logior dst a) (ash 1 8)) + (encode-X8_S8_S8_C8 asm dst a const opcode)) + (else + (emit-push asm a) + (encode-X8_S8_S8_C8 asm 0 0 const opcode) + (emit-pop asm dst)))) +(define (encode-X8_S8_C8_S8!/shuffle asm a const b opcode) + (cond + ((< (logior a b) (ash 1 8)) + (encode-X8_S8_C8_S8 asm a const b opcode)) + (else + (emit-push asm a) + (emit-push asm (1+ b)) + (encode-X8_S8_C8_S8 asm 1 const 0 opcode) + (emit-drop asm 2)))) +(define (encode-X8_S8_C8_S8<-/shuffle asm dst const a opcode) + (cond + ((< (logior dst a) (ash 1 8)) + (encode-X8_S8_C8_S8 asm dst const a opcode)) + (else + (emit-push asm a) + (encode-X8_S8_C8_S8 asm 0 const 0 opcode) + (emit-pop asm dst)))) + +(eval-when (expand) + (define (id-append ctx a b) + (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))) + + (define (shuffling-encoder-name kind operands) + (match (cons (syntax->datum kind) (syntax->datum operands)) + (('! 'X8_S12_S12) #'encode-X8_S12_S12!/shuffle) + (('<- 'X8_S12_S12) #'encode-X8_S12_S12<-/shuffle) + (('! 'X8_S12_S12 'X8_C24) #'encode-X8_S12_S12-X8_C24!/shuffle) + (('<- 'X8_S12_S12 'X8_C24) #'encode-X8_S12_S12-X8_C24<-/shuffle) + (('<- 'X8_S12_C12) #'encode-X8_S12_C12<-/shuffle) + (('<- 'X8_S8_I16) #'encode-X8_S8_I16<-/shuffle) + (('! 'X8_S8_S8_S8) #'encode-X8_S8_S8_S8!/shuffle) + (('<- 'X8_S8_S8_S8) #'encode-X8_S8_S8_S8<-/shuffle) + (('<- 'X8_S8_S8_C8) #'encode-X8_S8_S8_C8<-/shuffle) + (('! 'X8_S8_C8_S8) #'encode-X8_S8_C8_S8!/shuffle) + (('<- 'X8_S8_C8_S8) #'encode-X8_S8_C8_S8<-/shuffle) + (else (encoder-name operands)))) + + (define-syntax assembler + (lambda (x) + (define (word-args word) + (match word + ('C32 #'(a)) + ('I32 #'(imm)) + ('A32 #'(imm)) + ('AF32 #'(f64)) + ('AU32 #'(u64)) + ('AS32 #'(s64)) + ('B32 #'()) + ('BU32 #'()) + ('BS32 #'()) + ('BF32 #'()) + ('N32 #'(label)) + ('R32 #'(label)) + ('L32 #'(label)) + ('LO32 #'(label offset)) + ('C8_C24 #'(a b)) + ('B1_X7_L24 #'(a label)) + ('B1_C7_L24 #'(a b label)) + ('B1_X31 #'(a)) + ('B1_X7_S24 #'(a b)) + ('B1_X7_F24 #'(a b)) + ('B1_X7_C24 #'(a b)) + ('X8_S24 #'(arg)) + ('X8_F24 #'(arg)) + ('X8_C24 #'(arg)) + ('X8_L24 #'(label)) + ('X8_S8_I16 #'(a imm)) + ('X8_S12_S12 #'(a b)) + ('X8_S12_C12 #'(a b)) + ('X8_C12_C12 #'(a b)) + ('X8_F12_F12 #'(a b)) + ('X8_S8_S8_S8 #'(a b c)) + ('X8_S8_S8_C8 #'(a b c)) + ('X8_S8_C8_S8 #'(a b c)) + ('X32 #'()))) + + (syntax-case x () + ((_ name opcode kind word ...) + (with-syntax (((formal ...) + (generate-temporaries + (append-map word-args (syntax->datum #'(word ...))))) + (encode (shuffling-encoder-name #'kind #'(word ...)))) + #'(lambda (asm formal ...) + (encode asm formal ... opcode)))))))) (define assemblers (make-hash-table)) @@ -640,7 +855,7 @@ later by the linker." ((_ name opcode kind arg ...) (with-syntax ((emit (id-append #'name #'emit- #'name))) #'(define emit - (let ((emit (assembler name opcode arg ...))) + (let ((emit (assembler name opcode kind arg ...))) (hashq-set! assemblers 'name emit) emit))))))) @@ -657,177 +872,10 @@ later by the linker." (visit-opcodes define-assembler) -(eval-when (expand) - - ;; In Guile's VM, locals are usually addressed via the stack pointer - ;; (SP). There can be up to 2^24 slots for local variables in a - ;; frame. Some instructions encode their operands using a restricted - ;; subset of the full 24-bit local address space, in order to make the - ;; bytecode more dense in the usual case that a function needs few - ;; local slots. To allow these instructions to be used when there are - ;; many local slots, we can temporarily push the values on the stack, - ;; operate on them there, and then store back any result as we pop the - ;; SP to its original position. - ;; - ;; We implement this shuffling via wrapper emitters that have the same - ;; arity as the emitter they wrap, e.g. emit-cons* that wraps - ;; emit-cons. We expose these wrappers as the public interface for - ;; emitting `cons' instructions. That way we solve the problem fully - ;; and in just one place. The only manual care that need be taken is - ;; in the exports list at the top of the file -- to be sure that we - ;; export the wrapper and not the wrapped emitter. - - (define (shuffling-assembler emit kind word0 word*) - (with-syntax ((emit emit)) - (match (cons* word0 kind word*) - (('X8_S12_S12 '!) - #'(lambda (asm a b) - (cond - ((< (logior a b) (ash 1 12)) - (emit asm a b)) - (else - (emit-push asm a) - (emit-push asm (1+ b)) - (emit asm 1 0) - (emit-drop asm 2))))) - (('X8_S12_S12 '<-) - #'(lambda (asm dst a) - (cond - ((< (logior dst a) (ash 1 12)) - (emit asm dst a)) - (else - (emit-push asm a) - (emit asm 0 0) - (emit-pop asm dst))))) - - (('X8_S12_S12 '! 'X8_C24) - #'(lambda (asm a b c) - (cond - ((< (logior a b) (ash 1 12)) - (emit asm a b c)) - (else - (emit-push asm a) - (emit-push asm (1+ b)) - (emit asm 1 0 c) - (emit-drop asm 2))))) - (('X8_S12_S12 '<- 'X8_C24) - #'(lambda (asm dst a const) - (cond - ((< (logior dst a) (ash 1 12)) - (emit asm dst a const)) - (else - (emit-push asm a) - (emit asm 0 0 const) - (emit-pop asm dst))))) - - (('X8_S12_C12 '<-) - #'(lambda (asm dst const) - (cond - ((< dst (ash 1 12)) - (emit asm dst const)) - (else - ;; Push garbage value to make space for dst. - (emit-push asm dst) - (emit asm 0 const) - (emit-pop asm dst))))) - - (('X8_S8_I16 '<-) - #'(lambda (asm dst imm) - (cond - ((< dst (ash 1 8)) - (emit asm dst imm)) - (else - ;; Push garbage value to make space for dst. - (emit-push asm dst) - (emit asm 0 imm) - (emit-pop asm dst))))) - - (('X8_S8_S8_S8 '!) - #'(lambda (asm a b c) - (cond - ((< (logior a b c) (ash 1 8)) - (emit asm a b c)) - (else - (emit-push asm a) - (emit-push asm (+ b 1)) - (emit-push asm (+ c 2)) - (emit asm 2 1 0) - (emit-drop asm 3))))) - (('X8_S8_S8_S8 '<-) - #'(lambda (asm dst a b) - (cond - ((< (logior dst a b) (ash 1 8)) - (emit asm dst a b)) - (else - (emit-push asm a) - (emit-push asm (1+ b)) - (emit asm 1 1 0) - (emit-drop asm 1) - (emit-pop asm dst))))) - - (('X8_S8_S8_C8 '<-) - #'(lambda (asm dst a const) - (cond - ((< (logior dst a) (ash 1 8)) - (emit asm dst a const)) - (else - (emit-push asm a) - (emit asm 0 0 const) - (emit-pop asm dst))))) - - (('X8_S8_C8_S8 '!) - #'(lambda (asm a const b) - (cond - ((< (logior a b) (ash 1 8)) - (emit asm a const b)) - (else - (emit-push asm a) - (emit-push asm (1+ b)) - (emit asm 1 const 0) - (emit-drop asm 2))))) - (('X8_S8_C8_S8 '<-) - #'(lambda (asm dst const a) - (cond - ((< (logior dst a) (ash 1 8)) - (emit asm dst const a)) - (else - (emit-push asm a) - (emit asm 0 const 0) - (emit-pop asm dst)))))))) - - (define-syntax define-shuffling-assembler - (lambda (stx) - (define (might-shuffle? word0) - (case word0 - ((X8_S12_S12 X8_S12_C12 - X8_S8_I16 - X8_S8_S8_S8 X8_S8_S8_C8 X8_S8_C8_S8) #t) - (else #f))) - - (syntax-case stx () - ((_ #:except (except ...) name opcode kind word0 word* ...) - (let ((_except (syntax->datum #'(except ...))) - (_name (syntax->datum #'name)) - (_kind (syntax->datum #'kind)) - (_word0 (syntax->datum #'word0)) - (_word* (syntax->datum #'(word* ...))) - (emit (id-append #'name #'emit- #'name))) - (cond - ((and (might-shuffle? _word0) (not (memq _name _except))) - (with-syntax - ((emit* (id-append #'name emit #'*)) - (proc (shuffling-assembler emit _kind _word0 _word*))) - #'(define emit* - (let ((emit* proc)) - (hashq-set! assemblers 'name emit*) - emit*)))) - (else - #'(begin))))))))) - -(visit-opcodes define-shuffling-assembler #:except (receive mov)) - -;; Mov and receive are two special cases that can work without wrappers. -;; Indeed it is important that they do so. +;; Shuffling is a general mechanism to get around address space +;; limitations for SP-relative variable references. FP-relative +;; variables need special support. Also, some instructions like `mov' +;; have multiple variations with different addressing limits. (define (emit-mov* asm dst src) (if (and (< dst (ash 1 12)) (< src (ash 1 12))) From 620b640a4eccf6fdaa9cda8dc77c415e975a1834 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 26 Dec 2015 20:16:21 +0100 Subject: [PATCH 154/865] Fix bug in intmap-map * module/language/cps/utils.scm (intmap-map): Use transient intmap-add! on an empty intmap to build the result instead of intmap-replace! on the argument. Avoids spooky action-at-a-distance mutation of the argument if it happens to be a transient -- although the intmap-fold will correctly traverse a snapshot of the argument and the result will be correct, the argument value would be modified in place, causing strange results to calling code that passes in a transient. --- module/language/cps/utils.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm index 64b403dbc..3fce00a99 100644 --- a/module/language/cps/utils.scm +++ b/module/language/cps/utils.scm @@ -124,9 +124,9 @@ member, or @code{#f} otherwise." (define (intmap-map proc map) (persistent-intmap - (intmap-fold (lambda (k v out) (intmap-replace! out k (proc k v))) + (intmap-fold (lambda (k v out) (intmap-add! out k (proc k v))) map - map))) + empty-intmap))) (define (intmap-keys map) "Return an intset of the keys in @var{map}." From a9c2606451aebc708f75d0cb02a0b1aa84eec904 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 26 Dec 2015 21:27:53 +0100 Subject: [PATCH 155/865] Type inference copes better with unsorted graphs * module/language/cps/types.scm (&min/0, &min/s64, &max/s64, &max/size) (&max/u64, &max/vector): New clamped variable range accessors. Use them in type inferrers. --- module/language/cps/types.scm | 116 +++++++++++++++++++--------------- 1 file changed, 65 insertions(+), 51 deletions(-) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 2c2a775d0..a58953d55 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -366,6 +366,19 @@ minimum, and maximum." (define-type-helper &min) (define-type-helper &max) +;; Accessors to use in type inferrers where you know that the values +;; must be in some range for the computation to proceed (not throw an +;; error). Note that these accessors should be used even for &u64 and +;; &s64 values, whose definitions you would think would be apparent +;; already. However it could be that the graph isn't sorted, so we see +;; a use before a definition, in which case we need to clamp the generic +;; limits to the &u64/&s64 range. +(define-syntax-rule (&min/0 x) (max (&min x) 0)) +(define-syntax-rule (&max/u64 x) (min (&max x) &u64-max)) +(define-syntax-rule (&min/s64 x) (max (&min x) &s64-min)) +(define-syntax-rule (&max/s64 x) (min (&max x) &s64-max)) +(define-syntax-rule (&max/size x) (min (&max x) *max-size-t*)) + (define-syntax-rule (define-type-checker (name arg ...) body ...) (hashq-set! *type-checkers* @@ -601,27 +614,28 @@ minimum, and maximum." ;; This max-vector-len computation is a hack. (define *max-vector-len* (ash most-positive-fixnum -5)) +(define-syntax-rule (&max/vector x) (min (&max x) *max-vector-len*)) (define-simple-type-checker (make-vector (&u64 0 *max-vector-len*) &all-types)) (define-type-inferrer (make-vector size init result) (restrict! size &u64 0 *max-vector-len*) - (define! result &vector (max (&min size) 0) (&max size))) + (define! result &vector (&min/0 size) (&max/vector size))) (define-type-checker (vector-ref v idx) (and (check-type v &vector 0 *max-vector-len*) (check-type idx &u64 0 (1- (&min v))))) (define-type-inferrer (vector-ref v idx result) - (restrict! v &vector (1+ (&min idx)) *max-vector-len*) - (restrict! idx &u64 0 (1- (min (&max v) *max-vector-len*))) + (restrict! v &vector (1+ (&min/0 idx)) *max-vector-len*) + (restrict! idx &u64 0 (1- (&max/vector v))) (define! result &all-types -inf.0 +inf.0)) (define-type-checker (vector-set! v idx val) (and (check-type v &vector 0 *max-vector-len*) (check-type idx &u64 0 (1- (&min v))))) (define-type-inferrer (vector-set! v idx val) - (restrict! v &vector (1+ (&min idx)) *max-vector-len*) - (restrict! idx &u64 0 (1- (min (&max v) *max-vector-len*)))) + (restrict! v &vector (1+ (&min/0 idx)) *max-vector-len*) + (restrict! idx &u64 0 (1- (&max/vector v)))) (define-type-aliases make-vector make-vector/immediate) (define-type-aliases vector-ref vector-ref/immediate) @@ -630,8 +644,7 @@ minimum, and maximum." (define-simple-type-checker (vector-length &vector)) (define-type-inferrer (vector-length v result) (restrict! v &vector 0 *max-vector-len*) - (define! result &u64 (max (&min v) 0) - (min (&max v) *max-vector-len*))) + (define! result &u64 (&min/0 v) (&max/vector v))) @@ -645,7 +658,7 @@ minimum, and maximum." (define-type-inferrer (allocate-struct vt size result) (restrict! vt &struct vtable-offset-user *max-size-t*) (restrict! size &u64 0 *max-size-t*) - (define! result &struct (max (&min size) 0) (min (&max size) *max-size-t*))) + (define! result &struct (&min/0 size) (&max/size size))) (define-type-checker (struct-ref s idx) (and (check-type s &struct 0 *max-size-t*) @@ -653,8 +666,8 @@ minimum, and maximum." ;; FIXME: is the field readable? (< (&max idx) (&min s)))) (define-type-inferrer (struct-ref s idx result) - (restrict! s &struct (1+ (&min idx)) *max-size-t*) - (restrict! idx &u64 0 (1- (min (&max s) *max-size-t*))) + (restrict! s &struct (1+ (&min/0 idx)) *max-size-t*) + (restrict! idx &u64 0 (1- (&max/size s))) (define! result &all-types -inf.0 +inf.0)) (define-type-checker (struct-set! s idx val) @@ -663,8 +676,8 @@ minimum, and maximum." ;; FIXME: is the field writable? (< (&max idx) (&min s)))) (define-type-inferrer (struct-set! s idx val) - (restrict! s &struct (1+ (&min idx)) *max-size-t*) - (restrict! idx &u64 0 (1- (min (&max s) *max-size-t*)))) + (restrict! s &struct (1+ (&min/0 idx)) *max-size-t*) + (restrict! idx &u64 0 (1- (&max/size s)))) (define-type-aliases allocate-struct allocate-struct/immediate) (define-type-aliases struct-ref struct-ref/immediate) @@ -687,8 +700,8 @@ minimum, and maximum." (check-type idx &u64 0 *max-size-t*) (< (&max idx) (&min s)))) (define-type-inferrer (string-ref s idx result) - (restrict! s &string (1+ (&min idx)) *max-size-t*) - (restrict! idx &u64 0 (1- (min (&max s) *max-size-t*))) + (restrict! s &string (1+ (&min/0 idx)) *max-size-t*) + (restrict! idx &u64 0 (1- (&max/size s))) (define! result &char 0 *max-char*)) (define-type-checker (string-set! s idx val) @@ -697,14 +710,14 @@ minimum, and maximum." (check-type val &char 0 *max-char*) (< (&max idx) (&min s)))) (define-type-inferrer (string-set! s idx val) - (restrict! s &string (1+ (&min idx)) *max-size-t*) - (restrict! idx &exact-integer 0 (1- (min (&max s) *max-size-t*))) + (restrict! s &string (1+ (&min/0 idx)) *max-size-t*) + (restrict! idx &exact-integer 0 (1- (&max/size s))) (restrict! val &char 0 *max-char*)) (define-simple-type-checker (string-length &string)) (define-type-inferrer (string-length s result) (restrict! s &string 0 *max-size-t*) - (define! result &u64 (max (&min s) 0) (min (&max s) *max-size-t*))) + (define! result &u64 (&min/0 s) (&max/size s))) (define-simple-type (number->string &number) (&string 0 *max-size-t*)) (define-simple-type (string->number (&string 0 *max-size-t*)) @@ -733,7 +746,7 @@ minimum, and maximum." (check-type scm &exact-integer 0 #xffffffffffffffff)) (define-type-inferrer (scm->u64 scm result) (restrict! scm &exact-integer 0 #xffffffffffffffff) - (define! result &u64 (max (&min scm) 0) (min (&max scm) &u64-max))) + (define! result &u64 (&min/0 scm) (&max/u64 scm))) (define-type-aliases scm->u64 load-u64) (define-type-checker (scm->u64/truncate scm) @@ -745,19 +758,19 @@ minimum, and maximum." (define-type-checker (u64->scm u64) #t) (define-type-inferrer (u64->scm u64 result) - (define! result &exact-integer (&min u64) (&max u64))) + (define! result &exact-integer (&min/0 u64) (&max/u64 u64))) (define-type-checker (scm->s64 scm) (check-type scm &exact-integer &s64-min &s64-max)) (define-type-inferrer (scm->s64 scm result) (restrict! scm &exact-integer &s64-min &s64-max) - (define! result &s64 (max (&min scm) &s64-min) (min (&max scm) &s64-max))) + (define! result &s64 (&min/s64 scm) (&max/s64 scm))) (define-type-aliases scm->s64 load-s64) (define-type-checker (s64->scm s64) #t) (define-type-inferrer (s64->scm s64 result) - (define! result &exact-integer (&min s64) (&max s64))) + (define! result &exact-integer (&min/s64 s64) (&max/s64 s64))) @@ -769,8 +782,7 @@ minimum, and maximum." (define-simple-type-checker (bv-length &bytevector)) (define-type-inferrer (bv-length bv result) (restrict! bv &bytevector 0 *max-size-t*) - (define! result &u64 - (max (&min bv) 0) (min (&max bv) *max-size-t*))) + (define! result &u64 (&min/0 bv) (&max/size bv))) (define-syntax-rule (define-bytevector-accessors ref set type size lo hi) (begin @@ -779,8 +791,8 @@ minimum, and maximum." (check-type idx &u64 0 *max-size-t*) (< (&max idx) (- (&min bv) size)))) (define-type-inferrer (ref bv idx result) - (restrict! bv &bytevector (+ (&min idx) size) *max-size-t*) - (restrict! idx &u64 0 (- (min (&max bv) *max-size-t*) size)) + (restrict! bv &bytevector (+ (&min/0 idx) size) *max-size-t*) + (restrict! idx &u64 0 (- (&max/size bv) size)) (define! result type lo hi)) (define-type-checker (set bv idx val) (and (check-type bv &bytevector 0 *max-size-t*) @@ -788,8 +800,8 @@ minimum, and maximum." (check-type val type lo hi) (< (&max idx) (- (&min bv) size)))) (define-type-inferrer (set! bv idx val) - (restrict! bv &bytevector (+ (&min idx) size) *max-size-t*) - (restrict! idx &u64 0 (- (min (&max bv) *max-size-t*) size)) + (restrict! bv &bytevector (+ (&min/0 idx) size) *max-size-t*) + (restrict! idx &u64 0 (- (&max/size bv) size)) (restrict! val type lo hi)))) (define-bytevector-accessors bv-u8-ref bv-u8-set! &u64 1 0 #xff) @@ -870,16 +882,16 @@ minimum, and maximum." (define-simple-type-checker (u64-= &u64 &u64)) (define-predicate-inferrer (u64-= a b true?) (when true? - (let ((min (max (&min a) (&min b))) - (max (min (&max a) (&max b)))) + (let ((min (max (&min/0 a) (&min/0 b))) + (max (min (&max/u64 a) (&max/u64 b)))) (restrict! a &u64 min max) (restrict! b &u64 min max)))) (define-simple-type-checker (u64-=-scm &u64 &real)) (define-predicate-inferrer (u64-=-scm a b true?) (when (and true? (zero? (logand (&type b) (lognot &real)))) - (let ((min (max (&min a) (&min b))) - (max (min (&max a) (&max b)))) + (let ((min (max (&min/0 a) (&min/0 b))) + (max (min (&max/u64 a) (&max/u64 b)))) (restrict! a &u64 min max) (restrict! b &real min max)))) @@ -914,8 +926,8 @@ minimum, and maximum." (call-with-values (lambda () (infer-u64-comparison-ranges (if true? 'op 'inverse) - (&min a) (&max a) - (&min b) (&max b))) + (&min/0 a) (&max/u64 a) + (&min/0 b) (&max/u64 b))) (lambda (min0 max0 min1 max1) (restrict! a &u64 min0 max0) (restrict! b &u64 min1 max1))))) @@ -988,9 +1000,9 @@ minimum, and maximum." (+ (&max a) (&max b)))) (define-type-inferrer (uadd a b result) ;; Handle wraparound. - (let ((max (+ (&max a) (&max b)))) + (let ((max (+ (&max/u64 a) (&max/u64 b)))) (if (<= max #xffffffffffffffff) - (define! result &u64 (+ (&min a) (&min b)) max) + (define! result &u64 (+ (&min/0 a) (&min/0 b)) max) (define! result &u64 0 #xffffffffffffffff)))) (define-type-aliases uadd uadd/immediate) @@ -1008,10 +1020,10 @@ minimum, and maximum." (- (&max a) (&min b)))) (define-type-inferrer (usub a b result) ;; Handle wraparound. - (let ((min (- (&min a) (&max b)))) + (let ((min (- (&min/0 a) (&max/u64 b)))) (if (< min 0) (define! result &u64 0 #xffffffffffffffff) - (define! result &u64 min (- (&max a) (&min b)))))) + (define! result &u64 min (- (&max/u64 a) (&min/0 b)))))) (define-type-aliases usub usub/immediate) (define-simple-type-checker (mul &number &number)) @@ -1061,9 +1073,9 @@ minimum, and maximum." (define! result &f64 min max))))) (define-type-inferrer (umul a b result) ;; Handle wraparound. - (let ((max (* (&max a) (&max b)))) + (let ((max (* (&max/u64 a) (&max/u64 b)))) (if (<= max #xffffffffffffffff) - (define! result &u64 (* (&min a) (&min b)) max) + (define! result &u64 (* (&min/0 a) (&min/0 b)) max) (define! result &u64 0 #xffffffffffffffff)))) (define-type-aliases umul umul/immediate) @@ -1232,18 +1244,20 @@ minimum, and maximum." (restrict! a &u64 0 &u64-max) (restrict! b &u64 0 &u64-max) (define! result &u64 - (ash (&min a) (- (&max b))) - (ash (&max a) (- (&min b))))) + (ash (&min/0 a) (- (&max/u64 b))) + (ash (&max/u64 a) (- (&min/0 b))))) (define-type-aliases ursh ursh/immediate) (define-simple-type-checker (ulsh &u64 &u64)) (define-type-inferrer (ulsh a b result) (restrict! a &u64 0 &u64-max) (restrict! b &u64 0 &u64-max) - (if (and (< (&max b) 64) - (<= (ash (&max a) (&max b)) &u64-max)) + (if (and (< (&max/u64 b) 64) + (<= (ash (&max/u64 a) (&max/u64 b)) &u64-max)) ;; No overflow; we can be precise. - (define! result &u64 (ash (&min a) (&min b)) (ash (&max a) (&max b))) + (define! result &u64 + (ash (&min/0 a) (&min/0 b)) + (ash (&max/u64 a) (&max/u64 b))) ;; Otherwise assume the whole range. (define! result &u64 0 &u64-max))) (define-type-aliases ulsh ulsh/immediate) @@ -1274,7 +1288,7 @@ minimum, and maximum." (define-type-inferrer (ulogand a b result) (restrict! a &u64 0 &u64-max) (restrict! b &u64 0 &u64-max) - (define! result &u64 0 (max (&max a) (&max b)))) + (define! result &u64 0 (max (&max/u64 a) (&max/u64 b)))) (define-simple-type-checker (logsub &exact-integer &exact-integer)) (define-type-inferrer (logsub a b result) @@ -1305,7 +1319,7 @@ minimum, and maximum." (define-type-inferrer (ulogsub a b result) (restrict! a &u64 0 &u64-max) (restrict! b &u64 0 &u64-max) - (define! result &u64 0 (&max a))) + (define! result &u64 0 (&max/u64 a))) (define-simple-type-checker (logior &exact-integer &exact-integer)) (define-type-inferrer (logior a b result) @@ -1333,8 +1347,8 @@ minimum, and maximum." (restrict! a &u64 0 &u64-max) (restrict! b &u64 0 &u64-max) (define! result &u64 - (max (&min a) (&min b)) - (1- (next-power-of-two (logior (&max a) (&max b)))))) + (max (&min/0 a) (&min/0 b)) + (1- (next-power-of-two (logior (&max/u64 a) (&max/u64 b)))))) ;; For our purposes, treat logxor the same as logior. (define-type-aliases logior logxor) @@ -1390,7 +1404,7 @@ minimum, and maximum." (else (define! result (logior (logand (&type x) (lognot &number)) (logand (&type x) &real)) - (max (&min x) 0) + (&min/0 x) (max (abs (&min x)) (abs (&max x)))))))) @@ -1407,12 +1421,12 @@ minimum, and maximum." (define-simple-type-checker (integer->char (&exact-integer 0 #x10ffff))) (define-type-inferrer (integer->char i result) (restrict! i &exact-integer 0 #x10ffff) - (define! result &char (max (&min i) 0) (min (&max i) #x10ffff))) + (define! result &char (&min/0 i) (min (&max i) #x10ffff))) (define-simple-type-checker (char->integer &char)) (define-type-inferrer (char->integer c result) (restrict! c &char 0 #x10ffff) - (define! result &exact-integer (max (&min c) 0) (min (&max c) #x10ffff))) + (define! result &exact-integer (&min/0 c) (min (&max c) #x10ffff))) From 5d171d998cc7a0432a0f36f7a27be9f2a78620fa Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 30 Dec 2015 17:14:22 +0100 Subject: [PATCH 156/865] Fix module for reification of srfi-4 primitives * module/language/cps/reify-primitives.scm (primitive-module): Add cases for SRFI-4 primitives. These primitives are only treated as such for the purposes of Tree-IL primitive expansion; perhaps the right fix is elsewhere, but it's here for now. --- module/language/cps/reify-primitives.scm | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index 014593a9a..9b700bd83 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -76,6 +76,13 @@ bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!) '(rnrs bytevectors)) ((class-of) '(oop goops)) + ((u8vector-ref + u8vector-set! s8vector-ref s8vector-set! + u16vector-ref u16vector-set! s16vector-ref s16vector-set! + u32vector-ref u32vector-set! s32vector-ref s32vector-set! + u64vector-ref u64vector-set! s64vector-ref s64vector-set! + f32vector-ref f32vector-set! f64vector-ref f64vector-set!) + '(srfi srfi-4)) (else '(guile)))) (define (primitive-ref cps name k src) From 39002f251ee59f42fcaff8eb8c5fa8185a3ac77b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 3 Jan 2016 16:16:54 +0100 Subject: [PATCH 157/865] Eta-reduce branches * module/language/cps/simplify.scm (compute-eta-reductions): Eta-reduce branches as well, so that passing a constant to a branch will fold to the true or false branch, provided that the test variable was just used in the branch. --- module/language/cps/simplify.scm | 65 +++++++++++++++++++------------- 1 file changed, 39 insertions(+), 26 deletions(-) diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm index a53bdbff6..7878a1e36 100644 --- a/module/language/cps/simplify.scm +++ b/module/language/cps/simplify.scm @@ -111,34 +111,34 @@ ;;; as candidates. This prevents back-edges and so breaks SCCs, and is ;;; optimal if labels are sorted. If the labels aren't sorted it's ;;; suboptimal but cheap. -(define (compute-eta-reductions conts kfun) - (let ((singly-used (compute-singly-referenced-vars conts))) - (define (singly-used? vars) - (match vars - (() #t) - ((var . vars) - (and (intset-ref singly-used var) (singly-used? vars))))) - (define (visit-fun kfun body eta) - (define (visit-cont label eta) - (match (intmap-ref conts label) - (($ $kargs names vars ($ $continue k src ($ $values vars))) - (intset-maybe-add! eta label - (match (intmap-ref conts k) - (($ $kargs) - (and (not (eqv? label k)) ; A - (not (intset-ref eta label)) ; B - (singly-used? vars))) - (_ #f)))) - (_ - eta))) - (intset-fold visit-cont body eta)) - (persistent-intset - (intmap-fold visit-fun - (compute-reachable-functions conts kfun) - empty-intset)))) +(define (compute-eta-reductions conts kfun singly-used) + (define (singly-used? vars) + (match vars + (() #t) + ((var . vars) + (and (intset-ref singly-used var) (singly-used? vars))))) + (define (visit-fun kfun body eta) + (define (visit-cont label eta) + (match (intmap-ref conts label) + (($ $kargs names vars ($ $continue k src ($ $values vars))) + (intset-maybe-add! eta label + (match (intmap-ref conts k) + (($ $kargs) + (and (not (eqv? label k)) ; A + (not (intset-ref eta label)) ; B + (singly-used? vars))) + (_ #f)))) + (_ + eta))) + (intset-fold visit-cont body eta)) + (persistent-intset + (intmap-fold visit-fun + (compute-reachable-functions conts kfun) + empty-intset))) (define (eta-reduce conts kfun) - (let ((label-set (compute-eta-reductions conts kfun))) + (let* ((singly-used (compute-singly-referenced-vars conts)) + (label-set (compute-eta-reductions conts kfun singly-used))) ;; Replace any continuation to a label in LABEL-SET with the label's ;; continuation. The label will denote a $kargs continuation, so ;; only terms that can continue to $kargs need be taken into @@ -155,6 +155,19 @@ (($ $kargs names syms ($ $continue kf src ($ $branch kt exp))) ($kargs names syms ($continue (subst kf) src ($branch (subst kt) ,exp)))) + (($ $kargs names syms ($ $continue k src ($ $const val))) + ,(match (intmap-ref conts k) + (($ $kargs (_) + ((? (lambda (var) (intset-ref singly-used var)) + var)) + ($ $continue kf _ ($ $branch kt ($ $values (var))))) + (build-cont + ($kargs names syms + ($continue (subst (if val kt kf)) src ($values ()))))) + (_ + (build-cont + ($kargs names syms + ($continue (subst k) src ($const val))))))) (($ $kargs names syms ($ $continue k src exp)) ($kargs names syms ($continue (subst k) src ,exp))) From 52965e03ec47b92e5bd34c9dc9d9bbcaf100f26a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 3 Jan 2016 16:17:53 +0100 Subject: [PATCH 158/865] Better folding of branches on $values * module/language/cps/type-fold.scm (local-type-fold): Fold branches on $values, if we can. --- module/language/cps/type-fold.scm | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm index d935ea251..9459e31a0 100644 --- a/module/language/cps/type-fold.scm +++ b/module/language/cps/type-fold.scm @@ -408,6 +408,20 @@ ((x y) (or (fold-binary-branch cps label names vars k kt src name x y) cps)))) + (($ $branch kt ($ $values (arg))) + ;; We might be able to fold branches on values. + (call-with-values (lambda () (lookup-pre-type types label arg)) + (lambda (type min max) + (cond + ((zero? (logand type (logior &false &nil))) + (with-cps cps + (setk label + ($kargs names vars ($continue kt src ($values ())))))) + ((zero? (logand type (lognot (logior &false &nil)))) + (with-cps cps + (setk label + ($kargs names vars ($continue k src ($values ())))))) + (else cps))))) (_ cps))) (let lp ((label start) (cps cps)) (if (<= label end) From 166703c5ce9549a9e4e010d657b9415e4275fff6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 3 Jan 2016 18:15:20 +0100 Subject: [PATCH 159/865] Better partial evaluation of tests in tests * module/language/tree-il/peval.scm (peval): In test context, fold (let ((x EXP)) (if x x ALT)) to (if EXP #t ALT). This reduces the number of boolean literals that the compiler has to reify, by causing EXP to evaluate in test context instead of value context. Also, rotate `let' out of the test part of conditionals, for the same reason. --- module/language/tree-il/peval.scm | 73 ++++++++++++++++++++++--------- 1 file changed, 53 insertions(+), 20 deletions(-) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 355d423dd..1cf2cb1a8 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -944,26 +944,35 @@ top-level bindings from ENV and return the resulting expression." (map lookup-alias vals))) (env (fold extend-env env gensyms ops)) (body (loop body env counter ctx))) - (cond - ((const? body) - (for-tail (list->seq src (append vals (list body))))) - ((and (lexical-ref? body) - (memq (lexical-ref-gensym body) new)) - (let ((sym (lexical-ref-gensym body)) - (pairs (map cons new vals))) - ;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo) - (for-tail - (list->seq - src - (append (map cdr (alist-delete sym pairs eq?)) - (list (assq-ref pairs sym))))))) - (else - ;; Only include bindings for which lexical references - ;; have been residualized. - (prune-bindings ops #f body counter ctx - (lambda (names gensyms vals body) - (if (null? names) (error "what!" names)) - (make-let src names gensyms vals body))))))) + (match body + (($ ) + (for-tail (list->seq src (append vals (list body))))) + (($ _ _ (? (lambda (sym) (memq sym new)) sym)) + (let ((pairs (map cons new vals))) + ;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo) + (for-tail + (list->seq + src + (append (map cdr (alist-delete sym pairs eq?)) + (list (assq-ref pairs sym))))))) + ((and ($ src* + ($ _ _ sym) ($ _ _ sym) alt) + (? (lambda (_) + (case ctx + ((test effect) + (and (equal? (list sym) new) + (= (lexical-refcount sym) 2))) + (else #f))))) + ;; (let ((x EXP)) (if x x ALT)) -> (if EXP #t ALT) in test context + (make-conditional src* (visit-operand (car ops) counter 'test) + (make-const src* #t) alt)) + (_ + ;; Only include bindings for which lexical references + ;; have been residualized. + (prune-bindings ops #f body counter ctx + (lambda (names gensyms vals body) + (if (null? names) (error "what!" names)) + (make-let src names gensyms vals body))))))) (($ src in-order? names gensyms vals body) ;; Note the difference from the `let' case: here we use letrec* ;; so that the `visit' procedure for the new operands closes over @@ -1084,6 +1093,30 @@ top-level bindings from ENV and return the resulting expression." subsequent alternate) (simplify-conditional (make-conditional src pred alternate subsequent))) + ;; In the following four cases, we try to expose the test to + ;; the conditional. This will let the CPS conversion avoid + ;; reifying boolean literals in some cases. + (($ src ($ src* names vars vals body) + subsequent alternate) + (make-let src* names vars vals + (simplify-conditional + (make-conditional src body subsequent alternate)))) + (($ src + ($ src* in-order? names vars vals body) + subsequent alternate) + (make-letrec src* in-order? names vars vals + (simplify-conditional + (make-conditional src body subsequent alternate)))) + (($ src ($ src* names vars vals body) + subsequent alternate) + (make-fix src* names vars vals + (simplify-conditional + (make-conditional src body subsequent alternate)))) + (($ src ($ src* head tail) + subsequent alternate) + (make-seq src* head + (simplify-conditional + (make-conditional src tail subsequent alternate)))) ;; Special cases for common tests in the predicates of chains ;; of if expressions. (($ src From fb2f7b4e5fc50c3cf42d4d4906060bd99d56cb05 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 3 Jan 2016 18:18:51 +0100 Subject: [PATCH 160/865] Better CPS conversion for tests in tests * module/language/tree-il/compile-cps.scm (convert): Tests in tests have their consequents and alternates also converted in test context. --- module/language/tree-il/compile-cps.scm | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 5fa60109a..419cb336b 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -773,7 +773,7 @@ (build-term ($continue k src ($primcall 'apply args*))))))) (($ src test consequent alternate) - (define (convert-test cps kt kf) + (define (convert-test cps test kt kf) (match test (($ src (? branching-primitive? name) args) (convert-args cps args @@ -781,6 +781,13 @@ (with-cps cps (build-term ($continue kf src ($branch kt ($primcall name args)))))))) + (($ src test consequent alternate) + (with-cps cps + (let$ t (convert-test consequent kt kf)) + (let$ f (convert-test alternate kt kf)) + (letk kt* ($kargs () () ,t)) + (letk kf* ($kargs () () ,f)) + ($ (convert-test test kt* kf*)))) (_ (convert-arg cps test (lambda (cps test) (with-cps cps @@ -791,7 +798,7 @@ (let$ f (convert alternate k subst)) (letk kt ($kargs () () ,t)) (letk kf ($kargs () () ,f)) - ($ (convert-test kt kf)))) + ($ (convert-test test kt kf)))) (($ src name gensym exp) (convert-arg cps exp From 204336c37754f38a69949cdad50c7c0b904dea93 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 3 Jan 2016 18:20:19 +0100 Subject: [PATCH 161/865] Don't serialize build through psyntax-pp.scm * bootstrap/Makefile.am: Don't serialize the build through psyntax-pp.scm. On a multicore make, this will result in higher total CPU time as multiple processes use an interpreted expander, but lower total build time, as all processes will take approximately the same time to load and run the compiler. --- bootstrap/Makefile.am | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/bootstrap/Makefile.am b/bootstrap/Makefile.am index e9b3895bf..e954059bb 100644 --- a/bootstrap/Makefile.am +++ b/bootstrap/Makefile.am @@ -28,14 +28,11 @@ GOBJECTS = $(SOURCES:%.scm=%.go) GUILE_WARNINGS = GUILE_OPTIMIZATIONS = -O1 nobase_noinst_DATA = $(GOBJECTS) ice-9/eval.go -CLEANFILES = $(GOBJECTS) ice-9/eval.go ice-9/psyntax-pp.go +CLEANFILES = $(GOBJECTS) ice-9/eval.go # We must build the evaluator first, so that we can be sure to control -# the stack. Then we really need to build the expander before other -# things, otherwise the compile time for everything else is dominated by -# the expander. -ice-9/psyntax-pp.go: ice-9/eval.go -$(GOBJECTS): ice-9/psyntax-pp.go +# the stack. +$(GOBJECTS): ice-9/eval.go VM_TARGETS := system/vm/assembler.go system/vm/disassembler.go $(VM_TARGETS): $(top_builddir)/libguile/vm-operations.h @@ -61,6 +58,7 @@ SUFFIXES = .scm .go # these in any order; the order below is designed to hopefully result in # the lowest total compile time. SOURCES = \ + ice-9/psyntax-pp.scm \ language/cps/intmap.scm \ language/cps/intset.scm \ language/cps/utils.scm \ From 9091454c2ee8f76cf449add797707606d7c298c0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 4 Jan 2016 22:43:30 +0100 Subject: [PATCH 162/865] Include missing #:simplify? option in (language cps optimize). * module/language/cps/optimize.scm (cps-default-optimization-options): Add missing #:simplify? option. Otherwise the simplification pass was running even at -O0. --- module/language/cps/optimize.scm | 1 + 1 file changed, 1 insertion(+) diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm index cc1d95147..b1cbc89a7 100644 --- a/module/language/cps/optimize.scm +++ b/module/language/cps/optimize.scm @@ -116,6 +116,7 @@ (define (cps-default-optimization-options) (list ;; #:split-rec? #t + #:simplify? #t #:eliminate-dead-code? #t #:prune-top-level-scopes? #t #:contify? #t From f56f580a4a8d99cec79c5a64d41e1d005c2bac31 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 30 Nov 2015 12:09:26 +0100 Subject: [PATCH 163/865] Inline some helpers in intset.scm. * module/language/cps/intset.scm (round-down): Inline. (clone-branch-and-set): Inline, and inline the vector-move-left!. --- module/language/cps/intset.scm | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/module/language/cps/intset.scm b/module/language/cps/intset.scm index bb35a23d3..cdf1fbe82 100644 --- a/module/language/cps/intset.scm +++ b/module/language/cps/intset.scm @@ -117,9 +117,13 @@ (let ((vec (make-vector *branch-size-with-edit* #f))) (when edit (vector-set! vec *edit-index* edit)) vec)) -(define (clone-branch-and-set branch i elt) +(define-inlinable (clone-branch-and-set branch i elt) (let ((new (new-branch #f))) - (when branch (vector-move-left! branch 0 *branch-size* new 0)) + (when branch + (let lp ((n 0)) + (when (< n *branch-size*) + (vector-set! new n (vector-ref branch n)) + (lp (1+ n))))) (vector-set! new i elt) new)) (define-inlinable (assert-readable! root-edit) @@ -136,7 +140,7 @@ (and (not (vector-ref branch i)) (lp (1+ i)))))) -(define (round-down min shift) +(define-inlinable (round-down min shift) (logand min (lognot (1- (ash 1 shift))))) (define empty-intset (make-intset 0 *leaf-bits* #f)) From 4137c224e24215bd9496dfc2fd084a09383125a2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 4 Jan 2016 23:32:55 +0100 Subject: [PATCH 164/865] Remove unused function in simplify.scm * module/language/cps/simplify.scm (intset-add*): Remove unused function. --- module/language/cps/simplify.scm | 6 ------ 1 file changed, 6 deletions(-) diff --git a/module/language/cps/simplify.scm b/module/language/cps/simplify.scm index 7878a1e36..280e2573d 100644 --- a/module/language/cps/simplify.scm +++ b/module/language/cps/simplify.scm @@ -37,12 +37,6 @@ (define (intset-maybe-add! set k add?) (if add? (intset-add! set k) set)) -(define (intset-add* set k*) - (let lp ((set set) (k* k*)) - (match k* - ((k . k*) (lp (intset-add set k) k*)) - (() set)))) - (define (intset-add*! set k*) (fold1 (lambda (k set) (intset-add! set k)) k* set)) From 6d7c09c8a9900794a855b9c69c57c3d1736506ed Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 7 Jan 2016 10:53:57 +0100 Subject: [PATCH 165/865] web: Be less strict when parsing entity tags. * module/web/http.scm (parse-entity-tag): Be less strict, accepting unquoted strings as well. * test-suite/tests/web-http.test ("response headers"): Add a test for etag parsing. --- module/web/http.scm | 13 +++++++++---- test-suite/tests/web-http.test | 3 ++- 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/module/web/http.scm b/module/web/http.scm index a157cf021..8a07f6d0d 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -1,6 +1,6 @@ ;;; HTTP messages -;; Copyright (C) 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011, 2012, 2013, 2014, 2016 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 @@ -848,10 +848,15 @@ as an ordered alist." (display-digits (date-second date) 2 port) (display " GMT" port))) +;; Following https://tools.ietf.org/html/rfc7232#section-2.3, an entity +;; tag should really be a qstring. However there are a number of +;; servers that emit etags as unquoted strings. Assume that if the +;; value doesn't start with a quote, it's an unquoted strong etag. (define (parse-entity-tag val) - (if (string-prefix? "W/" val) - (cons (parse-qstring val 2) #f) - (cons (parse-qstring val) #t))) + (cond + ((string-prefix? "W/" val) (cons (parse-qstring val 2) #f)) + ((string-prefix? "\"" val) (cons (parse-qstring val) #t)) + (else (cons val #t)))) (define (entity-tag? val) (and (pair? val) diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test index dfc9677cf..f01a8326d 100644 --- a/test-suite/tests/web-http.test +++ b/test-suite/tests/web-http.test @@ -1,6 +1,6 @@ ;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010, 2011, 2014 Free Software Foundation, Inc. +;;;; Copyright (C) 2010, 2011, 2014, 2016 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 @@ -343,6 +343,7 @@ (pass-if-parse age "30" 30) (pass-if-parse etag "\"foo\"" '("foo" . #t)) (pass-if-parse etag "W/\"foo\"" '("foo" . #f)) + (pass-if-parse etag "foo" '("foo" . #t)) (pass-if-parse location "http://other-place" (build-uri 'http #:host "other-place")) (pass-if-parse location "#foo" From cf2fadf603b7fa39269d3590ae99dca162c9350d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 7 Jan 2016 16:23:26 +0100 Subject: [PATCH 166/865] statprof: Add tree #:display-style. * module/statprof.scm (statprof-display/flat): Rename from statprof-display. Use real format; we have it. (statprof-display-anomalies): Likewise use real format. (procedure=?): Remove unused function. (collect-cycles): New helper. (statprof-fetch-call-tree): Fix to root the trees correctly -- it was interpreting them in the wrong order. Detect cycles so that it's not so terrible. Use precise locations for source locations. Probably need to add an option to go back to the per-function behavior. (statprof-display/tree): New helper, uses statprof-fetch-call-tree to display a profile in a nested tree. (statprof-display): Add #:style argument, which can be `flat', `anomalies', or `tree'. (statprof): Add #:display-style argument, proxying to #:style, defaulting to 'flat. --- module/statprof.scm | 151 ++++++++++++++++++++++++++++++++++---------- 1 file changed, 119 insertions(+), 32 deletions(-) diff --git a/module/statprof.scm b/module/statprof.scm index 74b32c0ba..a922695ca 100644 --- a/module/statprof.scm +++ b/module/statprof.scm @@ -109,7 +109,9 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) - #:autoload (ice-9 format) (format) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 vlist) #:use-module (system vm vm) #:use-module (system vm frame) #:use-module (system vm debug) @@ -666,8 +668,7 @@ none is available." (statprof-stats-cum-secs-in-proc y)) diff)))) -(define* (statprof-display #:optional (port (current-output-port)) - (state (existing-profiler-state))) +(define* (statprof-display/flat port state) "Displays a gprof-like summary of the statistics collected. Unless an optional @var{port} argument is passed, uses the current output port." (cond @@ -720,11 +721,11 @@ optional @var{port} argument is passed, uses the current output port." (for-each display-stats-line sorted-stats) (display "---\n" port) - (simple-format #t "Sample count: ~A\n" (statprof-sample-count state)) - (simple-format #t "Total time: ~A seconds (~A seconds in GC)\n" - (statprof-accumulated-time state) - (/ (gc-time-taken state) - 1.0 internal-time-units-per-second)))))) + (format #t "Sample count: ~A\n" (statprof-sample-count state)) + (format #t "Total time: ~A seconds (~A seconds in GC)\n" + (statprof-accumulated-time state) + (/ (gc-time-taken state) + 1.0 internal-time-units-per-second)))))) (define* (statprof-display-anomalies #:optional (state (existing-profiler-state))) @@ -735,15 +736,15 @@ statistics.@code{}" (when (and (call-counts state) (zero? (call-data-call-count data)) (positive? (call-data-cum-sample-count data))) - (simple-format #t - "==[~A ~A ~A]\n" - (call-data-name data) - (call-data-call-count data) - (call-data-cum-sample-count data)))) + (format #t + "==[~A ~A ~A]\n" + (call-data-name data) + (call-data-call-count data) + (call-data-cum-sample-count data)))) #f state) - (simple-format #t "Total time: ~A\n" (statprof-accumulated-time state)) - (simple-format #t "Sample count: ~A\n" (statprof-sample-count state))) + (format #t "Total time: ~A\n" (statprof-accumulated-time state)) + (format #t "Sample count: ~A\n" (statprof-sample-count state))) (define (statprof-display-anomolies) (issue-deprecation-warning "statprof-display-anomolies is a misspelling. " @@ -769,15 +770,6 @@ statistics.@code{}" to @code{statprof-reset}." (stack-samples->callee-lists state)) -(define procedure=? - (lambda (a b) - (cond - ((eq? a b)) - ((and (program? a) (program? b)) - (eq? (program-code a) (program-code b))) - (else - #f)))) - ;; tree ::= (car n . tree*) (define (lists->trees lists equal?) @@ -806,6 +798,58 @@ to @code{statprof-reset}." n-terminal (acons (caar in) (list (cdar in)) tails)))))) +(define (collect-cycles items) + (define (find-cycle item stack) + (match (vhash-assoc item stack) + (#f #f) + ((_ . pos) + (let ((size (- (vlist-length stack) pos))) + (and (<= (1- (* size 2)) (vlist-length stack)) + (let lp ((i 0)) + (if (= i (1- size)) + size + (and (equal? (car (vlist-ref stack i)) + (car (vlist-ref stack (+ i size)))) + (lp (1+ i)))))))))) + (define (collect-cycle stack size) + (vlist-fold-right (lambda (pair cycle) + (cons (car pair) cycle)) + '() + (vlist-take stack size))) + (define (detect-cycle items stack) + (match items + (() stack) + ((item . items) + (let* ((cycle-size (find-cycle item stack))) + (if cycle-size + (chomp-cycles (collect-cycle stack cycle-size) + items + (vlist-drop stack (1- (* cycle-size 2)))) + (chomp-cycles (list item) items stack)))))) + (define (skip-cycles cycle items) + (let lp ((a cycle) (b items)) + (match a + (() (skip-cycles cycle b)) + ((a . a*) + (match b + (() items) + ((b . b*) + (if (equal? a b) + (lp a* b*) + items))))))) + (define (chomp-cycles cycle items stack) + (detect-cycle (skip-cycles cycle items) + (vhash-cons (match cycle + ((item) item) + (cycle cycle)) + (vlist-length stack) + stack))) + (vlist-fold + (lambda (pair out) + (cons (car pair) out)) + '() + (detect-cycle items vlist-null))) + (define* (statprof-fetch-call-tree #:optional (state (existing-profiler-state))) "Return a call tree for the previous statprof run. @@ -816,30 +860,73 @@ The return value is a list of nodes, each of which is of the type: (define (callee->printable callee) (cond ((number? callee) - (addr->printable callee (find-program-debug-info callee))) + (let* ((pdi (find-program-debug-info callee)) + (name (or (and=> (and pdi (program-debug-info-name pdi)) + symbol->string) + (string-append "#x" (number->string callee 16)))) + (loc (and=> (find-source-for-addr callee) source->string))) + (if loc + (string-append name " at " loc) + name))) + ((list? callee) + (string-join (map callee->printable callee) ", ")) (else (with-output-to-string (lambda () (write callee)))))) - (define (memoizev/1 proc table) + (define (memoize/1 proc table) (lambda (x) (cond - ((hashv-get-handle table x) => cdr) + ((hash-get-handle table x) => cdr) (else (let ((res (proc x))) - (hashv-set! table x res) + (hash-set! table x res) res))))) - (let ((callee->printable (memoizev/1 callee->printable (make-hash-table)))) + (let ((callee->printable (memoize/1 callee->printable (make-hash-table)))) (cons #t (lists->trees (map (lambda (callee-list) - (map callee->printable callee-list)) + (map callee->printable + (collect-cycles (reverse callee-list)))) (stack-samples->callee-lists state)) equal?)))) +(define (statprof-display/tree port state) + (match (statprof-fetch-call-tree state) + ((#t total-count . trees) + (define (print-tree tree indent) + (define (print-subtree tree) (print-tree tree (+ indent 2))) + (match tree + ((callee count . trees) + (format port "~vt~,1f% ~a\n" indent (* 100. (/ count total-count)) + callee) + (for-each print-subtree trees)))) + (for-each (lambda (tree) (print-tree tree 0)) trees))) + (display "---\n" port) + (format port "Sample count: ~A\n" (statprof-sample-count state)) + (format port "Total time: ~A seconds (~A seconds in GC)\n" + (statprof-accumulated-time state) + (/ (gc-time-taken state) + 1.0 internal-time-units-per-second))) + +(define* (statprof-display #:optional (port (current-output-port)) + (state (existing-profiler-state)) + #:key (style 'flat)) + "Displays a summary of the statistics collected. Unless an optional +@var{port} argument is passed, uses the current output port." + (case style + ((flat) (statprof-display/flat port state)) + ((anomalies) + (with-output-to-port port + (lambda () + (statprof-display-anomalies state)))) + ((tree) (statprof-display/tree port state)) + (else (error "Unknown statprof display style" style)))) + (define (call-thunk thunk) (call-with-values (lambda () (thunk)) (lambda results (apply values results)))) (define* (statprof thunk #:key (loop 1) (hz 100) (count-calls? #f) - (port (current-output-port)) full-stacks?) + (port (current-output-port)) full-stacks? + (display-style 'flat)) "Profile the execution of @var{thunk}, and return its return values. The stack will be sampled @var{hz} times per second, and the thunk @@ -865,7 +952,7 @@ operation is somewhat expensive." (call-thunk thunk)) (lambda () (statprof-stop state) - (statprof-display port state)))))) + (statprof-display port state #:style display-style)))))) (define-macro (with-statprof . args) "Profile the expressions in the body, and return the body's return values. From ee85113f4a9d1ee8311a99070321d91f9486cf56 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 7 Jan 2016 16:56:39 +0100 Subject: [PATCH 167/865] statprof: Better tree-format profiles * module/statprof.scm (statprof-fetch-call-tree): Add #:precise? keyword argument, defaulting to false. Search for cycles after computing printable source locations instead of doing so over addresses -- it could be that two addresses map to the same source location, and from the user's perspective they are then indistinguishable in the printout. --- module/statprof.scm | 48 +++++++++++++++++++++++++++------------------ 1 file changed, 29 insertions(+), 19 deletions(-) diff --git a/module/statprof.scm b/module/statprof.scm index a922695ca..8fb0951e8 100644 --- a/module/statprof.scm +++ b/module/statprof.scm @@ -850,42 +850,52 @@ to @code{statprof-reset}." '() (detect-cycle items vlist-null))) -(define* (statprof-fetch-call-tree #:optional (state (existing-profiler-state))) +(define* (statprof-fetch-call-tree #:optional (state (existing-profiler-state)) + #:key precise?) "Return a call tree for the previous statprof run. The return value is a list of nodes, each of which is of the type: @code node ::= (@var{proc} @var{count} . @var{nodes}) @end code" - (define (callee->printable callee) + (define-syntax-rule (define-memoized (fn arg) body) + (define fn + (let ((table (make-hash-table))) + (lambda (arg) + (cond + ((hash-get-handle table arg) => cdr) + (else + (let ((res body)) + (hash-set! table arg res) + res))))))) + (define-memoized (callee->printable callee) (cond ((number? callee) (let* ((pdi (find-program-debug-info callee)) (name (or (and=> (and pdi (program-debug-info-name pdi)) symbol->string) (string-append "#x" (number->string callee 16)))) - (loc (and=> (find-source-for-addr callee) source->string))) + (loc (and=> (find-source-for-addr + (or (and (not precise?) + (and=> pdi program-debug-info-addr)) + callee)) + source->string))) (if loc (string-append name " at " loc) name))) - ((list? callee) - (string-join (map callee->printable callee) ", ")) (else (with-output-to-string (lambda () (write callee)))))) - (define (memoize/1 proc table) - (lambda (x) - (cond - ((hash-get-handle table x) => cdr) - (else - (let ((res (proc x))) - (hash-set! table x res) - res))))) - (let ((callee->printable (memoize/1 callee->printable (make-hash-table)))) - (cons #t (lists->trees (map (lambda (callee-list) - (map callee->printable - (collect-cycles (reverse callee-list)))) - (stack-samples->callee-lists state)) - equal?)))) + (define (munge-stack stack) + ;; We collect the sample in newest-to-oldest + ;; order. Change to have the oldest first. + (let ((stack (reverse stack))) + (define (cycle->printable item) + (if (string? item) + item + (string-join (map cycle->printable item) ", "))) + (map cycle->printable (collect-cycles (map callee->printable stack))))) + (let ((stacks (map munge-stack (stack-samples->callee-lists state)))) + (cons #t (lists->trees stacks equal?)))) (define (statprof-display/tree port state) (match (statprof-fetch-call-tree state) From f61870979c38bcdba48b3c28d748a3e17c1a7d3f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 17 Jan 2016 16:58:36 +0100 Subject: [PATCH 168/865] Fix type inference of integer division * module/language/cps/types.scm (define-binary-result!): Fix inference of integer division. --- module/language/cps/types.scm | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index a58953d55..4adb8a89e 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -978,13 +978,17 @@ minimum, and maximum." ((and closed? (eqv? a-type &exact-integer) (eqv? b-type &exact-integer)) (define! result &exact-integer min* max*)) (else - ;; Fractions may become integers. - (let ((type (logior a-type b-type))) - (define! result - (if (zero? (logand type &fraction)) - type - (logior type &exact-integer)) - min* max*)))))) + (let* ((type (logior a-type b-type)) + ;; Fractions may become integers. + (type (if (zero? (logand type &fraction)) + type + (logior type &exact-integer))) + ;; Integers may become fractions under division. + (type (if (or closed? + (zero? (logand type (logior &exact-integer)))) + type + (logior type &fraction)))) + (define! result type min* max*)))))) (define-simple-type-checker (add &number &number)) (define-type-aliases add add/immediate) From e4be4aea3491be954da25b8356e97c0fe60f98f9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 29 Jan 2016 09:50:32 +0100 Subject: [PATCH 169/865] Fix cross-compilation of immediates to targets with different word sizes * module/system/vm/assembler.scm (immediate-bits): Rename from immediate?, and return the bits. Take asm argument so that we measure what's an immediate not on the host but for the target. Adapt all callers. (write-immediate): Take bits instead of SCM object. Adapt callers. (write-placeholder): New helper, to write bits for #f. Adapt callers that wrote #f to use write-placeholder. --- module/system/vm/assembler.scm | 93 ++++++++++++++++++++++------------ 1 file changed, 61 insertions(+), 32 deletions(-) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 2d11d8808..53ce5c358 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -919,9 +919,32 @@ lists. This procedure can be called many times before calling ;;; to the table. ;;; -(define-inline (immediate? x) - "Return @code{#t} if @var{x} is immediate, and @code{#f} otherwise." - (not (zero? (logand (object-address x) 6)))) +(define tc2-int 2) +(define (immediate-bits asm x) + "Return the bit pattern to write into the buffer if @var{x} is +immediate, and @code{#f} otherwise." + (let* ((bits (object-address x)) + (mask (case (asm-word-size asm) + ((4) #xffffffff) + ((8) #xffffffffFFFFFFFF) + (else (error "unexpected word size")))) + (fixnum-min (1- (ash mask -3))) + (fixnum-max (ash mask -3))) + (cond + ((not (zero? (logand bits 6))) + ;; Object is an immediate on the host. It's immediate if it can + ;; fit into a word on the target. + (and (= bits (logand bits mask)) + bits)) + ((and (exact-integer? x) (<= fixnum-min x fixnum-max)) + ;; Object is a bignum that would be an immediate on the target. + (let ((fixnum-bits (if (negative? x) + (+ fixnum-max 1 (logand x fixnum-max)) + x))) + (logior (ash x 2) tc2-int))) + (else + ;; Otherwise not an immediate. + #f)))) (define-record-type (make-stringbuf string) @@ -1025,7 +1048,7 @@ table, its existing label is used directly." (else (error "don't know how to intern" obj)))) (cond - ((immediate? obj) #f) + ((immediate-bits asm obj) #f) ((vhash-assoc obj (asm-constants asm)) => cdr) (else ;; Note that calling intern may mutate asm-constants and asm-inits. @@ -1038,7 +1061,7 @@ table, its existing label is used directly." (define (intern-non-immediate asm obj) "Intern a non-immediate into the constant table, and return its label." - (when (immediate? obj) + (when (immediate-bits asm obj) (error "expected a non-immediate" obj)) (intern-constant asm obj)) @@ -1076,15 +1099,15 @@ returned instead." (define-macro-assembler (load-constant asm dst obj) (cond - ((immediate? obj) - (let ((bits (object-address obj))) - (cond - ((and (< dst 256) (zero? (ash bits -16))) - (emit-make-short-immediate asm dst obj)) - ((zero? (ash bits -32)) - (emit-make-long-immediate asm dst obj)) - (else - (emit-make-long-long-immediate asm dst obj))))) + ((immediate-bits asm obj) + => (lambda (bits) + (cond + ((and (< dst 256) (zero? (ash bits -16))) + (emit-make-short-immediate asm dst obj)) + ((zero? (ash bits -32)) + (emit-make-long-immediate asm dst obj)) + (else + (emit-make-long-long-immediate asm dst obj))))) ((statically-allocatable? obj) (emit-make-non-immediate asm dst (intern-non-immediate asm obj))) (else @@ -1290,14 +1313,16 @@ corresponding linker symbol for the start of the section." ;;; residualizes instructions to initialize constants at load time. ;;; -(define (write-immediate asm buf pos x) - (let ((val (object-address x)) - (endianness (asm-endianness asm))) +(define (write-immediate asm buf pos bits) + (let ((endianness (asm-endianness asm))) (case (asm-word-size asm) - ((4) (bytevector-u32-set! buf pos val endianness)) - ((8) (bytevector-u64-set! buf pos val endianness)) + ((4) (bytevector-u32-set! buf pos bits endianness)) + ((8) (bytevector-u64-set! buf pos bits endianness)) (else (error "bad word size" asm))))) +(define (write-placeholder asm buf pos) + (write-immediate asm buf pos (immediate-bits asm #f))) + (define (emit-init-constants asm) "If there is writable data that needs initialization at runtime, emit a procedure to do that and return its label. Otherwise return @@ -1365,8 +1390,12 @@ should be .data or .rodata), and return the resulting linker object. word-size))) (define (write-constant-reference buf pos x) - ;; The asm-inits will fix up any reference to a non-immediate. - (write-immediate asm buf pos (if (immediate? x) x #f))) + (let ((bits (immediate-bits asm x))) + (if bits + (write-immediate asm buf pos bits) + ;; The asm-inits will fix up any reference to a + ;; non-immediate. + (write-placeholder asm buf pos)))) (define (write buf pos obj) (cond @@ -1414,19 +1443,19 @@ should be .data or .rodata), and return the resulting linker object. (else (error "bad word size")))) ((cache-cell? obj) - (write-immediate asm buf pos #f)) + (write-placeholder asm buf pos)) ((string? obj) (let ((tag (logior tc7-ro-string (ash (string-length obj) 8)))) ; FIXME: unused? (case word-size ((4) (bytevector-u32-set! buf pos tc7-ro-string endianness) - (write-immediate asm buf (+ pos 4) #f) ; stringbuf + (write-placeholder asm buf (+ pos 4)) ; stringbuf (bytevector-u32-set! buf (+ pos 8) 0 endianness) (bytevector-u32-set! buf (+ pos 12) (string-length obj) endianness)) ((8) (bytevector-u64-set! buf pos tc7-ro-string endianness) - (write-immediate asm buf (+ pos 8) #f) ; stringbuf + (write-placeholder asm buf (+ pos 8)) ; stringbuf (bytevector-u64-set! buf (+ pos 16) 0 endianness) (bytevector-u64-set! buf (+ pos 24) (string-length obj) endianness)) (else (error "bad word size"))))) @@ -1450,13 +1479,13 @@ should be .data or .rodata), and return the resulting linker object. (lp (1+ i))))))) ((symbol? obj) - (write-immediate asm buf pos #f)) + (write-placeholder asm buf pos)) ((keyword? obj) - (write-immediate asm buf pos #f)) + (write-placeholder asm buf pos)) ((number? obj) - (write-immediate asm buf pos #f)) + (write-placeholder asm buf pos)) ((simple-uniform-vector? obj) (let ((tag (if (bitvector? obj) @@ -1472,7 +1501,7 @@ should be .data or .rodata), and return the resulting linker object. (bytevector-length obj)) endianness) ; length (bytevector-u32-set! buf (+ pos 8) 0 endianness) ; pointer - (write-immediate asm buf (+ pos 12) #f)) ; owner + (write-placeholder asm buf (+ pos 12))) ; owner ((8) (bytevector-u64-set! buf pos tag endianness) (bytevector-u64-set! buf (+ pos 8) @@ -1481,7 +1510,7 @@ should be .data or .rodata), and return the resulting linker object. (bytevector-length obj)) endianness) ; length (bytevector-u64-set! buf (+ pos 16) 0 endianness) ; pointer - (write-immediate asm buf (+ pos 24) #f)) ; owner + (write-placeholder asm buf (+ pos 24))) ; owner (else (error "bad word size"))))) ((uniform-vector-backing-store? obj) @@ -1502,7 +1531,7 @@ should be .data or .rodata), and return the resulting linker object. ((8) (values bytevector-u64-set! bytevector-s64-set!)) (else (error "bad word size"))))) (bv-set! buf pos tag endianness) - (write-immediate asm buf (+ pos word-size) #f) ; root vector (fixed later) + (write-placeholder asm buf (+ pos word-size)) ; root vector (fixed later) (bv-set! buf (+ pos (* word-size 2)) 0 endianness) ; base (let lp ((pos (+ pos (* word-size 3))) (bounds (array-shape obj)) @@ -1548,11 +1577,11 @@ these may be @code{#f}." (cond ((stringbuf? x) #t) ((pair? x) - (and (immediate? (car x)) (immediate? (cdr x)))) + (and (immediate-bits asm (car x)) (immediate-bits asm (cdr x)))) ((simple-vector? x) (let lp ((i 0)) (or (= i (vector-length x)) - (and (immediate? (vector-ref x i)) + (and (immediate-bits asm (vector-ref x i)) (lp (1+ i)))))) ((uniform-vector-backing-store? x) #t) (else #f))) From eccdeb6cc6c164ea10160fafbd276b6dc5e9b73e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 29 Jan 2016 10:21:44 +0100 Subject: [PATCH 170/865] Distribute prebuilt bootstraps for common hosts * am/bootstrap.am: New file, factored out of bootstrap/Makefile.am. * bootstrap/Makefile.am: Use bootstrap.am. * prebuilt/Makefile.am: * prebuilt/i686-pc-linux-gnu/Makefile.am: * prebuilt/mips-unknown-linux-gnu/Makefile.am: * prebuilt/x86_64-unknown-linux-gnu/Makefile.am: New files. * configure.ac: Output the prebuilt/ makefiles. * Makefile.am: Descend into prebuilt/ when making dist. * meta/uninstalled-env.in: Arrange to put prebuilt/ in the beginning of the GUILE_LOAD_COMPILED_PATH. Also fix a case where bootstrap/ wasn't being correctly added to the load path. --- Makefile.am | 2 + am/bootstrap.am | 153 ++++++++++++++++++ bootstrap/Makefile.am | 133 +-------------- configure.ac | 5 + meta/uninstalled-env.in | 27 ++-- prebuilt/Makefile.am | 56 +++++++ prebuilt/i686-pc-linux-gnu/Makefile.am | 25 +++ prebuilt/mips-unknown-linux-gnu/Makefile.am | 25 +++ prebuilt/x86_64-unknown-linux-gnu/Makefile.am | 25 +++ 9 files changed, 308 insertions(+), 143 deletions(-) create mode 100644 am/bootstrap.am create mode 100644 prebuilt/Makefile.am create mode 100644 prebuilt/i686-pc-linux-gnu/Makefile.am create mode 100644 prebuilt/mips-unknown-linux-gnu/Makefile.am create mode 100644 prebuilt/x86_64-unknown-linux-gnu/Makefile.am diff --git a/Makefile.am b/Makefile.am index 7918c7974..070332611 100644 --- a/Makefile.am +++ b/Makefile.am @@ -41,6 +41,8 @@ SUBDIRS = \ am \ doc +DIST_SUBDIRS = $(SUBDIRS) prebuilt + libguileincludedir = $(pkgincludedir)/$(GUILE_EFFECTIVE_VERSION) libguileinclude_HEADERS = libguile.h diff --git a/am/bootstrap.am b/am/bootstrap.am new file mode 100644 index 000000000..d613d7f02 --- /dev/null +++ b/am/bootstrap.am @@ -0,0 +1,153 @@ +## Copyright (C) 2009, 2010, 2011, 2012, 2013, +## 2014, 2015 Free Software Foundation, Inc. +## +## This file is part of GNU Guile. +## +## GNU Guile is free software; you can redistribute it and/or modify +## it under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or (at +## your option) any later version. +## +## GNU Guile is distributed in the hope that it will be useful, but +## WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU Lesser General Public License for more details. +## +## You should have received a copy of the GNU Lesser General Public +## License along with GNU Guile; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA + +# These variables can be set before you include bootstrap.am. +GUILE_WARNINGS ?= -Wunbound-variable -Warity-mismatch -Wformat +GUILE_OPTIMIZATIONS ?= -O2 +GUILE_TARGET ?= $(host) +GUILE_BUILD_TAG ?= BOOTSTRAP + +GOBJECTS = $(SOURCES:%.scm=%.go) +nobase_noinst_DATA = $(GOBJECTS) +CLEANFILES = $(GOBJECTS) + +VM_TARGETS = system/vm/assembler.go system/vm/disassembler.go +$(VM_TARGETS): $(top_builddir)/libguile/vm-operations.h + +AM_V_GUILEC = $(AM_V_GUILEC_$(V)) +AM_V_GUILEC_ = $(AM_V_GUILEC_$(AM_DEFAULT_VERBOSITY)) +AM_V_GUILEC_0 = @echo " $(GUILE_BUILD_TAG) GUILEC" $@; + +vpath %.scm @top_srcdir@/module + +SUFFIXES = .scm .go + +.scm.go: + $(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \ + $(top_builddir)/meta/uninstalled-env \ + guild compile --target="$(GUILE_TARGET)" \ + $(GUILE_WARNINGS) $(GUILE_OPTIMIZATIONS) \ + -L "$(abs_top_srcdir)/module" \ + -L "$(abs_top_srcdir)/guile-readline" \ + -o "$@" "$<" + +# A subset of sources that are used by the compiler. We can compile +# these in any order; the order below is designed to hopefully result in +# the lowest total compile time. +SOURCES = \ + ice-9/eval.scm \ + ice-9/psyntax-pp.scm \ + language/cps/intmap.scm \ + language/cps/intset.scm \ + language/cps/utils.scm \ + ice-9/vlist.scm \ + srfi/srfi-1.scm \ + \ + language/tree-il.scm \ + language/tree-il/analyze.scm \ + language/tree-il/canonicalize.scm \ + language/tree-il/compile-cps.scm \ + language/tree-il/debug.scm \ + language/tree-il/effects.scm \ + language/tree-il/fix-letrec.scm \ + language/tree-il/optimize.scm \ + language/tree-il/peval.scm \ + language/tree-il/primitives.scm \ + language/tree-il/spec.scm \ + \ + language/cps.scm \ + language/cps/closure-conversion.scm \ + language/cps/compile-bytecode.scm \ + language/cps/constructors.scm \ + language/cps/contification.scm \ + language/cps/cse.scm \ + language/cps/dce.scm \ + language/cps/effects-analysis.scm \ + language/cps/elide-values.scm \ + language/cps/licm.scm \ + language/cps/peel-loops.scm \ + language/cps/primitives.scm \ + language/cps/prune-bailouts.scm \ + language/cps/prune-top-level-scopes.scm \ + language/cps/reify-primitives.scm \ + language/cps/renumber.scm \ + language/cps/rotate-loops.scm \ + language/cps/optimize.scm \ + language/cps/simplify.scm \ + language/cps/self-references.scm \ + language/cps/slot-allocation.scm \ + language/cps/spec.scm \ + language/cps/specialize-primcalls.scm \ + language/cps/specialize-numbers.scm \ + language/cps/split-rec.scm \ + language/cps/type-checks.scm \ + language/cps/type-fold.scm \ + language/cps/types.scm \ + language/cps/verify.scm \ + language/cps/with-cps.scm \ + \ + language/scheme/spec.scm \ + language/scheme/compile-tree-il.scm \ + language/scheme/decompile-tree-il.scm \ + \ + language/bytecode.scm \ + language/bytecode/spec.scm \ + \ + language/value/spec.scm \ + \ + system/base/pmatch.scm \ + system/base/syntax.scm \ + system/base/compile.scm \ + system/base/language.scm \ + system/base/lalr.scm \ + system/base/message.scm \ + system/base/target.scm \ + system/base/types.scm \ + system/base/ck.scm \ + \ + ice-9/boot-9.scm \ + ice-9/r5rs.scm \ + ice-9/deprecated.scm \ + ice-9/binary-ports.scm \ + ice-9/command-line.scm \ + ice-9/control.scm \ + ice-9/format.scm \ + ice-9/getopt-long.scm \ + ice-9/i18n.scm \ + ice-9/match.scm \ + ice-9/networking.scm \ + ice-9/posix.scm \ + ice-9/rdelim.scm \ + ice-9/receive.scm \ + ice-9/regex.scm \ + ice-9/session.scm \ + ice-9/pretty-print.scm \ + \ + system/vm/assembler.scm \ + system/vm/debug.scm \ + system/vm/disassembler.scm \ + system/vm/dwarf.scm \ + system/vm/elf.scm \ + system/vm/frame.scm \ + system/vm/linker.scm \ + system/vm/loader.scm \ + system/vm/program.scm \ + system/vm/vm.scm \ + system/foreign.scm diff --git a/bootstrap/Makefile.am b/bootstrap/Makefile.am index e954059bb..496d5301a 100644 --- a/bootstrap/Makefile.am +++ b/bootstrap/Makefile.am @@ -21,138 +21,11 @@ ## Fifth Floor, Boston, MA 02110-1301 USA -GOBJECTS = $(SOURCES:%.scm=%.go) -# No warnings for the bootstrap build. Run -# make GUILE_WARNINGS="-Wunbound-variable -Warity-mismatch -Wformat" -# to get the normal set of warnings. GUILE_WARNINGS = GUILE_OPTIMIZATIONS = -O1 -nobase_noinst_DATA = $(GOBJECTS) ice-9/eval.go -CLEANFILES = $(GOBJECTS) ice-9/eval.go + +include $(top_srcdir)/am/bootstrap.am # We must build the evaluator first, so that we can be sure to control # the stack. -$(GOBJECTS): ice-9/eval.go - -VM_TARGETS := system/vm/assembler.go system/vm/disassembler.go -$(VM_TARGETS): $(top_builddir)/libguile/vm-operations.h - -AM_V_GUILEC = $(AM_V_GUILEC_$(V)) -AM_V_GUILEC_ = $(AM_V_GUILEC_$(AM_DEFAULT_VERBOSITY)) -AM_V_GUILEC_0 = @echo " BOOTSTRAP GUILEC" $@; - -vpath %.scm @srcdir@/../module - -SUFFIXES = .scm .go - -.scm.go: - $(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \ - $(top_builddir)/meta/uninstalled-env \ - guild compile --target="$(host)" \ - $(GUILE_WARNINGS) $(GUILE_OPTIMIZATIONS) \ - -L "$(abs_top_srcdir)/module" \ - -L "$(abs_top_srcdir)/guile-readline" \ - -o "$@" "$<" - -# A subset of sources that are used by the compiler. We can compile -# these in any order; the order below is designed to hopefully result in -# the lowest total compile time. -SOURCES = \ - ice-9/psyntax-pp.scm \ - language/cps/intmap.scm \ - language/cps/intset.scm \ - language/cps/utils.scm \ - ice-9/vlist.scm \ - srfi/srfi-1.scm \ - \ - language/tree-il.scm \ - language/tree-il/analyze.scm \ - language/tree-il/canonicalize.scm \ - language/tree-il/compile-cps.scm \ - language/tree-il/debug.scm \ - language/tree-il/effects.scm \ - language/tree-il/fix-letrec.scm \ - language/tree-il/optimize.scm \ - language/tree-il/peval.scm \ - language/tree-il/primitives.scm \ - language/tree-il/spec.scm \ - \ - language/cps.scm \ - language/cps/closure-conversion.scm \ - language/cps/compile-bytecode.scm \ - language/cps/constructors.scm \ - language/cps/contification.scm \ - language/cps/cse.scm \ - language/cps/dce.scm \ - language/cps/effects-analysis.scm \ - language/cps/elide-values.scm \ - language/cps/licm.scm \ - language/cps/peel-loops.scm \ - language/cps/primitives.scm \ - language/cps/prune-bailouts.scm \ - language/cps/prune-top-level-scopes.scm \ - language/cps/reify-primitives.scm \ - language/cps/renumber.scm \ - language/cps/rotate-loops.scm \ - language/cps/optimize.scm \ - language/cps/simplify.scm \ - language/cps/self-references.scm \ - language/cps/slot-allocation.scm \ - language/cps/spec.scm \ - language/cps/specialize-primcalls.scm \ - language/cps/specialize-numbers.scm \ - language/cps/split-rec.scm \ - language/cps/type-checks.scm \ - language/cps/type-fold.scm \ - language/cps/types.scm \ - language/cps/verify.scm \ - language/cps/with-cps.scm \ - \ - language/scheme/spec.scm \ - language/scheme/compile-tree-il.scm \ - language/scheme/decompile-tree-il.scm \ - \ - language/bytecode.scm \ - language/bytecode/spec.scm \ - \ - language/value/spec.scm \ - \ - system/base/pmatch.scm \ - system/base/syntax.scm \ - system/base/compile.scm \ - system/base/language.scm \ - system/base/lalr.scm \ - system/base/message.scm \ - system/base/target.scm \ - system/base/types.scm \ - system/base/ck.scm \ - \ - ice-9/boot-9.scm \ - ice-9/r5rs.scm \ - ice-9/deprecated.scm \ - ice-9/binary-ports.scm \ - ice-9/command-line.scm \ - ice-9/control.scm \ - ice-9/format.scm \ - ice-9/getopt-long.scm \ - ice-9/i18n.scm \ - ice-9/match.scm \ - ice-9/networking.scm \ - ice-9/posix.scm \ - ice-9/rdelim.scm \ - ice-9/receive.scm \ - ice-9/regex.scm \ - ice-9/session.scm \ - ice-9/pretty-print.scm \ - \ - system/vm/assembler.scm \ - system/vm/debug.scm \ - system/vm/disassembler.scm \ - system/vm/dwarf.scm \ - system/vm/elf.scm \ - system/vm/frame.scm \ - system/vm/linker.scm \ - system/vm/loader.scm \ - system/vm/program.scm \ - system/vm/vm.scm \ - system/foreign.scm +$(filter-out ice-9/eval.go, $(GOBJECTS)): ice-9/eval.go diff --git a/configure.ac b/configure.ac index 9e639d6da..0eb2368ec 100644 --- a/configure.ac +++ b/configure.ac @@ -1645,8 +1645,13 @@ AC_CONFIG_FILES([ meta/Makefile bootstrap/Makefile module/Makefile + prebuilt/Makefile + prebuilt/x86_64-unknown-linux-gnu/Makefile + prebuilt/i686-pc-linux-gnu/Makefile + prebuilt/mips-unknown-linux-gnu/Makefile ]) + GUILE_CONFIG_SCRIPT([check-guile]) GUILE_CONFIG_SCRIPT([benchmark-guile]) GUILE_CONFIG_SCRIPT([meta/guile]) diff --git a/meta/uninstalled-env.in b/meta/uninstalled-env.in index 3bcde8eb9..7197eabee 100644 --- a/meta/uninstalled-env.in +++ b/meta/uninstalled-env.in @@ -80,21 +80,22 @@ then fi export GUILE_LOAD_PATH - if test "x$GUILE_LOAD_COMPILED_PATH" = "x" - then - GUILE_LOAD_COMPILED_PATH="${top_builddir}/module:${top_builddir}/guile-readline" + if test "x$GUILE_LOAD_COMPILED_PATH" = "x"; then + GUILE_LOAD_COMPILED_PATH="${top_srcdir}/prebuilt/@host@" else - for d in "/bootstrap" "/module" "/guile-readline" - do - # This hair prevents double inclusion. - # The ":" prevents prefix aliasing. - case x"$GUILE_LOAD_COMPILED_PATH" in - x*${top_builddir}${d}:*) ;; - x*${top_builddir}${d}) ;; - *) GUILE_LOAD_COMPILED_PATH="${top_builddir}${d}:$GUILE_LOAD_COMPILED_PATH" ;; - esac - done + GUILE_LOAD_COMPILED_PATH="${top_srcdir}/prebuilt/@host@:$GUILE_LOAD_COMPILED_PATH" fi + + for d in "/bootstrap" "/module" "/guile-readline" + do + # This hair prevents double inclusion. + # The ":" prevents prefix aliasing. + case x"$GUILE_LOAD_COMPILED_PATH" in + x*${top_builddir}${d}:*) ;; + x*${top_builddir}${d}) ;; + *) GUILE_LOAD_COMPILED_PATH="${top_builddir}${d}:$GUILE_LOAD_COMPILED_PATH" ;; + esac + done export GUILE_LOAD_COMPILED_PATH # Don't look in installed dirs for guile modules diff --git a/prebuilt/Makefile.am b/prebuilt/Makefile.am new file mode 100644 index 000000000..b0a24d023 --- /dev/null +++ b/prebuilt/Makefile.am @@ -0,0 +1,56 @@ +## Process this file with automake to produce Makefile.in. +## +## Copyright (C) 2016 Free Software Foundation, Inc. +## +## This file is part of GNU Guile. +## +## GNU Guile is free software; you can redistribute it and/or modify +## it under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or (at +## your option) any later version. +## +## GNU Guile is distributed in the hope that it will be useful, but +## WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU Lesser General Public License for more details. +## +## You should have received a copy of the GNU Lesser General Public +## License along with GNU Guile; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA + +# Guile Scheme is mostly written in Guile Scheme. Its compiler is +# written in Guile Scheme, and its interpreter too. However, it is not +# bootstrapped from itself: Guile includes a minimal interpreter written +# in C as well which can load the compiler, enough to compile the +# interpreter written in Scheme. That compiled interpreter written in +# Scheme is then used to compile the rest of Guile, including the +# compiler itself. +# +# The problem is, this process takes a long time, and for people +# installing Guile from source, it's their first experience of Guile: an +# hour-long bootstrap. It's not the nicest experience. To avoid this, +# in our tarballs we pre-build object files for the essential parts of +# the compiler. +# +# In the future we will do native compilation and so we will need to +# precompile object files for all common host types. Still, since we +# use ELF everywhere, there will be many host types whose compiled files +# are the same: because Guile incorporates its own linker and loader for +# compiled Scheme files, any AArch64 machine, for example, is going to +# have the same compiled files. So, for the variants that will be the +# same, we compile one target triple, and symlink the similar targets to +# that directory. +# +# The current situation though is that we compile to bytecode, and there +# are only four variants of that bytecode: big- or little-endian, and +# 32- or 64-bit. The strategy is the same, only that now +# arm64-unknown-linux-gnu will link to x86_64-unknown-linux-gnu, as they +# have the same word size and endianness. A pending issue to resolve is +# how this wil deal with architectures where longs are 32 bits and +# pointers are 64 bits; we'll let the x32 people deal with that. + +SUBDIRS = \ + x86_64-unknown-linux-gnu \ + i686-pc-linux-gnu \ + mips-unknown-linux-gnu diff --git a/prebuilt/i686-pc-linux-gnu/Makefile.am b/prebuilt/i686-pc-linux-gnu/Makefile.am new file mode 100644 index 000000000..6b5683498 --- /dev/null +++ b/prebuilt/i686-pc-linux-gnu/Makefile.am @@ -0,0 +1,25 @@ +## Process this file with automake to produce Makefile.in. +## +## Copyright (C) 2016 Free Software Foundation, Inc. +## +## This file is part of GNU Guile. +## +## GNU Guile is free software; you can redistribute it and/or modify +## it under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or (at +## your option) any later version. +## +## GNU Guile is distributed in the hope that it will be useful, but +## WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU Lesser General Public License for more details. +## +## You should have received a copy of the GNU Lesser General Public +## License along with GNU Guile; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA + +GUILE_TARGET = $(shell basename $(subdir)) +GUILE_BUILD_TAG = PREBUILD $(GUILE_TARGET) + +include $(top_srcdir)/am/bootstrap.am diff --git a/prebuilt/mips-unknown-linux-gnu/Makefile.am b/prebuilt/mips-unknown-linux-gnu/Makefile.am new file mode 100644 index 000000000..6b5683498 --- /dev/null +++ b/prebuilt/mips-unknown-linux-gnu/Makefile.am @@ -0,0 +1,25 @@ +## Process this file with automake to produce Makefile.in. +## +## Copyright (C) 2016 Free Software Foundation, Inc. +## +## This file is part of GNU Guile. +## +## GNU Guile is free software; you can redistribute it and/or modify +## it under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or (at +## your option) any later version. +## +## GNU Guile is distributed in the hope that it will be useful, but +## WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU Lesser General Public License for more details. +## +## You should have received a copy of the GNU Lesser General Public +## License along with GNU Guile; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA + +GUILE_TARGET = $(shell basename $(subdir)) +GUILE_BUILD_TAG = PREBUILD $(GUILE_TARGET) + +include $(top_srcdir)/am/bootstrap.am diff --git a/prebuilt/x86_64-unknown-linux-gnu/Makefile.am b/prebuilt/x86_64-unknown-linux-gnu/Makefile.am new file mode 100644 index 000000000..6b5683498 --- /dev/null +++ b/prebuilt/x86_64-unknown-linux-gnu/Makefile.am @@ -0,0 +1,25 @@ +## Process this file with automake to produce Makefile.in. +## +## Copyright (C) 2016 Free Software Foundation, Inc. +## +## This file is part of GNU Guile. +## +## GNU Guile is free software; you can redistribute it and/or modify +## it under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or (at +## your option) any later version. +## +## GNU Guile is distributed in the hope that it will be useful, but +## WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +## GNU Lesser General Public License for more details. +## +## You should have received a copy of the GNU Lesser General Public +## License along with GNU Guile; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA + +GUILE_TARGET = $(shell basename $(subdir)) +GUILE_BUILD_TAG = PREBUILD $(GUILE_TARGET) + +include $(top_srcdir)/am/bootstrap.am From 9eb841c2d860d5038b09e6c2b1bcd697ecc707fd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 29 Jan 2016 10:24:40 +0100 Subject: [PATCH 171/865] Fix uniform vector compilation to foreign byte orders. * module/system/vm/assembler.scm (define-byte-order-swapper): New helper. (byte-swap/2!, byte-swap/4!, byte-swap/8!): New functions. (link-data): Swap bytes in uniform vectors on foreign byte orders. --- module/system/vm/assembler.scm | 45 ++++++++++++++++++++-------------- 1 file changed, 26 insertions(+), 19 deletions(-) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 53ce5c358..94ebf0368 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -293,6 +293,24 @@ (if f2 (ash 1 1) 0)))))) +(define-syntax-rule (define-byte-order-swapper name size ref set) + (define* (name buf #:optional (start 0) (end (bytevector-length buf))) + "Patch up the text buffer @var{buf}, swapping the endianness of each +N-byte unit." + (unless (zero? (modulo (- end start) size)) + (error "unexpected length")) + (let lp ((pos start)) + (when (< pos end) + (set buf pos (ref buf pos (endianness big)) (endianness little)) + (lp (+ pos size)))))) + +(define-byte-order-swapper byte-swap/2! + 2 bytevector-u16-ref bytevector-u16-set!) +(define-byte-order-swapper byte-swap/4! + 4 bytevector-u32-ref bytevector-u32-set!) +(define-byte-order-swapper byte-swap/8! + 8 bytevector-u64-ref bytevector-u64-set!) + ;;; A entry collects metadata for one procedure. Procedures are @@ -1516,10 +1534,13 @@ should be .data or .rodata), and return the resulting linker object. ((uniform-vector-backing-store? obj) (let ((bv (uniform-vector-backing-store-bytes obj))) (bytevector-copy! bv 0 buf pos (bytevector-length bv)) - (unless (or (= 1 (uniform-vector-backing-store-element-size obj)) - (eq? endianness (native-endianness))) - ;; Need to swap units of element-size bytes - (error "FIXME: Implement byte order swap")))) + (unless (eq? endianness (native-endianness)) + (case (uniform-vector-backing-store-element-size obj) + ((1) #f) ;; Nothing to do. + ((2) (byte-swap/2! buf pos (+ pos (bytevector-length bv)))) + ((4) (byte-swap/4! buf pos (+ pos (bytevector-length bv)))) + ((8) (byte-swap/8! buf pos (+ pos (bytevector-length bv)))) + (else (error "FIXME: Implement byte order swap")))))) ((array? obj) (let-values @@ -1647,27 +1668,13 @@ The offsets are expected to be expressed in words." (make-linker-symbol label loc)) labels)) -(define (swap-bytes! buf) - "Patch up the text buffer @var{buf}, swapping the endianness of each -32-bit unit." - (unless (zero? (modulo (bytevector-length buf) 4)) - (error "unexpected length")) - (let ((byte-len (bytevector-length buf))) - (let lp ((pos 0)) - (unless (= pos byte-len) - (bytevector-u32-set! - buf pos - (bytevector-u32-ref buf pos (endianness big)) - (endianness little)) - (lp (+ pos 4)))))) - (define (link-text-object asm) "Link the .rtl-text section, swapping the endianness of the bytes if needed." (let ((buf (make-bytevector (asm-pos asm)))) (bytevector-copy! (asm-buf asm) 0 buf 0 (bytevector-length buf)) (unless (eq? (asm-endianness asm) (native-endianness)) - (swap-bytes! buf)) + (byte-swap/4! buf)) (make-object asm '.rtl-text buf (process-relocs buf (asm-relocs asm) From ffc9bc9149d7c99940e1fe4537d3235846802380 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 29 Jan 2016 10:36:32 +0100 Subject: [PATCH 172/865] Dist the prebuilt .go files * prebuilt/i686-pc-linux-gnu/Makefile.am: * prebuilt/mips-unknown-linux-gnu/Makefile.am: * prebuilt/x86_64-unknown-linux-gnu/Makefile.am: Actually dist the .go files. --- prebuilt/i686-pc-linux-gnu/Makefile.am | 2 ++ prebuilt/mips-unknown-linux-gnu/Makefile.am | 2 ++ prebuilt/x86_64-unknown-linux-gnu/Makefile.am | 2 ++ 3 files changed, 6 insertions(+) diff --git a/prebuilt/i686-pc-linux-gnu/Makefile.am b/prebuilt/i686-pc-linux-gnu/Makefile.am index 6b5683498..327002b60 100644 --- a/prebuilt/i686-pc-linux-gnu/Makefile.am +++ b/prebuilt/i686-pc-linux-gnu/Makefile.am @@ -23,3 +23,5 @@ GUILE_TARGET = $(shell basename $(subdir)) GUILE_BUILD_TAG = PREBUILD $(GUILE_TARGET) include $(top_srcdir)/am/bootstrap.am + +EXTRA_DIST = $(GOBJECTS) diff --git a/prebuilt/mips-unknown-linux-gnu/Makefile.am b/prebuilt/mips-unknown-linux-gnu/Makefile.am index 6b5683498..327002b60 100644 --- a/prebuilt/mips-unknown-linux-gnu/Makefile.am +++ b/prebuilt/mips-unknown-linux-gnu/Makefile.am @@ -23,3 +23,5 @@ GUILE_TARGET = $(shell basename $(subdir)) GUILE_BUILD_TAG = PREBUILD $(GUILE_TARGET) include $(top_srcdir)/am/bootstrap.am + +EXTRA_DIST = $(GOBJECTS) diff --git a/prebuilt/x86_64-unknown-linux-gnu/Makefile.am b/prebuilt/x86_64-unknown-linux-gnu/Makefile.am index 6b5683498..327002b60 100644 --- a/prebuilt/x86_64-unknown-linux-gnu/Makefile.am +++ b/prebuilt/x86_64-unknown-linux-gnu/Makefile.am @@ -23,3 +23,5 @@ GUILE_TARGET = $(shell basename $(subdir)) GUILE_BUILD_TAG = PREBUILD $(GUILE_TARGET) include $(top_srcdir)/am/bootstrap.am + +EXTRA_DIST = $(GOBJECTS) From 67e8aa85e81af1644eb75893c173a697ae3d687f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 30 Jan 2016 17:47:03 +0100 Subject: [PATCH 173/865] Remove frame-local-ref, frame-local-set! * libguile/frames.h (scm_frame_num_locals, scm_frame_local_ref) (scm_frame_local_set_x): Remove. As long as we are changing the interface in a backward-incompatible way, we might as well remove these. * libguile/frames.c (scm_frame_num_locals, scm_frame_local_ref) (scm_frame_local_set_x, scm_init_frames_builtins, scm_init_frames): Arrange to make frame-local-ref et al private to frames.scm. * module/system/vm/frame.scm: Load scm_init_frames_builtins extensions. (frame-instruction-pointer-or-primitive-procedure-name): New public function. (frame-binding-ref, frame-binding-set!): Allow binding objects as vars. * module/system/repl/debug.scm (print-locals): Pass binding directly to frame-binding-ref. * module/statprof.scm (sample-stack-procs, count-call): Use new frame-instruction-pointer-or-primitive-procedure-name function. --- libguile/frames.c | 35 +++++++++++++++++++++++++---------- libguile/frames.h | 4 ---- module/statprof.scm | 14 +++----------- module/system/repl/debug.scm | 3 +-- module/system/vm/frame.scm | 27 +++++++++++++++++++++++---- 5 files changed, 52 insertions(+), 31 deletions(-) diff --git a/libguile/frames.c b/libguile/frames.c index e1d7cf872..534720f4c 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -222,9 +222,9 @@ SCM_DEFINE (scm_frame_source, "frame-source", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0, - (SCM frame), - "") +static const char s_scm_frame_num_locals[] = "frame-num-locals"; +static SCM +scm_frame_num_locals (SCM frame) #define FUNC_NAME s_scm_frame_num_locals { union scm_vm_stack_element *fp, *sp; @@ -262,9 +262,9 @@ scm_to_stack_item_representation (SCM x, const char *subr, int pos) return 0; /* Not reached. */ } -SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 3, 0, 0, - (SCM frame, SCM index, SCM representation), - "") +static const char s_scm_frame_local_ref[] = "frame-local-ref"; +static SCM +scm_frame_local_ref (SCM frame, SCM index, SCM representation) #define FUNC_NAME s_scm_frame_local_ref { union scm_vm_stack_element *fp, *sp; @@ -300,10 +300,9 @@ SCM_DEFINE (scm_frame_local_ref, "frame-local-ref", 3, 0, 0, } #undef FUNC_NAME -/* Need same not-yet-active frame logic here as in frame-num-locals */ -SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 4, 0, 0, - (SCM frame, SCM index, SCM val, SCM representation), - "") +static const char s_scm_frame_local_set_x[] = "frame-local-set!"; +static SCM +scm_frame_local_set_x (SCM frame, SCM index, SCM val, SCM representation) #define FUNC_NAME s_scm_frame_local_set_x { union scm_vm_stack_element *fp, *sp; @@ -449,12 +448,28 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0, #undef FUNC_NAME +static void +scm_init_frames_builtins (void *unused) +{ + scm_c_define_gsubr (s_scm_frame_num_locals, 1, 0, 0, + (scm_t_subr) scm_frame_num_locals); + scm_c_define_gsubr (s_scm_frame_local_ref, 3, 0, 0, + (scm_t_subr) scm_frame_local_ref); + scm_c_define_gsubr (s_scm_frame_local_set_x, 4, 0, 0, + (scm_t_subr) scm_frame_local_set_x); +} + void scm_init_frames (void) { #ifndef SCM_MAGIC_SNARFER #include "libguile/frames.x" #endif + + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_frames_builtins", + scm_init_frames_builtins, + NULL); } /* diff --git a/libguile/frames.h b/libguile/frames.h index 5aa5499ba..ef668a9ce 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -162,10 +162,6 @@ SCM_API SCM scm_frame_procedure_name (SCM frame); SCM_API SCM scm_frame_call_representation (SCM frame); SCM_API SCM scm_frame_arguments (SCM frame); SCM_API SCM scm_frame_source (SCM frame); -SCM_API SCM scm_frame_num_locals (SCM frame); -SCM_API SCM scm_frame_local_ref (SCM frame, SCM index, SCM representation); -SCM_API SCM scm_frame_local_set_x (SCM frame, SCM index, SCM val, - SCM representation); SCM_API SCM scm_frame_address (SCM frame); SCM_API SCM scm_frame_stack_pointer (SCM frame); SCM_API SCM scm_frame_instruction_pointer (SCM frame); diff --git a/module/statprof.scm b/module/statprof.scm index 8fb0951e8..7a18bb420 100644 --- a/module/statprof.scm +++ b/module/statprof.scm @@ -329,13 +329,8 @@ (set-buffer! state buffer) (set-buffer-pos! state (1+ pos))) (else - (let ((ip (frame-instruction-pointer frame))) - (write-sample-and-continue - (if (primitive-code? ip) - ;; Grovel and get the primitive name from the gsubr, which - ;; we know to be in slot 0. - (procedure-name (frame-local-ref frame 0 'scm)) - ip))))))) + (write-sample-and-continue + (frame-instruction-pointer-or-primitive-procedure-name frame)))))) (define (reset-sigprof-timer usecs) ;; Guile's setitimer binding is terrible. @@ -382,10 +377,7 @@ (accumulate-time state (get-internal-run-time)) ;; We know local 0 is a SCM value: the c - (let* ((ip (frame-instruction-pointer frame)) - (key (if (primitive-code? ip) - (procedure-name (frame-local-ref frame 0 'scm)) - ip)) + (let* ((key (frame-instruction-pointer-or-primitive-procedure-name frame)) (handle (hashv-create-handle! (call-counts state) key 0))) (set-cdr! handle (1+ (cdr handle)))) diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm index 18ac10f5b..4bd9e2758 100644 --- a/module/system/repl/debug.scm +++ b/module/system/repl/debug.scm @@ -115,8 +115,7 @@ (format port "~aLocal variables:~%" per-line-prefix) (for-each (lambda (binding) - (let ((v (frame-local-ref frame (binding-slot binding) - (binding-representation binding)))) + (let ((v (frame-binding-ref frame binding))) (display per-line-prefix port) (run-hook before-print-hook v) (format port "~a = ~v:@y\n" (binding-name binding) width v))) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index ccfc05745..15e745d18 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -33,6 +33,7 @@ binding-slot binding-representation + frame-instruction-pointer-or-primitive-procedure-name frame-bindings frame-lookup-binding frame-binding-ref frame-binding-set! @@ -40,6 +41,10 @@ frame-environment frame-object-binding frame-object-name)) +(eval-when (expand compile load eval) + (load-extension (string-append "libguile-" (effective-version)) + "scm_init_frames_builtins")) + (define-record-type (make-binding idx name slot representation) binding? @@ -300,14 +305,18 @@ (lp (cdr bindings)))))) (define (frame-binding-set! frame var val) - (let ((binding (or (frame-lookup-binding frame var) - (error "variable not bound in frame" var frame)))) + (let ((binding (if (binding? var) + var + (or (frame-lookup-binding frame var) + (error "variable not bound in frame" var frame))))) (frame-local-set! frame (binding-slot binding) val (binding-representation binding)))) (define (frame-binding-ref frame var) - (let ((binding (or (frame-lookup-binding frame var) - (error "variable not bound in frame" var frame)))) + (let ((binding (if (binding? var) + var + (or (frame-lookup-binding frame var) + (error "variable not bound in frame" var frame))))) (frame-local-ref frame (binding-slot binding) (binding-representation binding)))) @@ -340,6 +349,16 @@ (define (frame-arguments frame) (cdr (frame-call-representation frame))) +;; Usually the IP is sufficient to identify the procedure being called. +;; However all primitive applications of the same arity share the same +;; code. Perhaps we should change that in the future, but for now we +;; export this function to avoid having to export frame-local-ref. +;; +(define (frame-instruction-pointer-or-primitive-procedure-name frame) + (let ((ip (frame-instruction-pointer frame))) + (if (primitive-code? ip) + (procedure-name (frame-local-ref frame 0 'scm)) + ip))) ;;; From cd0b61a04e5fa7db62c8795d3bdbee1bc831199a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 31 Jan 2016 11:15:58 +0100 Subject: [PATCH 174/865] Frame objects capture frame, can ref value directly * module/system/repl/debug.scm (print-locals): Adapt to frame-binding-ref change. * module/system/vm/frame.scm (): Add `frame' field. (available-bindings): Capture the frame. (binding-ref, binding-set!): New functions, accessing a local variable value directly from a frame. (frame-binding-ref, frame-binding-set!): Remove. As these are very low-level debugging interfaces introduced in 2.0, never documented, and quite tied to the VM, we feel comfortable making this change. (frame-call-representation): Adapt to available-bindings change. (frame-environment, frame-object-binding): Adapt to binding-ref interface change. * doc/ref/vm.texi (Stack Layout): Mention that slots can be re-used. Update disassembly in example. * doc/ref/api-debug.texi (Frames): Remove documentation for frame-local-ref, frame-local-set!, and frame-num-locals. Replace with documentation for frame-bindings, binding accessors, and binding-ref / binding-set!. --- doc/ref/api-debug.texi | 32 +++++++++++++++----- doc/ref/vm.texi | 37 ++++++++++++++--------- module/system/repl/debug.scm | 2 +- module/system/vm/frame.scm | 57 ++++++++++++++++++------------------ 4 files changed, 76 insertions(+), 52 deletions(-) diff --git a/doc/ref/api-debug.texi b/doc/ref/api-debug.texi index 459371fa7..a6cfd7b03 100644 --- a/doc/ref/api-debug.texi +++ b/doc/ref/api-debug.texi @@ -201,16 +201,32 @@ respectively. @xref{VM Concepts}, for more information. @deffnx {Scheme Procedure} frame-mv-return-address frame Accessors for the three saved VM registers in a frame: the previous frame pointer, the single-value return address, and the multiple-value -return address. @xref{Stack Layout}, for more information. +return address. @xref{Stack Layout}, for more information. @end deffn -@deffn {Scheme Procedure} frame-num-locals frame -@deffnx {Scheme Procedure} frame-local-ref frame i -@deffnx {Scheme Procedure} frame-local-set! frame i val -Accessors for the temporary values corresponding to @var{frame}'s -procedure application. The first local is the first argument given to -the procedure. After the arguments, there are the local variables, and -after that temporary values. @xref{Stack Layout}, for more information. +@deffn {Scheme Procedure} frame-bindings frame +Return a list of binding records indicating the local variables that are +live in a frame. +@end deffn + +@deffn {Scheme Procedure} frame-lookup-binding frame var +Fetch the bindings in @var{frame}, and return the first one whose name +is @var{var}, or @code{#f} otherwise. +@end deffn + +@deffn {Scheme Procedure} binding-index binding +@deffnx {Scheme Procedure} binding-name binding +@deffnx {Scheme Procedure} binding-slot binding +@deffnx {Scheme Procedure} binding-representation binding +Accessors for the various fields in a binding. The implicit ``callee'' +argument is index 0, the first argument is index 1, and so on to the end +of the arguments. After that are temporary variables. Note that if a +variable is dead, it might not be available. +@end deffn + +@deffn {Scheme Procedure} binding-ref binding +@deffnx {Scheme Procedure} binding-set! binding val +Accessors for the values of local variables in a frame. @end deffn @deffn {Scheme Procedure} display-application frame [port [indent]] diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index f97a009b5..097fb8b75 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -160,10 +160,18 @@ The structure of the top stack frame is as follows: \------------------/ <- sp @end example -In the above drawing, the stack grows downward. Usually the procedure -being applied is in local 0, followed by the arguments from local 1. -After that are enough slots to store the various lexically-bound and -temporary values that are needed in the function's application. +In the above drawing, the stack grows downward. At the beginning of a +function call, the procedure being applied is in local 0, followed by +the arguments from local 1. After the procedure checks that it is being +passed a compatible set of arguments, the procedure allocates some +additional space in the frame to hold variables local to the function. + +Note that once a value in a local variable slot is no longer needed, +Guile is free to re-use that slot. This applies to the slots that were +initially used for the callee and arguments, too. For this reason, +backtraces in Guile aren't always able to show all of the arguments: it +could be that the slot corresponding to that argument was re-used by +some other variable. The @dfn{return address} is the @code{ip} that was in effect before this program was applied. When we return from this activation frame, we will @@ -274,25 +282,26 @@ We can see how these concepts tie together by disassembling the @smallexample scheme@@(guile-user)> (define (foo a) (lambda (b) (list foo a b))) scheme@@(guile-user)> ,x foo -Disassembly of # at #xddb824: +Disassembly of # at #xea4ce4: - 0 (assert-nargs-ee/locals 2 0) ;; 2 slots (1 arg) at (unknown file):1:0 - 1 (make-closure 1 6 1) ;; anonymous procedure at #xddb840 (1 free var) + 0 (assert-nargs-ee/locals 2 0) ;; 2 slots (1 arg) at (unknown file):1:0 + 1 (make-closure 1 7 1) ;; anonymous procedure at #xea4d04 (1 free var) 4 (free-set! 1 0 0) ;; free var 0 - 6 (return 1) + 6 (mov 0 1) + 7 (return-values 2) ;; 1 value ---------------------------------------- -Disassembly of anonymous procedure at #xddb840: +Disassembly of anonymous procedure at #xea4d04: - 0 (assert-nargs-ee/locals 2 2) ;; 4 slots (1 arg) at (unknown file):1:16 - 1 (toplevel-box 1 73 57 67 #t) ;; `foo' + 0 (assert-nargs-ee/locals 2 2) ;; 4 slots (1 arg) at (unknown file):1:16 + 1 (toplevel-box 1 74 58 68 #t) ;; `foo' 6 (box-ref 1 1) 7 (make-short-immediate 0 772) ;; () at (unknown file):1:28 8 (cons 2 2 0) 9 (free-ref 3 3 0) ;; free var 0 - 11 (cons 3 3 2) - 12 (cons 3 1 3) - 13 (return 3) + 11 (cons 3 3 2) + 12 (cons 2 1 3) + 13 (return-values 2) ;; 1 value @end smallexample First there's some prelude, where @code{foo} checks that it was called diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm index 4bd9e2758..274ebdd00 100644 --- a/module/system/repl/debug.scm +++ b/module/system/repl/debug.scm @@ -115,7 +115,7 @@ (format port "~aLocal variables:~%" per-line-prefix) (for-each (lambda (binding) - (let ((v (frame-binding-ref frame binding))) + (let ((v (binding-ref binding))) (display per-line-prefix port) (run-hook before-print-hook v) (format port "~a = ~v:@y\n" (binding-name binding) width v))) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index 15e745d18..565177e4c 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -33,10 +33,11 @@ binding-slot binding-representation - frame-instruction-pointer-or-primitive-procedure-name frame-bindings frame-lookup-binding - frame-binding-ref frame-binding-set! + binding-ref binding-set! + + frame-instruction-pointer-or-primitive-procedure-name frame-call-representation frame-environment frame-object-binding frame-object-name)) @@ -46,8 +47,9 @@ "scm_init_frames_builtins")) (define-record-type - (make-binding idx name slot representation) + (make-binding frame idx name slot representation) binding? + (frame binding-frame) (idx binding-index) (name binding-name) (slot binding-slot) @@ -206,7 +208,7 @@ (lp (1+ n) (+ pos (vector-ref parsed n))))) killv)) -(define (available-bindings arity ip top-frame?) +(define (available-bindings frame arity ip top-frame?) (let* ((defs (list->vector (arity-definitions arity))) (code (arity-code arity)) (parsed (parse-code code)) @@ -282,7 +284,7 @@ (if n (match (vector-ref defs n) (#(name def-offset slot representation) - (cons (make-binding n name slot representation) + (cons (make-binding frame n name slot representation) (lp (1+ n))))) '())))) (lp (1+ n) (- offset (vector-ref parsed n))))))) @@ -292,7 +294,7 @@ (cond ((find-program-arity ip) => (lambda (arity) - (available-bindings arity ip top-frame?))) + (available-bindings frame arity ip top-frame?))) (else '())))) (define (frame-lookup-binding frame var) @@ -304,22 +306,18 @@ (else (lp (cdr bindings)))))) -(define (frame-binding-set! frame var val) - (let ((binding (if (binding? var) - var - (or (frame-lookup-binding frame var) - (error "variable not bound in frame" var frame))))) - (frame-local-set! frame (binding-slot binding) val - (binding-representation binding)))) - -(define (frame-binding-ref frame var) - (let ((binding (if (binding? var) - var - (or (frame-lookup-binding frame var) - (error "variable not bound in frame" var frame))))) - (frame-local-ref frame (binding-slot binding) - (binding-representation binding)))) +(define (binding-ref binding) + (frame-local-ref (or (binding-frame binding) + (error "binding has no frame" binding)) + (binding-slot binding) + (binding-representation binding))) +(define (binding-set! binding val) + (frame-local-set! (or (binding-frame binding) + (error "binding has no frame" binding)) + (binding-slot binding) + val + (binding-representation binding))) (define* (frame-procedure-name frame #:key (info (find-program-debug-info @@ -443,12 +441,13 @@ => (lambda (arity) (if (and top-frame? (eqv? ip (arity-low-pc arity))) (application-arguments) - (reconstruct-arguments (available-bindings arity ip top-frame?) - (arity-nreq arity) - (arity-nopt arity) - (arity-keyword-args arity) - (arity-has-rest? arity) - 1)))) + (reconstruct-arguments + (available-bindings frame arity ip top-frame?) + (arity-nreq arity) + (arity-nopt arity) + (arity-keyword-args arity) + (arity-has-rest? arity) + 1)))) ((and (primitive-code? ip) (program-arguments-alist (frame-local-ref frame 0 'scm) ip)) => (lambda (args) @@ -470,12 +469,12 @@ (define (frame-environment frame) (map (lambda (binding) - (cons (binding-name binding) (frame-binding-ref frame binding))) + (cons (binding-name binding) (binding-ref binding))) (frame-bindings frame))) (define (frame-object-binding frame obj) (do ((bs (frame-bindings frame) (cdr bs))) - ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs)))) + ((or (null? bs) (eq? obj (binding-ref (car bs)))) (and (pair? bs) (car bs))))) (define (frame-object-name frame obj) From 4066ee31920d52ec0549ce882f883b92992f894b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 1 Feb 2016 11:27:14 +0100 Subject: [PATCH 175/865] Better call-counting profiles in statprof * module/statprof.scm: Update commentary. (count-call): Don't bother stopping and starting the timer. The overhead of call counting perturbs timing too much already, and somewhat paradoxically stopping and starting the timer takes too much time. (skip-count-call): New function. (stack-samples->procedure-data, stack-samples->callee-lists): If we are counting calls, skip any part of the stack that is inside count-call. --- module/statprof.scm | 71 +++++++++++++++++++++++++-------------------- 1 file changed, 39 insertions(+), 32 deletions(-) diff --git a/module/statprof.scm b/module/statprof.scm index 7a18bb420..3c7c3f7c9 100644 --- a/module/statprof.scm +++ b/module/statprof.scm @@ -35,7 +35,7 @@ ;;; ;;; This would run the thunk with statistical profiling, finally ;;; displaying a gprof flat-style table of statistics which could -;;; something like this: +;;; look something like this: ;;; ;;; @example ;;; % cumulative self self total @@ -75,14 +75,6 @@ ;;; The name of the procedure. ;;; @end table ;;; -;;; The profiler uses @code{eq?} and the procedure object itself to -;;; identify the procedures, so it won't confuse different procedures with -;;; the same name. They will show up as two different rows in the output. -;;; -;;; Right now the profiler is quite simplistic. I cannot provide -;;; call-graphs or other higher level information. What you see in the -;;; table is pretty much all there is. Patches are welcome :-) -;;; ;;; @section Implementation notes ;;; ;;; The profiler works by setting the unix profiling signal @@ -374,14 +366,9 @@ (define (count-call frame) (let ((state (existing-profiler-state))) (unless (inside-profiler? state) - (accumulate-time state (get-internal-run-time)) - - ;; We know local 0 is a SCM value: the c (let* ((key (frame-instruction-pointer-or-primitive-procedure-name frame)) (handle (hashv-create-handle! (call-counts state) key 0))) - (set-cdr! handle (1+ (cdr handle)))) - - (set-last-start-time! state (get-internal-run-time))))) + (set-cdr! handle (1+ (cdr handle))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -490,6 +477,26 @@ always collects full stacks.)" (define (inc-call-data-self-sample-count! cd) (set-call-data-self-sample-count! cd (1+ (call-data-self-sample-count cd)))) +(define (skip-count-call buffer start len) + ;; If we are counting all procedure calls, count-call might be on the + ;; stack. If it is, skip that part of the stack. + (match (program-address-range count-call) + ((lo . hi) + (let lp ((pos start)) + (if (< pos len) + (let ((key (vector-ref buffer pos))) + (cond + ((not key) + ;; End of stack; count-call not on the stack. + start) + ((and (number? key) (<= lo key) (< key hi)) + ;; Found count-call. + (1+ pos)) + (else + ;; Otherwise keep going. + (lp (1+ pos))))) + start))))) + (define (stack-samples->procedure-data state) (let ((table (make-hash-table)) (addr-cache (make-hash-table)) @@ -536,19 +543,19 @@ always collects full stacks.)" (let visit-stacks ((pos 0)) (cond ((< pos len) - ;; FIXME: if we are counting all procedure calls, and - ;; count-call is on the stack, we need to not count the part - ;; of the stack that is within count-call. - (inc-call-data-self-sample-count! - (callee->call-data (vector-ref buffer pos))) - (let visit-stack ((pos pos)) - (cond - ((vector-ref buffer pos) - => (lambda (callee) - (inc-call-data-cum-sample-count! (callee->call-data callee)) - (visit-stack (1+ pos)))) - (else - (visit-stacks (1+ pos)))))) + (let ((pos (if call-counts + (skip-count-call buffer pos len) + pos))) + (inc-call-data-self-sample-count! + (callee->call-data (vector-ref buffer pos))) + (let visit-stack ((pos pos)) + (cond + ((vector-ref buffer pos) + => (lambda (callee) + (inc-call-data-cum-sample-count! (callee->call-data callee)) + (visit-stack (1+ pos)))) + (else + (visit-stacks (1+ pos))))))) (else table))))) (define (stack-samples->callee-lists state) @@ -557,10 +564,10 @@ always collects full stacks.)" (let visit-stacks ((pos 0) (out '())) (cond ((< pos len) - ;; FIXME: if we are counting all procedure calls, and - ;; count-call is on the stack, we need to not count the part - ;; of the stack that is within count-call. - (let visit-stack ((pos pos) (stack '())) + (let visit-stack ((pos (if (call-counts state) + (skip-count-call buffer pos len) + pos)) + (stack '())) (cond ((vector-ref buffer pos) => (lambda (callee) From 8998f1539f9b998a9ec5f867d3933cdd8f06fc41 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 1 Feb 2016 14:58:34 +0100 Subject: [PATCH 176/865] Update statprof documentation; deprecate `with-statprof' * module/statprof.scm: Remove most of the commentary, as it was duplicated in the manual and was getting out of date. (stats): Remove self-secs-per-call and cum-secs-per-call fields as they can be computed from the other fields. (statprof-call-data->stats): Adapt. (statprof-stats-self-secs-per-call): (statprof-stats-cum-secs-per-call): New functions. (statprof-display/flat): Don't print the seconds-per-call fields, as we are no longer stopping the clock around call counters. Anyway these times were quite misleading. (with-statprof): Deprecate. It took its keyword arguments at the beginning; very complicated! Better to use the `statprof' function. (`statprof' was introduced after `with-statprof' and then `with-statprof' was adapted to use it.) * doc/ref/statprof.texi (Statprof): Port this documentation away from the automatically generated text and update it for the new interfaces like #:display-style. * module/system/base/syntax.scm (record-case): Remove comment that referenced with-statprof. Add comment indicating that record-case should be replaced. * doc/ref/scheme-using.texi (Profile Commands): Update to mention keyword arguments and to link to the statprof documentation. --- doc/ref/scheme-using.texi | 8 +- doc/ref/statprof.texi | 422 ++++++++++++++++------------------ module/statprof.scm | 161 ++++--------- module/system/base/syntax.scm | 30 +-- 4 files changed, 248 insertions(+), 373 deletions(-) diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index 9334218b6..b7efcb4a9 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -294,8 +294,12 @@ Disassemble a file. Time execution. @end deffn -@deffn {REPL Command} profile exp -Profile execution. +@deffn {REPL Command} profile exp [#:hz hz=100] @ + [#:count-calls? count-calls?=#f] [#:display-style display-style=list] +Profile execution of an expression. This command compiled @var{exp} and +then runs it within the statprof profiler, passing all keyword options +to the @code{statprof} procedure. For more on statprof and on the the +options available to this command, @xref{Statprof}. @end deffn @deffn {REPL Command} trace exp [#:width w] [#:max-indent i] diff --git a/doc/ref/statprof.texi b/doc/ref/statprof.texi index 5b99fb6b8..6282811d1 100644 --- a/doc/ref/statprof.texi +++ b/doc/ref/statprof.texi @@ -6,220 +6,116 @@ @node Statprof @section Statprof -@code{(statprof)} is a fairly simple statistical profiler for Guile. +Statprof is a statistical profiler for Guile. A simple use of statprof would look like this: -@example -(statprof-reset 0 50000 #t) -(statprof-start) -(do-something) -(statprof-stop) -(statprof-display) +@example +(use-modules (statprof)) +(statprof (lambda () + (map 1+ (iota 1000000)) + #f)) @end example -This would reset statprof, clearing all accumulated statistics, then -start profiling, run some code, stop profiling, and finally display a -gprof flat-style table of statistics which will look something like -this: +This would run the thunk with statistical profiling, finally displaying +a flat table of statistics which could look something like this: -@example - % cumulative self self total - time seconds seconds calls ms/call ms/call name - 35.29 0.23 0.23 2002 0.11 0.11 - - 23.53 0.15 0.15 2001 0.08 0.08 positive? - 23.53 0.15 0.15 2000 0.08 0.08 + - 11.76 0.23 0.08 2000 0.04 0.11 do-nothing - 5.88 0.64 0.04 2001 0.02 0.32 loop - 0.00 0.15 0.00 1 0.00 150.59 do-something - ... +@example +% cumulative self +time seconds seconds procedure + 57.14 39769.73 0.07 ice-9/boot-9.scm:249:5:map1 + 28.57 0.04 0.04 ice-9/boot-9.scm:1165:0:iota + 14.29 0.02 0.02 1+ + 0.00 0.12 0.00 :2:10 +--- +Sample count: 7 +Total time: 0.123490713 seconds (0.201983993 seconds in GC) @end example All of the numerical data with the exception of the calls column is statistically approximate. In the following column descriptions, and in -all of statprof, "time" refers to execution time (both user and system), -not wall clock time. +all of statprof, ``time'' refers to execution time (both user and +system), not wall clock time. -@table @asis -@item % time -The percent of the time spent inside the procedure itself (not counting -children). +The @code{% time} column indicates the percentage of the run-time time +spent inside the procedure itself (not counting children). It is +calculated as @code{self seconds}, measuring the amount of time spent in +the procedure, divided by the total run-time. -@item cumulative seconds -The total number of seconds spent in the procedure, including children. +@code{cumulative seconds} also counts time spent in children of a +function. For recursive functions, this can exceed the total time, as +in our example above, because each activation on the stack adds to the +cumulative time. -@item self seconds -The total number of seconds spent in the procedure itself (not counting -children). +Finally, the GC time measures the time spent in the garbage collector. +On systems with multiple cores, this time can be larger than the run +time, because it counts time spent in all threads, and will run the +``marking'' phase of GC in parallel. If GC time is a significant +fraction of the run time, that means that most time in your program is +spent allocating objects and cleaning up after those allocations. To +speed up your program, one good place to start would be to look at how +to reduce the allocation rate. -@item calls -The total number of times the procedure was called. +Statprof's main mode of operation is as a statistical profiler. However +statprof can also run in a ``precise'' mode as well. Pass the +@code{#:count-calls? #t} keyword argument to @code{statprof} to record +all calls: -@item self ms/call -The average time taken by the procedure itself on each call, in ms. +@example +(use-modules (statprof)) +(statprof (lambda () + (map 1+ (iota 1000000)) + #f) + #:count-calls? #t) +@end example -@item total ms/call -The average time taken by each call to the procedure, including time -spent in child functions. +The result has an additional @code{calls} column: -@item name -The name of the procedure. +@example +% cumulative self +time seconds seconds calls procedure + 82.26 0.73 0.73 1000000 1+ + 11.29 420925.80 0.10 1000001 ice-9/boot-9.scm:249:5:map1 + 4.84 0.06 0.04 1 ice-9/boot-9.scm:1165:0:iota +[...] +--- +Sample count: 62 +Total time: 0.893098065 seconds (1.222796536 seconds in GC) +@end example -@end table - -The profiler uses @code{eq?} and the procedure object itself to identify -the procedures, so it won't confuse different procedures with the same -name. They will show up as two different rows in the output. - -Right now the profiler is quite simplistic. I cannot provide call-graphs -or other higher level information. What you see in the table is pretty -much all there is. Patches are welcome :-) +As you can see, the profile is perturbed: @code{1+} ends up on top, +whereas it was not marked as hot in the earlier profile. This is +because the overhead of call-counting unfairly penalizes calls. Still, +this precise mode can be useful at times to do algorithmic optimizations +based on the precise call counts. @section Implementation notes + The profiler works by setting the unix profiling signal @code{ITIMER_PROF} to go off after the interval you define in the call -to @code{statprof-reset}. When the signal fires, a sampling routine is -run which looks at the current procedure that's executing, and then -crawls up the stack, and for each procedure encountered, increments that -procedure's sample count. Note that if a procedure is encountered -multiple times on a given stack, it is only counted once. After the -sampling is complete, the profiler resets profiling timer to fire again -after the appropriate interval. +to @code{statprof-reset}. When the signal fires, a sampling routine +runs which crawls up the stack, recording all instruction pointers into +a buffer. After the sample is complete, the profiler resets profiling +timer to fire again after the appropriate interval. -Meanwhile, the profiler keeps track, via @code{get-internal-run-time}, -how much CPU time (system and user -- which is also what -@code{ITIMER_PROF} tracks), has elapsed while code has been executing -within a statprof-start/stop block. +Later, when profiling stops, that log buffer is analyzed to produce the +``self seconds'' and ``cumulative seconds'' statistics. A procedure at +the top of the stack counts toward ``self'' samples, and everything on +the stack counts towards ``cumulative'' samples. -The profiler also tries to avoid counting or timing its own code as much -as possible. +While the profiler is running it measures how much CPU time (system and +user -- which is also what @code{ITIMER_PROF} tracks) has elapsed while +code has been executing within the profiler. Only run time counts +towards the profile, not wall-clock time. For example, sleeping and +waiting for input or output do not cause the timer clock to advance. @section Usage -@anchor{statprof statprof-active?}@defun statprof-active? -Returns @code{#t} if @code{statprof-start} has been called more times -than @code{statprof-stop}, @code{#f} otherwise. -@end defun - -@anchor{statprof statprof-start}@defun statprof-start -Start the profiler.@code{} - -@end defun - -@anchor{statprof statprof-stop}@defun statprof-stop -Stop the profiler.@code{} - -@end defun - -@anchor{statprof statprof-reset}@defun statprof-reset sample-seconds sample-microseconds count-calls? [full-stacks?] -Reset the statprof sampler interval to @var{sample-seconds} and -@var{sample-microseconds}. If @var{count-calls?} is true, arrange to -instrument procedure calls as well as collecting statistical profiling -data. If @var{full-stacks?} is true, collect all sampled stacks into a -list for later analysis. - -Enables traps and debugging as necessary. - -@end defun - -@anchor{statprof statprof-accumulated-time}@defun statprof-accumulated-time -Returns the time accumulated during the last statprof run.@code{} - -@end defun - -@anchor{statprof statprof-sample-count}@defun statprof-sample-count -Returns the number of samples taken during the last statprof run.@code{} - -@end defun - -@anchor{statprof statprof-fold-call-data}@defun statprof-fold-call-data proc init -Fold @var{proc} over the call-data accumulated by statprof. Cannot be -called while statprof is active. @var{proc} should take two arguments, -@code{(@var{call-data} @var{prior-result})}. - -Note that a given proc-name may appear multiple times, but if it does, -it represents different functions with the same name. - -@end defun - -@anchor{statprof statprof-proc-call-data}@defun statprof-proc-call-data proc -Returns the call-data associated with @var{proc}, or @code{#f} if none -is available. - -@end defun - -@anchor{statprof statprof-call-data-name}@defun statprof-call-data-name cd -@end defun - -@anchor{statprof statprof-call-data-calls}@defun statprof-call-data-calls cd -@end defun - -@anchor{statprof statprof-call-data-cum-samples}@defun statprof-call-data-cum-samples cd -@end defun - -@anchor{statprof statprof-call-data-self-samples}@defun statprof-call-data-self-samples cd -@end defun - -@anchor{statprof statprof-call-data->stats}@defun statprof-call-data->stats call-data -Returns an object of type @code{statprof-stats}. - -@end defun - -@anchor{statprof statprof-stats-proc-name}@defun statprof-stats-proc-name stats -@end defun - -@anchor{statprof statprof-stats-%-time-in-proc}@defun statprof-stats-%-time-in-proc stats -@end defun - -@anchor{statprof statprof-stats-cum-secs-in-proc}@defun statprof-stats-cum-secs-in-proc stats -@end defun - -@anchor{statprof statprof-stats-self-secs-in-proc}@defun statprof-stats-self-secs-in-proc stats -@end defun - -@anchor{statprof statprof-stats-calls}@defun statprof-stats-calls stats -@end defun - -@anchor{statprof statprof-stats-self-secs-per-call}@defun statprof-stats-self-secs-per-call stats -@end defun - -@anchor{statprof statprof-stats-cum-secs-per-call}@defun statprof-stats-cum-secs-per-call stats -@end defun - -@anchor{statprof statprof-display}@defun statprof-display . _ -Displays a gprof-like summary of the statistics collected. Unless an -optional @var{port} argument is passed, uses the current output port. - -@end defun - -@anchor{statprof statprof-display-anomolies}@defun statprof-display-anomolies -A sanity check that attempts to detect anomolies in statprof's -statistics.@code{} - -@end defun - -@anchor{statprof statprof-fetch-stacks}@defun statprof-fetch-stacks -Returns a list of stacks, as they were captured since the last call to -@code{statprof-reset}. - -Note that stacks are only collected if the @var{full-stacks?} argument -to @code{statprof-reset} is true. - -@end defun - -@anchor{statprof statprof-fetch-call-tree}@defun statprof-fetch-call-tree -@verbatim -Return a call tree for the previous statprof run. - -The return value is a list of nodes, each of which is of the type: -@@code - node ::= (@@var@{proc@} @@var@{count@} . @@var@{nodes@}) -@@end code -@end verbatim - -@end defun - -@anchor{statprof statprof}@defun statprof thunk [#:loop] [#:hz] [#:count-calls?] [#:full-stacks?] +@deffn {Scheme Procedure} statprof thunk @ + [#:loop loop=1] [#:hz hz=100] @ + [#:port port=(current-output-port)] @ + [#:count-calls? count-calls?=#f] @ + [#:display-style display-style='flat] Profile the execution of @var{thunk}, and return its return values. The stack will be sampled @var{hz} times per second, and the thunk @@ -228,57 +124,127 @@ itself will be called @var{loop} times. If @var{count-calls?} is true, all procedure calls will be recorded. This operation is somewhat expensive. -If @var{full-stacks?} is true, at each sample, statprof will store away -the whole call tree, for later analysis. Use -@code{statprof-fetch-stacks} or @code{statprof-fetch-call-tree} to -retrieve the last-stored stacks. +After the @var{thunk} has been profiled, print out a profile to +@var{port}. If @var{display-style} is @code{flat}, the results will be +printed as a flat profile. Otherwise if @var{display-style} is +@code{tree}, print the results as a tree profile. +@end deffn -@end defun +Profiling can also be enabled and disabled manually. -@anchor{statprof with-statprof}@defspec with-statprof args -Profile the expressions in the body, and return the body's return -value. +@deffn {Scheme Procedure} statprof-active? +Returns @code{#t} if @code{statprof-start} has been called more times +than @code{statprof-stop}, @code{#f} otherwise. +@end deffn -Keyword arguments: +@deffn {Scheme Procedure} statprof-start +@deffnx {Scheme Procedure} statprof-stop +Start or stop the profiler. +@end deffn + +@deffn {Scheme Procedure} statprof-reset sample-seconds sample-microseconds count-calls? +Reset the profiling sample interval to @var{sample-seconds} and +@var{sample-microseconds}. If @var{count-calls?} is true, arrange to +instrument procedure calls as well as collecting statistical profiling +data. +@end deffn + +If you use the manual @code{statprof-start}/@code{statprof-stop} +interface, an implicit statprof state will persist starting from the +last call to @code{statprof-reset}, or the first call to +@code{statprof-start}. There are a number of accessors to fetch +statistics from this implicit state. + +@deffn {Scheme Procedure} statprof-accumulated-time +Returns the time accumulated during the last statprof run. +@end deffn + +@deffn {Scheme Procedure} statprof-sample-count +Returns the number of samples taken during the last statprof run. +@end deffn + +@deffn {Scheme Procedure} statprof-fold-call-data proc init +Fold @var{proc} over the call-data accumulated by statprof. This +procedure cannot be called while statprof is active. + +@var{proc} will be called with arguments, @var{call-data} and +@var{prior-result}. +@end deffn + +@deffn {Scheme Procedure} statprof-proc-call-data proc +Returns the call-data associated with @var{proc}, or @code{#f} if none +is available. +@end deffn + +@deffn {Scheme Procedure} statprof-call-data-name cd +@deffnx {Scheme Procedure} statprof-call-data-calls cd +@deffnx {Scheme Procedure} statprof-call-data-cum-samples cd +@deffnx {Scheme Procedure} statprof-call-data-self-samples cd +Accessors for the fields in a statprof call-data object. +@end deffn + +@deffn {Scheme Procedure} statprof-call-data->stats call-data +Returns an object of type @code{statprof-stats}. +@end deffn + +@deffn {Scheme Procedure} statprof-stats-proc-name stats +@deffnx {Scheme Procedure} statprof-stats-%-time-in-proc stats +@deffnx {Scheme Procedure} statprof-stats-cum-secs-in-proc stats +@deffnx {Scheme Procedure} statprof-stats-self-secs-in-proc stats +@deffnx {Scheme Procedure} statprof-stats-calls stats +@deffnx {Scheme Procedure} statprof-stats-self-secs-per-call stats +@deffnx {Scheme Procedure} statprof-stats-cum-secs-per-call stats +Accessors for the fields in a @code{statprof-stats} object. +@end deffn + +@deffn {Scheme Procedure} statprof-display @ + [port=(current-output-port)] [#:style style=flat] +Displays a summary of the statistics collected. Possible values for +@var{style} include: @table @code -@item #:loop -Execute the body @var{loop} number of times, or @code{#f} for no looping - -default: @code{#f} - -@item #:hz -Sampling rate - -default: @code{20} - -@item #:count-calls? -Whether to instrument each function call (expensive) - -default: @code{#f} - -@item #:full-stacks? -Whether to collect away all sampled stacks into a list - -default: @code{#f} - +@item flat +Display a traditional gprof-style flat profile. +@item anomalies +Find statistical anomalies in the data. +@item tree +Display a tree profile. @end table +@end deffn -@end defspec +@deffn {Scheme Procedure} statprof-fetch-stacks +Returns a list of stacks, as they were captured since the last call to +@code{statprof-reset}. +@end deffn -@anchor{statprof gcprof}@defun gcprof thunk [#:loop] [#:full-stacks?] -Do an allocation profile of the execution of @var{thunk}. +@deffn {Scheme Procedure} statprof-fetch-call-tree [#:precise precise?=#f] +@verbatim +Return a call tree for the previous statprof run. -The stack will be sampled soon after every garbage collection, yielding -an approximate idea of what is causing allocation in your program. +The return value is a list of nodes. A node is a list of the form: +@code + node ::= (@var{proc} @var{count} . @var{nodes}) +@end code + +The @var{proc} is a printable representation of a procedure, as a +string. If @var{precise?} is false, which is the default, then a node +corresponds to a procedure invocation. If it is true, then a node +corresponds to a return point in a procedure. Passing @code{#:precise? +#t} allows a user to distinguish different source lines in a procedure, +but usually it is too much detail, so it is off by default. +@end verbatim + +@end deffn + +@deffn {Scheme Procedure} gcprof thunk [#:loop] +Like the @code{statprof} procedure, but instead of profiling CPU time, +we profile garbage collection. + +The stack will be sampled soon after every garbage collection during the +evaluation of @var{thunk}, yielding an approximate idea of what is +causing allocation in your program. Since GC does not occur very frequently, you may need to use the @var{loop} parameter, to cause @var{thunk} to be called @var{loop} times. - -If @var{full-stacks?} is true, at each sample, statprof will store away -the whole call tree, for later analysis. Use -@code{statprof-fetch-stacks} or @code{statprof-fetch-call-tree} to -retrieve the last-stored stacks. - -@end defun +@end deffn diff --git a/module/statprof.scm b/module/statprof.scm index 3c7c3f7c9..03178da11 100644 --- a/module/statprof.scm +++ b/module/statprof.scm @@ -1,7 +1,7 @@ ;;;; (statprof) -- a statistical profiler for Guile ;;;; -*-scheme-*- ;;;; -;;;; Copyright (C) 2009, 2010, 2011, 2013-2015 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2011, 2013-2016 Free Software Foundation, Inc. ;;;; Copyright (C) 2004, 2009 Andy Wingo ;;;; Copyright (C) 2001 Rob Browning ;;;; @@ -23,77 +23,8 @@ ;;; Commentary: ;;; -;;; @code{(statprof)} is a statistical profiler for Guile. -;;; -;;; A simple use of statprof would look like this: -;;; -;;; @example -;;; (statprof (lambda () (do-something)) -;;; #:hz 100 -;;; #:count-calls? #t) -;;; @end example -;;; -;;; This would run the thunk with statistical profiling, finally -;;; displaying a gprof flat-style table of statistics which could -;;; look something like this: -;;; -;;; @example -;;; % cumulative self self total -;;; time seconds seconds calls ms/call ms/call name -;;; 35.29 0.23 0.23 2002 0.11 0.11 - -;;; 23.53 0.15 0.15 2001 0.08 0.08 positive? -;;; 23.53 0.15 0.15 2000 0.08 0.08 + -;;; 11.76 0.23 0.08 2000 0.04 0.11 do-nothing -;;; 5.88 0.64 0.04 2001 0.02 0.32 loop -;;; 0.00 0.15 0.00 1 0.00 150.59 do-something -;;; ... -;;; @end example -;;; -;;; All of the numerical data with the exception of the calls column is -;;; statistically approximate. In the following column descriptions, and -;;; in all of statprof, "time" refers to execution time (both user and -;;; system), not wall clock time. -;;; -;;; @table @asis -;;; @item % time -;;; The percent of the time spent inside the procedure itself -;;; (not counting children). -;;; @item cumulative seconds -;;; The total number of seconds spent in the procedure, including -;;; children. -;;; @item self seconds -;;; The total number of seconds spent in the procedure itself (not counting -;;; children). -;;; @item calls -;;; The total number of times the procedure was called. -;;; @item self ms/call -;;; The average time taken by the procedure itself on each call, in ms. -;;; @item total ms/call -;;; The average time taken by each call to the procedure, including time -;;; spent in child functions. -;;; @item name -;;; The name of the procedure. -;;; @end table -;;; -;;; @section Implementation notes -;;; -;;; The profiler works by setting the unix profiling signal -;;; @code{ITIMER_PROF} to go off after the interval you define in the call -;;; to @code{statprof-reset}. When the signal fires, a sampling routine is -;;; run which looks at the current procedure that's executing, and then -;;; crawls up the stack, and for each procedure encountered, increments -;;; that procedure's sample count. Note that if a procedure is encountered -;;; multiple times on a given stack, it is only counted once. After the -;;; sampling is complete, the profiler resets profiling timer to fire -;;; again after the appropriate interval. -;;; -;;; Meanwhile, the profiler keeps track, via @code{get-internal-run-time}, -;;; how much CPU time (system and user -- which is also what -;;; @code{ITIMER_PROF} tracks), has elapsed while code has been executing -;;; within a statprof-start/stop block. -;;; -;;; The profiler also tries to avoid counting or timing its own code as -;;; much as possible. +;;; @code{(statprof)} is a statistical profiler for Guile. See the +;;; "Statprof" section in the manual, for more information. ;;; ;;; Code: @@ -140,8 +71,6 @@ statprof-fetch-call-tree statprof - with-statprof - gcprof)) @@ -612,16 +541,28 @@ none is available." (define-record-type stats (make-stats proc-name proc-source %-time-in-proc cum-secs-in-proc self-secs-in-proc - calls self-secs-per-call cum-secs-per-call) + calls) stats? (proc-name statprof-stats-proc-name) (proc-source statprof-stats-proc-source) (%-time-in-proc statprof-stats-%-time-in-proc) (cum-secs-in-proc statprof-stats-cum-secs-in-proc) (self-secs-in-proc statprof-stats-self-secs-in-proc) - (calls statprof-stats-calls) - (self-secs-per-call statprof-stats-self-secs-per-call) - (cum-secs-per-call statprof-stats-cum-secs-per-call)) + (calls statprof-stats-calls)) + +(define (statprof-stats-self-secs-per-call stats) + (let ((calls (statprof-stats-calls stats))) + (and calls + (/ (statprof-stats-self-secs-in-proc stats) + calls)))) + +(define (statprof-stats-cum-secs-per-call stats) + (let ((calls (statprof-stats-calls stats))) + (and calls + (/ (statprof-stats-cum-secs-in-proc stats) + ;; `calls' might be 0 if we entered statprof during the + ;; dynamic extent of the call. + (max calls 1))))) (define (statprof-call-data->stats call-data) "Returns an object of type @code{statprof-stats}." @@ -645,16 +586,7 @@ none is available." (* (/ self-samples all-samples) 100.0) (* cum-samples secs-per-sample 1.0) (* self-samples secs-per-sample 1.0) - num-calls - (and num-calls ;; maybe we only sampled in children - (if (zero? self-samples) 0.0 - (/ (* self-samples secs-per-sample) 1.0 num-calls))) - (and num-calls ;; cum-samples must be positive - (/ (* cum-samples secs-per-sample) - 1.0 - ;; num-calls might be 0 if we entered statprof during the - ;; dynamic extent of the call - (max num-calls 1)))))) + num-calls))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -689,10 +621,8 @@ optional @var{port} argument is passed, uses the current output port." (statprof-stats-self-secs-in-proc stats)) (if (call-counts state) (if (statprof-stats-calls stats) - (format port " ~7d ~8,2f ~8,2f " - (statprof-stats-calls stats) - (* 1000 (statprof-stats-self-secs-per-call stats)) - (* 1000 (statprof-stats-cum-secs-per-call stats))) + (format port " ~7d " + (statprof-stats-calls stats)) (format port " ")) (display " " port)) (let ((source (statprof-stats-proc-source stats)) @@ -707,10 +637,10 @@ optional @var{port} argument is passed, uses the current output port." (if (call-counts state) (begin - (format port "~5a ~10a ~7a ~8a ~8a ~8a ~8@a\n" - "% " "cumulative" "self" "" "self" "total" "") - (format port "~5a ~9a ~8a ~8a ~8a ~8a ~a\n" - "time" "seconds" "seconds" "calls" "ms/call" "ms/call" "procedure")) + (format port "~5a ~10a ~7a ~8a\n" + "% " "cumulative" "self" "") + (format port "~5a ~9a ~8a ~7a ~a\n" + "time" "seconds" "seconds" "calls" "procedure")) (begin (format port "~5a ~10a ~7a ~8a\n" "%" "cumulative" "self" "") @@ -963,8 +893,9 @@ operation is somewhat expensive." (statprof-stop state) (statprof-display port state #:style display-style)))))) -(define-macro (with-statprof . args) - "Profile the expressions in the body, and return the body's return values. +(begin-deprecated + (define-macro (with-statprof . args) + "Profile the expressions in the body, and return the body's return values. Keyword arguments: @@ -982,22 +913,24 @@ Whether to instrument each function call (expensive) default: @code{#f} @end table" - (define (kw-arg-ref kw args def) - (cond - ((null? args) (error "Invalid macro body")) - ((keyword? (car args)) - (if (eq? (car args) kw) - (cadr args) - (kw-arg-ref kw (cddr args) def))) - ((eq? kw #f def) ;; asking for the body - args) - (else def))) ;; kw not found - `((@ (statprof) statprof) - (lambda () ,@(kw-arg-ref #f args #f)) - #:loop ,(kw-arg-ref #:loop args 1) - #:hz ,(kw-arg-ref #:hz args 100) - #:count-calls? ,(kw-arg-ref #:count-calls? args #f) - #:full-stacks? ,(kw-arg-ref #:full-stacks? args #f))) + (define (kw-arg-ref kw args def) + (cond + ((null? args) (error "Invalid macro body")) + ((keyword? (car args)) + (if (eq? (car args) kw) + (cadr args) + (kw-arg-ref kw (cddr args) def))) + ((eq? kw #f def) ;; asking for the body + args) + (else def))) ;; kw not found + (issue-deprecation-warning + "`with-statprof' is deprecated. Use `statprof' instead.") + `((@ (statprof) statprof) + (lambda () ,@(kw-arg-ref #f args #f)) + #:loop ,(kw-arg-ref #:loop args 1) + #:hz ,(kw-arg-ref #:hz args 100) + #:count-calls? ,(kw-arg-ref #:count-calls? args #f))) + (export with-statprof)) (define* (gcprof thunk #:key (loop 1) full-stacks? (port (current-output-port))) "Do an allocation profile of the execution of @var{thunk}. diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm index 249961d79..fafcce40b 100644 --- a/module/system/base/syntax.scm +++ b/module/system/base/syntax.scm @@ -146,35 +146,7 @@ (car in) out))))))) -;; So, dear reader. It is pleasant indeed around this fire or at this -;; cafe or in this room, is it not? I think so too. -;; -;; This macro used to generate code that looked like this: -;; -;; `(((record-predicate ,record-type) ,r) -;; (let ,(map (lambda (slot) -;; (if (pair? slot) -;; `(,(car slot) ((record-accessor ,record-type ',(cadr slot)) ,r)) -;; `(,slot ((record-accessor ,record-type ',slot) ,r)))) -;; slots) -;; ,@body))))) -;; -;; But this was a hot spot, so computing all those predicates and -;; accessors all the time was getting expensive, so we did a terrible -;; thing: we decided that since above we're already defining accessors -;; and predicates with computed names, we might as well just rely on that fact here. -;; -;; It's a bit nasty, I agree. But it is fast. -;; -;;scheme@(guile-user)> (with-statprof #:hz 1000 #:full-stacks? #t (resolve-module '(oop goops)))% cumulative self -;; time seconds seconds name -;; 8.82 0.03 0.01 glil->assembly -;; 8.82 0.01 0.01 record-type-fields -;; 5.88 0.01 0.01 %compute-initargs -;; 5.88 0.01 0.01 list-index - - -;;; So ugly... but I am too ignorant to know how to make it better. +;;; FIXME: Re-write uses of `record-case' to use `match' instead. (define-syntax record-case (lambda (x) (syntax-case x () From 5fceaed5e14086b0e0c7f91f58c2dd3392ecd9b9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 1 Feb 2016 15:32:03 +0100 Subject: [PATCH 177/865] Update NEWS. * NEWS: Update. --- NEWS | 93 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 90 insertions(+), 3 deletions(-) diff --git a/NEWS b/NEWS index ce3887920..5885e2ef9 100644 --- a/NEWS +++ b/NEWS @@ -8,9 +8,79 @@ Please send Guile bug reports to bug-guile@gnu.org. Changes in 2.1.2 (changes since the 2.1.1 alpha release): +* Notable changes + +** Unboxed arithmetic + +It used to be that Guile's numbers were always boxed with a tag +indicating their type. Small integers could sometimes represent their +tag and value in one word; these are the fixnums. Other kinds of +numbers would be allocated on the heap. + +Guile can now unbox arithmetic on exact integers (values in the signed +and unsigned 64-bit integer range) and inexact reals (floating-point +numbers). Access to bytevectors are always unboxed, and some arithmetic +can be unboxed as well. Unboxing eliminates run-time allocation for +numbers and removes run-time polymorphic dispatch, providing a +significant speedup. + +** Faster build times + +Building Guile from a tarball can now take advantage of a "prebuilt/" +tree of prebuilt .go files. These compiled files are created when a +tarball is made, and are used to speed up the build for users of +official releases. + +These pre-built binaries are not necessary, however: they are not stored +in revision control and can always be re-created from the source, given +that Guile can bootstrap itself from its minimal bootstrap C +interpreter. If you do not want to depend on these pre-built binaries, +you can "make -C prebuilt clean" before building. + +If Guile doesn't pre-build binaries for your architecture and you would +like support for your architecture, see prebuilt/Makefile.am for more +information on how to add support. + +** Better backtraces + +Guile's backtraces do a better job at finding the function name, and +they also do a better job printing function arguments whose values are +unavailable. + +** Add "tree" display mode for statprof. + +See the newly updated "Statprof" section of the manual, for more. + +** Many small compiler and VM improvements + +The user-visible change is that Guile is faster, for many small reasons. +See the commit log for detailed changes. + +Note that until the stable 2.2.0 release is made, we will not make any +efforts towards binary compatibility among 2.1.x releases. Compiled +Scheme files from older pre-releases in the Guile 2.1.x series are not +loadable by the Guile 2.1.2 pre-release. + +** Better handling of GUILE_LOAD_COMPILED_PATH + +It used to be that Guile would stop at the first .go file it found in +the GUILE_LOAD_COMPILED_PATH. If that file turned out to be out of +date, then no .go file would be loaded. Now Guile will continue to +search the path for a file which is both present and up-to-date, with +respect to the .scm file. + +** Fix build when threads are disabled +** Fix cross-compilation of .go files + +* New deprecations + +** `with-statprof' macro deprecated + +Use the `statprof' procedure instead. + * Incompatible changes -** Remove frame-procedure +** Remove `frame-procedure' Several optimizations in Guile make `frame-procedure' an interface that we can no longer support. For background, `frame-procedure' used to @@ -24,10 +94,27 @@ are all known) are optimized in such a way that slot 0 is not a procedure but some optimized representation of the procedure's free variables. Instead, developers building debugging tools that would like access to `frame-procedure' are invited to look at the source for the -`(system vm frame)' for alternate interfaces. +`(system vm frame)' module for alternate interfaces, including the new +`frame-procedure-name'. + +** Remove `,procedure' REPL command + +Not all procedures have values, so it doesn't make sense to expose this +interface to the user. Instead, the `,locals' REPL command will include +the callee, if it is live. + +** Remove `frame-local-ref', `frame-local-set!', `frame-num-locals' + +These procedures reference values in a frame on the stack. Since we now +have unboxed values of different kinds, it is now necessary to specify +the type when reference locals, and once this incompatible change needs +to be made, we might as well make these interfaces private. See +"Frames' in the manual, for more information on the replacements for +these low-level interfaces. + -Changes in 2.1.x (changes since the 2.0.x series): +Previous changes in 2.1.x (changes since the 2.0.x series): * Notable changes From a653271f986316118961bb20f59f5c924b6cd523 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 1 Feb 2016 21:21:38 +0100 Subject: [PATCH 178/865] Document new VM instructions * doc/ref/vm.texi (Stack Layout): Add a note about unboxed values. (Instruction Set): Update for new instructions. --- doc/ref/vm.texi | 231 ++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 205 insertions(+), 26 deletions(-) diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 097fb8b75..528b66d92 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -189,6 +189,12 @@ new call frame. In this way, the dynamic link links the current frame to the previous frame. Computing a stack trace involves traversing these frames. +Each stack local in Guile is 64 bits wide, even on 32-bit architectures. +This allows Guile to preserve its uniform treatment of stack locals +while allowing for unboxed arithmetic on 64-bit integers and +floating-point numbers. @xref{Instruction Set}, for more on unboxed +arithmetic. + As an implementation detail, we actually store the dynamic link as an offset and not an absolute value because the stack can move at runtime as it expands or during partial continuation calls. If it were an @@ -461,7 +467,7 @@ compiled @code{.go} files. It's good times! @node Instruction Set @subsection Instruction Set -There are currently about 130 instructions in Guile's virtual machine. +There are currently about 175 instructions in Guile's virtual machine. These instructions represent atomic units of a program's execution. Ideally, they perform one task without conditional branches, then dispatch to the next instruction in the stream. @@ -551,6 +557,16 @@ In addition, some Scheme primitives have their own inline implementations. For example, in the previous section we saw @code{cons}. +Finally, for instructions with operands that encode references to the +stack, the interpretation of those stack values is up to the instruction +itself. Most instructions expect their operands to be tagged SCM values +(@code{scm} representation), but some instructions expect unboxed +integers (@code{u64} and @code{s64} representations) or floating-point +numbers (@var{f64} representation). Instructions have static types: +they must receive their operands in the format they expect. It's up to +the compiler to ensure this is the case. Unless otherwise mentioned, +all operands and results are boxed as SCM values. + @menu * Lexical Environment Instructions:: * Top-Level Environment Instructions:: @@ -564,6 +580,8 @@ implementations. For example, in the previous section we saw * Inlined Scheme Instructions:: * Inlined Mathematical Instructions:: * Inlined Bytevector Instructions:: +* Unboxed Integer Arithmetic:: +* Unboxed Floating-Point Arithmetic:: @end menu @@ -707,10 +725,8 @@ in which to save the @code{ip} and @code{fp}. Returning values is similar. Multiple-value returns should have values already shuffled down to start from @code{fp}-relative slot 1 before -emitting @code{return-values}. There is a short-cut in the single-value -case, in that @code{return} handles the trivial shuffling itself. We -start from slot 1 instead of slot 0 to make tail calls to @code{values} -trivial. +emitting @code{return-values}. We start from slot 1 instead of slot 0 +to make tail calls to @code{values} trivial. In both calls and returns, the @code{sp} is used to indicate to the callee or caller the number of arguments or return values, respectively. @@ -772,10 +788,6 @@ return values equals @var{nvalues} exactly. After @code{receive-values} has run, the values can be copied down via @code{mov}, or used in place. @end deftypefn -@deftypefn Instruction {} return s24:@var{src} -Return a value. -@end deftypefn - @deftypefn Instruction {} return-values c24:@var{nlocals} Return a number of values from a call frame. This opcode corresponds to an application of @code{values} in tail position. As with tail calls, @@ -935,6 +947,13 @@ not generated by the compiler. Load a builtin stub by index into @var{dst}. @end deftypefn +@deftypefn Instruction {} apply-non-program x24:@var{_} +An instruction used only by a special trampoline that the VM uses to +apply non-programs. Using that trampoline allows profilers and +backtrace utilities to avoid seeing the instruction pointer from the +calling frame. +@end deftypefn + @node Branch Instructions @subsubsection Branch Instructions @@ -990,10 +1009,9 @@ See @code{libguile/tags.h} for all the details. @deftypefn Instruction {} br-if-eq s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} @deftypefnx Instruction {} br-if-eqv s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} -@deftypefnx Instruction {} br-if-equal s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} -If the value in @var{a} is @code{eq?}, @code{eqv?}, or @code{equal?} to -the value in @var{b}, respectively, add @var{offset} to the current -instruction pointer. +If the value in @var{a} is @code{eq?} or @code{eqv?} to the value in +@var{b}, respectively, add @var{offset} to the current instruction +pointer. @end deftypefn @deftypefn Instruction {} br-if-= s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} @@ -1179,6 +1197,10 @@ Reference the fluid in @var{src}, and place the value in @var{dst}. Set the value of the fluid in @var{dst} to the value in @var{src}. @end deftypefn +@deftypefn Instruction {} current-thread s24:@var{dst} +Write the value of the current thread to @var{dst}. +@end deftypefn + @node Miscellaneous Instructions @subsubsection Miscellaneous Instructions @@ -1234,12 +1256,14 @@ be filled with the value in slot @var{init}. @end deftypefn @deftypefn Instruction {} vector-length s12:@var{dst} s12:@var{src} -Store the length of the vector in @var{src} in @var{dst}. +Store the length of the vector in @var{src} in @var{dst}, as an unboxed +unsigned 64-bit integer. @end deftypefn @deftypefn Instruction {} vector-ref s8:@var{dst} s8:@var{src} s8:@var{idx} Fetch the item at position @var{idx} in the vector in @var{src}, and -store it in @var{dst}. +store it in @var{dst}. The @var{idx} value should be an unboxed +unsigned 64-bit integer. @end deftypefn @deftypefn Instruction {} vector-ref/immediate s8:@var{dst} s8:@var{src} c8:@var{idx} @@ -1248,7 +1272,8 @@ Fill @var{dst} with the item @var{idx} elements into the vector at @end deftypefn @deftypefn Instruction {} vector-set! s8:@var{dst} s8:@var{idx} s8:@var{src} -Store @var{src} into the vector @var{dst} at index @var{idx}. +Store @var{src} into the vector @var{dst} at index @var{idx}. The +@var{idx} value should be an unboxed unsigned 64-bit integer. @end deftypefn @deftypefn Instruction {} vector-set!/immediate s8:@var{dst} c8:@var{idx} s8:@var{src} @@ -1263,16 +1288,19 @@ Store the vtable of @var{src} into @var{dst}. @deftypefn Instruction {} allocate-struct s8:@var{dst} s8:@var{vtable} s8:@var{nfields} Allocate a new struct with @var{vtable}, and place it in @var{dst}. The struct will be constructed with space for @var{nfields} fields, which -should correspond to the field count of the @var{vtable}. +should correspond to the field count of the @var{vtable}. The @var{idx} +value should be an unboxed unsigned 64-bit integer. @end deftypefn @deftypefn Instruction {} struct-ref s8:@var{dst} s8:@var{src} s8:@var{idx} Fetch the item at slot @var{idx} in the struct in @var{src}, and store -it in @var{dst}. +it in @var{dst}. The @var{idx} value should be an unboxed unsigned +64-bit integer. @end deftypefn @deftypefn Instruction {} struct-set! s8:@var{dst} s8:@var{idx} s8:@var{src} -Store @var{src} into the struct @var{dst} at slot @var{idx}. +Store @var{src} into the struct @var{dst} at slot @var{idx}. The +@var{idx} value should be an unboxed unsigned 64-bit integer. @end deftypefn @deftypefn Instruction {} allocate-struct/immediate s8:@var{dst} s8:@var{vtable} c8:@var{nfields} @@ -1291,12 +1319,14 @@ Make a new array with @var{type}, @var{fill}, and @var{bounds}, storing it in @v @end deftypefn @deftypefn Instruction {} string-length s12:@var{dst} s12:@var{src} -Store the length of the string in @var{src} in @var{dst}. +Store the length of the string in @var{src} in @var{dst}, as an unboxed +unsigned 64-bit integer. @end deftypefn @deftypefn Instruction {} string-ref s8:@var{dst} s8:@var{src} s8:@var{idx} -Fetch the character at position @var{idx} in the string in @var{src}, and store -it in @var{dst}. +Fetch the character at position @var{idx} in the string in @var{src}, +and store it in @var{dst}. The @var{idx} value should be an unboxed +unsigned 64-bit integer. @end deftypefn @deftypefn Instruction {} cons s8:@var{dst} s8:@var{car} s8:@var{cdr} @@ -1340,16 +1370,16 @@ All of these operations place their result in their first operand, Add @var{a} to @var{b}. @end deftypefn -@deftypefn Instruction {} add1 s12:@var{dst} s12:@var{src} -Add 1 to the value in @var{src}. +@deftypefn Instruction {} add/immediate s8:@var{dst} s8:@var{src} c8:@var{imm} +Add the unsigned integer @var{imm} to the value in @var{src}. @end deftypefn @deftypefn Instruction {} sub s8:@var{dst} s8:@var{a} s8:@var{b} Subtract @var{b} from @var{a}. @end deftypefn -@deftypefn Instruction {} sub1 s12:@var{dst} s12:@var{src} -Subtract 1 from @var{src}. +@deftypefn Instruction {} sub/immediate s8:@var{dst} s8:@var{src} s8:@var{imm} +Subtract the unsigned integer @var{imm} from the value in @var{src}. @end deftypefn @deftypefn Instruction {} mul s8:@var{dst} s8:@var{a} s8:@var{b} @@ -1388,6 +1418,10 @@ Compute the bitwise inclusive @code{or} of @var{a} with @var{b}. Compute the bitwise exclusive @code{or} of @var{a} with @var{b}. @end deftypefn +@deftypefn Instruction {} logsub s8:@var{dst} s8:@var{a} s8:@var{b} +Place the bitwise @code{and} of @var{a} and the bitwise @code{not} of +@var{b} into @var{dst}. +@end deftypefn @node Inlined Bytevector Instructions @subsubsection Inlined Bytevector Instructions @@ -1398,6 +1432,11 @@ a clear path for eventual native compilation. Without this, Scheme programs would need other primitives for accessing raw bytes -- but these primitives are as good as any. +@deftypefn Instruction {} bv-length s12:@var{dst} s12:@var{src} +Store the length of the bytevector in @var{src} in @var{dst}, as an +unboxed unsigned 64-bit integer. +@end deftypefn + @deftypefn Instruction {} bv-u8-ref s8:@var{dst} s8:@var{src} s8:@var{idx} @deftypefnx Instruction {} bv-s8-ref s8:@var{dst} s8:@var{src} s8:@var{idx} @deftypefnx Instruction {} bv-u16-ref s8:@var{dst} s8:@var{src} s8:@var{idx} @@ -1411,6 +1450,12 @@ these primitives are as good as any. Fetch the item at byte offset @var{idx} in the bytevector @var{src}, and store it in @var{dst}. All accesses use native endianness. + +The @var{idx} value should be an unboxed unsigned 64-bit integer. + +The results are all written to the stack as unboxed values, either as +signed 64-bit integers, unsigned 64-bit integers, or IEEE double +floating point numbers. @end deftypefn @deftypefn Instruction {} bv-u8-set! s8:@var{dst} s8:@var{idx} s8:@var{src} @@ -1426,4 +1471,138 @@ store it in @var{dst}. All accesses use native endianness. Store @var{src} into the bytevector @var{dst} at byte offset @var{idx}. Multibyte values are written using native endianness. + +The @var{idx} value should be an unboxed unsigned 64-bit integer. + +The @var{src} values are all unboxed, either as signed 64-bit integers, +unsigned 64-bit integers, or IEEE double floating point numbers. @end deftypefn + + +@node Unboxed Integer Arithmetic +@subsubsection Unboxed Integer Arithmetic + +Guile supports two kinds of unboxed integers: unsigned 64-bit integers, +and signed 64-bit integers. Guile prefers unsigned integers, in the +sense that Guile's compiler supports them better and the virtual machine +has more operations that work on them. Still, signed integers are +supported at least to allow @code{bv-s64-ref} and related instructions +to avoid boxing their values. + +@deftypefn Instruction {} scm->u64 s12:@var{dst} s12:@var{src} +Unbox the SCM value at @var{src} to a unsigned 64-bit integer, placing +the result in @var{dst}. If the @var{src} value is not an exact integer +in the unsigned 64-bit range, signal an error. +@end deftypefn + +@deftypefn Instruction {} u64->scm s12:@var{dst} s12:@var{src} +Box the unsigned 64-bit integer at @var{src} to a SCM value and place +the result in @var{dst}. The result will be a fixnum or a bignum. +@end deftypefn + +@deftypefn Instruction {} load-u64 s24:@var{dst} au32:@var{high-bits} au32:@var{low-bits} +Load a 64-bit value formed by joining @var{high-bits} and +@var{low-bits}, and write it to @var{dst}. +@end deftypefn + +@deftypefn Instruction {} scm->s64 s12:@var{dst} s12:@var{src} +@deftypefnx Instruction {} s64->scm s12:@var{dst} s12:@var{src} +@deftypefnx Instruction {} load-s64 s24:@var{dst} as32:@var{high-bits} as32:@var{low-bits} +Like @code{scm->u64}, @code{u64->scm}, and @code{load-u64}, but for +signed 64-bit integers. +@end deftypefn + +Sometimes the compiler can know that we will only need a subset of the +bits in an integer. In that case we can sometimes unbox an integer even +if it might be out of range. + +@deftypefn Instruction {} scm->u64/truncate s12:@var{dst} s12:@var{src} +Take the SCM value in @var{dst} and @code{logand} it with @code{(1- (ash +1 64))}. Place the unboxed result in @var{dst}. +@end deftypefn + +@deftypefn Instruction {} br-if-u64-= s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} +@deftypefnx Instruction {} br-if-u64-< s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} +@deftypefnx Instruction {} br-if-u64-<= s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} +If the unboxed unsigned 64-bit integer value in @var{a} is @code{=}, +@code{<}, or @code{<=} to the unboxed unsigned 64-bit integer value in +@var{b}, respectively, add @var{offset} to the current instruction +pointer. +@end deftypefn + +@deftypefn Instruction {} br-if-u64-=-scm s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} +@deftypefnx Instruction {} br-if-u64-<-scm s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} +@deftypefnx Instruction {} br-if-u64-<=-scm s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} +If the unboxed unsigned 64-bit integer value in @var{a} is @code{=}, +@code{<}, or @code{<=} to the SCM value in @var{b}, respectively, add +@var{offset} to the current instruction pointer. +@end deftypefn + +@deftypefn Instruction {} uadd s8:@var{dst} s8:@var{a} s8:@var{b} +@deftypefnx Instruction {} usub s8:@var{dst} s8:@var{a} s8:@var{b} +@deftypefnx Instruction {} umul s8:@var{dst} s8:@var{a} s8:@var{b} +Like @code{add}, @code{sub}, and @code{mul}, except taking +the operands as unboxed unsigned 64-bit integers, and producing the +same. The result will be silently truncated to 64 bits. +@end deftypefn + +@deftypefn Instruction {} uadd/immediate s8:@var{dst} s8:@var{a} c8:@var{b} +@deftypefnx Instruction {} usub/immediate s8:@var{dst} s8:@var{a} c8:@var{b} +@deftypefnx Instruction {} umul/immediate s8:@var{dst} s8:@var{a} c8:@var{b} +Like @code{uadd}, @code{usub}, and @code{umul}, except the second +operand is an immediate unsigned 8-bit integer. +@end deftypefn + +@deftypefn Instruction {} ulogand s8:@var{dst} s8:@var{a} s8:@var{b} +@deftypefnx Instruction {} ulogior s8:@var{dst} s8:@var{a} s8:@var{b} +@deftypefnx Instruction {} ulogsub s8:@var{dst} s8:@var{a} s8:@var{b} +Like @code{logand}, @code{logior}, and @code{logsub}, but operating on +unboxed unsigned 64-bit integers. +@end deftypefn + +@deftypefn Instruction {} ulsh s8:@var{dst} s8:@var{a} s8:@var{b} +Shift the unboxed unsigned 64-bit integer in @var{a} left by @var{b} +bits, also an unboxed unsigned 64-bit integer. Truncate to 64 bits and +write to @var{dst} as an unboxed value. Only the lower 6 bits of +@var{b} are used. +@end deftypefn + +@deftypefn Instruction {} ursh s8:@var{dst} s8:@var{a} s8:@var{b} +Like @code{ulsh}, but shifting right. +@end deftypefn + +@deftypefn Instruction {} ulsh/immediate s8:@var{dst} s8:@var{a} c8:@var{b} +@deftypefnx Instruction {} ursh/immediate s8:@var{dst} s8:@var{a} c8:@var{b} +Like @code{ulsh} and @code{ursh}, but encoding @code{b} as an immediate +8-bit unsigned integer. +@end deftypefn + + +@node Unboxed Floating-Point Arithmetic +@subsubsection Unboxed Floating-Point Arithmetic + +@deftypefn Instruction {} scm->f64 s12:@var{dst} s12:@var{src} +Unbox the SCM value at @var{src} to an IEEE double, placing the result +in @var{dst}. If the @var{src} value is not a real number, signal an +error. +@end deftypefn + +@deftypefn Instruction {} f64->scm s12:@var{dst} s12:@var{src} +Box the IEEE double at @var{src} to a SCM value and place the result in +@var{dst}. +@end deftypefn + +@deftypefn Instruction {} load-f64 s24:@var{dst} au32:@var{high-bits} au32:@var{low-bits} +Load a 64-bit value formed by joining @var{high-bits} and +@var{low-bits}, and write it to @var{dst}. +@end deftypefn + +@deftypefn Instruction {} fadd s8:@var{dst} s8:@var{a} s8:@var{b} +@deftypefnx Instruction {} fsub s8:@var{dst} s8:@var{a} s8:@var{b} +@deftypefnx Instruction {} fmul s8:@var{dst} s8:@var{a} s8:@var{b} +@deftypefnx Instruction {} fdiv s8:@var{dst} s8:@var{a} s8:@var{b} +Like @code{add}, @code{sub}, @code{div}, and @code{mul}, except taking +the operands as unboxed IEEE double floating-point numbers, and producing +the same. +@end deftypefn + From 486b322fd5ab4211870c877b6ebe8bb386d76589 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 2 Feb 2016 11:09:00 +0100 Subject: [PATCH 179/865] Fix frame-call-representation for change to . * module/system/vm/frame.scm (frame-call-representation): Fix for change to . --- module/system/vm/frame.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index 565177e4c..c9090ef36 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -1,6 +1,6 @@ ;;; Guile VM frame functions -;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc. +;;; Copyright (C) 2001, 2005, 2009-2016 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 @@ -385,7 +385,7 @@ (define (find-slot i bindings) (match bindings (() #f) - (((and binding ($ idx name slot)) . bindings) + (((and binding ($ frame idx name slot)) . bindings) (if (< idx i) (find-slot i bindings) (and (= idx i) binding))))) From d236022eb0d285af3d462de9e99a212eba459df2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 3 Feb 2016 09:11:01 +0100 Subject: [PATCH 180/865] Release v2.1.2 * GUILE-VERSION (GUILE_MICRO_VERSION): Bump to 2.1.2. --- GUILE-VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index 53588a87a..6d1025b34 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -3,7 +3,7 @@ # Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'. GUILE_MAJOR_VERSION=2 GUILE_MINOR_VERSION=1 -GUILE_MICRO_VERSION=1 +GUILE_MICRO_VERSION=2 GUILE_EFFECTIVE_VERSION=2.2 From 43a038f6e12cc4615df3f4fb9e6904bd819a2928 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 14 Mar 2016 11:17:08 +0100 Subject: [PATCH 181/865] Fix lower-bound saturation in type inference * module/language/cps/types.scm (type-entry-saturating-union): Fix range saturation in the negative direction. Previously we were artificially truncating negative range ends to zero. --- module/language/cps/types.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 4adb8a89e..4cfc71fd6 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -288,8 +288,8 @@ (b-min (type-entry-min b))) (cond ((not (< b-min a-min)) a-min) - ((> 0 b-min) 0) - ((> &range-min b-min) &range-min) + ((< 0 b-min) 0) + ((< &range-min b-min) &range-min) (else -inf.0))) (let ((a-max (type-entry-max a)) (b-max (type-entry-max b))) From 737e62f4b5a9ef771bd40aab793942ba409cfe8a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 1 Apr 2016 21:30:13 +0200 Subject: [PATCH 182/865] Fix frame->stack-vector when no stack is active * module/system/repl/debug.scm (frame->stack-vector): Handle the case where there is no active stack. --- module/system/repl/debug.scm | 32 +++++++++++++++++--------------- 1 file changed, 17 insertions(+), 15 deletions(-) diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm index 274ebdd00..55062d783 100644 --- a/module/system/repl/debug.scm +++ b/module/system/repl/debug.scm @@ -25,9 +25,10 @@ #:use-module (system vm vm) #:use-module (system vm frame) #:use-module (system vm debug) + #:use-module (ice-9 format) + #:use-module (ice-9 match) #:use-module (ice-9 rdelim) #:use-module (ice-9 pretty-print) - #:use-module (ice-9 format) #:use-module ((system vm inspect) #:select ((inspect . %inspect))) #:use-module (system vm program) #:export ( @@ -181,20 +182,21 @@ #()))) ; ? Can be the case for a tail-call to `throw' tho (define (frame->stack-vector frame) - (let ((tag (and (pair? (fluid-ref %stacks)) - (cdar (fluid-ref %stacks))))) - (narrow-stack->vector - (make-stack frame) - ;; Take the stack from the given frame, cutting 0 - ;; frames. - 0 - ;; Narrow the end of the stack to the most recent - ;; start-stack. - tag - ;; And one more frame, because %start-stack - ;; invoking the start-stack thunk has its own frame - ;; too. - 0 (and tag 1)))) + (let ((stack (make-stack frame))) + (match (fluid-ref %stacks) + (((stack-tag . prompt-tag) . _) + (narrow-stack->vector + stack + ;; Take the stack from the given frame, cutting 0 frames. + 0 + ;; Narrow the end of the stack to the most recent start-stack. + prompt-tag + ;; And one more frame, because %start-stack invoking the + ;; start-stack thunk has its own frame too. + 0 (and prompt-tag 1))) + (_ + ;; Otherwise take the whole stack. + (stack->vector stack))))) ;; (define (debug) ;; (run-debugger From 8a0fc5117619c7c920092bb056af923f2bbaf343 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 1 Apr 2016 21:31:06 +0200 Subject: [PATCH 183/865] display-{application,-backtrace} delegate to Scheme * libguile/backtrace.h: * libguile/backtrace.c (print_frame_var, kw_count, print_frames_var) (frame_to_stack_vector_var): New variables. (init_print_frame_var) (init_print_frames_var_and_frame_to_stack_vector_var): New functions. (scm_set_print_params_x): Remove function. (scm_display_application): Delegate to print-frame. (display_backtrace_body, scm_display_backtrace_with_highlights): Delegate to print-frames. --- libguile/backtrace.c | 366 ++++++------------------------------------- libguile/backtrace.h | 3 - 2 files changed, 46 insertions(+), 323 deletions(-) diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 0c0f11007..36ef594e1 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -67,6 +67,10 @@ boot_print_exception (SCM port, SCM frame, SCM key, SCM args) #undef FUNC_NAME static SCM print_exception_var; +static SCM print_frame_var; +static SCM kw_count; +static SCM print_frames_var; +static SCM frame_to_stack_vector_var; static void init_print_exception_var (void) @@ -76,6 +80,23 @@ init_print_exception_var (void) scm_from_latin1_symbol ("print-exception")); } +static void +init_print_frame_var (void) +{ + print_frame_var = + scm_c_public_variable ("system repl debug", "print-frame"); +} + +static void +init_print_frames_var_and_frame_to_stack_vector_var (void) +{ + kw_count = scm_from_latin1_keyword ("count"); + print_frames_var = + scm_c_public_variable ("system repl debug", "print-frames"); + frame_to_stack_vector_var = + scm_c_public_variable ("system repl debug", "frame->stack-vector"); +} + SCM scm_print_exception (SCM port, SCM frame, SCM key, SCM args) #define FUNC_NAME "print-exception" @@ -168,106 +189,6 @@ SCM_DEFINE (scm_display_error, "display-error", 6, 0, 0, } #undef FUNC_NAME - -typedef struct { - int level; - int length; -} print_params_t; - -static int n_print_params = 9; -static print_params_t default_print_params[] = { - { 4, 9 }, { 4, 3 }, - { 3, 4 }, { 3, 3 }, - { 2, 4 }, { 2, 3 }, - { 1, 4 }, { 1, 3 }, { 1, 2 } -}; -static print_params_t *print_params = default_print_params; - -#ifdef GUILE_DEBUG -SCM_DEFINE (scm_set_print_params_x, "set-print-params!", 1, 0, 0, - (SCM params), - "Set the print parameters to the values from @var{params}.\n" - "@var{params} must be a list of two-element lists which must\n" - "hold two integer values.") -#define FUNC_NAME s_scm_set_print_params_x -{ - int i; - int n; - SCM ls; - print_params_t *new_params; - - SCM_VALIDATE_NONEMPTYLIST_COPYLEN (2, params, n); - for (ls = params; !SCM_NULL_OR_NIL_P (ls); ls = SCM_CDR (ls)) - SCM_ASSERT (scm_ilength (SCM_CAR (params)) == 2 - && scm_is_unsigned_integer (SCM_CAAR (ls), 0, INT_MAX) - && scm_is_unsigned_integer (SCM_CADAR (ls), 0, INT_MAX), - params, - SCM_ARG2, - s_scm_set_print_params_x); - new_params = scm_malloc (n * sizeof (print_params_t)); - if (print_params != default_print_params) - free (print_params); - print_params = new_params; - for (i = 0; i < n; ++i) - { - print_params[i].level = scm_to_int (SCM_CAAR (params)); - print_params[i].length = scm_to_int (SCM_CADAR (params)); - params = SCM_CDR (params); - } - n_print_params = n; - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME -#endif - -static void -indent (int n, SCM port) -{ - int i; - for (i = 0; i < n; ++i) - scm_putc_unlocked (' ', port); -} - -static void -display_frame_expr (char *hdr, SCM exp, char *tlr, int indentation, SCM sport, SCM port, scm_print_state *pstate) -{ - int i = 0, n; - scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (sport); - do - { - pstate->length = print_params[i].length; - ptob->seek (sport, 0, SEEK_SET); - if (scm_is_pair (exp)) - { - pstate->level = print_params[i].level - 1; - scm_iprlist (hdr, exp, tlr[0], sport, pstate); - scm_puts_unlocked (&tlr[1], sport); - } - else - { - pstate->level = print_params[i].level; - scm_iprin1 (exp, sport, pstate); - } - ptob->flush (sport); - n = ptob->seek (sport, 0, SEEK_CUR); - ++i; - } - while (indentation + n > SCM_BACKTRACE_WIDTH && i < n_print_params); - ptob->truncate (sport, n); - - scm_display (scm_strport_to_string (sport), port); -} - -static void -display_application (SCM frame, int indentation, SCM sport, SCM port, scm_print_state *pstate) -{ - display_frame_expr ("[", scm_frame_call_representation (frame), "]", - indentation, - sport, - port, - pstate); -} - SCM_DEFINE (scm_display_application, "display-application", 1, 2, 0, (SCM frame, SCM port, SCM indent), "Display a procedure application @var{frame} to the output port\n" @@ -275,158 +196,15 @@ SCM_DEFINE (scm_display_application, "display-application", 1, 2, 0, "output.") #define FUNC_NAME s_scm_display_application { - SCM_VALIDATE_FRAME (1, frame); - if (SCM_UNBNDP (port)) - port = scm_current_output_port (); - else - SCM_VALIDATE_OPOUTPORT (2, port); - if (SCM_UNBNDP (indent)) - indent = SCM_INUM0; - - /* Display an application. */ - { - SCM sport, print_state; - scm_print_state *pstate; - - /* Create a string port used for adaptation of printing parameters. */ - sport = scm_mkstrport (SCM_INUM0, SCM_BOOL_F, - SCM_OPN | SCM_WRTNG, - FUNC_NAME); + static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; + scm_i_pthread_once (&once, init_print_frame_var); - /* Create a print state for printing of frames. */ - print_state = scm_make_print_state (); - pstate = SCM_PRINT_STATE (print_state); - pstate->writingp = 1; - pstate->fancyp = 1; - - display_application (frame, scm_to_int (indent), sport, port, pstate); - return SCM_BOOL_T; - } + /* FIXME perhaps: ignoring indent. But really we should deprecate + this procedure in favor of print-frame. */ + return scm_call_2 (scm_variable_ref (print_frame_var), frame, port); } #undef FUNC_NAME -SCM_SYMBOL (sym_base, "base"); - -static void -display_backtrace_get_file_line (SCM frame, SCM *file, SCM *line) -{ - SCM source = scm_frame_source (frame); - *file = *line = SCM_BOOL_F; - if (scm_is_pair (source) - && scm_is_pair (scm_cdr (source)) - && scm_is_pair (scm_cddr (source)) - && !scm_is_pair (scm_cdddr (source))) - { - /* (addr . (filename . (line . column))), from vm compilation */ - *file = scm_cadr (source); - *line = scm_caddr (source); - } -} - -static void -display_backtrace_file (frame, last_file, port, pstate) - SCM frame; - SCM *last_file; - SCM port; - scm_print_state *pstate; -{ - SCM file, line; - - display_backtrace_get_file_line (frame, &file, &line); - - if (scm_is_true (scm_equal_p (file, *last_file))) - return; - - *last_file = file; - - scm_puts_unlocked ("In ", port); - if (scm_is_false (file)) - if (scm_is_false (line)) - scm_puts_unlocked ("unknown file", port); - else - scm_puts_unlocked ("current input", port); - else - { - pstate->writingp = 0; - scm_iprin1 (file, port, pstate); - pstate->writingp = 1; - } - scm_puts_unlocked (":\n", port); -} - -static void -display_backtrace_file_and_line (SCM frame, SCM port, scm_print_state *pstate) -{ - SCM file, line; - - display_backtrace_get_file_line (frame, &file, &line); - - if (scm_is_eq (SCM_PACK (SCM_SHOW_FILE_NAME), sym_base)) - { - if (scm_is_false (file)) - { - if (scm_is_false (line)) - scm_putc_unlocked ('?', port); - else - scm_puts_unlocked ("", port); - } - else - { - pstate -> writingp = 0; -#ifdef HAVE_POSIX - scm_iprin1 ((scm_is_string (file)? - scm_basename (file, SCM_UNDEFINED) : file), - port, pstate); -#else - scm_iprin1 (file, port, pstate); -#endif - pstate -> writingp = 1; - } - - scm_putc_unlocked (':', port); - } - else if (scm_is_true (line)) - { - int i, j=0; - for (i = scm_to_int (line)+1; i > 0; i = i/10, j++) - ; - indent (4-j, port); - } - - if (scm_is_false (line)) - scm_puts_unlocked (" ?", port); - else - scm_intprint (scm_to_int (line) + 1, 10, port); - scm_puts_unlocked (": ", port); -} - -static void -display_frame (SCM frame, int n, int nfield, int indentation, - SCM sport, SCM port, scm_print_state *pstate) -{ - int i, j; - - /* display file name and line number */ - if (scm_is_true (SCM_PACK (SCM_SHOW_FILE_NAME))) - display_backtrace_file_and_line (frame, port, pstate); - - /* Check size of frame number. */ - for (i = 0, j = n; j > 0; ++i) j /= 10; - - /* Number indentation. */ - indent (nfield - (i ? i : 1), port); - - /* Frame number. */ - scm_iprin1 (scm_from_int (n), port, pstate); - - /* Indentation. */ - indent (indentation, port); - - /* Display an application. */ - display_application (frame, nfield + 1 + indentation, sport, port, pstate); - scm_putc_unlocked ('\n', port); -} - struct display_backtrace_args { SCM stack; SCM port; @@ -437,83 +215,34 @@ struct display_backtrace_args { static SCM display_backtrace_body (struct display_backtrace_args *a) -#define FUNC_NAME "display_backtrace_body" +#define FUNC_NAME "display-backtrace" { - int n_frames, beg, end, n, i, j; - int nfield, indentation; - SCM frame, sport, print_state; - SCM last_file; - scm_print_state *pstate; + static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; + SCM frames; + + scm_i_pthread_once (&once, + init_print_frames_var_and_frame_to_stack_vector_var); a->port = SCM_COERCE_OUTPORT (a->port); /* Argument checking and extraction. */ SCM_VALIDATE_STACK (1, a->stack); SCM_VALIDATE_OPOUTPORT (2, a->port); - n_frames = scm_to_int (scm_stack_length (a->stack)); - n = scm_is_integer (a->depth) ? scm_to_int (a->depth) : SCM_BACKTRACE_DEPTH; - if (SCM_BACKWARDS_P) - { - beg = scm_is_integer (a->first) ? scm_to_int (a->first) : 0; - end = beg + n - 1; - if (end >= n_frames) - end = n_frames - 1; - n = end - beg + 1; - } - else - { - if (scm_is_integer (a->first)) - { - beg = scm_to_int (a->first); - end = beg - n + 1; - if (end < 0) - end = 0; - } - else - { - beg = n - 1; - end = 0; - if (beg >= n_frames) - beg = n_frames - 1; - } - n = beg - end + 1; - } - SCM_ASSERT (beg >= 0 && beg < n_frames, a->first, SCM_ARG3, s_display_backtrace); - SCM_ASSERT (n > 0, a->depth, SCM_ARG4, s_display_backtrace); - /* Create a string port used for adaptation of printing parameters. */ - sport = scm_mkstrport (SCM_INUM0, SCM_BOOL_F, - SCM_OPN | SCM_WRTNG, - FUNC_NAME); + if (scm_is_false (a->first)) + a->first = SCM_INUM0; + if (scm_is_false (a->depth)) + a->depth = scm_from_int (SCM_BACKTRACE_DEPTH); - /* Create a print state for printing of frames. */ - print_state = scm_make_print_state (); - pstate = SCM_PRINT_STATE (print_state); - pstate->writingp = 1; - pstate->fancyp = 1; - pstate->highlight_objects = a->highlight_objects; + if (scm_is_false (scm_less_p (a->first, scm_stack_length (a->stack)))) + return SCM_UNSPECIFIED; - /* Determine size of frame number field. */ - j = end; - for (i = 0; j > 0; ++i) j /= 10; - nfield = i ? i : 1; - - /* Print frames. */ - indentation = 1; - last_file = SCM_UNDEFINED; - if (SCM_BACKWARDS_P) - end++; - else - end--; - for (i = beg; i != end; SCM_BACKWARDS_P ? ++i : --i) - { - frame = scm_stack_ref (a->stack, scm_from_int (i)); - if (!scm_is_eq (SCM_PACK (SCM_SHOW_FILE_NAME), sym_base)) - display_backtrace_file (frame, &last_file, a->port, pstate); - display_frame (frame, i, nfield, indentation, sport, a->port, pstate); - } + frames = scm_call_1 (scm_variable_ref (frame_to_stack_vector_var), + scm_stack_ref (a->stack, a->first)); - scm_remember_upto_here_1 (print_state); + /* FIXME: highlight_objects */ + scm_call_4 (scm_variable_ref (print_frames_var), frames, a->port, + kw_count, a->depth); return SCM_UNSPECIFIED; } @@ -546,12 +275,9 @@ SCM_DEFINE (scm_display_backtrace_with_highlights, "display-backtrace", 2, 3, 0, struct display_backtrace_args a; a.stack = stack; a.port = port; - a.first = first; - a.depth = depth; - if (SCM_UNBNDP (highlights)) - a.highlight_objects = SCM_EOL; - else - a.highlight_objects = highlights; + a.first = SCM_UNBNDP (first) ? SCM_BOOL_F : first; + a.depth = SCM_UNBNDP (depth) ? SCM_BOOL_F : depth; + a.highlight_objects = SCM_UNBNDP (highlights) ? SCM_EOL : highlights; scm_internal_catch (SCM_BOOL_T, (scm_t_catch_body) display_backtrace_body, &a, diff --git a/libguile/backtrace.h b/libguile/backtrace.h index 42bd26f2a..59de89dae 100644 --- a/libguile/backtrace.h +++ b/libguile/backtrace.h @@ -36,9 +36,6 @@ SCM_API SCM scm_display_backtrace (SCM stack, SCM port, SCM first, SCM depth); SCM_API SCM scm_display_backtrace_with_highlights (SCM stack, SCM port, SCM first, SCM depth, SCM highlights); SCM_API SCM scm_backtrace (void); SCM_API SCM scm_backtrace_with_highlights (SCM highlights); -#ifdef GUILE_DEBUG -SCM_API SCM scm_set_print_params_x (SCM params); -#endif SCM_INTERNAL void scm_init_backtrace (void); From 0a0a8d819db685e240f0a27404ffd167654b7f85 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 1 Apr 2016 22:37:41 +0200 Subject: [PATCH 184/865] Move setvbuf impl to ports.[ch] * libguile/fports.h (scm_setbuf0): Remove extraneous declaration. * libguile/fports.c: * libguile/ports.c: * libguile/ports.c (scm_setvbuf): Move setvbuf to ports.[ch]. (scm_init_ports): Move _IONBF, _IOLBF, _IOFBF definitions here. --- libguile/fports.c | 103 ---------------------------------------------- libguile/fports.h | 2 - libguile/ports.c | 103 ++++++++++++++++++++++++++++++++++++++++++++++ libguile/ports.h | 1 + 4 files changed, 104 insertions(+), 105 deletions(-) diff --git a/libguile/fports.c b/libguile/fports.c index 8395f0e65..ff6d49dc1 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -136,105 +136,6 @@ scm_fport_buffer_add (SCM port, long read_size, long write_size) } #undef FUNC_NAME -SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, - (SCM port, SCM mode, SCM size), - "Set the buffering mode for @var{port}. @var{mode} can be:\n" - "@table @code\n" - "@item _IONBF\n" - "non-buffered\n" - "@item _IOLBF\n" - "line buffered\n" - "@item _IOFBF\n" - "block buffered, using a newly allocated buffer of @var{size} bytes.\n" - "If @var{size} is omitted, a default size will be used.\n" - "@end table\n\n" - "Only certain types of ports are supported, most importantly\n" - "file ports.") -#define FUNC_NAME s_scm_setvbuf -{ - int cmode; - long csize; - size_t ndrained; - char *drained = NULL; - scm_t_port *pt; - scm_t_ptob_descriptor *ptob; - - port = SCM_COERCE_OUTPORT (port); - - SCM_VALIDATE_OPENPORT (1, port); - ptob = SCM_PORT_DESCRIPTOR (port); - - if (ptob->setvbuf == NULL) - scm_wrong_type_arg_msg (FUNC_NAME, 1, port, - "port that supports 'setvbuf'"); - - cmode = scm_to_int (mode); - if (cmode != _IONBF && cmode != _IOFBF && cmode != _IOLBF) - scm_out_of_range (FUNC_NAME, mode); - - if (cmode == _IOLBF) - { - SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) | SCM_BUFLINE); - cmode = _IOFBF; - } - else - SCM_SET_CELL_WORD_0 (port, - SCM_CELL_WORD_0 (port) & ~(scm_t_bits) SCM_BUFLINE); - - if (SCM_UNBNDP (size)) - { - if (cmode == _IOFBF) - csize = -1; - else - csize = 0; - } - else - { - csize = scm_to_int (size); - if (csize < 0 || (cmode == _IONBF && csize > 0)) - scm_out_of_range (FUNC_NAME, size); - } - - pt = SCM_PTAB_ENTRY (port); - - if (SCM_INPUT_PORT_P (port)) - { - /* Drain pending input from PORT. Don't use `scm_drain_input' since - it returns a string, whereas we want binary input here. */ - ndrained = pt->read_end - pt->read_pos; - if (pt->read_buf == pt->putback_buf) - ndrained += pt->saved_read_end - pt->saved_read_pos; - - if (ndrained > 0) - { - drained = scm_gc_malloc_pointerless (ndrained, "file port"); - scm_take_from_input_buffers (port, drained, ndrained); - } - } - else - ndrained = 0; - - if (SCM_OUTPUT_PORT_P (port)) - scm_flush_unlocked (port); - - if (pt->read_buf == pt->putback_buf) - { - pt->read_buf = pt->saved_read_buf; - pt->read_pos = pt->saved_read_pos; - pt->read_end = pt->saved_read_end; - pt->read_buf_size = pt->saved_read_buf_size; - } - - ptob->setvbuf (port, csize, csize); - - if (ndrained > 0) - /* Put DRAINED back to PORT. */ - scm_unget_bytes ((unsigned char *) drained, ndrained, port); - - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - /* Move ports with the specified file descriptor to new descriptors, * resetting the revealed count to 0. */ @@ -1000,10 +901,6 @@ scm_init_fports () { scm_tc16_fport = scm_make_fptob (); - scm_c_define ("_IOFBF", scm_from_int (_IOFBF)); - scm_c_define ("_IOLBF", scm_from_int (_IOLBF)); - scm_c_define ("_IONBF", scm_from_int (_IONBF)); - sys_file_port_name_canonicalization = scm_make_fluid (); scm_c_define ("%file-port-name-canonicalization", sys_file_port_name_canonicalization); diff --git a/libguile/fports.h b/libguile/fports.h index 092b43ee8..4ea698a5a 100644 --- a/libguile/fports.h +++ b/libguile/fports.h @@ -51,8 +51,6 @@ SCM_API scm_t_bits scm_tc16_fport; #define SCM_FDES_RANDOM_P(fdes) ((lseek (fdes, 0, SEEK_CUR) == -1) ? 0 : 1) -SCM_API SCM scm_setbuf0 (SCM port); -SCM_API SCM scm_setvbuf (SCM port, SCM mode, SCM size); SCM_API void scm_evict_ports (int fd); SCM_API SCM scm_open_file_with_encoding (SCM filename, SCM modes, SCM guess_encoding, SCM encoding); diff --git a/libguile/ports.c b/libguile/ports.c index 98d2fa219..8ad3507b4 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -2337,6 +2337,105 @@ scm_port_non_buffer (scm_t_port *pt) pt->write_end = pt->write_buf + pt->write_buf_size; } +SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, + (SCM port, SCM mode, SCM size), + "Set the buffering mode for @var{port}. @var{mode} can be:\n" + "@table @code\n" + "@item _IONBF\n" + "non-buffered\n" + "@item _IOLBF\n" + "line buffered\n" + "@item _IOFBF\n" + "block buffered, using a newly allocated buffer of @var{size} bytes.\n" + "If @var{size} is omitted, a default size will be used.\n" + "@end table\n\n" + "Only certain types of ports are supported, most importantly\n" + "file ports.") +#define FUNC_NAME s_scm_setvbuf +{ + int cmode; + long csize; + size_t ndrained; + char *drained = NULL; + scm_t_port *pt; + scm_t_ptob_descriptor *ptob; + + port = SCM_COERCE_OUTPORT (port); + + SCM_VALIDATE_OPENPORT (1, port); + ptob = SCM_PORT_DESCRIPTOR (port); + + if (ptob->setvbuf == NULL) + scm_wrong_type_arg_msg (FUNC_NAME, 1, port, + "port that supports 'setvbuf'"); + + cmode = scm_to_int (mode); + if (cmode != _IONBF && cmode != _IOFBF && cmode != _IOLBF) + scm_out_of_range (FUNC_NAME, mode); + + if (cmode == _IOLBF) + { + SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) | SCM_BUFLINE); + cmode = _IOFBF; + } + else + SCM_SET_CELL_WORD_0 (port, + SCM_CELL_WORD_0 (port) & ~(scm_t_bits) SCM_BUFLINE); + + if (SCM_UNBNDP (size)) + { + if (cmode == _IOFBF) + csize = -1; + else + csize = 0; + } + else + { + csize = scm_to_int (size); + if (csize < 0 || (cmode == _IONBF && csize > 0)) + scm_out_of_range (FUNC_NAME, size); + } + + pt = SCM_PTAB_ENTRY (port); + + if (SCM_INPUT_PORT_P (port)) + { + /* Drain pending input from PORT. Don't use `scm_drain_input' since + it returns a string, whereas we want binary input here. */ + ndrained = pt->read_end - pt->read_pos; + if (pt->read_buf == pt->putback_buf) + ndrained += pt->saved_read_end - pt->saved_read_pos; + + if (ndrained > 0) + { + drained = scm_gc_malloc_pointerless (ndrained, "file port"); + scm_take_from_input_buffers (port, drained, ndrained); + } + } + else + ndrained = 0; + + if (SCM_OUTPUT_PORT_P (port)) + scm_flush_unlocked (port); + + if (pt->read_buf == pt->putback_buf) + { + pt->read_buf = pt->saved_read_buf; + pt->read_pos = pt->saved_read_pos; + pt->read_end = pt->saved_read_end; + pt->read_buf_size = pt->saved_read_buf_size; + } + + ptob->setvbuf (port, csize, csize); + + if (ndrained > 0) + /* Put DRAINED back to PORT. */ + scm_unget_bytes ((unsigned char *) drained, ndrained, port); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + /* this should only be called when the read buffer is empty. it tries to refill the read buffer. it returns the first char from the port, which is either EOF or *(pt->read_pos). */ @@ -3183,6 +3282,10 @@ scm_init_ports () scm_c_define ("SEEK_CUR", scm_from_int (SEEK_CUR)); scm_c_define ("SEEK_END", scm_from_int (SEEK_END)); + scm_c_define ("_IOFBF", scm_from_int (_IOFBF)); + scm_c_define ("_IOLBF", scm_from_int (_IOLBF)); + scm_c_define ("_IONBF", scm_from_int (_IONBF)); + scm_tc16_void_port = scm_make_port_type ("void", fill_input_void_port, write_void_port); diff --git a/libguile/ports.h b/libguile/ports.h index f2ab850dd..d8527be5f 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -338,6 +338,7 @@ SCM_API SCM scm_unread_string (SCM str, SCM port); /* Manipulating the buffers. */ SCM_API void scm_port_non_buffer (scm_t_port *pt); +SCM_API SCM scm_setvbuf (SCM port, SCM mode, SCM size); SCM_API int scm_fill_input (SCM port); SCM_API int scm_fill_input_unlocked (SCM port); SCM_INTERNAL size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len); From 59a18451b8bc70fe9cb9b9f41e61bbfa9e0e86be Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 2 Apr 2016 11:50:46 +0200 Subject: [PATCH 185/865] Use symbols instead of _IONBF values as args to setvbuf * libguile/ports.c (scm_setvbuf): Use the symbols `none', `line', and `block' instead of the values `_IONBF', `_IOLBF', and `_IOFBF'. * NEWS: Update. * doc/ref/posix.texi (Ports and File Descriptors): Update setvbuf documentation. * module/ice-9/deprecated.scm (define-deprecated): New helper. (_IONBF, _IOLBF, _IOFBF): Define deprecated values. * benchmark-suite/benchmarks/read.bm ("read"): * benchmark-suite/benchmarks/uniform-vector-read.bm ("uniform-vector-read!"): * libguile/r6rs-ports.c (cbip_fill_input): * module/system/base/types.scm (%ffi-memory-backend): * module/web/client.scm (open-socket-for-uri): * module/web/server/http.scm (http-read): * test-suite/tests/ports.test ("pipe, fdopen, and line buffering"): ("setvbuf"): * test-suite/tests/r6rs-ports.test ("7.2.7 Input Ports"): Update to use non-deprecated interfaces. --- NEWS | 16 +++++ benchmark-suite/benchmarks/read.bm | 20 +++--- .../benchmarks/uniform-vector-read.bm | 2 +- doc/ref/posix.texi | 14 ++-- libguile/ports.c | 70 +++++++++---------- libguile/r6rs-ports.c | 2 +- module/ice-9/deprecated.scm | 19 ++++- module/system/base/types.scm | 2 +- module/web/client.scm | 2 +- module/web/server/http.scm | 2 +- test-suite/tests/ports.test | 10 +-- test-suite/tests/r6rs-ports.test | 16 ++--- 12 files changed, 103 insertions(+), 72 deletions(-) diff --git a/NEWS b/NEWS index 5885e2ef9..1be6c83a2 100644 --- a/NEWS +++ b/NEWS @@ -5,6 +5,22 @@ See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. +FIXME: Incorporate 2.1.2 changes into cumulative 2.2 changes before +releasing 2.1.3. + + +Changes in 2.1.3 (changes since the 2.1.2 alpha release): + +* Notable changes +* New deprecations +** `_IONBF', `_IOLBF', and `_IOFBF' + +Instead, use the symbol values `none', `line', or `block', respectively, +as arguments to the `setvbuf' function. + +* Incompatible changes + + Changes in 2.1.2 (changes since the 2.1.1 alpha release): diff --git a/benchmark-suite/benchmarks/read.bm b/benchmark-suite/benchmarks/read.bm index f0b25f541..a4ff9936f 100644 --- a/benchmark-suite/benchmarks/read.bm +++ b/benchmark-suite/benchmarks/read.bm @@ -51,20 +51,20 @@ (with-benchmark-prefix "read" - (benchmark "_IONBF" 5 ;; this one is very slow - (exercise-read (list _IONBF))) + (benchmark "'none" 5 ;; this one is very slow + (exercise-read (list 'none))) - (benchmark "_IOLBF" 10 - (exercise-read (list _IOLBF))) + (benchmark "'line" 10 + (exercise-read (list 'line))) - (benchmark "_IOFBF 4096" 10 - (exercise-read (list _IOFBF 4096))) + (benchmark "'block 4096" 10 + (exercise-read (list 'block 4096))) - (benchmark "_IOFBF 8192" 10 - (exercise-read (list _IOFBF 8192))) + (benchmark "'block 8192" 10 + (exercise-read (list 'block 8192))) - (benchmark "_IOFBF 16384" 10 - (exercise-read (list _IOFBF 16384))) + (benchmark "'block 16384" 10 + (exercise-read (list 'block 16384))) (benchmark "small strings" 100000 (call-with-input-string small read)) diff --git a/benchmark-suite/benchmarks/uniform-vector-read.bm b/benchmark-suite/benchmarks/uniform-vector-read.bm index 8cda82457..01b747836 100644 --- a/benchmark-suite/benchmarks/uniform-vector-read.bm +++ b/benchmark-suite/benchmarks/uniform-vector-read.bm @@ -43,7 +43,7 @@ (benchmark "uniform-vector-read!" 20000 (let ((input (open-input-file file-name))) - (setvbuf input _IONBF) + (setvbuf input 'none) (uniform-vector-read! buf input) (close input))) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 356941f2d..e5f1232ac 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -458,18 +458,18 @@ cookie. @deffn {Scheme Procedure} setvbuf port mode [size] @deffnx {C Function} scm_setvbuf (port, mode, size) @cindex port buffering -Set the buffering mode for @var{port}. @var{mode} can be: +Set the buffering mode for @var{port}. @var{mode} can be one of the +following symbols: -@defvar _IONBF +@table @code +@item none non-buffered -@end defvar -@defvar _IOLBF +@item line line buffered -@end defvar -@defvar _IOFBF +@item block block buffered, using a newly allocated buffer of @var{size} bytes. If @var{size} is omitted, a default size will be used. -@end defvar +@end table Only certain types of ports are supported, most importantly file ports. diff --git a/libguile/ports.c b/libguile/ports.c index 8ad3507b4..d394193ab 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -2337,65 +2337,67 @@ scm_port_non_buffer (scm_t_port *pt) pt->write_end = pt->write_buf + pt->write_buf_size; } +SCM_SYMBOL (sym_none, "none"); +SCM_SYMBOL (sym_line, "line"); +SCM_SYMBOL (sym_block, "block"); + SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, (SCM port, SCM mode, SCM size), - "Set the buffering mode for @var{port}. @var{mode} can be:\n" + "Set the buffering mode for @var{port}. @var{mode} can be one\n" + "of the following symbols:\n" "@table @code\n" - "@item _IONBF\n" - "non-buffered\n" - "@item _IOLBF\n" - "line buffered\n" - "@item _IOFBF\n" - "block buffered, using a newly allocated buffer of @var{size} bytes.\n" + "@item none\n" + "no buffering\n" + "@item line\n" + "line buffering\n" + "@item block\n" + "block buffering, using a newly allocated buffer of @var{size} bytes.\n" "If @var{size} is omitted, a default size will be used.\n" "@end table\n\n" "Only certain types of ports are supported, most importantly\n" "file ports.") #define FUNC_NAME s_scm_setvbuf { - int cmode; long csize; size_t ndrained; char *drained = NULL; scm_t_port *pt; scm_t_ptob_descriptor *ptob; + scm_t_bits tag_word; port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); ptob = SCM_PORT_DESCRIPTOR (port); + tag_word = SCM_CELL_WORD_0 (port) & ~(SCM_BUF0 | SCM_BUFLINE); if (ptob->setvbuf == NULL) scm_wrong_type_arg_msg (FUNC_NAME, 1, port, "port that supports 'setvbuf'"); - cmode = scm_to_int (mode); - if (cmode != _IONBF && cmode != _IOFBF && cmode != _IOLBF) + if (scm_is_eq (mode, sym_none)) + { + tag_word |= SCM_BUF0; + if (!SCM_UNBNDP (size) && !scm_is_eq (size, SCM_INUM0)) + scm_out_of_range (FUNC_NAME, size); + csize = 0; + } + else if (scm_is_eq (mode, sym_line)) + { + csize = SCM_UNBNDP (size) ? -1 : scm_to_int (size); + tag_word |= SCM_BUFLINE; + } + else if (scm_is_eq (mode, sym_block)) + { + csize = SCM_UNBNDP (size) ? -1 : scm_to_int (size); + } + else scm_out_of_range (FUNC_NAME, mode); - if (cmode == _IOLBF) - { - SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) | SCM_BUFLINE); - cmode = _IOFBF; - } - else - SCM_SET_CELL_WORD_0 (port, - SCM_CELL_WORD_0 (port) & ~(scm_t_bits) SCM_BUFLINE); - - if (SCM_UNBNDP (size)) - { - if (cmode == _IOFBF) - csize = -1; - else - csize = 0; - } - else - { - csize = scm_to_int (size); - if (csize < 0 || (cmode == _IONBF && csize > 0)) - scm_out_of_range (FUNC_NAME, size); - } + if (!SCM_UNBNDP (size) && csize < 0) + scm_out_of_range (FUNC_NAME, size); + SCM_SET_CELL_WORD_0 (port, tag_word); pt = SCM_PTAB_ENTRY (port); if (SCM_INPUT_PORT_P (port)) @@ -3282,10 +3284,6 @@ scm_init_ports () scm_c_define ("SEEK_CUR", scm_from_int (SEEK_CUR)); scm_c_define ("SEEK_END", scm_from_int (SEEK_END)); - scm_c_define ("_IOFBF", scm_from_int (_IOFBF)); - scm_c_define ("_IOLBF", scm_from_int (_IOLBF)); - scm_c_define ("_IONBF", scm_from_int (_IONBF)); - scm_tc16_void_port = scm_make_port_type ("void", fill_input_void_port, write_void_port); diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 2c2b657d7..e4f3b5ca2 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -387,7 +387,7 @@ cbip_fill_input (SCM port) if (buffered) { /* Make sure the buffer isn't corrupt. Its size can be 1 when - someone called 'setvbuf' with _IONBF. BV can be passed + someone called 'setvbuf' with 'none. BV can be passed directly to READ_PROC. */ assert (c_port->read_buf_size == SCM_BYTEVECTOR_LENGTH (bv) || c_port->read_buf_size == 1); diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm index 9835c1230..375846ff3 100644 --- a/module/ice-9/deprecated.scm +++ b/module/ice-9/deprecated.scm @@ -16,4 +16,21 @@ ;;;; (define-module (ice-9 deprecated) - #:export ()) + #:export (_IONBF _IOLBF _IOFBF)) + +(define-syntax-rule (define-deprecated var msg exp) + (define-syntax var + (lambda (x) + (issue-deprecation-warning msg) + (syntax-case x () + (id (identifier? #'id) #'exp))))) + +(define-deprecated _IONBF + "`_IONBF' is deprecated. Use the symbol 'none instead." + 'none) +(define-deprecated _IOLBF + "`_IOLBF' is deprecated. Use the symbol 'line instead." + 'line) +(define-deprecated _IOFBF + "`_IOFBF' is deprecated. Use the symbol 'block instead." + 'block) diff --git a/module/system/base/types.scm b/module/system/base/types.scm index 26760d1d1..ea2f3bcaf 100644 --- a/module/system/base/types.scm +++ b/module/system/base/types.scm @@ -99,7 +99,7 @@ (let ((port (make-custom-binary-input-port "ffi-memory" read-memory! #f #f #f))) - (setvbuf port _IONBF) + (setvbuf port 'none) port))) (memory-backend dereference-word open #f))) diff --git a/module/web/client.scm b/module/web/client.scm index 11fee352d..f24a4d70a 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -92,7 +92,7 @@ (connect s (addrinfo:addr ai)) ;; Buffer input and output on this port. - (setvbuf s _IOFBF) + (setvbuf s 'block) ;; If we're using a proxy, make a note of that. (when http-proxy (set-http-proxy-port?! s #t)) s) diff --git a/module/web/server/http.scm b/module/web/server/http.scm index cda44f4aa..2184ad8a2 100644 --- a/module/web/server/http.scm +++ b/module/web/server/http.scm @@ -97,7 +97,7 @@ ;; FIXME: preserve meta-info. (let ((client (accept (poll-set-port poll-set idx)))) ;; Buffer input and output on this port. - (setvbuf (car client) _IOFBF) + (setvbuf (car client) 'block) ;; From "HOP, A Fast Server for the Diffuse Web", Serrano. (setsockopt (car client) SOL_SOCKET SO_SNDBUF (* 12 1024)) (poll-set-add! poll-set (car client) *events*) diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index c43801db4..2bc719e90 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -637,7 +637,7 @@ (equal? in-string "Mommy, why does everybody have a bomb?\n"))) (delete-file filename)) -(pass-if-equal "pipe, fdopen, and _IOLBF" +(pass-if-equal "pipe, fdopen, and line buffering" "foo\nbar\n" (let ((in+out (pipe)) (pid (primitive-fork))) @@ -647,7 +647,7 @@ (lambda () (close-port (car in+out)) (let ((port (cdr in+out))) - (setvbuf port _IOLBF ) + (setvbuf port 'line ) ;; Strings containing '\n' or should be flushed; others ;; should be kept in PORT's buffer. (display "foo\n" port) @@ -1519,13 +1519,13 @@ exception:wrong-type-arg (let ((port (open-input-file "/dev/null"))) (close-port port) - (setvbuf port _IOFBF))) + (setvbuf port 'block))) (pass-if-exception "string port" exception:wrong-type-arg (let ((port (open-input-string "Hey!"))) (close-port port) - (setvbuf port _IOFBF))) + (setvbuf port 'block))) (pass-if "line/column number preserved" ;; In Guile 2.0.5, `setvbuf' would erroneously decrease the port's @@ -1540,7 +1540,7 @@ (col (port-column p))) (and (= line 0) (= col 1) (begin - (setvbuf p _IOFBF 777) + (setvbuf p 'block 777) (let ((line* (port-line p)) (col* (port-column p))) (and (= line line*) diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index dd4092512..674768ea1 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -516,7 +516,7 @@ not `set-port-position!'" p))) (port (make-custom-binary-input-port "the port" read! get-pos #f #f))) - (setvbuf port _IONBF) + (setvbuf port 'none) (and (= 0 (port-position port)) (begin (get-bytevector-n! port output 0 2) @@ -545,7 +545,7 @@ not `set-port-position!'" (port (make-custom-binary-input-port "the port" read! #f #f #f))) - (setvbuf port _IONBF) + (setvbuf port 'none) (let ((ret (list (get-bytevector-n port 2) (get-bytevector-n port 3) (get-bytevector-n port 42)))) @@ -568,7 +568,7 @@ not `set-port-position!'" (if (eof-object? n) 0 n)))) (port (make-custom-binary-input-port "foo" read! #f #f #f))) - (setvbuf port _IONBF) + (setvbuf port 'none) (get-string-all port))) (pass-if-equal "custom binary input port unbuffered UTF-8 & 'get-string-all'" @@ -583,7 +583,7 @@ not `set-port-position!'" (if (eof-object? n) 0 n)))) (port (make-custom-binary-input-port "foo" read! #f #f #f))) - (setvbuf port _IONBF) + (setvbuf port 'none) (set-port-encoding! port "UTF-8") (get-string-all port))) @@ -603,11 +603,11 @@ not `set-port-position!'" (port (make-custom-binary-input-port "the port" read! #f #f #f))) - (setvbuf port _IONBF) + (setvbuf port 'none) (let ((ret (list (get-bytevector-n port 6) (get-bytevector-n port 12) (begin - (setvbuf port _IOFBF 777) + (setvbuf port 'block 777) (get-bytevector-n port 42)) (get-bytevector-n port 42)))) (zip (reverse reads) @@ -635,11 +635,11 @@ not `set-port-position!'" (port (make-custom-binary-input-port "the port" read! #f #f #f))) - (setvbuf port _IOFBF 18) + (setvbuf port 'block 18) (let ((ret (list (get-bytevector-n port 6) (get-bytevector-n port 12) (begin - (setvbuf port _IONBF) + (setvbuf port 'none) (get-bytevector-n port 42)) (get-bytevector-n port 42)))) (list (reverse reads) From 4eb9fd47c47fcd3d9da8aaced8b729a9cd303ab4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 3 Apr 2016 10:51:58 +0200 Subject: [PATCH 186/865] Move line-buffing machinery to ports.c * libguile/ports.c (scm_lfwrite_unlocked): * libguile/fports.c (fport_write): Move line-buffering from fport_write to scm_lfwrite_unlocked. --- libguile/fports.c | 4 ---- libguile/ports.c | 16 +++++++--------- 2 files changed, 7 insertions(+), 13 deletions(-) diff --git a/libguile/fports.c b/libguile/fports.c index ff6d49dc1..8ad8ba0ca 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -784,10 +784,6 @@ fport_write (SCM port, const void *data, size_t size) } } } - - /* handle line buffering. */ - if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && memchr (data, '\n', size)) - fport_flush (port); } } #undef FUNC_NAME diff --git a/libguile/ports.c b/libguile/ports.c index d394193ab..da8b4d22c 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -2753,23 +2753,21 @@ scm_c_write (SCM port, const void *ptr, size_t size) /* scm_lfwrite * * This function differs from scm_c_write; it updates port line and - * column. */ + * column, flushing line-buffered ports when appropriate. */ void scm_lfwrite_unlocked (const char *ptr, size_t size, SCM port) { - scm_t_port *pt = SCM_PTAB_ENTRY (port); - scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port); + int saved_line; - if (pt->rw_active == SCM_PORT_READ) - scm_end_input_unlocked (port); - - ptob->write (port, ptr, size); + scm_c_write_unlocked (port, ptr, size); + saved_line = SCM_LINUM (port); for (; size; ptr++, size--) update_port_lf ((scm_t_wchar) (unsigned char) *ptr, port); - if (pt->rw_random) - pt->rw_active = SCM_PORT_WRITE; + /* Handle line buffering. */ + if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && saved_line != SCM_LINUM (port)) + scm_flush_unlocked (port); } void From 4460f1f15280e3378633115fe9035448a68c636b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 3 Apr 2016 11:13:13 +0200 Subject: [PATCH 187/865] Remove port mark functions * doc/ref/api-io.texi (Port Implementation): Remove documentation. * libguile/ports.c (scm_set_port_mark): Remove function. * libguile/ports.h (scm_t_ptob_descriptor): Remove mark function. * NEWS: Add entry. --- NEWS | 3 +++ doc/ref/api-io.texi | 8 -------- libguile/ports.c | 6 ------ libguile/ports.h | 2 -- 4 files changed, 3 insertions(+), 16 deletions(-) diff --git a/NEWS b/NEWS index 1be6c83a2..0ab0b395c 100644 --- a/NEWS +++ b/NEWS @@ -19,7 +19,10 @@ Instead, use the symbol values `none', `line', or `block', respectively, as arguments to the `setvbuf' function. * Incompatible changes +** Remove `scm_set_port_mark' +Port mark functions have not been called since the switch to the BDW +garbage collector. Changes in 2.1.2 (changes since the 2.1.1 alpha release): diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index e1501e2b4..80a227202 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -2303,14 +2303,6 @@ A pointer to a NUL terminated string: the name of the port type. This is the only element of @code{scm_ptob_descriptor} which is not a procedure. Set via the first argument to @code{scm_make_port_type}. -@item mark -Called during garbage collection to mark any SCM objects that a port -object may contain. It doesn't need to be set unless the port has -@code{SCM} components. Set using - -@deftypefun void scm_set_port_mark (scm_t_bits tc, SCM (*mark) (SCM port)) -@end deftypefun - @item free Called when the port is collected during gc. It should free any resources used by the port. diff --git a/libguile/ports.c b/libguile/ports.c index da8b4d22c..3f1b5b1c5 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -267,12 +267,6 @@ scm_make_port_type (char *name, return scm_tc7_port + ptobnum * 256; } -void -scm_set_port_mark (scm_t_bits tc, SCM (*mark) (SCM)) -{ - scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->mark = mark; -} - void scm_set_port_free (scm_t_bits tc, size_t (*free) (SCM)) { diff --git a/libguile/ports.h b/libguile/ports.h index d8527be5f..f6c217fe3 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -184,7 +184,6 @@ typedef enum scm_t_port_type_flags { typedef struct scm_t_ptob_descriptor { char *name; - SCM (*mark) (SCM); size_t (*free) (SCM); int (*print) (SCM exp, SCM port, scm_print_state *pstate); SCM (*equalp) (SCM, SCM); @@ -224,7 +223,6 @@ SCM_API scm_t_bits scm_make_port_type (char *name, void (*write) (SCM port, const void *data, size_t size)); -SCM_API void scm_set_port_mark (scm_t_bits tc, SCM (*mark) (SCM)); SCM_API void scm_set_port_free (scm_t_bits tc, size_t (*free) (SCM)); SCM_API void scm_set_port_print (scm_t_bits tc, int (*print) (SCM exp, From 67b147fb7a5e8771b0314fcc0fcc826db09d9949 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 3 Apr 2016 11:39:21 +0200 Subject: [PATCH 188/865] Remove port free functions; just close instead * libguile/ports.h (scm_t_port_type_flags): Replace SCM_PORT_TYPE_HAS_FLUSH with SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC. (scm_t_ptob_descriptor): Remove free function. * libguile/ports.c (scm_set_port_needs_close_on_gc): New function. (scm_set_port_flush): Don't set flags. (scm_c_make_port_with_encoding, scm_close_port): Use the new flag to determine when to add a finalizer and also when to include the port in the weak set. (scm_set_port_free): Remove. (do_close, finalize_port): Close port instead of calling free function. * libguile/r6rs-ports.c (initialize_transcoded_ports): * libguile/vports.c (scm_make_sfptob): * libguile/fports.c (scm_make_fptob): Mark these ports as needing close on GC. * libguile/fports.c (fport_free): Remove. * NEWS: Update. * doc/ref/api-io.texi (Port Implementation): Update. --- NEWS | 11 ++++++++ doc/ref/api-io.texi | 22 ++++++++-------- libguile/fports.c | 9 +------ libguile/ports.c | 59 +++++++++++++++---------------------------- libguile/ports.h | 7 ++--- libguile/r6rs-ports.c | 1 + libguile/vports.c | 1 + 7 files changed, 50 insertions(+), 60 deletions(-) diff --git a/NEWS b/NEWS index 0ab0b395c..24c43b7a0 100644 --- a/NEWS +++ b/NEWS @@ -24,6 +24,17 @@ as arguments to the `setvbuf' function. Port mark functions have not been called since the switch to the BDW garbage collector. +** Remove `scm_set_port_free' + +It used to be that if an open port became unreachable, a special "free" +function would be called instead of the "close" function. Now that the +BDW-GC collector allows us to run arbitrary code in finalizers, we can +simplify to just call "close" on the port and remove the separate free +functions. Note that hooking into the garbage collector has some +overhead. For that reason Guile exposes a new interface, +`scm_set_port_needs_close_on_gc', allowing port implementations to +indicate to Guile whether they need closing on GC or not. + Changes in 2.1.2 (changes since the 2.1.1 alpha release): diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 80a227202..c175d2eac 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -2303,14 +2303,6 @@ A pointer to a NUL terminated string: the name of the port type. This is the only element of @code{scm_ptob_descriptor} which is not a procedure. Set via the first argument to @code{scm_make_port_type}. -@item free -Called when the port is collected during gc. It -should free any resources used by the port. -Set using - -@deftypefun void scm_set_port_free (scm_t_bits tc, size_t (*free) (SCM port)) -@end deftypefun - @item print Called when @code{write} is called on the port object, to print a port description. E.g., for an fport it may produce something like: @@ -2328,13 +2320,21 @@ Not used at present. Set using @end deftypefun @item close -Called when the port is closed, unless it was collected during gc. It -should free any resources used by the port. -Set using +Called when the port is closed. It should free any resources used by +the port. Set using @deftypefun void scm_set_port_close (scm_t_bits tc, int (*close) (SCM port)) @end deftypefun +By default, ports that are garbage collected just go away without +closing. If your port type needs to release some external resource like +a file descriptor, or needs to make sure that its internal buffers are +flushed even if the port is collected while it was open, then mark the +port type as needing a close on GC. + +@deftypefun void scm_set_port_needs_close_on_gc (scm_t_bits tc, int needs_close_p) +@end deftypefun + @item write Accept data which is to be written using the port. The port implementation may choose to buffer the data instead of processing it directly. diff --git a/libguile/fports.c b/libguile/fports.c index 8ad8ba0ca..3f4c8cc2e 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -858,19 +858,12 @@ fport_close (SCM port) return 0; } -static size_t -fport_free (SCM port) -{ - fport_close (port); - return 0; -} - static scm_t_bits scm_make_fptob () { scm_t_bits tc = scm_make_port_type ("file", fport_fill_input, fport_write); - scm_set_port_free (tc, fport_free); + scm_set_port_needs_close_on_gc (tc, 1); scm_set_port_print (tc, fport_print); scm_set_port_flush (tc, fport_flush); scm_set_port_end_input (tc, fport_end_input); diff --git a/libguile/ports.c b/libguile/ports.c index 3f1b5b1c5..e42f983c5 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -267,12 +267,6 @@ scm_make_port_type (char *name, return scm_tc7_port + ptobnum * 256; } -void -scm_set_port_free (scm_t_bits tc, size_t (*free) (SCM)) -{ - scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->free = free; -} - void scm_set_port_print (scm_t_bits tc, int (*print) (SCM exp, SCM port, scm_print_state *pstate)) @@ -293,11 +287,20 @@ scm_set_port_close (scm_t_bits tc, int (*close) (SCM)) } void -scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port)) +scm_set_port_needs_close_on_gc (scm_t_bits tc, int needs_close_p) { scm_t_ptob_descriptor *ptob = scm_c_port_type_ref (SCM_TC2PTOBNUM (tc)); - ptob->flush = flush; - ptob->flags |= SCM_PORT_TYPE_HAS_FLUSH; + + if (needs_close_p) + ptob->flags |= SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC; + else + ptob->flags &= ~SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC; +} + +void +scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port)) +{ + scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->flush = flush; } void @@ -633,22 +636,10 @@ SCM scm_i_port_weak_set; /* Port finalization. */ -struct do_free_data -{ - scm_t_ptob_descriptor *ptob; - SCM port; -}; - static SCM -do_free (void *body_data) +do_close (void *data) { - struct do_free_data *data = body_data; - - /* `close' is for explicit `close-port' by user. `free' is for this - purpose: ports collected by the GC. */ - data->ptob->free (data->port); - - return SCM_BOOL_T; + return scm_close_port (SCM_PACK_POINTER (data)); } /* Finalize the object (a port) pointed to by PTR. */ @@ -662,16 +653,8 @@ finalize_port (void *ptr, void *data) if (SCM_OPENP (port)) { - struct do_free_data data; - - SCM_CLR_PORT_OPEN_FLAG (port); - - data.ptob = SCM_PORT_DESCRIPTOR (port); - data.port = port; - - scm_internal_catch (SCM_BOOL_T, do_free, &data, + scm_internal_catch (SCM_BOOL_T, do_close, ptr, scm_handle_by_message_noexit, NULL); - scm_gc_ports_collected++; } } @@ -732,11 +715,11 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits, pti->pending_eof = 0; pti->alist = SCM_EOL; - if (SCM_PORT_DESCRIPTOR (ret)->free) - scm_i_set_finalizer (SCM2PTR (ret), finalize_port, NULL); - - if (SCM_PORT_DESCRIPTOR (ret)->flags & SCM_PORT_TYPE_HAS_FLUSH) - scm_weak_set_add_x (scm_i_port_weak_set, ret); + if (SCM_PORT_DESCRIPTOR (ret)->flags & SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC) + { + scm_i_set_finalizer (SCM2PTR (ret), finalize_port, NULL); + scm_weak_set_add_x (scm_i_port_weak_set, ret); + } return ret; } @@ -848,7 +831,7 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, pti = SCM_PORT_GET_INTERNAL (port); SCM_CLR_PORT_OPEN_FLAG (port); - if (SCM_PORT_DESCRIPTOR (port)->flags & SCM_PORT_TYPE_HAS_FLUSH) + if (SCM_PORT_DESCRIPTOR (port)->flags & SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC) scm_weak_set_remove_x (scm_i_port_weak_set, port); if (SCM_PORT_DESCRIPTOR (port)->close) diff --git a/libguile/ports.h b/libguile/ports.h index f6c217fe3..379fba294 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -177,14 +177,15 @@ SCM_INTERNAL SCM scm_i_port_weak_set; typedef enum scm_t_port_type_flags { - SCM_PORT_TYPE_HAS_FLUSH = 1 << 0 + /* Indicates that the port should be closed if it is garbage collected + while it is open. */ + SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC = 1 << 0 } scm_t_port_type_flags; /* port-type description. */ typedef struct scm_t_ptob_descriptor { char *name; - size_t (*free) (SCM); int (*print) (SCM exp, SCM port, scm_print_state *pstate); SCM (*equalp) (SCM, SCM); int (*close) (SCM port); @@ -223,13 +224,13 @@ SCM_API scm_t_bits scm_make_port_type (char *name, void (*write) (SCM port, const void *data, size_t size)); -SCM_API void scm_set_port_free (scm_t_bits tc, size_t (*free) (SCM)); SCM_API void scm_set_port_print (scm_t_bits tc, int (*print) (SCM exp, SCM port, scm_print_state *pstate)); SCM_API void scm_set_port_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM)); SCM_API void scm_set_port_close (scm_t_bits tc, int (*close) (SCM)); +SCM_API void scm_set_port_needs_close_on_gc (scm_t_bits tc, int needs_close_p); SCM_API void scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port)); SCM_API void scm_set_port_end_input (scm_t_bits tc, diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index e4f3b5ca2..274560251 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -1249,6 +1249,7 @@ initialize_transcoded_ports (void) scm_set_port_flush (transcoded_port_type, tp_flush); scm_set_port_close (transcoded_port_type, tp_close); + scm_set_port_needs_close_on_gc (transcoded_port_type, 1); } SCM_INTERNAL SCM scm_i_make_transcoded_port (SCM); diff --git a/libguile/vports.c b/libguile/vports.c index 17eac8695..c08df2ed0 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -225,6 +225,7 @@ scm_make_sfptob () scm_set_port_flush (tc, sf_flush); scm_set_port_close (tc, sf_close); + scm_set_port_needs_close_on_gc (tc, 1); scm_set_port_input_waiting (tc, sf_input_waiting); return tc; From e98f64009d493cb9b3bcd00d3846c96772f00778 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 3 Apr 2016 12:08:07 +0200 Subject: [PATCH 189/865] Remove port equal functions * doc/ref/api-io.texi (Port Implementation): Remove mention of port equal functions. * NEWS: Update. * libguile/ports.c (scm_set_port_equalp): Remove. * libguile/ports.h (scm_t_ptob_descriptor): Remove equalp function. --- NEWS | 6 ++++++ doc/ref/api-io.texi | 6 ------ libguile/ports.c | 6 ------ libguile/ports.h | 2 -- 4 files changed, 6 insertions(+), 14 deletions(-) diff --git a/NEWS b/NEWS index 24c43b7a0..c5a2a3f38 100644 --- a/NEWS +++ b/NEWS @@ -24,6 +24,12 @@ as arguments to the `setvbuf' function. Port mark functions have not been called since the switch to the BDW garbage collector. +** Remove `scm_set_port_equalp' + +Likewise port equal functions weren't being called. Given that ports +have their own internal buffers, it doesn't make sense to hook them into +equal? anyway. + ** Remove `scm_set_port_free' It used to be that if an open port became unreachable, a special "free" diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index c175d2eac..759d33940 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -2313,12 +2313,6 @@ The first argument @var{port} is the object being printed, the second argument @var{dest_port} is where its description should go. @end deftypefun -@item equalp -Not used at present. Set using - -@deftypefun void scm_set_port_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM)) -@end deftypefun - @item close Called when the port is closed. It should free any resources used by the port. Set using diff --git a/libguile/ports.c b/libguile/ports.c index e42f983c5..2c509eac0 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -274,12 +274,6 @@ scm_set_port_print (scm_t_bits tc, int (*print) (SCM exp, SCM port, scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->print = print; } -void -scm_set_port_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM)) -{ - scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->equalp = equalp; -} - void scm_set_port_close (scm_t_bits tc, int (*close) (SCM)) { diff --git a/libguile/ports.h b/libguile/ports.h index 379fba294..6b9a006b8 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -187,7 +187,6 @@ typedef struct scm_t_ptob_descriptor { char *name; int (*print) (SCM exp, SCM port, scm_print_state *pstate); - SCM (*equalp) (SCM, SCM); int (*close) (SCM port); void (*write) (SCM port, const void *data, size_t size); @@ -228,7 +227,6 @@ SCM_API void scm_set_port_print (scm_t_bits tc, int (*print) (SCM exp, SCM port, scm_print_state *pstate)); -SCM_API void scm_set_port_equalp (scm_t_bits tc, SCM (*equalp) (SCM, SCM)); SCM_API void scm_set_port_close (scm_t_bits tc, int (*close) (SCM)); SCM_API void scm_set_port_needs_close_on_gc (scm_t_bits tc, int needs_close_p); From 693359cb3de8918e4f5151426c34104429d8fc3e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 3 Apr 2016 20:43:16 +0200 Subject: [PATCH 190/865] Cosmetic changes to r6rs-ports.c * libguile/r6rs-ports.c: Expand out the acronyms "bip", "bop", "cbip", "cbop", and "tp". They always confused me, especially that the "b" in cbip/cbop wasn't the same as the one in bip/bop. --- libguile/r6rs-ports.c | 246 ++++++++++++++++++++++-------------------- 1 file changed, 128 insertions(+), 118 deletions(-) diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 274560251..6d0e3ec00 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -59,7 +59,7 @@ SCM_DEFINE (scm_eof_object, "eof-object", 0, 0, 0, "Return the end-of-file object.") #define FUNC_NAME s_scm_eof_object { - return (SCM_EOF_VAL); + return SCM_EOF_VAL; } #undef FUNC_NAME @@ -70,11 +70,11 @@ SCM_DEFINE (scm_eof_object, "eof-object", 0, 0, 0, # define MIN(a,b) ((a) < (b) ? (a) : (b)) #endif -/* Bytevector input ports or "bip" for short. */ +/* Bytevector input ports. */ static scm_t_bits bytevector_input_port_type = 0; static inline SCM -make_bip (SCM bv) +make_bytevector_input_port (SCM bv) { SCM port; char *c_bv; @@ -102,7 +102,7 @@ make_bip (SCM bv) } static int -bip_fill_input (SCM port) +bytevector_input_port_fill_input (SCM port) { int result; scm_t_port *c_port = SCM_PTAB_ENTRY (port); @@ -116,8 +116,8 @@ bip_fill_input (SCM port) } static scm_t_off -bip_seek (SCM port, scm_t_off offset, int whence) -#define FUNC_NAME "bip_seek" +bytevector_input_port_seek (SCM port, scm_t_off offset, int whence) +#define FUNC_NAME "bytevector_input_port_seek" { scm_t_off c_result = 0; scm_t_port *c_port = SCM_PTAB_ENTRY (port); @@ -163,10 +163,11 @@ static inline void initialize_bytevector_input_ports (void) { bytevector_input_port_type = - scm_make_port_type ("r6rs-bytevector-input-port", bip_fill_input, + scm_make_port_type ("r6rs-bytevector-input-port", + bytevector_input_port_fill_input, NULL); - scm_set_port_seek (bytevector_input_port_type, bip_seek); + scm_set_port_seek (bytevector_input_port_type, bytevector_input_port_seek); } @@ -181,7 +182,7 @@ SCM_DEFINE (scm_open_bytevector_input_port, if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder)) transcoders_not_implemented (); - return (make_bip (bv)); + return make_bytevector_input_port (bv); } #undef FUNC_NAME @@ -189,16 +190,16 @@ SCM_DEFINE (scm_open_bytevector_input_port, /* Custom binary ports. The following routines are shared by input and output custom binary ports. */ -#define SCM_CBP_GET_POSITION_PROC(_port) \ +#define SCM_CUSTOM_BINARY_PORT_GET_POSITION_PROC(_port) \ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1) -#define SCM_CBP_SET_POSITION_PROC(_port) \ +#define SCM_CUSTOM_BINARY_PORT_SET_POSITION_PROC(_port) \ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2) -#define SCM_CBP_CLOSE_PROC(_port) \ +#define SCM_CUSTOM_BINARY_PORT_CLOSE_PROC(_port) \ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3) static scm_t_off -cbp_seek (SCM port, scm_t_off offset, int whence) -#define FUNC_NAME "cbp_seek" +custom_binary_port_seek (SCM port, scm_t_off offset, int whence) +#define FUNC_NAME "custom_binary_port_seek" { SCM result; scm_t_off c_result = 0; @@ -209,7 +210,7 @@ cbp_seek (SCM port, scm_t_off offset, int whence) { SCM get_position_proc; - get_position_proc = SCM_CBP_GET_POSITION_PROC (port); + get_position_proc = SCM_CUSTOM_BINARY_PORT_GET_POSITION_PROC (port); if (SCM_LIKELY (scm_is_true (get_position_proc))) result = scm_call_0 (get_position_proc); else @@ -229,7 +230,7 @@ cbp_seek (SCM port, scm_t_off offset, int whence) { SCM set_position_proc; - set_position_proc = SCM_CBP_SET_POSITION_PROC (port); + set_position_proc = SCM_CUSTOM_BINARY_PORT_SET_POSITION_PROC (port); if (SCM_LIKELY (scm_is_true (set_position_proc))) result = scm_call_1 (set_position_proc, scm_from_int (offset)); else @@ -253,11 +254,11 @@ cbp_seek (SCM port, scm_t_off offset, int whence) #undef FUNC_NAME static int -cbp_close (SCM port) +custom_binary_port_close (SCM port) { SCM close_proc; - close_proc = SCM_CBP_CLOSE_PROC (port); + close_proc = SCM_CUSTOM_BINARY_PORT_CLOSE_PROC (port); if (scm_is_true (close_proc)) /* Invoke the `close' thunk. */ scm_call_0 (close_proc); @@ -266,35 +267,35 @@ cbp_close (SCM port) } -/* Custom binary input port ("cbip" for short). */ +/* Custom binary input port. */ static scm_t_bits custom_binary_input_port_type = 0; /* Initial size of the buffer embedded in custom binary input ports. */ -#define CBIP_BUFFER_SIZE 8192 +#define CUSTOM_BINARY_INPUT_PORT_BUFFER_SIZE 8192 /* Return the bytevector associated with PORT. */ -#define SCM_CBIP_BYTEVECTOR(_port) \ +#define SCM_CUSTOM_BINARY_INPUT_PORT_BYTEVECTOR(_port) \ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4) /* Set BV as the bytevector associated with PORT. */ -#define SCM_SET_CBIP_BYTEVECTOR(_port, _bv) \ +#define SCM_SET_CUSTOM_BINARY_INPUT_PORT_BYTEVECTOR(_port, _bv) \ SCM_SIMPLE_VECTOR_SET (SCM_PACK (SCM_STREAM (_port)), 4, (_bv)) /* Return the various procedures of PORT. */ -#define SCM_CBIP_READ_PROC(_port) \ +#define SCM_CUSTOM_BINARY_INPUT_PORT_READ_PROC(_port) \ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0) /* Set PORT's internal buffer according to READ_SIZE. */ static void -cbip_setvbuf (SCM port, long read_size, long write_size) +custom_binary_input_port_setvbuf (SCM port, long read_size, long write_size) { SCM bv; scm_t_port *pt; pt = SCM_PTAB_ENTRY (port); - bv = SCM_CBIP_BYTEVECTOR (port); + bv = SCM_CUSTOM_BINARY_INPUT_PORT_BYTEVECTOR (port); switch (read_size) { @@ -316,7 +317,7 @@ cbip_setvbuf (SCM port, long read_size, long write_size) default: /* Fully buffered: allocate a buffer of READ_SIZE bytes. */ bv = scm_c_make_bytevector (read_size); - SCM_SET_CBIP_BYTEVECTOR (port, bv); + SCM_SET_CUSTOM_BINARY_INPUT_PORT_BYTEVECTOR (port, bv); pt->read_buf = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); pt->read_buf_size = read_size; } @@ -325,8 +326,8 @@ cbip_setvbuf (SCM port, long read_size, long write_size) } static inline SCM -make_cbip (SCM read_proc, SCM get_position_proc, - SCM set_position_proc, SCM close_proc) +make_custom_binary_input_port (SCM read_proc, SCM get_position_proc, + SCM set_position_proc, SCM close_proc) { SCM port, bv, method_vector; char *c_bv; @@ -335,7 +336,7 @@ make_cbip (SCM read_proc, SCM get_position_proc, const unsigned long mode_bits = SCM_OPN | SCM_RDNG; /* Use a bytevector as the underlying buffer. */ - c_len = CBIP_BUFFER_SIZE; + c_len = CUSTOM_BINARY_INPUT_PORT_BUFFER_SIZE; bv = scm_c_make_bytevector (c_len); c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); @@ -364,8 +365,8 @@ make_cbip (SCM read_proc, SCM get_position_proc, } static int -cbip_fill_input (SCM port) -#define FUNC_NAME "cbip_fill_input" +custom_binary_input_port_fill_input (SCM port) +#define FUNC_NAME "custom_binary_input_port_fill_input" { int result; scm_t_port *c_port = SCM_PTAB_ENTRY (port); @@ -378,9 +379,9 @@ cbip_fill_input (SCM port) SCM bv, read_proc, octets; c_requested = c_port->read_buf_size; - read_proc = SCM_CBIP_READ_PROC (port); + read_proc = SCM_CUSTOM_BINARY_INPUT_PORT_READ_PROC (port); - bv = SCM_CBIP_BYTEVECTOR (port); + bv = SCM_CUSTOM_BINARY_INPUT_PORT_BYTEVECTOR (port); buffered = (c_port->read_buf == (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv)); @@ -405,7 +406,7 @@ cbip_fill_input (SCM port) bytevector for later reuse, in the hope that the application has regular access patterns. */ bv = scm_c_make_bytevector (c_requested); - SCM_SET_CBIP_BYTEVECTOR (port, bv); + SCM_SET_CUSTOM_BINARY_INPUT_PORT_BYTEVECTOR (port, bv); } } @@ -456,8 +457,8 @@ SCM_DEFINE (scm_make_custom_binary_input_port, if (!scm_is_false (close_proc)) SCM_VALIDATE_PROC (5, close_proc); - return (make_cbip (read_proc, get_position_proc, set_position_proc, - close_proc)); + return make_custom_binary_input_port (read_proc, get_position_proc, + set_position_proc, close_proc); } #undef FUNC_NAME @@ -468,11 +469,12 @@ initialize_custom_binary_input_ports (void) { custom_binary_input_port_type = scm_make_port_type ("r6rs-custom-binary-input-port", - cbip_fill_input, NULL); + custom_binary_input_port_fill_input, NULL); - scm_set_port_seek (custom_binary_input_port_type, cbp_seek); - scm_set_port_close (custom_binary_input_port_type, cbp_close); - scm_set_port_setvbuf (custom_binary_input_port_type, cbip_setvbuf); + scm_set_port_seek (custom_binary_input_port_type, custom_binary_port_seek); + scm_set_port_close (custom_binary_input_port_type, custom_binary_port_close); + scm_set_port_setvbuf (custom_binary_input_port_type, + custom_binary_input_port_setvbuf); } @@ -814,17 +816,19 @@ SCM_DEFINE (scm_unget_bytevector, "unget-bytevector", 2, 2, 0, -/* Bytevector output port ("bop" for short). */ +/* Bytevector output port. */ -/* Implementation of "bops". +/* Implementation of "bytevector output ports". - Each bop has an internal buffer, of type `scm_t_bop_buffer', attached to - it. The procedure returned along with the output port is actually an - applicable SMOB. The SMOB holds a reference to the port. When applied, - the SMOB swallows the port's internal buffer, turning it into a - bytevector, and resets it. + Each bytevector output port has an internal buffer, of type + `scm_t_bytevector_output_port_buffer', attached to it. The procedure + returned along with the output port is actually an applicable SMOB. + The SMOB holds a reference to the port. When applied, the SMOB + swallows the port's internal buffer, turning it into a bytevector, + and resets it. - XXX: Access to a bop's internal buffer is not thread-safe. */ + XXX: Access to a bytevector output port's internal buffer is not + thread-safe. */ static scm_t_bits bytevector_output_port_type = 0; @@ -832,64 +836,67 @@ SCM_SMOB (bytevector_output_port_procedure, "r6rs-bytevector-output-port-procedure", 0); -#define SCM_GC_BOP "r6rs-bytevector-output-port" -#define SCM_BOP_BUFFER_INITIAL_SIZE 4096 +#define SCM_GC_BYTEVECTOR_OUTPUT_PORT "r6rs-bytevector-output-port" +#define SCM_BYTEVECTOR_OUTPUT_PORT_BUFFER_INITIAL_SIZE 4096 -/* Representation of a bop's internal buffer. */ +/* Representation of a bytevector output port's internal buffer. */ typedef struct { size_t total_len; size_t len; size_t pos; char *buffer; -} scm_t_bop_buffer; +} scm_t_bytevector_output_port_buffer; -/* Accessing a bop's buffer. */ -#define SCM_BOP_BUFFER(_port) \ - ((scm_t_bop_buffer *) SCM_STREAM (_port)) -#define SCM_SET_BOP_BUFFER(_port, _buf) \ +/* Accessing a bytevector output port's buffer. */ +#define SCM_BYTEVECTOR_OUTPUT_PORT_BUFFER(_port) \ + ((scm_t_bytevector_output_port_buffer *) SCM_STREAM (_port)) +#define SCM_SET_BYTEVECTOR_OUTPUT_PORT_BUFFER(_port, _buf) \ (SCM_SETSTREAM ((_port), (scm_t_bits) (_buf))) static inline void -bop_buffer_init (scm_t_bop_buffer *buf) +bytevector_output_port_buffer_init (scm_t_bytevector_output_port_buffer *buf) { buf->total_len = buf->len = buf->pos = 0; buf->buffer = NULL; } static inline void -bop_buffer_grow (scm_t_bop_buffer *buf, size_t min_size) +bytevector_output_port_buffer_grow (scm_t_bytevector_output_port_buffer *buf, + size_t min_size) { char *new_buf; size_t new_size; for (new_size = buf->total_len - ? buf->total_len : SCM_BOP_BUFFER_INITIAL_SIZE; + ? buf->total_len : SCM_BYTEVECTOR_OUTPUT_PORT_BUFFER_INITIAL_SIZE; new_size < min_size; new_size *= 2); if (buf->buffer) new_buf = scm_gc_realloc ((void *) buf->buffer, buf->total_len, - new_size, SCM_GC_BOP); + new_size, SCM_GC_BYTEVECTOR_OUTPUT_PORT); else - new_buf = scm_gc_malloc_pointerless (new_size, SCM_GC_BOP); + new_buf = scm_gc_malloc_pointerless (new_size, + SCM_GC_BYTEVECTOR_OUTPUT_PORT); buf->buffer = new_buf; buf->total_len = new_size; } static inline SCM -make_bop (void) +make_bytevector_output_port (void) { - SCM port, bop_proc; + SCM port, proc; scm_t_port *c_port; - scm_t_bop_buffer *buf; + scm_t_bytevector_output_port_buffer *buf; const unsigned long mode_bits = SCM_OPN | SCM_WRTNG; - buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP); - bop_buffer_init (buf); + buf = (scm_t_bytevector_output_port_buffer *) + scm_gc_malloc (sizeof (* buf), SCM_GC_BYTEVECTOR_OUTPUT_PORT); + bytevector_output_port_buffer_init (buf); port = scm_c_make_port_with_encoding (bytevector_output_port_type, mode_bits, @@ -902,22 +909,22 @@ make_bop (void) c_port->write_buf = c_port->write_pos = c_port->write_end = NULL; c_port->write_buf_size = 0; - /* Make the bop procedure. */ - SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure, buf); + /* Make the bytevector output port procedure. */ + SCM_NEWSMOB (proc, bytevector_output_port_procedure, buf); - return (scm_values (scm_list_2 (port, bop_proc))); + return (scm_values (scm_list_2 (port, proc))); } /* Write SIZE octets from DATA to PORT. */ static void -bop_write (SCM port, const void *data, size_t size) +bytevector_output_port_write (SCM port, const void *data, size_t size) { - scm_t_bop_buffer *buf; + scm_t_bytevector_output_port_buffer *buf; - buf = SCM_BOP_BUFFER (port); + buf = SCM_BYTEVECTOR_OUTPUT_PORT_BUFFER (port); if (buf->pos + size > buf->total_len) - bop_buffer_grow (buf, buf->pos + size); + bytevector_output_port_buffer_grow (buf, buf->pos + size); memcpy (buf->buffer + buf->pos, data, size); buf->pos += size; @@ -925,12 +932,12 @@ bop_write (SCM port, const void *data, size_t size) } static scm_t_off -bop_seek (SCM port, scm_t_off offset, int whence) -#define FUNC_NAME "bop_seek" +bytevector_output_port_seek (SCM port, scm_t_off offset, int whence) +#define FUNC_NAME "bytevector_output_port_seek" { - scm_t_bop_buffer *buf; + scm_t_bytevector_output_port_buffer *buf; - buf = SCM_BOP_BUFFER (port); + buf = SCM_BYTEVECTOR_OUTPUT_PORT_BUFFER (port); switch (whence) { case SEEK_CUR: @@ -960,17 +967,17 @@ bop_seek (SCM port, scm_t_off offset, int whence) } #undef FUNC_NAME -/* Fetch data from a bop. */ +/* Fetch data from a bytevector output port. */ SCM_SMOB_APPLY (bytevector_output_port_procedure, - bop_proc_apply, 0, 0, 0, (SCM bop_proc)) + bytevector_output_port_proc_apply, 0, 0, 0, (SCM proc)) { SCM bv; - scm_t_bop_buffer *buf, result_buf; + scm_t_bytevector_output_port_buffer *buf, result_buf; - buf = (scm_t_bop_buffer *) SCM_SMOB_DATA (bop_proc); + buf = (scm_t_bytevector_output_port_buffer *) SCM_SMOB_DATA (proc); result_buf = *buf; - bop_buffer_init (buf); + bytevector_output_port_buffer_init (buf); if (result_buf.len == 0) bv = scm_c_take_gc_bytevector (NULL, 0, SCM_BOOL_F); @@ -981,7 +988,7 @@ SCM_SMOB_APPLY (bytevector_output_port_procedure, result_buf.buffer = scm_gc_realloc ((void *) result_buf.buffer, result_buf.total_len, result_buf.len, - SCM_GC_BOP); + SCM_GC_BYTEVECTOR_OUTPUT_PORT); bv = scm_c_take_gc_bytevector ((signed char *) result_buf.buffer, result_buf.len, SCM_BOOL_F); @@ -1001,7 +1008,7 @@ SCM_DEFINE (scm_open_bytevector_output_port, if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder)) transcoders_not_implemented (); - return (make_bop ()); + return make_bytevector_output_port (); } #undef FUNC_NAME @@ -1010,24 +1017,24 @@ initialize_bytevector_output_ports (void) { bytevector_output_port_type = scm_make_port_type ("r6rs-bytevector-output-port", - NULL, bop_write); + NULL, bytevector_output_port_write); - scm_set_port_seek (bytevector_output_port_type, bop_seek); + scm_set_port_seek (bytevector_output_port_type, bytevector_output_port_seek); } -/* Custom binary output port ("cbop" for short). */ +/* Custom binary output port. */ static scm_t_bits custom_binary_output_port_type; /* Return the various procedures of PORT. */ -#define SCM_CBOP_WRITE_PROC(_port) \ +#define SCM_CUSTOM_BINARY_OUTPUT_PORT_WRITE_PROC(_port) \ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0) static inline SCM -make_cbop (SCM write_proc, SCM get_position_proc, - SCM set_position_proc, SCM close_proc) +make_custom_binary_output_port (SCM write_proc, SCM get_position_proc, + SCM set_position_proc, SCM close_proc) { SCM port, method_vector; scm_t_port *c_port; @@ -1057,8 +1064,8 @@ make_cbop (SCM write_proc, SCM get_position_proc, /* Write SIZE octets from DATA to PORT. */ static void -cbop_write (SCM port, const void *data, size_t size) -#define FUNC_NAME "cbop_write" +custom_binary_output_port_write (SCM port, const void *data, size_t size) +#define FUNC_NAME "custom_binary_output_port_write" { long int c_result; size_t c_written; @@ -1071,7 +1078,7 @@ cbop_write (SCM port, const void *data, size_t size) bv = scm_c_make_bytevector (size); memcpy (SCM_BYTEVECTOR_CONTENTS (bv), data, size); - write_proc = SCM_CBOP_WRITE_PROC (port); + write_proc = SCM_CUSTOM_BINARY_OUTPUT_PORT_WRITE_PROC (port); /* Since the `write' procedure of Guile's ports has type `void', it must try hard to write exactly SIZE bytes, regardless of how many bytes the @@ -1116,8 +1123,8 @@ SCM_DEFINE (scm_make_custom_binary_output_port, if (!scm_is_false (close_proc)) SCM_VALIDATE_PROC (5, close_proc); - return (make_cbop (write_proc, get_position_proc, set_position_proc, - close_proc)); + return make_custom_binary_output_port (write_proc, get_position_proc, + set_position_proc, close_proc); } #undef FUNC_NAME @@ -1128,22 +1135,22 @@ initialize_custom_binary_output_ports (void) { custom_binary_output_port_type = scm_make_port_type ("r6rs-custom-binary-output-port", - NULL, cbop_write); + NULL, custom_binary_output_port_write); - scm_set_port_seek (custom_binary_output_port_type, cbp_seek); - scm_set_port_close (custom_binary_output_port_type, cbp_close); + scm_set_port_seek (custom_binary_output_port_type, custom_binary_port_seek); + scm_set_port_close (custom_binary_output_port_type, custom_binary_port_close); } -/* Transcoded ports ("tp" for short). */ +/* Transcoded ports. */ static scm_t_bits transcoded_port_type = 0; -#define TP_INPUT_BUFFER_SIZE 4096 +#define TRANSCODED_PORT_INPUT_BUFFER_SIZE 4096 -#define SCM_TP_BINARY_PORT(_port) SCM_PACK (SCM_STREAM (_port)) +#define SCM_TRANSCODED_PORT_BINARY_PORT(_port) SCM_PACK (SCM_STREAM (_port)) static inline SCM -make_tp (SCM binary_port, unsigned long mode) +make_transcoded_port (SCM binary_port, unsigned long mode) { SCM port; scm_t_port *c_port; @@ -1155,10 +1162,11 @@ make_tp (SCM binary_port, unsigned long mode) if (SCM_INPUT_PORT_P (port)) { c_port = SCM_PTAB_ENTRY (port); - c_port->read_buf = scm_gc_malloc_pointerless (TP_INPUT_BUFFER_SIZE, - "port buffer"); + c_port->read_buf = + scm_gc_malloc_pointerless (TRANSCODED_PORT_INPUT_BUFFER_SIZE, + "port buffer"); c_port->read_pos = c_port->read_end = c_port->read_buf; - c_port->read_buf_size = TP_INPUT_BUFFER_SIZE; + c_port->read_buf_size = TRANSCODED_PORT_INPUT_BUFFER_SIZE; SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~SCM_BUF0); } @@ -1167,17 +1175,17 @@ make_tp (SCM binary_port, unsigned long mode) } static void -tp_write (SCM port, const void *data, size_t size) +transcoded_port_write (SCM port, const void *data, size_t size) { - scm_c_write_unlocked (SCM_TP_BINARY_PORT (port), data, size); + scm_c_write_unlocked (SCM_TRANSCODED_PORT_BINARY_PORT (port), data, size); } static int -tp_fill_input (SCM port) +transcoded_port_fill_input (SCM port) { size_t count; scm_t_port *c_port = SCM_PTAB_ENTRY (port); - SCM bport = SCM_TP_BINARY_PORT (port); + SCM bport = SCM_TRANSCODED_PORT_BINARY_PORT (port); scm_t_port *c_bport = SCM_PTAB_ENTRY (bport); /* We can't use `scm_c_read' here, since it blocks until the whole @@ -1210,9 +1218,9 @@ tp_fill_input (SCM port) } static void -tp_flush (SCM port) +transcoded_port_flush (SCM port) { - SCM binary_port = SCM_TP_BINARY_PORT (port); + SCM binary_port = SCM_TRANSCODED_PORT_BINARY_PORT (port); scm_t_port *c_port = SCM_PTAB_ENTRY (port); size_t count = c_port->write_pos - c_port->write_buf; @@ -1234,21 +1242,23 @@ tp_flush (SCM port) } static int -tp_close (SCM port) +transcoded_port_close (SCM port) { + SCM bport = SCM_TRANSCODED_PORT_BINARY_PORT (port); if (SCM_OUTPUT_PORT_P (port)) - tp_flush (port); - return scm_is_true (scm_close_port (SCM_TP_BINARY_PORT (port))) ? 0 : -1; + transcoded_port_flush (port); + return scm_is_true (scm_close_port (bport)) ? 0 : -1; } static inline void initialize_transcoded_ports (void) { transcoded_port_type = - scm_make_port_type ("r6rs-transcoded-port", tp_fill_input, tp_write); + scm_make_port_type ("r6rs-transcoded-port", transcoded_port_fill_input, + transcoded_port_write); - scm_set_port_flush (transcoded_port_type, tp_flush); - scm_set_port_close (transcoded_port_type, tp_close); + scm_set_port_flush (transcoded_port_type, transcoded_port_flush); + scm_set_port_close (transcoded_port_type, transcoded_port_close); scm_set_port_needs_close_on_gc (transcoded_port_type, 1); } @@ -1270,7 +1280,7 @@ SCM_DEFINE (scm_i_make_transcoded_port, else if (scm_is_true (scm_input_port_p (port))) mode |= SCM_RDNG; - result = make_tp (port, mode); + result = make_transcoded_port (port, mode); /* FIXME: We should actually close `port' "in a special way" here, according to R6RS. As there is no way to do that in Guile without From b538a96f927d5a0079655bd6df8f019c008930ee Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 3 Apr 2016 21:54:37 +0200 Subject: [PATCH 191/865] Custom binary port internals refactor * libguile/r6rs-ports.c (struct custom_binary_port): Use a struct instead of a vector as the state for a custom binary port. Adapt all callers. Some whitespace fixes as well. --- libguile/r6rs-ports.c | 142 +++++++++++++++++++++--------------------- 1 file changed, 70 insertions(+), 72 deletions(-) diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 6d0e3ec00..12e0cc7db 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -38,6 +38,7 @@ + /* Unimplemented features. */ @@ -51,7 +52,9 @@ transcoders_not_implemented (void) PACKAGE_NAME); } + + /* End-of-file object. */ SCM_DEFINE (scm_eof_object, "eof-object", 0, 0, 0, @@ -63,7 +66,9 @@ SCM_DEFINE (scm_eof_object, "eof-object", 0, 0, 0, } #undef FUNC_NAME + + /* Input ports. */ #ifndef MIN @@ -186,33 +191,35 @@ SCM_DEFINE (scm_open_bytevector_input_port, } #undef FUNC_NAME + + /* Custom binary ports. The following routines are shared by input and output custom binary ports. */ -#define SCM_CUSTOM_BINARY_PORT_GET_POSITION_PROC(_port) \ - SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1) -#define SCM_CUSTOM_BINARY_PORT_SET_POSITION_PROC(_port) \ - SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2) -#define SCM_CUSTOM_BINARY_PORT_CLOSE_PROC(_port) \ - SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3) +struct custom_binary_port { + SCM read_buffer; + SCM read; + SCM write; + SCM get_position; + SCM set_position_x; + SCM close; +}; static scm_t_off custom_binary_port_seek (SCM port, scm_t_off offset, int whence) #define FUNC_NAME "custom_binary_port_seek" { SCM result; + struct custom_binary_port *stream = (void *) SCM_STREAM (port); scm_t_off c_result = 0; switch (whence) { case SEEK_CUR: { - SCM get_position_proc; - - get_position_proc = SCM_CUSTOM_BINARY_PORT_GET_POSITION_PROC (port); - if (SCM_LIKELY (scm_is_true (get_position_proc))) - result = scm_call_0 (get_position_proc); + if (SCM_LIKELY (scm_is_true (stream->get_position))) + result = scm_call_0 (stream->get_position); else scm_wrong_type_arg_msg (FUNC_NAME, 0, port, "R6RS custom binary port with " @@ -228,11 +235,8 @@ custom_binary_port_seek (SCM port, scm_t_off offset, int whence) case SEEK_SET: { - SCM set_position_proc; - - set_position_proc = SCM_CUSTOM_BINARY_PORT_SET_POSITION_PROC (port); - if (SCM_LIKELY (scm_is_true (set_position_proc))) - result = scm_call_1 (set_position_proc, scm_from_int (offset)); + if (SCM_LIKELY (scm_is_true (stream->set_position_x))) + result = scm_call_1 (stream->set_position_x, scm_from_int (offset)); else scm_wrong_type_arg_msg (FUNC_NAME, 0, port, "seekable R6RS custom binary port"); @@ -256,36 +260,25 @@ custom_binary_port_seek (SCM port, scm_t_off offset, int whence) static int custom_binary_port_close (SCM port) { - SCM close_proc; + struct custom_binary_port *stream = (void *) SCM_STREAM (port); - close_proc = SCM_CUSTOM_BINARY_PORT_CLOSE_PROC (port); - if (scm_is_true (close_proc)) + if (scm_is_true (stream->close)) /* Invoke the `close' thunk. */ - scm_call_0 (close_proc); + scm_call_0 (stream->close); return 1; } + -/* Custom binary input port. */ + +/* Custom binary input ports. */ static scm_t_bits custom_binary_input_port_type = 0; /* Initial size of the buffer embedded in custom binary input ports. */ #define CUSTOM_BINARY_INPUT_PORT_BUFFER_SIZE 8192 -/* Return the bytevector associated with PORT. */ -#define SCM_CUSTOM_BINARY_INPUT_PORT_BYTEVECTOR(_port) \ - SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4) - -/* Set BV as the bytevector associated with PORT. */ -#define SCM_SET_CUSTOM_BINARY_INPUT_PORT_BYTEVECTOR(_port, _bv) \ - SCM_SIMPLE_VECTOR_SET (SCM_PACK (SCM_STREAM (_port)), 4, (_bv)) - -/* Return the various procedures of PORT. */ -#define SCM_CUSTOM_BINARY_INPUT_PORT_READ_PROC(_port) \ - SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0) - /* Set PORT's internal buffer according to READ_SIZE. */ static void @@ -293,9 +286,10 @@ custom_binary_input_port_setvbuf (SCM port, long read_size, long write_size) { SCM bv; scm_t_port *pt; + struct custom_binary_port *stream = (void *) SCM_STREAM (port); pt = SCM_PTAB_ENTRY (port); - bv = SCM_CUSTOM_BINARY_INPUT_PORT_BYTEVECTOR (port); + bv = stream->read_buffer; switch (read_size) { @@ -317,7 +311,7 @@ custom_binary_input_port_setvbuf (SCM port, long read_size, long write_size) default: /* Fully buffered: allocate a buffer of READ_SIZE bytes. */ bv = scm_c_make_bytevector (read_size); - SCM_SET_CUSTOM_BINARY_INPUT_PORT_BYTEVECTOR (port, bv); + stream->read_buffer = bv; pt->read_buf = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); pt->read_buf_size = read_size; } @@ -329,10 +323,11 @@ static inline SCM make_custom_binary_input_port (SCM read_proc, SCM get_position_proc, SCM set_position_proc, SCM close_proc) { - SCM port, bv, method_vector; + SCM port, bv; char *c_bv; unsigned c_len; scm_t_port *c_port; + struct custom_binary_port *stream; const unsigned long mode_bits = SCM_OPN | SCM_RDNG; /* Use a bytevector as the underlying buffer. */ @@ -340,19 +335,19 @@ make_custom_binary_input_port (SCM read_proc, SCM get_position_proc, bv = scm_c_make_bytevector (c_len); c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); - /* Store the various methods and bytevector in a vector. */ - method_vector = scm_c_make_vector (5, SCM_BOOL_F); - SCM_SIMPLE_VECTOR_SET (method_vector, 4, bv); - SCM_SIMPLE_VECTOR_SET (method_vector, 0, read_proc); - SCM_SIMPLE_VECTOR_SET (method_vector, 1, get_position_proc); - SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc); - SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc); + stream = scm_gc_typed_calloc (struct custom_binary_port); + stream->read_buffer = bv; + stream->read = read_proc; + stream->write = SCM_BOOL_F; + stream->get_position = get_position_proc; + stream->set_position_x = set_position_proc; + stream->close = close_proc; port = scm_c_make_port_with_encoding (custom_binary_input_port_type, mode_bits, NULL, /* encoding */ SCM_FAILED_CONVERSION_ERROR, - SCM_UNPACK (method_vector)); + (scm_t_bits) stream); c_port = SCM_PTAB_ENTRY (port); @@ -370,18 +365,18 @@ custom_binary_input_port_fill_input (SCM port) { int result; scm_t_port *c_port = SCM_PTAB_ENTRY (port); + struct custom_binary_port *stream = (void *) SCM_STREAM (port); if (c_port->read_pos >= c_port->read_end) { /* Invoke the user's `read!' procedure. */ int buffered; size_t c_octets, c_requested; - SCM bv, read_proc, octets; + SCM bv, octets; c_requested = c_port->read_buf_size; - read_proc = SCM_CUSTOM_BINARY_INPUT_PORT_READ_PROC (port); - bv = SCM_CUSTOM_BINARY_INPUT_PORT_BYTEVECTOR (port); + bv = stream->read_buffer; buffered = (c_port->read_buf == (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv)); @@ -401,16 +396,13 @@ custom_binary_input_port_fill_input (SCM port) are passed the caller-provided buffer, so we need to check its size. */ if (SCM_BYTEVECTOR_LENGTH (bv) < c_requested) - { - /* Bad luck: we have to make another allocation. Save that - bytevector for later reuse, in the hope that the application - has regular access patterns. */ - bv = scm_c_make_bytevector (c_requested); - SCM_SET_CUSTOM_BINARY_INPUT_PORT_BYTEVECTOR (port, bv); - } + /* Bad luck: we have to make another allocation. Save that + nbytevector for later reuse, in the hope that the application + has regular access patterns. */ + stream->read_buffer = bv = scm_c_make_bytevector (c_requested); } - octets = scm_call_3 (read_proc, bv, SCM_INUM0, + octets = scm_call_3 (stream->read, bv, SCM_INUM0, scm_from_size_t (c_requested)); c_octets = scm_to_size_t (octets); if (SCM_UNLIKELY (c_octets > c_requested)) @@ -479,6 +471,7 @@ initialize_custom_binary_input_ports (void) + /* Binary input. */ /* We currently don't support specific binary input ports. */ @@ -603,7 +596,6 @@ SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0, } #undef FUNC_NAME - SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0, (SCM port), "Read from @var{port}, blocking as necessary, until bytes " @@ -706,6 +698,7 @@ SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0, + /* Binary output. */ /* We currently don't support specific binary input ports. */ @@ -816,6 +809,7 @@ SCM_DEFINE (scm_unget_bytevector, "unget-bytevector", 2, 2, 0, + /* Bytevector output port. */ /* Implementation of "bytevector output ports". @@ -1022,36 +1016,38 @@ initialize_bytevector_output_ports (void) scm_set_port_seek (bytevector_output_port_type, bytevector_output_port_seek); } + -/* Custom binary output port. */ + +/* Custom binary output ports. */ static scm_t_bits custom_binary_output_port_type; -/* Return the various procedures of PORT. */ -#define SCM_CUSTOM_BINARY_OUTPUT_PORT_WRITE_PROC(_port) \ - SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0) - static inline SCM make_custom_binary_output_port (SCM write_proc, SCM get_position_proc, SCM set_position_proc, SCM close_proc) { - SCM port, method_vector; + SCM port; scm_t_port *c_port; + struct custom_binary_port *stream; const unsigned long mode_bits = SCM_OPN | SCM_WRTNG; /* Store the various methods and bytevector in a vector. */ - method_vector = scm_c_make_vector (4, SCM_BOOL_F); - SCM_SIMPLE_VECTOR_SET (method_vector, 0, write_proc); - SCM_SIMPLE_VECTOR_SET (method_vector, 1, get_position_proc); - SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc); - SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc); + stream = scm_gc_typed_calloc (struct custom_binary_port); + + stream->read_buffer = SCM_BOOL_F; + stream->read = SCM_BOOL_F; + stream->write = write_proc; + stream->get_position = get_position_proc; + stream->set_position_x = set_position_proc; + stream->close = close_proc; port = scm_c_make_port_with_encoding (custom_binary_output_port_type, mode_bits, NULL, /* encoding */ SCM_FAILED_CONVERSION_ERROR, - SCM_UNPACK (method_vector)); + (scm_t_bits) stream); c_port = SCM_PTAB_ENTRY (port); @@ -1069,7 +1065,8 @@ custom_binary_output_port_write (SCM port, const void *data, size_t size) { long int c_result; size_t c_written; - SCM bv, write_proc, result; + struct custom_binary_port *stream = (void *) SCM_STREAM (port); + SCM bv, result; /* XXX: Allocating a new bytevector at each `write' call is inefficient, but necessary since (1) we don't control the lifetime of the buffer @@ -1078,8 +1075,6 @@ custom_binary_output_port_write (SCM port, const void *data, size_t size) bv = scm_c_make_bytevector (size); memcpy (SCM_BYTEVECTOR_CONTENTS (bv), data, size); - write_proc = SCM_CUSTOM_BINARY_OUTPUT_PORT_WRITE_PROC (port); - /* Since the `write' procedure of Guile's ports has type `void', it must try hard to write exactly SIZE bytes, regardless of how many bytes the sink can handle. */ @@ -1087,7 +1082,7 @@ custom_binary_output_port_write (SCM port, const void *data, size_t size) c_written < size; c_written += c_result) { - result = scm_call_3 (write_proc, bv, + result = scm_call_3 (stream->write, bv, scm_from_size_t (c_written), scm_from_size_t (size - c_written)); @@ -1141,8 +1136,11 @@ initialize_custom_binary_output_ports (void) scm_set_port_close (custom_binary_output_port_type, custom_binary_port_close); } + + /* Transcoded ports. */ + static scm_t_bits transcoded_port_type = 0; #define TRANSCODED_PORT_INPUT_BUFFER_SIZE 4096 From 2caae477c55ed945555715150606a097d8b50f9b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 4 Apr 2016 11:03:52 +0200 Subject: [PATCH 192/865] Refactor to rw_random / rw_active port flags * libguile/fports.c (fport_flush, fport_end_input): Move rw_active handling to ports.c. * libguile/ioext.c (scm_redirect_port): Use scm_flush_unlocked instead of calling the flush function directly. * libguile/ports.c (scm_c_make_port_with_encoding): Ports default to "rw_random" mode when they have a seek function. (scm_c_read_unlocked, scm_i_unget_bytes_unlocked) (scm_slow_get_byte_or_eof_unlocked) (scm_slow_peek_byte_or_eof_unlocked): Flush write buffer and set rw_active always in the same way, and only if rw_random is true. (scm_end_input_unlocked, scm_flush_unlocked): Clear rw_active here unconditionally. (scm_c_write_unlocked): Flush read buffer and set rw_active always in the same way, but only if rw_random is true. (scm_c_write, scm_lfwrite): Whitespace fixes. (scm_lfwrite_substr): Don't flush read buffer; lower-level code will do this. (scm_truncate_file): Use scm_flush_unlocked instead of calling the flush function directly. * libguile/r6rs-ports.c (transcoded_port_flush): Don't muck with rw_active. * libguile/read.c (scm_i_scan_for_encoding): Flush write buffer if needed in same way as ports.c. * libguile/strports.c (st_end_input): Don't muck with rw_active. (scm_mkstrport): rw_random defaults to 1 now. --- libguile/fports.c | 2 -- libguile/ioext.c | 3 +- libguile/ports.c | 67 ++++++++++++++++++++++--------------------- libguile/r6rs-ports.c | 1 - libguile/read.c | 9 +++--- libguile/strports.c | 2 -- 6 files changed, 40 insertions(+), 44 deletions(-) diff --git a/libguile/fports.c b/libguile/fports.c index 3f4c8cc2e..2b415b9a8 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -801,7 +801,6 @@ fport_flush (SCM port) scm_syserror ("scm_flush"); pt->write_pos = pt->write_buf; - pt->rw_active = SCM_PORT_NEITHER; } /* clear the read buffer and adjust the file position for unread bytes. */ @@ -821,7 +820,6 @@ fport_end_input (SCM port, int offset) if (lseek (fp->fdes, -offset, SEEK_CUR) == -1) scm_syserror ("fport_end_input"); } - pt->rw_active = SCM_PORT_NEITHER; } static void diff --git a/libguile/ioext.c b/libguile/ioext.c index 659eabcf5..25ce01471 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -88,11 +88,10 @@ SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0, { scm_t_port *pt = SCM_PTAB_ENTRY (new); scm_t_port *old_pt = SCM_PTAB_ENTRY (old); - scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (new); /* must flush to old fdes. */ if (pt->rw_active == SCM_PORT_WRITE) - ptob->flush (new); + scm_flush_unlocked (new); else if (pt->rw_active == SCM_PORT_READ) scm_end_input_unlocked (new); ans = dup2 (oldfd, newfd); diff --git a/libguile/ports.c b/libguile/ports.c index 2c509eac0..ee3355b1a 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -680,6 +680,9 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits, entry->internal = pti; entry->file_name = SCM_BOOL_F; + /* By default, any port type with a seek function has random-access + ports. */ + entry->rw_random = ptob->seek != NULL; entry->rw_active = SCM_PORT_NEITHER; entry->port = ret; entry->stream = stream; @@ -1455,11 +1458,13 @@ scm_c_read_unlocked (SCM port, void *buffer, size_t size) pt = SCM_PTAB_ENTRY (port); pti = SCM_PORT_GET_INTERNAL (port); - if (pt->rw_active == SCM_PORT_WRITE) - SCM_PORT_DESCRIPTOR (port)->flush (port); if (pt->rw_random) - pt->rw_active = SCM_PORT_READ; + { + if (pt->rw_active == SCM_PORT_WRITE) + scm_flush_unlocked (port); + pt->rw_active = SCM_PORT_READ; + } /* Take bytes first from the port's read buffer. */ if (pt->read_pos < pt->read_end) @@ -1984,6 +1989,13 @@ scm_i_unget_bytes_unlocked (const unsigned char *buf, size_t len, SCM port) scm_t_port *pt = SCM_PTAB_ENTRY (port); size_t old_len, new_len; + if (pt->rw_random) + { + if (pt->rw_active == SCM_PORT_WRITE) + scm_flush (port); + pt->rw_active = SCM_PORT_READ; + } + scm_i_clear_pending_eof (port); if (pt->read_buf != pt->putback_buf) @@ -2053,12 +2065,6 @@ scm_i_unget_bytes_unlocked (const unsigned char *buf, size_t len, SCM port) /* Move read_pos back and copy the bytes there. */ pt->read_pos -= len; memcpy (pt->read_buf + (pt->read_pos - pt->read_buf), buf, len); - - if (pt->rw_active == SCM_PORT_WRITE) - scm_flush (port); - - if (pt->rw_random) - pt->rw_active = SCM_PORT_READ; } #undef FUNC_NAME @@ -2460,11 +2466,12 @@ scm_slow_get_byte_or_eof_unlocked (SCM port) { scm_t_port *pt = SCM_PTAB_ENTRY (port); - if (pt->rw_active == SCM_PORT_WRITE) - scm_flush_unlocked (port); - if (pt->rw_random) - pt->rw_active = SCM_PORT_READ; + { + if (pt->rw_active == SCM_PORT_WRITE) + scm_flush_unlocked (port); + pt->rw_active = SCM_PORT_READ; + } if (pt->read_pos >= pt->read_end) { @@ -2481,11 +2488,12 @@ scm_slow_peek_byte_or_eof_unlocked (SCM port) { scm_t_port *pt = SCM_PTAB_ENTRY (port); - if (pt->rw_active == SCM_PORT_WRITE) - scm_flush_unlocked (port); - if (pt->rw_random) - pt->rw_active = SCM_PORT_READ; + { + if (pt->rw_active == SCM_PORT_WRITE) + scm_flush_unlocked (port); + pt->rw_active = SCM_PORT_READ; + } if (pt->read_pos >= pt->read_end) { @@ -2594,6 +2602,7 @@ scm_end_input_unlocked (SCM port) offset = 0; SCM_PORT_DESCRIPTOR (port)->end_input (port, offset); + pt->rw_active = SCM_PORT_NEITHER; } void @@ -2633,6 +2642,7 @@ void scm_flush_unlocked (SCM port) { SCM_PORT_DESCRIPTOR (port)->flush (port); + SCM_PTAB_ENTRY (port)->rw_active = SCM_PORT_NEITHER; } void @@ -2700,13 +2710,14 @@ scm_c_write_unlocked (SCM port, const void *ptr, size_t size) pt = SCM_PTAB_ENTRY (port); ptob = SCM_PORT_DESCRIPTOR (port); - if (pt->rw_active == SCM_PORT_READ) - scm_end_input_unlocked (port); + if (pt->rw_random) + { + if (pt->rw_active == SCM_PORT_READ) + scm_end_input_unlocked (port); + pt->rw_active = SCM_PORT_WRITE; + } ptob->write (port, ptr, size); - - if (pt->rw_random) - pt->rw_active = SCM_PORT_WRITE; } #undef FUNC_NAME @@ -2718,7 +2729,6 @@ scm_c_write (SCM port, const void *ptr, size_t size) scm_c_write_unlocked (port, ptr, size); if (lock) scm_i_pthread_mutex_unlock (lock); - } /* scm_lfwrite @@ -2749,25 +2759,16 @@ scm_lfwrite (const char *ptr, size_t size, SCM port) scm_lfwrite_unlocked (ptr, size, port); if (lock) scm_i_pthread_mutex_unlock (lock); - } /* Write STR to PORT from START inclusive to END exclusive. */ void scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port) { - scm_t_port *pt = SCM_PTAB_ENTRY (port); - - if (pt->rw_active == SCM_PORT_READ) - scm_end_input_unlocked (port); - if (end == (size_t) -1) end = scm_i_string_length (str); scm_i_display_substring (str, start, end, port); - - if (pt->rw_random) - pt->rw_active = SCM_PORT_WRITE; } @@ -2972,7 +2973,7 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, if (pt->rw_active == SCM_PORT_READ) scm_end_input_unlocked (object); else if (pt->rw_active == SCM_PORT_WRITE) - ptob->flush (object); + scm_flush_unlocked (object); ptob->truncate (object, c_length); rv = 0; diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 12e0cc7db..5a752bbc5 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -1233,7 +1233,6 @@ transcoded_port_flush (SCM port) scm_c_write_unlocked (binary_port, c_port->write_buf, count); c_port->write_pos = c_port->write_buf; - c_port->rw_active = SCM_PORT_NEITHER; if (SCM_OPOUTPORTP (binary_port)) scm_force_output (binary_port); diff --git a/libguile/read.c b/libguile/read.c index ecf27ff6e..346bcc969 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -2065,11 +2065,12 @@ scm_i_scan_for_encoding (SCM port) pt = SCM_PTAB_ENTRY (port); - if (pt->rw_active == SCM_PORT_WRITE) - scm_flush_unlocked (port); - if (pt->rw_random) - pt->rw_active = SCM_PORT_READ; + { + if (pt->rw_active == SCM_PORT_WRITE) + scm_flush_unlocked (port); + pt->rw_active = SCM_PORT_READ; + } if (pt->read_pos == pt->read_end) { diff --git a/libguile/strports.c b/libguile/strports.c index a6a03b4eb..6c65ec86c 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -154,7 +154,6 @@ st_end_input (SCM port, int offset) scm_misc_error ("st_end_input", "negative position", SCM_EOL); pt->write_pos = (unsigned char *) (pt->read_pos = pt->read_pos - offset); - pt->rw_active = SCM_PORT_NEITHER; } static scm_t_off @@ -304,7 +303,6 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) pt->read_buf_size = read_buf_size; pt->write_buf_size = num_bytes; pt->write_end = pt->read_end = pt->read_buf + pt->read_buf_size; - pt->rw_random = 1; return z; } From b7e49a75a9f0c4f992c212e9f61de164dbaa66ec Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 4 Apr 2016 11:14:41 +0200 Subject: [PATCH 193/865] Whitespace fixes * libguile/ports.c: Fix whitespaces introduced when adding the port lock. --- libguile/ports.c | 9 --------- 1 file changed, 9 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index ee3355b1a..e51ac5e65 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1563,7 +1563,6 @@ scm_c_read (SCM port, void *buffer, size_t size) ret = scm_c_read_unlocked (port, buffer, size); if (lock) scm_i_pthread_mutex_unlock (lock); - return ret; } @@ -1948,7 +1947,6 @@ scm_getc (SCM port) ret = scm_getc_unlocked (port); if (lock) scm_i_pthread_mutex_unlock (lock); - return ret; } @@ -2162,7 +2160,6 @@ scm_ungetc (scm_t_wchar c, SCM port) scm_ungetc_unlocked (c, port); if (lock) scm_i_pthread_mutex_unlock (lock); - } void @@ -2186,7 +2183,6 @@ scm_ungets (const char *s, int n, SCM port) scm_ungets_unlocked (s, n, port); if (lock) scm_i_pthread_mutex_unlock (lock); - } SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0, @@ -2455,7 +2451,6 @@ scm_fill_input (SCM port) ret = scm_fill_input_unlocked (port); if (lock) scm_i_pthread_mutex_unlock (lock); - return ret; } @@ -2613,7 +2608,6 @@ scm_end_input (SCM port) scm_end_input_unlocked (port); if (lock) scm_i_pthread_mutex_unlock (lock); - } SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0, @@ -2653,7 +2647,6 @@ scm_flush (SCM port) scm_flush_unlocked (port); if (lock) scm_i_pthread_mutex_unlock (lock); - } int @@ -2675,7 +2668,6 @@ scm_putc (char c, SCM port) scm_putc_unlocked (c, port); if (lock) scm_i_pthread_mutex_unlock (lock); - } void @@ -2686,7 +2678,6 @@ scm_puts (const char *s, SCM port) scm_puts_unlocked (s, port); if (lock) scm_i_pthread_mutex_unlock (lock); - } /* scm_c_write From b77fb752dd7e14876741ecb6360ef0319eae18e0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 4 Apr 2016 11:28:28 +0200 Subject: [PATCH 194/865] Flush buffered reads / writes before seeking * libguile/ports.c (scm_seek): Flush before seeking on a buffered port. * libguile/fports.c (fport_seek): * libguile/strports.c (st_seek): Remove code to flush buffers. * test-suite/tests/ports.test: Update test expectations that the putback buffer is flushed on a seek. Previously there was a special case for SEEK_CUR with an offset of 0 to avoid flushing buffers, but that's an arbitrary choice that differs from all other combinations of OFFSET and WHENCE. --- libguile/fports.c | 42 +----------------- libguile/ports.c | 16 +++++-- libguile/strports.c | 86 ++++++++++++++----------------------- test-suite/tests/ports.test | 8 ++-- 4 files changed, 52 insertions(+), 100 deletions(-) diff --git a/libguile/fports.c b/libguile/fports.c index 2b415b9a8..e33bfe58c 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -670,50 +670,12 @@ fport_fill_input (SCM port) static scm_t_off fport_seek (SCM port, scm_t_off offset, int whence) { - scm_t_port *pt = SCM_PTAB_ENTRY (port); scm_t_fport *fp = SCM_FSTREAM (port); - off_t_or_off64_t rv; off_t_or_off64_t result; - if (pt->rw_active == SCM_PORT_WRITE) - { - if (offset != 0 || whence != SEEK_CUR) - { - fport_flush (port); - result = rv = lseek_or_lseek64 (fp->fdes, offset, whence); - } - else - { - /* read current position without disturbing the buffer. */ - rv = lseek_or_lseek64 (fp->fdes, offset, whence); - result = rv + (pt->write_pos - pt->write_buf); - } - } - else if (pt->rw_active == SCM_PORT_READ) - { - if (offset != 0 || whence != SEEK_CUR) - { - /* could expand to avoid a second seek. */ - scm_end_input_unlocked (port); - result = rv = lseek_or_lseek64 (fp->fdes, offset, whence); - } - else - { - /* read current position without disturbing the buffer - (particularly the unread-char buffer). */ - rv = lseek_or_lseek64 (fp->fdes, offset, whence); - result = rv - (pt->read_end - pt->read_pos); + result = lseek_or_lseek64 (fp->fdes, offset, whence); - if (pt->read_buf == pt->putback_buf) - result -= pt->saved_read_end - pt->saved_read_pos; - } - } - else /* SCM_PORT_NEITHER */ - { - result = rv = lseek_or_lseek64 (fp->fdes, offset, whence); - } - - if (rv == -1) + if (result == -1) scm_syserror ("fport_seek"); return result; diff --git a/libguile/ports.c b/libguile/ports.c index e51ac5e65..202f7f998 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -2851,16 +2851,26 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, if (SCM_OPPORTP (fd_port)) { + scm_t_port *pt = SCM_PTAB_ENTRY (fd_port); scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (fd_port); scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (fd_port); off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset); off_t_or_off64_t rv; - if (!ptob->seek) + if (!ptob->seek || !pt->rw_random) SCM_MISC_ERROR ("port is not seekable", scm_cons (fd_port, SCM_EOL)); - else - rv = ptob->seek (fd_port, off, how); + + /* FIXME: Avoid flushing buffers for SEEK_CUR with an offset of + 0. */ + + if (pt->rw_active == SCM_PORT_READ) + scm_end_input_unlocked (pt->port); + else if (pt->rw_active == SCM_PORT_WRITE) + scm_flush_unlocked (pt->port); + pt->rw_active = SCM_PORT_NEITHER; + + rv = ptob->seek (fd_port, off, how); /* Set stream-start flags according to new position. */ pti->at_stream_start_for_bom_read = (rv == 0); diff --git a/libguile/strports.c b/libguile/strports.c index 6c65ec86c..064e2f04a 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -162,64 +162,44 @@ st_seek (SCM port, scm_t_off offset, int whence) scm_t_port *pt = SCM_PTAB_ENTRY (port); scm_t_off target; - if (pt->rw_active == SCM_PORT_READ && offset == 0 && whence == SEEK_CUR) - /* special case to avoid disturbing the unread-char buffer. */ + switch (whence) { - if (pt->read_buf == pt->putback_buf) - { - target = pt->saved_read_pos - pt->saved_read_buf - - (pt->read_end - pt->read_pos); - } - else - { - target = pt->read_pos - pt->read_buf; - } + case SEEK_CUR: + target = pt->read_pos - pt->read_buf + offset; + break; + case SEEK_END: + target = pt->read_end - pt->read_buf + offset; + break; + default: /* SEEK_SET */ + target = offset; + break; } - else - /* all other cases. */ - { - if (pt->rw_active == SCM_PORT_READ) - scm_end_input_unlocked (port); - pt->rw_active = SCM_PORT_NEITHER; - - switch (whence) - { - case SEEK_CUR: - target = pt->read_pos - pt->read_buf + offset; - break; - case SEEK_END: - target = pt->read_end - pt->read_buf + offset; - break; - default: /* SEEK_SET */ - target = offset; - break; - } - - if (target < 0) - scm_misc_error ("st_seek", "negative offset", SCM_EOL); + if (target < 0) + scm_misc_error ("st_seek", "negative offset", SCM_EOL); - if (target >= pt->write_buf_size) - { - if (!(SCM_CELL_WORD_0 (port) & SCM_WRTNG)) - { - if (target > pt->write_buf_size) - { - scm_misc_error ("st_seek", - "seek past end of read-only strport", - SCM_EOL); - } - } - else if (target == pt->write_buf_size) - st_resize_port (pt, target * 2); - } - pt->read_pos = pt->write_pos = pt->read_buf + target; - if (pt->read_pos > pt->read_end) - { - pt->read_end = (unsigned char *) pt->read_pos; - pt->read_buf_size = pt->read_end - pt->read_buf; - } + if (target >= pt->write_buf_size) + { + if (!(SCM_CELL_WORD_0 (port) & SCM_WRTNG)) + { + if (target > pt->write_buf_size) + { + scm_misc_error ("st_seek", + "seek past end of read-only strport", + SCM_EOL); + } + } + else if (target == pt->write_buf_size) + st_resize_port (pt, target * 2); } + + pt->read_pos = pt->write_pos = pt->read_buf + target; + if (pt->read_pos > pt->read_end) + { + pt->read_end = (unsigned char *) pt->read_pos; + pt->read_buf_size = pt->read_end - pt->read_buf; + } + return target; } diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index 2bc719e90..33050fd7f 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -176,8 +176,8 @@ (unread-char #\z iport) (pass-if "file: in tell 0 after unread" (= (seek iport 0 SEEK_CUR) 0)) - (pass-if "file: unread char still there" - (char=? (read-char iport) #\z)) + (pass-if "file: putback buffer flushed after seek" + (char=? (read-char iport) #\J)) (seek iport 7 SEEK_SET) (pass-if "file: in last char" (char=? (read-char iport) #\x)) @@ -700,8 +700,8 @@ (unread-char #\x p) (pass-if "input tell back to 0" (= (seek p 0 SEEK_CUR) 0)) - (pass-if "input ungetted char" - (char=? (read-char p) #\x)) + (pass-if "putback buffer discarded after seek" + (char=? (read-char p) #\t)) (seek p 0 SEEK_END) (pass-if "input seek to end" (= (seek p 0 SEEK_CUR) From 4bd903892535b1b1ddb7a7b09895e85e96736745 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 4 Apr 2016 12:22:12 +0200 Subject: [PATCH 195/865] Fix POLLOUT assignment from port buffers * libguile/poll.c (scm_primitive_poll): A buffered port's buffer marks it as writable only when writing a byte would not block, which is the case only if there is more than one byte free in the buffer; writing the last byte would block. --- libguile/poll.c | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/libguile/poll.c b/libguile/poll.c index 9ea846b6d..90a5c05e1 100644 --- a/libguile/poll.c +++ b/libguile/poll.c @@ -111,8 +111,10 @@ scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout) if (pt->read_pos < pt->read_end) /* Buffered input waiting to be read. */ revents |= POLLIN; - if (pt->write_pos < pt->write_end) - /* Buffered output possible. */ + if (SCM_OUTPUT_PORT_P (port) + && pt->write_end - pt->write_pos > 1) + /* Buffered output possible. The "> 1" is because + writing the last byte would flush the port. */ revents |= POLLOUT; } } @@ -147,8 +149,10 @@ scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout) if (pt->read_pos < pt->read_end) /* Buffered input waiting to be read. */ revents |= POLLIN; - if (SCM_OUTPUT_PORT_P (port) && pt->write_pos < pt->write_end) - /* Buffered output possible. */ + if (SCM_OUTPUT_PORT_P (port) + && pt->write_end - pt->write_pos > 1) + /* Buffered output possible. The "> 1" is because + writing the last byte would flush the port. */ revents |= POLLOUT; } } From b51c34e8722783036c503fb1fc35d292bff8be63 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 4 Apr 2016 22:43:45 +0200 Subject: [PATCH 196/865] Cosmetic changes to vports.c * libguile/vports.c (soft_port_flush): Rename from sf_flush, and similar changes following. --- libguile/vports.c | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/libguile/vports.c b/libguile/vports.c index c08df2ed0..03697f09d 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -49,11 +49,11 @@ */ -static scm_t_bits scm_tc16_sfport; +static scm_t_bits scm_tc16_soft_port; static void -sf_flush (SCM port) +soft_port_flush (SCM port) { scm_t_port *pt = SCM_PTAB_ENTRY (port); SCM stream = SCM_PACK (pt->stream); @@ -62,11 +62,10 @@ sf_flush (SCM port) if (scm_is_true (f)) scm_call_0 (f); - } static void -sf_write (SCM port, const void *data, size_t size) +soft_port_write (SCM port, const void *data, size_t size) { SCM p = SCM_PACK (SCM_STREAM (port)); @@ -84,7 +83,7 @@ sf_write (SCM port, const void *data, size_t size) /* places a single char in the input buffer. */ static int -sf_fill_input (SCM port) +soft_port_fill_input (SCM port) { SCM p = SCM_PACK (SCM_STREAM (port)); SCM ans; @@ -94,7 +93,7 @@ sf_fill_input (SCM port) ans = scm_call_0 (SCM_SIMPLE_VECTOR_REF (p, 3)); /* get char. */ if (scm_is_false (ans) || SCM_EOF_OBJECT_P (ans)) return EOF; - SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "sf_fill_input"); + SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "soft_port_fill_input"); pti = SCM_PORT_GET_INTERNAL (port); c = SCM_CHAR (ans); @@ -124,7 +123,7 @@ sf_fill_input (SCM port) static int -sf_close (SCM port) +soft_port_close (SCM port) { SCM p = SCM_PACK (SCM_STREAM (port)); SCM f = SCM_SIMPLE_VECTOR_REF (p, 4); @@ -137,7 +136,7 @@ sf_close (SCM port) static int -sf_input_waiting (SCM port) +soft_port_input_waiting (SCM port) { SCM p = SCM_PACK (SCM_STREAM (port)); if (SCM_SIMPLE_VECTOR_LENGTH (p) >= 6) @@ -209,7 +208,7 @@ SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, SCM_ASSERT ((vlen == 5) || (vlen == 6), pv, 1, FUNC_NAME); SCM_VALIDATE_STRING (2, modes); - z = scm_c_make_port (scm_tc16_sfport, scm_i_mode_bits (modes), + z = scm_c_make_port (scm_tc16_soft_port, scm_i_mode_bits (modes), SCM_UNPACK (pv)); scm_port_non_buffer (SCM_PTAB_ENTRY (z)); @@ -221,12 +220,13 @@ SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, static scm_t_bits scm_make_sfptob () { - scm_t_bits tc = scm_make_port_type ("soft", sf_fill_input, sf_write); + scm_t_bits tc = scm_make_port_type ("soft", soft_port_fill_input, + soft_port_write); - scm_set_port_flush (tc, sf_flush); - scm_set_port_close (tc, sf_close); + scm_set_port_flush (tc, soft_port_flush); + scm_set_port_close (tc, soft_port_close); scm_set_port_needs_close_on_gc (tc, 1); - scm_set_port_input_waiting (tc, sf_input_waiting); + scm_set_port_input_waiting (tc, soft_port_input_waiting); return tc; } @@ -234,7 +234,7 @@ scm_make_sfptob () void scm_init_vports () { - scm_tc16_sfport = scm_make_sfptob (); + scm_tc16_soft_port = scm_make_sfptob (); #include "libguile/vports.x" } From c0d5f8b5551cb5857f170f8e1557096874e684c5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 5 Apr 2016 14:56:24 +0200 Subject: [PATCH 197/865] When making soft port, parse handlers into struct * libguile/vports.c (struct soft_port): New data structure. (scm_make_soft_port): Unpack vector into struct when making soft port. (soft_port_input_waiting, soft_port_close, soft_port_fill_input): (soft_port_write, soft_port_flush): Adapt. Remove an extraneous errno=0 in soft_port_close. --- libguile/vports.c | 59 +++++++++++++++++++++++++++-------------------- 1 file changed, 34 insertions(+), 25 deletions(-) diff --git a/libguile/vports.c b/libguile/vports.c index 03697f09d..b46f9f75d 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -51,29 +51,35 @@ static scm_t_bits scm_tc16_soft_port; +struct soft_port { + SCM write_char; + SCM write_string; + SCM flush; + SCM read_char; + SCM close; + SCM input_waiting; +}; + static void soft_port_flush (SCM port) { - scm_t_port *pt = SCM_PTAB_ENTRY (port); - SCM stream = SCM_PACK (pt->stream); + struct soft_port *stream = (void *) SCM_STREAM (port); - SCM f = SCM_SIMPLE_VECTOR_REF (stream, 2); - - if (scm_is_true (f)) - scm_call_0 (f); + if (scm_is_true (stream->flush)) + scm_call_0 (stream->flush); } static void soft_port_write (SCM port, const void *data, size_t size) { - SCM p = SCM_PACK (SCM_STREAM (port)); + struct soft_port *stream = (void *) SCM_STREAM (port); /* DATA is assumed to be a locale-encoded C string, which makes it hard to reliably pass binary data to a soft port. It can be achieved by choosing a Latin-1 locale, though, but the recommended approach is to use an R6RS "custom binary output port" instead. */ - scm_call_1 (SCM_SIMPLE_VECTOR_REF (p, 1), + scm_call_1 (stream->write_string, scm_from_locale_stringn ((char *) data, size)); } @@ -85,12 +91,12 @@ soft_port_write (SCM port, const void *data, size_t size) static int soft_port_fill_input (SCM port) { - SCM p = SCM_PACK (SCM_STREAM (port)); + struct soft_port *stream = (void *) SCM_STREAM (port); SCM ans; scm_t_wchar c; scm_t_port_internal *pti; - ans = scm_call_0 (SCM_SIMPLE_VECTOR_REF (p, 3)); /* get char. */ + ans = scm_call_0 (stream->read_char); if (scm_is_false (ans) || SCM_EOF_OBJECT_P (ans)) return EOF; SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "soft_port_fill_input"); @@ -125,26 +131,19 @@ soft_port_fill_input (SCM port) static int soft_port_close (SCM port) { - SCM p = SCM_PACK (SCM_STREAM (port)); - SCM f = SCM_SIMPLE_VECTOR_REF (p, 4); - if (scm_is_false (f)) + struct soft_port *stream = (void *) SCM_STREAM (port); + if (scm_is_false (stream->close)) return 0; - f = scm_call_0 (f); - errno = 0; - return scm_is_false (f) ? EOF : 0; + return scm_is_false (scm_call_0 (stream->close)) ? EOF : 0; } static int soft_port_input_waiting (SCM port) { - SCM p = SCM_PACK (SCM_STREAM (port)); - if (SCM_SIMPLE_VECTOR_LENGTH (p) >= 6) - { - SCM f = SCM_SIMPLE_VECTOR_REF (p, 5); - if (scm_is_true (f)) - return scm_to_int (scm_call_0 (f)); - } + struct soft_port *stream = (void *) SCM_STREAM (port); + if (scm_is_true (stream->input_waiting)) + return scm_to_int (scm_call_0 (stream->input_waiting)); /* Default is such that char-ready? for soft ports returns #t, as it did before this extension was implemented. */ return 1; @@ -202,14 +201,24 @@ SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, { int vlen; SCM z; + struct soft_port *stream; SCM_VALIDATE_VECTOR (1, pv); vlen = SCM_SIMPLE_VECTOR_LENGTH (pv); SCM_ASSERT ((vlen == 5) || (vlen == 6), pv, 1, FUNC_NAME); SCM_VALIDATE_STRING (2, modes); - + + stream = scm_gc_typed_calloc (struct soft_port); + stream->write_char = SCM_SIMPLE_VECTOR_REF (pv, 0); + stream->write_string = SCM_SIMPLE_VECTOR_REF (pv, 1); + stream->flush = SCM_SIMPLE_VECTOR_REF (pv, 2); + stream->read_char = SCM_SIMPLE_VECTOR_REF (pv, 3); + stream->close = SCM_SIMPLE_VECTOR_REF (pv, 4); + stream->input_waiting = + vlen == 6 ? SCM_SIMPLE_VECTOR_REF (pv, 5) : SCM_BOOL_F; + z = scm_c_make_port (scm_tc16_soft_port, scm_i_mode_bits (modes), - SCM_UNPACK (pv)); + (scm_t_bits) stream); scm_port_non_buffer (SCM_PTAB_ENTRY (z)); return z; From e8eeeeb1d4743fce89b28fa9360e71f6efd6a4e8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 5 Apr 2016 15:13:36 +0200 Subject: [PATCH 198/865] Port close functions return void * libguile/ports.h (scm_t_ptob_descriptor): The port close function now returns void. (scm_set_port_close): Adapt prototype. * libguile/ports.c (scm_close_port): Always return true if we managed to call the close function. There's no other sensible result; exceptions are handled, well, exceptionally. * libguile/fports.c (fport_close) * libguile/r6rs-ports.c (custom_binary_port_close, transcoded_port_close): * libguile/vports.c (soft_port_close): Adapt. * doc/ref/api-io.texi (Port Implementation): Update. --- doc/ref/api-io.texi | 2 +- libguile/fports.c | 8 ++------ libguile/ports.c | 8 +++----- libguile/ports.h | 4 ++-- libguile/r6rs-ports.c | 8 +++----- libguile/vports.c | 7 +++---- 6 files changed, 14 insertions(+), 23 deletions(-) diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 759d33940..4e4d59b66 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -2317,7 +2317,7 @@ argument @var{dest_port} is where its description should go. Called when the port is closed. It should free any resources used by the port. Set using -@deftypefun void scm_set_port_close (scm_t_bits tc, int (*close) (SCM port)) +@deftypefun void scm_set_port_close (scm_t_bits tc, void (*close) (SCM port)) @end deftypefun By default, ports that are garbage collected just go away without diff --git a/libguile/fports.c b/libguile/fports.c index e33bfe58c..963c1eafd 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -794,11 +794,10 @@ close_the_fd (void *data) errno = 0; } -static int +static void fport_close (SCM port) { scm_t_fport *fp = SCM_FSTREAM (port); - int rv; scm_dynwind_begin (0); scm_dynwind_unwind_handler (close_the_fd, fp, 0); @@ -807,15 +806,12 @@ fport_close (SCM port) scm_port_non_buffer (SCM_PTAB_ENTRY (port)); - rv = close (fp->fdes); - if (rv) + if (close (fp->fdes) != 0) /* It's not useful to retry after EINTR, as the file descriptor is in an undefined state. See http://lwn.net/Articles/365294/. Instead just throw an error if close fails, trusting that the fd was cleaned up. */ scm_syserror ("fport_close"); - - return 0; } static scm_t_bits diff --git a/libguile/ports.c b/libguile/ports.c index 202f7f998..b8d2616c1 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -275,7 +275,7 @@ scm_set_port_print (scm_t_bits tc, int (*print) (SCM exp, SCM port, } void -scm_set_port_close (scm_t_bits tc, int (*close) (SCM)) +scm_set_port_close (scm_t_bits tc, void (*close) (SCM)) { scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->close = close; } @@ -834,9 +834,7 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, if (SCM_PORT_DESCRIPTOR (port)->close) /* Note! This may throw an exception. Anything after this point should be resilient to non-local exits. */ - rv = SCM_PORT_DESCRIPTOR (port)->close (port); - else - rv = 0; + SCM_PORT_DESCRIPTOR (port)->close (port); if (pti->iconv_descriptors) { @@ -846,7 +844,7 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, pti->iconv_descriptors = NULL; } - return scm_from_bool (rv >= 0); + return SCM_BOOL_T; } #undef FUNC_NAME diff --git a/libguile/ports.h b/libguile/ports.h index 6b9a006b8..0196753ae 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -187,7 +187,7 @@ typedef struct scm_t_ptob_descriptor { char *name; int (*print) (SCM exp, SCM port, scm_print_state *pstate); - int (*close) (SCM port); + void (*close) (SCM port); void (*write) (SCM port, const void *data, size_t size); void (*flush) (SCM port); @@ -227,7 +227,7 @@ SCM_API void scm_set_port_print (scm_t_bits tc, int (*print) (SCM exp, SCM port, scm_print_state *pstate)); -SCM_API void scm_set_port_close (scm_t_bits tc, int (*close) (SCM)); +SCM_API void scm_set_port_close (scm_t_bits tc, void (*close) (SCM)); SCM_API void scm_set_port_needs_close_on_gc (scm_t_bits tc, int needs_close_p); SCM_API void scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port)); diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 5a752bbc5..9e12b5a52 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -257,7 +257,7 @@ custom_binary_port_seek (SCM port, scm_t_off offset, int whence) } #undef FUNC_NAME -static int +static void custom_binary_port_close (SCM port) { struct custom_binary_port *stream = (void *) SCM_STREAM (port); @@ -265,8 +265,6 @@ custom_binary_port_close (SCM port) if (scm_is_true (stream->close)) /* Invoke the `close' thunk. */ scm_call_0 (stream->close); - - return 1; } @@ -1238,13 +1236,13 @@ transcoded_port_flush (SCM port) scm_force_output (binary_port); } -static int +static void transcoded_port_close (SCM port) { SCM bport = SCM_TRANSCODED_PORT_BINARY_PORT (port); if (SCM_OUTPUT_PORT_P (port)) transcoded_port_flush (port); - return scm_is_true (scm_close_port (bport)) ? 0 : -1; + scm_close_port (bport); } static inline void diff --git a/libguile/vports.c b/libguile/vports.c index b46f9f75d..65041283d 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -128,13 +128,12 @@ soft_port_fill_input (SCM port) } -static int +static void soft_port_close (SCM port) { struct soft_port *stream = (void *) SCM_STREAM (port); - if (scm_is_false (stream->close)) - return 0; - return scm_is_false (scm_call_0 (stream->close)) ? EOF : 0; + if (scm_is_true (stream->close)) + scm_call_0 (stream->close); } From 8399e7af51df3956417e8776ac506e04f4c3bdce Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 6 Apr 2016 09:21:44 +0200 Subject: [PATCH 199/865] Generic port facility provides buffering uniformly * libguile/ports.h (struct scm_t_port_buffer): New data type. (struct scm_t_port): Refactor to use port buffers instead of implementation-managed read and write pointers. Add "read_buffering" member. (SCM_INITIAL_PUTBACK_BUF_SIZE, SCM_READ_BUFFER_EMPTY_P): Remove. (scm_t_ptob_descriptor): Rename "fill_input" function to "read", and take a port buffer, returning void. Likewise "write" takes a port buffer and returns void. Remove "end_input"; instead if there is buffered input and rw_random is true, then there must be a seek function, so just seek back if needed. Remove "flush"; instead all calls to the "write" function implicitly include a "flush", since the buffering happens in the generic port code now. Remove "setvbuf", but add "get_natural_buffer_sizes"; instead the generic port code can buffer any port. (scm_make_port_type): Adapt to read and write prototype changes. (scm_set_port_flush, scm_set_port_end_input, scm_set_port_setvbuf): Remove. (scm_slow_get_byte_or_eof_unlocked) (scm_slow_get_peek_or_eof_unlocked): Remove; the slow path is to call scm_fill_input. (scm_set_port_get_natural_buffer_sizes): New function. (scm_c_make_port_buffer): New internal function. (scm_port_non_buffer): Remove. This was a function for implementations that is no longer needed. Instead open with BUF0 or use (setvbuf port 'none). (scm_fill_input, scm_fill_input_unlocked): Return the filled port buffer. (scm_get_byte_or_eof_unlocked, scm_peek_byte_or_eof_unlocked): Adapt to changes in buffering and EOF management. * libguile/ports.c: Adapt to port interface changes. (initialize_port_buffers): New function, using the port mode flags to set up appropriate initial buffering for all ports. (scm_c_make_port_with_encoding): Create port buffers here instead of delegating to implementations. (scm_close_port): Flush the port if needed instead of delegating to the implementation. * libguile/filesys.c (set_element): Adapt to buffering changes. * libguile/fports.c (fport_get_natural_buffer_sizes): New function, replacing scm_fport_buffer_add. (fport_write, fport_read): Update to let the generic ports code do the buffering. (fport_flush, fport_end_input): Remove. (fport_close): Don't flush in a dynwind; that's the core ports' job. (scm_make_fptob): Adapt. * libguile/ioext.c (scm_redirect_port): Adapt to buffering changes. * libguile/poll.c (scm_primitive_poll): Adapt to buffering changes. * libguile/ports-internal.h (struct scm_port_internal): Remove pending_eof flag; this is now set on the read buffer. * libguile/r6rs-ports.c (struct bytevector_input_port): New type. The new buffering arrangement means that there's now an intermediate buffer between the bytevector and the user of the port; this could lead to a perf degradation, but on the other hand there are some other speedups enabled by the buffering refactor, so probably the memcpy cost is dwarfed by the cost of the other parts of the ports machinery. (make_bytevector_input_port, bytevector_input_port_read): (bytevector_input_port_seek, initialize_bytevector_input_ports): Adapt to new buffering arrangement. (struct custom_binary_port): Remove read buffer, as Guile handles that now. (custom_binary_input_port_setvbuf): Remove; now handled by Guile. (make_custom_binary_input_port, custom_binary_input_port_read) (initialize_custom_binary_input_ports): Adapt. (scm_get_bytevector_some): Adapt to new EOF management. (scm_t_bytevector_output_port_buffer): Hold on to the underlying port, so we can flush it if it's open. (make_bytevector_output_port, bytevector_output_port_write): (bytevector_output_port_seek): Adapt. (bytevector_output_port_procedure): Flush the port as appropriate, so that we get all the bytes. (make_custom_binary_output_port, custom_binary_output_port_write): Adapt. (make_transcoded_port): Don't muck with buffering. (transcoded_port_write): Simply forward the write to the underlying port. (transcoded_port_read): Likewise. (transcoded_port_close): No need to flush. (initialize_transcoded_ports): Adapt. * libguile/read.c (scm_i_scan_for_encoding): Adapt to buffering changes. * libguile/rw.c (scm_write_string_partial): Adapt to buffering changes. * libguile/strports.c: Adapt to the fact that we don't manage the buffer. Probably room for speed improvements here... * libguile/vports.c (soft_port_get_natural_buffer_sizes): New function. Adapt the rest of the file for the new buffering regime. * test-suite/tests/r6rs-ports.test ("8.2.10 Output ports"): Custom binary output ports need to be flushed before you can rely on the write! procedure having been called. Add necessary flush-port invocations. ("8.2.6 Input and output ports"): Transcoded ports now have an internal buffer by default. This test checks that the characters are transcoded one at a time, so to do that, call setvbuf on the transcoded port to remove the buffer. * test-suite/tests/web-client.test (run-with-http-transcript): Fix for different flushing regime on soft ports. (The vestigial flush procedure is now called after each write, which is not what the test was expecting.) * test-suite/standalone/test-scm-c-read.c: Update for changes to the C interface for defining port types. * doc/ref/api-io.texi (Ports): Update to discuss buffering in a generic way, and to remove a hand-wavey paragraph describing string ports as "interesting and powerful". (Reading, Writing): Remove placeholder comments. Document `scm_lfwrite'. (Buffering): New section. (File Ports): Link to buffering. (I/O Extensions): Join subnodes into parent and describe new API, including buffering API. * doc/ref/posix.texi (Ports and File Descriptors): Link to buffering. Remove unread-char etc, as they are documented elsewhere. (Pipes, Network Sockets and Communication): Link to buffering. --- doc/ref/api-io.texi | 420 +++++++------- doc/ref/posix.texi | 69 +-- libguile/filesys.c | 4 +- libguile/fports.c | 242 ++------ libguile/ioext.c | 22 +- libguile/poll.c | 8 +- libguile/ports-internal.h | 1 - libguile/ports.c | 720 ++++++++++-------------- libguile/ports.h | 208 +++---- libguile/r6rs-ports.c | 485 +++++----------- libguile/read.c | 12 +- libguile/rw.c | 19 +- libguile/strports.c | 275 +++------ libguile/vports.c | 103 ++-- test-suite/standalone/test-scm-c-read.c | 59 +- test-suite/tests/r6rs-ports.test | 3 + test-suite/tests/web-client.test | 12 +- 17 files changed, 1033 insertions(+), 1629 deletions(-) diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 4e4d59b66..b5e70cf7b 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -12,13 +12,14 @@ * Reading:: Procedures for reading from a port. * Writing:: Procedures for writing to a port. * Closing:: Procedures to close a port. +* Buffering:: Controlling when data is written to ports. * Random Access:: Moving around a random access port. * Line/Delimited:: Read and write lines or delimited text. * Block Reading and Writing:: Reading and writing blocks of text. * Default Ports:: Defaults for input, output and errors. * Port Types:: Types of port and how to make them. * R6RS I/O Ports:: The R6RS port API. -* I/O Extensions:: Using and extending ports in C. +* I/O Extensions:: Implementing new port types in C. * BOM Handling:: Handling of Unicode byte order marks. @end menu @@ -32,26 +33,21 @@ Sequential input/output in Scheme is represented by operations on a for working with ports. Ports are created by opening, for instance @code{open-file} for a file -(@pxref{File Ports}). Characters can be read from an input port and -written to an output port, or both on an input/output port. A port -can be closed (@pxref{Closing}) when no longer required, after which -any attempt to read or write is an error. - -The formal definition of a port is very generic: an input port is -simply ``an object which can deliver characters on demand,'' and an -output port is ``an object which can accept characters.'' Because -this definition is so loose, it is easy to write functions that -simulate ports in software. @dfn{Soft ports} and @dfn{string ports} -are two interesting and powerful examples of this technique. -(@pxref{Soft Ports}, and @ref{String Ports}.) +(@pxref{File Ports}). Other kinds of ports include @dfn{soft ports} and +@dfn{string ports} (@pxref{Soft Ports}, and @ref{String Ports}). +Characters or bytes can be read from an input port and written to an +output port, or both on an input/output port. A port can be closed +(@pxref{Closing}) when no longer required, after which any attempt to +read or write is an error. Ports are garbage collected in the usual way (@pxref{Memory -Management}), and will be closed at that time if not already closed. -In this case any errors occurring in the close will not be reported. -Usually a program will want to explicitly close so as to be sure all -its operations have been successful. Of course if a program has -abandoned something due to an error or other condition then closing -problems are probably not of interest. +Management}), and will be closed at that time if not already closed. In +this case any errors occurring in the close will not be reported. +Usually a program will want to explicitly close so as to be sure all its +operations have been successful, including any buffered writes +(@pxref{Buffering}). Of course if a program has abandoned something due +to an error or other condition then closing problems are probably not of +interest. It is strongly recommended that file ports be closed explicitly when no longer required. Most systems have limits on how many files can be @@ -71,10 +67,10 @@ available, so files bigger than 2 Gbytes (@math{2^31} bytes) can be read and written on a 32-bit system. Each port has an associated character encoding that controls how bytes -read from the port are converted to characters and string and controls -how characters and strings written to the port are converted to bytes. -When ports are created, they inherit their character encoding from the -current locale, but, that can be modified after the port is created. +read from the port are converted to characters and controls how +characters written to the port are converted to bytes. When ports are +created, they inherit their character encoding from the current locale, +but, that can be modified after the port is created. Currently, the ports only work with @emph{non-modal} encodings. Most encodings are non-modal, meaning that the conversion of bytes to a @@ -88,6 +84,15 @@ representation for output. There are three possible strategies: to raise an error, to replace the character with a hex escape, or to replace the character with a substitute character. +Finally, all ports have associated input and output buffers, as +appropriate. Buffering is a common strategy to limit the overhead of +small reads and writes: without buffering, each character fetched from a +file would involve at least one call into the kernel, and maybe more +depending on the character and the encoding. Instead, Guile will batch +reads and writes into internal buffers. However, sometimes you want to +make output on a port show up immediately. @xref{Buffering}, for more +on interfaces to control port buffering. + @rnindex input-port? @deffn {Scheme Procedure} input-port? x @deffnx {C Function} scm_input_port_p (x) @@ -188,8 +193,6 @@ equivalent to @code{(fluid-set! %default-port-conversion-strategy @subsection Reading @cindex Reading -[Generic procedures for reading from ports.] - These procedures pertain to reading characters and strings from ports. To read general S-expressions from ports, @xref{Scheme Read}. @@ -325,8 +328,6 @@ Set the current column or line number of @var{port}. @subsection Writing @cindex Writing -[Generic procedures for writing to ports.] - These procedures are for writing characters and strings to ports. For more information on writing arbitrary Scheme objects to ports, @xref{Scheme Write}. @@ -380,6 +381,14 @@ Note that this function does not update @code{port-line} and @code{port-column} (@pxref{Reading}). @end deftypefn +@deftypefn {C Function} void scm_lfwrite (const char *buffer, size_t size, SCM port) +Write @var{size} bytes at @var{buffer} to @var{port}. The @code{lf} +indicates that unlike @code{scm_c_write}, this function updates the +port's @code{port-line} and @code{port-column}, and also flushes the +port if the data contains a newline (@code{\n}) and the port is +line-buffered. +@end deftypefn + @findex fflush @deffn {Scheme Procedure} force-output [port] @deffnx {C Function} scm_force_output (port) @@ -435,6 +444,96 @@ open. @end deffn +@node Buffering +@subsection Buffering +@cindex Port, buffering + +Every port has associated input and output buffers. You can think of +ports as being backed by some mutable store, and that store might be far +away. For example, ports backed by file descriptors have to go all the +way to the kernel to read and write their data. To avoid this +round-trip cost, Guile usually reads in data from the mutable store in +chunks, and then services small requests like @code{get-char} out of +that intermediate buffer. Similarly, small writes like +@code{write-char} first go to a buffer, and are sent to the store when +the buffer is full (or when port is flushed). Buffered ports speed up +your program by reducing the number of round-trips to the mutable store, +and the do so in a way that is mostly transparent to the user. + +There are two major ways, however, in which buffering affects program +semantics. Building correct, performant programs requires understanding +these situations. + +The first case is in random-access read/write ports (@pxref{Random +Access}). These ports, usually backed by a file, logically operate over +the same mutable store when both reading and writing. So, if you read a +character, causing the buffer to fill, then write a character, the bytes +you filled in your read buffer are now invalid. Every time you switch +between reading and writing, Guile has to flush any pending buffer. If +this happens frequently, the cost can be high. In that case you should +reduce the amount that you buffer, in both directions. Similarly, Guile +has to flush buffers before seeking. None of these considerations apply +to sockets, which don't logically read from and write to the same +mutable store, and are not seekable. Note also that sockets are +unbuffered by default. @xref{Network Sockets and Communication}. + +The second case is the more pernicious one. If you write data to a +buffered port, it probably hasn't gone out to the mutable store yet. +(This ``probably'' introduces some indeterminism in your program: what +goes to the store, and when, depends on how full the buffer is. It is +something that the user needs to explicitly be aware of.) The data is +written to the store later -- when the buffer fills up due to another +write, or when @code{force-output} is called, or when @code{close-port} +is called, or when the program exits, or even when the garbage collector +runs. The salient point is, @emph{the errors are signalled then too}. +Buffered writes defer error detection (and defer the side effects to the +mutable store), perhaps indefinitely if the port type does not need to +be closed at GC. + +One common heuristic that works well for textual ports is to flush +output when a newline (@code{\n}) is written. This @dfn{line buffering} +mode is on by default for TTY ports. Most other ports are @dfn{block +buffered}, meaning that once the output buffer reaches the block size, +which depends on the port and its configuration, the output is flushed +as a block, without regard to what is in the block. Likewise reads are +read in at the block size, though if there are fewer bytes available to +read, the buffer may not be entirely filled. + +Note that reads or writes that are larger than the buffer size go +directly to the mutable store without passing through the buffers. If +your access pattern involves many big reads or writes, buffering might +not matter so much to you. + +To control the buffering behavior of a port, use @code{setvbuf}. + +@deffn {Scheme Procedure} setvbuf port mode [size] +@deffnx {C Function} scm_setvbuf (port, mode, size) +@cindex port buffering +Set the buffering mode for @var{port}. @var{mode} can be one of the +following symbols: + +@table @code +@item none +non-buffered +@item line +line buffered +@item block +block buffered, using a newly allocated buffer of @var{size} bytes. +If @var{size} is omitted, a default size will be used. +@end table +@end deffn + +Another way to set the buffering, for file ports, is to open the file +with @code{0} or @code{l} as part of the mode string, for unbuffered or +line-buffered ports, respectively. @xref{File Ports}, for more. + +All of these considerations are very similar to those of streams in the +C library, although Guile's ports are not built on top of C streams. +Still, it is useful to read what other systems do. +@xref{Streams,,,libc,The GNU C Library Reference Manual}, for more +discussion on C streams. + + @node Random Access @subsection Random Access @cindex Random access, ports @@ -882,8 +981,7 @@ Create an "unbuffered" port. In this case input and output operations are passed directly to the underlying port implementation without additional buffering. This is likely to slow down I/O operations. The buffering mode can be changed -while a port is in use @pxref{Ports and File Descriptors, -setvbuf} +while a port is in use (@pxref{Buffering}). @item l Add line-buffering to the port. The port output buffer will be automatically flushed whenever a newline character is written. @@ -1797,8 +1895,7 @@ Finally, if @var{close} is not @code{#f}, it must be a thunk. It is invoked when the custom binary input port is closed. The returned port is fully buffered by default, but its buffering mode -can be changed using @code{setvbuf} (@pxref{Ports and File Descriptors, -@code{setvbuf}}). +can be changed using @code{setvbuf} (@pxref{Buffering}). Using a custom binary input port, the @code{open-bytevector-input-port} procedure could be implemented as follows: @@ -2157,152 +2254,111 @@ the representation, will return an object equal (in the sense of @end deffn @node I/O Extensions -@subsection Using and Extending Ports in C +@subsection Implementing New Port Types in C -@menu -* C Port Interface:: Using ports from C. -* Port Implementation:: How to implement a new port type in C. -@end menu - - -@node C Port Interface -@subsubsection C Port Interface -@cindex C port interface -@cindex Port, C interface - -This section describes how to use Scheme ports from C. - -@subsubheading Port basics +This section describes how to implement a new port type in C. Before +getting to the details, here is a summary of how the generic port +interface works internally. @cindex ptob -@tindex scm_ptob_descriptor -@tindex scm_port +@tindex scm_t_ptob_descriptor +@tindex scm_t_port +@tindex scm_t_port_buffer @findex SCM_PTAB_ENTRY @findex SCM_PTOBNUM @vindex scm_ptobs -There are two main data structures. A port type object (ptob) is of -type @code{scm_ptob_descriptor}. A port instance is of type -@code{scm_port}. Given an @code{SCM} variable which points to a port, -the corresponding C port object can be obtained using the -@code{SCM_PTAB_ENTRY} macro. The ptob can be obtained by using -@code{SCM_PTOBNUM} to give an index into the @code{scm_ptobs} -global array. +Guile's port facility consists of three main data structures. A port +type object (ptob) is of type @code{scm_t_ptob_descriptor}, and holds +pointers to the methods that implement the port type. A port instance +is of type @code{scm_t_port}, and holds all state for the port. Finally +the read and write buffers are the @code{read_buf} and @code{write_buf} +members of the port instance, and are of type @code{scm_t_port_buffer}. + +Given an @code{SCM} variable which points to a port, the corresponding C +port object can be obtained using the @code{SCM_PTAB_ENTRY} macro. The +ptob can be obtained by using @code{SCM_PTOBNUM} to give an index into +the @code{scm_ptobs} global array. @subsubheading Port buffers An input port always has a read buffer and an output port always has a -write buffer. However the size of these buffers is not guaranteed to be -more than one byte (e.g., the @code{shortbuf} field in @code{scm_port} -which is used when no other buffer is allocated). The way in which the -buffers are allocated depends on the implementation of the ptob. For -example in the case of an fport, buffers may be allocated with malloc -when the port is created, but in the case of an strport the underlying -string is used as the buffer. +write buffer. @xref{Buffering}. These buffers are represented in C by +@code{scm_t_port_buffer} objects. + +The port buffer consists of data as a byte array, pointed to by its +@code{buf} field. The valid data in the buffer is between the +@code{cur} and @code{end} indices into @code{buf}; @code{cur} must +always be less than or equal to @code{end}, which in turn must be less +than or equal to the buffer size @code{size}. + +``Valid data'' for a read buffer is data that has been buffered, but not +yet read by the user. A port's @code{read} procedure fills a read +buffer from the @code{end} element. For a write buffer, the ``valid +data'' is data which has been written by the user, but not yet flushed +to the mutable store. A port's @code{write} procedure will consume the +data between @code{cur} and @code{end} (not including @code{end}) and +advance @code{cur}. + +The size of the buffers is controlled by the user, via @code{setvbuf}. +A port implementation can provide an idea of what the ``natural'' size +for its buffers are, but it has no guarantee that the buffer will be +those sizes. It's also possible for big reads or writes to work on +auxiliary buffers, and it's possible for @code{unget-bytevector} to +cause a read buffer to expand temporarily; port implementations can't +assume that the buffer they have been given to fill or empty corresponds +to the port's designated read or write buffer. + +Port read buffers also have a flag indicating that the last read did not +advance @code{end}, which indicates end-of-stream. It is cleared by +Guile when Guile gives the user an EOF object. @subsubheading The @code{rw_random} flag Special treatment is required for ports which can be seeked at random. Before various operations, such as seeking the port or changing from -input to output on a bidirectional port or vice versa, the port -implementation must be given a chance to update its state. The write -buffer is updated by calling the @code{flush} ptob procedure and the -input buffer is updated by calling the @code{end_input} ptob procedure. -In the case of an fport, @code{flush} causes buffered output to be -written to the file descriptor, while @code{end_input} causes the -descriptor position to be adjusted to account for buffered input which -was never read. +input to output on a bidirectional port or vice versa. Seeking on a +port with buffered input, or switching to writing after reading, will +cause the buffered input to be discarded and Guile will seek the port +back the buffered number of bytes. Likewise seeking on a port with +buffered output, or switching to reading after writing, will flush +pending bytes with a call to the @code{write} procedure. Indicate to +Guile that your port needs this behavior by setting the @code{rw_random} +flag. This flag is set by default if the port type supplies a seek +implementation. -The special treatment must be performed if the @code{rw_random} flag in -the port is non-zero. +@subsubheading C interface -@subsubheading The @code{rw_active} variable +A port type object is created by calling @code{scm_make_port_type}. -The @code{rw_active} variable in the port is only used if -@code{rw_random} is set. It's defined as an enum with the following -values: - -@table @code -@item SCM_PORT_READ -the read buffer may have unread data. - -@item SCM_PORT_WRITE -the write buffer may have unwritten data. - -@item SCM_PORT_NEITHER -neither the write nor the read buffer has data. -@end table - -@subsubheading Reading from a port. - -To read from a port, it's possible to either call existing libguile -procedures such as @code{scm_getc} and @code{scm_read_line} or to read -data from the read buffer directly. Reading from the buffer involves -the following steps: - -@enumerate -@item -Flush output on the port, if @code{rw_active} is @code{SCM_PORT_WRITE}. - -@item -Fill the read buffer, if it's empty, using @code{scm_fill_input}. - -@item Read the data from the buffer and update the read position in -the buffer. Steps 2) and 3) may be repeated as many times as required. - -@item Set rw_active to @code{SCM_PORT_READ} if @code{rw_random} is set. - -@item update the port's line and column counts. -@end enumerate - -@subsubheading Writing to a port. - -To write data to a port, calling @code{scm_lfwrite} should be sufficient for -most purposes. This takes care of the following steps: - -@enumerate -@item -End input on the port, if @code{rw_active} is @code{SCM_PORT_READ}. - -@item -Pass the data to the ptob implementation using the @code{write} ptob -procedure. The advantage of using the ptob @code{write} instead of -manipulating the write buffer directly is that it allows the data to be -written in one operation even if the port is using the single-byte -@code{shortbuf}. - -@item -Set @code{rw_active} to @code{SCM_PORT_WRITE} if @code{rw_random} -is set. -@end enumerate - - -@node Port Implementation -@subsubsection Port Implementation -@cindex Port implementation - -This section describes how to implement a new port type in C. - -As described in the previous section, a port type object (ptob) is -a structure of type @code{scm_ptob_descriptor}. A ptob is created by -calling @code{scm_make_port_type}. - -@deftypefun scm_t_bits scm_make_port_type (char *name, int (*fill_input) (SCM port), void (*write) (SCM port, const void *data, size_t size)) -Return a new port type object. The @var{name}, @var{fill_input} and -@var{write} parameters are initial values for those port type fields, -as described below. The other fields are initialized with default -values and can be changed later. +@deftypefun scm_t_bits scm_make_port_type (char *name, void (*read) (SCM port, scm_t_port_buffer *dst), void (*write) (SCM port, scm_t_port_buffer *src)) +Return a new port type object. The @var{name}, @var{read} and +@var{write} parameters are initial values for those port type fields, as +described below. The other fields are initialized with default values +and can be changed later. @end deftypefun -All of the elements of the ptob, apart from @code{name}, are procedures -which collectively implement the port behaviour. Creating a new port -type mostly involves writing these procedures. +All of the elements of the port type object, apart from @code{name}, are +procedures which collectively implement the port behaviour. Creating a +new port type mostly involves writing these procedures. @table @code @item name A pointer to a NUL terminated string: the name of the port type. This -is the only element of @code{scm_ptob_descriptor} which is not +is the only element of @code{scm_t_ptob_descriptor} which is not a procedure. Set via the first argument to @code{scm_make_port_type}. +@item read +A port's @code{read} implementation fills read buffers. It should copy +bytes to the supplied port buffer object, advancing the buffer's +@code{end} field as appropriate, but not past the buffer's @code{size} +field. + +@item write +A port's @code{write} implementation flushes write buffers to the +mutable store. It should copy bytes from the supplied port buffer +object, advancing the buffer's @code{cur} field as appropriate, but not +past the buffer's @code{end} field. + @item print Called when @code{write} is called on the port object, to print a port description. E.g., for an fport it may produce something like: @@ -2329,70 +2385,16 @@ port type as needing a close on GC. @deftypefun void scm_set_port_needs_close_on_gc (scm_t_bits tc, int needs_close_p) @end deftypefun -@item write -Accept data which is to be written using the port. The port implementation -may choose to buffer the data instead of processing it directly. -Set via the third argument to @code{scm_make_port_type}. - -@item flush -Complete the processing of buffered output data. Reset the value of -@code{rw_active} to @code{SCM_PORT_NEITHER}. -Set using - -@deftypefun void scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port)) -@end deftypefun - -@item end_input -Perform any synchronization required when switching from input to output -on the port. Reset the value of @code{rw_active} to @code{SCM_PORT_NEITHER}. -Set using - -@deftypefun void scm_set_port_end_input (scm_t_bits tc, void (*end_input) (SCM port, int offset)) -@end deftypefun - -@item fill_input -Read new data into the read buffer and return the first character. It -can be assumed that the read buffer is empty when this procedure is called. -Set via the second argument to @code{scm_make_port_type}. - -@item input_waiting -Return a lower bound on the number of bytes that could be read from the -port without blocking. It can be assumed that the current state of -@code{rw_active} is @code{SCM_PORT_NEITHER}. -Set using - -@deftypefun void scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SCM port)) -@end deftypefun - @item seek -Set the current position of the port. The procedure can not make -any assumptions about the value of @code{rw_active} when it's -called. It can reset the buffers first if desired by using something -like: - -@example -if (pt->rw_active == SCM_PORT_READ) - scm_end_input (port); -else if (pt->rw_active == SCM_PORT_WRITE) - ptob->flush (port); -@end example - -However note that this will have the side effect of discarding any data -in the unread-char buffer, in addition to any side effects from the -@code{end_input} and @code{flush} ptob procedures. This is undesirable -when seek is called to measure the current position of the port, i.e., -@code{(seek p 0 SEEK_CUR)}. The libguile fport and string port -implementations take care to avoid this problem. - -The procedure is set using +Set the current position of the port. Guile will flush read and/or +write buffers before seeking, as appropriate. @deftypefun void scm_set_port_seek (scm_t_bits tc, scm_t_off (*seek) (SCM port, scm_t_off offset, int whence)) @end deftypefun @item truncate -Truncate the port data to be specified length. It can be assumed that the -current state of @code{rw_active} is @code{SCM_PORT_NEITHER}. -Set using +Truncate the port data to be specified length. Guile will flush buffers +before hand, as appropriate. Set using @deftypefun void scm_set_port_truncate (scm_t_bits tc, void (*truncate) (SCM port, scm_t_off length)) @end deftypefun diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index e5f1232ac..53a71c138 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -133,18 +133,6 @@ then the return is @code{#f}. For example, Conventions generally follow those of scsh, @ref{The Scheme shell (scsh)}. -File ports are implemented using low-level operating system I/O -facilities, with optional buffering to improve efficiency; see -@ref{File Ports}. - -Note that some procedures (e.g., @code{recv!}) will accept ports as -arguments, but will actually operate directly on the file descriptor -underlying the port. Any port buffering is ignored, including the -buffer which implements @code{peek-char} and @code{unread-char}. - -The @code{force-output} and @code{drain-input} procedures can be used -to clear the buffers. - Each open file port has an associated operating system file descriptor. File descriptors are generally not useful in Scheme programs; however they may be needed when interfacing with foreign code and the Unix @@ -181,6 +169,22 @@ initially set to one, so that dropping references to one of these ports will not result in its garbage collection: it could be retrieved with @code{fdopen} or @code{fdes->ports}. +Guile's ports can be buffered. This means that writing a byte to a file +port goes to the internal buffer first, and only when the buffer is full +(or the user invokes @code{force-output} on the port) is the data +actually written to the file descriptor. Likewise on input, bytes are +read in from the file descriptor in blocks and placed in a buffer. +Reading a character via @code{read-char} first goes to the buffer, +filling it as needed. Usually read buffering is more or less +transparent, but write buffering can sometimes cause writes to be +delayed unexpectedly, if you forget to call @code{force-output}. +@xref{Buffering}, for more on how to control port buffers. + +Note however that some procedures (e.g., @code{recv!}) will accept ports +as arguments, but will actually operate directly on the file descriptor +underlying the port. Any port buffering is ignored, including the +buffer which implements @code{peek-char} and @code{unread-char}. + @deffn {Scheme Procedure} port-revealed port @deffnx {C Function} scm_port_revealed (port) Return the revealed count for @var{port}. @@ -314,32 +318,16 @@ the file descriptor will be closed even if a port is using it. The return value is unspecified. @end deffn -@deffn {Scheme Procedure} unread-char char [port] -@deffnx {C Function} scm_unread_char (char, port) -Place @var{char} in @var{port} so that it will be read by the next -read operation on that port. If called multiple times, the unread -characters will be read again in ``last-in, first-out'' order (i.e.@: -a stack). If @var{port} is not supplied, the current input port is -used. -@end deffn - -@deffn {Scheme Procedure} unread-string str port -Place the string @var{str} in @var{port} so that its characters will be -read in subsequent read operations. If called multiple times, the -unread characters will be read again in last-in first-out order. If -@var{port} is not supplied, the current-input-port is used. -@end deffn - @deffn {Scheme Procedure} pipe @deffnx {C Function} scm_pipe () @cindex pipe -Return a newly created pipe: a pair of ports which are linked -together on the local machine. The @acronym{CAR} is the input -port and the @acronym{CDR} is the output port. Data written (and -flushed) to the output port can be read from the input port. -Pipes are commonly used for communication with a newly forked -child process. The need to flush the output port can be -avoided by making it unbuffered using @code{setvbuf}. +Return a newly created pipe: a pair of ports which are linked together +on the local machine. The @acronym{CAR} is the input port and the +@acronym{CDR} is the output port. Data written (and flushed) to the +output port can be read from the input port. Pipes are commonly used +for communication with a newly forked child process. The need to flush +the output port can be avoided by making it unbuffered using +@code{setvbuf} (@pxref{Buffering}). @defvar PIPE_BUF A write of up to @code{PIPE_BUF} many bytes to a pipe is atomic, @@ -2286,11 +2274,10 @@ don't have file descriptors for the child, then @file{/dev/null} is used instead. Care should be taken with @code{OPEN_BOTH}, a deadlock will occur if -both parent and child are writing, and waiting until the write -completes before doing any reading. Each direction has -@code{PIPE_BUF} bytes of buffering (@pxref{Ports and File -Descriptors}), which will be enough for small writes, but not for say -putting a big file through a filter. +both parent and child are writing, and waiting until the write completes +before doing any reading. Each direction has @code{PIPE_BUF} bytes of +buffering (@pxref{Buffering}), which will be enough for small writes, +but not for say putting a big file through a filter. @end deffn @deffn {Scheme Procedure} open-input-pipe command @@ -3057,7 +3044,7 @@ release the returned structure when no longer required. Socket ports can be created using @code{socket} and @code{socketpair}. The ports are initially unbuffered, to make reading and writing to the same port more reliable. A buffer can be added to the port using -@code{setvbuf}; see @ref{Ports and File Descriptors}. +@code{setvbuf} (@pxref{Buffering}). Most systems have limits on how many files and sockets can be open, so it's strongly recommended that socket ports be closed explicitly when diff --git a/libguile/filesys.c b/libguile/filesys.c index 95d1a9dff..03a0b069c 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -652,7 +652,7 @@ set_element (fd_set *set, SCM *ports_ready, SCM element, int pos) /* check whether port has buffered input. */ scm_t_port *pt = SCM_PTAB_ENTRY (element); - if (pt->read_pos < pt->read_end) + if (pt->read_buf->cur < pt->read_buf->end) use_buf = 1; } else if (pos == SCM_ARG2) @@ -661,7 +661,7 @@ set_element (fd_set *set, SCM *ports_ready, SCM element, int pos) scm_t_port *pt = SCM_PTAB_ENTRY (element); /* > 1 since writing the last byte in the buffer causes flush. */ - if (pt->write_end - pt->write_pos > 1) + if (pt->write_buf->size - pt->write_buf->end > 1) use_buf = 1; } fd = use_buf ? -1 : SCM_FPORT_FDES (element); diff --git a/libguile/fports.c b/libguile/fports.c index 963c1eafd..3e4756204 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -75,67 +75,6 @@ scm_t_bits scm_tc16_fport; -/* default buffer size, used if the O/S won't supply a value. */ -static const size_t default_buffer_size = 1024; - -/* Create FPORT buffers with specified sizes (or -1 to use default size - or 0 for no buffer.) */ -static void -scm_fport_buffer_add (SCM port, long read_size, long write_size) -#define FUNC_NAME "scm_fport_buffer_add" -{ - scm_t_port *pt = SCM_PTAB_ENTRY (port); - - if (read_size == -1 || write_size == -1) - { - size_t default_size; -#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE - struct stat st; - scm_t_fport *fp = SCM_FSTREAM (port); - - default_size = (fstat (fp->fdes, &st) == -1) ? default_buffer_size - : st.st_blksize; -#else - default_size = default_buffer_size; -#endif - if (read_size == -1) - read_size = default_size; - if (write_size == -1) - write_size = default_size; - } - - if (SCM_INPUT_PORT_P (port) && read_size > 0) - { - pt->read_buf = scm_gc_malloc_pointerless (read_size, "port buffer"); - pt->read_pos = pt->read_end = pt->read_buf; - pt->read_buf_size = read_size; - } - else - { - pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf; - pt->read_buf_size = 1; - } - - if (SCM_OUTPUT_PORT_P (port) && write_size > 0) - { - pt->write_buf = scm_gc_malloc_pointerless (write_size, "port buffer"); - pt->write_pos = pt->write_buf; - pt->write_buf_size = write_size; - } - else - { - pt->write_buf = pt->write_pos = &pt->shortbuf; - pt->write_buf_size = 1; - } - - pt->write_end = pt->write_buf + pt->write_buf_size; - if (read_size > 0 || write_size > 0) - SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~SCM_BUF0); - else - SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) | SCM_BUF0); -} -#undef FUNC_NAME - /* Move ports with the specified file descriptor to new descriptors, * resetting the revealed count to 0. */ @@ -480,12 +419,6 @@ scm_i_fdes_to_port (int fdes, long mode_bits, SCM name) port = scm_c_make_port (scm_tc16_fport, mode_bits, (scm_t_bits)fp); SCM_PTAB_ENTRY (port)->rw_random = SCM_FDES_RANDOM_P (fdes); - - if (mode_bits & SCM_BUF0) - scm_fport_buffer_add (port, 0, 0); - else - scm_fport_buffer_add (port, -1, -1); - SCM_SET_FILENAME (port, name); return port; @@ -643,28 +576,31 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) return 1; } -static void fport_flush (SCM port); - /* fill a port's read-buffer with a single read. returns the first char or EOF if end of file. */ -static scm_t_wchar -fport_fill_input (SCM port) +static void +fport_read (SCM port, scm_t_port_buffer *dst) { long count; - scm_t_port *pt = SCM_PTAB_ENTRY (port); scm_t_fport *fp = SCM_FSTREAM (port); + scm_t_uint8 *ptr = dst->buf + dst->end; + size_t size = dst->size - dst->end; - SCM_SYSCALL (count = read (fp->fdes, pt->read_buf, pt->read_buf_size)); + SCM_SYSCALL (count = read (fp->fdes, ptr, size)); if (count == -1) - scm_syserror ("fport_fill_input"); - if (count == 0) - return (scm_t_wchar) EOF; - else - { - pt->read_pos = pt->read_buf; - pt->read_end = pt->read_buf + count; - return *pt->read_buf; - } + scm_syserror ("fport_read"); + dst->end += count; +} + +static void +fport_write (SCM port, scm_t_port_buffer *src) +{ + int fd = SCM_FPORT_FDES (port); + scm_t_uint8 *ptr = src->buf + src->cur; + size_t size = src->end - src->cur; + + if (full_write (fd, ptr, size) < size) + scm_syserror ("fport_write"); } static scm_t_off @@ -690,122 +626,11 @@ fport_truncate (SCM port, scm_t_off length) scm_syserror ("ftruncate"); } -static void -fport_write (SCM port, const void *data, size_t size) -#define FUNC_NAME "fport_write" -{ - /* this procedure tries to minimize the number of writes/flushes. */ - scm_t_port *pt = SCM_PTAB_ENTRY (port); - - if (pt->write_buf == &pt->shortbuf - || (pt->write_pos == pt->write_buf && size >= pt->write_buf_size)) - { - /* Unbuffered port, or port with empty buffer and data won't fit in - buffer. */ - if (full_write (SCM_FPORT_FDES (port), data, size) < size) - SCM_SYSERROR; - - return; - } - - { - scm_t_off space = pt->write_end - pt->write_pos; - - if (size <= space) - { - /* data fits in buffer. */ - memcpy (pt->write_pos, data, size); - pt->write_pos += size; - if (pt->write_pos == pt->write_end) - { - fport_flush (port); - /* we can skip the line-buffering check if nothing's buffered. */ - return; - } - } - else - { - memcpy (pt->write_pos, data, space); - pt->write_pos = pt->write_end; - fport_flush (port); - { - const void *ptr = ((const char *) data) + space; - size_t remaining = size - space; - - if (size >= pt->write_buf_size) - { - if (full_write (SCM_FPORT_FDES (port), ptr, remaining) - < remaining) - SCM_SYSERROR; - return; - } - else - { - memcpy (pt->write_pos, ptr, remaining); - pt->write_pos += remaining; - } - } - } - } -} -#undef FUNC_NAME - -static void -fport_flush (SCM port) -{ - size_t written; - scm_t_port *pt = SCM_PTAB_ENTRY (port); - scm_t_fport *fp = SCM_FSTREAM (port); - size_t count = pt->write_pos - pt->write_buf; - - written = full_write (fp->fdes, pt->write_buf, count); - if (written < count) - scm_syserror ("scm_flush"); - - pt->write_pos = pt->write_buf; -} - -/* clear the read buffer and adjust the file position for unread bytes. */ -static void -fport_end_input (SCM port, int offset) -{ - scm_t_fport *fp = SCM_FSTREAM (port); - scm_t_port *pt = SCM_PTAB_ENTRY (port); - - offset += pt->read_end - pt->read_pos; - - if (offset > 0) - { - pt->read_pos = pt->read_end; - /* will throw error if unread-char used at beginning of file - then attempting to write. seems correct. */ - if (lseek (fp->fdes, -offset, SEEK_CUR) == -1) - scm_syserror ("fport_end_input"); - } -} - -static void -close_the_fd (void *data) -{ - scm_t_fport *fp = data; - - close (fp->fdes); - /* There's already one exception. That's probably enough! */ - errno = 0; -} - static void fport_close (SCM port) { scm_t_fport *fp = SCM_FSTREAM (port); - scm_dynwind_begin (0); - scm_dynwind_unwind_handler (close_the_fd, fp, 0); - fport_flush (port); - scm_dynwind_end (); - - scm_port_non_buffer (SCM_PTAB_ENTRY (port)); - if (close (fp->fdes) != 0) /* It's not useful to retry after EINTR, as the file descriptor is in an undefined state. See http://lwn.net/Articles/365294/. @@ -814,20 +639,31 @@ fport_close (SCM port) scm_syserror ("fport_close"); } +/* Query the OS to get the natural buffering for FPORT, if available. */ +static void +fport_get_natural_buffer_sizes (SCM port, size_t *read_size, size_t *write_size) +{ +#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE + scm_t_fport *fp = SCM_FSTREAM (port); + struct stat st; + + if (fstat (fp->fdes, &st) == 0) + *read_size = *write_size = st.st_blksize; +#endif +} + static scm_t_bits scm_make_fptob () { - scm_t_bits tc = scm_make_port_type ("file", fport_fill_input, fport_write); + scm_t_bits tc = scm_make_port_type ("file", fport_read, fport_write); - scm_set_port_needs_close_on_gc (tc, 1); - scm_set_port_print (tc, fport_print); - scm_set_port_flush (tc, fport_flush); - scm_set_port_end_input (tc, fport_end_input); - scm_set_port_close (tc, fport_close); - scm_set_port_seek (tc, fport_seek); - scm_set_port_truncate (tc, fport_truncate); - scm_set_port_input_waiting (tc, fport_input_waiting); - scm_set_port_setvbuf (tc, scm_fport_buffer_add); + scm_set_port_print (tc, fport_print); + scm_set_port_needs_close_on_gc (tc, 1); + scm_set_port_close (tc, fport_close); + scm_set_port_seek (tc, fport_seek); + scm_set_port_truncate (tc, fport_truncate); + scm_set_port_input_waiting (tc, fport_input_waiting); + scm_set_port_get_natural_buffer_sizes (tc, fport_get_natural_buffer_sizes); return tc; } diff --git a/libguile/ioext.c b/libguile/ioext.c index 25ce01471..607eec636 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -86,19 +86,23 @@ SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0, newfd = fp->fdes; if (oldfd != newfd) { - scm_t_port *pt = SCM_PTAB_ENTRY (new); - scm_t_port *old_pt = SCM_PTAB_ENTRY (old); + /* Ensure there is nothing in either port's input or output + buffers. */ + if (SCM_OUTPUT_PORT_P (old)) + scm_flush_unlocked (old); + if (SCM_INPUT_PORT_P (old)) + scm_end_input_unlocked (old); + + if (SCM_OUTPUT_PORT_P (new)) + scm_flush_unlocked (new); + if (SCM_INPUT_PORT_P (new)) + scm_end_input_unlocked (new); - /* must flush to old fdes. */ - if (pt->rw_active == SCM_PORT_WRITE) - scm_flush_unlocked (new); - else if (pt->rw_active == SCM_PORT_READ) - scm_end_input_unlocked (new); ans = dup2 (oldfd, newfd); if (ans == -1) SCM_SYSERROR; - pt->rw_random = old_pt->rw_random; - /* continue using existing buffers, even if inappropriate. */ + + SCM_PTAB_ENTRY (new)->rw_random = SCM_PTAB_ENTRY (old)->rw_random; } return SCM_UNSPECIFIED; } diff --git a/libguile/poll.c b/libguile/poll.c index 90a5c05e1..1e8fa7a3b 100644 --- a/libguile/poll.c +++ b/libguile/poll.c @@ -108,11 +108,11 @@ scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout) { scm_t_port *pt = SCM_PTAB_ENTRY (port); - if (pt->read_pos < pt->read_end) + if (pt->read_buf->cur < pt->read_buf->end) /* Buffered input waiting to be read. */ revents |= POLLIN; if (SCM_OUTPUT_PORT_P (port) - && pt->write_end - pt->write_pos > 1) + && pt->write_buf->size - pt->write_buf->end > 1) /* Buffered output possible. The "> 1" is because writing the last byte would flush the port. */ revents |= POLLOUT; @@ -146,11 +146,11 @@ scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout) { scm_t_port *pt = SCM_PTAB_ENTRY (port); - if (pt->read_pos < pt->read_end) + if (pt->read_buf->cur < pt->read_buf->end) /* Buffered input waiting to be read. */ revents |= POLLIN; if (SCM_OUTPUT_PORT_P (port) - && pt->write_end - pt->write_pos > 1) + && pt->write_buf->size - pt->write_buf->end > 1) /* Buffered output possible. The "> 1" is because writing the last byte would flush the port. */ revents |= POLLOUT; diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index bff89cb5e..1a94bd5b2 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -50,7 +50,6 @@ struct scm_port_internal unsigned at_stream_start_for_bom_write : 1; scm_t_port_encoding_mode encoding_mode; scm_t_iconv_descriptors *iconv_descriptors; - int pending_eof; SCM alist; }; diff --git a/libguile/ports.c b/libguile/ports.c index b8d2616c1..8f07425e3 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -224,26 +224,13 @@ scm_c_port_type_add_x (scm_t_ptob_descriptor *desc) return ret; } -/* - * We choose to use an interface similar to the smob interface with - * fill_input and write as standard fields, passed to the port - * type constructor, and optional fields set by setters. - */ - -static void -flush_port_default (SCM port SCM_UNUSED) -{ -} - -static void -end_input_default (SCM port SCM_UNUSED, int offset SCM_UNUSED) -{ -} +/* Default buffer size. Used if the port type won't supply a value. */ +static const size_t default_buffer_size = 1024; scm_t_bits scm_make_port_type (char *name, - int (*fill_input) (SCM port), - void (*write) (SCM port, const void *data, size_t size)) + void (*read) (SCM port, scm_t_port_buffer *buf), + void (*write) (SCM port, scm_t_port_buffer *buf)) { scm_t_ptob_descriptor *desc; long ptobnum; @@ -253,10 +240,8 @@ scm_make_port_type (char *name, desc->name = name; desc->print = scm_port_print; + desc->read = read; desc->write = write; - desc->flush = flush_port_default; - desc->end_input = end_input_default; - desc->fill_input = fill_input; ptobnum = scm_c_port_type_add_x (desc); @@ -291,18 +276,6 @@ scm_set_port_needs_close_on_gc (scm_t_bits tc, int needs_close_p) ptob->flags &= ~SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC; } -void -scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port)) -{ - scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->flush = flush; -} - -void -scm_set_port_end_input (scm_t_bits tc, void (*end_input) (SCM port, int offset)) -{ - scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->end_input = end_input; -} - void scm_set_port_seek (scm_t_bits tc, scm_t_off (*seek) (SCM, scm_t_off, int)) { @@ -322,21 +295,23 @@ scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SCM)) } void -scm_set_port_setvbuf (scm_t_bits tc, void (*setvbuf) (SCM, long, long)) +scm_set_port_get_natural_buffer_sizes + (scm_t_bits tc, void (*get_natural_buffer_sizes) (SCM, size_t *, size_t *)) { - scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->setvbuf = setvbuf; + scm_t_ptob_descriptor *ptob = scm_c_port_type_ref (SCM_TC2PTOBNUM (tc)); + ptob->get_natural_buffer_sizes = get_natural_buffer_sizes; } static void scm_i_set_pending_eof (SCM port) { - SCM_PORT_GET_INTERNAL (port)->pending_eof = 1; + SCM_PTAB_ENTRY (port)->read_buf->has_eof = 1; } static void scm_i_clear_pending_eof (SCM port) { - SCM_PORT_GET_INTERNAL (port)->pending_eof = 0; + SCM_PTAB_ENTRY (port)->read_buf->has_eof = 0; } SCM_DEFINE (scm_i_port_property, "%port-property", 2, 0, 0, @@ -542,6 +517,22 @@ scm_i_dynwind_current_load_port (SCM port) } + + +/* Port buffers. */ + +scm_t_port_buffer * +scm_c_make_port_buffer (size_t size) +{ + scm_t_port_buffer *ret = scm_gc_typed_calloc (scm_t_port_buffer); + + ret->size = size; + ret->buf = scm_gc_malloc_pointerless (ret->size, "port buffer"); + + return ret; +} + + /* Retrieving a port's mode. */ @@ -656,6 +647,36 @@ finalize_port (void *ptr, void *data) +static void +initialize_port_buffers (SCM port) +{ + scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port); + size_t read_buf_size, write_buf_size; + + if (SCM_CELL_WORD_0 (port) & SCM_BUF0) + read_buf_size = write_buf_size = 1; + else + { + read_buf_size = write_buf_size = default_buffer_size; + if (ptob->get_natural_buffer_sizes) + ptob->get_natural_buffer_sizes (port, &read_buf_size, &write_buf_size); + if (read_buf_size == 0) + read_buf_size = 1; + if (write_buf_size == 0) + write_buf_size = 1; + } + + if (!SCM_INPUT_PORT_P (port)) + read_buf_size = 1; + if (!SCM_OUTPUT_PORT_P (port)) + write_buf_size = 1; + + pt->read_buffering = read_buf_size; + pt->read_buf = scm_c_make_port_buffer (read_buf_size); + pt->write_buf = scm_c_make_port_buffer (write_buf_size); +} + SCM scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits, const char *encoding, @@ -709,7 +730,6 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits, pti->at_stream_start_for_bom_read = 1; pti->at_stream_start_for_bom_write = 1; - pti->pending_eof = 0; pti->alist = SCM_EOL; if (SCM_PORT_DESCRIPTOR (ret)->flags & SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC) @@ -718,6 +738,8 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits, scm_weak_set_add_x (scm_i_port_weak_set, ret); } + initialize_port_buffers (ret); + return ret; } @@ -817,7 +839,6 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, #define FUNC_NAME s_scm_close_port { scm_t_port_internal *pti; - int rv; port = SCM_COERCE_OUTPORT (port); @@ -825,6 +846,10 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, if (SCM_CLOSEDP (port)) return SCM_BOOL_F; + /* May throw an exception. */ + if (SCM_OUTPUT_PORT_P (port)) + scm_flush (port); + pti = SCM_PORT_GET_INTERNAL (port); SCM_CLR_PORT_OPEN_FLAG (port); @@ -1018,7 +1043,7 @@ looking_at_bytes (SCM port, const unsigned char *bytes, int len) while (i < len && scm_peek_byte_or_eof_unlocked (port) == bytes[i]) { - pt->read_pos++; + pt->read_buf->cur++; i++; } scm_i_unget_bytes_unlocked (bytes, i, port); @@ -1407,55 +1432,38 @@ scm_peek_byte_or_eof (SCM port) return ret; } +/* scm_i_read_unlocked is used internally to add bytes to the given port + buffer. If the number of available bytes in the buffer does not + increase after a call to scm_i_read_unlocked, that indicates EOF. */ +static void +scm_i_read_unlocked (SCM port, scm_t_port_buffer *buf) +{ + size_t prev_end = buf->end; + assert (buf->end < buf->size); + + SCM_PORT_DESCRIPTOR (port)->read (port, buf); + buf->has_eof = buf->end == prev_end; +} + /* scm_c_read * - * Used by an application to read arbitrary number of bytes from an - * SCM port. Same semantics as libc read, except that scm_c_read only + * Used by an application to read arbitrary number of bytes from an SCM + * port. Same semantics as libc read, except that scm_c_read only * returns less than SIZE bytes if at end-of-file. * * Warning: Doesn't update port line and column counts! */ - -/* This structure, and the following swap_buffer function, are used - for temporarily swapping a port's own read buffer, and the buffer - that the caller of scm_c_read provides. */ -struct port_and_swap_buffer -{ - scm_t_port *pt; - unsigned char *buffer; - size_t size; -}; - -static void -swap_buffer (void *data) -{ - struct port_and_swap_buffer *psb = (struct port_and_swap_buffer *) data; - unsigned char *old_buf = psb->pt->read_buf; - size_t old_size = psb->pt->read_buf_size; - - /* Make the port use (buffer, size) from the struct. */ - psb->pt->read_pos = psb->pt->read_buf = psb->pt->read_end = psb->buffer; - psb->pt->read_buf_size = psb->size; - - /* Save the port's old (buffer, size) in the struct. */ - psb->buffer = old_buf; - psb->size = old_size; -} - -static int scm_i_fill_input_unlocked (SCM port); - size_t scm_c_read_unlocked (SCM port, void *buffer, size_t size) #define FUNC_NAME "scm_c_read" { scm_t_port *pt; - scm_t_port_internal *pti; - size_t n_read = 0, n_available; - struct port_and_swap_buffer psb; + scm_t_port_buffer *read_buf; + scm_t_port_buffer dst_buf = { buffer, 0, 0, size, 0, NULL }; SCM_VALIDATE_OPINPORT (1, port); pt = SCM_PTAB_ENTRY (port); - pti = SCM_PORT_GET_INTERNAL (port); + read_buf = pt->read_buf; if (pt->rw_random) { @@ -1465,89 +1473,45 @@ scm_c_read_unlocked (SCM port, void *buffer, size_t size) } /* Take bytes first from the port's read buffer. */ - if (pt->read_pos < pt->read_end) + if (read_buf->cur < read_buf->end) { - n_available = min (size, pt->read_end - pt->read_pos); - memcpy (buffer, pt->read_pos, n_available); - buffer = (char *) buffer + n_available; - pt->read_pos += n_available; - n_read += n_available; - size -= n_available; + size_t to_read = dst_buf.size - dst_buf.end; + to_read = min (to_read, read_buf->end - read_buf->cur); + memcpy (dst_buf.buf + dst_buf.end, read_buf->buf + read_buf->cur, + to_read); + dst_buf.end += to_read; + read_buf->cur += to_read; } - /* Avoid the scm_dynwind_* costs if we now have enough data. */ - if (size == 0) - return n_read; + while (dst_buf.end < dst_buf.size) + /* If the read buffering is larger than our read size, buffer the + read. Otherwise read into our buffer directly. */ + if (dst_buf.size - dst_buf.end < pt->read_buffering) + { + size_t to_read = dst_buf.size - dst_buf.end; + read_buf = scm_fill_input_unlocked (port); + if (to_read > read_buf->end - read_buf->cur) + to_read = read_buf->end - read_buf->cur; + if (to_read == 0) + { + /* Consider that we've read off this EOF. */ + read_buf->has_eof = 0; + break; + } + memcpy (dst_buf.buf + dst_buf.end, + read_buf->buf + read_buf->cur, + to_read); + read_buf->cur += to_read; + dst_buf.end += to_read; + } + else + { + scm_i_read_unlocked (port, &dst_buf); + if (dst_buf.has_eof) + break; + } - /* Now we will call scm_i_fill_input_unlocked repeatedly until we have - read the requested number of bytes. (Note that a single - scm_i_fill_input_unlocked call does not guarantee to fill the whole - of the port's read buffer.) */ - if (pt->read_buf_size <= 1 - && pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1) - { - /* The port that we are reading from is unbuffered - i.e. does not - have its own persistent buffer - but we have a buffer, provided - by our caller, that is the right size for the data that is - wanted. For the following scm_i_fill_input_unlocked calls, - therefore, we use the buffer in hand as the port's read buffer. - - We need to make sure that the port's normal (1 byte) buffer is - reinstated in case one of the scm_i_fill_input_unlocked () - calls throws an exception; we use the scm_dynwind_* API to - achieve that. - - A consequence of this optimization is that the fill_input - functions can't unget characters. That'll push data to the - pushback buffer instead of this psb buffer. */ -#if SCM_DEBUG == 1 - unsigned char *pback = pt->putback_buf; -#endif - psb.pt = pt; - psb.buffer = buffer; - psb.size = size; - scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE); - scm_dynwind_rewind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY); - scm_dynwind_unwind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY); - - /* Call scm_i_fill_input_unlocked until we have all the bytes that - we need, or we hit EOF. */ - while (pt->read_buf_size && (scm_i_fill_input_unlocked (port) != EOF)) - { - pt->read_buf_size -= (pt->read_end - pt->read_pos); - pt->read_pos = pt->read_buf = pt->read_end; - } -#if SCM_DEBUG == 1 - if (pback != pt->putback_buf - || pt->read_buf - (unsigned char *) buffer < 0) - scm_misc_error (FUNC_NAME, - "scm_c_read must not call a fill function that pushes " - "back characters onto an unbuffered port", SCM_EOL); -#endif - n_read += pt->read_buf - (unsigned char *) buffer; - - /* Reinstate the port's normal buffer. */ - scm_dynwind_end (); - } - else - { - /* The port has its own buffer. It is important that we use it, - even if it happens to be smaller than our caller's buffer, so - that a custom port implementation's entry points (in - particular, fill_input) can rely on the buffer always being - the same as they first set up. */ - while (size && (scm_i_fill_input_unlocked (port) != EOF)) - { - n_available = min (size, pt->read_end - pt->read_pos); - memcpy (buffer, pt->read_pos, n_available); - buffer = (char *) buffer + n_available; - pt->read_pos += n_available; - n_read += n_available; - size -= n_available; - } - } - - return n_read; + return dst_buf.end; } #undef FUNC_NAME @@ -1643,7 +1607,7 @@ get_utf8_codepoint (SCM port, scm_t_wchar *codepoint, if (SCM_UNLIKELY ((b) == EOF)) \ goto invalid_seq #define CONSUME_PEEKED_BYTE() \ - pt->read_pos++ + pt->read_buf->cur++ int byte; scm_t_port *pt; @@ -1979,88 +1943,58 @@ SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0, static void -scm_i_unget_bytes_unlocked (const unsigned char *buf, size_t len, SCM port) +scm_i_unget_bytes_unlocked (const scm_t_uint8 *buf, size_t len, SCM port) #define FUNC_NAME "scm_unget_bytes" { scm_t_port *pt = SCM_PTAB_ENTRY (port); - size_t old_len, new_len; + scm_t_port_buffer *read_buf = pt->read_buf; if (pt->rw_random) { if (pt->rw_active == SCM_PORT_WRITE) - scm_flush (port); + scm_flush_unlocked (port); pt->rw_active = SCM_PORT_READ; } - scm_i_clear_pending_eof (port); - - if (pt->read_buf != pt->putback_buf) - /* switch to the put-back buffer. */ + if (read_buf->cur < len) { - if (pt->putback_buf == NULL) - { - pt->putback_buf_size = (len > SCM_INITIAL_PUTBACK_BUF_SIZE - ? len : SCM_INITIAL_PUTBACK_BUF_SIZE); - pt->putback_buf - = (unsigned char *) scm_gc_malloc_pointerless - (pt->putback_buf_size, "putback buffer"); - } + /* The bytes don't fit directly in the read_buf. */ + if (len <= read_buf->cur + (read_buf->size - read_buf->end)) + { + /* But they would fit if we shift the not-yet-read bytes from + the read_buf right. Let's do that. */ + size_t to_move = read_buf->end - read_buf->cur; - pt->saved_read_buf = pt->read_buf; - pt->saved_read_pos = pt->read_pos; - pt->saved_read_end = pt->read_end; - pt->saved_read_buf_size = pt->read_buf_size; + if (to_move > 0) + memmove (read_buf->buf + (read_buf->size - to_move), + read_buf->buf + read_buf->cur, + to_move); + read_buf->end = read_buf->size; + read_buf->cur = read_buf->end - to_move; + } + else + { + /* Bah, have to expand the read_buf for the putback. */ + scm_t_port_buffer *new_buf; + size_t buffered = read_buf->end - read_buf->cur; + size_t size = read_buf->size; - /* Put read_pos at the end of the buffer, so that ungets will not - have to shift the buffer contents each time. */ - pt->read_buf = pt->putback_buf; - pt->read_pos = pt->read_end = pt->putback_buf + pt->putback_buf_size; - pt->read_buf_size = pt->putback_buf_size; + while (size < len + buffered) + size *= 2; + + new_buf = scm_c_make_port_buffer (size); + new_buf->end = new_buf->size; + new_buf->cur = new_buf->end - buffered; + new_buf->has_eof = read_buf->has_eof; + memcpy (new_buf->buf + new_buf->cur, read_buf->buf + read_buf->cur, + buffered); + + pt->read_buf = read_buf = new_buf; + } } - old_len = pt->read_end - pt->read_pos; - new_len = old_len + len; - - if (new_len > pt->read_buf_size) - /* The putback buffer needs to be enlarged. */ - { - size_t new_buf_size; - unsigned char *new_buf, *new_end, *new_pos; - - new_buf_size = pt->read_buf_size * 2; - if (new_buf_size < new_len) - new_buf_size = new_len; - - new_buf = (unsigned char *) - scm_gc_malloc_pointerless (new_buf_size, "putback buffer"); - - /* Put the bytes at the end of the buffer, so that future - ungets won't need to shift the buffer. */ - new_end = new_buf + new_buf_size; - new_pos = new_end - old_len; - memcpy (new_pos, pt->read_pos, old_len); - - pt->read_buf = pt->putback_buf = new_buf; - pt->read_pos = new_pos; - pt->read_end = new_end; - pt->read_buf_size = pt->putback_buf_size = new_buf_size; - } - else if (pt->read_buf + len < pt->read_pos) - /* If needed, shift the existing buffer contents up. - This should not happen unless some external code - manipulates the putback buffer pointers. */ - { - unsigned char *new_end = pt->read_buf + pt->read_buf_size; - unsigned char *new_pos = new_end - old_len; - - memmove (new_pos, pt->read_pos, old_len); - pt->read_pos = new_pos; - pt->read_end = new_end; - } - - /* Move read_pos back and copy the bytes there. */ - pt->read_pos -= len; - memcpy (pt->read_buf + (pt->read_pos - pt->read_buf), buf, len); + read_buf->cur -= len; + memcpy (read_buf->buf + read_buf->cur, buf, len); } #undef FUNC_NAME @@ -2297,17 +2231,6 @@ SCM_DEFINE (scm_unread_string, "unread-string", 2, 0, 0, /* Manipulating the buffers. */ -/* This routine does not take any locks, as it is usually called as part - of a port implementation. */ -void -scm_port_non_buffer (scm_t_port *pt) -{ - pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf; - pt->write_buf = pt->write_pos = &pt->shortbuf; - pt->read_buf_size = pt->write_buf_size = 1; - pt->write_end = pt->write_buf + pt->write_buf_size; -} - SCM_SYMBOL (sym_none, "none"); SCM_SYMBOL (sym_line, "line"); SCM_SYMBOL (sym_block, "block"); @@ -2330,22 +2253,19 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, #define FUNC_NAME s_scm_setvbuf { long csize; - size_t ndrained; - char *drained = NULL; scm_t_port *pt; scm_t_ptob_descriptor *ptob; scm_t_bits tag_word; + size_t read_buf_size, write_buf_size; + scm_t_port_buffer *saved_read_buf; port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); + pt = SCM_PTAB_ENTRY (port); ptob = SCM_PORT_DESCRIPTOR (port); tag_word = SCM_CELL_WORD_0 (port) & ~(SCM_BUF0 | SCM_BUFLINE); - if (ptob->setvbuf == NULL) - scm_wrong_type_arg_msg (FUNC_NAME, 1, port, - "port that supports 'setvbuf'"); - if (scm_is_eq (mode, sym_none)) { tag_word |= SCM_BUF0; @@ -2368,82 +2288,48 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, if (!SCM_UNBNDP (size) && csize < 0) scm_out_of_range (FUNC_NAME, size); - SCM_SET_CELL_WORD_0 (port, tag_word); - pt = SCM_PTAB_ENTRY (port); - - if (SCM_INPUT_PORT_P (port)) - { - /* Drain pending input from PORT. Don't use `scm_drain_input' since - it returns a string, whereas we want binary input here. */ - ndrained = pt->read_end - pt->read_pos; - if (pt->read_buf == pt->putback_buf) - ndrained += pt->saved_read_end - pt->saved_read_pos; - - if (ndrained > 0) - { - drained = scm_gc_malloc_pointerless (ndrained, "file port"); - scm_take_from_input_buffers (port, drained, ndrained); - } - } + if (csize >= 0) + read_buf_size = write_buf_size = csize; else - ndrained = 0; + { + read_buf_size = write_buf_size = default_buffer_size; + if (ptob->get_natural_buffer_sizes) + ptob->get_natural_buffer_sizes (port, &read_buf_size, &write_buf_size); + } + + /* Minimum buffer size is one byte. */ + if (read_buf_size == 0) + read_buf_size = 1; + if (write_buf_size == 0) + write_buf_size = 1; if (SCM_OUTPUT_PORT_P (port)) scm_flush_unlocked (port); - if (pt->read_buf == pt->putback_buf) - { - pt->read_buf = pt->saved_read_buf; - pt->read_pos = pt->saved_read_pos; - pt->read_end = pt->saved_read_end; - pt->read_buf_size = pt->saved_read_buf_size; - } + saved_read_buf = pt->read_buf; - ptob->setvbuf (port, csize, csize); + SCM_SET_CELL_WORD_0 (port, tag_word); + pt->read_buffering = read_buf_size; + pt->read_buf = scm_c_make_port_buffer (read_buf_size); + pt->write_buf = scm_c_make_port_buffer (write_buf_size); - if (ndrained > 0) - /* Put DRAINED back to PORT. */ - scm_unget_bytes ((unsigned char *) drained, ndrained, port); + if (saved_read_buf && saved_read_buf->cur < saved_read_buf->end) + scm_unget_bytes (saved_read_buf->buf + saved_read_buf->cur, + saved_read_buf->end - saved_read_buf->cur, + port); + + if (saved_read_buf) + pt->read_buf->has_eof = saved_read_buf->has_eof; return SCM_UNSPECIFIED; } #undef FUNC_NAME -/* this should only be called when the read buffer is empty. it - tries to refill the read buffer. it returns the first char from - the port, which is either EOF or *(pt->read_pos). */ -static int -scm_i_fill_input_unlocked (SCM port) -{ - scm_t_port *pt = SCM_PTAB_ENTRY (port); - scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); - - assert (pt->read_pos == pt->read_end); - - if (pti->pending_eof) - { - pti->pending_eof = 0; - return EOF; - } - - if (pt->read_buf == pt->putback_buf) - { - /* finished reading put-back chars. */ - pt->read_buf = pt->saved_read_buf; - pt->read_pos = pt->saved_read_pos; - pt->read_end = pt->saved_read_end; - pt->read_buf_size = pt->saved_read_buf_size; - if (pt->read_pos < pt->read_end) - return *(pt->read_pos); - } - return SCM_PORT_DESCRIPTOR (port)->fill_input (port); -} - -int +scm_t_port_buffer* scm_fill_input (SCM port) { scm_i_pthread_mutex_t *lock; - int ret; + scm_t_port_buffer *ret; scm_c_lock_port (port, &lock); ret = scm_fill_input_unlocked (port); @@ -2453,85 +2339,19 @@ scm_fill_input (SCM port) return ret; } -/* Slow-path fallback for 'scm_get_byte_or_eof_unlocked' */ -int -scm_slow_get_byte_or_eof_unlocked (SCM port) -{ - scm_t_port *pt = SCM_PTAB_ENTRY (port); - - if (pt->rw_random) - { - if (pt->rw_active == SCM_PORT_WRITE) - scm_flush_unlocked (port); - pt->rw_active = SCM_PORT_READ; - } - - if (pt->read_pos >= pt->read_end) - { - if (SCM_UNLIKELY (scm_i_fill_input_unlocked (port) == EOF)) - return EOF; - } - - return *pt->read_pos++; -} - -/* Slow-path fallback for 'scm_peek_byte_or_eof_unlocked' */ -int -scm_slow_peek_byte_or_eof_unlocked (SCM port) -{ - scm_t_port *pt = SCM_PTAB_ENTRY (port); - - if (pt->rw_random) - { - if (pt->rw_active == SCM_PORT_WRITE) - scm_flush_unlocked (port); - pt->rw_active = SCM_PORT_READ; - } - - if (pt->read_pos >= pt->read_end) - { - if (SCM_UNLIKELY (scm_i_fill_input_unlocked (port) == EOF)) - { - scm_i_set_pending_eof (port); - return EOF; - } - } - - return *pt->read_pos; -} - -/* Move up to READ_LEN bytes from PORT's putback and/or read buffers - into memory starting at DEST. Return the number of bytes moved. - PORT's line/column numbers are left unchanged. */ +/* Move up to READ_LEN bytes from PORT's read buffer into memory + starting at DEST. Return the number of bytes moved. PORT's + line/column numbers are left unchanged. */ size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len) { scm_t_port *pt = SCM_PTAB_ENTRY (port); - size_t bytes_read = 0; - size_t from_buf = min (pt->read_end - pt->read_pos, read_len); + scm_t_port_buffer *read_buf = pt->read_buf; + size_t count = min (read_buf->end - read_buf->cur, read_len); - if (from_buf > 0) - { - memcpy (dest, pt->read_pos, from_buf); - pt->read_pos += from_buf; - bytes_read += from_buf; - read_len -= from_buf; - dest += from_buf; - } - - /* if putback was active, try the real input buffer too. */ - if (pt->read_buf == pt->putback_buf) - { - from_buf = min (pt->saved_read_end - pt->saved_read_pos, read_len); - if (from_buf > 0) - { - memcpy (dest, pt->saved_read_pos, from_buf); - pt->saved_read_pos += from_buf; - bytes_read += from_buf; - } - } - - return bytes_read; + memcpy (dest, read_buf->buf + read_buf->cur, count); + read_buf->cur += count; + return count; } /* Clear a port's read buffers, returning the contents. */ @@ -2553,21 +2373,21 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, #define FUNC_NAME s_scm_drain_input { SCM result; - char *data; scm_t_port *pt; + scm_t_port_buffer *read_buf; long count; SCM_VALIDATE_OPINPORT (1, port); pt = SCM_PTAB_ENTRY (port); + read_buf = pt->read_buf; - count = pt->read_end - pt->read_pos; - if (pt->read_buf == pt->putback_buf) - count += pt->saved_read_end - pt->saved_read_pos; + count = read_buf->end - read_buf->cur; if (count) { - result = scm_i_make_string (count, &data, 0); - scm_take_from_input_buffers (port, data, count); + scm_t_uint8 *ptr = read_buf->buf + read_buf->cur; + result = scm_from_port_stringn ((char *) ptr, count, port); + read_buf->cur = read_buf->end; } else result = scm_nullstr; @@ -2579,22 +2399,19 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, void scm_end_input_unlocked (SCM port) { - long offset; - scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt; + scm_t_port_buffer *buf; + scm_t_off offset; - scm_i_clear_pending_eof (port); - if (pt->read_buf == pt->putback_buf) - { - offset = pt->read_end - pt->read_pos; - pt->read_buf = pt->saved_read_buf; - pt->read_pos = pt->saved_read_pos; - pt->read_end = pt->saved_read_end; - pt->read_buf_size = pt->saved_read_buf_size; - } - else - offset = 0; + pt = SCM_PTAB_ENTRY (port); + buf = SCM_PTAB_ENTRY (port)->read_buf; + offset = buf->cur - buf->end; - SCM_PORT_DESCRIPTOR (port)->end_input (port, offset); + assert (pt->rw_random); + + buf->end = buf->cur = 0; + if (offset != 0) + SCM_PORT_DESCRIPTOR (port)->seek (port, offset, SEEK_CUR); pt->rw_active = SCM_PORT_NEITHER; } @@ -2633,7 +2450,10 @@ SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0, void scm_flush_unlocked (SCM port) { - SCM_PORT_DESCRIPTOR (port)->flush (port); + scm_t_port_buffer *buf = SCM_PTAB_ENTRY (port)->write_buf; + if (buf->cur < buf->end) + SCM_PORT_DESCRIPTOR (port)->write (port, buf); + buf->cur = buf->end = 0; SCM_PTAB_ENTRY (port)->rw_active = SCM_PORT_NEITHER; } @@ -2647,10 +2467,32 @@ scm_flush (SCM port) scm_i_pthread_mutex_unlock (lock); } -int +scm_t_port_buffer * scm_fill_input_unlocked (SCM port) { - return scm_i_fill_input_unlocked (port); + scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_port_buffer *read_buf = pt->read_buf; + + if (read_buf->cur < read_buf->end || read_buf->has_eof) + return read_buf; + + if (pt->rw_random) + { + if (pt->rw_active == SCM_PORT_WRITE) + scm_flush_unlocked (pt->port); + pt->rw_active = SCM_PORT_READ; + } + + /* It could be that putback caused us to enlarge the buffer; now that + we've read all the bytes we need to shrink it again. */ + if (read_buf->size != pt->read_buffering) + read_buf = pt->read_buf = scm_c_make_port_buffer (pt->read_buffering); + else + read_buf->cur = read_buf->end = 0; + + scm_i_read_unlocked (port, read_buf); + + return read_buf; } @@ -2692,12 +2534,14 @@ scm_c_write_unlocked (SCM port, const void *ptr, size_t size) #define FUNC_NAME "scm_c_write" { scm_t_port *pt; + scm_t_port_buffer *write_buf; scm_t_ptob_descriptor *ptob; SCM_VALIDATE_OPOUTPORT (1, port); pt = SCM_PTAB_ENTRY (port); ptob = SCM_PORT_DESCRIPTOR (port); + write_buf = pt->write_buf; if (pt->rw_random) { @@ -2706,7 +2550,49 @@ scm_c_write_unlocked (SCM port, const void *ptr, size_t size) pt->rw_active = SCM_PORT_WRITE; } - ptob->write (port, ptr, size); + if (size < write_buf->size) + { + /* Make it so that write_buf->end is only nonzero if there are + buffered bytes already. */ + if (write_buf->cur == write_buf->end) + write_buf->cur = write_buf->end = 0; + + /* We buffer writes that are smaller in size than the write + buffer. If the buffer is too full to hold the new data, we + flush it beforehand. Otherwise it could be that the buffer is + full after filling it with the new data; if that's the case, we + flush then instead. */ + if (write_buf->end + size > write_buf->size) + { + ptob->write (port, write_buf); + write_buf->cur = write_buf->end = 0; + } + + memcpy (write_buf->buf + write_buf->end, ptr, size); + write_buf->end += size; + + if (write_buf->end == write_buf->size) + { + ptob->write (port, write_buf); + write_buf->cur = write_buf->end = 0; + } + } + else + { + /* Our write would overflow the buffer. Flush buffered bytes (if + needed), then write our bytes with just one syscall. */ + + scm_t_port_buffer ad_hoc_buf = + { (scm_t_uint8 *) ptr, 0, size, size, 0, NULL }; + + if (write_buf->cur < write_buf->end) + { + ptob->write (port, write_buf); + write_buf->cur = write_buf->end = 0; + } + + ptob->write (port, &ad_hoc_buf); + } } #undef FUNC_NAME @@ -2784,6 +2670,7 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, #define FUNC_NAME s_scm_char_ready_p { scm_t_port *pt; + scm_t_port_buffer *read_buf; if (SCM_UNBNDP (port)) port = scm_current_input_port (); @@ -2792,20 +2679,17 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, SCM_VALIDATE_OPINPORT (1, port); pt = SCM_PTAB_ENTRY (port); + read_buf = pt->read_buf; - /* if the current read buffer is filled, or the - last pushed-back char has been read and the saved buffer is - filled, result is true. */ - if (pt->read_pos < pt->read_end - || (pt->read_buf == pt->putback_buf - && pt->saved_read_pos < pt->saved_read_end)) + if (read_buf->cur < read_buf->end || read_buf->has_eof) + /* FIXME: Verify that a whole character is available? */ return SCM_BOOL_T; else { scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port); if (ptob->input_waiting) - return scm_from_bool(ptob->input_waiting (port)); + return scm_from_bool (ptob->input_waiting (port)); else return SCM_BOOL_T; } @@ -2969,10 +2853,10 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, SCM_MISC_ERROR ("port is not truncatable", SCM_EOL); scm_i_clear_pending_eof (object); - if (pt->rw_active == SCM_PORT_READ) - scm_end_input_unlocked (object); - else if (pt->rw_active == SCM_PORT_WRITE) - scm_flush_unlocked (object); + + if (SCM_INPUT_PORT_P (object)) + scm_end_input_unlocked (object); + scm_flush_unlocked (object); ptob->truncate (object, c_length); rv = 0; @@ -3198,28 +3082,20 @@ SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0, scm_t_bits scm_tc16_void_port = 0; -static int fill_input_void_port (SCM port SCM_UNUSED) +static void +void_port_read (SCM port, scm_t_port_buffer *buf) { - return EOF; } static void -write_void_port (SCM port SCM_UNUSED, - const void *data SCM_UNUSED, - size_t size SCM_UNUSED) +void_port_write (SCM port, scm_t_port_buffer *buf) { } static SCM scm_i_void_port (long mode_bits) { - SCM ret; - - ret = scm_c_make_port (scm_tc16_void_port, mode_bits, 0); - - scm_port_non_buffer (SCM_PTAB_ENTRY (ret)); - - return ret; + return scm_c_make_port (scm_tc16_void_port, mode_bits, 0); } SCM @@ -3253,8 +3129,8 @@ scm_init_ports () scm_c_define ("SEEK_CUR", scm_from_int (SEEK_CUR)); scm_c_define ("SEEK_END", scm_from_int (SEEK_END)); - scm_tc16_void_port = scm_make_port_type ("void", fill_input_void_port, - write_void_port); + scm_tc16_void_port = scm_make_port_type ("void", void_port_read, + void_port_write); cur_inport_fluid = scm_make_fluid (); cur_outport_fluid = scm_make_fluid (); diff --git a/libguile/ports.h b/libguile/ports.h index 0196753ae..80e3a6774 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -39,8 +39,6 @@ -#define SCM_INITIAL_PUTBACK_BUF_SIZE 4 - /* values for the rw_active flag. */ typedef enum scm_t_port_rw_active { SCM_PORT_NEITHER = 0, @@ -51,74 +49,94 @@ typedef enum scm_t_port_rw_active { /* An internal-only structure defined in ports-internal.h. */ struct scm_port_internal; +/* Port buffers. + + It's important to avoid calling into the kernel too many times. For + that reason we buffer the input and output, using `scm_t_port_buffer' + objects. The bytes in a read buffer are laid out like this: + + |already read | not yet | invalid + | data | read | data + readbuf: #vu8(|r r r r r r r|u u u u u|x x x x x|) + ^buf ^cur ^end ^size + + Similarly for a write buffer: + + |already written | not yet | invalid + | data | written | data + writebuf: #vu8(|w w w w w w w w |u u u u u|x x x x x|) + ^buf ^cur ^end ^size + + We use a `scm_t_port_buffer' object for both purposes. Port buffers + are implemented as their own object so that they can be atomically + swapped in or out. */ + +typedef struct +{ + /* Start of the buffer. Never changed. */ + scm_t_uint8 *buf; + + /* Offsets into the buffer. Invariant: cur <= end <= size. */ + size_t cur; + size_t end; + size_t size; + + /* For read buffers, flag indicating whether the last read() returned + zero bytes. Note that in the case of pushback, there could still + be bytes in the buffer, but that after any bytes are read off, + peek-u8 should still return EOF. */ + int has_eof; + + /* Heap object that keeps `buf' alive. */ + void *holder; +} scm_t_port_buffer; + + /* C representation of a Scheme port. */ typedef struct { - SCM port; /* Link back to the port object. */ - scm_i_pthread_mutex_t *lock; /* A recursive lock for this port. */ + /* Link back to the port object. */ + SCM port; - /* pointer to internal-only port structure */ + /* A recursive lock for this port. */ + scm_i_pthread_mutex_t *lock; + + /* Pointer to internal-only port structure. */ struct scm_port_internal *internal; - /* data for the underlying port implementation as a raw C value. */ + /* Data for the underlying port implementation as a raw C value. */ scm_t_bits stream; - SCM file_name; /* debugging support. */ - long line_number; /* debugging support. */ - int column_number; /* debugging support. */ + /* Source location information. */ + SCM file_name; + long line_number; + int column_number; - /* port buffers. the buffer(s) are set up for all ports. - in the case of string ports, the buffer is the string itself. - in the case of unbuffered file ports, the buffer is a - single char: shortbuf. */ + /* Port buffers. */ + scm_t_port_buffer *read_buf; + scm_t_port_buffer *write_buf; - /* this buffer is filled from read_buf to read_end using the ptob - buffer_fill. then input requests are taken from read_pos until - it reaches read_end. */ + /* All ports have read and write buffers; an unbuffered port simply + has a one-byte buffer. However unreading bytes can expand the read + buffer, but that doesn't mean that we want to increase the input + buffering. For that reason `read_buffering' is a separate + indication of how many characters to buffer on the read side. + There isn't a write_buf_size because there isn't an + `unwrite-byte'. */ + size_t read_buffering; - unsigned char *read_buf; /* buffer start. */ - const unsigned char *read_pos;/* the next unread char. */ - unsigned char *read_end; /* pointer to last buffered char + 1. */ - scm_t_off read_buf_size; /* size of the buffer. */ + /* True if the port is random access. Implies that the buffers must + be flushed before switching between reading and writing, seeking, + and so on. */ + int rw_random; - /* when chars are put back into the buffer, e.g., using peek-char or - unread-string, the read-buffer pointers are switched to cbuf. - the original pointers are saved here and restored when the put-back - chars have been consumed. */ - unsigned char *saved_read_buf; - const unsigned char *saved_read_pos; - unsigned char *saved_read_end; - scm_t_off saved_read_buf_size; + /* For random access ports, indicates which of the buffers is + currently in use. Can be SCM_PORT_WRITE, SCM_PORT_READ, or + SCM_PORT_NEITHER. */ + scm_t_port_rw_active rw_active; - /* write requests are saved into this buffer at write_pos until it - reaches write_buf + write_buf_size, then the ptob flush is - called. */ - - unsigned char *write_buf; /* buffer start. */ - unsigned char *write_pos; /* pointer to last buffered char + 1. */ - unsigned char *write_end; /* pointer to end of buffer + 1. */ - scm_t_off write_buf_size; /* size of the buffer. */ - - unsigned char shortbuf; /* buffer for "unbuffered" streams. */ - - int rw_random; /* true if the port is random access. - implies that the buffers must be - flushed before switching between - reading and writing, seeking, etc. */ - - scm_t_port_rw_active rw_active; /* for random access ports, - indicates which of the buffers - is currently in use. can be - SCM_PORT_WRITE, SCM_PORT_READ, - or SCM_PORT_NEITHER. */ - - - /* a buffer for un-read chars and strings. */ - unsigned char *putback_buf; - size_t putback_buf_size; /* allocated size of putback_buf. */ - - /* Character encoding support */ + /* Character encoding support. */ char *encoding; scm_t_string_failed_conversion_handler ilseq_handler; } scm_t_port; @@ -127,8 +145,6 @@ typedef struct SCM_INTERNAL SCM scm_i_port_weak_set; -#define SCM_READ_BUFFER_EMPTY_P(c_port) (c_port->read_pos >= c_port->read_end) - #define SCM_EOF_OBJECT_P(x) (scm_is_eq ((x), SCM_EOF_VAL)) @@ -187,25 +203,19 @@ typedef struct scm_t_ptob_descriptor { char *name; int (*print) (SCM exp, SCM port, scm_print_state *pstate); + + void (*read) (SCM port, scm_t_port_buffer *dst); + void (*write) (SCM port, scm_t_port_buffer *src); + scm_t_off (*seek) (SCM port, scm_t_off OFFSET, int WHENCE); void (*close) (SCM port); - void (*write) (SCM port, const void *data, size_t size); - void (*flush) (SCM port); + void (*get_natural_buffer_sizes) (SCM port, size_t *read_size, + size_t *write_size); - void (*end_input) (SCM port, int offset); - int (*fill_input) (SCM port); int (*input_waiting) (SCM port); - scm_t_off (*seek) (SCM port, scm_t_off OFFSET, int WHENCE); void (*truncate) (SCM port, scm_t_off length); - /* When non-NULL, this is the method called by 'setvbuf' for this port. - It must create read and write buffers for PORT with the specified - sizes (a size of 0 is for unbuffered ports, which should use the - 'shortbuf' field.) Size -1 means to use the port's preferred buffer - size. */ - void (*setvbuf) (SCM port, long read_size, long write_size); - unsigned flags; } scm_t_ptob_descriptor; @@ -218,22 +228,16 @@ typedef struct scm_t_ptob_descriptor SCM_INTERNAL long scm_c_num_port_types (void); SCM_API scm_t_ptob_descriptor* scm_c_port_type_ref (long ptobnum); SCM_API long scm_c_port_type_add_x (scm_t_ptob_descriptor *desc); -SCM_API scm_t_bits scm_make_port_type (char *name, - int (*fill_input) (SCM port), - void (*write) (SCM port, - const void *data, - size_t size)); +SCM_API scm_t_bits scm_make_port_type + (char *name, + void (*read) (SCM port, scm_t_port_buffer *dst), + void (*write) (SCM port, scm_t_port_buffer *src)); SCM_API void scm_set_port_print (scm_t_bits tc, int (*print) (SCM exp, SCM port, scm_print_state *pstate)); SCM_API void scm_set_port_close (scm_t_bits tc, void (*close) (SCM)); SCM_API void scm_set_port_needs_close_on_gc (scm_t_bits tc, int needs_close_p); - -SCM_API void scm_set_port_flush (scm_t_bits tc, void (*flush) (SCM port)); -SCM_API void scm_set_port_end_input (scm_t_bits tc, - void (*end_input) (SCM port, - int offset)); SCM_API void scm_set_port_seek (scm_t_bits tc, scm_t_off (*seek) (SCM port, scm_t_off OFFSET, @@ -242,8 +246,8 @@ SCM_API void scm_set_port_truncate (scm_t_bits tc, void (*truncate) (SCM port, scm_t_off length)); SCM_API void scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SCM)); -SCM_API void scm_set_port_setvbuf (scm_t_bits tc, - void (*setvbuf) (SCM, long, long)); +SCM_API void scm_set_port_get_natural_buffer_sizes + (scm_t_bits tc, void (*get_natural_buffer_sizes) (SCM, size_t *, size_t *)); /* The input, output, error, and load ports. */ SCM_API SCM scm_current_input_port (void); @@ -260,6 +264,9 @@ SCM_API void scm_dynwind_current_output_port (SCM port); SCM_API void scm_dynwind_current_error_port (SCM port); SCM_INTERNAL void scm_i_dynwind_current_load_port (SCM port); +/* Port buffers. */ +SCM_INTERNAL scm_t_port_buffer *scm_c_make_port_buffer (size_t size); + /* Mode bits. */ SCM_INTERNAL long scm_i_mode_bits (SCM modes); SCM_API long scm_mode_bits (char *modes); @@ -334,10 +341,9 @@ SCM_API SCM scm_unread_char (SCM cobj, SCM port); SCM_API SCM scm_unread_string (SCM str, SCM port); /* Manipulating the buffers. */ -SCM_API void scm_port_non_buffer (scm_t_port *pt); SCM_API SCM scm_setvbuf (SCM port, SCM mode, SCM size); -SCM_API int scm_fill_input (SCM port); -SCM_API int scm_fill_input_unlocked (SCM port); +SCM_API scm_t_port_buffer* scm_fill_input (SCM port); +SCM_API scm_t_port_buffer* scm_fill_input_unlocked (SCM port); SCM_INTERNAL size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len); SCM_API SCM scm_drain_input (SCM port); SCM_API void scm_end_input (SCM port); @@ -422,13 +428,19 @@ scm_c_try_lock_port (SCM port, scm_i_pthread_mutex_t **lock) SCM_INLINE_IMPLEMENTATION int scm_get_byte_or_eof_unlocked (SCM port) { - scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_port_buffer *buf = SCM_PTAB_ENTRY (port)->read_buf; - if (SCM_LIKELY ((pt->rw_active == SCM_PORT_READ || !pt->rw_random) - && pt->read_pos < pt->read_end)) - return *pt->read_pos++; - else - return scm_slow_get_byte_or_eof_unlocked (port); + if (SCM_LIKELY (buf->cur < buf->end)) + return buf->buf[buf->cur++]; + + buf = scm_fill_input_unlocked (port); + if (buf->cur < buf->end) + return buf->buf[buf->cur++]; + + /* The next peek or get should cause the read() function to be called + to see if we still have EOF. */ + buf->has_eof = 0; + return EOF; } /* Like `scm_get_byte_or_eof' but does not change PORT's `read_pos'. */ @@ -436,12 +448,16 @@ SCM_INLINE_IMPLEMENTATION int scm_peek_byte_or_eof_unlocked (SCM port) { scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_port_buffer *buf = pt->read_buf; - if (SCM_LIKELY ((pt->rw_active == SCM_PORT_READ || !pt->rw_random) - && pt->read_pos < pt->read_end)) - return *pt->read_pos; - else - return scm_slow_peek_byte_or_eof_unlocked (port); + if (SCM_LIKELY (buf->cur < buf->end)) + return buf->buf[buf->cur]; + + buf = scm_fill_input_unlocked (port); + if (buf->cur < buf->end) + return buf->buf[buf->cur]; + + return EOF; } SCM_INLINE_IMPLEMENTATION void diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 9e12b5a52..aa54a0e67 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -78,87 +78,70 @@ SCM_DEFINE (scm_eof_object, "eof-object", 0, 0, 0, /* Bytevector input ports. */ static scm_t_bits bytevector_input_port_type = 0; +struct bytevector_input_port { + SCM bytevector; + size_t pos; +}; + static inline SCM make_bytevector_input_port (SCM bv) { - SCM port; - char *c_bv; - unsigned c_len; - scm_t_port *c_port; const unsigned long mode_bits = SCM_OPN | SCM_RDNG; + struct bytevector_input_port *stream; - port = scm_c_make_port_with_encoding (bytevector_input_port_type, + stream = scm_gc_typed_calloc (struct bytevector_input_port); + stream->bytevector = bv; + stream->pos = 0; + return scm_c_make_port_with_encoding (bytevector_input_port_type, mode_bits, NULL, /* encoding */ SCM_FAILED_CONVERSION_ERROR, - SCM_UNPACK (bv)); - - c_port = SCM_PTAB_ENTRY (port); - - /* Have the port directly access the bytevector. */ - c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); - c_len = SCM_BYTEVECTOR_LENGTH (bv); - - c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv; - c_port->read_end = (unsigned char *) c_bv + c_len; - c_port->read_buf_size = c_len; - - return port; + (scm_t_bits) stream); } -static int -bytevector_input_port_fill_input (SCM port) +static void +bytevector_input_port_read (SCM port, scm_t_port_buffer *buf) { - int result; - scm_t_port *c_port = SCM_PTAB_ENTRY (port); + size_t count; + struct bytevector_input_port *stream = (void *) SCM_STREAM (port); - if (c_port->read_pos >= c_port->read_end) - result = EOF; - else - result = (int) *c_port->read_pos; + if (stream->pos >= SCM_BYTEVECTOR_LENGTH (stream->bytevector)) + return; - return result; + count = SCM_BYTEVECTOR_LENGTH (stream->bytevector) - stream->pos; + if (count > buf->size - buf->end) + count = buf->size - buf->end; + + memcpy (buf->buf + buf->end, + SCM_BYTEVECTOR_CONTENTS (stream->bytevector) + stream->pos, + count); + + buf->end += count; + stream->pos += count; } static scm_t_off bytevector_input_port_seek (SCM port, scm_t_off offset, int whence) #define FUNC_NAME "bytevector_input_port_seek" { - scm_t_off c_result = 0; - scm_t_port *c_port = SCM_PTAB_ENTRY (port); + struct bytevector_input_port *stream = (void *) SCM_STREAM (port); + scm_t_off target; - switch (whence) - { - case SEEK_CUR: - offset += c_port->read_pos - c_port->read_buf; - /* Fall through. */ + if (whence == SEEK_CUR) + target = offset + stream->pos; + else if (whence == SEEK_SET) + target = offset; + else if (whence == SEEK_END) + target = offset + SCM_BYTEVECTOR_LENGTH (stream->bytevector); + else + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, "invalid `seek' parameter"); - case SEEK_SET: - if (c_port->read_buf + offset <= c_port->read_end) - { - c_port->read_pos = c_port->read_buf + offset; - c_result = offset; - } - else - scm_out_of_range (FUNC_NAME, scm_from_int (offset)); - break; + if (target >= 0 && target <= SCM_BYTEVECTOR_LENGTH (stream->bytevector)) + stream->pos = target; + else + scm_out_of_range (FUNC_NAME, scm_from_long (offset)); - case SEEK_END: - if (c_port->read_end - offset >= c_port->read_buf) - { - c_port->read_pos = c_port->read_end - offset; - c_result = c_port->read_pos - c_port->read_buf; - } - else - scm_out_of_range (FUNC_NAME, scm_from_int (offset)); - break; - - default: - scm_wrong_type_arg_msg (FUNC_NAME, 0, port, - "invalid `seek' parameter"); - } - - return c_result; + return target; } #undef FUNC_NAME @@ -169,7 +152,7 @@ initialize_bytevector_input_ports (void) { bytevector_input_port_type = scm_make_port_type ("r6rs-bytevector-input-port", - bytevector_input_port_fill_input, + bytevector_input_port_read, NULL); scm_set_port_seek (bytevector_input_port_type, bytevector_input_port_seek); @@ -198,7 +181,6 @@ SCM_DEFINE (scm_open_bytevector_input_port, output custom binary ports. */ struct custom_binary_port { - SCM read_buffer; SCM read; SCM write; SCM get_position; @@ -274,154 +256,53 @@ custom_binary_port_close (SCM port) static scm_t_bits custom_binary_input_port_type = 0; -/* Initial size of the buffer embedded in custom binary input ports. */ -#define CUSTOM_BINARY_INPUT_PORT_BUFFER_SIZE 8192 - - -/* Set PORT's internal buffer according to READ_SIZE. */ -static void -custom_binary_input_port_setvbuf (SCM port, long read_size, long write_size) -{ - SCM bv; - scm_t_port *pt; - struct custom_binary_port *stream = (void *) SCM_STREAM (port); - - pt = SCM_PTAB_ENTRY (port); - bv = stream->read_buffer; - - switch (read_size) - { - case 0: - /* Unbuffered: keep using PORT's bytevector as the underlying - buffer (it will also be used by future 'scm_c_read' calls.) */ - assert (SCM_BYTEVECTOR_LENGTH (bv) >= 1); - pt->read_buf = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); - pt->read_buf_size = 1; - break; - - case -1: - /* Preferred size: keep the current bytevector and use it as the - backing store. */ - pt->read_buf = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); - pt->read_buf_size = SCM_BYTEVECTOR_LENGTH (bv); - break; - - default: - /* Fully buffered: allocate a buffer of READ_SIZE bytes. */ - bv = scm_c_make_bytevector (read_size); - stream->read_buffer = bv; - pt->read_buf = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); - pt->read_buf_size = read_size; - } - - pt->read_pos = pt->read_end = pt->read_buf; -} - static inline SCM make_custom_binary_input_port (SCM read_proc, SCM get_position_proc, SCM set_position_proc, SCM close_proc) { - SCM port, bv; - char *c_bv; - unsigned c_len; - scm_t_port *c_port; struct custom_binary_port *stream; const unsigned long mode_bits = SCM_OPN | SCM_RDNG; - /* Use a bytevector as the underlying buffer. */ - c_len = CUSTOM_BINARY_INPUT_PORT_BUFFER_SIZE; - bv = scm_c_make_bytevector (c_len); - c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); - stream = scm_gc_typed_calloc (struct custom_binary_port); - stream->read_buffer = bv; stream->read = read_proc; stream->write = SCM_BOOL_F; stream->get_position = get_position_proc; stream->set_position_x = set_position_proc; stream->close = close_proc; - port = scm_c_make_port_with_encoding (custom_binary_input_port_type, + return scm_c_make_port_with_encoding (custom_binary_input_port_type, mode_bits, NULL, /* encoding */ SCM_FAILED_CONVERSION_ERROR, (scm_t_bits) stream); - - c_port = SCM_PTAB_ENTRY (port); - - /* Have the port directly access the buffer (bytevector). */ - c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv; - c_port->read_end = (unsigned char *) c_bv; - c_port->read_buf_size = c_len; - - return port; } -static int -custom_binary_input_port_fill_input (SCM port) -#define FUNC_NAME "custom_binary_input_port_fill_input" +static void +custom_binary_input_port_read (SCM port, scm_t_port_buffer *buf) +#define FUNC_NAME "custom_binary_input_port_read" { - int result; - scm_t_port *c_port = SCM_PTAB_ENTRY (port); struct custom_binary_port *stream = (void *) SCM_STREAM (port); + SCM bv, octets; + size_t c_octets; - if (c_port->read_pos >= c_port->read_end) - { - /* Invoke the user's `read!' procedure. */ - int buffered; - size_t c_octets, c_requested; - SCM bv, octets; + /* FIXME: We need to make sure buf->buf is kept alive. If read_buf is + referenced from PORT, passing PORT as the parent will do it. But, + pushback could re-set PORT->read_buf, which would be a fail. But, + probably buf->buf is itself GC-allocated, so we can pack it + directly. But, perhaps it's not, as in scm_c_read(). In that + latter case we're kinda screwed and probably need to prevent + rewinding. But shouldn't we always prevent rewinding? And how can + we avoid allocating the bytevector at all? */ + bv = scm_c_take_gc_bytevector ((signed char *) (buf->buf + buf->end), + buf->size - buf->end, + PTR2SCM (buf->buf)); - c_requested = c_port->read_buf_size; + octets = scm_call_3 (stream->read, bv, SCM_INUM0, scm_bytevector_length (bv)); + c_octets = scm_to_size_t (octets); + if (c_octets > scm_c_bytevector_length (bv)) + scm_out_of_range (FUNC_NAME, octets); - bv = stream->read_buffer; - buffered = - (c_port->read_buf == (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv)); - - if (buffered) - { - /* Make sure the buffer isn't corrupt. Its size can be 1 when - someone called 'setvbuf' with 'none. BV can be passed - directly to READ_PROC. */ - assert (c_port->read_buf_size == SCM_BYTEVECTOR_LENGTH (bv) - || c_port->read_buf_size == 1); - c_port->read_pos = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); - } - else - { - /* This is an unbuffered port. When called via the - 'get-bytevector-*' procedures, and thus via 'scm_c_read', we - are passed the caller-provided buffer, so we need to check its - size. */ - if (SCM_BYTEVECTOR_LENGTH (bv) < c_requested) - /* Bad luck: we have to make another allocation. Save that - nbytevector for later reuse, in the hope that the application - has regular access patterns. */ - stream->read_buffer = bv = scm_c_make_bytevector (c_requested); - } - - octets = scm_call_3 (stream->read, bv, SCM_INUM0, - scm_from_size_t (c_requested)); - c_octets = scm_to_size_t (octets); - if (SCM_UNLIKELY (c_octets > c_requested)) - scm_out_of_range (FUNC_NAME, octets); - - if (!buffered) - /* Copy the data back to the internal buffer. */ - memcpy ((char *) c_port->read_pos, SCM_BYTEVECTOR_CONTENTS (bv), - c_octets); - - c_port->read_end = (unsigned char *) c_port->read_pos + c_octets; - - if (c_octets != 0 || c_requested == 0) - result = (int) *c_port->read_pos; - else - result = EOF; - } - else - result = (int) *c_port->read_pos; - - return result; + buf->end += c_octets; } #undef FUNC_NAME @@ -459,12 +340,10 @@ initialize_custom_binary_input_ports (void) { custom_binary_input_port_type = scm_make_port_type ("r6rs-custom-binary-input-port", - custom_binary_input_port_fill_input, NULL); + custom_binary_input_port_read, NULL); scm_set_port_seek (custom_binary_input_port_type, custom_binary_port_seek); scm_set_port_close (custom_binary_input_port_type, custom_binary_port_close); - scm_set_port_setvbuf (custom_binary_input_port_type, - custom_binary_input_port_setvbuf); } @@ -603,29 +482,20 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0, "position to point just past these bytes.") #define FUNC_NAME s_scm_get_bytevector_some { - scm_t_port *pt; + scm_t_port_buffer *buf; size_t size; SCM bv; SCM_VALIDATE_BINARY_INPUT_PORT (1, port); - pt = SCM_PTAB_ENTRY (port); - if (pt->rw_active == SCM_PORT_WRITE) - scm_flush_unlocked (port); - - if (pt->rw_random) - pt->rw_active = SCM_PORT_READ; - - if (pt->read_pos >= pt->read_end) + buf = scm_fill_input_unlocked (port); + if (buf->cur == buf->end) { - if (scm_fill_input_unlocked (port) == EOF) - return SCM_EOF_VAL; + buf->has_eof = 0; + return SCM_EOF_VAL; } - size = pt->read_end - pt->read_pos; - if (pt->read_buf == pt->putback_buf) - size += pt->saved_read_end - pt->saved_read_pos; - + size = buf->end - buf->cur; bv = scm_c_make_bytevector (size); scm_take_from_input_buffers (port, (char *) SCM_BYTEVECTOR_CONTENTS (bv), size); @@ -838,6 +708,10 @@ typedef struct size_t len; size_t pos; char *buffer; + + /* The get-bytevector procedure will flush this port, if it's + open. */ + SCM port; } scm_t_bytevector_output_port_buffer; @@ -853,6 +727,7 @@ bytevector_output_port_buffer_init (scm_t_bytevector_output_port_buffer *buf) { buf->total_len = buf->len = buf->pos = 0; buf->buffer = NULL; + /* Don't clear the port. */ } static inline void @@ -882,7 +757,6 @@ static inline SCM make_bytevector_output_port (void) { SCM port, proc; - scm_t_port *c_port; scm_t_bytevector_output_port_buffer *buf; const unsigned long mode_bits = SCM_OPN | SCM_WRTNG; @@ -895,31 +769,28 @@ make_bytevector_output_port (void) NULL, /* encoding */ SCM_FAILED_CONVERSION_ERROR, (scm_t_bits)buf); + buf->port = port; - c_port = SCM_PTAB_ENTRY (port); - - c_port->write_buf = c_port->write_pos = c_port->write_end = NULL; - c_port->write_buf_size = 0; - - /* Make the bytevector output port procedure. */ SCM_NEWSMOB (proc, bytevector_output_port_procedure, buf); - return (scm_values (scm_list_2 (port, proc))); + return scm_values (scm_list_2 (port, proc)); } -/* Write SIZE octets from DATA to PORT. */ +/* Write octets from WRITE_BUF to the backing store. */ static void -bytevector_output_port_write (SCM port, const void *data, size_t size) +bytevector_output_port_write (SCM port, scm_t_port_buffer *write_buf) { + size_t count; scm_t_bytevector_output_port_buffer *buf; buf = SCM_BYTEVECTOR_OUTPUT_PORT_BUFFER (port); + count = write_buf->end - write_buf->cur; - if (buf->pos + size > buf->total_len) - bytevector_output_port_buffer_grow (buf, buf->pos + size); + if (buf->pos + count > buf->total_len) + bytevector_output_port_buffer_grow (buf, buf->pos + count); - memcpy (buf->buffer + buf->pos, data, size); - buf->pos += size; + memcpy (buf->buffer + buf->pos, write_buf->buf + write_buf->cur, count); + buf->pos += count; buf->len = (buf->len > buf->pos) ? buf->len : buf->pos; } @@ -928,34 +799,25 @@ bytevector_output_port_seek (SCM port, scm_t_off offset, int whence) #define FUNC_NAME "bytevector_output_port_seek" { scm_t_bytevector_output_port_buffer *buf; + scm_t_off target; buf = SCM_BYTEVECTOR_OUTPUT_PORT_BUFFER (port); - switch (whence) - { - case SEEK_CUR: - offset += (scm_t_off) buf->pos; - /* Fall through. */ - case SEEK_SET: - if (offset < 0 || (unsigned) offset > buf->len) - scm_out_of_range (FUNC_NAME, scm_from_int (offset)); - else - buf->pos = offset; - break; + if (whence == SEEK_CUR) + target = offset + buf->pos; + else if (whence == SEEK_SET) + target = offset; + else if (whence == SEEK_END) + target = offset + buf->len; + else + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, "invalid `seek' parameter"); - case SEEK_END: - if (offset < 0 || (unsigned) offset >= buf->len) - scm_out_of_range (FUNC_NAME, scm_from_int (offset)); - else - buf->pos = buf->len - (offset + 1); - break; + if (target >= 0 && target <= buf->len) + buf->pos = target; + else + scm_out_of_range (FUNC_NAME, scm_from_long (offset)); - default: - scm_wrong_type_arg_msg (FUNC_NAME, 0, port, - "invalid `seek' parameter"); - } - - return buf->pos; + return target; } #undef FUNC_NAME @@ -968,6 +830,9 @@ SCM_SMOB_APPLY (bytevector_output_port_procedure, buf = (scm_t_bytevector_output_port_buffer *) SCM_SMOB_DATA (proc); + if (SCM_OPPORTP (buf->port)) + scm_flush (buf->port); + result_buf = *buf; bytevector_output_port_buffer_init (buf); @@ -1026,70 +891,58 @@ static inline SCM make_custom_binary_output_port (SCM write_proc, SCM get_position_proc, SCM set_position_proc, SCM close_proc) { - SCM port; - scm_t_port *c_port; struct custom_binary_port *stream; const unsigned long mode_bits = SCM_OPN | SCM_WRTNG; - /* Store the various methods and bytevector in a vector. */ stream = scm_gc_typed_calloc (struct custom_binary_port); - - stream->read_buffer = SCM_BOOL_F; stream->read = SCM_BOOL_F; stream->write = write_proc; stream->get_position = get_position_proc; stream->set_position_x = set_position_proc; stream->close = close_proc; - port = scm_c_make_port_with_encoding (custom_binary_output_port_type, + return scm_c_make_port_with_encoding (custom_binary_output_port_type, mode_bits, NULL, /* encoding */ SCM_FAILED_CONVERSION_ERROR, (scm_t_bits) stream); - - c_port = SCM_PTAB_ENTRY (port); - - /* Have the port directly access the buffer (bytevector). */ - c_port->write_buf = c_port->write_pos = c_port->write_end = NULL; - c_port->write_buf_size = c_port->read_buf_size = 0; - - return port; } -/* Write SIZE octets from DATA to PORT. */ +/* Flush octets from BUF to the backing store. */ static void -custom_binary_output_port_write (SCM port, const void *data, size_t size) +custom_binary_output_port_write (SCM port, scm_t_port_buffer *buf) #define FUNC_NAME "custom_binary_output_port_write" { - long int c_result; - size_t c_written; + size_t size, written; struct custom_binary_port *stream = (void *) SCM_STREAM (port); - SCM bv, result; + SCM bv; - /* XXX: Allocating a new bytevector at each `write' call is inefficient, - but necessary since (1) we don't control the lifetime of the buffer - pointed to by DATA, and (2) the `write!' procedure could capture the - bytevector it is passed. */ + /* FIXME: If BUF is the same as PORT->write_buf, then the data is + GC-managed and we could avoid allocating a new bytevector backing + store. Otherwise we have to copy, as we do here. */ + size = buf->end - buf->cur; bv = scm_c_make_bytevector (size); - memcpy (SCM_BYTEVECTOR_CONTENTS (bv), data, size); + memcpy (SCM_BYTEVECTOR_CONTENTS (bv), buf->buf + buf->cur, size); /* Since the `write' procedure of Guile's ports has type `void', it must try hard to write exactly SIZE bytes, regardless of how many bytes the sink can handle. */ - for (c_written = 0; - c_written < size; - c_written += c_result) + written = 0; + while (written < size) { + long int c_result; + SCM result; + result = scm_call_3 (stream->write, bv, - scm_from_size_t (c_written), - scm_from_size_t (size - c_written)); + scm_from_size_t (written), + scm_from_size_t (size - written)); c_result = scm_to_long (result); - if (SCM_UNLIKELY (c_result < 0 - || (size_t) c_result > (size - c_written))) + if (c_result < 0 || (size_t) c_result > (size - written)) scm_wrong_type_arg_msg (FUNC_NAME, 0, result, "R6RS custom binary output port `write!' " "returned a incorrect integer"); + written += c_result; } } #undef FUNC_NAME @@ -1141,118 +994,60 @@ initialize_custom_binary_output_ports (void) static scm_t_bits transcoded_port_type = 0; -#define TRANSCODED_PORT_INPUT_BUFFER_SIZE 4096 - #define SCM_TRANSCODED_PORT_BINARY_PORT(_port) SCM_PACK (SCM_STREAM (_port)) static inline SCM make_transcoded_port (SCM binary_port, unsigned long mode) { SCM port; - scm_t_port *c_port; const unsigned long mode_bits = SCM_OPN | mode; port = scm_c_make_port (transcoded_port_type, mode_bits, SCM_UNPACK (binary_port)); - if (SCM_INPUT_PORT_P (port)) - { - c_port = SCM_PTAB_ENTRY (port); - c_port->read_buf = - scm_gc_malloc_pointerless (TRANSCODED_PORT_INPUT_BUFFER_SIZE, - "port buffer"); - c_port->read_pos = c_port->read_end = c_port->read_buf; - c_port->read_buf_size = TRANSCODED_PORT_INPUT_BUFFER_SIZE; - - SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~SCM_BUF0); - } - return port; } static void -transcoded_port_write (SCM port, const void *data, size_t size) +transcoded_port_write (SCM port, scm_t_port_buffer *buf) { - scm_c_write_unlocked (SCM_TRANSCODED_PORT_BINARY_PORT (port), data, size); + SCM bport = SCM_TRANSCODED_PORT_BINARY_PORT (port); + scm_c_write_unlocked (bport, buf->buf + buf->cur, buf->end - buf->cur); } -static int -transcoded_port_fill_input (SCM port) +static void +transcoded_port_read (SCM port, scm_t_port_buffer *buf) { size_t count; - scm_t_port *c_port = SCM_PTAB_ENTRY (port); - SCM bport = SCM_TRANSCODED_PORT_BINARY_PORT (port); - scm_t_port *c_bport = SCM_PTAB_ENTRY (bport); + scm_t_port_buffer *bport_buf; /* We can't use `scm_c_read' here, since it blocks until the whole block has been read or EOF. */ - if (c_bport->rw_active == SCM_PORT_WRITE) - scm_force_output (bport); + bport_buf = scm_fill_input (SCM_TRANSCODED_PORT_BINARY_PORT (port)); + /* Consume EOF from bport. */ + bport_buf->has_eof = 0; + count = bport_buf->end - bport_buf->cur; + if (count > buf->size - buf->end) + count = buf->size - buf->end; - if (c_bport->read_pos >= c_bport->read_end) - scm_fill_input_unlocked (bport); - - count = c_bport->read_end - c_bport->read_pos; - if (count > c_port->read_buf_size) - count = c_port->read_buf_size; - - memcpy (c_port->read_buf, c_bport->read_pos, count); - c_bport->read_pos += count; - - if (c_bport->rw_random) - c_bport->rw_active = SCM_PORT_READ; - - if (count == 0) - return EOF; - else - { - c_port->read_pos = c_port->read_buf; - c_port->read_end = c_port->read_buf + count; - return *c_port->read_buf; - } -} - -static void -transcoded_port_flush (SCM port) -{ - SCM binary_port = SCM_TRANSCODED_PORT_BINARY_PORT (port); - scm_t_port *c_port = SCM_PTAB_ENTRY (port); - size_t count = c_port->write_pos - c_port->write_buf; - - /* As the runtime will try to flush all ports upon exit, we test for - the underlying port still being open here. Otherwise, when you - would explicitly close the underlying port and the transcoded port - still had data outstanding, you'd get an exception on Guile exit. - - We just throw away the data when the underlying port is closed. */ - - if (SCM_OPOUTPORTP (binary_port)) - scm_c_write_unlocked (binary_port, c_port->write_buf, count); - - c_port->write_pos = c_port->write_buf; - - if (SCM_OPOUTPORTP (binary_port)) - scm_force_output (binary_port); + memcpy (buf->buf + buf->end, bport_buf->buf + bport_buf->cur, count); + bport_buf->cur += count; + buf->end += count; } static void transcoded_port_close (SCM port) { - SCM bport = SCM_TRANSCODED_PORT_BINARY_PORT (port); - if (SCM_OUTPUT_PORT_P (port)) - transcoded_port_flush (port); - scm_close_port (bport); + scm_close_port (SCM_TRANSCODED_PORT_BINARY_PORT (port)); } static inline void initialize_transcoded_ports (void) { transcoded_port_type = - scm_make_port_type ("r6rs-transcoded-port", transcoded_port_fill_input, + scm_make_port_type ("r6rs-transcoded-port", transcoded_port_read, transcoded_port_write); - - scm_set_port_flush (transcoded_port_type, transcoded_port_flush); scm_set_port_close (transcoded_port_type, transcoded_port_close); scm_set_port_needs_close_on_gc (transcoded_port_type, 1); } diff --git a/libguile/read.c b/libguile/read.c index 346bcc969..27cb094b9 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -2057,6 +2057,7 @@ char * scm_i_scan_for_encoding (SCM port) { scm_t_port *pt; + scm_t_port_buffer *buf; char header[SCM_ENCODING_SEARCH_SIZE+1]; size_t bytes_read, encoding_length, i; char *encoding = NULL; @@ -2064,6 +2065,7 @@ scm_i_scan_for_encoding (SCM port) int in_comment; pt = SCM_PTAB_ENTRY (port); + buf = pt->read_buf; if (pt->rw_random) { @@ -2072,13 +2074,11 @@ scm_i_scan_for_encoding (SCM port) pt->rw_active = SCM_PORT_READ; } - if (pt->read_pos == pt->read_end) + if (buf->cur == buf->end) { /* We can use the read buffer, and thus avoid a seek. */ - if (scm_fill_input_unlocked (port) == EOF) - return NULL; - - bytes_read = pt->read_end - pt->read_pos; + buf = scm_fill_input_unlocked (port); + bytes_read = buf->end - buf->cur; if (bytes_read > SCM_ENCODING_SEARCH_SIZE) bytes_read = SCM_ENCODING_SEARCH_SIZE; @@ -2086,7 +2086,7 @@ scm_i_scan_for_encoding (SCM port) /* An unbuffered port -- don't scan. */ return NULL; - memcpy (header, pt->read_pos, bytes_read); + memcpy (header, buf->buf + buf->cur, bytes_read); header[bytes_read] = '\0'; } else diff --git a/libguile/rw.c b/libguile/rw.c index 75c280b4e..9bd23208a 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -231,22 +231,21 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0, { SCM port = (SCM_UNBNDP (port_or_fdes)? scm_current_output_port () : port_or_fdes); - scm_t_port *pt; - scm_t_off space; + scm_t_port_buffer *write_buf; SCM_VALIDATE_OPFPORT (2, port); SCM_VALIDATE_OUTPUT_PORT (2, port); - pt = SCM_PTAB_ENTRY (port); - /* filling the last character in the buffer would require a flush. */ - space = pt->write_end - pt->write_pos - 1; - if (space >= write_len) + write_buf = SCM_PTAB_ENTRY (port)->write_buf; + + /* Filling the last character in the buffer would require a + flush. */ + if (write_len < write_buf->size - write_buf->end) { - memcpy (pt->write_pos, src, write_len); - pt->write_pos += write_len; + scm_c_write_unlocked (port, src, write_len); return scm_from_long (write_len); } - if (pt->write_pos > pt->write_buf) - scm_flush_unlocked (port); + + scm_flush_unlocked (port); fdes = SCM_FPORT_FDES (port); } { diff --git a/libguile/strports.c b/libguile/strports.c index 064e2f04a..6ad7d18f2 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -52,171 +52,90 @@ * */ -/* NOTES: - - write_buf/write_end point to the ends of the allocated bytevector. - read_buf/read_end point to the part of the bytevector which has been - written to. read_pos and write_pos are always equal. - - ENHANCE-ME - output blocks: - - The current code keeps an output string as a single block. That means - when the size is increased the entire old contents must be copied. It'd - be more efficient to begin a new block when the old one is full, so - there's no re-copying of previous data. - - To make seeking efficient, keeping the pieces in a vector might be best, - though appending is probably the most common operation. The size of each - block could be progressively increased, so the bigger the string the - bigger the blocks. - - When `get-output-string' is called the blocks have to be coalesced into a - string, the result could be kept as a single big block. If blocks were - strings then `get-output-string' could notice when there's just one and - return that with a copy-on-write (though repeated calls to - `get-output-string' are probably unlikely). - - Another possibility would be to extend the port mechanism to let SCM - strings come through directly from `display' and friends. That way if a - big string is written it can be kept as a copy-on-write, saving time - copying and maybe saving some space. */ - - scm_t_bits scm_tc16_strport; +struct string_port { + SCM bytevector; + size_t pos; + size_t len; +}; -static int -st_fill_input (SCM port) -{ - scm_t_port *pt = SCM_PTAB_ENTRY (port); - - if (pt->read_pos >= pt->read_end) - return EOF; - else - return *pt->read_pos; -} - -/* Change the size of a port's bytevector to NEW_SIZE. This doesn't - change `read_buf_size'. */ static void -st_resize_port (scm_t_port *pt, scm_t_off new_size) +string_port_read (SCM port, scm_t_port_buffer *dst) { - SCM old_stream = SCM_PACK (pt->stream); - const signed char *src = SCM_BYTEVECTOR_CONTENTS (old_stream); - SCM new_stream = scm_c_make_bytevector (new_size); - signed char *dst = SCM_BYTEVECTOR_CONTENTS (new_stream); - unsigned long int old_size = SCM_BYTEVECTOR_LENGTH (old_stream); - unsigned long int min_size = min (old_size, new_size); + size_t count; + struct string_port *stream = (void *) SCM_STREAM (port); - scm_t_off offset = pt->write_pos - pt->write_buf; + if (stream->pos >= stream->len) + return; - pt->write_buf_size = new_size; + count = stream->len - stream->pos; + if (count > dst->size - dst->end) + count = dst->size - dst->end; - memcpy (dst, src, min_size); - - scm_remember_upto_here_1 (old_stream); - - /* reset buffer. */ - { - pt->stream = SCM_UNPACK (new_stream); - pt->read_buf = pt->write_buf = (unsigned char *)dst; - pt->read_pos = pt->write_pos = pt->write_buf + offset; - pt->write_end = pt->write_buf + pt->write_buf_size; - pt->read_end = pt->read_buf + pt->read_buf_size; - } + memcpy (dst->buf + dst->end, + SCM_BYTEVECTOR_CONTENTS (stream->bytevector) + stream->pos, + count); + dst->end += count; + stream->pos += count; } static void -st_write (SCM port, const void *data, size_t size) +string_port_write (SCM port, scm_t_port_buffer *src) { - scm_t_port *pt = SCM_PTAB_ENTRY (port); + struct string_port *stream = (void *) SCM_STREAM (port); + size_t count = src->end - src->cur; - if (size > pt->write_end - pt->write_pos) - st_resize_port (pt, max (pt->write_buf_size * 2, - pt->write_end - pt->write_pos + size)); - - memcpy ((char *) pt->write_pos, data, size); - pt->read_pos = (pt->write_pos += size); - - if (pt->read_pos > pt->read_end) + if (SCM_BYTEVECTOR_LENGTH (stream->bytevector) < stream->pos + count) { - pt->read_end = (unsigned char *) pt->read_pos; - pt->read_buf_size = pt->read_end - pt->read_buf; + SCM new_bv; + size_t new_size; + + new_size = max (SCM_BYTEVECTOR_LENGTH (stream->bytevector) * 2, + stream->pos + count); + new_bv = scm_c_make_bytevector (new_size); + memcpy (SCM_BYTEVECTOR_CONTENTS (new_bv), + SCM_BYTEVECTOR_CONTENTS (stream->bytevector), + stream->len); + stream->bytevector = new_bv; } -} -static void -st_end_input (SCM port, int offset) -{ - scm_t_port *pt = SCM_PTAB_ENTRY (port); - - if (pt->read_pos - pt->read_buf < offset) - scm_misc_error ("st_end_input", "negative position", SCM_EOL); - - pt->write_pos = (unsigned char *) (pt->read_pos = pt->read_pos - offset); + memcpy (SCM_BYTEVECTOR_CONTENTS (stream->bytevector) + stream->pos, + src->buf + src->cur, + count); + src->cur += count; + stream->pos += count; + if (stream->pos > stream->len) + stream->len = stream->pos; } static scm_t_off -st_seek (SCM port, scm_t_off offset, int whence) +string_port_seek (SCM port, scm_t_off offset, int whence) +#define FUNC_NAME "string_port_seek" { - scm_t_port *pt = SCM_PTAB_ENTRY (port); + struct string_port *stream = (void *) SCM_STREAM (port); scm_t_off target; - switch (whence) - { - case SEEK_CUR: - target = pt->read_pos - pt->read_buf + offset; - break; - case SEEK_END: - target = pt->read_end - pt->read_buf + offset; - break; - default: /* SEEK_SET */ - target = offset; - break; - } + if (whence == SEEK_CUR) + target = offset + stream->pos; + else if (whence == SEEK_SET) + target = offset; + else if (whence == SEEK_END) + target = offset + stream->len; + else + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, "invalid `seek' parameter"); - if (target < 0) - scm_misc_error ("st_seek", "negative offset", SCM_EOL); - - if (target >= pt->write_buf_size) - { - if (!(SCM_CELL_WORD_0 (port) & SCM_WRTNG)) - { - if (target > pt->write_buf_size) - { - scm_misc_error ("st_seek", - "seek past end of read-only strport", - SCM_EOL); - } - } - else if (target == pt->write_buf_size) - st_resize_port (pt, target * 2); - } - - pt->read_pos = pt->write_pos = pt->read_buf + target; - if (pt->read_pos > pt->read_end) - { - pt->read_end = (unsigned char *) pt->read_pos; - pt->read_buf_size = pt->read_end - pt->read_buf; - } + if (target >= 0 && target <= stream->len) + stream->pos = target; + else + scm_out_of_range (FUNC_NAME, scm_from_long (offset)); return target; } +#undef FUNC_NAME -static void -st_truncate (SCM port, scm_t_off length) -{ - scm_t_port *pt = SCM_PTAB_ENTRY (port); - - if (length > pt->write_buf_size) - st_resize_port (pt, length); - - pt->read_buf_size = length; - pt->read_end = pt->read_buf + length; - if (pt->read_pos > pt->read_end) - pt->read_pos = pt->write_pos = pt->read_end; -} + /* The initial size in bytes of a string port's buffer. */ #define INITIAL_BUFFER_SIZE 128 @@ -226,10 +145,9 @@ st_truncate (SCM port, scm_t_off length) SCM scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) { - SCM z, buf; - scm_t_port *pt; - size_t read_buf_size, num_bytes, c_byte_pos; - char *c_buf; + SCM buf; + size_t len, byte_pos; + struct string_port *stream; if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG))) scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL); @@ -237,54 +155,34 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) if (scm_is_false (str)) { /* Allocate a new buffer to write to. */ - num_bytes = INITIAL_BUFFER_SIZE; - buf = scm_c_make_bytevector (num_bytes); - c_buf = (char *) SCM_BYTEVECTOR_CONTENTS (buf); - - /* Reset `read_buf_size'. It will contain the actual number of - bytes written to the port. */ - read_buf_size = 0; - c_byte_pos = 0; + buf = scm_c_make_bytevector (INITIAL_BUFFER_SIZE); + len = byte_pos = 0; } else { - char *copy; - SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller); - /* STR is a string. */ - /* Create a copy of STR in UTF-8. */ - copy = scm_to_utf8_stringn (str, &num_bytes); - buf = scm_c_make_bytevector (num_bytes); - c_buf = (char *) SCM_BYTEVECTOR_CONTENTS (buf); - memcpy (c_buf, copy, num_bytes); - free (copy); - - read_buf_size = num_bytes; + buf = scm_string_to_utf8 (str); + len = scm_c_bytevector_length (buf); if (scm_is_eq (pos, SCM_INUM0)) - c_byte_pos = 0; + byte_pos = 0; else /* Inefficient but simple way to convert the character position - POS into a byte position C_BYTE_POS. */ + POS into a byte position BYTE_POS. */ free (scm_to_utf8_stringn (scm_substring (str, SCM_INUM0, pos), - &c_byte_pos)); + &byte_pos)); } - z = scm_c_make_port_with_encoding (scm_tc16_strport, modes, - "UTF-8", - scm_i_default_port_conversion_handler (), - SCM_UNPACK (buf)); + stream = scm_gc_typed_calloc (struct string_port); + stream->bytevector = buf; + stream->pos = byte_pos; + stream->len = len; - pt = SCM_PTAB_ENTRY (z); - - pt->write_buf = pt->read_buf = (unsigned char *) c_buf; - pt->read_pos = pt->write_pos = pt->read_buf + c_byte_pos; - pt->read_buf_size = read_buf_size; - pt->write_buf_size = num_bytes; - pt->write_end = pt->read_end = pt->read_buf + pt->read_buf_size; - - return z; + return scm_c_make_port_with_encoding (scm_tc16_strport, modes, + "UTF-8", + scm_i_default_port_conversion_handler (), + (scm_t_bits) stream); } /* Create a new string from the buffer of PORT, a string port, converting from @@ -292,12 +190,16 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) SCM scm_strport_to_string (SCM port) { - scm_t_port *pt = SCM_PTAB_ENTRY (port); + signed char *ptr; + struct string_port *stream = (void *) SCM_STREAM (port); - if (pt->read_buf_size == 0) + scm_flush (port); + + if (stream->len == 0) return scm_nullstr; - return scm_from_port_stringn ((char *)pt->read_buf, pt->read_buf_size, port); + ptr = SCM_BYTEVECTOR_CONTENTS (stream->bytevector); + return scm_from_port_stringn ((char *) ptr, stream->len, port); } SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0, @@ -364,7 +266,7 @@ SCM_DEFINE (scm_open_input_string, "open-input-string", 1, 0, 0, "by the garbage collector if it becomes inaccessible.") #define FUNC_NAME s_scm_open_input_string { - SCM p = scm_mkstrport(SCM_INUM0, str, SCM_OPN | SCM_RDNG, FUNC_NAME); + SCM p = scm_mkstrport (SCM_INUM0, str, SCM_OPN | SCM_RDNG, FUNC_NAME); return p; } #undef FUNC_NAME @@ -473,13 +375,12 @@ scm_eval_string (SCM string) } static scm_t_bits -scm_make_stptob () +scm_make_string_port_type () { - scm_t_bits tc = scm_make_port_type ("string", st_fill_input, st_write); - - scm_set_port_end_input (tc, st_end_input); - scm_set_port_seek (tc, st_seek); - scm_set_port_truncate (tc, st_truncate); + scm_t_bits tc = scm_make_port_type ("string", + string_port_read, + string_port_write); + scm_set_port_seek (tc, string_port_seek); return tc; } @@ -487,7 +388,7 @@ scm_make_stptob () void scm_init_strports () { - scm_tc16_strport = scm_make_stptob (); + scm_tc16_strport = scm_make_string_port_type (); #include "libguile/strports.x" } diff --git a/libguile/vports.c b/libguile/vports.c index 65041283d..82fef1e0b 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -22,6 +22,7 @@ # include #endif +#include #include #include @@ -58,73 +59,68 @@ struct soft_port { SCM read_char; SCM close; SCM input_waiting; + scm_t_port_buffer *encode_buf; }; +/* Sadly it seems that most code expects there to be no write buffering + at all. */ static void -soft_port_flush (SCM port) +soft_port_get_natural_buffer_sizes (SCM port, size_t *read_size, + size_t *write_size) +{ + *write_size = 1; +} + +static void +soft_port_write (SCM port, scm_t_port_buffer *buf) { struct soft_port *stream = (void *) SCM_STREAM (port); + scm_t_uint8 * ptr = buf->buf + buf->cur; + SCM str = scm_from_port_stringn ((char *) ptr, buf->end - buf->cur, port); + buf->end = buf->cur = 0; + scm_call_1 (stream->write_string, str); + + /* Backwards compatibility. */ if (scm_is_true (stream->flush)) scm_call_0 (stream->flush); } -static void -soft_port_write (SCM port, const void *data, size_t size) -{ - struct soft_port *stream = (void *) SCM_STREAM (port); - - /* DATA is assumed to be a locale-encoded C string, which makes it - hard to reliably pass binary data to a soft port. It can be - achieved by choosing a Latin-1 locale, though, but the recommended - approach is to use an R6RS "custom binary output port" instead. */ - scm_call_1 (stream->write_string, - scm_from_locale_stringn ((char *) data, size)); -} - -/* calling the flush proc (element 2) is in case old code needs it, - but perhaps softports could the use port buffer in the same way as - fports. */ - /* places a single char in the input buffer. */ -static int -soft_port_fill_input (SCM port) +static void +soft_port_read (SCM port, scm_t_port_buffer *dst) { struct soft_port *stream = (void *) SCM_STREAM (port); - SCM ans; - scm_t_wchar c; - scm_t_port_internal *pti; + scm_t_port_buffer *encode_buf = stream->encode_buf; - ans = scm_call_0 (stream->read_char); - if (scm_is_false (ans) || SCM_EOF_OBJECT_P (ans)) - return EOF; - SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "soft_port_fill_input"); - pti = SCM_PORT_GET_INTERNAL (port); - - c = SCM_CHAR (ans); - - if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1 - || (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8 && c < 0xff)) + /* A character can be more than one byte, but we don't have a + guarantee that there is more than one byte in the read buffer. So, + use an intermediate buffer. Terrible. This whole facility should + be (re)designed. */ + if (encode_buf->cur == encode_buf->end) { - scm_t_port *pt = SCM_PTAB_ENTRY (port); - - *pt->read_buf = c; - pt->read_pos = pt->read_buf; - pt->read_end = pt->read_buf + 1; - } - else - { - long line = SCM_LINUM (port); - int column = SCM_COL (port); + SCM ans; + char *str; + size_t len; - scm_ungetc_unlocked (c, port); + ans = scm_call_0 (stream->read_char); + if (scm_is_false (ans) || SCM_EOF_OBJECT_P (ans)) + return; + SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "soft_port_read"); - SCM_LINUM (port) = line; - SCM_COL (port) = column; + /* It's possible to make a fast path here, but it would be fastest + if the read procedure could fill its buffer directly. */ + str = scm_to_port_stringn (scm_string (scm_list_1 (ans)), &len, port); + assert (len > 0 && len <= encode_buf->size); + encode_buf->cur = 0; + encode_buf->end = len; + memcpy (encode_buf->buf, str, len); + free (str); } - return c; + while (dst->end < dst->size && encode_buf->cur < encode_buf->end) + dst->buf[dst->end++] = encode_buf->buf[encode_buf->cur++]; } @@ -199,7 +195,6 @@ SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, #define FUNC_NAME s_scm_make_soft_port { int vlen; - SCM z; struct soft_port *stream; SCM_VALIDATE_VECTOR (1, pv); @@ -216,11 +211,10 @@ SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, stream->input_waiting = vlen == 6 ? SCM_SIMPLE_VECTOR_REF (pv, 5) : SCM_BOOL_F; - z = scm_c_make_port (scm_tc16_soft_port, scm_i_mode_bits (modes), - (scm_t_bits) stream); - scm_port_non_buffer (SCM_PTAB_ENTRY (z)); + stream->encode_buf = scm_c_make_port_buffer (10); - return z; + return scm_c_make_port (scm_tc16_soft_port, scm_i_mode_bits (modes), + (scm_t_bits) stream); } #undef FUNC_NAME @@ -228,12 +222,13 @@ SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, static scm_t_bits scm_make_sfptob () { - scm_t_bits tc = scm_make_port_type ("soft", soft_port_fill_input, + scm_t_bits tc = scm_make_port_type ("soft", soft_port_read, soft_port_write); - scm_set_port_flush (tc, soft_port_flush); scm_set_port_close (tc, soft_port_close); scm_set_port_needs_close_on_gc (tc, 1); + scm_set_port_get_natural_buffer_sizes (tc, + soft_port_get_natural_buffer_sizes); scm_set_port_input_waiting (tc, soft_port_input_waiting); return tc; diff --git a/test-suite/standalone/test-scm-c-read.c b/test-suite/standalone/test-scm-c-read.c index 5f11e7565..86bca48ed 100644 --- a/test-suite/standalone/test-scm-c-read.c +++ b/test-suite/standalone/test-scm-c-read.c @@ -33,52 +33,39 @@ /* Size of our port's internal buffer. */ #define PORT_BUFFER_SIZE 1024 +struct custom_port +{ + size_t pos; + size_t len; + char *buf; +}; + + /* Return a new port of type PORT_TYPE. */ static inline SCM make_port (scm_t_bits port_type) { - SCM port; - char *c_buffer; - scm_t_port *c_port; + struct custom_port *stream = scm_gc_typed_calloc (struct custom_port); - c_buffer = scm_gc_calloc (PORT_BUFFER_SIZE, "custom-port-buffer"); + stream->pos = 0; + stream->len = PORT_BUFFER_SIZE; + stream->buf = scm_gc_calloc (stream->len, "custom-port-buffer"); - port = scm_new_port_table_entry (port_type); - - /* Associate C_BUFFER with PORT, for test purposes. */ - SCM_SETSTREAM (port, (scm_t_bits) c_buffer); - - /* Use C_BUFFER as PORT's internal buffer. */ - c_port = SCM_PTAB_ENTRY (port); - c_port->read_pos = c_port->read_buf = (unsigned char *) c_buffer; - c_port->read_end = (unsigned char *) c_buffer + PORT_BUFFER_SIZE; - c_port->read_buf_size = PORT_BUFFER_SIZE; - - /* Mark PORT as open and readable. */ - SCM_SET_CELL_TYPE (port, port_type | SCM_OPN | SCM_RDNG); - - return port; + return scm_c_make_port (port_type, SCM_RDNG, (scm_t_bits) stream); } -/* Read one byte from PORT. */ -static int -fill_input (SCM port) +static void +custom_port_read (SCM port, scm_t_port_buffer *dst) { - int result; - scm_t_port *c_port = SCM_PTAB_ENTRY (port); + size_t to_copy = dst->size - dst->end; + struct custom_port *stream = (void *) SCM_STREAM (port); - /* Make sure that C_PORT's internal buffer wasn't changed behind our back. - See http://lists.gnu.org/archive/html/guile-devel/2008-11/msg00042.html - for an example where this assumption matters. */ - assert (c_port->read_buf == (unsigned char *) SCM_STREAM (port)); - assert (c_port->read_buf_size == PORT_BUFFER_SIZE); + if (stream->pos + to_copy > stream->len) + to_copy = stream->len - stream->pos; - if (c_port->read_pos >= c_port->read_end) - result = EOF; - else - result = (int) *c_port->read_pos++; - - return result; + memcpy (dst->buf + dst->end, stream->buf + stream->pos, to_copy); + stream->pos += to_copy; + dst->end += to_copy; } /* Return true (non-zero) if BUF contains only zeros. */ @@ -103,7 +90,7 @@ do_start (void *arg) char buffer[PORT_BUFFER_SIZE + (PORT_BUFFER_SIZE / 2)]; size_t read, last_read; - port_type = scm_make_port_type ("custom-input-port", fill_input, NULL); + port_type = scm_make_port_type ("custom-input-port", custom_port_read, NULL); port = make_port (port_type); read = 0; diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index 674768ea1..1441daf1b 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -789,6 +789,7 @@ not `set-port-position!'" (port (make-custom-binary-output-port "cbop" write! #f #f #f))) (put-bytevector port source) + (force-output port) (and (= sink-pos (bytevector-length source)) (not eof?) (bytevector=? sink source)))) @@ -813,6 +814,7 @@ not `set-port-position!'" (port (make-custom-binary-output-port "cbop" write! #f #f #f))) (put-bytevector port source) + (force-output port) (and (= sink-pos (bytevector-length source)) (not eof?) (bytevector=? sink source)))) @@ -873,6 +875,7 @@ not `set-port-position!'" (let* ((t (make-transcoder (latin-1-codec) (native-eol-style) (error-handling-mode raise))) (tp (transcoded-port p t))) + (setvbuf tp 'none) (guard (c ((i/o-encoding-error? c) (and (eq? (i/o-error-port c) tp) (char=? (i/o-encoding-error-char c) #\λ) diff --git a/test-suite/tests/web-client.test b/test-suite/tests/web-client.test index 3133b73c8..805baa9e9 100644 --- a/test-suite/tests/web-client.test +++ b/test-suite/tests/web-client.test @@ -471,8 +471,7 @@ Connection: close\r (error "Port closed for writing")) (put-u8 request-port (char->integer c))) (define (put-string s) - (string-for-each put-char s)) - (define (flush) + (string-for-each put-char s) (set! writing? #f) (set! reading? #t) (let* ((p (open-bytevector-input-port (get-bytevector))) @@ -500,8 +499,13 @@ Connection: close\r (when writing? (unless (eof-object? (get-u8 response-body-port)) (error "Failed to consume all of body")))) - (proc (make-soft-port (vector put-char put-string flush get-char close) - "rw")))))) + (let ((soft-port (make-soft-port + (vector put-char put-string #f get-char close) + "rw"))) + ;; Arrange it so that the only time our put-char/put-string + ;; functions are called is during force-output. + (setvbuf soft-port 'block 10000) + (proc soft-port)))))) (define* (check-transaction method uri request-headers request-body request-body-encoding From f5a0c167f62fc3c6a9874bfc7b3f43f3f6bacda2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 8 Apr 2016 20:56:41 +0200 Subject: [PATCH 200/865] Update NEWS for changes to port buffering. * NEWS: Update. --- NEWS | 37 ++++++++++++++++++++++++++++++++++--- 1 file changed, 34 insertions(+), 3 deletions(-) diff --git a/NEWS b/NEWS index c5a2a3f38..b1ea7db62 100644 --- a/NEWS +++ b/NEWS @@ -12,6 +12,13 @@ releasing 2.1.3. Changes in 2.1.3 (changes since the 2.1.2 alpha release): * Notable changes +** All ports are now buffered, can be targets of `setvbuf' + +See "Buffering" in the manual, for more. A port with a buffer size of 1 +is equivalent to an unbuffered port. Ports may set their default buffer +sizes, and some ports (for example soft ports) are unbuffered by default +for historical reasons. + * New deprecations ** `_IONBF', `_IOLBF', and `_IOFBF' @@ -19,18 +26,27 @@ Instead, use the symbol values `none', `line', or `block', respectively, as arguments to the `setvbuf' function. * Incompatible changes -** Remove `scm_set_port_mark' +** API to define new port types from C has changed + +In Guile 2.2 the API used to define new port types has changed. This +largely shouldn't affect port users, modulo the buffering port mentioned +above. However, in order to enable all ports to have buffers +implemented in the same way, which is a prerequisite to non-blocking +I/O, the port API has changed. See "I/O Extensions" in the manual, for +full details. Notably: + +*** Remove `scm_set_port_mark' Port mark functions have not been called since the switch to the BDW garbage collector. -** Remove `scm_set_port_equalp' +*** Remove `scm_set_port_equalp' Likewise port equal functions weren't being called. Given that ports have their own internal buffers, it doesn't make sense to hook them into equal? anyway. -** Remove `scm_set_port_free' +*** Remove `scm_set_port_free' It used to be that if an open port became unreachable, a special "free" function would be called instead of the "close" function. Now that the @@ -41,6 +57,21 @@ overhead. For that reason Guile exposes a new interface, `scm_set_port_needs_close_on_gc', allowing port implementations to indicate to Guile whether they need closing on GC or not. +*** Remove `scm_set_port_end_input', `scm_set_port_flush' + +As buffering is handled by Guile itself, these functions which were to +manage an implementation-side buffer are no longer needed. + +*** Change prototype of `scm_make_port_type' + +The `read' (renamed from `fill_input') and `write' functions now return +void and take a port buffer. + +*** Remove `SCM_INITIAL_PUTBACK_BUF_SIZE', `SCM_READ_BUFFER_EMPTY_P' + +Probably nobody used these. + + Changes in 2.1.2 (changes since the 2.1.1 alpha release): From 3ce52fa5034acd59eadc2d818cb813a336fb5b29 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 8 Apr 2016 21:03:18 +0200 Subject: [PATCH 201/865] Fold 2.1.2 NEWS items into cumulative 2.2 NEWS * NEWS: Update. --- NEWS | 181 ++++++++++++++++++++++------------------------------------- 1 file changed, 68 insertions(+), 113 deletions(-) diff --git a/NEWS b/NEWS index b1ea7db62..85cf5f576 100644 --- a/NEWS +++ b/NEWS @@ -5,9 +5,6 @@ See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. -FIXME: Incorporate 2.1.2 changes into cumulative 2.2 changes before -releasing 2.1.3. - Changes in 2.1.3 (changes since the 2.1.2 alpha release): @@ -72,114 +69,6 @@ void and take a port buffer. Probably nobody used these. - -Changes in 2.1.2 (changes since the 2.1.1 alpha release): - -* Notable changes - -** Unboxed arithmetic - -It used to be that Guile's numbers were always boxed with a tag -indicating their type. Small integers could sometimes represent their -tag and value in one word; these are the fixnums. Other kinds of -numbers would be allocated on the heap. - -Guile can now unbox arithmetic on exact integers (values in the signed -and unsigned 64-bit integer range) and inexact reals (floating-point -numbers). Access to bytevectors are always unboxed, and some arithmetic -can be unboxed as well. Unboxing eliminates run-time allocation for -numbers and removes run-time polymorphic dispatch, providing a -significant speedup. - -** Faster build times - -Building Guile from a tarball can now take advantage of a "prebuilt/" -tree of prebuilt .go files. These compiled files are created when a -tarball is made, and are used to speed up the build for users of -official releases. - -These pre-built binaries are not necessary, however: they are not stored -in revision control and can always be re-created from the source, given -that Guile can bootstrap itself from its minimal bootstrap C -interpreter. If you do not want to depend on these pre-built binaries, -you can "make -C prebuilt clean" before building. - -If Guile doesn't pre-build binaries for your architecture and you would -like support for your architecture, see prebuilt/Makefile.am for more -information on how to add support. - -** Better backtraces - -Guile's backtraces do a better job at finding the function name, and -they also do a better job printing function arguments whose values are -unavailable. - -** Add "tree" display mode for statprof. - -See the newly updated "Statprof" section of the manual, for more. - -** Many small compiler and VM improvements - -The user-visible change is that Guile is faster, for many small reasons. -See the commit log for detailed changes. - -Note that until the stable 2.2.0 release is made, we will not make any -efforts towards binary compatibility among 2.1.x releases. Compiled -Scheme files from older pre-releases in the Guile 2.1.x series are not -loadable by the Guile 2.1.2 pre-release. - -** Better handling of GUILE_LOAD_COMPILED_PATH - -It used to be that Guile would stop at the first .go file it found in -the GUILE_LOAD_COMPILED_PATH. If that file turned out to be out of -date, then no .go file would be loaded. Now Guile will continue to -search the path for a file which is both present and up-to-date, with -respect to the .scm file. - -** Fix build when threads are disabled -** Fix cross-compilation of .go files - -* New deprecations - -** `with-statprof' macro deprecated - -Use the `statprof' procedure instead. - -* Incompatible changes - -** Remove `frame-procedure' - -Several optimizations in Guile make `frame-procedure' an interface that -we can no longer support. For background, `frame-procedure' used to -return the value at slot 0 in a frame, which usually corresponds to the -SCM value of the procedure being applied. However it could be that this -slot is re-used for some other value, because the closure was not needed -in the function. Such a re-use might even be for an untagged value, in -which case treating slot 0 as a SCM value is quite dangerous. It's also -possible that so-called "well-known" closures (closures whose callers -are all known) are optimized in such a way that slot 0 is not a -procedure but some optimized representation of the procedure's free -variables. Instead, developers building debugging tools that would like -access to `frame-procedure' are invited to look at the source for the -`(system vm frame)' module for alternate interfaces, including the new -`frame-procedure-name'. - -** Remove `,procedure' REPL command - -Not all procedures have values, so it doesn't make sense to expose this -interface to the user. Instead, the `,locals' REPL command will include -the callee, if it is live. - -** Remove `frame-local-ref', `frame-local-set!', `frame-num-locals' - -These procedures reference values in a frame on the stack. Since we now -have unboxed values of different kinds, it is now necessary to specify -the type when reference locals, and once this incompatible change needs -to be made, we might as well make these interfaces private. See -"Frames' in the manual, for more information on the replacements for -these low-level interfaces. - - Previous changes in 2.1.x (changes since the 2.0.x series): @@ -276,6 +165,14 @@ in Scheme. This decreases its maintenance burden on the rest of Guile, while also makes it possible to implement new features in the future, such as method combinations or `eqv?' specializers. +** Better handling of GUILE_LOAD_COMPILED_PATH + +It used to be that Guile would stop at the first .go file it found in +the GUILE_LOAD_COMPILED_PATH. If that file turned out to be out of +date, then no .go file would be loaded. Now Guile will continue to +search the path for a file which is both present and up-to-date, with +respect to the .scm file. + * Performance improvements ** Faster programs via new virtual machine @@ -309,8 +206,9 @@ values and control flow. Examples of optimizations that this permits are optimal contification, optimal common subexpression elimination, dead code elimination, loop-invariant code motion, loop peeling, loop inversion, parallel moves with at most one temporary, allocation of -stack slots using precise liveness information, and closure -optimization. For more, see "Continuation-Passing Style" in the manual. +stack slots using precise liveness information, unboxing of 64-bit +integers and floating point values, and closure optimization. For more, +see "Continuation-Passing Style" in the manual. ** Faster interpreter @@ -365,6 +263,10 @@ See the "Guile Implementation" chapter in the manual for all details. See "Integers" in the manual, for more. +** Add "tree" display mode for statprof. + +See the newly updated "Statprof" section of the manual, for more. + ** New thread-safe port API For details on `scm_c_make_port', `scm_c_make_port_with_encoding', @@ -460,6 +362,38 @@ ports are both textual and binary, Guile's R6RS ports are also both textual and binary, and thus both kinds have port transcoders. This is an incompatibility with respect to R6RS. +** Remove `frame-procedure' + +Several optimizations in Guile make `frame-procedure' an interface that +we can no longer support. For background, `frame-procedure' used to +return the value at slot 0 in a frame, which usually corresponds to the +SCM value of the procedure being applied. However it could be that this +slot is re-used for some other value, because the closure was not needed +in the function. Such a re-use might even be for an untagged value, in +which case treating slot 0 as a SCM value is quite dangerous. It's also +possible that so-called "well-known" closures (closures whose callers +are all known) are optimized in such a way that slot 0 is not a +procedure but some optimized representation of the procedure's free +variables. Instead, developers building debugging tools that would like +access to `frame-procedure' are invited to look at the source for the +`(system vm frame)' module for alternate interfaces, including the new +`frame-procedure-name'. + +** Remove `,procedure' REPL command + +Not all procedures have values, so it doesn't make sense to expose this +interface to the user. Instead, the `,locals' REPL command will include +the callee, if it is live. + +** Remove `frame-local-ref', `frame-local-set!', `frame-num-locals' + +These procedures reference values in a frame on the stack. Since we now +have unboxed values of different kinds, it is now necessary to specify +the type when reference locals, and once this incompatible change needs +to be made, we might as well make these interfaces private. See +"Frames' in the manual, for more information on the replacements for +these low-level interfaces. + ** Vtable hierarchy changes In an attempt to make Guile's structure and record types integrate @@ -647,6 +581,10 @@ scm_t_debug_info', `scm_pure_generic_p', `SCM_PUREGENERICP', * New deprecations +** `with-statprof' macro deprecated + +Use the `statprof' procedure instead. + ** SCM_WTA_DISPATCH_0, SCM_WTA_DISPATCH_1, SCM_WTA_DISPATCH_2, SCM_WTA_DISPATCH_N ** SCM_GASSERT0, SCM_GASSERT1, SCM_GASSERT2, SCM_GASSERTn ** SCM_WTA_DISPATCH_1_SUBR @@ -699,6 +637,23 @@ Instead use the normal `scm_slot_ref' and similar procedures. * Changes to the distribution +** Pre-built binary files in the tarball + +Building Guile from a tarball can now take advantage of a "prebuilt/" +tree of prebuilt .go files. These compiled files are created when a +tarball is made, and are used to speed up the build for users of +official releases. + +These pre-built binaries are not necessary, however: they are not stored +in revision control and can always be re-created from the source, given +that Guile can bootstrap itself from its minimal bootstrap C +interpreter. If you do not want to depend on these pre-built binaries, +you can "make -C prebuilt clean" before building. + +If Guile doesn't pre-build binaries for your architecture and you would +like support for your architecture, see prebuilt/Makefile.am for more +information on how to add support. + ** New minor version The "effective version" of Guile is now 2.2, which allows parallel From 55fb8f4e7e8181ef09e49ea9d917ca25f9fe8159 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 11 Apr 2016 22:22:39 +0200 Subject: [PATCH 202/865] make-chunked-output-port buffering fix * module/web/http.scm (make-chunked-output-port): Add #:buffering argument, defaulting to 1200 (some random value under the MTU). This will force a flush every so often, and not every character as would otherwise be the case after this port rewrite. --- module/web/http.scm | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/module/web/http.scm b/module/web/http.scm index 8a07f6d0d..9e8e4a3a5 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -1972,13 +1972,15 @@ closed it will also close PORT, unless the KEEP-ALIVE? is true." (loop to-read 0)) (make-custom-binary-input-port "chunked input port" read! #f #f close)) -(define* (make-chunked-output-port port #:key (keep-alive? #f)) +(define* (make-chunked-output-port port #:key (keep-alive? #f) + (buffering 1200)) "Returns a new port which translates non-encoded data into a HTTP -chunked transfer encoded data and writes this to PORT. Data -written to this port is buffered until the port is flushed, at which -point it is all sent as one chunk. Take care to close the port when -done, as it will output the remaining data, and encode the final zero -chunk. When the port is closed it will also close PORT, unless +chunked transfer encoded data and writes this to PORT. Data written to +this port is buffered until the port is flushed, at which point it is +all sent as one chunk. The port will otherwise be flushed every +BUFFERING bytes, which defaults to 1200. Take care to close the port +when done, as it will output the remaining data, and encode the final +zero chunk. When the port is closed it will also close PORT, unless KEEP-ALIVE? is true." (define (q-for-each f q) (while (not (q-empty? q)) @@ -2005,7 +2007,9 @@ KEEP-ALIVE? is true." (force-output port) (unless keep-alive? (close-port port))) - (make-soft-port (vector put-char put-string flush #f close) "w")) + (let ((ret (make-soft-port (vector put-char put-string flush #f close) "w"))) + (setvbuf ret 'block buffering) + ret)) (define %http-proxy-port? (make-object-property)) (define (http-proxy-port? port) (%http-proxy-port? port)) From f7027a8b88452948cd6bf0fe2605ef3d9ef4dded Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 11 Apr 2016 18:40:03 +0200 Subject: [PATCH 203/865] Port read/write functions take bytevectors This will allow better Scheme integration for ports. * libguile/ports.h (scm_t_port_buffer): Change "holder" member to be a bytevector defined to have "buf" as its starting point. (scm_t_ptob_descriptor): Change read and write functions to take bytevectors as arguments and to return the number of octets read or written. (scm_make_port_type): Adapt accordingly. (scm_c_read_bytes, scm_c_write_bytes): New functions that take bytevectors. * libguile/ports.c (scm_make_port_type): Adapt to read/write function prototype change. (scm_c_make_port_buffer): Arrange to populate the "bytevector" field. (scm_i_read_bytes_unlocked): New function. (scm_i_read_unlocked): Use scm_i_read_bytes_unlocked. (scm_c_read_bytes_unlocked): New function. (scm_c_read_unlocked): Update comment, and always go through the buffer. (scm_c_read_bytes): New function. (scm_flush_unlocked): Use scm_i_write_unlocked instead of the port's write function. (scm_i_write_bytes_unlocked): New function. (scm_i_write_unlocked): Use scm_i_write_bytes_unlocked. (scm_c_write_bytes_unlocked): New function. (scm_c_write_unlocked): Always write through the buffer. (scm_c_write_bytes): New function. (scm_truncate_file): Remove unused variable. (void_port_read, void_port_write): Adapt to read/write prototype change. * libguile/fports.c (fport_read, fport_write): * libguile/r6rs-ports.c (bytevector_input_port_read) (custom_binary_input_port_read, bytevector_output_port_write) (custom_binary_output_port_write, transcoded_port_write) (transcoded_port_read): Adapt to read/write prototype change. (scm_get_bytevector_n, scm_get_bytevector_n_x) (scm_get_bytevector_all): Use scm_c_read_bytes. (scm_put_bytevector): Use scm_c_write_bytes. * libguile/strports.c (string_port_read, string_port_write): * libguile/vports.c (soft_port_write, soft_port_read): Adapt to read/write prototype change. * test-suite/standalone/test-scm-c-read.c (custom_port_read): Fix for read API change. --- libguile/fports.c | 26 +- libguile/ports.c | 351 +++++++++++++++++------- libguile/ports.h | 14 +- libguile/r6rs-ports.c | 153 ++++------- libguile/strports.c | 27 +- libguile/vports.c | 29 +- test-suite/standalone/test-scm-c-read.c | 12 +- 7 files changed, 372 insertions(+), 240 deletions(-) diff --git a/libguile/fports.c b/libguile/fports.c index 3e4756204..11aa1707b 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -578,29 +578,29 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) /* fill a port's read-buffer with a single read. returns the first char or EOF if end of file. */ -static void -fport_read (SCM port, scm_t_port_buffer *dst) +static size_t +fport_read (SCM port, SCM dst, size_t start, size_t count) { - long count; + long res; scm_t_fport *fp = SCM_FSTREAM (port); - scm_t_uint8 *ptr = dst->buf + dst->end; - size_t size = dst->size - dst->end; + signed char *ptr = SCM_BYTEVECTOR_CONTENTS (dst) + start; - SCM_SYSCALL (count = read (fp->fdes, ptr, size)); - if (count == -1) + SCM_SYSCALL (res = read (fp->fdes, ptr, count)); + if (res == -1) scm_syserror ("fport_read"); - dst->end += count; + return res; } -static void -fport_write (SCM port, scm_t_port_buffer *src) +static size_t +fport_write (SCM port, SCM src, size_t start, size_t count) { int fd = SCM_FPORT_FDES (port); - scm_t_uint8 *ptr = src->buf + src->cur; - size_t size = src->end - src->cur; + signed char *ptr = SCM_BYTEVECTOR_CONTENTS (src) + start; - if (full_write (fd, ptr, size) < size) + if (full_write (fd, ptr, count) < count) scm_syserror ("fport_write"); + + return count; } static scm_t_off diff --git a/libguile/ports.c b/libguile/ports.c index 8f07425e3..144daef3f 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -229,8 +229,10 @@ static const size_t default_buffer_size = 1024; scm_t_bits scm_make_port_type (char *name, - void (*read) (SCM port, scm_t_port_buffer *buf), - void (*write) (SCM port, scm_t_port_buffer *buf)) + size_t (*read) (SCM port, SCM dst, size_t start, + size_t count), + size_t (*write) (SCM port, SCM src, size_t start, + size_t count)) { scm_t_ptob_descriptor *desc; long ptobnum; @@ -527,7 +529,8 @@ scm_c_make_port_buffer (size_t size) scm_t_port_buffer *ret = scm_gc_typed_calloc (scm_t_port_buffer); ret->size = size; - ret->buf = scm_gc_malloc_pointerless (ret->size, "port buffer"); + ret->bytevector = scm_c_make_bytevector (size); + ret->buf = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (ret->bytevector); return ret; } @@ -1432,33 +1435,51 @@ scm_peek_byte_or_eof (SCM port) return ret; } +static size_t +scm_i_read_bytes_unlocked (SCM port, SCM dst, size_t start, size_t count) +{ + size_t filled; + scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port); + + assert (count <= SCM_BYTEVECTOR_LENGTH (dst)); + assert (start + count <= SCM_BYTEVECTOR_LENGTH (dst)); + + filled = ptob->read (port, dst, start, count); + + assert (filled <= count); + + return filled; +} + /* scm_i_read_unlocked is used internally to add bytes to the given port buffer. If the number of available bytes in the buffer does not increase after a call to scm_i_read_unlocked, that indicates EOF. */ static void scm_i_read_unlocked (SCM port, scm_t_port_buffer *buf) { - size_t prev_end = buf->end; + size_t count; + assert (buf->end < buf->size); - SCM_PORT_DESCRIPTOR (port)->read (port, buf); - buf->has_eof = buf->end == prev_end; + count = scm_i_read_bytes_unlocked (port, buf->bytevector, buf->end, + buf->size - buf->end); + buf->end += count; + buf->has_eof = count == 0; } -/* scm_c_read - * - * Used by an application to read arbitrary number of bytes from an SCM - * port. Same semantics as libc read, except that scm_c_read only - * returns less than SIZE bytes if at end-of-file. - * - * Warning: Doesn't update port line and column counts! */ -size_t -scm_c_read_unlocked (SCM port, void *buffer, size_t size) -#define FUNC_NAME "scm_c_read" +/* Used by an application to read arbitrary number of bytes from an SCM + port. Same semantics as libc read, except that scm_c_read_bytes only + returns less than SIZE bytes if at end-of-file. + + Warning: Doesn't update port line and column counts! */ +static size_t +scm_c_read_bytes_unlocked (SCM port, SCM dst, size_t start, size_t count) +#define FUNC_NAME "scm_c_read_bytes" { + size_t to_read = count; scm_t_port *pt; scm_t_port_buffer *read_buf; - scm_t_port_buffer dst_buf = { buffer, 0, 0, size, 0, NULL }; + signed char *dst_ptr = SCM_BYTEVECTOR_CONTENTS (dst) + start; SCM_VALIDATE_OPINPORT (1, port); @@ -1475,46 +1496,115 @@ scm_c_read_unlocked (SCM port, void *buffer, size_t size) /* Take bytes first from the port's read buffer. */ if (read_buf->cur < read_buf->end) { - size_t to_read = dst_buf.size - dst_buf.end; - to_read = min (to_read, read_buf->end - read_buf->cur); - memcpy (dst_buf.buf + dst_buf.end, read_buf->buf + read_buf->cur, - to_read); - dst_buf.end += to_read; - read_buf->cur += to_read; + size_t to_copy = count; + to_copy = min (to_copy, read_buf->end - read_buf->cur); + memcpy (dst_ptr, read_buf->buf + read_buf->cur, to_copy); + dst_ptr += to_copy; + to_read -= to_copy; + read_buf->cur += to_copy; } - while (dst_buf.end < dst_buf.size) - /* If the read buffering is larger than our read size, buffer the - read. Otherwise read into our buffer directly. */ - if (dst_buf.size - dst_buf.end < pt->read_buffering) - { - size_t to_read = dst_buf.size - dst_buf.end; - read_buf = scm_fill_input_unlocked (port); - if (to_read > read_buf->end - read_buf->cur) - to_read = read_buf->end - read_buf->cur; - if (to_read == 0) - { - /* Consider that we've read off this EOF. */ - read_buf->has_eof = 0; - break; - } - memcpy (dst_buf.buf + dst_buf.end, - read_buf->buf + read_buf->cur, - to_read); - read_buf->cur += to_read; - dst_buf.end += to_read; - } - else - { - scm_i_read_unlocked (port, &dst_buf); - if (dst_buf.has_eof) - break; - } + while (to_read) + { + /* If the read is smaller than the buffering on the read side of + this port, then go through the buffer. Otherwise fill our + buffer directly. */ + if (to_read < pt->read_buffering) + { + size_t to_copy = to_read; + read_buf = scm_fill_input_unlocked (port); + to_copy = min (to_copy, read_buf->end - read_buf->cur); + memcpy (dst_ptr, read_buf->buf + read_buf->cur, to_copy); + if (to_copy == 0) + { + /* Consider that we've read off this EOF. */ + read_buf->has_eof = 0; + break; + } + dst_ptr += to_copy; + to_read -= to_copy; + read_buf->cur += to_copy; + } + else + { + size_t filled; - return dst_buf.end; + filled = scm_i_read_bytes_unlocked (port, dst, + start + count - to_read, + to_read); + if (filled == 0) + break; + to_read -= filled; + dst_ptr += filled; + } + } + + return count - to_read; } #undef FUNC_NAME +/* Like scm_c_read_bytes, but always proxies reads through the port's + read buffer. Used by an application when it wants to read into a + memory chunk that's not owned by Guile's GC. */ +size_t +scm_c_read_unlocked (SCM port, void *buffer, size_t size) +#define FUNC_NAME "scm_c_read" +{ + size_t copied = 0; + scm_t_port *pt; + scm_t_port_buffer *read_buf; + scm_t_uint8 *dst = buffer; + + SCM_VALIDATE_OPINPORT (1, port); + + pt = SCM_PTAB_ENTRY (port); + read_buf = pt->read_buf; + + if (pt->rw_random) + { + if (pt->rw_active == SCM_PORT_WRITE) + scm_flush_unlocked (port); + pt->rw_active = SCM_PORT_READ; + } + + while (copied < size) + { + read_buf = scm_fill_input_unlocked (port); + /* Take bytes first from the port's read buffer. */ + if (read_buf->cur < read_buf->end) + { + size_t to_copy = size - copied; + to_copy = min (to_copy, read_buf->end - read_buf->cur); + memcpy (dst + copied, read_buf->buf + read_buf->cur, to_copy); + copied += to_copy; + read_buf->cur += to_copy; + } + else + { + /* Consider that we've read off this EOF. */ + read_buf->has_eof = 0; + break; + } + } + + return copied; +} +#undef FUNC_NAME + +size_t +scm_c_read_bytes (SCM port, SCM dst, size_t start, size_t count) +{ + scm_i_pthread_mutex_t *lock; + size_t ret; + + scm_c_lock_port (port, &lock); + ret = scm_c_read_bytes_unlocked (port, dst, start, count); + if (lock) + scm_i_pthread_mutex_unlock (lock); + + return ret; +} + size_t scm_c_read (SCM port, void *buffer, size_t size) { @@ -2447,13 +2537,14 @@ SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0, } #undef FUNC_NAME +static void scm_i_write_unlocked (SCM port, scm_t_port_buffer *src); + void scm_flush_unlocked (SCM port) { scm_t_port_buffer *buf = SCM_PTAB_ENTRY (port)->write_buf; if (buf->cur < buf->end) - SCM_PORT_DESCRIPTOR (port)->write (port, buf); - buf->cur = buf->end = 0; + scm_i_write_unlocked (port, buf); SCM_PTAB_ENTRY (port)->rw_active = SCM_PORT_NEITHER; } @@ -2520,27 +2611,56 @@ scm_puts (const char *s, SCM port) scm_i_pthread_mutex_unlock (lock); } -/* scm_c_write - * - * Used by an application to write arbitrary number of bytes to an SCM - * port. Similar semantics as libc write. However, unlike libc - * write, scm_c_write writes the requested number of bytes and has no - * return value. - * - * Warning: Doesn't update port line and column counts! - */ -void -scm_c_write_unlocked (SCM port, const void *ptr, size_t size) -#define FUNC_NAME "scm_c_write" +static void +scm_i_write_bytes_unlocked (SCM port, SCM src, size_t start, size_t count) +{ + size_t written; + scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port); + + assert (count <= SCM_BYTEVECTOR_LENGTH (src)); + assert (start + count <= SCM_BYTEVECTOR_LENGTH (src)); + + written = ptob->write (port, src, start, count); + + /* FIXME: Allow short writes? */ + assert (written == count); +} + +static void +scm_i_write_unlocked (SCM port, scm_t_port_buffer *src) +{ + size_t start, count; + + assert (src->cur < src->end); + assert (src->end <= src->size); + + /* Update cursors before attempting to write, assuming that I/O errors + are sticky. That way if the write throws an error, causing the + computation to abort, and possibly causing the port to be collected + by GC when it's open, any subsequent close-port / force-output + won't signal *another* error. */ + + start = src->cur; + count = src->end - src->cur; + src->cur = src->end = 0; + scm_i_write_bytes_unlocked (port, src->bytevector, start, count); +} + +/* Used by an application to write arbitrary number of bytes to an SCM + port. Similar semantics as libc write. However, unlike libc write, + scm_c_write writes the requested number of bytes. + + Warning: Doesn't update port line and column counts! */ +static size_t +scm_c_write_bytes_unlocked (SCM port, SCM src, size_t start, size_t count) +#define FUNC_NAME "scm_c_write_bytes" { scm_t_port *pt; scm_t_port_buffer *write_buf; - scm_t_ptob_descriptor *ptob; SCM_VALIDATE_OPOUTPORT (1, port); pt = SCM_PTAB_ENTRY (port); - ptob = SCM_PORT_DESCRIPTOR (port); write_buf = pt->write_buf; if (pt->rw_random) @@ -2550,7 +2670,7 @@ scm_c_write_unlocked (SCM port, const void *ptr, size_t size) pt->rw_active = SCM_PORT_WRITE; } - if (size < write_buf->size) + if (count < write_buf->size) { /* Make it so that write_buf->end is only nonzero if there are buffered bytes already. */ @@ -2562,36 +2682,72 @@ scm_c_write_unlocked (SCM port, const void *ptr, size_t size) flush it beforehand. Otherwise it could be that the buffer is full after filling it with the new data; if that's the case, we flush then instead. */ - if (write_buf->end + size > write_buf->size) - { - ptob->write (port, write_buf); - write_buf->cur = write_buf->end = 0; - } + if (write_buf->end + count > write_buf->size) + scm_i_write_unlocked (port, write_buf); - memcpy (write_buf->buf + write_buf->end, ptr, size); - write_buf->end += size; + memcpy (write_buf->buf + write_buf->end, + SCM_BYTEVECTOR_CONTENTS (src) + start, + count); + write_buf->end += count; if (write_buf->end == write_buf->size) - { - ptob->write (port, write_buf); - write_buf->cur = write_buf->end = 0; - } + scm_i_write_unlocked (port, write_buf); } else { /* Our write would overflow the buffer. Flush buffered bytes (if needed), then write our bytes with just one syscall. */ - - scm_t_port_buffer ad_hoc_buf = - { (scm_t_uint8 *) ptr, 0, size, size, 0, NULL }; + size_t written; if (write_buf->cur < write_buf->end) - { - ptob->write (port, write_buf); - write_buf->cur = write_buf->end = 0; - } + scm_i_write_unlocked (port, write_buf); - ptob->write (port, &ad_hoc_buf); + written = SCM_PORT_DESCRIPTOR (port)->write (port, src, start, count); + assert (written == count); + } + + return count; +} +#undef FUNC_NAME + +/* Like scm_c_write_bytes, but always writes through the write buffer. + Used when an application wants to write bytes stored in an area not + managed by GC. */ +void +scm_c_write_unlocked (SCM port, const void *ptr, size_t size) +#define FUNC_NAME "scm_c_write" +{ + scm_t_port *pt; + scm_t_port_buffer *write_buf; + size_t written = 0; + const scm_t_uint8 *src = ptr; + + SCM_VALIDATE_OPOUTPORT (1, port); + + pt = SCM_PTAB_ENTRY (port); + write_buf = pt->write_buf; + + if (pt->rw_random) + { + if (pt->rw_active == SCM_PORT_READ) + scm_end_input_unlocked (port); + pt->rw_active = SCM_PORT_WRITE; + } + + while (written < size) + { + size_t to_write = write_buf->size - write_buf->end; + + if (to_write > size - written) + to_write = size - written; + + memcpy (write_buf->buf + write_buf->end, src, to_write); + write_buf->end += to_write; + written += to_write; + src += to_write; + + if (write_buf->end == write_buf->size) + scm_i_write_unlocked (port, write_buf); } } #undef FUNC_NAME @@ -2606,6 +2762,16 @@ scm_c_write (SCM port, const void *ptr, size_t size) scm_i_pthread_mutex_unlock (lock); } +void +scm_c_write_bytes (SCM port, SCM src, size_t start, size_t count) +{ + scm_i_pthread_mutex_t *lock; + scm_c_lock_port (port, &lock); + scm_c_write_bytes_unlocked (port, src, start, count); + if (lock) + scm_i_pthread_mutex_unlock (lock); +} + /* scm_lfwrite * * This function differs from scm_c_write; it updates port line and @@ -2846,7 +3012,6 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, else if (SCM_OPOUTPORTP (object)) { off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length); - scm_t_port *pt = SCM_PTAB_ENTRY (object); scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (object); if (!ptob->truncate) @@ -3082,14 +3247,16 @@ SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0, scm_t_bits scm_tc16_void_port = 0; -static void -void_port_read (SCM port, scm_t_port_buffer *buf) +static size_t +void_port_read (SCM port, SCM dst, size_t start, size_t count) { + return 0; } -static void -void_port_write (SCM port, scm_t_port_buffer *buf) +static size_t +void_port_write (SCM port, SCM src, size_t start, size_t count) { + return count; } static SCM diff --git a/libguile/ports.h b/libguile/ports.h index 80e3a6774..e7277e3ab 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -87,8 +87,8 @@ typedef struct peek-u8 should still return EOF. */ int has_eof; - /* Heap object that keeps `buf' alive. */ - void *holder; + /* Bytevector whose contents are [BUF, BUF + SIZE). */ + SCM bytevector; } scm_t_port_buffer; @@ -204,8 +204,8 @@ typedef struct scm_t_ptob_descriptor char *name; int (*print) (SCM exp, SCM port, scm_print_state *pstate); - void (*read) (SCM port, scm_t_port_buffer *dst); - void (*write) (SCM port, scm_t_port_buffer *src); + size_t (*read) (SCM port, SCM dst, size_t start, size_t count); + size_t (*write) (SCM port, SCM src, size_t start, size_t count); scm_t_off (*seek) (SCM port, scm_t_off OFFSET, int WHENCE); void (*close) (SCM port); @@ -230,8 +230,8 @@ SCM_API scm_t_ptob_descriptor* scm_c_port_type_ref (long ptobnum); SCM_API long scm_c_port_type_add_x (scm_t_ptob_descriptor *desc); SCM_API scm_t_bits scm_make_port_type (char *name, - void (*read) (SCM port, scm_t_port_buffer *dst), - void (*write) (SCM port, scm_t_port_buffer *src)); + size_t (*read) (SCM port, SCM dst, size_t start, size_t count), + size_t (*write) (SCM port, SCM src, size_t start, size_t count)); SCM_API void scm_set_port_print (scm_t_bits tc, int (*print) (SCM exp, SCM port, @@ -323,6 +323,7 @@ SCM_INLINE int scm_peek_byte_or_eof_unlocked (SCM port); SCM_API int scm_slow_peek_byte_or_eof_unlocked (SCM port); SCM_API size_t scm_c_read (SCM port, void *buffer, size_t size); SCM_API size_t scm_c_read_unlocked (SCM port, void *buffer, size_t size); +SCM_API size_t scm_c_read_bytes (SCM port, SCM dst, size_t start, size_t count); SCM_API scm_t_wchar scm_getc (SCM port); SCM_API scm_t_wchar scm_getc_unlocked (SCM port); SCM_API SCM scm_read_char (SCM port); @@ -359,6 +360,7 @@ SCM_API void scm_puts (const char *str_data, SCM port); SCM_INLINE void scm_puts_unlocked (const char *str_data, SCM port); SCM_API void scm_c_write (SCM port, const void *buffer, size_t size); SCM_API void scm_c_write_unlocked (SCM port, const void *buffer, size_t size); +SCM_API void scm_c_write_bytes (SCM port, SCM src, size_t start, size_t count); SCM_API void scm_lfwrite (const char *ptr, size_t size, SCM port); SCM_API void scm_lfwrite_unlocked (const char *ptr, size_t size, SCM port); SCM_INTERNAL void scm_lfwrite_substr (SCM str, size_t start, size_t end, diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index aa54a0e67..fb821bb18 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -99,25 +99,26 @@ make_bytevector_input_port (SCM bv) (scm_t_bits) stream); } -static void -bytevector_input_port_read (SCM port, scm_t_port_buffer *buf) +static size_t +bytevector_input_port_read (SCM port, SCM dst, size_t start, size_t count) { - size_t count; + size_t remaining; struct bytevector_input_port *stream = (void *) SCM_STREAM (port); if (stream->pos >= SCM_BYTEVECTOR_LENGTH (stream->bytevector)) - return; + return 0; - count = SCM_BYTEVECTOR_LENGTH (stream->bytevector) - stream->pos; - if (count > buf->size - buf->end) - count = buf->size - buf->end; + remaining = SCM_BYTEVECTOR_LENGTH (stream->bytevector) - stream->pos; + if (remaining < count) + count = remaining; - memcpy (buf->buf + buf->end, + memcpy (SCM_BYTEVECTOR_CONTENTS (dst) + start, SCM_BYTEVECTOR_CONTENTS (stream->bytevector) + stream->pos, count); - buf->end += count; stream->pos += count; + + return count; } static scm_t_off @@ -277,32 +278,21 @@ make_custom_binary_input_port (SCM read_proc, SCM get_position_proc, (scm_t_bits) stream); } -static void -custom_binary_input_port_read (SCM port, scm_t_port_buffer *buf) +static size_t +custom_binary_input_port_read (SCM port, SCM dst, size_t start, size_t count) #define FUNC_NAME "custom_binary_input_port_read" { struct custom_binary_port *stream = (void *) SCM_STREAM (port); - SCM bv, octets; + SCM octets; size_t c_octets; - /* FIXME: We need to make sure buf->buf is kept alive. If read_buf is - referenced from PORT, passing PORT as the parent will do it. But, - pushback could re-set PORT->read_buf, which would be a fail. But, - probably buf->buf is itself GC-allocated, so we can pack it - directly. But, perhaps it's not, as in scm_c_read(). In that - latter case we're kinda screwed and probably need to prevent - rewinding. But shouldn't we always prevent rewinding? And how can - we avoid allocating the bytevector at all? */ - bv = scm_c_take_gc_bytevector ((signed char *) (buf->buf + buf->end), - buf->size - buf->end, - PTR2SCM (buf->buf)); - - octets = scm_call_3 (stream->read, bv, SCM_INUM0, scm_bytevector_length (bv)); + octets = scm_call_3 (stream->read, dst, scm_from_size_t (start), + scm_from_size_t (count)); c_octets = scm_to_size_t (octets); - if (c_octets > scm_c_bytevector_length (bv)) + if (c_octets > count) scm_out_of_range (FUNC_NAME, octets); - buf->end += c_octets; + return c_octets; } #undef FUNC_NAME @@ -405,7 +395,6 @@ SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2, 0, 0, #define FUNC_NAME s_scm_get_bytevector_n { SCM result; - char *c_bv; unsigned c_count; size_t c_read; @@ -413,11 +402,10 @@ SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2, 0, 0, c_count = scm_to_uint (count); result = scm_c_make_bytevector (c_count); - c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (result); if (SCM_LIKELY (c_count > 0)) /* XXX: `scm_c_read ()' does not update the port position. */ - c_read = scm_c_read_unlocked (port, c_bv, c_count); + c_read = scm_c_read_bytes (port, result, 0, c_count); else /* Don't invoke `scm_c_read ()' since it may block. */ c_read = 0; @@ -443,7 +431,6 @@ SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0, #define FUNC_NAME s_scm_get_bytevector_n_x { SCM result; - char *c_bv; unsigned c_start, c_count, c_len; size_t c_read; @@ -452,14 +439,13 @@ SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0, c_start = scm_to_uint (start); c_count = scm_to_uint (count); - c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); c_len = SCM_BYTEVECTOR_LENGTH (bv); if (SCM_UNLIKELY (c_start + c_count > c_len)) scm_out_of_range (FUNC_NAME, count); if (SCM_LIKELY (c_count > 0)) - c_read = scm_c_read_unlocked (port, c_bv + c_start, c_count); + c_read = scm_c_read_bytes (port, bv, c_start, c_count); else /* Don't invoke `scm_c_read ()' since it may block. */ c_read = 0; @@ -513,14 +499,13 @@ SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0, #define FUNC_NAME s_scm_get_bytevector_all { SCM result; - char *c_bv; unsigned c_len, c_count; size_t c_read, c_total; SCM_VALIDATE_BINARY_INPUT_PORT (1, port); c_len = c_count = 4096; - c_bv = (char *) scm_gc_malloc_pointerless (c_len, SCM_GC_BYTEVECTOR); + result = scm_c_make_bytevector (c_count); c_total = c_read = 0; do @@ -528,37 +513,27 @@ SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0, if (c_total + c_read > c_len) { /* Grow the bytevector. */ - c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2, - SCM_GC_BYTEVECTOR); + SCM prev = result; + result = scm_c_make_bytevector (c_len * 2); + memcpy (SCM_BYTEVECTOR_CONTENTS (result), + SCM_BYTEVECTOR_CONTENTS (prev), + c_total); c_count = c_len; c_len *= 2; } /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is reached. */ - c_read = scm_c_read_unlocked (port, c_bv + c_total, c_count); + c_read = scm_c_read_bytes (port, result, c_total, c_count); c_total += c_read, c_count -= c_read; } while (c_count == 0); if (c_total == 0) - { - result = SCM_EOF_VAL; - scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR); - } - else - { - if (c_len > c_total) - { - /* Shrink the bytevector. */ - c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total, - SCM_GC_BYTEVECTOR); - c_len = (unsigned) c_total; - } + return SCM_EOF_VAL; - result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len, - SCM_BOOL_F); - } + if (c_len > c_total) + return scm_c_shrink_bytevector (result, c_total); return result; } @@ -596,14 +571,12 @@ SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0, "octets.") #define FUNC_NAME s_scm_put_bytevector { - char *c_bv; unsigned c_start, c_count, c_len; SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port); SCM_VALIDATE_BYTEVECTOR (2, bv); c_len = SCM_BYTEVECTOR_LENGTH (bv); - c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); if (!scm_is_eq (start, SCM_UNDEFINED)) { @@ -626,7 +599,7 @@ SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0, else c_start = 0, c_count = c_len; - scm_c_write_unlocked (port, c_bv + c_start, c_count); + scm_c_write_bytes (port, bv, c_start, c_count); return SCM_UNSPECIFIED; } @@ -777,21 +750,22 @@ make_bytevector_output_port (void) } /* Write octets from WRITE_BUF to the backing store. */ -static void -bytevector_output_port_write (SCM port, scm_t_port_buffer *write_buf) +static size_t +bytevector_output_port_write (SCM port, SCM src, size_t start, size_t count) { - size_t count; scm_t_bytevector_output_port_buffer *buf; buf = SCM_BYTEVECTOR_OUTPUT_PORT_BUFFER (port); - count = write_buf->end - write_buf->cur; if (buf->pos + count > buf->total_len) bytevector_output_port_buffer_grow (buf, buf->pos + count); - memcpy (buf->buffer + buf->pos, write_buf->buf + write_buf->cur, count); + memcpy (buf->buffer + buf->pos, SCM_BYTEVECTOR_CONTENTS (src) + start, count); + buf->pos += count; buf->len = (buf->len > buf->pos) ? buf->len : buf->pos; + + return count; } static scm_t_off @@ -909,41 +883,35 @@ make_custom_binary_output_port (SCM write_proc, SCM get_position_proc, } /* Flush octets from BUF to the backing store. */ -static void -custom_binary_output_port_write (SCM port, scm_t_port_buffer *buf) +static size_t +custom_binary_output_port_write (SCM port, SCM src, size_t start, size_t count) #define FUNC_NAME "custom_binary_output_port_write" { - size_t size, written; + size_t written; struct custom_binary_port *stream = (void *) SCM_STREAM (port); - SCM bv; - - /* FIXME: If BUF is the same as PORT->write_buf, then the data is - GC-managed and we could avoid allocating a new bytevector backing - store. Otherwise we have to copy, as we do here. */ - size = buf->end - buf->cur; - bv = scm_c_make_bytevector (size); - memcpy (SCM_BYTEVECTOR_CONTENTS (bv), buf->buf + buf->cur, size); /* Since the `write' procedure of Guile's ports has type `void', it must try hard to write exactly SIZE bytes, regardless of how many bytes the sink can handle. */ written = 0; - while (written < size) + while (written < count) { long int c_result; SCM result; - result = scm_call_3 (stream->write, bv, - scm_from_size_t (written), - scm_from_size_t (size - written)); + result = scm_call_3 (stream->write, src, + scm_from_size_t (start + written), + scm_from_size_t (count - written)); c_result = scm_to_long (result); - if (c_result < 0 || (size_t) c_result > (size - written)) + if (c_result < 0 || (size_t) c_result > (count - written)) scm_wrong_type_arg_msg (FUNC_NAME, 0, result, "R6RS custom binary output port `write!' " "returned a incorrect integer"); written += c_result; } + + return written; } #undef FUNC_NAME @@ -1008,32 +976,19 @@ make_transcoded_port (SCM binary_port, unsigned long mode) return port; } -static void -transcoded_port_write (SCM port, scm_t_port_buffer *buf) +static size_t +transcoded_port_write (SCM port, SCM src, size_t start, size_t count) { SCM bport = SCM_TRANSCODED_PORT_BINARY_PORT (port); - scm_c_write_unlocked (bport, buf->buf + buf->cur, buf->end - buf->cur); + scm_c_write_bytes (bport, src, start, count); + return count; } -static void -transcoded_port_read (SCM port, scm_t_port_buffer *buf) +static size_t +transcoded_port_read (SCM port, SCM dst, size_t start, size_t count) { - size_t count; - scm_t_port_buffer *bport_buf; - - /* We can't use `scm_c_read' here, since it blocks until the whole - block has been read or EOF. */ - - bport_buf = scm_fill_input (SCM_TRANSCODED_PORT_BINARY_PORT (port)); - /* Consume EOF from bport. */ - bport_buf->has_eof = 0; - count = bport_buf->end - bport_buf->cur; - if (count > buf->size - buf->end) - count = buf->size - buf->end; - - memcpy (buf->buf + buf->end, bport_buf->buf + bport_buf->cur, count); - bport_buf->cur += count; - buf->end += count; + SCM bport = SCM_TRANSCODED_PORT_BINARY_PORT (port); + return scm_c_read_bytes (bport, dst, start, count); } static void diff --git a/libguile/strports.c b/libguile/strports.c index 6ad7d18f2..e8ce67a8f 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -60,31 +60,29 @@ struct string_port { size_t len; }; -static void -string_port_read (SCM port, scm_t_port_buffer *dst) +static size_t +string_port_read (SCM port, SCM dst, size_t start, size_t count) { - size_t count; struct string_port *stream = (void *) SCM_STREAM (port); if (stream->pos >= stream->len) - return; + return 0; - count = stream->len - stream->pos; - if (count > dst->size - dst->end) - count = dst->size - dst->end; + if (count > stream->len - stream->pos) + count = stream->len - stream->pos; - memcpy (dst->buf + dst->end, + memcpy (SCM_BYTEVECTOR_CONTENTS (dst) + start, SCM_BYTEVECTOR_CONTENTS (stream->bytevector) + stream->pos, count); - dst->end += count; + stream->pos += count; + return count; } -static void -string_port_write (SCM port, scm_t_port_buffer *src) +static size_t +string_port_write (SCM port, SCM src, size_t start, size_t count) { struct string_port *stream = (void *) SCM_STREAM (port); - size_t count = src->end - src->cur; if (SCM_BYTEVECTOR_LENGTH (stream->bytevector) < stream->pos + count) { @@ -101,12 +99,13 @@ string_port_write (SCM port, scm_t_port_buffer *src) } memcpy (SCM_BYTEVECTOR_CONTENTS (stream->bytevector) + stream->pos, - src->buf + src->cur, + SCM_BYTEVECTOR_CONTENTS (src) + start, count); - src->cur += count; stream->pos += count; if (stream->pos > stream->len) stream->len = stream->pos; + + return count; } static scm_t_off diff --git a/libguile/vports.c b/libguile/vports.c index 82fef1e0b..e52057065 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -72,27 +72,30 @@ soft_port_get_natural_buffer_sizes (SCM port, size_t *read_size, *write_size = 1; } -static void -soft_port_write (SCM port, scm_t_port_buffer *buf) +static size_t +soft_port_write (SCM port, SCM src, size_t start, size_t count) { struct soft_port *stream = (void *) SCM_STREAM (port); - scm_t_uint8 * ptr = buf->buf + buf->cur; - SCM str = scm_from_port_stringn ((char *) ptr, buf->end - buf->cur, port); - buf->end = buf->cur = 0; + signed char * ptr = SCM_BYTEVECTOR_CONTENTS (src) + start; - scm_call_1 (stream->write_string, str); + scm_call_1 (stream->write_string, + scm_from_port_stringn ((char *) ptr, count, port)); /* Backwards compatibility. */ if (scm_is_true (stream->flush)) scm_call_0 (stream->flush); + + return count; } /* places a single char in the input buffer. */ -static void -soft_port_read (SCM port, scm_t_port_buffer *dst) +static size_t +soft_port_read (SCM port, SCM dst, size_t start, size_t count) { + size_t written; struct soft_port *stream = (void *) SCM_STREAM (port); scm_t_port_buffer *encode_buf = stream->encode_buf; + signed char *dst_ptr = SCM_BYTEVECTOR_CONTENTS (dst) + start; /* A character can be more than one byte, but we don't have a guarantee that there is more than one byte in the read buffer. So, @@ -106,7 +109,7 @@ soft_port_read (SCM port, scm_t_port_buffer *dst) ans = scm_call_0 (stream->read_char); if (scm_is_false (ans) || SCM_EOF_OBJECT_P (ans)) - return; + return 0; SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "soft_port_read"); /* It's possible to make a fast path here, but it would be fastest @@ -119,8 +122,12 @@ soft_port_read (SCM port, scm_t_port_buffer *dst) free (str); } - while (dst->end < dst->size && encode_buf->cur < encode_buf->end) - dst->buf[dst->end++] = encode_buf->buf[encode_buf->cur++]; + for (written = 0; + written < count && encode_buf->cur < encode_buf->end; + written++, encode_buf->cur++) + dst_ptr[written] = encode_buf->buf[encode_buf->cur]; + + return written; } diff --git a/test-suite/standalone/test-scm-c-read.c b/test-suite/standalone/test-scm-c-read.c index 86bca48ed..7850f3447 100644 --- a/test-suite/standalone/test-scm-c-read.c +++ b/test-suite/standalone/test-scm-c-read.c @@ -54,18 +54,20 @@ make_port (scm_t_bits port_type) return scm_c_make_port (port_type, SCM_RDNG, (scm_t_bits) stream); } -static void -custom_port_read (SCM port, scm_t_port_buffer *dst) +static size_t +custom_port_read (SCM port, SCM dst, size_t start, size_t count) { - size_t to_copy = dst->size - dst->end; + size_t to_copy = count; struct custom_port *stream = (void *) SCM_STREAM (port); if (stream->pos + to_copy > stream->len) to_copy = stream->len - stream->pos; - memcpy (dst->buf + dst->end, stream->buf + stream->pos, to_copy); + memcpy (SCM_BYTEVECTOR_CONTENTS (dst) + start, + stream->buf + stream->pos, to_copy); stream->pos += to_copy; - dst->end += to_copy; + + return to_copy; } /* Return true (non-zero) if BUF contains only zeros. */ From d83140890fa112737a895feeaa5e90a952fedce7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 12 Apr 2016 16:31:20 +0200 Subject: [PATCH 204/865] Update port implementation documentation. * doc/ref/api-io.texi (I/O Extensions): Update read/write documentation. --- doc/ref/api-io.texi | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index b5e70cf7b..78f7caec7 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -2289,7 +2289,10 @@ The port buffer consists of data as a byte array, pointed to by its @code{buf} field. The valid data in the buffer is between the @code{cur} and @code{end} indices into @code{buf}; @code{cur} must always be less than or equal to @code{end}, which in turn must be less -than or equal to the buffer size @code{size}. +than or equal to the buffer size @code{size}. The @code{buf} pointer is +actually a pointer to the start of a bytevector, stored in the +@code{bytevector} member. Using bytevectors to back port buffers allows +Scheme to manipulate these buffers. ``Valid data'' for a read buffer is data that has been buffered, but not yet read by the user. A port's @code{read} procedure fills a read @@ -2330,7 +2333,7 @@ implementation. A port type object is created by calling @code{scm_make_port_type}. -@deftypefun scm_t_bits scm_make_port_type (char *name, void (*read) (SCM port, scm_t_port_buffer *dst), void (*write) (SCM port, scm_t_port_buffer *src)) +@deftypefun scm_t_bits scm_make_port_type (char *name, size_t (*read) (SCM port, SCM dst, size_t start, size_t count), size_t (*write) (SCM port, SCM src, size_t start, size_t count)) Return a new port type object. The @var{name}, @var{read} and @var{write} parameters are initial values for those port type fields, as described below. The other fields are initialized with default values @@ -2349,15 +2352,16 @@ a procedure. Set via the first argument to @code{scm_make_port_type}. @item read A port's @code{read} implementation fills read buffers. It should copy -bytes to the supplied port buffer object, advancing the buffer's -@code{end} field as appropriate, but not past the buffer's @code{size} -field. +bytes to the supplied bytevector @code{dst}, starting at offset +@code{start} and continuing for @code{count} bytes, returning the number +of bytes read. @item write A port's @code{write} implementation flushes write buffers to the -mutable store. It should copy bytes from the supplied port buffer -object, advancing the buffer's @code{cur} field as appropriate, but not -past the buffer's @code{end} field. +mutable store. A port's @code{read} implementation fills read buffers. +It should write out bytes from the supplied bytevector @code{src}, +starting at offset @code{start} and continuing for @code{count} bytes, +and return the number of bytes that were written. @item print Called when @code{write} is called on the port object, to print a From a9cf9f424fe0afb58b2cc5ded1babf1555a51b47 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 12 Apr 2016 16:45:10 +0200 Subject: [PATCH 205/865] Allow port "write" functions to only write a chunk * libguile/ports.c (scm_i_write_bytes_unlocked): Allow incomplete writes from the implementation. (scm_c_write_bytes_unlocked): Use scm_i_write_bytes_unlocked helper to call the write function. * libguile/r6rs-ports.c (custom_binary_output_port_write): Don't loop; core Guile will do that. --- libguile/ports.c | 12 +++++------- libguile/r6rs-ports.c | 29 +++++++++-------------------- 2 files changed, 14 insertions(+), 27 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 144daef3f..8fe8dbe0d 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -2614,15 +2614,16 @@ scm_puts (const char *s, SCM port) static void scm_i_write_bytes_unlocked (SCM port, SCM src, size_t start, size_t count) { - size_t written; + size_t written = 0; scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port); assert (count <= SCM_BYTEVECTOR_LENGTH (src)); assert (start + count <= SCM_BYTEVECTOR_LENGTH (src)); - written = ptob->write (port, src, start, count); + do + written += ptob->write (port, src, start + written, count - written); + while (written < count); - /* FIXME: Allow short writes? */ assert (written == count); } @@ -2697,13 +2698,10 @@ scm_c_write_bytes_unlocked (SCM port, SCM src, size_t start, size_t count) { /* Our write would overflow the buffer. Flush buffered bytes (if needed), then write our bytes with just one syscall. */ - size_t written; - if (write_buf->cur < write_buf->end) scm_i_write_unlocked (port, write_buf); - written = SCM_PORT_DESCRIPTOR (port)->write (port, src, start, count); - assert (written == count); + scm_i_write_bytes_unlocked (port, src, start, count); } return count; diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index fb821bb18..4b2df9229 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -887,29 +887,18 @@ static size_t custom_binary_output_port_write (SCM port, SCM src, size_t start, size_t count) #define FUNC_NAME "custom_binary_output_port_write" { - size_t written; struct custom_binary_port *stream = (void *) SCM_STREAM (port); + size_t written; + SCM result; - /* Since the `write' procedure of Guile's ports has type `void', it must - try hard to write exactly SIZE bytes, regardless of how many bytes the - sink can handle. */ - written = 0; - while (written < count) - { - long int c_result; - SCM result; + result = scm_call_3 (stream->write, src, scm_from_size_t (start), + scm_from_size_t (count)); - result = scm_call_3 (stream->write, src, - scm_from_size_t (start + written), - scm_from_size_t (count - written)); - - c_result = scm_to_long (result); - if (c_result < 0 || (size_t) c_result > (count - written)) - scm_wrong_type_arg_msg (FUNC_NAME, 0, result, - "R6RS custom binary output port `write!' " - "returned a incorrect integer"); - written += c_result; - } + written = scm_to_size_t (result); + if (written > count) + scm_wrong_type_arg_msg (FUNC_NAME, 0, result, + "R6RS custom binary output port `write!' " + "returned a incorrect integer"); return written; } From 110695c82e724521dbd0ebedee8f85fef2c418a2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 13 Apr 2016 11:12:24 +0200 Subject: [PATCH 206/865] Fix error in exception printer when bootstrapping * module/ice-9/boot-9.scm (exception-printers): Fix error in which, for a pure bootstrap with no compiled files, the exception printer would use false-with-exception before it has been defined, which doesn't work for macros. We wouldn't see this problem normally because, oddly, the macro is indeed defined normally because of boot reasons. --- module/ice-9/boot-9.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 6da8085a0..9e9efe65b 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -895,7 +895,10 @@ for key @var{k}, then invoke @var{thunk}." (when frame (print-location frame port) - (let ((name (false-if-exception (frame-procedure-name frame)))) + ;; When booting, false-if-exception isn't defined yet. + (let ((name (catch #t + (lambda () (frame-procedure-name frame)) + (lambda _ #f)))) (when name (format port "In procedure ~a:\n" name)))) From cf80502c0af8b0d0acee5b73b36a9fbb66ed7084 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 14 Apr 2016 11:04:53 +0200 Subject: [PATCH 207/865] Fix scm_init_struct dependency on port conversion handlers * libguile/struct.c (scm_init_struct): Use scm_from_latin1_string to avoid locale-dependency for what is really a latin1 string. Also avoids an early dependency on the default port conversion handler, though I wonder if using port conversion handlers in strings is the right thing. --- libguile/struct.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/libguile/struct.c b/libguile/struct.c index 8bfbcf433..3bf2e3687 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -990,10 +990,10 @@ scm_init_struct () OBJ once OBJ has undergone class redefinition. */ GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits)); - required_vtable_fields = scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT); + required_vtable_fields = scm_from_latin1_string (SCM_VTABLE_BASE_LAYOUT); scm_c_define ("standard-vtable-fields", required_vtable_fields); - required_applicable_fields = scm_from_locale_string (SCM_APPLICABLE_BASE_LAYOUT); - required_applicable_with_setter_fields = scm_from_locale_string (SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT); + required_applicable_fields = scm_from_latin1_string (SCM_APPLICABLE_BASE_LAYOUT); + required_applicable_with_setter_fields = scm_from_latin1_string (SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT); scm_standard_vtable_vtable = scm_i_make_vtable_vtable (required_vtable_fields); From 5e470ea48f054aebad0e1000453a6c84e59cf460 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 14 Apr 2016 11:50:08 +0200 Subject: [PATCH 208/865] Fix R6RS imports of interfaces that use interfaces * module/ice-9/r6rs-libraries.scm (resolve-r6rs-interface): In Guile, a module's public interface is just another module, and that means that it can import other modules as well. Allow for R6RS modules that import module whose interfaces import other modules to access all visible bindings. * test-suite/tests/rnrs-libraries.test ("import features"): Update test. --- module/ice-9/r6rs-libraries.scm | 34 ++++++++++++++++------ test-suite/tests/rnrs-libraries.test | 42 +++++++++++++++++++++------- 2 files changed, 57 insertions(+), 19 deletions(-) diff --git a/module/ice-9/r6rs-libraries.scm b/module/ice-9/r6rs-libraries.scm index a68df3c63..579d6bd72 100644 --- a/module/ice-9/r6rs-libraries.scm +++ b/module/ice-9/r6rs-libraries.scm @@ -26,6 +26,17 @@ (set-module-kind! iface 'custom-interface) (set-module-name! iface (module-name mod)) iface)) + (define (module-for-each/nonlocal f mod) + (define (module-and-uses mod) + (let lp ((in (list mod)) (out '())) + (cond + ((null? in) (reverse out)) + ((memq (car in) out) (lp (cdr in) out)) + (else (lp (append (module-uses (car in)) (cdr in)) + (cons (car in) out)))))) + (for-each (lambda (mod) + (module-for-each f mod)) + (module-and-uses mod))) (define (sym? x) (symbol? (syntax->datum x))) (syntax-case import-spec (library only except prefix rename srfi) @@ -63,7 +74,7 @@ (iface (make-custom-interface mod))) (for-each (lambda (sym) (module-add! iface sym - (or (module-local-variable mod sym) + (or (module-variable mod sym) (error "no binding `~A' in module ~A" sym mod)))) (syntax->datum #'(identifier ...))) @@ -73,7 +84,9 @@ (and-map sym? #'(identifier ...)) (let* ((mod (resolve-r6rs-interface #'import-set)) (iface (make-custom-interface mod))) - (module-for-each (lambda (sym var) (module-add! iface sym var)) mod) + (module-for-each/nonlocal (lambda (sym var) + (module-add! iface sym var)) + mod) (for-each (lambda (sym) (if (module-local-variable iface sym) (module-remove! iface sym) @@ -86,16 +99,19 @@ (let* ((mod (resolve-r6rs-interface #'import-set)) (iface (make-custom-interface mod)) (pre (syntax->datum #'identifier))) - (module-for-each (lambda (sym var) - (module-add! iface (symbol-append pre sym) var)) - mod) + (module-for-each/nonlocal + (lambda (sym var) + (module-add! iface (symbol-append pre sym) var)) + mod) iface)) ((rename import-set (from to) ...) (and (and-map sym? #'(from ...)) (and-map sym? #'(to ...))) (let* ((mod (resolve-r6rs-interface #'import-set)) (iface (make-custom-interface mod))) - (module-for-each (lambda (sym var) (module-add! iface sym var)) mod) + (module-for-each/nonlocal + (lambda (sym var) (module-add! iface sym var)) + mod) (let lp ((in (syntax->datum #'((from . to) ...))) (out '())) (cond ((null? in) @@ -108,7 +124,7 @@ out) iface) (else - (let ((var (or (module-local-variable mod (caar in)) + (let ((var (or (module-variable mod (caar in)) (error "no binding `~A' in module ~A" (caar in) mod)))) (module-remove! iface (caar in)) @@ -126,9 +142,9 @@ (lambda (stx) (define (compute-exports ifaces specs) (define (re-export? sym) - (or-map (lambda (iface) (module-local-variable iface sym)) ifaces)) + (or-map (lambda (iface) (module-variable iface sym)) ifaces)) (define (replace? sym) - (module-local-variable the-scm-module sym)) + (module-variable the-scm-module sym)) (let lp ((specs specs) (e '()) (r '()) (x '())) (syntax-case specs (rename) diff --git a/test-suite/tests/rnrs-libraries.test b/test-suite/tests/rnrs-libraries.test index 9add98af6..86035e508 100644 --- a/test-suite/tests/rnrs-libraries.test +++ b/test-suite/tests/rnrs-libraries.test @@ -143,18 +143,40 @@ (module-obarray (resolve-r6rs-interface '(only (guile) +))))))) (with-test-prefix "except" - (let ((bindings (hash-map->list - (lambda (sym var) sym) - (module-obarray - (resolve-r6rs-interface '(except (guile) +)))))) + ;; In Guile, interfaces can use other interfaces. For R6RS modules + ;; that are imported as-is (without `except', etc), Guile will just + ;; import them as-is. `(guile)' is one of those modules. For other + ;; import kinds like `except', the resolve-r6rs-interface code will + ;; go binding-by-binding and create a new flat interface. Anyway, + ;; that means to compare an except interface with (guile), we're + ;; comparing a flat interface with a deep interface, so we need to + ;; do more work to get the set of bindings in (guile), knowing also + ;; that some of those bindings could be duplicates. + (define (bound-name-count mod) + (define (module-for-each/nonlocal f mod) + (define (module-and-uses mod) + (let lp ((in (list mod)) (out '())) + (cond + ((null? in) (reverse out)) + ((memq (car in) out) (lp (cdr in) out)) + (else (lp (append (module-uses (car in)) (cdr in)) + (cons (car in) out)))))) + (for-each (lambda (mod) + (module-for-each f mod)) + (module-and-uses mod))) + (hash-fold (lambda (sym var n) (1+ n)) + 0 + (let ((t (make-hash-table))) + (module-for-each/nonlocal (lambda (sym var) + (hashq-set! t sym var)) + mod) + t))) + (let ((except-+ (resolve-r6rs-interface '(except (guile) +)))) (pass-if "contains" - (equal? (length bindings) - (1- (hash-fold - (lambda (sym var n) (1+ n)) - 0 - (module-obarray (resolve-interface '(guile))))))) + (equal? (bound-name-count except-+) + (1- (bound-name-count (resolve-interface '(guile)))))) (pass-if "does not contain" - (not (memq '+ bindings))))) + (not (module-variable except-+ '+))))) (with-test-prefix "prefix" (let ((iface (resolve-r6rs-interface '(prefix (ice-9 q) q:)))) From 44b3342c4d5ebd4bbf21c7c7608a5f1a53ba0eb4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 14 Apr 2016 15:44:34 +0200 Subject: [PATCH 209/865] Load port bindings in separate (ice-9 ports) module * module/ice-9/ports.scm: New file. * am/bootstrap.am (SOURCES): Add ice-9/ports.scm. * libguile/fports.c (scm_init_ice_9_fports): New function. (scm_init_fports): Arrange for scm_init_ice_9_fports to be called via load-extension, and load snarfed things there. Move open-file definition early, to allow ports to bootstrap. * libguile/ioext.c (scm_init_ice_9_ioext): New function. (scm_init_ioext): Similarly, register scm_init_ice_9_ioext as an extension. * libguile/ports.c (scm_set_current_input_port) (scm_set_current_output_port, scm_set_current_error_port): Don't define Scheme bindings; do that in Scheme. * libguile/ports.c (scm_i_set_default_port_encoding): (scm_i_default_port_encoding, scm_i_default_port_conversion_handler): (scm_i_set_default_port_conversion_handler): Since we now init encoding early, remove the "init" flags on these encoding/strategy vars. (scm_init_ice_9_ports): New function. (scm_init_ports): Register scm_init_ice_9_ports extension, and define some bindings needed by the bootstrap. * module/Makefile.am (SOURCES): Add ice-9/ports.scm. * module/ice-9/boot-9.scm: Remove code that's not on the boot path, moving it to ice-9/ports.scm. At the end, load (ice-9 ports). * module/ice-9/psyntax.scm (include): Use close-port instead of close-input-port. * module/ice-9/psyntax-pp.scm (include): Regenerate. --- am/bootstrap.am | 1 + libguile/fports.c | 26 +- libguile/ioext.c | 11 +- libguile/ports.c | 186 +++++++------- module/Makefile.am | 1 + module/ice-9/boot-9.scm | 311 ++---------------------- module/ice-9/ports.scm | 469 ++++++++++++++++++++++++++++++++++++ module/ice-9/psyntax-pp.scm | 2 +- module/ice-9/psyntax.scm | 2 +- 9 files changed, 607 insertions(+), 402 deletions(-) create mode 100644 module/ice-9/ports.scm diff --git a/am/bootstrap.am b/am/bootstrap.am index d613d7f02..0eaa87b06 100644 --- a/am/bootstrap.am +++ b/am/bootstrap.am @@ -123,6 +123,7 @@ SOURCES = \ system/base/ck.scm \ \ ice-9/boot-9.scm \ + ice-9/ports.scm \ ice-9/r5rs.scm \ ice-9/deprecated.scm \ ice-9/binary-ports.scm \ diff --git a/libguile/fports.c b/libguile/fports.c index 11aa1707b..efbcf73a0 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -121,8 +121,8 @@ SCM_DEFINE (scm_file_port_p, "file-port?", 1, 0, 0, static SCM sys_file_port_name_canonicalization; -SCM_SYMBOL (sym_relative, "relative"); -SCM_SYMBOL (sym_absolute, "absolute"); +static SCM sym_relative; +static SCM sym_absolute; static SCM fport_canonicalize_filename (SCM filename) @@ -677,16 +677,34 @@ scm_init_fports_keywords () k_encoding = scm_from_latin1_keyword ("encoding"); } +static void +scm_init_ice_9_fports (void) +{ +#include "libguile/fports.x" +} + void scm_init_fports () { scm_tc16_fport = scm_make_fptob (); + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_ice_9_fports", + (scm_t_extension_init_func) scm_init_ice_9_fports, + NULL); + + /* The following bindings are used early in boot-9.scm. */ + + /* Used by `include' and also by `file-exists?' if `stat' is + unavailable. */ + scm_c_define_gsubr (s_scm_i_open_file, 2, 0, 1, (scm_t_subr) scm_i_open_file); + + /* Used by `open-file.', also via C. */ + sym_relative = scm_from_latin1_symbol ("relative"); + sym_absolute = scm_from_latin1_symbol ("absolute"); sys_file_port_name_canonicalization = scm_make_fluid (); scm_c_define ("%file-port-name-canonicalization", sys_file_port_name_canonicalization); - -#include "libguile/fports.x" } /* diff --git a/libguile/ioext.c b/libguile/ioext.c index 607eec636..3f0a53f5d 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -302,12 +302,21 @@ SCM_DEFINE (scm_fdes_to_ports, "fdes->ports", 1, 0, 0, #undef FUNC_NAME +static void +scm_init_ice_9_ioext (void) +{ +#include "libguile/ioext.x" +} + void scm_init_ioext () { scm_add_feature ("i/o-extensions"); -#include "libguile/ioext.x" + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_ice_9_ioext", + (scm_t_extension_init_func) scm_init_ice_9_ioext, + NULL); } diff --git a/libguile/ports.c b/libguile/ports.c index 8fe8dbe0d..d1bb231f0 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -425,14 +425,9 @@ SCM_DEFINE (scm_current_load_port, "current-load-port", 0, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_set_current_input_port, "set-current-input-port", 1, 0, 0, - (SCM port), - "@deffnx {Scheme Procedure} set-current-output-port port\n" - "@deffnx {Scheme Procedure} set-current-error-port port\n" - "Change the ports returned by @code{current-input-port},\n" - "@code{current-output-port} and @code{current-error-port}, respectively,\n" - "so that they use the supplied @var{port} for input or output.") -#define FUNC_NAME s_scm_set_current_input_port +SCM +scm_set_current_input_port (SCM port) +#define FUNC_NAME "set-current-input-port" { SCM oinp = scm_fluid_ref (cur_inport_fluid); SCM_VALIDATE_OPINPORT (1, port); @@ -441,11 +436,9 @@ SCM_DEFINE (scm_set_current_input_port, "set-current-input-port", 1, 0, 0, } #undef FUNC_NAME - -SCM_DEFINE (scm_set_current_output_port, "set-current-output-port", 1, 0, 0, - (SCM port), - "Set the current default output port to @var{port}.") -#define FUNC_NAME s_scm_set_current_output_port +SCM +scm_set_current_output_port (SCM port) +#define FUNC_NAME "scm-set-current-output-port" { SCM ooutp = scm_fluid_ref (cur_outport_fluid); port = SCM_COERCE_OUTPORT (port); @@ -455,11 +448,9 @@ SCM_DEFINE (scm_set_current_output_port, "set-current-output-port", 1, 0, 0, } #undef FUNC_NAME - -SCM_DEFINE (scm_set_current_error_port, "set-current-error-port", 1, 0, 0, - (SCM port), - "Set the current default error port to @var{port}.") -#define FUNC_NAME s_scm_set_current_error_port +SCM +scm_set_current_error_port (SCM port) +#define FUNC_NAME "set-current-error-port" { SCM oerrp = scm_fluid_ref (cur_errport_fluid); port = SCM_COERCE_OUTPORT (port); @@ -469,7 +460,6 @@ SCM_DEFINE (scm_set_current_error_port, "set-current-error-port", 1, 0, 0, } #undef FUNC_NAME - SCM scm_set_current_warning_port (SCM port) #define FUNC_NAME "set-current-warning-port" @@ -482,7 +472,6 @@ scm_set_current_warning_port (SCM port) } #undef FUNC_NAME - void scm_dynwind_current_input_port (SCM port) #define FUNC_NAME NULL @@ -916,19 +905,12 @@ SCM_DEFINE (scm_close_output_port, "close-output-port", 1, 0, 0, /* A fluid specifying the default encoding for newly created ports. If it is a string, that is the encoding. If it is #f, it is in the "native" (Latin-1) encoding. */ -SCM_VARIABLE (default_port_encoding_var, "%default-port-encoding"); - -static int scm_port_encoding_init = 0; +static SCM default_port_encoding_var; /* Use ENCODING as the default encoding for future ports. */ void scm_i_set_default_port_encoding (const char *encoding) { - if (!scm_port_encoding_init - || !scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var))) - scm_misc_error (NULL, "tried to set port encoding fluid before it is initialized", - SCM_EOL); - if (encoding_matches (encoding, "ISO-8859-1")) scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var), SCM_BOOL_F); else @@ -940,63 +922,41 @@ scm_i_set_default_port_encoding (const char *encoding) const char * scm_i_default_port_encoding (void) { - if (!scm_port_encoding_init) - return "ISO-8859-1"; - else if (!scm_is_fluid (SCM_VARIABLE_REF (default_port_encoding_var))) + SCM encoding; + + encoding = scm_fluid_ref (SCM_VARIABLE_REF (default_port_encoding_var)); + if (!scm_is_string (encoding)) return "ISO-8859-1"; else - { - SCM encoding; - - encoding = scm_fluid_ref (SCM_VARIABLE_REF (default_port_encoding_var)); - if (!scm_is_string (encoding)) - return "ISO-8859-1"; - else - return scm_i_string_chars (encoding); - } + return scm_i_string_chars (encoding); } /* A fluid specifying the default conversion handler for newly created ports. Its value should be one of the symbols below. */ -SCM_VARIABLE (default_conversion_strategy_var, - "%default-port-conversion-strategy"); - -/* Whether the above fluid is initialized. */ -static int scm_conversion_strategy_init = 0; +static SCM default_conversion_strategy_var; /* The possible conversion strategies. */ -SCM_SYMBOL (sym_error, "error"); -SCM_SYMBOL (sym_substitute, "substitute"); -SCM_SYMBOL (sym_escape, "escape"); +static SCM sym_error; +static SCM sym_substitute; +static SCM sym_escape; /* Return the default failed encoding conversion policy for new created ports. */ scm_t_string_failed_conversion_handler scm_i_default_port_conversion_handler (void) { - scm_t_string_failed_conversion_handler handler; + SCM value; - if (!scm_conversion_strategy_init - || !scm_is_fluid (SCM_VARIABLE_REF (default_conversion_strategy_var))) - handler = SCM_FAILED_CONVERSION_QUESTION_MARK; + value = scm_fluid_ref (SCM_VARIABLE_REF (default_conversion_strategy_var)); + + if (scm_is_eq (sym_substitute, value)) + return SCM_FAILED_CONVERSION_QUESTION_MARK; + else if (scm_is_eq (sym_escape, value)) + return SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE; else - { - SCM fluid, value; - - fluid = SCM_VARIABLE_REF (default_conversion_strategy_var); - value = scm_fluid_ref (fluid); - - if (scm_is_eq (sym_substitute, value)) - handler = SCM_FAILED_CONVERSION_QUESTION_MARK; - else if (scm_is_eq (sym_escape, value)) - handler = SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE; - else - /* Default to 'error also when the fluid's value is not one of - the valid symbols. */ - handler = SCM_FAILED_CONVERSION_ERROR; - } - - return handler; + /* Default to 'error also when the fluid's value is not one of + the valid symbols. */ + return SCM_FAILED_CONVERSION_ERROR; } /* Use HANDLER as the default conversion strategy for future ports. */ @@ -1006,11 +966,6 @@ scm_i_set_default_port_conversion_handler (scm_t_string_failed_conversion_handle { SCM strategy; - if (!scm_conversion_strategy_init - || !scm_is_fluid (SCM_VARIABLE_REF (default_conversion_strategy_var))) - scm_misc_error (NULL, "tried to set conversion strategy fluid before it is initialized", - SCM_EOL); - switch (handler) { case SCM_FAILED_CONVERSION_ERROR: @@ -3286,36 +3241,16 @@ SCM_DEFINE (scm_sys_make_void_port, "%make-void-port", 1, 0, 0, /* Initialization. */ -void -scm_init_ports () +static void +scm_init_ice_9_ports (void) { +#include "libguile/ports.x" + /* lseek() symbols. */ scm_c_define ("SEEK_SET", scm_from_int (SEEK_SET)); scm_c_define ("SEEK_CUR", scm_from_int (SEEK_CUR)); scm_c_define ("SEEK_END", scm_from_int (SEEK_END)); - scm_tc16_void_port = scm_make_port_type ("void", void_port_read, - void_port_write); - - cur_inport_fluid = scm_make_fluid (); - cur_outport_fluid = scm_make_fluid (); - cur_errport_fluid = scm_make_fluid (); - cur_warnport_fluid = scm_make_fluid (); - cur_loadport_fluid = scm_make_fluid (); - - scm_i_port_weak_set = scm_c_make_weak_set (31); - -#include "libguile/ports.x" - - /* Use Latin-1 as the default port encoding. */ - SCM_VARIABLE_SET (default_port_encoding_var, - scm_make_fluid_with_default (SCM_BOOL_F)); - scm_port_encoding_init = 1; - - SCM_VARIABLE_SET (default_conversion_strategy_var, - scm_make_fluid_with_default (sym_substitute)); - scm_conversion_strategy_init = 1; - /* These bindings are used when boot-9 turns `current-input-port' et al into parameters. They are then removed from the guile module. */ scm_c_define ("%current-input-port-fluid", cur_inport_fluid); @@ -3324,6 +3259,61 @@ scm_init_ports () scm_c_define ("%current-warning-port-fluid", cur_warnport_fluid); } +void +scm_init_ports (void) +{ + scm_tc16_void_port = scm_make_port_type ("void", void_port_read, + void_port_write); + + scm_i_port_weak_set = scm_c_make_weak_set (31); + + cur_inport_fluid = scm_make_fluid (); + cur_outport_fluid = scm_make_fluid (); + cur_errport_fluid = scm_make_fluid (); + cur_warnport_fluid = scm_make_fluid (); + cur_loadport_fluid = scm_make_fluid (); + + sym_substitute = scm_from_latin1_symbol ("substitute"); + sym_escape = scm_from_latin1_symbol ("escape"); + sym_error = scm_from_latin1_symbol ("error"); + + /* Use Latin-1 as the default port encoding. */ + default_port_encoding_var = + scm_c_define ("%default-port-encoding", + scm_make_fluid_with_default (SCM_BOOL_F)); + default_conversion_strategy_var = + scm_c_define ("%default-port-conversion-strategy", + scm_make_fluid_with_default (sym_substitute)); + + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_ice_9_ports", + (scm_t_extension_init_func) scm_init_ice_9_ports, + NULL); + + /* The following bindings are used early in boot-9.scm. */ + + /* Used by `include'. */ + scm_c_define_gsubr (s_scm_set_port_encoding_x, 2, 0, 0, + (scm_t_subr) scm_set_port_encoding_x); + scm_c_define_gsubr (s_scm_eof_object_p, 1, 0, 0, + (scm_t_subr) scm_eof_object_p); + + /* Used by a number of error/warning-printing routines. */ + scm_c_define_gsubr (s_scm_force_output, 0, 1, 0, + (scm_t_subr) scm_force_output); + + /* Used by `file-exists?' and related functions if `stat' is + unavailable. */ + scm_c_define_gsubr (s_scm_close_port, 1, 0, 0, + (scm_t_subr) scm_close_port); + + /* Used by error routines. */ + scm_c_define_gsubr (s_scm_current_error_port, 0, 0, 0, + (scm_t_subr) scm_current_error_port); + scm_c_define_gsubr (s_scm_current_warning_port, 0, 0, 0, + (scm_t_subr) scm_current_warning_port); +} + /* Local Variables: c-file-style: "gnu" diff --git a/module/Makefile.am b/module/Makefile.am index 6cb160314..71b265ae4 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -88,6 +88,7 @@ SOURCES = \ ice-9/poe.scm \ ice-9/poll.scm \ ice-9/popen.scm \ + ice-9/ports.scm \ ice-9/posix.scm \ ice-9/pretty-print.scm \ ice-9/psyntax-pp.scm \ diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 9e9efe65b..ee3648027 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -151,38 +151,6 @@ a-cont -;;; {Low-Level Port Code} -;;; - -;; These are used to request the proper mode to open files in. -;; -(define OPEN_READ "r") -(define OPEN_WRITE "w") -(define OPEN_BOTH "r+") - -(define *null-device* "/dev/null") - -;; NOTE: Later in this file, this is redefined to support keywords -(define (open-input-file str) - "Takes a string naming an existing file and returns an input port -capable of delivering characters from the file. If the file -cannot be opened, an error is signalled." - (open-file str OPEN_READ)) - -;; NOTE: Later in this file, this is redefined to support keywords -(define (open-output-file str) - "Takes a string naming an output file to be created and returns an -output port capable of writing characters to a new file by that -name. If the file cannot be opened, an error is signalled. If a -file with the given name already exists, the effect is unspecified." - (open-file str OPEN_WRITE)) - -(define (open-io-file str) - "Open file with name STR for both input and output." - (open-file str OPEN_BOTH)) - - - ;;; {Simple Debugging Tools} ;;; @@ -315,11 +283,10 @@ file with the given name already exists, the effect is unspecified." (for-eachn (cdr l1) (map cdr rest)))))))) -;; Temporary definition used in the include-from-path expansion; -;; replaced later. +;; Temporary definitions used by `include'; replaced later. -(define (absolute-file-name? file-name) - #t) +(define (absolute-file-name? file-name) #t) +(define (open-input-file str) (open-file str "r")) ;;; {and-map and or-map} ;;; @@ -1195,11 +1162,6 @@ VALUE." ;; ;; It should print OBJECT to PORT. -(define (inherit-print-state old-port new-port) - (if (get-print-state old-port) - (port-with-print-state new-port (get-print-state old-port)) - new-port)) - ;; 0: type-name, 1: fields, 2: constructor (define record-type-vtable (let ((s (make-vtable (string-append standard-vtable-fields "prprpw") @@ -1446,29 +1408,6 @@ CONV is not applied to the initial value." -;;; Current ports as parameters. -;;; - -(let () - (define-syntax-rule (port-parameterize! binding fluid predicate msg) - (begin - (set! binding (fluid->parameter (module-ref (current-module) 'fluid) - (lambda (x) - (if (predicate x) x - (error msg x))))) - (hashq-remove! (%get-pre-modules-obarray) 'fluid))) - - (port-parameterize! current-input-port %current-input-port-fluid - input-port? "expected an input port") - (port-parameterize! current-output-port %current-output-port-fluid - output-port? "expected an output port") - (port-parameterize! current-error-port %current-error-port-fluid - output-port? "expected an output port") - (port-parameterize! current-warning-port %current-warning-port-fluid - output-port? "expected an output port")) - - - ;;; {Languages} ;;; @@ -1483,140 +1422,6 @@ CONV is not applied to the initial value." ;;; {High-Level Port Routines} ;;; -(define* (open-input-file - file #:key (binary #f) (encoding #f) (guess-encoding #f)) - "Takes a string naming an existing file and returns an input port -capable of delivering characters from the file. If the file -cannot be opened, an error is signalled." - (open-file file (if binary "rb" "r") - #:encoding encoding - #:guess-encoding guess-encoding)) - -(define* (open-output-file file #:key (binary #f) (encoding #f)) - "Takes a string naming an output file to be created and returns an -output port capable of writing characters to a new file by that -name. If the file cannot be opened, an error is signalled. If a -file with the given name already exists, the effect is unspecified." - (open-file file (if binary "wb" "w") - #:encoding encoding)) - -(define* (call-with-input-file - file proc #:key (binary #f) (encoding #f) (guess-encoding #f)) - "PROC should be a procedure of one argument, and FILE should be a -string naming a file. The file must -already exist. These procedures call PROC -with one argument: the port obtained by opening the named file for -input or output. If the file cannot be opened, an error is -signalled. If the procedure returns, then the port is closed -automatically and the values yielded by the procedure are returned. -If the procedure does not return, then the port will not be closed -automatically unless it is possible to prove that the port will -never again be used for a read or write operation." - (let ((p (open-input-file file - #:binary binary - #:encoding encoding - #:guess-encoding guess-encoding))) - (call-with-values - (lambda () (proc p)) - (lambda vals - (close-input-port p) - (apply values vals))))) - -(define* (call-with-output-file file proc #:key (binary #f) (encoding #f)) - "PROC should be a procedure of one argument, and FILE should be a -string naming a file. The behaviour is unspecified if the file -already exists. These procedures call PROC -with one argument: the port obtained by opening the named file for -input or output. If the file cannot be opened, an error is -signalled. If the procedure returns, then the port is closed -automatically and the values yielded by the procedure are returned. -If the procedure does not return, then the port will not be closed -automatically unless it is possible to prove that the port will -never again be used for a read or write operation." - (let ((p (open-output-file file #:binary binary #:encoding encoding))) - (call-with-values - (lambda () (proc p)) - (lambda vals - (close-output-port p) - (apply values vals))))) - -(define (with-input-from-port port thunk) - (parameterize ((current-input-port port)) - (thunk))) - -(define (with-output-to-port port thunk) - (parameterize ((current-output-port port)) - (thunk))) - -(define (with-error-to-port port thunk) - (parameterize ((current-error-port port)) - (thunk))) - -(define* (with-input-from-file - file thunk #:key (binary #f) (encoding #f) (guess-encoding #f)) - "THUNK must be a procedure of no arguments, and FILE must be a -string naming a file. The file must already exist. The file is opened for -input, an input port connected to it is made -the default value returned by `current-input-port', -and the THUNK is called with no arguments. -When the THUNK returns, the port is closed and the previous -default is restored. Returns the values yielded by THUNK. If an -escape procedure is used to escape from the continuation of these -procedures, their behavior is implementation dependent." - (call-with-input-file file - (lambda (p) (with-input-from-port p thunk)) - #:binary binary - #:encoding encoding - #:guess-encoding guess-encoding)) - -(define* (with-output-to-file file thunk #:key (binary #f) (encoding #f)) - "THUNK must be a procedure of no arguments, and FILE must be a -string naming a file. The effect is unspecified if the file already exists. -The file is opened for output, an output port connected to it is made -the default value returned by `current-output-port', -and the THUNK is called with no arguments. -When the THUNK returns, the port is closed and the previous -default is restored. Returns the values yielded by THUNK. If an -escape procedure is used to escape from the continuation of these -procedures, their behavior is implementation dependent." - (call-with-output-file file - (lambda (p) (with-output-to-port p thunk)) - #:binary binary - #:encoding encoding)) - -(define* (with-error-to-file file thunk #:key (binary #f) (encoding #f)) - "THUNK must be a procedure of no arguments, and FILE must be a -string naming a file. The effect is unspecified if the file already exists. -The file is opened for output, an output port connected to it is made -the default value returned by `current-error-port', -and the THUNK is called with no arguments. -When the THUNK returns, the port is closed and the previous -default is restored. Returns the values yielded by THUNK. If an -escape procedure is used to escape from the continuation of these -procedures, their behavior is implementation dependent." - (call-with-output-file file - (lambda (p) (with-error-to-port p thunk)) - #:binary binary - #:encoding encoding)) - -(define (call-with-input-string string proc) - "Calls the one-argument procedure @var{proc} with a newly created -input port from which @var{string}'s contents may be read. The value -yielded by the @var{proc} is returned." - (proc (open-input-string string))) - -(define (with-input-from-string string thunk) - "THUNK must be a procedure of no arguments. -The test of STRING is opened for -input, an input port connected to it is made, -and the THUNK is called with no arguments. -When the THUNK returns, the port is closed. -Returns the values yielded by THUNK. If an -escape procedure is used to escape from the continuation of these -procedures, their behavior is implementation dependent." - (call-with-input-string string - (lambda (p) (with-input-from-port p thunk)))) - (define (call-with-output-string proc) "Calls the one-argument procedure @var{proc} with a newly created output port. When the function returns, the string composed of the characters @@ -1625,18 +1430,6 @@ written into the port is returned." (proc port) (get-output-string port))) -(define (with-output-to-string thunk) - "Calls THUNK and returns its output as a string." - (call-with-output-string - (lambda (p) (with-output-to-port p thunk)))) - -(define (with-error-to-string thunk) - "Calls THUNK and returns its error output as a string." - (call-with-output-string - (lambda (p) (with-error-to-port p thunk)))) - -(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p)))) - ;;; {Booleans} @@ -1758,95 +1551,9 @@ written into the port is returned." -;;; {File Descriptors and Ports} +;;; {C Environment} ;;; -(define file-position ftell) -(define* (file-set-position port offset #:optional (whence SEEK_SET)) - (seek port offset whence)) - -(define (move->fdes fd/port fd) - (cond ((integer? fd/port) - (dup->fdes fd/port fd) - (close fd/port) - fd) - (else - (primitive-move->fdes fd/port fd) - (set-port-revealed! fd/port 1) - fd/port))) - -(define (release-port-handle port) - (let ((revealed (port-revealed port))) - (if (> revealed 0) - (set-port-revealed! port (- revealed 1))))) - -(define dup->port - (case-lambda - ((port/fd mode) - (fdopen (dup->fdes port/fd) mode)) - ((port/fd mode new-fd) - (let ((port (fdopen (dup->fdes port/fd new-fd) mode))) - (set-port-revealed! port 1) - port)))) - -(define dup->inport - (case-lambda - ((port/fd) - (dup->port port/fd "r")) - ((port/fd new-fd) - (dup->port port/fd "r" new-fd)))) - -(define dup->outport - (case-lambda - ((port/fd) - (dup->port port/fd "w")) - ((port/fd new-fd) - (dup->port port/fd "w" new-fd)))) - -(define dup - (case-lambda - ((port/fd) - (if (integer? port/fd) - (dup->fdes port/fd) - (dup->port port/fd (port-mode port/fd)))) - ((port/fd new-fd) - (if (integer? port/fd) - (dup->fdes port/fd new-fd) - (dup->port port/fd (port-mode port/fd) new-fd))))) - -(define (duplicate-port port modes) - (dup->port port modes)) - -(define (fdes->inport fdes) - (let loop ((rest-ports (fdes->ports fdes))) - (cond ((null? rest-ports) - (let ((result (fdopen fdes "r"))) - (set-port-revealed! result 1) - result)) - ((input-port? (car rest-ports)) - (set-port-revealed! (car rest-ports) - (+ (port-revealed (car rest-ports)) 1)) - (car rest-ports)) - (else - (loop (cdr rest-ports)))))) - -(define (fdes->outport fdes) - (let loop ((rest-ports (fdes->ports fdes))) - (cond ((null? rest-ports) - (let ((result (fdopen fdes "w"))) - (set-port-revealed! result 1) - result)) - ((output-port? (car rest-ports)) - (set-port-revealed! (car rest-ports) - (+ (port-revealed (car rest-ports)) 1)) - (car rest-ports)) - (else - (loop (cdr rest-ports)))))) - -(define (port->fdes port) - (set-port-revealed! port (+ (port-revealed port) 1)) - (fileno port)) - (define (setenv name value) (if value (putenv (string-append name "=" value)) @@ -4322,6 +4029,16 @@ when none is available, reading FILE-NAME with READER." +;;; {Ports} +;;; + +;; Allow code in (guile) to use port bindings. +(module-use! the-root-module (resolve-interface '(ice-9 ports))) +;; Allow users of (guile) to see port bindings. +(module-use! the-scm-module (resolve-interface '(ice-9 ports))) + + + ;;; SRFI-4 in the default environment. FIXME: we should figure out how ;;; to deprecate this. ;;; diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm new file mode 100644 index 000000000..0dd1df718 --- /dev/null +++ b/module/ice-9/ports.scm @@ -0,0 +1,469 @@ +;;; Ports +;;; Copyright (C) 2016 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 License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this program. If not, see +;;; . + +;;; Commentary: +;;; +;;; Implementation of input/output routines over ports. +;;; +;;; Note that loading this module overrides some core bindings; see the +;;; `replace-bootstrap-bindings' invocation below for details. +;;; +;;; Code: + + +(define-module (ice-9 ports) + #:export (;; Definitions from ports.c. + %port-property + %set-port-property! + current-input-port current-output-port + current-error-port current-warning-port + set-current-input-port set-current-output-port + set-current-error-port + port-mode + port? + input-port? + output-port? + port-closed? + eof-object? + close-port + close-input-port + close-output-port + ;; These two are currently defined by scm_init_ports; fix? + ;; %default-port-encoding + ;; %default-port-conversion-strategy + port-encoding + set-port-encoding! + port-conversion-strategy + set-port-conversion-strategy! + read-char + peek-char + unread-char + unread-string + setvbuf + drain-input + force-output + char-ready? + seek SEEK_SET SEEK_CUR SEEK_END + truncate-file + port-line + set-port-line! + port-column + set-port-column! + port-filename + set-port-filename! + port-for-each + flush-all-ports + %make-void-port + + ;; Definitions from fports.c. + open-file + file-port? + port-revealed + set-port-revealed! + adjust-port-revealed! + ;; note: %file-port-name-canonicalization is used in boot-9 + + ;; Definitions from ioext.c. + ftell + redirect-port + dup->fdes + dup2 + fileno + isatty? + fdopen + primitive-move->fdes + fdes->ports + + ;; Definitions in Scheme + file-position + file-set-position + move->fdes + release-port-handle + dup->port + dup->inport + dup->outport + dup + duplicate-port + fdes->inport + fdes->outport + port->fdes + OPEN_READ OPEN_WRITE OPEN_BOTH + *null-device* + open-input-file + open-output-file + open-io-file + call-with-input-file + call-with-output-file + with-input-from-port + with-output-to-port + with-error-to-port + with-input-from-file + with-output-to-file + with-error-to-file + call-with-input-string + with-input-from-string + call-with-output-string + with-output-to-string + with-error-to-string + the-eof-object + inherit-print-state)) + +(define (replace-bootstrap-bindings syms) + (for-each + (lambda (sym) + (let* ((var (module-variable the-scm-module sym)) + (mod (current-module)) + (iface (module-public-interface mod))) + (unless var (error "unbound in root module" sym)) + (module-add! mod sym var) + (when (module-local-variable iface sym) + (module-add! iface sym var)))) + syms)) + +(replace-bootstrap-bindings '(open-file + open-input-file + set-port-encoding! + eof-object? + force-output + call-with-output-string + close-port + current-error-port + current-warning-port)) + +(load-extension (string-append "libguile-" (effective-version)) + "scm_init_ice_9_ports") +(load-extension (string-append "libguile-" (effective-version)) + "scm_init_ice_9_fports") +(load-extension (string-append "libguile-" (effective-version)) + "scm_init_ice_9_ioext") + + + +;;; Current ports as parameters. +;;; + +(define current-input-port + (fluid->parameter %current-input-port-fluid + (lambda (x) + (unless (input-port? x) + (error "expected an input port" x)) + x))) + +(define current-output-port + (fluid->parameter %current-output-port-fluid + (lambda (x) + (unless (output-port? x) + (error "expected an output port" x)) + x))) + +(define current-error-port + (fluid->parameter %current-error-port-fluid + (lambda (x) + (unless (output-port? x) + (error "expected an output port" x)) + x))) + +(define current-warning-port + (fluid->parameter %current-warning-port-fluid + (lambda (x) + (unless (output-port? x) + (error "expected an output port" x)) + x))) + + + + +;;; {File Descriptors and Ports} +;;; + +(define file-position ftell) +(define* (file-set-position port offset #:optional (whence SEEK_SET)) + (seek port offset whence)) + +(define (move->fdes fd/port fd) + (cond ((integer? fd/port) + (dup->fdes fd/port fd) + (close fd/port) + fd) + (else + (primitive-move->fdes fd/port fd) + (set-port-revealed! fd/port 1) + fd/port))) + +(define (release-port-handle port) + (let ((revealed (port-revealed port))) + (if (> revealed 0) + (set-port-revealed! port (- revealed 1))))) + +(define dup->port + (case-lambda + ((port/fd mode) + (fdopen (dup->fdes port/fd) mode)) + ((port/fd mode new-fd) + (let ((port (fdopen (dup->fdes port/fd new-fd) mode))) + (set-port-revealed! port 1) + port)))) + +(define dup->inport + (case-lambda + ((port/fd) + (dup->port port/fd "r")) + ((port/fd new-fd) + (dup->port port/fd "r" new-fd)))) + +(define dup->outport + (case-lambda + ((port/fd) + (dup->port port/fd "w")) + ((port/fd new-fd) + (dup->port port/fd "w" new-fd)))) + +(define dup + (case-lambda + ((port/fd) + (if (integer? port/fd) + (dup->fdes port/fd) + (dup->port port/fd (port-mode port/fd)))) + ((port/fd new-fd) + (if (integer? port/fd) + (dup->fdes port/fd new-fd) + (dup->port port/fd (port-mode port/fd) new-fd))))) + +(define (duplicate-port port modes) + (dup->port port modes)) + +(define (fdes->inport fdes) + (let loop ((rest-ports (fdes->ports fdes))) + (cond ((null? rest-ports) + (let ((result (fdopen fdes "r"))) + (set-port-revealed! result 1) + result)) + ((input-port? (car rest-ports)) + (set-port-revealed! (car rest-ports) + (+ (port-revealed (car rest-ports)) 1)) + (car rest-ports)) + (else + (loop (cdr rest-ports)))))) + +(define (fdes->outport fdes) + (let loop ((rest-ports (fdes->ports fdes))) + (cond ((null? rest-ports) + (let ((result (fdopen fdes "w"))) + (set-port-revealed! result 1) + result)) + ((output-port? (car rest-ports)) + (set-port-revealed! (car rest-ports) + (+ (port-revealed (car rest-ports)) 1)) + (car rest-ports)) + (else + (loop (cdr rest-ports)))))) + +(define (port->fdes port) + (set-port-revealed! port (+ (port-revealed port) 1)) + (fileno port)) + +;; Legacy interfaces. + +(define (set-current-input-port port) + "Set the current default input port to @var{port}." + (current-input-port port)) + +(define (set-current-output-port port) + "Set the current default output port to @var{port}." + (current-output-port port)) + +(define (set-current-error-port port) + "Set the current default error port to @var{port}." + (current-error-port port)) + + +;;;; high level routines + + +;;; {High-Level Port Routines} +;;; + +;; These are used to request the proper mode to open files in. +;; +(define OPEN_READ "r") +(define OPEN_WRITE "w") +(define OPEN_BOTH "r+") + +(define *null-device* "/dev/null") + +(define* (open-input-file + file #:key (binary #f) (encoding #f) (guess-encoding #f)) + "Takes a string naming an existing file and returns an input port +capable of delivering characters from the file. If the file +cannot be opened, an error is signalled." + (open-file file (if binary "rb" "r") + #:encoding encoding + #:guess-encoding guess-encoding)) + +(define* (open-output-file file #:key (binary #f) (encoding #f)) + "Takes a string naming an output file to be created and returns an +output port capable of writing characters to a new file by that +name. If the file cannot be opened, an error is signalled. If a +file with the given name already exists, the effect is unspecified." + (open-file file (if binary "wb" "w") + #:encoding encoding)) + +(define (open-io-file str) + "Open file with name STR for both input and output." + (open-file str OPEN_BOTH)) + +(define* (call-with-input-file + file proc #:key (binary #f) (encoding #f) (guess-encoding #f)) + "PROC should be a procedure of one argument, and FILE should be a +string naming a file. The file must +already exist. These procedures call PROC +with one argument: the port obtained by opening the named file for +input or output. If the file cannot be opened, an error is +signalled. If the procedure returns, then the port is closed +automatically and the values yielded by the procedure are returned. +If the procedure does not return, then the port will not be closed +automatically unless it is possible to prove that the port will +never again be used for a read or write operation." + (let ((p (open-input-file file + #:binary binary + #:encoding encoding + #:guess-encoding guess-encoding))) + (call-with-values + (lambda () (proc p)) + (lambda vals + (close-input-port p) + (apply values vals))))) + +(define* (call-with-output-file file proc #:key (binary #f) (encoding #f)) + "PROC should be a procedure of one argument, and FILE should be a +string naming a file. The behaviour is unspecified if the file +already exists. These procedures call PROC +with one argument: the port obtained by opening the named file for +input or output. If the file cannot be opened, an error is +signalled. If the procedure returns, then the port is closed +automatically and the values yielded by the procedure are returned. +If the procedure does not return, then the port will not be closed +automatically unless it is possible to prove that the port will +never again be used for a read or write operation." + (let ((p (open-output-file file #:binary binary #:encoding encoding))) + (call-with-values + (lambda () (proc p)) + (lambda vals + (close-output-port p) + (apply values vals))))) + +(define (with-input-from-port port thunk) + (parameterize ((current-input-port port)) + (thunk))) + +(define (with-output-to-port port thunk) + (parameterize ((current-output-port port)) + (thunk))) + +(define (with-error-to-port port thunk) + (parameterize ((current-error-port port)) + (thunk))) + +(define* (with-input-from-file + file thunk #:key (binary #f) (encoding #f) (guess-encoding #f)) + "THUNK must be a procedure of no arguments, and FILE must be a +string naming a file. The file must already exist. The file is opened for +input, an input port connected to it is made +the default value returned by `current-input-port', +and the THUNK is called with no arguments. +When the THUNK returns, the port is closed and the previous +default is restored. Returns the values yielded by THUNK. If an +escape procedure is used to escape from the continuation of these +procedures, their behavior is implementation dependent." + (call-with-input-file file + (lambda (p) (with-input-from-port p thunk)) + #:binary binary + #:encoding encoding + #:guess-encoding guess-encoding)) + +(define* (with-output-to-file file thunk #:key (binary #f) (encoding #f)) + "THUNK must be a procedure of no arguments, and FILE must be a +string naming a file. The effect is unspecified if the file already exists. +The file is opened for output, an output port connected to it is made +the default value returned by `current-output-port', +and the THUNK is called with no arguments. +When the THUNK returns, the port is closed and the previous +default is restored. Returns the values yielded by THUNK. If an +escape procedure is used to escape from the continuation of these +procedures, their behavior is implementation dependent." + (call-with-output-file file + (lambda (p) (with-output-to-port p thunk)) + #:binary binary + #:encoding encoding)) + +(define* (with-error-to-file file thunk #:key (binary #f) (encoding #f)) + "THUNK must be a procedure of no arguments, and FILE must be a +string naming a file. The effect is unspecified if the file already exists. +The file is opened for output, an output port connected to it is made +the default value returned by `current-error-port', +and the THUNK is called with no arguments. +When the THUNK returns, the port is closed and the previous +default is restored. Returns the values yielded by THUNK. If an +escape procedure is used to escape from the continuation of these +procedures, their behavior is implementation dependent." + (call-with-output-file file + (lambda (p) (with-error-to-port p thunk)) + #:binary binary + #:encoding encoding)) + +(define (call-with-input-string string proc) + "Calls the one-argument procedure @var{proc} with a newly created +input port from which @var{string}'s contents may be read. The value +yielded by the @var{proc} is returned." + (proc (open-input-string string))) + +(define (with-input-from-string string thunk) + "THUNK must be a procedure of no arguments. +The test of STRING is opened for +input, an input port connected to it is made, +and the THUNK is called with no arguments. +When the THUNK returns, the port is closed. +Returns the values yielded by THUNK. If an +escape procedure is used to escape from the continuation of these +procedures, their behavior is implementation dependent." + (call-with-input-string string + (lambda (p) (with-input-from-port p thunk)))) + +(define (call-with-output-string proc) + "Calls the one-argument procedure @var{proc} with a newly created output +port. When the function returns, the string composed of the characters +written into the port is returned." + (let ((port (open-output-string))) + (proc port) + (get-output-string port))) + +(define (with-output-to-string thunk) + "Calls THUNK and returns its output as a string." + (call-with-output-string + (lambda (p) (with-output-to-port p thunk)))) + +(define (with-error-to-string thunk) + "Calls THUNK and returns its error output as a string." + (call-with-output-string + (lambda (p) (with-error-to-port p thunk)))) + +(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p)))) + +(define (inherit-print-state old-port new-port) + (if (get-print-state old-port) + (port-with-print-state new-port (get-print-state old-port)) + new-port)) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 6029f0565..0d30b7c3f 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -3246,7 +3246,7 @@ (set-port-encoding! p (let ((t enc)) (if t t "UTF-8"))) (let f ((x (read p)) (result '())) (if (eof-object? x) - (begin (close-input-port p) (reverse result)) + (begin (close-port p) (reverse result)) (f (read p) (cons (datum->syntax k x) result))))))))) (let ((src (syntax-source x))) (let ((file (if src (assq-ref src 'filename) #f))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index c9c309ae1..0bc602431 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -3183,7 +3183,7 @@ (result '())) (if (eof-object? x) (begin - (close-input-port p) + (close-port p) (reverse result)) (f (read p) (cons (datum->syntax k x) result))))))) From 2214fff5241f23a1dc5b1f171e97bafed9990ed0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 17 Apr 2016 14:39:51 +0200 Subject: [PATCH 210/865] Remove unrelated scm_t_port_buffer use in vports * libguile/vports.c (struct soft_port): Inline the encoding buffer so as to not use scm_t_port_buffer, in anticipation of changing the port buffer representations. Adapt users. --- libguile/vports.c | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/libguile/vports.c b/libguile/vports.c index e52057065..5ef54fdce 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -52,6 +52,8 @@ static scm_t_bits scm_tc16_soft_port; +#define ENCODE_BUF_SIZE 10 + struct soft_port { SCM write_char; SCM write_string; @@ -59,7 +61,9 @@ struct soft_port { SCM read_char; SCM close; SCM input_waiting; - scm_t_port_buffer *encode_buf; + scm_t_uint8 encode_buf[ENCODE_BUF_SIZE]; + size_t encode_cur; + size_t encode_end; }; @@ -94,14 +98,13 @@ soft_port_read (SCM port, SCM dst, size_t start, size_t count) { size_t written; struct soft_port *stream = (void *) SCM_STREAM (port); - scm_t_port_buffer *encode_buf = stream->encode_buf; signed char *dst_ptr = SCM_BYTEVECTOR_CONTENTS (dst) + start; /* A character can be more than one byte, but we don't have a guarantee that there is more than one byte in the read buffer. So, use an intermediate buffer. Terrible. This whole facility should be (re)designed. */ - if (encode_buf->cur == encode_buf->end) + if (stream->encode_cur == stream->encode_end) { SCM ans; char *str; @@ -115,17 +118,17 @@ soft_port_read (SCM port, SCM dst, size_t start, size_t count) /* It's possible to make a fast path here, but it would be fastest if the read procedure could fill its buffer directly. */ str = scm_to_port_stringn (scm_string (scm_list_1 (ans)), &len, port); - assert (len > 0 && len <= encode_buf->size); - encode_buf->cur = 0; - encode_buf->end = len; - memcpy (encode_buf->buf, str, len); + assert (len > 0 && len <= ENCODE_BUF_SIZE); + stream->encode_cur = 0; + stream->encode_end = len; + memcpy (stream->encode_buf, str, len); free (str); } for (written = 0; - written < count && encode_buf->cur < encode_buf->end; - written++, encode_buf->cur++) - dst_ptr[written] = encode_buf->buf[encode_buf->cur]; + written < count && stream->encode_cur < stream->encode_end; + written++, stream->encode_cur++) + dst_ptr[written] = stream->encode_buf[stream->encode_cur]; return written; } @@ -218,8 +221,6 @@ SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, stream->input_waiting = vlen == 6 ? SCM_SIMPLE_VECTOR_REF (pv, 5) : SCM_BOOL_F; - stream->encode_buf = scm_c_make_port_buffer (10); - return scm_c_make_port (scm_tc16_soft_port, scm_i_mode_bits (modes), (scm_t_bits) stream); } From f62974000f74c2e6e160b02137ab037466812014 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 17 Apr 2016 15:42:13 +0200 Subject: [PATCH 211/865] Port buffer has-eof? field is SCM value * libguile/ports.h (scm_t_port_buffer): Rename has_eof member to has_eof_p, and be a Scheme value, in anticipation of moving the port buffers to be Scheme objects. --- libguile/ports.c | 19 ++++++++++--------- libguile/ports.h | 4 ++-- libguile/r6rs-ports.c | 2 +- 3 files changed, 13 insertions(+), 12 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index d1bb231f0..39551bc06 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -307,13 +307,13 @@ scm_set_port_get_natural_buffer_sizes static void scm_i_set_pending_eof (SCM port) { - SCM_PTAB_ENTRY (port)->read_buf->has_eof = 1; + SCM_PTAB_ENTRY (port)->read_buf->has_eof_p = SCM_BOOL_T; } static void scm_i_clear_pending_eof (SCM port) { - SCM_PTAB_ENTRY (port)->read_buf->has_eof = 0; + SCM_PTAB_ENTRY (port)->read_buf->has_eof_p = SCM_BOOL_F; } SCM_DEFINE (scm_i_port_property, "%port-property", 2, 0, 0, @@ -520,6 +520,7 @@ scm_c_make_port_buffer (size_t size) ret->size = size; ret->bytevector = scm_c_make_bytevector (size); ret->buf = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (ret->bytevector); + ret->has_eof_p = SCM_BOOL_F; return ret; } @@ -1419,7 +1420,7 @@ scm_i_read_unlocked (SCM port, scm_t_port_buffer *buf) count = scm_i_read_bytes_unlocked (port, buf->bytevector, buf->end, buf->size - buf->end); buf->end += count; - buf->has_eof = count == 0; + buf->has_eof_p = scm_from_bool (count == 0); } /* Used by an application to read arbitrary number of bytes from an SCM @@ -1473,7 +1474,7 @@ scm_c_read_bytes_unlocked (SCM port, SCM dst, size_t start, size_t count) if (to_copy == 0) { /* Consider that we've read off this EOF. */ - read_buf->has_eof = 0; + read_buf->has_eof_p = SCM_BOOL_F; break; } dst_ptr += to_copy; @@ -1537,7 +1538,7 @@ scm_c_read_unlocked (SCM port, void *buffer, size_t size) else { /* Consider that we've read off this EOF. */ - read_buf->has_eof = 0; + read_buf->has_eof_p = SCM_BOOL_F; break; } } @@ -2030,7 +2031,7 @@ scm_i_unget_bytes_unlocked (const scm_t_uint8 *buf, size_t len, SCM port) new_buf = scm_c_make_port_buffer (size); new_buf->end = new_buf->size; new_buf->cur = new_buf->end - buffered; - new_buf->has_eof = read_buf->has_eof; + new_buf->has_eof_p = read_buf->has_eof_p; memcpy (new_buf->buf + new_buf->cur, read_buf->buf + read_buf->cur, buffered); @@ -2364,7 +2365,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, port); if (saved_read_buf) - pt->read_buf->has_eof = saved_read_buf->has_eof; + pt->read_buf->has_eof_p = saved_read_buf->has_eof_p; return SCM_UNSPECIFIED; } @@ -2519,7 +2520,7 @@ scm_fill_input_unlocked (SCM port) scm_t_port *pt = SCM_PTAB_ENTRY (port); scm_t_port_buffer *read_buf = pt->read_buf; - if (read_buf->cur < read_buf->end || read_buf->has_eof) + if (read_buf->cur < read_buf->end || scm_is_true (read_buf->has_eof_p)) return read_buf; if (pt->rw_random) @@ -2800,7 +2801,7 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, pt = SCM_PTAB_ENTRY (port); read_buf = pt->read_buf; - if (read_buf->cur < read_buf->end || read_buf->has_eof) + if (read_buf->cur < read_buf->end || scm_is_true (read_buf->has_eof_p)) /* FIXME: Verify that a whole character is available? */ return SCM_BOOL_T; else diff --git a/libguile/ports.h b/libguile/ports.h index e7277e3ab..3c48bb754 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -85,7 +85,7 @@ typedef struct zero bytes. Note that in the case of pushback, there could still be bytes in the buffer, but that after any bytes are read off, peek-u8 should still return EOF. */ - int has_eof; + SCM has_eof_p; /* Bytevector whose contents are [BUF, BUF + SIZE). */ SCM bytevector; @@ -441,7 +441,7 @@ scm_get_byte_or_eof_unlocked (SCM port) /* The next peek or get should cause the read() function to be called to see if we still have EOF. */ - buf->has_eof = 0; + buf->has_eof_p = SCM_BOOL_F; return EOF; } diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 4b2df9229..c1cf95af3 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -477,7 +477,7 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0, buf = scm_fill_input_unlocked (port); if (buf->cur == buf->end) { - buf->has_eof = 0; + buf->has_eof_p = SCM_BOOL_F; return SCM_EOF_VAL; } From b869344a4f238ad66ab33e08de5c7b66ed823fc3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 17 Apr 2016 19:38:44 +0200 Subject: [PATCH 212/865] Remove size field from port buffers * libguile/ports.h (scm_t_port_buffer): Remove size field. Instead use bytevector size. * libguile/ports-internal.h (scm_port_buffer_size) (scm_port_buffer_reset) (scm_port_buffer_can_take, scm_port_buffer_can_put) (scm_port_buffer_did_take, scm_port_buffer_did_put) (scm_port_buffer_take_pointer, scm_port_buffer_put_pointer) (scm_port_buffer_take, scm_port_buffer_put): New helpers. * libguile/filesys.c (set_element): Use new helpers. * libguile/poll.c (scm_primitive_poll): Use new helpers. * libguile/ports.c (scm_c_make_port_buffer): No more "size" field. (scm_i_read_unlocked, scm_c_read_bytes_unlocked) (scm_c_read_unlocked, scm_i_unget_bytes_unlocked) (scm_unget_bytes, scm_setvbuf, scm_take_from_input_buffers) (scm_drain_input, scm_end_input_unlocked, scm_flush_unlocked) (scm_fill_input_unlocked, scm_i_write_unlocked) (scm_c_write_bytes_unlocked, scm_c_write_unlocked) (scm_char_ready_p): Use new helpers. * libguile/r6rs-ports.c (scm_get_bytevector_some): Use new helpers. * libguile/rw.c (scm_write_string_partial): Use new helpers. --- libguile/filesys.c | 5 +- libguile/poll.c | 11 +-- libguile/ports-internal.h | 71 ++++++++++++++++ libguile/ports.c | 172 ++++++++++++++++---------------------- libguile/ports.h | 3 +- libguile/r6rs-ports.c | 4 +- libguile/rw.c | 3 +- 7 files changed, 157 insertions(+), 112 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index 03a0b069c..5e0a2321c 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -47,6 +47,7 @@ #include "libguile/strings.h" #include "libguile/vectors.h" #include "libguile/dynwind.h" +#include "libguile/ports-internal.h" #include "libguile/validate.h" #include "libguile/filesys.h" @@ -652,7 +653,7 @@ set_element (fd_set *set, SCM *ports_ready, SCM element, int pos) /* check whether port has buffered input. */ scm_t_port *pt = SCM_PTAB_ENTRY (element); - if (pt->read_buf->cur < pt->read_buf->end) + if (scm_port_buffer_can_take (pt->read_buf) > 0) use_buf = 1; } else if (pos == SCM_ARG2) @@ -661,7 +662,7 @@ set_element (fd_set *set, SCM *ports_ready, SCM element, int pos) scm_t_port *pt = SCM_PTAB_ENTRY (element); /* > 1 since writing the last byte in the buffer causes flush. */ - if (pt->write_buf->size - pt->write_buf->end > 1) + if (scm_port_buffer_can_put (pt->write_buf) > 1) use_buf = 1; } fd = use_buf ? -1 : SCM_FPORT_FDES (element); diff --git a/libguile/poll.c b/libguile/poll.c index 1e8fa7a3b..9557339c2 100644 --- a/libguile/poll.c +++ b/libguile/poll.c @@ -29,8 +29,9 @@ #include "libguile/_scm.h" #include "libguile/bytevectors.h" -#include "libguile/numbers.h" #include "libguile/error.h" +#include "libguile/numbers.h" +#include "libguile/ports-internal.h" #include "libguile/validate.h" #include "libguile/poll.h" @@ -108,11 +109,11 @@ scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout) { scm_t_port *pt = SCM_PTAB_ENTRY (port); - if (pt->read_buf->cur < pt->read_buf->end) + if (scm_port_buffer_can_take (pt->read_buf) > 0) /* Buffered input waiting to be read. */ revents |= POLLIN; if (SCM_OUTPUT_PORT_P (port) - && pt->write_buf->size - pt->write_buf->end > 1) + && scm_port_buffer_can_put (pt->write_buf) > 1) /* Buffered output possible. The "> 1" is because writing the last byte would flush the port. */ revents |= POLLOUT; @@ -146,11 +147,11 @@ scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout) { scm_t_port *pt = SCM_PTAB_ENTRY (port); - if (pt->read_buf->cur < pt->read_buf->end) + if (scm_port_buffer_can_take (pt->read_buf) > 0) /* Buffered input waiting to be read. */ revents |= POLLIN; if (SCM_OUTPUT_PORT_P (port) - && pt->write_buf->size - pt->write_buf->end > 1) + && scm_port_buffer_can_put (pt->write_buf) > 1) /* Buffered output possible. The "> 1" is because writing the last byte would flush the port. */ revents |= POLLOUT; diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index 1a94bd5b2..b3f15e187 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -25,6 +25,77 @@ #include "libguile/_scm.h" #include "libguile/ports.h" +static inline size_t +scm_port_buffer_size (scm_t_port_buffer *buf) +{ + return scm_c_bytevector_length (buf->bytevector); +} + +static inline void +scm_port_buffer_reset (scm_t_port_buffer *buf) +{ + buf->cur = buf->end = 0; +} + +static inline size_t +scm_port_buffer_can_take (scm_t_port_buffer *buf) +{ + return buf->end - buf->cur; +} + +static inline size_t +scm_port_buffer_can_put (scm_t_port_buffer *buf) +{ + return scm_port_buffer_size (buf) - buf->end; +} + +static inline void +scm_port_buffer_did_take (scm_t_port_buffer *buf, size_t count) +{ + buf->cur += count; +} + +static inline void +scm_port_buffer_did_put (scm_t_port_buffer *buf, size_t count) +{ + buf->end += count; +} + +static inline const scm_t_uint8 * +scm_port_buffer_take_pointer (scm_t_port_buffer *buf) +{ + signed char *ret = SCM_BYTEVECTOR_CONTENTS (buf->bytevector); + return ((scm_t_uint8 *) ret) + buf->cur; +} + +static inline scm_t_uint8 * +scm_port_buffer_put_pointer (scm_t_port_buffer *buf) +{ + signed char *ret = SCM_BYTEVECTOR_CONTENTS (buf->bytevector); + return ((scm_t_uint8 *) ret) + buf->end; +} + +static inline size_t +scm_port_buffer_take (scm_t_port_buffer *buf, scm_t_uint8 *dst, size_t count) +{ + count = min (count, scm_port_buffer_can_take (buf)); + if (dst) + memcpy (dst, scm_port_buffer_take_pointer (buf), count); + scm_port_buffer_did_take (buf, count); + return count; +} + +static inline size_t +scm_port_buffer_put (scm_t_port_buffer *buf, const scm_t_uint8 *src, + size_t count) +{ + count = min (count, scm_port_buffer_can_put (buf)); + if (src) + memcpy (scm_port_buffer_put_pointer (buf), src, count); + scm_port_buffer_did_put (buf, count); + return count; +} + enum scm_port_encoding_mode { SCM_PORT_ENCODING_MODE_UTF8, SCM_PORT_ENCODING_MODE_LATIN1, diff --git a/libguile/ports.c b/libguile/ports.c index 39551bc06..2351438df 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -517,7 +517,6 @@ scm_c_make_port_buffer (size_t size) { scm_t_port_buffer *ret = scm_gc_typed_calloc (scm_t_port_buffer); - ret->size = size; ret->bytevector = scm_c_make_bytevector (size); ret->buf = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (ret->bytevector); ret->has_eof_p = SCM_BOOL_F; @@ -1415,11 +1414,9 @@ scm_i_read_unlocked (SCM port, scm_t_port_buffer *buf) { size_t count; - assert (buf->end < buf->size); - count = scm_i_read_bytes_unlocked (port, buf->bytevector, buf->end, - buf->size - buf->end); - buf->end += count; + scm_port_buffer_can_put (buf)); + scm_port_buffer_did_put (buf, count); buf->has_eof_p = scm_from_bool (count == 0); } @@ -1435,7 +1432,7 @@ scm_c_read_bytes_unlocked (SCM port, SCM dst, size_t start, size_t count) size_t to_read = count; scm_t_port *pt; scm_t_port_buffer *read_buf; - signed char *dst_ptr = SCM_BYTEVECTOR_CONTENTS (dst) + start; + scm_t_uint8 *dst_ptr = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (dst) + start; SCM_VALIDATE_OPINPORT (1, port); @@ -1450,48 +1447,41 @@ scm_c_read_bytes_unlocked (SCM port, SCM dst, size_t start, size_t count) } /* Take bytes first from the port's read buffer. */ - if (read_buf->cur < read_buf->end) - { - size_t to_copy = count; - to_copy = min (to_copy, read_buf->end - read_buf->cur); - memcpy (dst_ptr, read_buf->buf + read_buf->cur, to_copy); - dst_ptr += to_copy; - to_read -= to_copy; - read_buf->cur += to_copy; - } + { + size_t did_read = scm_port_buffer_take (read_buf, dst_ptr, to_read); + dst_ptr += did_read; + to_read -= did_read; + } while (to_read) { + size_t did_read; + /* If the read is smaller than the buffering on the read side of this port, then go through the buffer. Otherwise fill our buffer directly. */ if (to_read < pt->read_buffering) { - size_t to_copy = to_read; read_buf = scm_fill_input_unlocked (port); - to_copy = min (to_copy, read_buf->end - read_buf->cur); - memcpy (dst_ptr, read_buf->buf + read_buf->cur, to_copy); - if (to_copy == 0) + did_read = scm_port_buffer_take (read_buf, dst_ptr, to_read); + dst_ptr += did_read; + to_read -= did_read; + if (did_read == 0) { /* Consider that we've read off this EOF. */ read_buf->has_eof_p = SCM_BOOL_F; break; } - dst_ptr += to_copy; - to_read -= to_copy; - read_buf->cur += to_copy; } else { - size_t filled; - - filled = scm_i_read_bytes_unlocked (port, dst, - start + count - to_read, - to_read); - if (filled == 0) + did_read = scm_i_read_bytes_unlocked (port, dst, + start + count - to_read, + to_read); + to_read -= did_read; + dst_ptr += did_read; + if (did_read == 0) break; - to_read -= filled; - dst_ptr += filled; } } @@ -1525,17 +1515,11 @@ scm_c_read_unlocked (SCM port, void *buffer, size_t size) while (copied < size) { + size_t count; read_buf = scm_fill_input_unlocked (port); - /* Take bytes first from the port's read buffer. */ - if (read_buf->cur < read_buf->end) - { - size_t to_copy = size - copied; - to_copy = min (to_copy, read_buf->end - read_buf->cur); - memcpy (dst + copied, read_buf->buf + read_buf->cur, to_copy); - copied += to_copy; - read_buf->cur += to_copy; - } - else + count = scm_port_buffer_take (read_buf, dst + copied, size - copied); + copied += count; + if (count == 0) { /* Consider that we've read off this EOF. */ read_buf->has_eof_p = SCM_BOOL_F; @@ -2005,31 +1989,31 @@ scm_i_unget_bytes_unlocked (const scm_t_uint8 *buf, size_t len, SCM port) if (read_buf->cur < len) { /* The bytes don't fit directly in the read_buf. */ - if (len <= read_buf->cur + (read_buf->size - read_buf->end)) + size_t buffered, size; + + buffered = scm_port_buffer_can_take (read_buf); + size = scm_port_buffer_size (read_buf); + + if (len <= size - buffered) { /* But they would fit if we shift the not-yet-read bytes from the read_buf right. Let's do that. */ - size_t to_move = read_buf->end - read_buf->cur; - - if (to_move > 0) - memmove (read_buf->buf + (read_buf->size - to_move), - read_buf->buf + read_buf->cur, - to_move); - read_buf->end = read_buf->size; - read_buf->cur = read_buf->end - to_move; + memmove (read_buf->buf + (size - buffered), + scm_port_buffer_take_pointer (read_buf), + buffered); + read_buf->end = size; + read_buf->cur = read_buf->end - buffered; } else { /* Bah, have to expand the read_buf for the putback. */ scm_t_port_buffer *new_buf; - size_t buffered = read_buf->end - read_buf->cur; - size_t size = read_buf->size; while (size < len + buffered) size *= 2; new_buf = scm_c_make_port_buffer (size); - new_buf->end = new_buf->size; + new_buf->end = size; new_buf->cur = new_buf->end - buffered; new_buf->has_eof_p = read_buf->has_eof_p; memcpy (new_buf->buf + new_buf->cur, read_buf->buf + read_buf->cur, @@ -2061,6 +2045,8 @@ void scm_unget_bytes (const unsigned char *buf, size_t len, SCM port) { scm_i_pthread_mutex_t *lock; + if (len == 0) + return; scm_c_lock_port (port, &lock); scm_i_unget_bytes_unlocked (buf, len, port); if (lock) @@ -2359,9 +2345,9 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, pt->read_buf = scm_c_make_port_buffer (read_buf_size); pt->write_buf = scm_c_make_port_buffer (write_buf_size); - if (saved_read_buf && saved_read_buf->cur < saved_read_buf->end) - scm_unget_bytes (saved_read_buf->buf + saved_read_buf->cur, - saved_read_buf->end - saved_read_buf->cur, + if (saved_read_buf) + scm_unget_bytes (scm_port_buffer_take_pointer (saved_read_buf), + scm_port_buffer_can_take (saved_read_buf), port); if (saved_read_buf) @@ -2391,13 +2377,8 @@ scm_fill_input (SCM port) size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len) { - scm_t_port *pt = SCM_PTAB_ENTRY (port); - scm_t_port_buffer *read_buf = pt->read_buf; - size_t count = min (read_buf->end - read_buf->cur, read_len); - - memcpy (dest, read_buf->buf + read_buf->cur, count); - read_buf->cur += count; - return count; + scm_t_port_buffer *read_buf = SCM_PTAB_ENTRY (port)->read_buf; + return scm_port_buffer_take (read_buf, (scm_t_uint8 *) dest, read_len); } /* Clear a port's read buffers, returning the contents. */ @@ -2426,14 +2407,13 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, SCM_VALIDATE_OPINPORT (1, port); pt = SCM_PTAB_ENTRY (port); read_buf = pt->read_buf; - - count = read_buf->end - read_buf->cur; + count = scm_port_buffer_can_take (read_buf); if (count) { - scm_t_uint8 *ptr = read_buf->buf + read_buf->cur; - result = scm_from_port_stringn ((char *) ptr, count, port); - read_buf->cur = read_buf->end; + const scm_t_uint8 *ptr = scm_port_buffer_take_pointer (read_buf); + result = scm_from_port_stringn ((const char *) ptr, count, port); + scm_port_buffer_did_take (read_buf, count); } else result = scm_nullstr; @@ -2447,17 +2427,16 @@ scm_end_input_unlocked (SCM port) { scm_t_port *pt; scm_t_port_buffer *buf; - scm_t_off offset; + size_t discarded; pt = SCM_PTAB_ENTRY (port); buf = SCM_PTAB_ENTRY (port)->read_buf; - offset = buf->cur - buf->end; + discarded = scm_port_buffer_take (buf, NULL, (size_t) -1); assert (pt->rw_random); - buf->end = buf->cur = 0; - if (offset != 0) - SCM_PORT_DESCRIPTOR (port)->seek (port, offset, SEEK_CUR); + if (discarded != 0) + SCM_PORT_DESCRIPTOR (port)->seek (port, -discarded, SEEK_CUR); pt->rw_active = SCM_PORT_NEITHER; } @@ -2499,7 +2478,7 @@ void scm_flush_unlocked (SCM port) { scm_t_port_buffer *buf = SCM_PTAB_ENTRY (port)->write_buf; - if (buf->cur < buf->end) + if (scm_port_buffer_can_take (buf)) scm_i_write_unlocked (port, buf); SCM_PTAB_ENTRY (port)->rw_active = SCM_PORT_NEITHER; } @@ -2520,7 +2499,7 @@ scm_fill_input_unlocked (SCM port) scm_t_port *pt = SCM_PTAB_ENTRY (port); scm_t_port_buffer *read_buf = pt->read_buf; - if (read_buf->cur < read_buf->end || scm_is_true (read_buf->has_eof_p)) + if (scm_port_buffer_can_take (read_buf) || scm_is_true (read_buf->has_eof_p)) return read_buf; if (pt->rw_random) @@ -2532,10 +2511,10 @@ scm_fill_input_unlocked (SCM port) /* It could be that putback caused us to enlarge the buffer; now that we've read all the bytes we need to shrink it again. */ - if (read_buf->size != pt->read_buffering) + if (scm_port_buffer_size (read_buf) != pt->read_buffering) read_buf = pt->read_buf = scm_c_make_port_buffer (pt->read_buffering); else - read_buf->cur = read_buf->end = 0; + scm_port_buffer_reset (read_buf); scm_i_read_unlocked (port, read_buf); @@ -2589,7 +2568,7 @@ scm_i_write_unlocked (SCM port, scm_t_port_buffer *src) size_t start, count; assert (src->cur < src->end); - assert (src->end <= src->size); + assert (src->end <= scm_port_buffer_size (src)); /* Update cursors before attempting to write, assuming that I/O errors are sticky. That way if the write throws an error, causing the @@ -2599,7 +2578,7 @@ scm_i_write_unlocked (SCM port, scm_t_port_buffer *src) start = src->cur; count = src->end - src->cur; - src->cur = src->end = 0; + scm_port_buffer_reset (src); scm_i_write_bytes_unlocked (port, src->bytevector, start, count); } @@ -2627,34 +2606,34 @@ scm_c_write_bytes_unlocked (SCM port, SCM src, size_t start, size_t count) pt->rw_active = SCM_PORT_WRITE; } - if (count < write_buf->size) + if (count < scm_port_buffer_size (write_buf)) { /* Make it so that write_buf->end is only nonzero if there are buffered bytes already. */ - if (write_buf->cur == write_buf->end) - write_buf->cur = write_buf->end = 0; + if (scm_port_buffer_can_take (write_buf) == 0) + scm_port_buffer_reset (write_buf); /* We buffer writes that are smaller in size than the write buffer. If the buffer is too full to hold the new data, we flush it beforehand. Otherwise it could be that the buffer is full after filling it with the new data; if that's the case, we flush then instead. */ - if (write_buf->end + count > write_buf->size) + if (scm_port_buffer_can_put (write_buf) < count) scm_i_write_unlocked (port, write_buf); - memcpy (write_buf->buf + write_buf->end, - SCM_BYTEVECTOR_CONTENTS (src) + start, - count); - write_buf->end += count; + { + signed char *src_ptr = SCM_BYTEVECTOR_CONTENTS (src) + start; + scm_port_buffer_put (write_buf, (scm_t_uint8 *) src_ptr, count); + } - if (write_buf->end == write_buf->size) + if (scm_port_buffer_can_put (write_buf) == 0) scm_i_write_unlocked (port, write_buf); } else { /* Our write would overflow the buffer. Flush buffered bytes (if needed), then write our bytes with just one syscall. */ - if (write_buf->cur < write_buf->end) + if (scm_port_buffer_can_take (write_buf)) scm_i_write_unlocked (port, write_buf); scm_i_write_bytes_unlocked (port, src, start, count); @@ -2690,17 +2669,10 @@ scm_c_write_unlocked (SCM port, const void *ptr, size_t size) while (written < size) { - size_t to_write = write_buf->size - write_buf->end; - - if (to_write > size - written) - to_write = size - written; - - memcpy (write_buf->buf + write_buf->end, src, to_write); - write_buf->end += to_write; - written += to_write; - src += to_write; - - if (write_buf->end == write_buf->size) + size_t did_put = scm_port_buffer_put (write_buf, src, size - written); + written += did_put; + src += did_put; + if (scm_port_buffer_can_put (write_buf) == 0) scm_i_write_unlocked (port, write_buf); } } @@ -2801,7 +2773,7 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, pt = SCM_PTAB_ENTRY (port); read_buf = pt->read_buf; - if (read_buf->cur < read_buf->end || scm_is_true (read_buf->has_eof_p)) + if (scm_port_buffer_can_take (read_buf) || scm_is_true (read_buf->has_eof_p)) /* FIXME: Verify that a whole character is available? */ return SCM_BOOL_T; else diff --git a/libguile/ports.h b/libguile/ports.h index 3c48bb754..9e28e4837 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -76,10 +76,9 @@ typedef struct /* Start of the buffer. Never changed. */ scm_t_uint8 *buf; - /* Offsets into the buffer. Invariant: cur <= end <= size. */ + /* Offsets into the buffer. Invariant: cur <= end <= size(buf). */ size_t cur; size_t end; - size_t size; /* For read buffers, flag indicating whether the last read() returned zero bytes. Note that in the case of pushback, there could still diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index c1cf95af3..4c5c87ca5 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -475,13 +475,13 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0, SCM_VALIDATE_BINARY_INPUT_PORT (1, port); buf = scm_fill_input_unlocked (port); - if (buf->cur == buf->end) + size = scm_port_buffer_can_take (buf); + if (size == 0) { buf->has_eof_p = SCM_BOOL_F; return SCM_EOF_VAL; } - size = buf->end - buf->cur; bv = scm_c_make_bytevector (size); scm_take_from_input_buffers (port, (char *) SCM_BYTEVECTOR_CONTENTS (bv), size); diff --git a/libguile/rw.c b/libguile/rw.c index 9bd23208a..76467a90e 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -36,6 +36,7 @@ #include "libguile/validate.h" #include "libguile/modules.h" #include "libguile/strports.h" +#include "libguile/ports-internal.h" #include #ifdef HAVE_IO_H @@ -239,7 +240,7 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0, /* Filling the last character in the buffer would require a flush. */ - if (write_len < write_buf->size - write_buf->end) + if (write_len < scm_port_buffer_size (write_buf) - write_buf->end) { scm_c_write_unlocked (port, src, write_len); return scm_from_long (write_len); From 10dc6d043e0b76f36461f0a04160a4d2f411413e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 18 Apr 2016 00:19:24 +0200 Subject: [PATCH 213/865] Remove "buf" field from port buffers * libguile/ports-internal.h (scm_port_buffer_reset_end): New helper. (scm_port_buffer_putback): New helper. * libguile/ports.h (scm_t_port_buffer): Remove "buf" field. (scm_get_byte_or_eof_unlocked, scm_peek_byte_or_eof_unlocked): Adapt. * libguile/ports.c (scm_c_make_port_buffer): No more "buf" field. (scm_i_unget_bytes_unlocked): Use helper. * libguile/read.c (scm_i_scan_for_encoding): No more "buf" field. --- libguile/ports-internal.h | 20 ++++++++++++++++++++ libguile/ports.c | 21 ++++++++------------- libguile/ports.h | 22 ++++++++++++---------- libguile/read.c | 2 +- 4 files changed, 41 insertions(+), 24 deletions(-) diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index b3f15e187..14d00c2a6 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -22,6 +22,8 @@ #ifndef SCM_PORTS_INTERNAL #define SCM_PORTS_INTERNAL +#include + #include "libguile/_scm.h" #include "libguile/ports.h" @@ -37,6 +39,12 @@ scm_port_buffer_reset (scm_t_port_buffer *buf) buf->cur = buf->end = 0; } +static inline void +scm_port_buffer_reset_end (scm_t_port_buffer *buf) +{ + buf->cur = buf->end = scm_port_buffer_size (buf); +} + static inline size_t scm_port_buffer_can_take (scm_t_port_buffer *buf) { @@ -96,6 +104,18 @@ scm_port_buffer_put (scm_t_port_buffer *buf, const scm_t_uint8 *src, return count; } +static inline void +scm_port_buffer_putback (scm_t_port_buffer *buf, const scm_t_uint8 *src, + size_t count) +{ + assert (count <= buf->cur); + + /* Sometimes used to move around data within a buffer, so we must use + memmove. */ + buf->cur -= count; + memmove (SCM_BYTEVECTOR_CONTENTS (buf->bytevector) + buf->cur, src, count); +} + enum scm_port_encoding_mode { SCM_PORT_ENCODING_MODE_UTF8, SCM_PORT_ENCODING_MODE_LATIN1, diff --git a/libguile/ports.c b/libguile/ports.c index 2351438df..a433e28fb 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -518,7 +518,6 @@ scm_c_make_port_buffer (size_t size) scm_t_port_buffer *ret = scm_gc_typed_calloc (scm_t_port_buffer); ret->bytevector = scm_c_make_bytevector (size); - ret->buf = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (ret->bytevector); ret->has_eof_p = SCM_BOOL_F; return ret; @@ -1998,11 +1997,9 @@ scm_i_unget_bytes_unlocked (const scm_t_uint8 *buf, size_t len, SCM port) { /* But they would fit if we shift the not-yet-read bytes from the read_buf right. Let's do that. */ - memmove (read_buf->buf + (size - buffered), - scm_port_buffer_take_pointer (read_buf), - buffered); - read_buf->end = size; - read_buf->cur = read_buf->end - buffered; + const scm_t_uint8 *to_shift = scm_port_buffer_take_pointer (read_buf); + scm_port_buffer_reset_end (read_buf); + scm_port_buffer_putback (read_buf, to_shift, buffered); } else { @@ -2013,18 +2010,16 @@ scm_i_unget_bytes_unlocked (const scm_t_uint8 *buf, size_t len, SCM port) size *= 2; new_buf = scm_c_make_port_buffer (size); - new_buf->end = size; - new_buf->cur = new_buf->end - buffered; + scm_port_buffer_reset_end (new_buf); new_buf->has_eof_p = read_buf->has_eof_p; - memcpy (new_buf->buf + new_buf->cur, read_buf->buf + read_buf->cur, - buffered); - + scm_port_buffer_putback (new_buf, + scm_port_buffer_take_pointer (read_buf), + buffered); pt->read_buf = read_buf = new_buf; } } - read_buf->cur -= len; - memcpy (read_buf->buf + read_buf->cur, buf, len); + scm_port_buffer_putback (read_buf, buf, len); } #undef FUNC_NAME diff --git a/libguile/ports.h b/libguile/ports.h index 9e28e4837..12a67ec99 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -29,6 +29,7 @@ #include #include #include +#include "libguile/bytevectors.h" #include "libguile/gc.h" #include "libguile/tags.h" #include "libguile/error.h" @@ -73,8 +74,8 @@ struct scm_port_internal; typedef struct { - /* Start of the buffer. Never changed. */ - scm_t_uint8 *buf; + /* The port buffer. */ + SCM bytevector; /* Offsets into the buffer. Invariant: cur <= end <= size(buf). */ size_t cur; @@ -86,8 +87,6 @@ typedef struct peek-u8 should still return EOF. */ SCM has_eof_p; - /* Bytevector whose contents are [BUF, BUF + SIZE). */ - SCM bytevector; } scm_t_port_buffer; @@ -430,13 +429,16 @@ SCM_INLINE_IMPLEMENTATION int scm_get_byte_or_eof_unlocked (SCM port) { scm_t_port_buffer *buf = SCM_PTAB_ENTRY (port)->read_buf; + scm_t_uint8 *ptr; + ptr = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (buf->bytevector); if (SCM_LIKELY (buf->cur < buf->end)) - return buf->buf[buf->cur++]; + return ptr[buf->cur++]; buf = scm_fill_input_unlocked (port); + ptr = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (buf->bytevector); if (buf->cur < buf->end) - return buf->buf[buf->cur++]; + return ptr[buf->cur++]; /* The next peek or get should cause the read() function to be called to see if we still have EOF. */ @@ -448,15 +450,15 @@ scm_get_byte_or_eof_unlocked (SCM port) SCM_INLINE_IMPLEMENTATION int scm_peek_byte_or_eof_unlocked (SCM port) { - scm_t_port *pt = SCM_PTAB_ENTRY (port); - scm_t_port_buffer *buf = pt->read_buf; + scm_t_port_buffer *buf = SCM_PTAB_ENTRY (port)->read_buf; + scm_t_uint8 *ptr = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (buf->bytevector); if (SCM_LIKELY (buf->cur < buf->end)) - return buf->buf[buf->cur]; + return ptr[buf->cur]; buf = scm_fill_input_unlocked (port); if (buf->cur < buf->end) - return buf->buf[buf->cur]; + return ptr[buf->cur]; return EOF; } diff --git a/libguile/read.c b/libguile/read.c index 27cb094b9..a4357d179 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -2086,7 +2086,7 @@ scm_i_scan_for_encoding (SCM port) /* An unbuffered port -- don't scan. */ return NULL; - memcpy (header, buf->buf + buf->cur, bytes_read); + memcpy (header, scm_port_buffer_take_pointer (buf), bytes_read); header[bytes_read] = '\0'; } else From ffb4347d5330fbd2b3e78d761613955f83aeef3d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 19 Apr 2016 19:50:21 +0200 Subject: [PATCH 214/865] Port buffer cur/next pointers are Scheme values * libguile/ports.h (scm_t_port_buffer): Change "cur" and "end" members to be SCM values, in preparation for changing port buffers to be Scheme vectors. (scm_get_byte_or_eof_unlocked, scm_peek_byte_or_eof_unlocked): Adapt. * libguile/ports.c (scm_c_make_port_buffer): Initialize cur and end members. (looking_at_bytes): Use helper instead of incrementing cur. (scm_i_read_unlocked): Adapt to end type change. (CONSUME_PEEKED_BYTE): Use helper instead of incrementing cur. (scm_i_unget_bytes_unlocked): Use helper instead of comparing cur. (scm_i_write_unlocked): Fix for changing end/cur types. * libguile/read.c (scm_i_scan_for_encoding): Use helpers instead of addressing cursors directly. * libguile/rw.c (scm_write_string_partial): Likewise. * libguile/ports-internal.h (scm_port_buffer_reset): (scm_port_buffer_reset_end, scm_port_buffer_can_take): (scm_port_buffer_can_put, scm_port_buffer_can_putback): (scm_port_buffer_did_take, scm_port_buffer_did_put): (scm_port_buffer_take_pointer, scm_port_buffer_put_pointer): (scm_port_buffer_putback): Adapt to data types. --- libguile/ports-internal.h | 29 ++++++++++++++++---------- libguile/ports.c | 18 +++++++++------- libguile/ports.h | 44 ++++++++++++++++++++++++++------------- libguile/read.c | 4 ++-- libguile/rw.c | 2 +- 5 files changed, 61 insertions(+), 36 deletions(-) diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index 14d00c2a6..862d85800 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -36,51 +36,57 @@ scm_port_buffer_size (scm_t_port_buffer *buf) static inline void scm_port_buffer_reset (scm_t_port_buffer *buf) { - buf->cur = buf->end = 0; + buf->cur = buf->end = SCM_INUM0; } static inline void scm_port_buffer_reset_end (scm_t_port_buffer *buf) { - buf->cur = buf->end = scm_port_buffer_size (buf); + buf->cur = buf->end = scm_from_size_t (scm_port_buffer_size (buf)); } static inline size_t scm_port_buffer_can_take (scm_t_port_buffer *buf) { - return buf->end - buf->cur; + return scm_to_size_t (buf->end) - scm_to_size_t (buf->cur); } static inline size_t scm_port_buffer_can_put (scm_t_port_buffer *buf) { - return scm_port_buffer_size (buf) - buf->end; + return scm_port_buffer_size (buf) - scm_to_size_t (buf->end); +} + +static inline size_t +scm_port_buffer_can_putback (scm_t_port_buffer *buf) +{ + return scm_to_size_t (buf->cur); } static inline void scm_port_buffer_did_take (scm_t_port_buffer *buf, size_t count) { - buf->cur += count; + buf->cur = scm_from_size_t (scm_to_size_t (buf->cur) + count); } static inline void scm_port_buffer_did_put (scm_t_port_buffer *buf, size_t count) { - buf->end += count; + buf->end = scm_from_size_t (scm_to_size_t (buf->end) + count); } static inline const scm_t_uint8 * scm_port_buffer_take_pointer (scm_t_port_buffer *buf) { signed char *ret = SCM_BYTEVECTOR_CONTENTS (buf->bytevector); - return ((scm_t_uint8 *) ret) + buf->cur; + return ((scm_t_uint8 *) ret) + scm_to_size_t (buf->cur); } static inline scm_t_uint8 * scm_port_buffer_put_pointer (scm_t_port_buffer *buf) { signed char *ret = SCM_BYTEVECTOR_CONTENTS (buf->bytevector); - return ((scm_t_uint8 *) ret) + buf->end; + return ((scm_t_uint8 *) ret) + scm_to_size_t (buf->end); } static inline size_t @@ -108,12 +114,13 @@ static inline void scm_port_buffer_putback (scm_t_port_buffer *buf, const scm_t_uint8 *src, size_t count) { - assert (count <= buf->cur); + assert (count <= scm_to_size_t (buf->cur)); /* Sometimes used to move around data within a buffer, so we must use memmove. */ - buf->cur -= count; - memmove (SCM_BYTEVECTOR_CONTENTS (buf->bytevector) + buf->cur, src, count); + buf->cur = scm_from_size_t (scm_to_size_t (buf->cur) - count); + memmove (SCM_BYTEVECTOR_CONTENTS (buf->bytevector) + scm_to_size_t (buf->cur), + src, count); } enum scm_port_encoding_mode { diff --git a/libguile/ports.c b/libguile/ports.c index a433e28fb..b8b6dbf92 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -518,6 +518,7 @@ scm_c_make_port_buffer (size_t size) scm_t_port_buffer *ret = scm_gc_typed_calloc (scm_t_port_buffer); ret->bytevector = scm_c_make_bytevector (size); + ret->cur = ret->end = SCM_INUM0; ret->has_eof_p = SCM_BOOL_F; return ret; @@ -1000,7 +1001,7 @@ looking_at_bytes (SCM port, const unsigned char *bytes, int len) while (i < len && scm_peek_byte_or_eof_unlocked (port) == bytes[i]) { - pt->read_buf->cur++; + scm_port_buffer_did_take (pt->read_buf, 1); i++; } scm_i_unget_bytes_unlocked (bytes, i, port); @@ -1413,7 +1414,8 @@ scm_i_read_unlocked (SCM port, scm_t_port_buffer *buf) { size_t count; - count = scm_i_read_bytes_unlocked (port, buf->bytevector, buf->end, + count = scm_i_read_bytes_unlocked (port, buf->bytevector, + scm_to_size_t (buf->end), scm_port_buffer_can_put (buf)); scm_port_buffer_did_put (buf, count); buf->has_eof_p = scm_from_bool (count == 0); @@ -1636,7 +1638,7 @@ get_utf8_codepoint (SCM port, scm_t_wchar *codepoint, if (SCM_UNLIKELY ((b) == EOF)) \ goto invalid_seq #define CONSUME_PEEKED_BYTE() \ - pt->read_buf->cur++ + scm_port_buffer_did_take (pt->read_buf, 1) int byte; scm_t_port *pt; @@ -1985,7 +1987,7 @@ scm_i_unget_bytes_unlocked (const scm_t_uint8 *buf, size_t len, SCM port) pt->rw_active = SCM_PORT_READ; } - if (read_buf->cur < len) + if (scm_port_buffer_can_putback (read_buf) < len) { /* The bytes don't fit directly in the read_buf. */ size_t buffered, size; @@ -2562,8 +2564,8 @@ scm_i_write_unlocked (SCM port, scm_t_port_buffer *src) { size_t start, count; - assert (src->cur < src->end); - assert (src->end <= scm_port_buffer_size (src)); + assert (scm_to_size_t (src->cur) < scm_to_size_t (src->end)); + assert (scm_to_size_t (src->end) <= scm_port_buffer_size (src)); /* Update cursors before attempting to write, assuming that I/O errors are sticky. That way if the write throws an error, causing the @@ -2571,8 +2573,8 @@ scm_i_write_unlocked (SCM port, scm_t_port_buffer *src) by GC when it's open, any subsequent close-port / force-output won't signal *another* error. */ - start = src->cur; - count = src->end - src->cur; + start = scm_to_size_t (src->cur); + count = scm_port_buffer_can_take (src); scm_port_buffer_reset (src); scm_i_write_bytes_unlocked (port, src->bytevector, start, count); } diff --git a/libguile/ports.h b/libguile/ports.h index 12a67ec99..173562324 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -78,8 +78,8 @@ typedef struct SCM bytevector; /* Offsets into the buffer. Invariant: cur <= end <= size(buf). */ - size_t cur; - size_t end; + SCM cur; + SCM end; /* For read buffers, flag indicating whether the last read() returned zero bytes. Note that in the case of pushback, there could still @@ -429,16 +429,24 @@ SCM_INLINE_IMPLEMENTATION int scm_get_byte_or_eof_unlocked (SCM port) { scm_t_port_buffer *buf = SCM_PTAB_ENTRY (port)->read_buf; - scm_t_uint8 *ptr; + size_t cur; - ptr = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (buf->bytevector); - if (SCM_LIKELY (buf->cur < buf->end)) - return ptr[buf->cur++]; + cur = scm_to_size_t (buf->cur); + if (SCM_LIKELY (cur < scm_to_size_t (buf->end))) + { + scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf->bytevector)[cur]; + buf->cur = scm_from_size_t (cur + 1); + return ret; + } buf = scm_fill_input_unlocked (port); - ptr = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (buf->bytevector); - if (buf->cur < buf->end) - return ptr[buf->cur++]; + cur = scm_to_size_t (buf->cur); + if (cur < scm_to_size_t (buf->end)) + { + scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf->bytevector)[cur]; + buf->cur = scm_from_size_t (cur + 1); + return ret; + } /* The next peek or get should cause the read() function to be called to see if we still have EOF. */ @@ -451,14 +459,22 @@ SCM_INLINE_IMPLEMENTATION int scm_peek_byte_or_eof_unlocked (SCM port) { scm_t_port_buffer *buf = SCM_PTAB_ENTRY (port)->read_buf; - scm_t_uint8 *ptr = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (buf->bytevector); + size_t cur; - if (SCM_LIKELY (buf->cur < buf->end)) - return ptr[buf->cur]; + cur = scm_to_size_t (buf->cur); + if (SCM_LIKELY (cur < scm_to_size_t (buf->end))) + { + scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf->bytevector)[cur]; + return ret; + } buf = scm_fill_input_unlocked (port); - if (buf->cur < buf->end) - return ptr[buf->cur]; + cur = scm_to_size_t (buf->cur); + if (cur < scm_to_size_t (buf->end)) + { + scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf->bytevector)[cur]; + return ret; + } return EOF; } diff --git a/libguile/read.c b/libguile/read.c index a4357d179..bc5c3c179 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -2074,11 +2074,11 @@ scm_i_scan_for_encoding (SCM port) pt->rw_active = SCM_PORT_READ; } - if (buf->cur == buf->end) + if (scm_port_buffer_can_take (buf) == 0) { /* We can use the read buffer, and thus avoid a seek. */ buf = scm_fill_input_unlocked (port); - bytes_read = buf->end - buf->cur; + bytes_read = scm_port_buffer_can_take (buf); if (bytes_read > SCM_ENCODING_SEARCH_SIZE) bytes_read = SCM_ENCODING_SEARCH_SIZE; diff --git a/libguile/rw.c b/libguile/rw.c index 76467a90e..d6437e96a 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -240,7 +240,7 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0, /* Filling the last character in the buffer would require a flush. */ - if (write_len < scm_port_buffer_size (write_buf) - write_buf->end) + if (write_len < scm_port_buffer_can_put (write_buf)) { scm_c_write_unlocked (port, src, write_len); return scm_from_long (write_len); From bb6edc5a35c570b3355dd69f89cbc8d0f85fc21c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 19 Apr 2016 22:58:33 +0200 Subject: [PATCH 215/865] peek-u8 correctness and speed refactor * libguile/ports-internal.h (scm_port_buffer_size): Verify that the bytevector field is a bytevector, in anticipation of Schemification. (scm_port_buffer_can_take, scm_port_buffer_can_put) (scm_port_buffer_can_putback): Enforce invariants on cur and end here. (scm_port_buffer_did_take, scm_port_buffer_did_put): Relax to not call other functions. * libguile/ports.h (scm_get_byte_or_eof_unlocked) (scm_peek_byte_or_eof_unlocked): Refactor to call no functions on the fast path. --- libguile/ports-internal.h | 42 +++++++++++++++++++++++++++++++++------ libguile/ports.h | 18 ++++++++++------- 2 files changed, 47 insertions(+), 13 deletions(-) diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index 862d85800..a8c4ea93b 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -27,10 +27,26 @@ #include "libguile/_scm.h" #include "libguile/ports.h" +/* The port buffers are exposed to Scheme, which can mutate their + fields. We have to do dynamic checks to ensure that + potentially-malicious Scheme doesn't invalidate our invariants. + However these dynamic checks are slow, so we need to avoid them where + they are unnecessary. An unnecessary check is a check which has + already been performed, or one which would already be performed by + the time that memory is accessed. Given that the "can_take", + "can_put", or "can_putback" functions are eventually called before + any access to the buffer, we hoist the necessary type checks the + can_foo and size functions, and otherwise assume that the cur and end + values are inums within the right ranges. */ + static inline size_t scm_port_buffer_size (scm_t_port_buffer *buf) { - return scm_c_bytevector_length (buf->bytevector); + if (SCM_LIKELY (SCM_BYTEVECTOR_P (buf->bytevector))) + return SCM_BYTEVECTOR_LENGTH (buf->bytevector); + scm_misc_error (NULL, "invalid port buffer ~a", + scm_list_1 (buf->bytevector)); + return -1; } static inline void @@ -48,31 +64,45 @@ scm_port_buffer_reset_end (scm_t_port_buffer *buf) static inline size_t scm_port_buffer_can_take (scm_t_port_buffer *buf) { - return scm_to_size_t (buf->end) - scm_to_size_t (buf->cur); + size_t cur, end; + cur = scm_to_size_t (buf->cur); + end = scm_to_size_t (buf->end); + if (cur > end || end > scm_port_buffer_size (buf)) + scm_misc_error (NULL, "invalid port buffer cursors ~a, ~a", + scm_list_2 (buf->cur, buf->end)); + return end - cur; } static inline size_t scm_port_buffer_can_put (scm_t_port_buffer *buf) { - return scm_port_buffer_size (buf) - scm_to_size_t (buf->end); + size_t end = scm_to_size_t (buf->end); + if (end > scm_port_buffer_size (buf)) + scm_misc_error (NULL, "invalid port buffer cursor ~a", + scm_list_1 (buf->end)); + return scm_port_buffer_size (buf) - end; } static inline size_t scm_port_buffer_can_putback (scm_t_port_buffer *buf) { - return scm_to_size_t (buf->cur); + size_t cur = scm_to_size_t (buf->cur); + if (cur > scm_port_buffer_size (buf)) + scm_misc_error (NULL, "invalid port buffer cursor ~a", + scm_list_1 (buf->cur)); + return cur; } static inline void scm_port_buffer_did_take (scm_t_port_buffer *buf, size_t count) { - buf->cur = scm_from_size_t (scm_to_size_t (buf->cur) + count); + buf->cur = SCM_I_MAKINUM (SCM_I_INUM (buf->cur) + count); } static inline void scm_port_buffer_did_put (scm_t_port_buffer *buf, size_t count) { - buf->end = scm_from_size_t (scm_to_size_t (buf->end) + count); + buf->end = SCM_I_MAKINUM (SCM_I_INUM (buf->end) + count); } static inline const scm_t_uint8 * diff --git a/libguile/ports.h b/libguile/ports.h index 173562324..997b755d9 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -429,13 +429,15 @@ SCM_INLINE_IMPLEMENTATION int scm_get_byte_or_eof_unlocked (SCM port) { scm_t_port_buffer *buf = SCM_PTAB_ENTRY (port)->read_buf; - size_t cur; + size_t cur = SCM_I_INUM (buf->cur); - cur = scm_to_size_t (buf->cur); - if (SCM_LIKELY (cur < scm_to_size_t (buf->end))) + if (SCM_LIKELY (SCM_I_INUMP (buf->cur)) + && SCM_LIKELY (SCM_I_INUMP (buf->end)) + && SCM_LIKELY (cur < SCM_I_INUM (buf->end)) + && SCM_LIKELY (cur < SCM_BYTEVECTOR_LENGTH (buf->bytevector))) { scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf->bytevector)[cur]; - buf->cur = scm_from_size_t (cur + 1); + buf->cur = SCM_I_MAKINUM (cur + 1); return ret; } @@ -459,10 +461,12 @@ SCM_INLINE_IMPLEMENTATION int scm_peek_byte_or_eof_unlocked (SCM port) { scm_t_port_buffer *buf = SCM_PTAB_ENTRY (port)->read_buf; - size_t cur; + size_t cur = SCM_I_INUM (buf->cur); - cur = scm_to_size_t (buf->cur); - if (SCM_LIKELY (cur < scm_to_size_t (buf->end))) + if (SCM_LIKELY (SCM_I_INUMP (buf->cur)) + && SCM_LIKELY (SCM_I_INUMP (buf->end)) + && SCM_LIKELY (cur < SCM_I_INUM (buf->end)) + && SCM_LIKELY (cur < SCM_BYTEVECTOR_LENGTH (buf->bytevector))) { scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf->bytevector)[cur]; return ret; From 5a342f61c4b09e503918b8bd2d996f138b114849 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 20 Apr 2016 09:09:15 +0200 Subject: [PATCH 216/865] Port buffers are Scheme values * libguile/ports-internal.h (scm_port_buffer_bytevector) (scm_port_buffer_cur, scm_port_buffer_set_cur) (scm_port_buffer_end, scm_port_buffer_set_end) (scm_port_buffer_has_eof_p, scm_port_buffer_set_has_eof_p): New helpers. * libguile/ports-internal.h (scm_port_buffer_size) (scm_port_buffer_reset, scm_port_buffer_reset_end) (scm_port_buffer_can_take, scm_port_buffer_can_put) (scm_port_buffer_can_putback, scm_port_buffer_did_take) (scm_port_buffer_did_put, scm_port_buffer_take_pointer) (scm_port_buffer_put_pointer, scm_port_buffer_take) (scm_port_buffer_put, scm_port_buffer_putback): Adapt to treat port buffers as SCM values and use helpers to access them. * libguile/ports.c (scm_i_clear_pending_eof, scm_i_set_pending_eof) (scm_c_make_port_buffer, scm_i_read_unlocked) (scm_c_read_bytes_unlocked, scm_i_unget_bytes_unlocked) (scm_setvbuf, scm_fill_input, scm_take_from_input_buffers) (scm_drain_input, scm_end_input_unlocked, scm_flush_unlocked) (scm_fill_input_unlocked, scm_i_write_unlocked) (scm_c_write_bytes_unlocked, scm_c_write_unlocked) (scm_char_ready_p): Adapt to treat port buffers as SCM values and use helpers to access them. (scm_port_read_buffer, scm_port_write_buffer): New functions, allowing (ice-9 ports) to access port buffers. * libguile/ports.h: Update comments on port buffers. Replace scm_t_port_buffer structure with a Scheme vector whose fields are enumerated by "enum scm_port_buffer_field". (scm_get_byte_or_eof_unlocked, scm_peek_byte_or_eof_unlocked): Adapt these implementations to port buffer representation change. * libguile/r6rs-ports.c (scm_get_bytevector_some): * libguile/read.c (scm_i_scan_for_encoding): * libguile/rw.c (scm_write_string_partial): Port buffers are Scheme objects. --- libguile/ports-internal.h | 127 ++++++++++++++++++++++++----------- libguile/ports.c | 138 ++++++++++++++++++++++++++------------ libguile/ports.h | 119 ++++++++++++++++++-------------- libguile/r6rs-ports.c | 4 +- libguile/read.c | 2 +- libguile/rw.c | 2 +- 6 files changed, 251 insertions(+), 141 deletions(-) diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index a8c4ea93b..19e49a7bd 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -39,88 +39,132 @@ can_foo and size functions, and otherwise assume that the cur and end values are inums within the right ranges. */ -static inline size_t -scm_port_buffer_size (scm_t_port_buffer *buf) +static inline SCM +scm_port_buffer_bytevector (SCM buf) { - if (SCM_LIKELY (SCM_BYTEVECTOR_P (buf->bytevector))) - return SCM_BYTEVECTOR_LENGTH (buf->bytevector); - scm_misc_error (NULL, "invalid port buffer ~a", - scm_list_1 (buf->bytevector)); + return SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_BYTEVECTOR); +} + +static inline SCM +scm_port_buffer_cur (SCM buf) +{ + return SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_CUR); +} + +static inline void +scm_port_buffer_set_cur (SCM buf, SCM cur) +{ + SCM_SIMPLE_VECTOR_SET (buf, SCM_PORT_BUFFER_FIELD_CUR, cur); +} + +static inline SCM +scm_port_buffer_end (SCM buf) +{ + return SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_END); +} + +static inline void +scm_port_buffer_set_end (SCM buf, SCM end) +{ + SCM_SIMPLE_VECTOR_SET (buf, SCM_PORT_BUFFER_FIELD_END, end); +} + +static inline SCM +scm_port_buffer_has_eof_p (SCM buf) +{ + return SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_HAS_EOF_P); +} + +static inline void +scm_port_buffer_set_has_eof_p (SCM buf, SCM has_eof_p) +{ + SCM_SIMPLE_VECTOR_SET (buf, SCM_PORT_BUFFER_FIELD_HAS_EOF_P, + has_eof_p); +} + +static inline size_t +scm_port_buffer_size (SCM buf) +{ + SCM bv = scm_port_buffer_bytevector (buf); + if (SCM_LIKELY (SCM_BYTEVECTOR_P (bv))) + return SCM_BYTEVECTOR_LENGTH (bv); + scm_misc_error (NULL, "invalid port buffer ~a", scm_list_1 (bv)); return -1; } static inline void -scm_port_buffer_reset (scm_t_port_buffer *buf) +scm_port_buffer_reset (SCM buf) { - buf->cur = buf->end = SCM_INUM0; + scm_port_buffer_set_cur (buf, SCM_INUM0); + scm_port_buffer_set_end (buf, SCM_INUM0); } static inline void -scm_port_buffer_reset_end (scm_t_port_buffer *buf) +scm_port_buffer_reset_end (SCM buf) { - buf->cur = buf->end = scm_from_size_t (scm_port_buffer_size (buf)); + scm_port_buffer_set_cur (buf, scm_from_size_t (scm_port_buffer_size (buf))); + scm_port_buffer_set_end (buf, scm_from_size_t (scm_port_buffer_size (buf))); } static inline size_t -scm_port_buffer_can_take (scm_t_port_buffer *buf) +scm_port_buffer_can_take (SCM buf) { size_t cur, end; - cur = scm_to_size_t (buf->cur); - end = scm_to_size_t (buf->end); + cur = scm_to_size_t (scm_port_buffer_cur (buf)); + end = scm_to_size_t (scm_port_buffer_end (buf)); if (cur > end || end > scm_port_buffer_size (buf)) - scm_misc_error (NULL, "invalid port buffer cursors ~a, ~a", - scm_list_2 (buf->cur, buf->end)); + scm_misc_error (NULL, "invalid port buffer ~a", scm_list_1 (buf)); return end - cur; } static inline size_t -scm_port_buffer_can_put (scm_t_port_buffer *buf) +scm_port_buffer_can_put (SCM buf) { - size_t end = scm_to_size_t (buf->end); + size_t end = scm_to_size_t (scm_port_buffer_end (buf)); if (end > scm_port_buffer_size (buf)) - scm_misc_error (NULL, "invalid port buffer cursor ~a", - scm_list_1 (buf->end)); + scm_misc_error (NULL, "invalid port buffer ~a", scm_list_1 (buf)); return scm_port_buffer_size (buf) - end; } static inline size_t -scm_port_buffer_can_putback (scm_t_port_buffer *buf) +scm_port_buffer_can_putback (SCM buf) { - size_t cur = scm_to_size_t (buf->cur); + size_t cur = scm_to_size_t (scm_port_buffer_cur (buf)); if (cur > scm_port_buffer_size (buf)) - scm_misc_error (NULL, "invalid port buffer cursor ~a", - scm_list_1 (buf->cur)); + scm_misc_error (NULL, "invalid port buffer ~a", scm_list_1 (buf)); return cur; } static inline void -scm_port_buffer_did_take (scm_t_port_buffer *buf, size_t count) +scm_port_buffer_did_take (SCM buf, size_t count) { - buf->cur = SCM_I_MAKINUM (SCM_I_INUM (buf->cur) + count); + scm_port_buffer_set_cur + (buf, SCM_I_MAKINUM (SCM_I_INUM (scm_port_buffer_cur (buf)) + count)); } static inline void -scm_port_buffer_did_put (scm_t_port_buffer *buf, size_t count) +scm_port_buffer_did_put (SCM buf, size_t count) { - buf->end = SCM_I_MAKINUM (SCM_I_INUM (buf->end) + count); + scm_port_buffer_set_end + (buf, SCM_I_MAKINUM (SCM_I_INUM (scm_port_buffer_end (buf)) + count)); } static inline const scm_t_uint8 * -scm_port_buffer_take_pointer (scm_t_port_buffer *buf) +scm_port_buffer_take_pointer (SCM buf) { - signed char *ret = SCM_BYTEVECTOR_CONTENTS (buf->bytevector); - return ((scm_t_uint8 *) ret) + scm_to_size_t (buf->cur); + signed char *ret = SCM_BYTEVECTOR_CONTENTS (scm_port_buffer_bytevector (buf)); + return ((scm_t_uint8 *) ret) + scm_to_size_t (scm_port_buffer_cur (buf)); } static inline scm_t_uint8 * -scm_port_buffer_put_pointer (scm_t_port_buffer *buf) +scm_port_buffer_put_pointer (SCM buf) { - signed char *ret = SCM_BYTEVECTOR_CONTENTS (buf->bytevector); - return ((scm_t_uint8 *) ret) + scm_to_size_t (buf->end); + signed char *ret = SCM_BYTEVECTOR_CONTENTS (scm_port_buffer_bytevector (buf)); + return ((scm_t_uint8 *) ret) + scm_to_size_t (scm_port_buffer_end (buf)); } static inline size_t -scm_port_buffer_take (scm_t_port_buffer *buf, scm_t_uint8 *dst, size_t count) +scm_port_buffer_take (SCM buf, scm_t_uint8 *dst, size_t count) { count = min (count, scm_port_buffer_can_take (buf)); if (dst) @@ -130,8 +174,7 @@ scm_port_buffer_take (scm_t_port_buffer *buf, scm_t_uint8 *dst, size_t count) } static inline size_t -scm_port_buffer_put (scm_t_port_buffer *buf, const scm_t_uint8 *src, - size_t count) +scm_port_buffer_put (SCM buf, const scm_t_uint8 *src, size_t count) { count = min (count, scm_port_buffer_can_put (buf)); if (src) @@ -141,15 +184,17 @@ scm_port_buffer_put (scm_t_port_buffer *buf, const scm_t_uint8 *src, } static inline void -scm_port_buffer_putback (scm_t_port_buffer *buf, const scm_t_uint8 *src, - size_t count) +scm_port_buffer_putback (SCM buf, const scm_t_uint8 *src, size_t count) { - assert (count <= scm_to_size_t (buf->cur)); + size_t cur = scm_to_size_t (scm_port_buffer_cur (buf)); + + assert (count <= cur); /* Sometimes used to move around data within a buffer, so we must use memmove. */ - buf->cur = scm_from_size_t (scm_to_size_t (buf->cur) - count); - memmove (SCM_BYTEVECTOR_CONTENTS (buf->bytevector) + scm_to_size_t (buf->cur), + cur -= count; + scm_port_buffer_set_cur (buf, scm_from_size_t (cur)); + memmove (SCM_BYTEVECTOR_CONTENTS (scm_port_buffer_bytevector (buf)) + cur, src, count); } diff --git a/libguile/ports.c b/libguile/ports.c index b8b6dbf92..ed387c6c8 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -307,13 +307,13 @@ scm_set_port_get_natural_buffer_sizes static void scm_i_set_pending_eof (SCM port) { - SCM_PTAB_ENTRY (port)->read_buf->has_eof_p = SCM_BOOL_T; + scm_port_buffer_set_has_eof_p (SCM_PTAB_ENTRY (port)->read_buf, SCM_BOOL_T); } static void scm_i_clear_pending_eof (SCM port) { - SCM_PTAB_ENTRY (port)->read_buf->has_eof_p = SCM_BOOL_F; + scm_port_buffer_set_has_eof_p (SCM_PTAB_ENTRY (port)->read_buf, SCM_BOOL_F); } SCM_DEFINE (scm_i_port_property, "%port-property", 2, 0, 0, @@ -512,14 +512,14 @@ scm_i_dynwind_current_load_port (SCM port) /* Port buffers. */ -scm_t_port_buffer * +SCM scm_c_make_port_buffer (size_t size) { - scm_t_port_buffer *ret = scm_gc_typed_calloc (scm_t_port_buffer); + SCM ret = scm_c_make_vector (SCM_PORT_BUFFER_FIELD_COUNT, SCM_INUM0); - ret->bytevector = scm_c_make_bytevector (size); - ret->cur = ret->end = SCM_INUM0; - ret->has_eof_p = SCM_BOOL_F; + SCM_SIMPLE_VECTOR_SET (ret, SCM_PORT_BUFFER_FIELD_BYTEVECTOR, + scm_c_make_bytevector (size)); + scm_port_buffer_set_has_eof_p (ret, SCM_BOOL_F); return ret; } @@ -1410,15 +1410,15 @@ scm_i_read_bytes_unlocked (SCM port, SCM dst, size_t start, size_t count) buffer. If the number of available bytes in the buffer does not increase after a call to scm_i_read_unlocked, that indicates EOF. */ static void -scm_i_read_unlocked (SCM port, scm_t_port_buffer *buf) +scm_i_read_unlocked (SCM port, SCM buf) { size_t count; - count = scm_i_read_bytes_unlocked (port, buf->bytevector, - scm_to_size_t (buf->end), + count = scm_i_read_bytes_unlocked (port, scm_port_buffer_bytevector (buf), + scm_to_size_t (scm_port_buffer_end (buf)), scm_port_buffer_can_put (buf)); scm_port_buffer_did_put (buf, count); - buf->has_eof_p = scm_from_bool (count == 0); + scm_port_buffer_set_has_eof_p (buf, scm_from_bool (count == 0)); } /* Used by an application to read arbitrary number of bytes from an SCM @@ -1432,7 +1432,7 @@ scm_c_read_bytes_unlocked (SCM port, SCM dst, size_t start, size_t count) { size_t to_read = count; scm_t_port *pt; - scm_t_port_buffer *read_buf; + SCM read_buf; scm_t_uint8 *dst_ptr = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (dst) + start; SCM_VALIDATE_OPINPORT (1, port); @@ -1470,7 +1470,7 @@ scm_c_read_bytes_unlocked (SCM port, SCM dst, size_t start, size_t count) if (did_read == 0) { /* Consider that we've read off this EOF. */ - read_buf->has_eof_p = SCM_BOOL_F; + scm_port_buffer_set_has_eof_p (read_buf, SCM_BOOL_F); break; } } @@ -1499,7 +1499,7 @@ scm_c_read_unlocked (SCM port, void *buffer, size_t size) { size_t copied = 0; scm_t_port *pt; - scm_t_port_buffer *read_buf; + SCM read_buf; scm_t_uint8 *dst = buffer; SCM_VALIDATE_OPINPORT (1, port); @@ -1523,7 +1523,7 @@ scm_c_read_unlocked (SCM port, void *buffer, size_t size) if (count == 0) { /* Consider that we've read off this EOF. */ - read_buf->has_eof_p = SCM_BOOL_F; + scm_port_buffer_set_has_eof_p (read_buf, SCM_BOOL_F); break; } } @@ -1978,7 +1978,7 @@ scm_i_unget_bytes_unlocked (const scm_t_uint8 *buf, size_t len, SCM port) #define FUNC_NAME "scm_unget_bytes" { scm_t_port *pt = SCM_PTAB_ENTRY (port); - scm_t_port_buffer *read_buf = pt->read_buf; + SCM read_buf = pt->read_buf; if (pt->rw_random) { @@ -2006,14 +2006,15 @@ scm_i_unget_bytes_unlocked (const scm_t_uint8 *buf, size_t len, SCM port) else { /* Bah, have to expand the read_buf for the putback. */ - scm_t_port_buffer *new_buf; + SCM new_buf; while (size < len + buffered) size *= 2; new_buf = scm_c_make_port_buffer (size); scm_port_buffer_reset_end (new_buf); - new_buf->has_eof_p = read_buf->has_eof_p; + scm_port_buffer_set_has_eof_p (new_buf, + scm_port_buffer_has_eof_p (read_buf)); scm_port_buffer_putback (new_buf, scm_port_buffer_take_pointer (read_buf), buffered); @@ -2286,7 +2287,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, scm_t_ptob_descriptor *ptob; scm_t_bits tag_word; size_t read_buf_size, write_buf_size; - scm_t_port_buffer *saved_read_buf; + SCM saved_read_buf; port = SCM_COERCE_OUTPORT (port); @@ -2348,17 +2349,18 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, port); if (saved_read_buf) - pt->read_buf->has_eof_p = saved_read_buf->has_eof_p; + scm_port_buffer_set_has_eof_p (pt->read_buf, + scm_port_buffer_has_eof_p (saved_read_buf)); return SCM_UNSPECIFIED; } #undef FUNC_NAME -scm_t_port_buffer* +SCM scm_fill_input (SCM port) { scm_i_pthread_mutex_t *lock; - scm_t_port_buffer *ret; + SCM ret; scm_c_lock_port (port, &lock); ret = scm_fill_input_unlocked (port); @@ -2374,7 +2376,7 @@ scm_fill_input (SCM port) size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len) { - scm_t_port_buffer *read_buf = SCM_PTAB_ENTRY (port)->read_buf; + SCM read_buf = SCM_PTAB_ENTRY (port)->read_buf; return scm_port_buffer_take (read_buf, (scm_t_uint8 *) dest, read_len); } @@ -2398,7 +2400,7 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, { SCM result; scm_t_port *pt; - scm_t_port_buffer *read_buf; + SCM read_buf; long count; SCM_VALIDATE_OPINPORT (1, port); @@ -2423,7 +2425,7 @@ void scm_end_input_unlocked (SCM port) { scm_t_port *pt; - scm_t_port_buffer *buf; + SCM buf; size_t discarded; pt = SCM_PTAB_ENTRY (port); @@ -2469,12 +2471,12 @@ SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0, } #undef FUNC_NAME -static void scm_i_write_unlocked (SCM port, scm_t_port_buffer *src); +static void scm_i_write_unlocked (SCM port, SCM buf); void scm_flush_unlocked (SCM port) { - scm_t_port_buffer *buf = SCM_PTAB_ENTRY (port)->write_buf; + SCM buf = SCM_PTAB_ENTRY (port)->write_buf; if (scm_port_buffer_can_take (buf)) scm_i_write_unlocked (port, buf); SCM_PTAB_ENTRY (port)->rw_active = SCM_PORT_NEITHER; @@ -2490,13 +2492,14 @@ scm_flush (SCM port) scm_i_pthread_mutex_unlock (lock); } -scm_t_port_buffer * +SCM scm_fill_input_unlocked (SCM port) { scm_t_port *pt = SCM_PTAB_ENTRY (port); - scm_t_port_buffer *read_buf = pt->read_buf; + SCM read_buf = pt->read_buf; - if (scm_port_buffer_can_take (read_buf) || scm_is_true (read_buf->has_eof_p)) + if (scm_port_buffer_can_take (read_buf) || + scm_is_true (scm_port_buffer_has_eof_p (read_buf))) return read_buf; if (pt->rw_random) @@ -2518,6 +2521,54 @@ scm_fill_input_unlocked (SCM port) return read_buf; } +SCM_DEFINE (scm_port_read_buffer, "port-read-buffer", 1, 0, 0, + (SCM port), + "Return the read buffer for a port. If the port is\n" + "random-access, its write buffer, if any, will be flushed\n" + "if needed.") +#define FUNC_NAME s_scm_port_read_buffer +{ + scm_t_port *pt; + + SCM_VALIDATE_OPINPORT (1, port); + + pt = SCM_PTAB_ENTRY (port); + + if (pt->rw_random) + { + if (pt->rw_active == SCM_PORT_WRITE) + scm_flush (pt->port); + pt->rw_active = SCM_PORT_READ; + } + + return pt->read_buf; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_port_write_buffer, "port-write-buffer", 1, 0, 0, + (SCM port), + "Return the write buffer for a port. If the port is\n" + "random-access, its read buffer, if any, will be discarded\n" + "if needed.") +#define FUNC_NAME s_scm_port_write_buffer +{ + scm_t_port *pt; + + SCM_VALIDATE_OPOUTPORT (1, port); + + pt = SCM_PTAB_ENTRY (port); + + if (pt->rw_random) + { + if (pt->rw_active == SCM_PORT_READ) + scm_end_input (pt->port); + pt->rw_active = SCM_PORT_WRITE; + } + + return pt->write_buf; +} +#undef FUNC_NAME + @@ -2560,23 +2611,21 @@ scm_i_write_bytes_unlocked (SCM port, SCM src, size_t start, size_t count) } static void -scm_i_write_unlocked (SCM port, scm_t_port_buffer *src) +scm_i_write_unlocked (SCM port, SCM buf) { size_t start, count; - assert (scm_to_size_t (src->cur) < scm_to_size_t (src->end)); - assert (scm_to_size_t (src->end) <= scm_port_buffer_size (src)); - /* Update cursors before attempting to write, assuming that I/O errors are sticky. That way if the write throws an error, causing the computation to abort, and possibly causing the port to be collected by GC when it's open, any subsequent close-port / force-output won't signal *another* error. */ - start = scm_to_size_t (src->cur); - count = scm_port_buffer_can_take (src); - scm_port_buffer_reset (src); - scm_i_write_bytes_unlocked (port, src->bytevector, start, count); + start = scm_to_size_t (scm_port_buffer_cur (buf)); + count = scm_port_buffer_can_take (buf); + scm_port_buffer_reset (buf); + scm_i_write_bytes_unlocked (port, scm_port_buffer_bytevector (buf), start, + count); } /* Used by an application to write arbitrary number of bytes to an SCM @@ -2589,7 +2638,7 @@ scm_c_write_bytes_unlocked (SCM port, SCM src, size_t start, size_t count) #define FUNC_NAME "scm_c_write_bytes" { scm_t_port *pt; - scm_t_port_buffer *write_buf; + SCM write_buf; SCM_VALIDATE_OPOUTPORT (1, port); @@ -2605,8 +2654,8 @@ scm_c_write_bytes_unlocked (SCM port, SCM src, size_t start, size_t count) if (count < scm_port_buffer_size (write_buf)) { - /* Make it so that write_buf->end is only nonzero if there are - buffered bytes already. */ + /* Make it so that the write_buf "end" cursor is only nonzero if + there are buffered bytes already. */ if (scm_port_buffer_can_take (write_buf) == 0) scm_port_buffer_reset (write_buf); @@ -2648,7 +2697,7 @@ scm_c_write_unlocked (SCM port, const void *ptr, size_t size) #define FUNC_NAME "scm_c_write" { scm_t_port *pt; - scm_t_port_buffer *write_buf; + SCM write_buf; size_t written = 0; const scm_t_uint8 *src = ptr; @@ -2759,7 +2808,7 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, #define FUNC_NAME s_scm_char_ready_p { scm_t_port *pt; - scm_t_port_buffer *read_buf; + SCM read_buf; if (SCM_UNBNDP (port)) port = scm_current_input_port (); @@ -2770,7 +2819,8 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, pt = SCM_PTAB_ENTRY (port); read_buf = pt->read_buf; - if (scm_port_buffer_can_take (read_buf) || scm_is_true (read_buf->has_eof_p)) + if (scm_port_buffer_can_take (read_buf) || + scm_is_true (scm_port_buffer_has_eof_p (read_buf))) /* FIXME: Verify that a whole character is available? */ return SCM_BOOL_T; else diff --git a/libguile/ports.h b/libguile/ports.h index 997b755d9..92799cb73 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -37,6 +37,7 @@ #include "libguile/struct.h" #include "libguile/threads.h" #include "libguile/strings.h" +#include "libguile/vectors.h" @@ -53,42 +54,35 @@ struct scm_port_internal; /* Port buffers. It's important to avoid calling into the kernel too many times. For - that reason we buffer the input and output, using `scm_t_port_buffer' - objects. The bytes in a read buffer are laid out like this: + that reason we buffer the input and output, using "port buffer" + objects. Port buffers are represented as vectors containing the + buffer, two cursors, and a flag. The bytes in a read buffer are laid + out like this: |already read | not yet | invalid | data | read | data readbuf: #vu8(|r r r r r r r|u u u u u|x x x x x|) - ^buf ^cur ^end ^size + ^buf ^cur ^end ^size(buf) Similarly for a write buffer: |already written | not yet | invalid | data | written | data writebuf: #vu8(|w w w w w w w w |u u u u u|x x x x x|) - ^buf ^cur ^end ^size + ^buf ^cur ^end ^size(buf) - We use a `scm_t_port_buffer' object for both purposes. Port buffers - are implemented as their own object so that they can be atomically - swapped in or out. */ - -typedef struct -{ - /* The port buffer. */ - SCM bytevector; - - /* Offsets into the buffer. Invariant: cur <= end <= size(buf). */ - SCM cur; - SCM end; - - /* For read buffers, flag indicating whether the last read() returned - zero bytes. Note that in the case of pushback, there could still - be bytes in the buffer, but that after any bytes are read off, - peek-u8 should still return EOF. */ - SCM has_eof_p; - -} scm_t_port_buffer; + We use the same port buffer data structure for both purposes. Port + buffers are implemented as their own object so that they can be + atomically swapped in or out of ports, and as Scheme vectors so they + can be manipulated from Scheme. */ +enum scm_port_buffer_field { + SCM_PORT_BUFFER_FIELD_BYTEVECTOR, + SCM_PORT_BUFFER_FIELD_CUR, + SCM_PORT_BUFFER_FIELD_END, + SCM_PORT_BUFFER_FIELD_HAS_EOF_P, + SCM_PORT_BUFFER_FIELD_COUNT +}; /* C representation of a Scheme port. */ @@ -112,8 +106,8 @@ typedef struct int column_number; /* Port buffers. */ - scm_t_port_buffer *read_buf; - scm_t_port_buffer *write_buf; + SCM read_buf; + SCM write_buf; /* All ports have read and write buffers; an unbuffered port simply has a one-byte buffer. However unreading bytes can expand the read @@ -263,7 +257,7 @@ SCM_API void scm_dynwind_current_error_port (SCM port); SCM_INTERNAL void scm_i_dynwind_current_load_port (SCM port); /* Port buffers. */ -SCM_INTERNAL scm_t_port_buffer *scm_c_make_port_buffer (size_t size); +SCM_INTERNAL SCM scm_c_make_port_buffer (size_t size); /* Mode bits. */ SCM_INTERNAL long scm_i_mode_bits (SCM modes); @@ -341,8 +335,8 @@ SCM_API SCM scm_unread_string (SCM str, SCM port); /* Manipulating the buffers. */ SCM_API SCM scm_setvbuf (SCM port, SCM mode, SCM size); -SCM_API scm_t_port_buffer* scm_fill_input (SCM port); -SCM_API scm_t_port_buffer* scm_fill_input_unlocked (SCM port); +SCM_API SCM scm_fill_input (SCM port); +SCM_API SCM scm_fill_input_unlocked (SCM port); SCM_INTERNAL size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len); SCM_API SCM scm_drain_input (SCM port); SCM_API void scm_end_input (SCM port); @@ -350,6 +344,8 @@ SCM_API void scm_end_input_unlocked (SCM port); SCM_API SCM scm_force_output (SCM port); SCM_API void scm_flush (SCM port); SCM_API void scm_flush_unlocked (SCM port); +SCM_INTERNAL SCM scm_port_read_buffer (SCM port); +SCM_INTERNAL SCM scm_port_write_buffer (SCM port); /* Output. */ SCM_API void scm_putc (char c, SCM port); @@ -428,31 +424,42 @@ scm_c_try_lock_port (SCM port, scm_i_pthread_mutex_t **lock) SCM_INLINE_IMPLEMENTATION int scm_get_byte_or_eof_unlocked (SCM port) { - scm_t_port_buffer *buf = SCM_PTAB_ENTRY (port)->read_buf; - size_t cur = SCM_I_INUM (buf->cur); + SCM buf = SCM_PTAB_ENTRY (port)->read_buf; + SCM buf_bv, buf_cur, buf_end; + size_t cur; - if (SCM_LIKELY (SCM_I_INUMP (buf->cur)) - && SCM_LIKELY (SCM_I_INUMP (buf->end)) - && SCM_LIKELY (cur < SCM_I_INUM (buf->end)) - && SCM_LIKELY (cur < SCM_BYTEVECTOR_LENGTH (buf->bytevector))) + buf_bv = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_BYTEVECTOR); + buf_cur = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_CUR); + buf_end = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_END); + cur = SCM_I_INUM (buf_cur); + + if (SCM_LIKELY (SCM_I_INUMP (buf_cur)) + && SCM_LIKELY (SCM_I_INUMP (buf_end)) + && SCM_LIKELY (cur < SCM_I_INUM (buf_end)) + && SCM_LIKELY (cur < SCM_BYTEVECTOR_LENGTH (buf_bv))) { - scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf->bytevector)[cur]; - buf->cur = SCM_I_MAKINUM (cur + 1); + scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf_bv)[cur]; + buf_cur = SCM_I_MAKINUM (cur + 1); + SCM_SIMPLE_VECTOR_SET (buf, SCM_PORT_BUFFER_FIELD_CUR, buf_cur); return ret; } buf = scm_fill_input_unlocked (port); - cur = scm_to_size_t (buf->cur); - if (cur < scm_to_size_t (buf->end)) + buf_bv = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_BYTEVECTOR); + buf_cur = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_CUR); + buf_end = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_END); + cur = scm_to_size_t (buf_cur); + if (cur < scm_to_size_t (buf_end)) { - scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf->bytevector)[cur]; - buf->cur = scm_from_size_t (cur + 1); + scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf_bv)[cur]; + buf_cur = SCM_I_MAKINUM (cur + 1); + SCM_SIMPLE_VECTOR_SET (buf, SCM_PORT_BUFFER_FIELD_CUR, buf_cur); return ret; } /* The next peek or get should cause the read() function to be called to see if we still have EOF. */ - buf->has_eof_p = SCM_BOOL_F; + SCM_SIMPLE_VECTOR_SET (buf, SCM_PORT_BUFFER_FIELD_HAS_EOF_P, SCM_BOOL_F); return EOF; } @@ -460,23 +467,31 @@ scm_get_byte_or_eof_unlocked (SCM port) SCM_INLINE_IMPLEMENTATION int scm_peek_byte_or_eof_unlocked (SCM port) { - scm_t_port_buffer *buf = SCM_PTAB_ENTRY (port)->read_buf; - size_t cur = SCM_I_INUM (buf->cur); + SCM buf = SCM_PTAB_ENTRY (port)->read_buf; + SCM buf_bv, buf_cur, buf_end; + size_t cur; - if (SCM_LIKELY (SCM_I_INUMP (buf->cur)) - && SCM_LIKELY (SCM_I_INUMP (buf->end)) - && SCM_LIKELY (cur < SCM_I_INUM (buf->end)) - && SCM_LIKELY (cur < SCM_BYTEVECTOR_LENGTH (buf->bytevector))) + buf_bv = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_BYTEVECTOR); + buf_cur = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_CUR); + buf_end = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_END); + cur = SCM_I_INUM (buf_cur); + if (SCM_LIKELY (SCM_I_INUMP (buf_cur)) + && SCM_LIKELY (SCM_I_INUMP (buf_end)) + && SCM_LIKELY (cur < SCM_I_INUM (buf_end)) + && SCM_LIKELY (cur < SCM_BYTEVECTOR_LENGTH (buf_bv))) { - scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf->bytevector)[cur]; + scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf_bv)[cur]; return ret; } buf = scm_fill_input_unlocked (port); - cur = scm_to_size_t (buf->cur); - if (cur < scm_to_size_t (buf->end)) + buf_bv = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_BYTEVECTOR); + buf_cur = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_CUR); + buf_end = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_END); + cur = scm_to_size_t (buf_cur); + if (cur < scm_to_size_t (buf_end)) { - scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf->bytevector)[cur]; + scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf_bv)[cur]; return ret; } diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 4c5c87ca5..e96e2205b 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -468,7 +468,7 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0, "position to point just past these bytes.") #define FUNC_NAME s_scm_get_bytevector_some { - scm_t_port_buffer *buf; + SCM buf; size_t size; SCM bv; @@ -478,7 +478,7 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0, size = scm_port_buffer_can_take (buf); if (size == 0) { - buf->has_eof_p = SCM_BOOL_F; + scm_port_buffer_set_has_eof_p (buf, SCM_BOOL_F); return SCM_EOF_VAL; } diff --git a/libguile/read.c b/libguile/read.c index bc5c3c179..d717ea27c 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -2057,7 +2057,7 @@ char * scm_i_scan_for_encoding (SCM port) { scm_t_port *pt; - scm_t_port_buffer *buf; + SCM buf; char header[SCM_ENCODING_SEARCH_SIZE+1]; size_t bytes_read, encoding_length, i; char *encoding = NULL; diff --git a/libguile/rw.c b/libguile/rw.c index d6437e96a..bf4a1f56d 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -232,7 +232,7 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0, { SCM port = (SCM_UNBNDP (port_or_fdes)? scm_current_output_port () : port_or_fdes); - scm_t_port_buffer *write_buf; + SCM write_buf; SCM_VALIDATE_OPFPORT (2, port); SCM_VALIDATE_OUTPUT_PORT (2, port); From 3e951f7dfc6260da597e7677120a5f012c943bff Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 Apr 2016 16:23:42 +0200 Subject: [PATCH 217/865] Refactor thread safety for %port-property * libguile/ports.c (scm_i_port_property, scm_i_set_port_property_x): Knowing that the critical section can't throw, use serial lock discipline. --- libguile/ports.c | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index ed387c6c8..0a424e04f 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -321,14 +321,16 @@ SCM_DEFINE (scm_i_port_property, "%port-property", 2, 0, 0, "Return the property of @var{port} associated with @var{key}.") #define FUNC_NAME s_scm_i_port_property { - scm_i_pthread_mutex_t *lock; SCM result; + scm_t_port *pt; SCM_VALIDATE_OPPORT (1, port); - scm_c_lock_port (port, &lock); - result = scm_assq_ref (SCM_PORT_GET_INTERNAL (port)->alist, key); - if (lock) - scm_i_pthread_mutex_unlock (lock); + + pt = SCM_PTAB_ENTRY (port); + scm_i_pthread_mutex_lock (pt->lock); + result = scm_assq_ref (pt->internal->alist, key); + scm_i_pthread_mutex_unlock (pt->lock); + return result; } #undef FUNC_NAME @@ -338,15 +340,15 @@ SCM_DEFINE (scm_i_set_port_property_x, "%set-port-property!", 3, 0, 0, "Set the property of @var{port} associated with @var{key} to @var{value}.") #define FUNC_NAME s_scm_i_set_port_property_x { - scm_i_pthread_mutex_t *lock; - scm_t_port_internal *pti; + scm_t_port *pt; SCM_VALIDATE_OPPORT (1, port); - scm_c_lock_port (port, &lock); - pti = SCM_PORT_GET_INTERNAL (port); - pti->alist = scm_assq_set_x (pti->alist, key, value); - if (lock) - scm_i_pthread_mutex_unlock (lock); + + pt = SCM_PTAB_ENTRY (port); + scm_i_pthread_mutex_lock (pt->lock); + pt->internal->alist = scm_assq_set_x (pt->internal->alist, key, value); + scm_i_pthread_mutex_unlock (pt->lock); + return SCM_UNSPECIFIED; } #undef FUNC_NAME From fb577b59af2619edd78fea71ce6250a36376abdd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 Apr 2016 17:12:58 +0200 Subject: [PATCH 218/865] Refactor to internal get/peek-byte functions * libguile/ports.h (scm_get_byte_or_eof_unlocked) (scm_peek_byte_or_eof_unlocked): Remove inline functions. The important uses are in ports.c anyway and we will use a static function there. (scm_slow_get_byte_or_eof_unlocked) (scm_slow_peek_byte_or_eof_unlocked): Remove declarations without definitions. * libguile/ports.c (looking_at_bytes): Use scm_peek_byte_or_eof instead of the _unlocked variant. (get_byte_or_eof, peek_byte_or_eof): New static functions. (scm_get_byte_or_eof, scm_peek_byte_or_eof): Don't lock: the port buffer mechanism means that we won't crash. More comments to come. (get_utf8_codepoint, get_latin1_codepoint, get_iconv_codepoint): Use new static functions. * libguile/read.c (read_token, scm_read_semicolon_comment): Use scm_get_byte_or_eof, not scm_get_byte_or_eof_unlocked. --- libguile/ports.c | 115 +++++++++++++++++++++++++++++++++++------------ libguile/ports.h | 81 --------------------------------- libguile/read.c | 6 +-- 3 files changed, 90 insertions(+), 112 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 0a424e04f..b754e1bae 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1001,7 +1001,7 @@ looking_at_bytes (SCM port, const unsigned char *bytes, int len) scm_t_port *pt = SCM_PTAB_ENTRY (port); int i = 0; - while (i < len && scm_peek_byte_or_eof_unlocked (port) == bytes[i]) + while (i < len && scm_peek_byte_or_eof (port) == bytes[i]) { scm_port_buffer_did_take (pt->read_buf, 1); i++; @@ -1364,32 +1364,91 @@ scm_dynwind_lock_port (SCM port) /* Input. */ +static int +get_byte_or_eof (SCM port) +{ + SCM buf = SCM_PTAB_ENTRY (port)->read_buf; + SCM buf_bv, buf_cur, buf_end; + size_t cur; + + buf_bv = scm_port_buffer_bytevector (buf); + buf_cur = scm_port_buffer_cur (buf); + buf_end = scm_port_buffer_end (buf); + cur = SCM_I_INUM (buf_cur); + + if (SCM_LIKELY (SCM_I_INUMP (buf_cur)) + && SCM_LIKELY (SCM_I_INUMP (buf_end)) + && SCM_LIKELY (cur < SCM_I_INUM (buf_end)) + && SCM_LIKELY (cur < SCM_BYTEVECTOR_LENGTH (buf_bv))) + { + scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf_bv)[cur]; + scm_port_buffer_set_cur (buf, SCM_I_MAKINUM (cur + 1)); + return ret; + } + + buf = scm_fill_input (port); + buf_bv = scm_port_buffer_bytevector (buf); + buf_cur = scm_port_buffer_cur (buf); + buf_end = scm_port_buffer_end (buf); + cur = scm_to_size_t (buf_cur); + if (cur < scm_to_size_t (buf_end)) + { + scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf_bv)[cur]; + scm_port_buffer_set_cur (buf, SCM_I_MAKINUM (cur + 1)); + return ret; + } + + /* The next peek or get should cause the read() function to be called + to see if we still have EOF. */ + scm_port_buffer_set_has_eof_p (buf, SCM_BOOL_F); + return EOF; +} + +/* Like `scm_get_byte_or_eof' but does not change PORT's `read_pos'. */ +static int +peek_byte_or_eof (SCM port) +{ + SCM buf = SCM_PTAB_ENTRY (port)->read_buf; + SCM buf_bv, buf_cur, buf_end; + size_t cur; + + buf_bv = scm_port_buffer_bytevector (buf); + buf_cur = scm_port_buffer_cur (buf); + buf_end = scm_port_buffer_end (buf); + cur = scm_to_size_t (buf_cur); + if (SCM_LIKELY (SCM_I_INUMP (buf_cur)) + && SCM_LIKELY (SCM_I_INUMP (buf_end)) + && SCM_LIKELY (cur < SCM_I_INUM (buf_end)) + && SCM_LIKELY (cur < SCM_BYTEVECTOR_LENGTH (buf_bv))) + { + scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf_bv)[cur]; + return ret; + } + + buf = scm_fill_input (port); + buf_bv = scm_port_buffer_bytevector (buf); + buf_cur = scm_port_buffer_cur (buf); + buf_end = scm_port_buffer_end (buf); + cur = scm_to_size_t (buf_cur); + if (cur < scm_to_size_t (buf_end)) + { + scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf_bv)[cur]; + return ret; + } + + return EOF; +} + int scm_get_byte_or_eof (SCM port) { - scm_i_pthread_mutex_t *lock; - int ret; - - scm_c_lock_port (port, &lock); - ret = scm_get_byte_or_eof_unlocked (port); - if (lock) - scm_i_pthread_mutex_unlock (lock); - - return ret; + return get_byte_or_eof (port); } int scm_peek_byte_or_eof (SCM port) { - scm_i_pthread_mutex_t *lock; - int ret; - - scm_c_lock_port (port, &lock); - ret = scm_peek_byte_or_eof_unlocked (port); - if (lock) - scm_i_pthread_mutex_unlock (lock); - - return ret; + return peek_byte_or_eof (port); } static size_t @@ -1648,7 +1707,7 @@ get_utf8_codepoint (SCM port, scm_t_wchar *codepoint, *len = 0; pt = SCM_PTAB_ENTRY (port); - byte = scm_get_byte_or_eof_unlocked (port); + byte = get_byte_or_eof (port); if (byte == EOF) { *codepoint = EOF; @@ -1664,7 +1723,7 @@ get_utf8_codepoint (SCM port, scm_t_wchar *codepoint, else if (buf[0] >= 0xc2 && buf[0] <= 0xdf) { /* 2-byte form. */ - byte = scm_peek_byte_or_eof_unlocked (port); + byte = peek_byte_or_eof (port); ASSERT_NOT_EOF (byte); if (SCM_UNLIKELY ((byte & 0xc0) != 0x80)) @@ -1680,7 +1739,7 @@ get_utf8_codepoint (SCM port, scm_t_wchar *codepoint, else if ((buf[0] & 0xf0) == 0xe0) { /* 3-byte form. */ - byte = scm_peek_byte_or_eof_unlocked (port); + byte = peek_byte_or_eof (port); ASSERT_NOT_EOF (byte); if (SCM_UNLIKELY ((byte & 0xc0) != 0x80 @@ -1692,7 +1751,7 @@ get_utf8_codepoint (SCM port, scm_t_wchar *codepoint, buf[1] = (scm_t_uint8) byte; *len = 2; - byte = scm_peek_byte_or_eof_unlocked (port); + byte = peek_byte_or_eof (port); ASSERT_NOT_EOF (byte); if (SCM_UNLIKELY ((byte & 0xc0) != 0x80)) @@ -1709,7 +1768,7 @@ get_utf8_codepoint (SCM port, scm_t_wchar *codepoint, else if (buf[0] >= 0xf0 && buf[0] <= 0xf4) { /* 4-byte form. */ - byte = scm_peek_byte_or_eof_unlocked (port); + byte = peek_byte_or_eof (port); ASSERT_NOT_EOF (byte); if (SCM_UNLIKELY (((byte & 0xc0) != 0x80) @@ -1721,7 +1780,7 @@ get_utf8_codepoint (SCM port, scm_t_wchar *codepoint, buf[1] = (scm_t_uint8) byte; *len = 2; - byte = scm_peek_byte_or_eof_unlocked (port); + byte = peek_byte_or_eof (port); ASSERT_NOT_EOF (byte); if (SCM_UNLIKELY ((byte & 0xc0) != 0x80)) @@ -1731,7 +1790,7 @@ get_utf8_codepoint (SCM port, scm_t_wchar *codepoint, buf[2] = (scm_t_uint8) byte; *len = 3; - byte = scm_peek_byte_or_eof_unlocked (port); + byte = peek_byte_or_eof (port); ASSERT_NOT_EOF (byte); if (SCM_UNLIKELY ((byte & 0xc0) != 0x80)) @@ -1771,7 +1830,7 @@ static int get_latin1_codepoint (SCM port, scm_t_wchar *codepoint, char buf[SCM_MBCHAR_BUF_SIZE], size_t *len) { - *codepoint = scm_get_byte_or_eof_unlocked (port); + *codepoint = get_byte_or_eof (port); if (*codepoint == EOF) *len = 0; @@ -1801,7 +1860,7 @@ get_iconv_codepoint (SCM port, scm_t_wchar *codepoint, char *input, *output; size_t input_left, output_left, done; - byte_read = scm_get_byte_or_eof_unlocked (port); + byte_read = get_byte_or_eof (port); if (SCM_UNLIKELY (byte_read == EOF)) { if (SCM_LIKELY (input_size == 0)) diff --git a/libguile/ports.h b/libguile/ports.h index 92799cb73..2cd6f8be7 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -308,11 +308,7 @@ SCM_INLINE int scm_c_try_lock_port (SCM port, scm_i_pthread_mutex_t **lock); /* Input. */ SCM_API int scm_get_byte_or_eof (SCM port); -SCM_INLINE int scm_get_byte_or_eof_unlocked (SCM port); -SCM_API int scm_slow_get_byte_or_eof_unlocked (SCM port); SCM_API int scm_peek_byte_or_eof (SCM port); -SCM_INLINE int scm_peek_byte_or_eof_unlocked (SCM port); -SCM_API int scm_slow_peek_byte_or_eof_unlocked (SCM port); SCM_API size_t scm_c_read (SCM port, void *buffer, size_t size); SCM_API size_t scm_c_read_unlocked (SCM port, void *buffer, size_t size); SCM_API size_t scm_c_read_bytes (SCM port, SCM dst, size_t start, size_t count); @@ -421,83 +417,6 @@ scm_c_try_lock_port (SCM port, scm_i_pthread_mutex_t **lock) return 0; } -SCM_INLINE_IMPLEMENTATION int -scm_get_byte_or_eof_unlocked (SCM port) -{ - SCM buf = SCM_PTAB_ENTRY (port)->read_buf; - SCM buf_bv, buf_cur, buf_end; - size_t cur; - - buf_bv = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_BYTEVECTOR); - buf_cur = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_CUR); - buf_end = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_END); - cur = SCM_I_INUM (buf_cur); - - if (SCM_LIKELY (SCM_I_INUMP (buf_cur)) - && SCM_LIKELY (SCM_I_INUMP (buf_end)) - && SCM_LIKELY (cur < SCM_I_INUM (buf_end)) - && SCM_LIKELY (cur < SCM_BYTEVECTOR_LENGTH (buf_bv))) - { - scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf_bv)[cur]; - buf_cur = SCM_I_MAKINUM (cur + 1); - SCM_SIMPLE_VECTOR_SET (buf, SCM_PORT_BUFFER_FIELD_CUR, buf_cur); - return ret; - } - - buf = scm_fill_input_unlocked (port); - buf_bv = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_BYTEVECTOR); - buf_cur = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_CUR); - buf_end = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_END); - cur = scm_to_size_t (buf_cur); - if (cur < scm_to_size_t (buf_end)) - { - scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf_bv)[cur]; - buf_cur = SCM_I_MAKINUM (cur + 1); - SCM_SIMPLE_VECTOR_SET (buf, SCM_PORT_BUFFER_FIELD_CUR, buf_cur); - return ret; - } - - /* The next peek or get should cause the read() function to be called - to see if we still have EOF. */ - SCM_SIMPLE_VECTOR_SET (buf, SCM_PORT_BUFFER_FIELD_HAS_EOF_P, SCM_BOOL_F); - return EOF; -} - -/* Like `scm_get_byte_or_eof' but does not change PORT's `read_pos'. */ -SCM_INLINE_IMPLEMENTATION int -scm_peek_byte_or_eof_unlocked (SCM port) -{ - SCM buf = SCM_PTAB_ENTRY (port)->read_buf; - SCM buf_bv, buf_cur, buf_end; - size_t cur; - - buf_bv = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_BYTEVECTOR); - buf_cur = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_CUR); - buf_end = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_END); - cur = SCM_I_INUM (buf_cur); - if (SCM_LIKELY (SCM_I_INUMP (buf_cur)) - && SCM_LIKELY (SCM_I_INUMP (buf_end)) - && SCM_LIKELY (cur < SCM_I_INUM (buf_end)) - && SCM_LIKELY (cur < SCM_BYTEVECTOR_LENGTH (buf_bv))) - { - scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf_bv)[cur]; - return ret; - } - - buf = scm_fill_input_unlocked (port); - buf_bv = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_BYTEVECTOR); - buf_cur = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_CUR); - buf_end = SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_END); - cur = scm_to_size_t (buf_cur); - if (cur < scm_to_size_t (buf_end)) - { - scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf_bv)[cur]; - return ret; - } - - return EOF; -} - SCM_INLINE_IMPLEMENTATION void scm_putc_unlocked (char c, SCM port) { diff --git a/libguile/read.c b/libguile/read.c index d717ea27c..144e39dc5 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -263,7 +263,7 @@ read_token (SCM port, scm_t_read_opts *opts, { int chr; - chr = scm_get_byte_or_eof_unlocked (port); + chr = scm_get_byte_or_eof (port); if (chr == EOF) return 0; @@ -965,9 +965,9 @@ scm_read_semicolon_comment (int chr, SCM port) /* We use the get_byte here because there is no need to get the locale correct with comment input. This presumes that newline always represents itself no matter what the encoding is. */ - for (c = scm_get_byte_or_eof_unlocked (port); + for (c = scm_get_byte_or_eof (port); (c != EOF) && (c != '\n'); - c = scm_get_byte_or_eof_unlocked (port)); + c = scm_get_byte_or_eof (port)); return SCM_UNSPECIFIED; } From 4934b69ddfb70d59b6ede6538b48da8ddea70a11 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 Apr 2016 20:42:24 +0200 Subject: [PATCH 219/865] scm_c_read instead of scm_c_read_unlock * libguile/ports.h (scm_c_read_unlocked): Remove. * libguile/ports.c (scm_c_read): Rename from scm_c_read_unlocked. Remove old scm_c_read. Lock around access to the rw_active flag, and call scm_flush instead of scm_flush_unlocked, and scm_fill_input instead of scm_fill_input_unlocked. * libguile/read.c (scm_i_scan_for_encoding): Use scm_c_read instead of the _unlocked function. --- libguile/ports.c | 27 +++++++++------------------ libguile/ports.h | 1 - libguile/read.c | 2 +- 3 files changed, 10 insertions(+), 20 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index b754e1bae..a59c8d831 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1555,7 +1555,7 @@ scm_c_read_bytes_unlocked (SCM port, SCM dst, size_t start, size_t count) read buffer. Used by an application when it wants to read into a memory chunk that's not owned by Guile's GC. */ size_t -scm_c_read_unlocked (SCM port, void *buffer, size_t size) +scm_c_read (SCM port, void *buffer, size_t size) #define FUNC_NAME "scm_c_read" { size_t copied = 0; @@ -1570,15 +1570,20 @@ scm_c_read_unlocked (SCM port, void *buffer, size_t size) if (pt->rw_random) { - if (pt->rw_active == SCM_PORT_WRITE) - scm_flush_unlocked (port); + int needs_flush; + scm_i_pthread_mutex_lock (pt->lock); + needs_flush = pt->rw_active == SCM_PORT_WRITE; pt->rw_active = SCM_PORT_READ; + scm_i_pthread_mutex_unlock (pt->lock); + + if (needs_flush) + scm_flush (port); } while (copied < size) { size_t count; - read_buf = scm_fill_input_unlocked (port); + read_buf = scm_fill_input (port); count = scm_port_buffer_take (read_buf, dst + copied, size - copied); copied += count; if (count == 0) @@ -1607,20 +1612,6 @@ scm_c_read_bytes (SCM port, SCM dst, size_t start, size_t count) return ret; } -size_t -scm_c_read (SCM port, void *buffer, size_t size) -{ - scm_i_pthread_mutex_t *lock; - size_t ret; - - scm_c_lock_port (port, &lock); - ret = scm_c_read_unlocked (port, buffer, size); - if (lock) - scm_i_pthread_mutex_unlock (lock); - - return ret; -} - /* Update the line and column number of PORT after consumption of C. */ static inline void update_port_lf (scm_t_wchar c, SCM port) diff --git a/libguile/ports.h b/libguile/ports.h index 2cd6f8be7..2b05a229f 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -310,7 +310,6 @@ SCM_INLINE int scm_c_try_lock_port (SCM port, scm_i_pthread_mutex_t **lock); SCM_API int scm_get_byte_or_eof (SCM port); SCM_API int scm_peek_byte_or_eof (SCM port); SCM_API size_t scm_c_read (SCM port, void *buffer, size_t size); -SCM_API size_t scm_c_read_unlocked (SCM port, void *buffer, size_t size); SCM_API size_t scm_c_read_bytes (SCM port, SCM dst, size_t start, size_t count); SCM_API scm_t_wchar scm_getc (SCM port); SCM_API scm_t_wchar scm_getc_unlocked (SCM port); diff --git a/libguile/read.c b/libguile/read.c index 144e39dc5..75f042377 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -2100,7 +2100,7 @@ scm_i_scan_for_encoding (SCM port) if (SCM_FPORTP (port) && !SCM_FDES_RANDOM_P (SCM_FPORT_FDES (port))) return NULL; - bytes_read = scm_c_read_unlocked (port, header, SCM_ENCODING_SEARCH_SIZE); + bytes_read = scm_c_read (port, header, SCM_ENCODING_SEARCH_SIZE); header[bytes_read] = '\0'; scm_seek (port, scm_from_int (0), scm_from_int (SEEK_SET)); } From 69a1b83f31824cc23c7c4d60144de2225517c76f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 Apr 2016 21:08:30 +0200 Subject: [PATCH 220/865] Remove port rw_active field * libguile/ports.h (scm_t_port_rw_active): Move type definition to ports-internal.h. (scm_t_port): Remove rw_active field. It's sufficient to check the port buffer cursors. * libguile/read.c (scm_i_scan_for_encoding): Just call scm_flush_unlocked; it's idempotent. * libguile/ports.c (scm_c_make_port_with_encoding): Remove rw_active field. (scm_c_read_bytes_unlocked, scm_c_read, scm_i_unget_bytes_unlocked) (scm_end_input_unlocked, scm_flush_unlocked, scm_fill_input_unlocked) (scm_port_write_buffer, scm_port_read_buffer) (scm_c_write_bytes_unlocked, scm_c_write_unlocked, scm_seek): Remove management of rw_active field. --- libguile/ports-internal.h | 6 ++++ libguile/ports.c | 63 +++++++-------------------------------- libguile/ports.h | 12 -------- libguile/read.c | 6 +--- 4 files changed, 17 insertions(+), 70 deletions(-) diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index 19e49a7bd..5eeefb9b7 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -232,6 +232,12 @@ typedef struct scm_port_internal scm_t_port_internal; #define SCM_PORT_GET_INTERNAL(x) (SCM_PTAB_ENTRY(x)->internal) +typedef enum scm_t_port_rw_active { + SCM_PORT_NEITHER = 0, + SCM_PORT_READ = 1, + SCM_PORT_WRITE = 2 +} scm_t_port_rw_active; + SCM_INTERNAL scm_t_iconv_descriptors * scm_i_port_iconv_descriptors (SCM port, scm_t_port_rw_active mode); diff --git a/libguile/ports.c b/libguile/ports.c index a59c8d831..8181056f3 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -698,7 +698,6 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits, /* By default, any port type with a seek function has random-access ports. */ entry->rw_random = ptob->seek != NULL; - entry->rw_active = SCM_PORT_NEITHER; entry->port = ret; entry->stream = stream; @@ -1502,11 +1501,7 @@ scm_c_read_bytes_unlocked (SCM port, SCM dst, size_t start, size_t count) read_buf = pt->read_buf; if (pt->rw_random) - { - if (pt->rw_active == SCM_PORT_WRITE) - scm_flush_unlocked (port); - pt->rw_active = SCM_PORT_READ; - } + scm_flush_unlocked (port); /* Take bytes first from the port's read buffer. */ { @@ -1569,16 +1564,7 @@ scm_c_read (SCM port, void *buffer, size_t size) read_buf = pt->read_buf; if (pt->rw_random) - { - int needs_flush; - scm_i_pthread_mutex_lock (pt->lock); - needs_flush = pt->rw_active == SCM_PORT_WRITE; - pt->rw_active = SCM_PORT_READ; - scm_i_pthread_mutex_unlock (pt->lock); - - if (needs_flush) - scm_flush (port); - } + scm_flush (port); while (copied < size) { @@ -2033,11 +2019,7 @@ scm_i_unget_bytes_unlocked (const scm_t_uint8 *buf, size_t len, SCM port) SCM read_buf = pt->read_buf; if (pt->rw_random) - { - if (pt->rw_active == SCM_PORT_WRITE) - scm_flush_unlocked (port); - pt->rw_active = SCM_PORT_READ; - } + scm_flush_unlocked (port); if (scm_port_buffer_can_putback (read_buf) < len) { @@ -2488,7 +2470,6 @@ scm_end_input_unlocked (SCM port) if (discarded != 0) SCM_PORT_DESCRIPTOR (port)->seek (port, -discarded, SEEK_CUR); - pt->rw_active = SCM_PORT_NEITHER; } void @@ -2531,7 +2512,6 @@ scm_flush_unlocked (SCM port) SCM buf = SCM_PTAB_ENTRY (port)->write_buf; if (scm_port_buffer_can_take (buf)) scm_i_write_unlocked (port, buf); - SCM_PTAB_ENTRY (port)->rw_active = SCM_PORT_NEITHER; } void @@ -2555,11 +2535,7 @@ scm_fill_input_unlocked (SCM port) return read_buf; if (pt->rw_random) - { - if (pt->rw_active == SCM_PORT_WRITE) - scm_flush_unlocked (pt->port); - pt->rw_active = SCM_PORT_READ; - } + scm_flush_unlocked (pt->port); /* It could be that putback caused us to enlarge the buffer; now that we've read all the bytes we need to shrink it again. */ @@ -2587,11 +2563,7 @@ SCM_DEFINE (scm_port_read_buffer, "port-read-buffer", 1, 0, 0, pt = SCM_PTAB_ENTRY (port); if (pt->rw_random) - { - if (pt->rw_active == SCM_PORT_WRITE) - scm_flush (pt->port); - pt->rw_active = SCM_PORT_READ; - } + scm_flush (pt->port); return pt->read_buf; } @@ -2611,11 +2583,7 @@ SCM_DEFINE (scm_port_write_buffer, "port-write-buffer", 1, 0, 0, pt = SCM_PTAB_ENTRY (port); if (pt->rw_random) - { - if (pt->rw_active == SCM_PORT_READ) - scm_end_input (pt->port); - pt->rw_active = SCM_PORT_WRITE; - } + scm_end_input (pt->port); return pt->write_buf; } @@ -2698,11 +2666,7 @@ scm_c_write_bytes_unlocked (SCM port, SCM src, size_t start, size_t count) write_buf = pt->write_buf; if (pt->rw_random) - { - if (pt->rw_active == SCM_PORT_READ) - scm_end_input_unlocked (port); - pt->rw_active = SCM_PORT_WRITE; - } + scm_end_input_unlocked (port); if (count < scm_port_buffer_size (write_buf)) { @@ -2759,11 +2723,7 @@ scm_c_write_unlocked (SCM port, const void *ptr, size_t size) write_buf = pt->write_buf; if (pt->rw_random) - { - if (pt->rw_active == SCM_PORT_READ) - scm_end_input_unlocked (port); - pt->rw_active = SCM_PORT_WRITE; - } + scm_end_input_unlocked (port); while (written < size) { @@ -2937,11 +2897,8 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, /* FIXME: Avoid flushing buffers for SEEK_CUR with an offset of 0. */ - if (pt->rw_active == SCM_PORT_READ) - scm_end_input_unlocked (pt->port); - else if (pt->rw_active == SCM_PORT_WRITE) - scm_flush_unlocked (pt->port); - pt->rw_active = SCM_PORT_NEITHER; + scm_end_input_unlocked (pt->port); + scm_flush_unlocked (pt->port); rv = ptob->seek (fd_port, off, how); diff --git a/libguile/ports.h b/libguile/ports.h index 2b05a229f..816005d9c 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -41,13 +41,6 @@ -/* values for the rw_active flag. */ -typedef enum scm_t_port_rw_active { - SCM_PORT_NEITHER = 0, - SCM_PORT_READ = 1, - SCM_PORT_WRITE = 2 -} scm_t_port_rw_active; - /* An internal-only structure defined in ports-internal.h. */ struct scm_port_internal; @@ -123,11 +116,6 @@ typedef struct and so on. */ int rw_random; - /* For random access ports, indicates which of the buffers is - currently in use. Can be SCM_PORT_WRITE, SCM_PORT_READ, or - SCM_PORT_NEITHER. */ - scm_t_port_rw_active rw_active; - /* Character encoding support. */ char *encoding; scm_t_string_failed_conversion_handler ilseq_handler; diff --git a/libguile/read.c b/libguile/read.c index 75f042377..c7ba4e7e4 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -2068,11 +2068,7 @@ scm_i_scan_for_encoding (SCM port) buf = pt->read_buf; if (pt->rw_random) - { - if (pt->rw_active == SCM_PORT_WRITE) - scm_flush_unlocked (port); - pt->rw_active = SCM_PORT_READ; - } + scm_flush_unlocked (port); if (scm_port_buffer_can_take (buf) == 0) { From 99899b7c9c360cc382ba3fbb05bae5265313b9ac Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 Apr 2016 21:32:05 +0200 Subject: [PATCH 221/865] Remove scm_flush_unlocked / scm_end_input_unlocked * libguile/ports.h (scm_flush_unlocked, scm_end_input_unlocked): Remove. * libguile/ports.c (scm_c_read_bytes_unlocked): (scm_i_unget_bytes_unlocked, scm_setvbuf, scm_force_output) (scm_fill_input_unlocked, scm_c_write_bytes_unlocked) (scm_c_write_unlocked, scm_lfwrite_unlocked, scm_seek) (scm_truncate_file, flush_output_port): Call scm_flush / scm_end_input instead of the _unlocked variants. (scm_end_input): Lock while discarding the input buffer but not while calling out to the seek function. * libguile/filesys.c (scm_fsync): * libguile/ioext.c (scm_redirect_port): * libguile/read.c (scm_i_scan_for_encoding): * libguile/rw.c (scm_write_string_partial): Use scm_flush, not scm_flush_unlocked. --- libguile/filesys.c | 2 +- libguile/ioext.c | 12 +++++----- libguile/ports.c | 57 ++++++++++++++++------------------------------ libguile/ports.h | 2 -- libguile/read.c | 2 +- libguile/rw.c | 2 +- 6 files changed, 28 insertions(+), 49 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index 5e0a2321c..167d4448a 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -980,7 +980,7 @@ SCM_DEFINE (scm_fsync, "fsync", 1, 0, 0, if (SCM_OPFPORTP (object)) { - scm_flush_unlocked (object); + scm_flush (object); fdes = SCM_FPORT_FDES (object); } else diff --git a/libguile/ioext.c b/libguile/ioext.c index 3f0a53f5d..f39771eec 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -89,14 +89,14 @@ SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0, /* Ensure there is nothing in either port's input or output buffers. */ if (SCM_OUTPUT_PORT_P (old)) - scm_flush_unlocked (old); - if (SCM_INPUT_PORT_P (old)) - scm_end_input_unlocked (old); + scm_flush (old); + if (SCM_INPUT_PORT_P (old) && SCM_PTAB_ENTRY (old)->rw_random) + scm_end_input (old); if (SCM_OUTPUT_PORT_P (new)) - scm_flush_unlocked (new); - if (SCM_INPUT_PORT_P (new)) - scm_end_input_unlocked (new); + scm_flush (new); + if (SCM_INPUT_PORT_P (new) && SCM_PTAB_ENTRY (new)->rw_random) + scm_end_input (new); ans = dup2 (oldfd, newfd); if (ans == -1) diff --git a/libguile/ports.c b/libguile/ports.c index 8181056f3..b466ed808 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1501,7 +1501,7 @@ scm_c_read_bytes_unlocked (SCM port, SCM dst, size_t start, size_t count) read_buf = pt->read_buf; if (pt->rw_random) - scm_flush_unlocked (port); + scm_flush (port); /* Take bytes first from the port's read buffer. */ { @@ -2019,7 +2019,7 @@ scm_i_unget_bytes_unlocked (const scm_t_uint8 *buf, size_t len, SCM port) SCM read_buf = pt->read_buf; if (pt->rw_random) - scm_flush_unlocked (port); + scm_flush (port); if (scm_port_buffer_can_putback (read_buf) < len) { @@ -2368,7 +2368,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, write_buf_size = 1; if (SCM_OUTPUT_PORT_P (port)) - scm_flush_unlocked (port); + scm_flush (port); saved_read_buf = pt->read_buf; @@ -2456,32 +2456,23 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, #undef FUNC_NAME void -scm_end_input_unlocked (SCM port) +scm_end_input (SCM port) { scm_t_port *pt; SCM buf; size_t discarded; pt = SCM_PTAB_ENTRY (port); + + scm_i_pthread_mutex_lock (pt->lock); buf = SCM_PTAB_ENTRY (port)->read_buf; discarded = scm_port_buffer_take (buf, NULL, (size_t) -1); - - assert (pt->rw_random); + scm_i_pthread_mutex_unlock (pt->lock); if (discarded != 0) SCM_PORT_DESCRIPTOR (port)->seek (port, -discarded, SEEK_CUR); } -void -scm_end_input (SCM port) -{ - scm_i_pthread_mutex_t *lock; - scm_c_lock_port (port, &lock); - scm_end_input_unlocked (port); - if (lock) - scm_i_pthread_mutex_unlock (lock); -} - SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0, (SCM port), "Flush the specified output port, or the current output port if @var{port}\n" @@ -2499,7 +2490,7 @@ SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0, port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPOUTPORT (1, port); } - scm_flush_unlocked (port); + scm_flush (port); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -2507,23 +2498,13 @@ SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0, static void scm_i_write_unlocked (SCM port, SCM buf); void -scm_flush_unlocked (SCM port) +scm_flush (SCM port) { SCM buf = SCM_PTAB_ENTRY (port)->write_buf; if (scm_port_buffer_can_take (buf)) scm_i_write_unlocked (port, buf); } -void -scm_flush (SCM port) -{ - scm_i_pthread_mutex_t *lock; - scm_c_lock_port (port, &lock); - scm_flush_unlocked (port); - if (lock) - scm_i_pthread_mutex_unlock (lock); -} - SCM scm_fill_input_unlocked (SCM port) { @@ -2535,7 +2516,7 @@ scm_fill_input_unlocked (SCM port) return read_buf; if (pt->rw_random) - scm_flush_unlocked (pt->port); + scm_flush (pt->port); /* It could be that putback caused us to enlarge the buffer; now that we've read all the bytes we need to shrink it again. */ @@ -2666,7 +2647,7 @@ scm_c_write_bytes_unlocked (SCM port, SCM src, size_t start, size_t count) write_buf = pt->write_buf; if (pt->rw_random) - scm_end_input_unlocked (port); + scm_end_input (port); if (count < scm_port_buffer_size (write_buf)) { @@ -2723,7 +2704,7 @@ scm_c_write_unlocked (SCM port, const void *ptr, size_t size) write_buf = pt->write_buf; if (pt->rw_random) - scm_end_input_unlocked (port); + scm_end_input (port); while (written < size) { @@ -2773,7 +2754,7 @@ scm_lfwrite_unlocked (const char *ptr, size_t size, SCM port) /* Handle line buffering. */ if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && saved_line != SCM_LINUM (port)) - scm_flush_unlocked (port); + scm_flush (port); } void @@ -2897,8 +2878,8 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, /* FIXME: Avoid flushing buffers for SEEK_CUR with an offset of 0. */ - scm_end_input_unlocked (pt->port); - scm_flush_unlocked (pt->port); + scm_end_input (pt->port); + scm_flush (pt->port); rv = ptob->seek (fd_port, off, how); @@ -3001,9 +2982,9 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, scm_i_clear_pending_eof (object); - if (SCM_INPUT_PORT_P (object)) - scm_end_input_unlocked (object); - scm_flush_unlocked (object); + if (SCM_INPUT_PORT_P (object) && SCM_PTAB_ENTRY (object)->rw_random) + scm_end_input (object); + scm_flush (object); ptob->truncate (object, c_length); rv = 0; @@ -3208,7 +3189,7 @@ static void flush_output_port (void *closure, SCM port) { if (SCM_OPOUTPORTP (port)) - scm_flush_unlocked (port); + scm_flush (port); } SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0, diff --git a/libguile/ports.h b/libguile/ports.h index 816005d9c..4b5242ecd 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -323,10 +323,8 @@ SCM_API SCM scm_fill_input_unlocked (SCM port); SCM_INTERNAL size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len); SCM_API SCM scm_drain_input (SCM port); SCM_API void scm_end_input (SCM port); -SCM_API void scm_end_input_unlocked (SCM port); SCM_API SCM scm_force_output (SCM port); SCM_API void scm_flush (SCM port); -SCM_API void scm_flush_unlocked (SCM port); SCM_INTERNAL SCM scm_port_read_buffer (SCM port); SCM_INTERNAL SCM scm_port_write_buffer (SCM port); diff --git a/libguile/read.c b/libguile/read.c index c7ba4e7e4..9e072ad67 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -2068,7 +2068,7 @@ scm_i_scan_for_encoding (SCM port) buf = pt->read_buf; if (pt->rw_random) - scm_flush_unlocked (port); + scm_flush (port); if (scm_port_buffer_can_take (buf) == 0) { diff --git a/libguile/rw.c b/libguile/rw.c index bf4a1f56d..b2f8f3a1d 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -246,7 +246,7 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0, return scm_from_long (write_len); } - scm_flush_unlocked (port); + scm_flush (port); fdes = SCM_FPORT_FDES (port); } { From 9632b24c4d6ee24a4672cdf0907364d26adb4bd9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 Apr 2016 21:39:18 +0200 Subject: [PATCH 222/865] Remove scm_c_read_bytes_unlocked * libguile/ports.c (scm_c_read_bytes_unlocked): Remove internal function. --- libguile/ports.c | 18 ++---------------- 1 file changed, 2 insertions(+), 16 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index b466ed808..61f00ef7f 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1486,8 +1486,8 @@ scm_i_read_unlocked (SCM port, SCM buf) returns less than SIZE bytes if at end-of-file. Warning: Doesn't update port line and column counts! */ -static size_t -scm_c_read_bytes_unlocked (SCM port, SCM dst, size_t start, size_t count) +size_t +scm_c_read_bytes (SCM port, SCM dst, size_t start, size_t count) #define FUNC_NAME "scm_c_read_bytes" { size_t to_read = count; @@ -1584,20 +1584,6 @@ scm_c_read (SCM port, void *buffer, size_t size) } #undef FUNC_NAME -size_t -scm_c_read_bytes (SCM port, SCM dst, size_t start, size_t count) -{ - scm_i_pthread_mutex_t *lock; - size_t ret; - - scm_c_lock_port (port, &lock); - ret = scm_c_read_bytes_unlocked (port, dst, start, count); - if (lock) - scm_i_pthread_mutex_unlock (lock); - - return ret; -} - /* Update the line and column number of PORT after consumption of C. */ static inline void update_port_lf (scm_t_wchar c, SCM port) From cd83872df8c495f1f5a4aa304dfb9b2d99ce5b22 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 Apr 2016 21:45:55 +0200 Subject: [PATCH 223/865] Replace scm_getc with scm_getc_unlocked * libguile/ports.h (scm_getc_unlocked): Remove, or rather rename to scm_getc. This probably introduces some thread-related bugs but we'll fix them in a different way. * libguile/ports.c (scm_getc): Rename from scm_getc_unlocked, replacing the locky implementation. (scm_read_char): Use scm_getc. * libguile/r6rs-ports.c (scm_get_string_n_x): Use scm_getc. * libguile/rdelim.c (scm_read_delimited_x, scm_read_line): Use scm_getc. * libguile/read.c: Use scm_getc. --- libguile/ports.c | 18 ++----------- libguile/ports.h | 1 - libguile/r6rs-ports.c | 2 +- libguile/rdelim.c | 4 +-- libguile/read.c | 62 +++++++++++++++++++++---------------------- 5 files changed, 36 insertions(+), 51 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 61f00ef7f..fb28f6b25 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1936,7 +1936,7 @@ get_codepoint (SCM port, scm_t_wchar *codepoint, /* Read a codepoint from PORT and return it. */ scm_t_wchar -scm_getc_unlocked (SCM port) +scm_getc (SCM port) #define FUNC_NAME "scm_getc" { int err; @@ -1954,20 +1954,6 @@ scm_getc_unlocked (SCM port) } #undef FUNC_NAME -scm_t_wchar -scm_getc (SCM port) -{ - scm_i_pthread_mutex_t *lock; - scm_t_wchar ret; - - scm_c_lock_port (port, &lock); - ret = scm_getc_unlocked (port); - if (lock) - scm_i_pthread_mutex_unlock (lock); - - return ret; -} - SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0, (SCM port), "Return the next character available from @var{port}, updating\n" @@ -1983,7 +1969,7 @@ SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0, if (SCM_UNBNDP (port)) port = scm_current_input_port (); SCM_VALIDATE_OPINPORT (1, port); - c = scm_getc_unlocked (port); + c = scm_getc (port); if (EOF == c) return SCM_EOF_VAL; return SCM_MAKE_CHAR (c); diff --git a/libguile/ports.h b/libguile/ports.h index 4b5242ecd..23ceb2be4 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -300,7 +300,6 @@ SCM_API int scm_peek_byte_or_eof (SCM port); SCM_API size_t scm_c_read (SCM port, void *buffer, size_t size); SCM_API size_t scm_c_read_bytes (SCM port, SCM dst, size_t start, size_t count); SCM_API scm_t_wchar scm_getc (SCM port); -SCM_API scm_t_wchar scm_getc_unlocked (SCM port); SCM_API SCM scm_read_char (SCM port); /* Pushback. */ diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index e96e2205b..db95e0805 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -1053,7 +1053,7 @@ SCM_DEFINE (scm_get_string_n_x, for (j = c_start; j < c_end; j++) { - c = scm_getc_unlocked (port); + c = scm_getc (port); if (c == EOF) { size_t chars_read = j - c_start; diff --git a/libguile/rdelim.c b/libguile/rdelim.c index c8c7d8b43..14955a972 100644 --- a/libguile/rdelim.c +++ b/libguile/rdelim.c @@ -79,7 +79,7 @@ SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0, { size_t k; - c = scm_getc_unlocked (port); + c = scm_getc (port); for (k = 0; k < num_delims; k++) { if (scm_i_string_ref (delims, k) == c) @@ -149,7 +149,7 @@ SCM_DEFINE (scm_read_line, "%read-line", 0, 1, 0, } else { - buf[index] = scm_getc_unlocked (port); + buf[index] = scm_getc (port); switch (buf[index]) { case EOF: diff --git a/libguile/read.c b/libguile/read.c index 9e072ad67..7eafe423a 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -335,7 +335,7 @@ flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr) { scm_t_wchar c; while (1) - switch (c = scm_getc_unlocked (port)) + switch (c = scm_getc (port)) { case EOF: goteof: @@ -350,7 +350,7 @@ flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr) case ';': lp: - switch (c = scm_getc_unlocked (port)) + switch (c = scm_getc (port)) { case EOF: goto goteof; @@ -362,7 +362,7 @@ flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr) break; case '#': - switch (c = scm_getc_unlocked (port)) + switch (c = scm_getc (port)) { case EOF: eoferr = "read_sharp"; @@ -557,7 +557,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) c = 0; \ while (i < ndigits) \ { \ - a = scm_getc_unlocked (port); \ + a = scm_getc (port); \ if (a == EOF) \ goto str_eof; \ if (terminator \ @@ -587,7 +587,7 @@ skip_intraline_whitespace (SCM port) do { - c = scm_getc_unlocked (port); + c = scm_getc (port); if (c == EOF) return; } @@ -614,7 +614,7 @@ scm_read_string_like_syntax (int chr, SCM port, scm_t_read_opts *opts) long line = SCM_LINUM (port); int column = SCM_COL (port) - 1; - while (chr != (c = scm_getc_unlocked (port))) + while (chr != (c = scm_getc (port))) { if (c == EOF) { @@ -634,7 +634,7 @@ scm_read_string_like_syntax (int chr, SCM port, scm_t_read_opts *opts) if (c == '\\') { - switch (c = scm_getc_unlocked (port)) + switch (c = scm_getc (port)) { case EOF: goto str_eof; @@ -876,7 +876,7 @@ scm_read_quote (int chr, SCM port, scm_t_read_opts *opts) { scm_t_wchar c; - c = scm_getc_unlocked (port); + c = scm_getc (port); if ('@' == c) p = scm_sym_uq_splicing; else @@ -923,7 +923,7 @@ scm_read_syntax (int chr, SCM port, scm_t_read_opts *opts) { int c; - c = scm_getc_unlocked (port); + c = scm_getc (port); if ('@' == c) p = sym_unsyntax_splicing; else @@ -987,7 +987,7 @@ try_read_ci_chars (SCM port, const char *expected_chars) while (num_chars_read < num_chars_wanted) { - c = scm_getc_unlocked (port); + c = scm_getc (port); if (c == EOF) break; else if (c_tolower (c) != expected_chars[num_chars_read]) @@ -1049,7 +1049,7 @@ scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) if (bytes_read == 0) { - chr = scm_getc_unlocked (port); + chr = scm_getc (port); if (chr == EOF) scm_i_input_error (FUNC_NAME, port, "unexpected end of file " "while reading character", SCM_EOL); @@ -1181,7 +1181,7 @@ read_decimal_integer (SCM port, int c, ssize_t *resp) if (c == '-') { sign = -1; - c = scm_getc_unlocked (port); + c = scm_getc (port); } while ('0' <= c && c <= '9') @@ -1191,7 +1191,7 @@ read_decimal_integer (SCM port, int c, ssize_t *resp) "number too large", SCM_EOL); res = 10*res + c-'0'; got_it = 1; - c = scm_getc_unlocked (port); + c = scm_getc (port); } if (got_it) @@ -1222,7 +1222,7 @@ scm_read_array (int c, SCM port, scm_t_read_opts *opts, long line, int column) /* Disambiguate between '#f' and uniform floating point vectors. */ if (c == 'f') { - c = scm_getc_unlocked (port); + c = scm_getc (port); if (c != '3' && c != '6') { if (c == 'a' && try_read_ci_chars (port, "lse")) @@ -1251,7 +1251,7 @@ scm_read_array (int c, SCM port, scm_t_read_opts *opts, long line, int column) && tag_len < sizeof tag_buf / sizeof tag_buf[0]) { tag_buf[tag_len++] = c; - c = scm_getc_unlocked (port); + c = scm_getc (port); } if (tag_len == 0) tag = SCM_BOOL_T; @@ -1275,7 +1275,7 @@ scm_read_array (int c, SCM port, scm_t_read_opts *opts, long line, int column) if (c == '@') { - c = scm_getc_unlocked (port); + c = scm_getc (port); c = read_decimal_integer (port, c, &lbnd); } @@ -1283,7 +1283,7 @@ scm_read_array (int c, SCM port, scm_t_read_opts *opts, long line, int column) if (c == ':') { - c = scm_getc_unlocked (port); + c = scm_getc (port); c = read_decimal_integer (port, c, &len); if (len < 0) scm_i_input_error (NULL, port, @@ -1345,15 +1345,15 @@ static SCM scm_read_bytevector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, long line, int column) { - chr = scm_getc_unlocked (port); + chr = scm_getc (port); if (chr != 'u') goto syntax; - chr = scm_getc_unlocked (port); + chr = scm_getc (port); if (chr != '8') goto syntax; - chr = scm_getc_unlocked (port); + chr = scm_getc (port); if (chr != '(') goto syntax; @@ -1376,9 +1376,9 @@ scm_read_guile_bit_vector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, terribly inefficient but who cares? */ SCM s_bits = SCM_EOL; - for (chr = scm_getc_unlocked (port); + for (chr = scm_getc (port); (chr != EOF) && ((chr == '0') || (chr == '1')); - chr = scm_getc_unlocked (port)) + chr = scm_getc (port)) { s_bits = scm_cons ((chr == '0') ? SCM_BOOL_F : SCM_BOOL_T, s_bits); } @@ -1398,7 +1398,7 @@ scm_read_scsh_block_comment (scm_t_wchar chr, SCM port) for (;;) { - int c = scm_getc_unlocked (port); + int c = scm_getc (port); if (c == EOF) scm_i_input_error ("skip_block_comment", port, @@ -1431,7 +1431,7 @@ scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) while (i <= READER_DIRECTIVE_NAME_MAX_SIZE) { - c = scm_getc_unlocked (port); + c = scm_getc (port); if (c == EOF) scm_i_input_error ("skip_block_comment", port, "unterminated `#! ... !#' comment", SCM_EOL); @@ -1477,7 +1477,7 @@ scm_read_r6rs_block_comment (scm_t_wchar chr, SCM port) nested. So care must be taken. */ int nesting_level = 1; - int a = scm_getc_unlocked (port); + int a = scm_getc (port); if (a == EOF) scm_i_input_error ("scm_read_r6rs_block_comment", port, @@ -1485,7 +1485,7 @@ scm_read_r6rs_block_comment (scm_t_wchar chr, SCM port) while (nesting_level > 0) { - int b = scm_getc_unlocked (port); + int b = scm_getc (port); if (b == EOF) scm_i_input_error ("scm_read_r6rs_block_comment", port, @@ -1537,7 +1537,7 @@ scm_read_extended_symbol (scm_t_wchar chr, SCM port) buf = scm_i_string_start_writing (buf); - while ((chr = scm_getc_unlocked (port)) != EOF) + while ((chr = scm_getc (port)) != EOF) { if (saw_brace) { @@ -1564,7 +1564,7 @@ scm_read_extended_symbol (scm_t_wchar chr, SCM port) that the extended read syntax would never put a `\' before an `x'. For now, we just ignore other instances of backslash in the string. */ - switch ((chr = scm_getc_unlocked (port))) + switch ((chr = scm_getc (port))) { case EOF: goto done; @@ -1653,7 +1653,7 @@ scm_read_sharp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, { SCM result; - chr = scm_getc_unlocked (port); + chr = scm_getc (port); result = scm_read_sharp_extension (chr, port, opts); if (!scm_is_eq (result, SCM_UNSPECIFIED)) @@ -1743,7 +1743,7 @@ read_inner_expression (SCM port, scm_t_read_opts *opts) { scm_t_wchar chr; - chr = scm_getc_unlocked (port); + chr = scm_getc (port); switch (chr) { @@ -1881,7 +1881,7 @@ scm_read_expression (SCM port, scm_t_read_opts *opts) new expression. For example, f{n - 1}(x) => ((f (- n 1)) x). */ for (;;) { - int chr = scm_getc_unlocked (port); + int chr = scm_getc (port); if (chr == '(') /* e(...) => (e ...) */ From 21650f8d52e8a42bb44c92e85b6e96da1fcf5805 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 23 Apr 2016 12:33:48 +0200 Subject: [PATCH 224/865] Remove scm_unget_{byte,bytes}_unlocked * libguile/ports.h (scm_unget_bytes_unlocked, scm_unget_byte_unlocked): Remove. * libguile/ports.c (looking_at_bytes): Use scm_unget_bytes instead of scm_i_unget_bytes_unlocked (scm_unget_bytes): Rename from scm_i_unget_bytes_unlocked. Remove other implementations of this function. (scm_unget_byte): Likewise. (scm_ungetc_unlocked, scm_peek_char): Use scm_unget_byte. * libguile/read.c (read_token): Use scm_unget_byte. --- libguile/ports.c | 44 ++++++-------------------------------------- libguile/ports.h | 2 -- libguile/read.c | 2 +- 3 files changed, 7 insertions(+), 41 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index fb28f6b25..754cb4f1d 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -989,9 +989,6 @@ scm_i_set_default_port_conversion_handler (scm_t_string_failed_conversion_handle strategy); } -static void -scm_i_unget_bytes_unlocked (const unsigned char *buf, size_t len, SCM port); - /* If the next LEN bytes from PORT are equal to those in BYTES, then return 1, else return 0. Leave the port position unchanged. */ static int @@ -1005,7 +1002,7 @@ looking_at_bytes (SCM port, const unsigned char *bytes, int len) scm_port_buffer_did_take (pt->read_buf, 1); i++; } - scm_i_unget_bytes_unlocked (bytes, i, port); + scm_unget_bytes (bytes, i, port); return (i == len); } @@ -1983,8 +1980,8 @@ SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0, -static void -scm_i_unget_bytes_unlocked (const scm_t_uint8 *buf, size_t len, SCM port) +void +scm_unget_bytes (const scm_t_uint8 *buf, size_t len, SCM port) #define FUNC_NAME "scm_unget_bytes" { scm_t_port *pt = SCM_PTAB_ENTRY (port); @@ -2033,39 +2030,10 @@ scm_i_unget_bytes_unlocked (const scm_t_uint8 *buf, size_t len, SCM port) #undef FUNC_NAME void -scm_unget_bytes_unlocked (const unsigned char *buf, size_t len, SCM port) -{ - scm_i_unget_bytes_unlocked (buf, len, port); -} - -void -scm_unget_byte_unlocked (int c, SCM port) -{ - unsigned char byte = c; - scm_i_unget_bytes_unlocked (&byte, 1, port); -} - -void -scm_unget_bytes (const unsigned char *buf, size_t len, SCM port) -{ - scm_i_pthread_mutex_t *lock; - if (len == 0) - return; - scm_c_lock_port (port, &lock); - scm_i_unget_bytes_unlocked (buf, len, port); - if (lock) - scm_i_pthread_mutex_unlock (lock); -} - -void scm_unget_byte (int c, SCM port) { unsigned char byte = c; - scm_i_pthread_mutex_t *lock; - scm_c_lock_port (port, &lock); - scm_i_unget_bytes_unlocked (&byte, 1, port); - if (lock) - scm_i_pthread_mutex_unlock (lock); + scm_unget_bytes (&byte, 1, port); } void @@ -2109,7 +2077,7 @@ scm_ungetc_unlocked (scm_t_wchar c, SCM port) "conversion to port encoding failed", SCM_BOOL_F, SCM_MAKE_CHAR (c)); - scm_i_unget_bytes_unlocked ((unsigned char *) result, len, port); + scm_unget_bytes ((unsigned char *) result, len, port); if (SCM_UNLIKELY (result != result_buf)) free (result); @@ -2192,7 +2160,7 @@ SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0, err = get_codepoint (port, &c, bytes, &len); - scm_i_unget_bytes_unlocked ((unsigned char *) bytes, len, port); + scm_unget_bytes ((unsigned char *) bytes, len, port); SCM_COL (port) = column; SCM_LINUM (port) = line; diff --git a/libguile/ports.h b/libguile/ports.h index 23ceb2be4..4d9c72b80 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -304,9 +304,7 @@ SCM_API SCM scm_read_char (SCM port); /* Pushback. */ SCM_API void scm_unget_bytes (const unsigned char *buf, size_t len, SCM port); -SCM_API void scm_unget_bytes_unlocked (const unsigned char *buf, size_t len, SCM port); SCM_API void scm_unget_byte (int c, SCM port); -SCM_API void scm_unget_byte_unlocked (int c, SCM port); SCM_API void scm_ungetc (scm_t_wchar c, SCM port); SCM_API void scm_ungetc_unlocked (scm_t_wchar c, SCM port); SCM_API void scm_ungets (const char *s, int n, SCM port); diff --git a/libguile/read.c b/libguile/read.c index 7eafe423a..dece2b582 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -269,7 +269,7 @@ read_token (SCM port, scm_t_read_opts *opts, return 0; else if (CHAR_IS_DELIMITER (chr)) { - scm_unget_byte_unlocked (chr, port); + scm_unget_byte (chr, port); return 0; } else From 122c8e6b37ad9dd44226d66e3357802f40d75f5f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 23 Apr 2016 22:20:18 +0200 Subject: [PATCH 225/865] scm_ungetc, scm_ungets instead of _unlocked variants * libguile/ports.h (scm_ungetc_unlocked, scm_ungets_unlocked): Remove; replace with scm_ungetc, scm_ungets. * libguile/ports.c (scm_ungetc, scm_ungets, scm_unread_char) (scm_unread_string): Adapt. * libguile/rdelim.c (scm_read_delimited_x): Use scm_ungetc. * libguile/read.c: Unread characers with scm_ungetc, not scm_ungetc_unlocked. --- libguile/ports.c | 30 +++++------------------------- libguile/ports.h | 2 -- libguile/rdelim.c | 2 +- libguile/read.c | 42 +++++++++++++++++++++--------------------- 4 files changed, 27 insertions(+), 49 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 754cb4f1d..8405a0a2a 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -2037,7 +2037,7 @@ scm_unget_byte (int c, SCM port) } void -scm_ungetc_unlocked (scm_t_wchar c, SCM port) +scm_ungetc (scm_t_wchar c, SCM port) #define FUNC_NAME "scm_ungetc" { scm_t_port *pt = SCM_PTAB_ENTRY (port); @@ -2089,17 +2089,7 @@ scm_ungetc_unlocked (scm_t_wchar c, SCM port) #undef FUNC_NAME void -scm_ungetc (scm_t_wchar c, SCM port) -{ - scm_i_pthread_mutex_t *lock; - scm_c_lock_port (port, &lock); - scm_ungetc_unlocked (c, port); - if (lock) - scm_i_pthread_mutex_unlock (lock); -} - -void -scm_ungets_unlocked (const char *s, int n, SCM port) +scm_ungets (const char *s, int n, SCM port) { /* This is simple minded and inefficient, but unreading strings is * probably not a common operation, and remember that line and @@ -2108,17 +2098,7 @@ scm_ungets_unlocked (const char *s, int n, SCM port) * Please feel free to write an optimized version! */ while (n--) - scm_ungetc_unlocked (s[n], port); -} - -void -scm_ungets (const char *s, int n, SCM port) -{ - scm_i_pthread_mutex_t *lock; - scm_c_lock_port (port, &lock); - scm_ungets_unlocked (s, n, port); - if (lock) - scm_i_pthread_mutex_unlock (lock); + scm_ungetc (s[n], port); } SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0, @@ -2202,7 +2182,7 @@ SCM_DEFINE (scm_unread_char, "unread-char", 1, 1, 0, c = SCM_CHAR (cobj); - scm_ungetc_unlocked (c, port); + scm_ungetc (c, port); return cobj; } #undef FUNC_NAME @@ -2224,7 +2204,7 @@ SCM_DEFINE (scm_unread_string, "unread-string", 2, 0, 0, n = scm_i_string_length (str); while (n--) - scm_ungetc_unlocked (scm_i_string_ref (str, n), port); + scm_ungetc (scm_i_string_ref (str, n), port); return str; } diff --git a/libguile/ports.h b/libguile/ports.h index 4d9c72b80..82b2553fe 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -306,9 +306,7 @@ SCM_API SCM scm_read_char (SCM port); SCM_API void scm_unget_bytes (const unsigned char *buf, size_t len, SCM port); SCM_API void scm_unget_byte (int c, SCM port); SCM_API void scm_ungetc (scm_t_wchar c, SCM port); -SCM_API void scm_ungetc_unlocked (scm_t_wchar c, SCM port); SCM_API void scm_ungets (const char *s, int n, SCM port); -SCM_API void scm_ungets_unlocked (const char *s, int n, SCM port); SCM_API SCM scm_peek_char (SCM port); SCM_API SCM scm_unread_char (SCM cobj, SCM port); SCM_API SCM scm_unread_string (SCM str, SCM port); diff --git a/libguile/rdelim.c b/libguile/rdelim.c index 14955a972..9d1496795 100644 --- a/libguile/rdelim.c +++ b/libguile/rdelim.c @@ -85,7 +85,7 @@ SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0, if (scm_i_string_ref (delims, k) == c) { if (scm_is_false (gobble)) - scm_ungetc_unlocked (c, port); + scm_ungetc (c, port); return scm_cons (SCM_MAKE_CHAR (c), scm_from_size_t (j - cstart)); diff --git a/libguile/read.c b/libguile/read.c index dece2b582..bcbf37ee4 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -381,7 +381,7 @@ flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr) } /* fall through */ default: - scm_ungetc_unlocked (c, port); + scm_ungetc (c, port); return '#'; } break; @@ -440,7 +440,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) if (terminating_char == c) return SCM_EOL; - scm_ungetc_unlocked (c, port); + scm_ungetc (c, port); tmp = scm_read_expression (port, opts); /* Note that it is possible for scm_read_expression to return @@ -468,7 +468,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) "in pair: mismatched close paren: ~A", scm_list_1 (SCM_MAKE_CHAR (c))); - scm_ungetc_unlocked (c, port); + scm_ungetc (c, port); tmp = scm_read_expression (port, opts); /* See above note about scm_sym_dot. */ @@ -593,7 +593,7 @@ skip_intraline_whitespace (SCM port) } while (c == '\t' || uc_is_general_category (c, UC_SPACE_SEPARATOR)); - scm_ungetc_unlocked (c, port); + scm_ungetc (c, port); } /* Read either a double-quoted string or an R7RS-style symbol delimited @@ -741,7 +741,7 @@ scm_read_number (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) long line = SCM_LINUM (port); int column = SCM_COL (port) - 1; - scm_ungetc_unlocked (chr, port); + scm_ungetc (chr, port); buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer, &bytes_read); @@ -772,7 +772,7 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) char local_buffer[READER_BUFFER_SIZE], *buffer; SCM str; - scm_ungetc_unlocked (chr, port); + scm_ungetc (chr, port); buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer, &bytes_read); if (bytes_read > 0) @@ -832,8 +832,8 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) break; default: - scm_ungetc_unlocked (chr, port); - scm_ungetc_unlocked ('#', port); + scm_ungetc (chr, port); + scm_ungetc ('#', port); radix = 10; } @@ -881,7 +881,7 @@ scm_read_quote (int chr, SCM port, scm_t_read_opts *opts) p = scm_sym_uq_splicing; else { - scm_ungetc_unlocked (c, port); + scm_ungetc (c, port); p = scm_sym_unquote; } break; @@ -928,7 +928,7 @@ scm_read_syntax (int chr, SCM port, scm_t_read_opts *opts) p = sym_unsyntax_splicing; else { - scm_ungetc_unlocked (c, port); + scm_ungetc (c, port); p = sym_unsyntax; } break; @@ -992,7 +992,7 @@ try_read_ci_chars (SCM port, const char *expected_chars) break; else if (c_tolower (c) != expected_chars[num_chars_read]) { - scm_ungetc_unlocked (c, port); + scm_ungetc (c, port); break; } else @@ -1004,7 +1004,7 @@ try_read_ci_chars (SCM port, const char *expected_chars) else { while (num_chars_read > 0) - scm_ungetc_unlocked (chars_read[--num_chars_read], port); + scm_ungetc (chars_read[--num_chars_read], port); return 0; } } @@ -1228,7 +1228,7 @@ scm_read_array (int c, SCM port, scm_t_read_opts *opts, long line, int column) if (c == 'a' && try_read_ci_chars (port, "lse")) return SCM_BOOL_F; else if (c != EOF) - scm_ungetc_unlocked (c, port); + scm_ungetc (c, port); return SCM_BOOL_F; } rank = 1; @@ -1384,7 +1384,7 @@ scm_read_guile_bit_vector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, } if (chr != EOF) - scm_ungetc_unlocked (chr, port); + scm_ungetc (chr, port); return maybe_annotate_source (scm_bitvector (scm_reverse_x (s_bits, SCM_EOL)), @@ -1439,7 +1439,7 @@ scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) name[i++] = c; else if (CHAR_IS_DELIMITER (c)) { - scm_ungetc_unlocked (c, port); + scm_ungetc (c, port); name[i] = '\0'; if (0 == strcmp ("r6rs", name)) ; /* Silently ignore */ @@ -1461,12 +1461,12 @@ scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) } else { - scm_ungetc_unlocked (c, port); + scm_ungetc (c, port); break; } } while (i > 0) - scm_ungetc_unlocked (name[--i], port); + scm_ungetc (name[--i], port); return scm_read_scsh_block_comment (chr, port); } @@ -1518,7 +1518,7 @@ scm_read_commented_expression (scm_t_wchar chr, SCM port, if (EOF == c) scm_i_input_error ("read_commented_expression", port, "no expression after #; comment", SCM_EOL); - scm_ungetc_unlocked (c, port); + scm_ungetc (c, port); scm_read_expression (port, opts); return SCM_UNSPECIFIED; } @@ -1868,7 +1868,7 @@ scm_read_expression (SCM port, scm_t_read_opts *opts) int c = flush_ws (port, opts, (char *) NULL); if (c == EOF) return SCM_EOF_VAL; - scm_ungetc_unlocked (c, port); + scm_ungetc (c, port); line = SCM_LINUM (port); column = SCM_COL (port); } @@ -1903,7 +1903,7 @@ scm_read_expression (SCM port, scm_t_read_opts *opts) else { if (chr != EOF) - scm_ungetc_unlocked (chr, port); + scm_ungetc (chr, port); break; } maybe_annotate_source (expr, port, opts, line, column); @@ -1937,7 +1937,7 @@ SCM_DEFINE (scm_read, "read", 0, 1, 0, c = flush_ws (port, &opts, (char *) NULL); if (EOF == c) return SCM_EOF_VAL; - scm_ungetc_unlocked (c, port); + scm_ungetc (c, port); return (scm_read_expression (port, &opts)); } From abf90c4e72fd7cd6573f77b06239e2e6c2f47fce Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 26 Apr 2016 22:11:41 +0200 Subject: [PATCH 226/865] Remove locking in scm_end_input * libguile/ports.c (scm_end_input): Sadly, we can't naively lock around the scm_port_buffer_take, as it might throw. Will revisit in the future. --- libguile/ports.c | 3 --- 1 file changed, 3 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 8405a0a2a..2062f588b 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -2383,11 +2383,8 @@ scm_end_input (SCM port) size_t discarded; pt = SCM_PTAB_ENTRY (port); - - scm_i_pthread_mutex_lock (pt->lock); buf = SCM_PTAB_ENTRY (port)->read_buf; discarded = scm_port_buffer_take (buf, NULL, (size_t) -1); - scm_i_pthread_mutex_unlock (pt->lock); if (discarded != 0) SCM_PORT_DESCRIPTOR (port)->seek (port, -discarded, SEEK_CUR); From 796676028b5812b556decf5cad1f3ce3992ac25f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 26 Apr 2016 22:13:26 +0200 Subject: [PATCH 227/865] Remove scm_fill_input_unlocked * libguile/ports.h (scm_fill_input_unlocked): Remove. * libguile/ports.c (scm_fill_input): Rename from scm_fill_input_unlocked. Adapt callers. * libguile/r6rs-ports.c (scm_get_bytevector_some): Adapt. * libguile/read.c (scm_i_scan_for_encoding): Adapt. --- libguile/ports.c | 20 ++------------------ libguile/ports.h | 1 - libguile/r6rs-ports.c | 2 +- libguile/read.c | 2 +- 4 files changed, 4 insertions(+), 21 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 2062f588b..58fe0f7f2 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1516,7 +1516,7 @@ scm_c_read_bytes (SCM port, SCM dst, size_t start, size_t count) buffer directly. */ if (to_read < pt->read_buffering) { - read_buf = scm_fill_input_unlocked (port); + read_buf = scm_fill_input (port); did_read = scm_port_buffer_take (read_buf, dst_ptr, to_read); dst_ptr += did_read; to_read -= did_read; @@ -2310,20 +2310,6 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, } #undef FUNC_NAME -SCM -scm_fill_input (SCM port) -{ - scm_i_pthread_mutex_t *lock; - SCM ret; - - scm_c_lock_port (port, &lock); - ret = scm_fill_input_unlocked (port); - if (lock) - scm_i_pthread_mutex_unlock (lock); - - return ret; -} - /* Move up to READ_LEN bytes from PORT's read buffer into memory starting at DEST. Return the number of bytes moved. PORT's line/column numbers are left unchanged. */ @@ -2378,11 +2364,9 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, void scm_end_input (SCM port) { - scm_t_port *pt; SCM buf; size_t discarded; - pt = SCM_PTAB_ENTRY (port); buf = SCM_PTAB_ENTRY (port)->read_buf; discarded = scm_port_buffer_take (buf, NULL, (size_t) -1); @@ -2423,7 +2407,7 @@ scm_flush (SCM port) } SCM -scm_fill_input_unlocked (SCM port) +scm_fill_input (SCM port) { scm_t_port *pt = SCM_PTAB_ENTRY (port); SCM read_buf = pt->read_buf; diff --git a/libguile/ports.h b/libguile/ports.h index 82b2553fe..4ea2c30ff 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -314,7 +314,6 @@ SCM_API SCM scm_unread_string (SCM str, SCM port); /* Manipulating the buffers. */ SCM_API SCM scm_setvbuf (SCM port, SCM mode, SCM size); SCM_API SCM scm_fill_input (SCM port); -SCM_API SCM scm_fill_input_unlocked (SCM port); SCM_INTERNAL size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len); SCM_API SCM scm_drain_input (SCM port); SCM_API void scm_end_input (SCM port); diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index db95e0805..bad344f88 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -474,7 +474,7 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0, SCM_VALIDATE_BINARY_INPUT_PORT (1, port); - buf = scm_fill_input_unlocked (port); + buf = scm_fill_input (port); size = scm_port_buffer_can_take (buf); if (size == 0) { diff --git a/libguile/read.c b/libguile/read.c index bcbf37ee4..ca9694f89 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -2073,7 +2073,7 @@ scm_i_scan_for_encoding (SCM port) if (scm_port_buffer_can_take (buf) == 0) { /* We can use the read buffer, and thus avoid a seek. */ - buf = scm_fill_input_unlocked (port); + buf = scm_fill_input (port); bytes_read = scm_port_buffer_can_take (buf); if (bytes_read > SCM_ENCODING_SEARCH_SIZE) bytes_read = SCM_ENCODING_SEARCH_SIZE; From 206b3f6e037a3e6d4eaa6401899cc48a51488657 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 26 Apr 2016 23:01:14 +0200 Subject: [PATCH 228/865] Remove scm_putc_unlocked. * libguile/ports.h (scm_putc_unlocked): Remove. * libguile/ports.c (scm_putc): Replace implementation with scm_putc_unlocked's implementation. (scm_port_print): Use scm_putc. * libguile/arbiters.c: * libguile/arrays.c: * libguile/bitvectors.c: * libguile/bytevectors.c: * libguile/continuations.c: * libguile/dynl.c: * libguile/eval.c: * libguile/filesys.c: * libguile/fluids.c: * libguile/foreign.c: * libguile/fports.c: * libguile/frames.c: * libguile/hashtab.c: * libguile/hooks.c: * libguile/macros.c: * libguile/mallocs.c: * libguile/print.c: * libguile/programs.c: * libguile/promises.c: * libguile/r6rs-ports.c: * libguile/smob.c: * libguile/srcprop.c: * libguile/struct.c: * libguile/variable.c: * libguile/weak-set.c: * libguile/weak-table.c: Use scm_putc instead of scm_putc_unlocked. --- libguile/arbiters.c | 2 +- libguile/arrays.c | 16 ++++++++-------- libguile/bitvectors.c | 2 +- libguile/bytevectors.c | 8 ++++---- libguile/continuations.c | 2 +- libguile/dynl.c | 2 +- libguile/eval.c | 4 ++-- libguile/filesys.c | 2 +- libguile/fluids.c | 4 ++-- libguile/foreign.c | 2 +- libguile/fports.c | 6 +++--- libguile/frames.c | 2 +- libguile/hashtab.c | 2 +- libguile/hooks.c | 8 ++++---- libguile/macros.c | 2 +- libguile/mallocs.c | 4 ++-- libguile/ports.c | 11 ++++------- libguile/ports.h | 8 -------- libguile/print.c | 32 ++++++++++++++++---------------- libguile/programs.c | 8 ++++---- libguile/promises.c | 2 +- libguile/r6rs-ports.c | 2 +- libguile/smob.c | 4 ++-- libguile/srcprop.c | 2 +- libguile/struct.c | 8 ++++---- libguile/variable.c | 2 +- libguile/weak-set.c | 2 +- libguile/weak-table.c | 2 +- 28 files changed, 70 insertions(+), 81 deletions(-) diff --git a/libguile/arbiters.c b/libguile/arbiters.c index 831e0a230..e25be4417 100644 --- a/libguile/arbiters.c +++ b/libguile/arbiters.c @@ -93,7 +93,7 @@ arbiter_print (SCM exp, SCM port, scm_print_state *pstate) if (SCM_ARB_LOCKED (exp)) scm_puts_unlocked ("locked ", port); scm_iprin1 (SCM_PACK (SCM_SMOB_DATA (exp)), port, pstate); - scm_putc_unlocked ('>', port); + scm_putc ('>', port); return !0; } diff --git a/libguile/arrays.c b/libguile/arrays.c index 4c1b824f2..52fe90a19 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -735,15 +735,15 @@ scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos, else { ssize_t i; - scm_putc_unlocked ('(', port); + scm_putc ('(', port); for (i = h->dims[dim].lbnd; i <= h->dims[dim].ubnd; i++, pos += h->dims[dim].inc) { scm_i_print_array_dimension (h, dim+1, pos, port, pstate); if (i < h->dims[dim].ubnd) - scm_putc_unlocked (' ', port); + scm_putc (' ', port); } - scm_putc_unlocked (')', port); + scm_putc (')', port); } return 1; } @@ -760,7 +760,7 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) scm_array_get_handle (array, &h); - scm_putc_unlocked ('#', port); + scm_putc ('#', port); if (SCM_I_ARRAYP (array)) scm_intprint (h.ndims, 10, port); if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM) @@ -781,12 +781,12 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) { if (print_lbnds) { - scm_putc_unlocked ('@', port); + scm_putc ('@', port); scm_intprint (h.dims[i].lbnd, 10, port); } if (print_lens) { - scm_putc_unlocked (':', port); + scm_putc (':', port); scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1, 10, port); } @@ -814,9 +814,9 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) not really the same as Scheme values since they are boxed and can be modified with array-set!, say. */ - scm_putc_unlocked ('(', port); + scm_putc ('(', port); scm_i_print_array_dimension (&h, 0, 0, port, pstate); - scm_putc_unlocked (')', port); + scm_putc (')', port); return 1; } else diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c index d594317b2..baa5e5e95 100644 --- a/libguile/bitvectors.c +++ b/libguile/bitvectors.c @@ -62,7 +62,7 @@ scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate) { scm_t_uint32 mask = 1; for (j = 0; j < 32 && j < bit_len; j++, mask <<= 1) - scm_putc_unlocked ((bits[i] & mask)? '1' : '0', port); + scm_putc ((bits[i] & mask)? '1' : '0', port); } return 1; diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index 41d5b6c85..54eef8b8e 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -417,17 +417,17 @@ scm_i_print_bytevector (SCM bv, SCM port, scm_print_state *pstate SCM_UNUSED) scm_array_get_handle (bv, &h); - scm_putc_unlocked ('#', port); + scm_putc ('#', port); scm_write (scm_array_handle_element_type (&h), port); - scm_putc_unlocked ('(', port); + scm_putc ('(', port); for (i = h.dims[0].lbnd, ubnd = h.dims[0].ubnd, inc = h.dims[0].inc; i <= ubnd; i += inc) { if (i > 0) - scm_putc_unlocked (' ', port); + scm_putc (' ', port); scm_write (scm_array_handle_ref (&h, i), port); } - scm_putc_unlocked (')', port); + scm_putc (')', port); return 1; } diff --git a/libguile/continuations.c b/libguile/continuations.c index c0a2bd8ae..9efa4359a 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -96,7 +96,7 @@ continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED) scm_intprint (continuation->num_stack_items, 10, port); scm_puts_unlocked (" @ ", port); scm_uintprint (SCM_SMOB_DATA_1 (obj), 16, port); - scm_putc_unlocked ('>', port); + scm_putc ('>', port); return 1; } diff --git a/libguile/dynl.c b/libguile/dynl.c index 79198e64c..d557faa37 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -233,7 +233,7 @@ dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate) scm_iprin1 (DYNL_FILENAME (exp), port, pstate); if (DYNL_HANDLE (exp) == NULL) scm_puts_unlocked (" (unlinked)", port); - scm_putc_unlocked ('>', port); + scm_putc ('>', port); return 1; } diff --git a/libguile/eval.c b/libguile/eval.c index 6f2751970..dca790c6b 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -922,14 +922,14 @@ boot_closure_print (SCM closure, SCM port, scm_print_state *pstate) SCM args; scm_puts_unlocked ("#', port); + scm_putc ('>', port); return 1; } diff --git a/libguile/filesys.c b/libguile/filesys.c index 167d4448a..c0acb8d39 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1825,7 +1825,7 @@ scm_dir_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) scm_puts_unlocked ("closed: ", port); scm_puts_unlocked ("directory stream ", port); scm_uintprint (SCM_SMOB_DATA_1 (exp), 16, port); - scm_putc_unlocked ('>', port); + scm_putc ('>', port); return 1; } diff --git a/libguile/fluids.c b/libguile/fluids.c index 4e0684af8..d50fc54a4 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -81,7 +81,7 @@ scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { scm_puts_unlocked ("#', port); + scm_putc ('>', port); } void @@ -89,7 +89,7 @@ scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED { scm_puts_unlocked ("#', port); + scm_putc ('>', port); } diff --git a/libguile/foreign.c b/libguile/foreign.c index 864019e63..1f30cd898 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -315,7 +315,7 @@ scm_i_pointer_print (SCM pointer, SCM port, scm_print_state *pstate) { scm_puts_unlocked ("#', port); + scm_putc ('>', port); } diff --git a/libguile/fports.c b/libguile/fports.c index efbcf73a0..59cabf254 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -556,7 +556,7 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) scm_display (name, port); else scm_puts_unlocked (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port); - scm_putc_unlocked (' ', port); + scm_putc (' ', port); fdes = (SCM_FSTREAM (exp))->fdes; #if (defined HAVE_TTYNAME) && (defined HAVE_POSIX) @@ -569,10 +569,10 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) else { scm_puts_unlocked (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port); - scm_putc_unlocked (' ', port); + scm_putc (' ', port); scm_uintprint ((scm_t_bits) SCM_PTAB_ENTRY (exp), 16, port); } - scm_putc_unlocked ('>', port); + scm_putc ('>', port); return 1; } diff --git a/libguile/frames.c b/libguile/frames.c index 534720f4c..221964f93 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -49,7 +49,7 @@ scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate) if (scm_is_true (name)) { - scm_putc_unlocked (' ', port); + scm_putc (' ', port); scm_write (name, port); } } diff --git a/libguile/hashtab.c b/libguile/hashtab.c index 30d781fe7..cbeaed717 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -172,7 +172,7 @@ scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate) scm_uintprint (SCM_UNPACK (exp), 16, port); scm_putc (' ', port); scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp), 10, port); - scm_putc_unlocked ('/', port); + scm_putc ('/', port); scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)), 10, port); scm_puts_unlocked (">", port); diff --git a/libguile/hooks.c b/libguile/hooks.c index 782636e4e..39b92ec5f 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -136,20 +136,20 @@ hook_print (SCM hook, SCM port, scm_print_state *pstate) SCM ls, name; scm_puts_unlocked ("#', port); + scm_putc ('>', port); return 1; } diff --git a/libguile/macros.c b/libguile/macros.c index 47b252d85..c5807b624 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -53,7 +53,7 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate) else scm_puts_unlocked ("#', port); + scm_putc ('>', port); return 1; } diff --git a/libguile/mallocs.c b/libguile/mallocs.c index 9f3584a09..1dc751e87 100644 --- a/libguile/mallocs.c +++ b/libguile/mallocs.c @@ -44,9 +44,9 @@ scm_t_bits scm_tc16_malloc; static int malloc_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { - scm_puts_unlocked("#', port); + scm_putc ('>', port); return 1; } diff --git a/libguile/ports.c b/libguile/ports.c index 58fe0f7f2..1076d760a 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -2479,11 +2479,8 @@ SCM_DEFINE (scm_port_write_buffer, "port-write-buffer", 1, 0, 0, void scm_putc (char c, SCM port) { - scm_i_pthread_mutex_t *lock; - scm_c_lock_port (port, &lock); - scm_putc_unlocked (c, port); - if (lock) - scm_i_pthread_mutex_unlock (lock); + SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port"); + scm_lfwrite_unlocked (&c, 1, port); } void @@ -3023,9 +3020,9 @@ scm_port_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) scm_puts_unlocked ("#<", port); scm_print_port_mode (exp, port); scm_puts_unlocked (type, port); - scm_putc_unlocked (' ', port); + scm_putc (' ', port); scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port); - scm_putc_unlocked ('>', port); + scm_putc ('>', port); return 1; } diff --git a/libguile/ports.h b/libguile/ports.h index 4ea2c30ff..70bf3ada8 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -324,7 +324,6 @@ SCM_INTERNAL SCM scm_port_write_buffer (SCM port); /* Output. */ SCM_API void scm_putc (char c, SCM port); -SCM_INLINE void scm_putc_unlocked (char c, SCM port); SCM_API void scm_puts (const char *str_data, SCM port); SCM_INLINE void scm_puts_unlocked (const char *str_data, SCM port); SCM_API void scm_c_write (SCM port, const void *buffer, size_t size); @@ -396,13 +395,6 @@ scm_c_try_lock_port (SCM port, scm_i_pthread_mutex_t **lock) return 0; } -SCM_INLINE_IMPLEMENTATION void -scm_putc_unlocked (char c, SCM port) -{ - SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port"); - scm_lfwrite_unlocked (&c, 1, port); -} - SCM_INLINE_IMPLEMENTATION void scm_puts_unlocked (const char *s, SCM port) { diff --git a/libguile/print.c b/libguile/print.c index d95051183..8c6b999eb 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -166,7 +166,7 @@ do \ { \ if (pstate->top - pstate->list_offset >= pstate->level) \ { \ - scm_putc_unlocked ('#', port); \ + scm_putc ('#', port); \ return; \ } \ } \ @@ -310,9 +310,9 @@ print_circref (SCM port, scm_print_state *pstate, SCM ref) for (i = pstate->top - 1; 1; --i) if (scm_is_eq (PSTATE_STACK_REF(pstate, i), ref)) break; - scm_putc_unlocked ('#', port); + scm_putc ('#', port); scm_intprint (i - self, 10, port); - scm_putc_unlocked ('#', port); + scm_putc ('#', port); } /* Print the name of a symbol. */ @@ -473,7 +473,7 @@ print_extended_symbol (SCM sym, SCM port) { scm_lfwrite_unlocked ("\\x", 2, port); scm_intprint (c, 16, port); - scm_putc_unlocked (';', port); + scm_putc (';', port); } } @@ -489,7 +489,7 @@ print_r7rs_extended_symbol (SCM sym, SCM port) len = scm_i_symbol_length (sym); strategy = PORT_CONVERSION_HANDLER (port); - scm_putc_unlocked ('|', port); + scm_putc ('|', port); for (pos = 0; pos < len; pos++) { @@ -522,13 +522,13 @@ print_r7rs_extended_symbol (SCM sym, SCM port) { scm_lfwrite_unlocked ("\\x", 2, port); scm_intprint (c, 16, port); - scm_putc_unlocked (';', port); + scm_putc (';', port); } break; } } - scm_putc_unlocked ('|', port); + scm_putc ('|', port); } /* FIXME: allow R6RS hex escapes instead of #{...}# or |...|. */ @@ -602,7 +602,7 @@ print_vector_or_weak_vector (SCM v, size_t len, SCM (*ref) (SCM, size_t), for (i = 0; i < last; ++i) { scm_iprin1 (ref (v, i), port, pstate); - scm_putc_unlocked (' ', port); + scm_putc (' ', port); } if (i == last) { @@ -611,7 +611,7 @@ print_vector_or_weak_vector (SCM v, size_t len, SCM (*ref) (SCM, size_t), } if (cutp) scm_puts_unlocked (" ...", port); - scm_putc_unlocked (')', port); + scm_putc (')', port); } static void @@ -744,9 +744,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) { scm_puts_unlocked ("#', port); + scm_putc ('>', port); } break; case scm_tc7_variable: @@ -1404,7 +1404,7 @@ scm_ipruk (char *hdr, SCM ptr, SCM port) } scm_puts_unlocked (" 0x", port); scm_uintprint (SCM_UNPACK (ptr), 16, port); - scm_putc_unlocked ('>', port); + scm_putc ('>', port); } @@ -1445,7 +1445,7 @@ scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate) if (scm_is_eq (PSTATE_STACK_REF(pstate, i), exp)) goto circref; PUSH_REF (pstate, exp); - scm_putc_unlocked (' ', port); + scm_putc (' ', port); /* CHECK_INTS; */ scm_iprin1 (SCM_CAR (exp), port, pstate); } @@ -1456,7 +1456,7 @@ scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate) } end: - scm_putc_unlocked (tlr, port); + scm_putc (tlr, port); pstate->top = floor + 2; return; @@ -1485,7 +1485,7 @@ fancy_printing: } PUSH_REF(pstate, exp); ++pstate->list_offset; - scm_putc_unlocked (' ', port); + scm_putc (' ', port); /* CHECK_INTS; */ scm_iprin1 (SCM_CAR (exp), port, pstate); } @@ -1665,7 +1665,7 @@ SCM_DEFINE (scm_newline, "newline", 0, 1, 0, SCM_VALIDATE_OPORT_VALUE (1, port); - scm_putc_unlocked ('\n', SCM_COERCE_OUTPORT (port)); + scm_putc ('\n', SCM_COERCE_OUTPORT (port)); return SCM_UNSPECIFIED; } #undef FUNC_NAME diff --git a/libguile/programs.c b/libguile/programs.c index c03865de1..72990d4e6 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -105,22 +105,22 @@ scm_i_program_print (SCM program, SCM port, scm_print_state *pstate) /* twingliness */ scm_puts_unlocked ("#', port); + scm_putc ('>', port); } else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program)) { /* twingliness */ scm_puts_unlocked ("#', port); + scm_putc ('>', port); } else if (scm_is_false (write_program) || print_error) { scm_puts_unlocked ("#', port); + scm_putc ('>', port); } else { diff --git a/libguile/promises.c b/libguile/promises.c index dcd0ac383..2435d80fe 100644 --- a/libguile/promises.c +++ b/libguile/promises.c @@ -92,7 +92,7 @@ promise_print (SCM exp, SCM port, scm_print_state *pstate) SCM_SET_WRITINGP (pstate, 1); scm_iprin1 (SCM_PROMISE_DATA (exp), port, pstate); SCM_SET_WRITINGP (pstate, writingp); - scm_putc_unlocked ('>', port); + scm_putc ('>', port); return !0; } diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index bad344f88..8a7fddd3b 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -558,7 +558,7 @@ SCM_DEFINE (scm_put_u8, "put-u8", 2, 0, 0, SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port); c_octet = scm_to_uint8 (octet); - scm_putc_unlocked ((char) c_octet, port); + scm_putc ((char) c_octet, port); return SCM_UNSPECIFIED; } diff --git a/libguile/smob.c b/libguile/smob.c index eecefd3dc..7bcd0440e 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -107,12 +107,12 @@ scm_smob_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) long n = SCM_SMOBNUM (exp); scm_puts_unlocked ("#<", port); scm_puts_unlocked (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port); - scm_putc_unlocked (' ', port); + scm_putc (' ', port); if (scm_smobs[n].size) scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port); else scm_uintprint (SCM_UNPACK (exp), 16, port); - scm_putc_unlocked ('>', port); + scm_putc ('>', port); return 1; } diff --git a/libguile/srcprop.c b/libguile/srcprop.c index dbebf779f..1f6e59a35 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -108,7 +108,7 @@ srcprops_print (SCM obj, SCM port, scm_print_state *pstate) SCM_SET_WRITINGP (pstate, 1); scm_iprin1 (scm_srcprops_to_alist (obj), port, pstate); SCM_SET_WRITINGP (pstate, writingp); - scm_putc_unlocked ('>', port); + scm_putc ('>', port); return 1; } diff --git a/libguile/struct.c b/libguile/struct.c index 3bf2e3687..4c9d8dac2 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -940,7 +940,7 @@ scm_print_struct (SCM exp, SCM port, scm_print_state *pstate) if (scm_is_true (name)) { scm_display (name, port); - scm_putc_unlocked (' ', port); + scm_putc (' ', port); } else { @@ -949,9 +949,9 @@ scm_print_struct (SCM exp, SCM port, scm_print_state *pstate) else scm_puts_unlocked ("struct:", port); scm_uintprint (SCM_UNPACK (vtable), 16, port); - scm_putc_unlocked (' ', port); + scm_putc (' ', port); scm_write (SCM_VTABLE_LAYOUT (vtable), port); - scm_putc_unlocked (' ', port); + scm_putc (' ', port); } scm_uintprint (SCM_UNPACK (exp), 16, port); /* hackety hack */ @@ -971,7 +971,7 @@ scm_print_struct (SCM exp, SCM port, scm_print_state *pstate) scm_write (SCM_STRUCT_SETTER (exp), port); } } - scm_putc_unlocked ('>', port); + scm_putc ('>', port); } } diff --git a/libguile/variable.c b/libguile/variable.c index 7b3f3356c..41f9c4df5 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -40,7 +40,7 @@ scm_i_variable_print (SCM exp, SCM port, scm_print_state *pstate) scm_uintprint (SCM_UNPACK (exp), 16, port); scm_puts_unlocked (" value: ", port); scm_iprin1 (SCM_VARIABLE_REF (exp), port, pstate); - scm_putc_unlocked('>', port); + scm_putc ('>', port); } diff --git a/libguile/weak-set.c b/libguile/weak-set.c index e8523ba62..6e42cddf8 100644 --- a/libguile/weak-set.c +++ b/libguile/weak-set.c @@ -678,7 +678,7 @@ scm_i_weak_set_print (SCM exp, SCM port, scm_print_state *pstate) scm_puts_unlocked ("#<", port); scm_puts_unlocked ("weak-set ", port); scm_uintprint (SCM_WEAK_SET (exp)->n_items, 10, port); - scm_putc_unlocked ('/', port); + scm_putc ('/', port); scm_uintprint (SCM_WEAK_SET (exp)->size, 10, port); scm_puts_unlocked (">", port); } diff --git a/libguile/weak-table.c b/libguile/weak-table.c index 4e3ed3396..082d7967d 100644 --- a/libguile/weak-table.c +++ b/libguile/weak-table.c @@ -793,7 +793,7 @@ scm_i_weak_table_print (SCM exp, SCM port, scm_print_state *pstate) scm_puts_unlocked ("#<", port); scm_puts_unlocked ("weak-table ", port); scm_uintprint (SCM_WEAK_TABLE (exp)->n_items, 10, port); - scm_putc_unlocked ('/', port); + scm_putc ('/', port); scm_uintprint (SCM_WEAK_TABLE (exp)->size, 10, port); scm_puts_unlocked (">", port); } From 105e36543fdc6eecff3189c0b94fca80f5af8480 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 26 Apr 2016 23:07:28 +0200 Subject: [PATCH 229/865] Remove scm_puts_unlocked. * libguile/ports.h (scm_puts_unlocked): Remove. * libguile/ports.c (scm_puts): Replace implementation with scm_puts_unlocked's implementation. * libguile/arbiters.c: * libguile/backtrace.c: * libguile/bitvectors.c: * libguile/continuations.c: * libguile/deprecation.c: * libguile/dynl.c: * libguile/eval.c: * libguile/filesys.c: * libguile/fluids.c: * libguile/foreign.c: * libguile/fports.c: * libguile/frames.c: * libguile/guardians.c: * libguile/hashtab.c: * libguile/hooks.c: * libguile/load.c: * libguile/macros.c: * libguile/mallocs.c: * libguile/print.c: * libguile/programs.c: * libguile/promises.c: * libguile/smob.c: * libguile/srcprop.c: * libguile/srfi-14.c: * libguile/stackchk.c: * libguile/struct.c: * libguile/threads.c: * libguile/throw.c: * libguile/values.c: * libguile/variable.c: * libguile/vm.c: * libguile/weak-set.c: * libguile/weak-table.c: Use scm_puts instead of scm_puts_unlocked. --- libguile/arbiters.c | 4 ++-- libguile/backtrace.c | 8 ++++---- libguile/bitvectors.c | 2 +- libguile/continuations.c | 6 +++--- libguile/deprecation.c | 2 +- libguile/dynl.c | 4 ++-- libguile/eval.c | 2 +- libguile/filesys.c | 6 +++--- libguile/fluids.c | 4 ++-- libguile/foreign.c | 2 +- libguile/fports.c | 6 +++--- libguile/frames.c | 4 ++-- libguile/guardians.c | 10 +++++----- libguile/hashtab.c | 4 ++-- libguile/hooks.c | 2 +- libguile/load.c | 26 +++++++++++++------------- libguile/macros.c | 4 ++-- libguile/mallocs.c | 2 +- libguile/ports.c | 13 +++++-------- libguile/ports.h | 8 -------- libguile/print.c | 38 +++++++++++++++++++------------------- libguile/programs.c | 6 +++--- libguile/promises.c | 2 +- libguile/smob.c | 4 ++-- libguile/srcprop.c | 2 +- libguile/srfi-14.c | 18 +++++++++--------- libguile/stackchk.c | 6 +++--- libguile/struct.c | 12 ++++++------ libguile/threads.c | 14 +++++++------- libguile/throw.c | 2 +- libguile/values.c | 4 ++-- libguile/variable.c | 4 ++-- libguile/vm.c | 4 ++-- libguile/weak-set.c | 6 +++--- libguile/weak-table.c | 6 +++--- 35 files changed, 118 insertions(+), 129 deletions(-) diff --git a/libguile/arbiters.c b/libguile/arbiters.c index e25be4417..f1ace572d 100644 --- a/libguile/arbiters.c +++ b/libguile/arbiters.c @@ -89,9 +89,9 @@ static scm_t_bits scm_tc16_arbiter; static int arbiter_print (SCM exp, SCM port, scm_print_state *pstate) { - scm_puts_unlocked ("#', port); return !0; diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 36ef594e1..495a68bad 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -58,9 +58,9 @@ static SCM boot_print_exception (SCM port, SCM frame, SCM key, SCM args) #define FUNC_NAME "boot-print-exception" { - scm_puts_unlocked ("Throw to key ", port); + scm_puts ("Throw to key ", port); scm_write (key, port); - scm_puts_unlocked (" with args ", port); + scm_puts (" with args ", port); scm_write (args, port); return SCM_UNSPECIFIED; } @@ -253,7 +253,7 @@ error_during_backtrace (void *data, SCM tag, SCM throw_args) { SCM port = SCM_PACK_POINTER (data); - scm_puts_unlocked ("Exception thrown while printing backtrace:\n", port); + scm_puts ("Exception thrown while printing backtrace:\n", port); scm_print_exception (port, SCM_BOOL_F, tag, throw_args); return SCM_UNSPECIFIED; @@ -311,7 +311,7 @@ SCM_DEFINE (scm_backtrace_with_highlights, "backtrace", 0, 1, 0, highlights = SCM_EOL; scm_newline (port); - scm_puts_unlocked ("Backtrace:\n", port); + scm_puts ("Backtrace:\n", port); scm_display_backtrace_with_highlights (stack, port, SCM_BOOL_F, SCM_BOOL_F, highlights); scm_newline (port); diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c index baa5e5e95..7a4ed9bf9 100644 --- a/libguile/bitvectors.c +++ b/libguile/bitvectors.c @@ -57,7 +57,7 @@ scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate) scm_t_uint32 *bits = BITVECTOR_BITS (vec); size_t i, j; - scm_puts_unlocked ("#*", port); + scm_puts ("#*", port); for (i = 0; i < word_len; i++, bit_len -= 32) { scm_t_uint32 mask = 1; diff --git a/libguile/continuations.c b/libguile/continuations.c index 9efa4359a..3ce794be1 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -92,9 +92,9 @@ continuation_print (SCM obj, SCM port, scm_print_state *state SCM_UNUSED) { scm_t_contregs *continuation = SCM_CONTREGS (obj); - scm_puts_unlocked ("#num_stack_items, 10, port); - scm_puts_unlocked (" @ ", port); + scm_puts (" @ ", port); scm_uintprint (SCM_SMOB_DATA_1 (obj), 16, port); scm_putc ('>', port); return 1; @@ -404,7 +404,7 @@ print_exception_and_backtrace (SCM port, SCM tag, SCM args) if (should_print_backtrace (tag, stack)) { - scm_puts_unlocked ("Backtrace:\n", port); + scm_puts ("Backtrace:\n", port); scm_display_backtrace_with_highlights (stack, port, SCM_BOOL_F, SCM_BOOL_F, SCM_EOL); diff --git a/libguile/deprecation.c b/libguile/deprecation.c index 1be3aea7e..aa50eaf8c 100644 --- a/libguile/deprecation.c +++ b/libguile/deprecation.c @@ -83,7 +83,7 @@ scm_c_issue_deprecation_warning (const char *msg) fprintf (stderr, "%s\n", msg); else { - scm_puts_unlocked (msg, scm_current_warning_port ()); + scm_puts (msg, scm_current_warning_port ()); scm_newline (scm_current_warning_port ()); } } diff --git a/libguile/dynl.c b/libguile/dynl.c index d557faa37..0061234e8 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -229,10 +229,10 @@ scm_t_bits scm_tc16_dynamic_obj; static int dynl_obj_print (SCM exp, SCM port, scm_print_state *pstate) { - scm_puts_unlocked ("#', port); return 1; } diff --git a/libguile/eval.c b/libguile/eval.c index dca790c6b..a20572f01 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -920,7 +920,7 @@ static int boot_closure_print (SCM closure, SCM port, scm_print_state *pstate) { SCM args; - scm_puts_unlocked ("#', port); return 1; diff --git a/libguile/fluids.c b/libguile/fluids.c index d50fc54a4..5ff92a884 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -79,7 +79,7 @@ grow_dynamic_state (SCM state) void scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { - scm_puts_unlocked ("#', port); } @@ -87,7 +87,7 @@ scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) void scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { - scm_puts_unlocked ("#', port); } diff --git a/libguile/foreign.c b/libguile/foreign.c index 1f30cd898..e6ba5331c 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -313,7 +313,7 @@ SCM_DEFINE (scm_set_pointer_finalizer_x, "set-pointer-finalizer!", 2, 0, 0, void scm_i_pointer_print (SCM pointer, SCM port, scm_print_state *pstate) { - scm_puts_unlocked ("#', port); } diff --git a/libguile/fports.c b/libguile/fports.c index 59cabf254..c6071febb 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -546,7 +546,7 @@ SCM_DEFINE (scm_adjust_port_revealed_x, "adjust-port-revealed!", 2, 0, 0, static int fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { - scm_puts_unlocked ("#<", port); + scm_puts ("#<", port); scm_print_port_mode (exp, port); if (SCM_OPFPORTP (exp)) { @@ -555,7 +555,7 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) if (scm_is_string (name) || scm_is_symbol (name)) scm_display (name, port); else - scm_puts_unlocked (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port); + scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port); scm_putc (' ', port); fdes = (SCM_FSTREAM (exp))->fdes; @@ -568,7 +568,7 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) } else { - scm_puts_unlocked (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port); + scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port); scm_putc (' ', port); scm_uintprint ((scm_t_bits) SCM_PTAB_ENTRY (exp), 16, port); } diff --git a/libguile/frames.c b/libguile/frames.c index 221964f93..bc2e501da 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -41,7 +41,7 @@ scm_c_make_frame (enum scm_vm_frame_kind kind, const struct scm_frame *frame) void scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate) { - scm_puts_unlocked ("#", port); + scm_puts (">", port); } static union scm_vm_stack_element* diff --git a/libguile/guardians.c b/libguile/guardians.c index 86e39ee54..63b8ec0d5 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -86,16 +86,16 @@ guardian_print (SCM guardian, SCM port, scm_print_state *pstate SCM_UNUSED) { t_guardian *g = GUARDIAN_DATA (guardian); - scm_puts_unlocked ("#live), port); - scm_puts_unlocked (" unreachable: ", port); + scm_puts (" unreachable: ", port); scm_display (scm_length (g->zombies), port); - scm_puts_unlocked (")", port); + scm_puts (")", port); - scm_puts_unlocked (">", port); + scm_puts (">", port); return 1; } diff --git a/libguile/hashtab.c b/libguile/hashtab.c index cbeaed717..4b9874488 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -168,14 +168,14 @@ scm_i_rehash (SCM table, void scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate) { - scm_puts_unlocked ("#", port); + scm_puts (">", port); } diff --git a/libguile/hooks.c b/libguile/hooks.c index 39b92ec5f..14335f879 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -134,7 +134,7 @@ static int hook_print (SCM hook, SCM port, scm_print_state *pstate) { SCM ls, name; - scm_puts_unlocked ("#', port); diff --git a/libguile/mallocs.c b/libguile/mallocs.c index 1dc751e87..23c1a6079 100644 --- a/libguile/mallocs.c +++ b/libguile/mallocs.c @@ -44,7 +44,7 @@ scm_t_bits scm_tc16_malloc; static int malloc_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { - scm_puts_unlocked ("#', port); return 1; diff --git a/libguile/ports.c b/libguile/ports.c index 1076d760a..77dfc8335 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -2486,11 +2486,8 @@ scm_putc (char c, SCM port) void scm_puts (const char *s, SCM port) { - scm_i_pthread_mutex_t *lock; - scm_c_lock_port (port, &lock); - scm_puts_unlocked (s, port); - if (lock) - scm_i_pthread_mutex_unlock (lock); + SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port"); + scm_lfwrite_unlocked (s, strlen (s), port); } static void @@ -2999,7 +2996,7 @@ SCM_DEFINE (scm_set_port_filename_x, "set-port-filename!", 2, 0, 0, void scm_print_port_mode (SCM exp, SCM port) { - scm_puts_unlocked (SCM_CLOSEDP (exp) + scm_puts (SCM_CLOSEDP (exp) ? "closed: " : (SCM_RDNG & SCM_CELL_WORD_0 (exp) ? (SCM_WRTNG & SCM_CELL_WORD_0 (exp) @@ -3017,9 +3014,9 @@ scm_port_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) char *type = SCM_PTOBNAME (SCM_PTOBNUM (exp)); if (!type) type = "port"; - scm_puts_unlocked ("#<", port); + scm_puts ("#<", port); scm_print_port_mode (exp, port); - scm_puts_unlocked (type, port); + scm_puts (type, port); scm_putc (' ', port); scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port); scm_putc ('>', port); diff --git a/libguile/ports.h b/libguile/ports.h index 70bf3ada8..40198218c 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -325,7 +325,6 @@ SCM_INTERNAL SCM scm_port_write_buffer (SCM port); /* Output. */ SCM_API void scm_putc (char c, SCM port); SCM_API void scm_puts (const char *str_data, SCM port); -SCM_INLINE void scm_puts_unlocked (const char *str_data, SCM port); SCM_API void scm_c_write (SCM port, const void *buffer, size_t size); SCM_API void scm_c_write_unlocked (SCM port, const void *buffer, size_t size); SCM_API void scm_c_write_bytes (SCM port, SCM src, size_t start, size_t count); @@ -394,13 +393,6 @@ scm_c_try_lock_port (SCM port, scm_i_pthread_mutex_t **lock) else return 0; } - -SCM_INLINE_IMPLEMENTATION void -scm_puts_unlocked (const char *s, SCM port) -{ - SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port"); - scm_lfwrite_unlocked (s, strlen (s), port); -} #endif /* SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES */ #endif /* SCM_PORTS_H */ diff --git a/libguile/print.c b/libguile/print.c index 8c6b999eb..2f03d0c9f 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -566,7 +566,7 @@ static void iprin1 (SCM exp, SCM port, scm_print_state *pstate); scm_intprint (i, 8, port); \ else \ { \ - scm_puts_unlocked ("x", port); \ + scm_puts ("x", port); \ scm_intprint (i, 16, port); \ } \ } \ @@ -610,7 +610,7 @@ print_vector_or_weak_vector (SCM v, size_t len, SCM (*ref) (SCM, size_t), scm_iprin1 (ref (v, i), port, pstate); } if (cutp) - scm_puts_unlocked (" ...", port); + scm_puts (" ...", port); scm_putc (')', port); } @@ -648,7 +648,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) else if (SCM_IFLAGP (exp) && ((size_t) SCM_IFLAGNUM (exp) < (sizeof iflagnames / sizeof (char *)))) { - scm_puts_unlocked (iflagnames [SCM_IFLAGNUM (exp)], port); + scm_puts (iflagnames [SCM_IFLAGNUM (exp)], port); } else { @@ -742,7 +742,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) } else { - scm_puts_unlocked ("#', port); } @@ -1415,7 +1415,7 @@ scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate) { register SCM hare, tortoise; long floor = pstate->top - 2; - scm_puts_unlocked (hdr, port); + scm_puts (hdr, port); /* CHECK_INTS; */ if (pstate->fancyp) goto fancy_printing; @@ -1451,7 +1451,7 @@ scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate) } if (!SCM_NULL_OR_NIL_P (exp)) { - scm_puts_unlocked (" . ", port); + scm_puts (" . ", port); scm_iprin1 (exp, port, pstate); } @@ -1477,7 +1477,7 @@ fancy_printing: { if (n == 0) { - scm_puts_unlocked (" ...", port); + scm_puts (" ...", port); goto skip_tail; } else @@ -1492,7 +1492,7 @@ fancy_printing: } if (!SCM_NULL_OR_NIL_P (exp)) { - scm_puts_unlocked (" . ", port); + scm_puts (" . ", port); scm_iprin1 (exp, port, pstate); } skip_tail: @@ -1503,7 +1503,7 @@ fancy_circref: pstate->list_offset -= pstate->top - floor - 2; circref: - scm_puts_unlocked (" . ", port); + scm_puts (" . ", port); print_circref (port, pstate, exp); goto end; } diff --git a/libguile/programs.c b/libguile/programs.c index 72990d4e6..49d4c77b1 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -103,20 +103,20 @@ scm_i_program_print (SCM program, SCM port, scm_print_state *pstate) if (SCM_PROGRAM_IS_CONTINUATION (program)) { /* twingliness */ - scm_puts_unlocked ("#', port); } else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program)) { /* twingliness */ - scm_puts_unlocked ("#', port); } else if (scm_is_false (write_program) || print_error) { - scm_puts_unlocked ("#len; i++) { if (first) first = 0; else - scm_puts_unlocked (" ", port); + scm_puts (" ", port); scm_write (SCM_MAKE_CHAR (p->ranges[i].lo), port); if (p->ranges[i].lo != p->ranges[i].hi) { - scm_puts_unlocked ("..", port); + scm_puts ("..", port); scm_write (SCM_MAKE_CHAR (p->ranges[i].hi), port); } if (i >= max_ranges_to_print) { /* Too many to print here. Quit early. */ - scm_puts_unlocked (" ...", port); + scm_puts (" ...", port); break; } } - scm_puts_unlocked ("}>", port); + scm_puts ("}>", port); return 1; } @@ -630,16 +630,16 @@ charset_cursor_print (SCM cursor, SCM port, cur = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor); - scm_puts_unlocked ("#range == (size_t) (-1)) - scm_puts_unlocked ("(empty)", port); + scm_puts ("(empty)", port); else { scm_write (scm_from_size_t (cur->range), port); - scm_puts_unlocked (":", port); + scm_puts (":", port); scm_write (scm_from_int32 (cur->n), port); } - scm_puts_unlocked (">", port); + scm_puts (">", port); return 1; } diff --git a/libguile/stackchk.c b/libguile/stackchk.c index 6a88c3e08..146dac50f 100644 --- a/libguile/stackchk.c +++ b/libguile/stackchk.c @@ -58,11 +58,11 @@ scm_stack_report () scm_uintprint ((scm_stack_size (thread->continuation_base) * sizeof (SCM_STACKITEM)), 16, port); - scm_puts_unlocked (" of stack: 0x", port); + scm_puts (" of stack: 0x", port); scm_uintprint ((scm_t_bits) thread->continuation_base, 16, port); - scm_puts_unlocked (" - 0x", port); + scm_puts (" - 0x", port); scm_uintprint ((scm_t_bits) &stack, 16, port); - scm_puts_unlocked ("\n", port); + scm_puts ("\n", port); } diff --git a/libguile/struct.c b/libguile/struct.c index 4c9d8dac2..51c0f111d 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -936,7 +936,7 @@ scm_print_struct (SCM exp, SCM port, scm_print_state *pstate) { SCM vtable = SCM_STRUCT_VTABLE (exp); SCM name = scm_struct_vtable_name (vtable); - scm_puts_unlocked ("#<", port); + scm_puts ("#<", port); if (scm_is_true (name)) { scm_display (name, port); @@ -945,9 +945,9 @@ scm_print_struct (SCM exp, SCM port, scm_print_state *pstate) else { if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_VTABLE)) - scm_puts_unlocked ("vtable:", port); + scm_puts ("vtable:", port); else - scm_puts_unlocked ("struct:", port); + scm_puts ("struct:", port); scm_uintprint (SCM_UNPACK (vtable), 16, port); scm_putc (' ', port); scm_write (SCM_VTABLE_LAYOUT (vtable), port); @@ -959,15 +959,15 @@ scm_print_struct (SCM exp, SCM port, scm_print_state *pstate) { if (scm_is_true (SCM_STRUCT_PROCEDURE (exp))) { - scm_puts_unlocked (" proc: ", port); + scm_puts (" proc: ", port); if (scm_is_true (scm_procedure_p (SCM_STRUCT_PROCEDURE (exp)))) scm_write (SCM_STRUCT_PROCEDURE (exp), port); else - scm_puts_unlocked ("(not a procedure?)", port); + scm_puts ("(not a procedure?)", port); } if (SCM_STRUCT_SETTER_P (exp)) { - scm_puts_unlocked (" setter: ", port); + scm_puts (" setter: ", port); scm_write (SCM_STRUCT_SETTER (exp), port); } } diff --git a/libguile/threads.c b/libguile/threads.c index 3dc0f40c3..b6099309f 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -264,11 +264,11 @@ thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) else id = u.um; - scm_puts_unlocked ("#", port); + scm_puts (")>", port); return 1; } @@ -1197,9 +1197,9 @@ static int fat_mutex_print (SCM mx, SCM port, scm_print_state *pstate SCM_UNUSED) { fat_mutex *m = SCM_MUTEX_DATA (mx); - scm_puts_unlocked ("#", port); + scm_puts (">", port); return 1; } @@ -1658,9 +1658,9 @@ static int fat_cond_print (SCM cv, SCM port, scm_print_state *pstate SCM_UNUSED) { fat_cond *c = SCM_CONDVAR_DATA (cv); - scm_puts_unlocked ("#", port); + scm_puts (">", port); return 1; } diff --git a/libguile/throw.c b/libguile/throw.c index 773ac2783..38fe149fa 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -527,7 +527,7 @@ handler_message (void *handler_data, SCM tag, SCM args) if (should_print_backtrace (tag, stack)) { - scm_puts_unlocked ("Backtrace:\n", p); + scm_puts ("Backtrace:\n", p); scm_display_backtrace_with_highlights (stack, p, SCM_BOOL_F, SCM_BOOL_F, SCM_EOL); diff --git a/libguile/values.c b/libguile/values.c index 670e22294..ef27cadd1 100644 --- a/libguile/values.c +++ b/libguile/values.c @@ -60,9 +60,9 @@ print_values (SCM obj, SCM pwps) SCM port = SCM_PORT_WITH_PS_PORT (pwps); scm_print_state *ps = SCM_PRINT_STATE (SCM_PORT_WITH_PS_PS (pwps)); - scm_puts_unlocked ("#", port); + scm_puts (">", port); return SCM_UNSPECIFIED; } diff --git a/libguile/variable.c b/libguile/variable.c index 41f9c4df5..b377b4140 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -36,9 +36,9 @@ void scm_i_variable_print (SCM exp, SCM port, scm_print_state *pstate) { - scm_puts_unlocked ("#', port); } diff --git a/libguile/vm.c b/libguile/vm.c index 33f12b454..4899a8038 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -106,9 +106,9 @@ vm_restore_sp (struct scm_vm *vp, union scm_vm_stack_element *new_sp) void scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate) { - scm_puts_unlocked ("#", port); + scm_puts (">", port); } int diff --git a/libguile/weak-set.c b/libguile/weak-set.c index 6e42cddf8..d2e4744bf 100644 --- a/libguile/weak-set.c +++ b/libguile/weak-set.c @@ -675,12 +675,12 @@ make_weak_set (unsigned long k) void scm_i_weak_set_print (SCM exp, SCM port, scm_print_state *pstate) { - scm_puts_unlocked ("#<", port); - scm_puts_unlocked ("weak-set ", port); + scm_puts ("#<", port); + scm_puts ("weak-set ", port); scm_uintprint (SCM_WEAK_SET (exp)->n_items, 10, port); scm_putc ('/', port); scm_uintprint (SCM_WEAK_SET (exp)->size, 10, port); - scm_puts_unlocked (">", port); + scm_puts (">", port); } static void diff --git a/libguile/weak-table.c b/libguile/weak-table.c index 082d7967d..cd7d8c86a 100644 --- a/libguile/weak-table.c +++ b/libguile/weak-table.c @@ -790,12 +790,12 @@ make_weak_table (unsigned long k, scm_t_weak_table_kind kind) void scm_i_weak_table_print (SCM exp, SCM port, scm_print_state *pstate) { - scm_puts_unlocked ("#<", port); - scm_puts_unlocked ("weak-table ", port); + scm_puts ("#<", port); + scm_puts ("weak-table ", port); scm_uintprint (SCM_WEAK_TABLE (exp)->n_items, 10, port); scm_putc ('/', port); scm_uintprint (SCM_WEAK_TABLE (exp)->size, 10, port); - scm_puts_unlocked (">", port); + scm_puts (">", port); } static void From d0b9d3b04d63d5add984b33d2371528297464623 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 26 Apr 2016 23:13:32 +0200 Subject: [PATCH 230/865] Remove scm_c_write_unlocked * libguile/ports.h (scm_c_write_bytes_unlocked): Remove. * libguile/ports.c (scm_c_write_bytes): Rename from scm_c_write_bytes_unlocked, make public, and return void. (scm_c_write): Rename from scm_c_write_unlocked. Remove locked variant. (scm_lfwrite_unlocked): Call scm_c_write. * libguile/rw.c (scm_write_string_partial): Call scm_c_write. --- libguile/ports.c | 30 ++++-------------------------- libguile/ports.h | 1 - libguile/rw.c | 2 +- 3 files changed, 5 insertions(+), 28 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 77dfc8335..14be36889 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -2529,8 +2529,8 @@ scm_i_write_unlocked (SCM port, SCM buf) scm_c_write writes the requested number of bytes. Warning: Doesn't update port line and column counts! */ -static size_t -scm_c_write_bytes_unlocked (SCM port, SCM src, size_t start, size_t count) +void +scm_c_write_bytes (SCM port, SCM src, size_t start, size_t count) #define FUNC_NAME "scm_c_write_bytes" { scm_t_port *pt; @@ -2576,8 +2576,6 @@ scm_c_write_bytes_unlocked (SCM port, SCM src, size_t start, size_t count) scm_i_write_bytes_unlocked (port, src, start, count); } - - return count; } #undef FUNC_NAME @@ -2585,7 +2583,7 @@ scm_c_write_bytes_unlocked (SCM port, SCM src, size_t start, size_t count) Used when an application wants to write bytes stored in an area not managed by GC. */ void -scm_c_write_unlocked (SCM port, const void *ptr, size_t size) +scm_c_write (SCM port, const void *ptr, size_t size) #define FUNC_NAME "scm_c_write" { scm_t_port *pt; @@ -2612,26 +2610,6 @@ scm_c_write_unlocked (SCM port, const void *ptr, size_t size) } #undef FUNC_NAME -void -scm_c_write (SCM port, const void *ptr, size_t size) -{ - scm_i_pthread_mutex_t *lock; - scm_c_lock_port (port, &lock); - scm_c_write_unlocked (port, ptr, size); - if (lock) - scm_i_pthread_mutex_unlock (lock); -} - -void -scm_c_write_bytes (SCM port, SCM src, size_t start, size_t count) -{ - scm_i_pthread_mutex_t *lock; - scm_c_lock_port (port, &lock); - scm_c_write_bytes_unlocked (port, src, start, count); - if (lock) - scm_i_pthread_mutex_unlock (lock); -} - /* scm_lfwrite * * This function differs from scm_c_write; it updates port line and @@ -2641,7 +2619,7 @@ scm_lfwrite_unlocked (const char *ptr, size_t size, SCM port) { int saved_line; - scm_c_write_unlocked (port, ptr, size); + scm_c_write (port, ptr, size); saved_line = SCM_LINUM (port); for (; size; ptr++, size--) diff --git a/libguile/ports.h b/libguile/ports.h index 40198218c..d916205ff 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -326,7 +326,6 @@ SCM_INTERNAL SCM scm_port_write_buffer (SCM port); SCM_API void scm_putc (char c, SCM port); SCM_API void scm_puts (const char *str_data, SCM port); SCM_API void scm_c_write (SCM port, const void *buffer, size_t size); -SCM_API void scm_c_write_unlocked (SCM port, const void *buffer, size_t size); SCM_API void scm_c_write_bytes (SCM port, SCM src, size_t start, size_t count); SCM_API void scm_lfwrite (const char *ptr, size_t size, SCM port); SCM_API void scm_lfwrite_unlocked (const char *ptr, size_t size, SCM port); diff --git a/libguile/rw.c b/libguile/rw.c index b2f8f3a1d..b3d1f1614 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -242,7 +242,7 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0, flush. */ if (write_len < scm_port_buffer_can_put (write_buf)) { - scm_c_write_unlocked (port, src, write_len); + scm_c_write (port, src, write_len); return scm_from_long (write_len); } From 15d53047233ad3d3b1ac39764d3c417e3b87f118 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 26 Apr 2016 23:17:22 +0200 Subject: [PATCH 231/865] scm_lfwrite, not scm_lfwrite_unlocked * libguile/ports.h (scm_lfwrite_unlocked): Remove. * libguile/ports.c (scm_lfwrite): Rename from scm_lfwrite_unlocked. * libguile/numbers.c: * libguile/print.c: Adapt to call scm_lfwrite. --- libguile/numbers.c | 10 +++++----- libguile/ports.c | 16 +++------------- libguile/ports.h | 1 - libguile/print.c | 46 +++++++++++++++++++++++----------------------- 4 files changed, 31 insertions(+), 42 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 14d98ffea..4f740c583 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -5692,7 +5692,7 @@ int scm_print_real (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED) { char num_buf[FLOBUFLEN]; - scm_lfwrite_unlocked (num_buf, iflo2str (sexp, num_buf, 10), port); + scm_lfwrite (num_buf, iflo2str (sexp, num_buf, 10), port); return !0; } @@ -5700,7 +5700,7 @@ void scm_i_print_double (double val, SCM port) { char num_buf[FLOBUFLEN]; - scm_lfwrite_unlocked (num_buf, idbl2str (val, num_buf, 10), port); + scm_lfwrite (num_buf, idbl2str (val, num_buf, 10), port); } int @@ -5708,7 +5708,7 @@ scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED) { char num_buf[FLOBUFLEN]; - scm_lfwrite_unlocked (num_buf, iflo2str (sexp, num_buf, 10), port); + scm_lfwrite (num_buf, iflo2str (sexp, num_buf, 10), port); return !0; } @@ -5716,7 +5716,7 @@ void scm_i_print_complex (double real, double imag, SCM port) { char num_buf[FLOBUFLEN]; - scm_lfwrite_unlocked (num_buf, icmplx2str (real, imag, num_buf, 10), port); + scm_lfwrite (num_buf, icmplx2str (real, imag, num_buf, 10), port); } int @@ -5737,7 +5737,7 @@ scm_bigprint (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) void (*freefunc) (void *, size_t); mp_get_memory_functions (NULL, NULL, &freefunc); scm_remember_upto_here_1 (exp); - scm_lfwrite_unlocked (str, len, port); + scm_lfwrite (str, len, port); freefunc (str, len + 1); return !0; } diff --git a/libguile/ports.c b/libguile/ports.c index 14be36889..cc33bd905 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -2480,14 +2480,14 @@ void scm_putc (char c, SCM port) { SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port"); - scm_lfwrite_unlocked (&c, 1, port); + scm_lfwrite (&c, 1, port); } void scm_puts (const char *s, SCM port) { SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port"); - scm_lfwrite_unlocked (s, strlen (s), port); + scm_lfwrite (s, strlen (s), port); } static void @@ -2615,7 +2615,7 @@ scm_c_write (SCM port, const void *ptr, size_t size) * This function differs from scm_c_write; it updates port line and * column, flushing line-buffered ports when appropriate. */ void -scm_lfwrite_unlocked (const char *ptr, size_t size, SCM port) +scm_lfwrite (const char *ptr, size_t size, SCM port) { int saved_line; @@ -2630,16 +2630,6 @@ scm_lfwrite_unlocked (const char *ptr, size_t size, SCM port) scm_flush (port); } -void -scm_lfwrite (const char *ptr, size_t size, SCM port) -{ - scm_i_pthread_mutex_t *lock; - scm_c_lock_port (port, &lock); - scm_lfwrite_unlocked (ptr, size, port); - if (lock) - scm_i_pthread_mutex_unlock (lock); -} - /* Write STR to PORT from START inclusive to END exclusive. */ void scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port) diff --git a/libguile/ports.h b/libguile/ports.h index d916205ff..d88fb21bd 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -328,7 +328,6 @@ SCM_API void scm_puts (const char *str_data, SCM port); SCM_API void scm_c_write (SCM port, const void *buffer, size_t size); SCM_API void scm_c_write_bytes (SCM port, SCM src, size_t start, size_t count); SCM_API void scm_lfwrite (const char *ptr, size_t size, SCM port); -SCM_API void scm_lfwrite_unlocked (const char *ptr, size_t size, SCM port); SCM_INTERNAL void scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port); diff --git a/libguile/print.c b/libguile/print.c index 2f03d0c9f..514a725c2 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -453,7 +453,7 @@ print_extended_symbol (SCM sym, SCM port) len = scm_i_symbol_length (sym); strategy = PORT_CONVERSION_HANDLER (port); - scm_lfwrite_unlocked ("#{", 2, port); + scm_lfwrite ("#{", 2, port); for (pos = 0; pos < len; pos++) { @@ -471,13 +471,13 @@ print_extended_symbol (SCM sym, SCM port) } else { - scm_lfwrite_unlocked ("\\x", 2, port); + scm_lfwrite ("\\x", 2, port); scm_intprint (c, 16, port); scm_putc (';', port); } } - scm_lfwrite_unlocked ("}#", 2, port); + scm_lfwrite ("}#", 2, port); } static void @@ -497,13 +497,13 @@ print_r7rs_extended_symbol (SCM sym, SCM port) switch (c) { - case '\a': scm_lfwrite_unlocked ("\\a", 2, port); break; - case '\b': scm_lfwrite_unlocked ("\\b", 2, port); break; - case '\t': scm_lfwrite_unlocked ("\\t", 2, port); break; - case '\n': scm_lfwrite_unlocked ("\\n", 2, port); break; - case '\r': scm_lfwrite_unlocked ("\\r", 2, port); break; - case '|': scm_lfwrite_unlocked ("\\|", 2, port); break; - case '\\': scm_lfwrite_unlocked ("\\x5c;", 5, port); break; + case '\a': scm_lfwrite ("\\a", 2, port); break; + case '\b': scm_lfwrite ("\\b", 2, port); break; + case '\t': scm_lfwrite ("\\t", 2, port); break; + case '\n': scm_lfwrite ("\\n", 2, port); break; + case '\r': scm_lfwrite ("\\r", 2, port); break; + case '|': scm_lfwrite ("\\|", 2, port); break; + case '\\': scm_lfwrite ("\\x5c;", 5, port); break; default: if (uc_is_general_category_withtable (c, UC_CATEGORY_MASK_L @@ -520,7 +520,7 @@ print_r7rs_extended_symbol (SCM sym, SCM port) } else { - scm_lfwrite_unlocked ("\\x", 2, port); + scm_lfwrite ("\\x", 2, port); scm_intprint (c, 16, port); scm_putc (';', port); } @@ -956,7 +956,7 @@ display_string_as_utf8 (const void *str, int narrow_p, size_t len, /* INPUT was successfully converted, entirely; print the result. */ - scm_lfwrite_unlocked (utf8_buf, utf8_len, port); + scm_lfwrite (utf8_buf, utf8_len, port); printed += i - printed; } @@ -976,7 +976,7 @@ display_string_as_latin1 (const void *str, int narrow_p, size_t len, if (narrow_p) { - scm_lfwrite_unlocked (str, len, port); + scm_lfwrite (str, len, port); return len; } @@ -995,7 +995,7 @@ display_string_as_latin1 (const void *str, int narrow_p, size_t len, break; } - scm_lfwrite_unlocked (buf, i, port); + scm_lfwrite (buf, i, port); if (i < sizeof(buf) && printed < len) { @@ -1081,7 +1081,7 @@ display_string_using_iconv (const void *str, int narrow_p, size_t len, iconv (id->output_cd, NULL, NULL, NULL, NULL); /* Print the OUTPUT_LEN bytes successfully converted. */ - scm_lfwrite_unlocked (encoded_output, output_len, port); + scm_lfwrite (encoded_output, output_len, port); /* See how many input codepoints these OUTPUT_LEN bytes corresponds to. */ @@ -1116,7 +1116,7 @@ display_string_using_iconv (const void *str, int narrow_p, size_t len, { /* INPUT was successfully converted, entirely; print the result. */ - scm_lfwrite_unlocked (encoded_output, output_len, port); + scm_lfwrite (encoded_output, output_len, port); codepoints_read = i - printed; printed += codepoints_read; } @@ -1217,7 +1217,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port) /* Use special escapes for some C0 controls. */ buf[0] = '\\'; buf[1] = escapes[ch - 0x07]; - scm_lfwrite_unlocked (buf, 2, port); + scm_lfwrite (buf, 2, port); } else if (!SCM_R6RS_ESCAPES_P) { @@ -1227,7 +1227,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port) buf[1] = 'x'; buf[2] = hex[ch / 16]; buf[3] = hex[ch % 16]; - scm_lfwrite_unlocked (buf, 4, port); + scm_lfwrite (buf, 4, port); } else if (ch <= 0xFFFF) { @@ -1237,7 +1237,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port) buf[3] = hex[(ch & 0xF00) >> 8]; buf[4] = hex[(ch & 0xF0) >> 4]; buf[5] = hex[(ch & 0xF)]; - scm_lfwrite_unlocked (buf, 6, port); + scm_lfwrite (buf, 6, port); } else if (ch > 0xFFFF) { @@ -1249,7 +1249,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port) buf[5] = hex[(ch & 0xF00) >> 8]; buf[6] = hex[(ch & 0xF0) >> 4]; buf[7] = hex[(ch & 0xF)]; - scm_lfwrite_unlocked (buf, 8, port); + scm_lfwrite (buf, 8, port); } } else @@ -1272,7 +1272,7 @@ write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port) buf[i] = 'x'; i --; buf[i] = '\\'; - scm_lfwrite_unlocked (buf + i, 9 - i, port); + scm_lfwrite (buf + i, 9 - i, port); } } else @@ -1376,14 +1376,14 @@ void scm_intprint (scm_t_intmax n, int radix, SCM port) { char num_buf[SCM_INTBUFLEN]; - scm_lfwrite_unlocked (num_buf, scm_iint2str (n, radix, num_buf), port); + scm_lfwrite (num_buf, scm_iint2str (n, radix, num_buf), port); } void scm_uintprint (scm_t_uintmax n, int radix, SCM port) { char num_buf[SCM_INTBUFLEN]; - scm_lfwrite_unlocked (num_buf, scm_iuint2str (n, radix, num_buf), port); + scm_lfwrite (num_buf, scm_iuint2str (n, radix, num_buf), port); } /* Print an object of unrecognized type. From ee4854a315a902d64c6de0ff27ac2d423dc75600 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 27 Apr 2016 20:54:10 +0200 Subject: [PATCH 232/865] Remove port locking around write, display * libguile/print.c (scm_write, scm_display): * libguile/read.c (set_port_read_option): Remove port locking. Reading and writing to the same port from multiple threads just must not crash; it doesn't have to make sense. --- libguile/print.c | 8 -------- libguile/read.c | 5 ----- 2 files changed, 13 deletions(-) diff --git a/libguile/print.c b/libguile/print.c index 514a725c2..ff0dab3ec 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1527,11 +1527,7 @@ scm_write (SCM obj, SCM port) port = scm_current_output_port (); SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_write); - - scm_dynwind_begin (0); - scm_dynwind_lock_port (SCM_COERCE_OUTPORT (port)); scm_prin1 (obj, port, 1); - scm_dynwind_end (); return SCM_UNSPECIFIED; } @@ -1546,11 +1542,7 @@ scm_display (SCM obj, SCM port) port = scm_current_output_port (); SCM_ASSERT (scm_valid_oport_value_p (port), port, SCM_ARG2, s_display); - - scm_dynwind_begin (0); - scm_dynwind_lock_port (SCM_COERCE_OUTPORT (port)); scm_prin1 (obj, port, 0); - scm_dynwind_end (); return SCM_UNSPECIFIED; } diff --git a/libguile/read.c b/libguile/read.c index ca9694f89..20de0bb9b 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -2252,9 +2252,6 @@ set_port_read_option (SCM port, int option, int new_value) new_value &= READ_OPTION_MASK; - scm_dynwind_begin (0); - scm_dynwind_lock_port (port); - scm_read_options = scm_i_port_property (port, sym_port_read_options); if (scm_is_unsigned_integer (scm_read_options, 0, READ_OPTIONS_MAX_VALUE)) read_options = scm_to_uint (scm_read_options); @@ -2264,8 +2261,6 @@ set_port_read_option (SCM port, int option, int new_value) read_options |= new_value << option; scm_read_options = scm_from_uint (read_options); scm_i_set_port_property_x (port, sym_port_read_options, scm_read_options); - - scm_dynwind_end (); } /* Set OPTS and PORT's case-insensitivity according to VALUE. */ From 8b46a4af446d2015976b1d9c09888a75260ebc2b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 28 Apr 2016 07:54:07 +0200 Subject: [PATCH 233/865] Optimize peek-char * libguile/ports.c (scm_peek_char): Optimize. A loop calling peek-char on a buffered string port 10e6 times goes down from 50ns/iteration to 32ns/iteration. --- libguile/ports.c | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/libguile/ports.c b/libguile/ports.c index cc33bd905..394d632e7 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -2124,17 +2124,29 @@ SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0, "sequence when the error is raised.\n") #define FUNC_NAME s_scm_peek_char { - int err; + int first_byte, err; SCM result; scm_t_wchar c; char bytes[SCM_MBCHAR_BUF_SIZE]; long column, line; size_t len = 0; + scm_t_port_internal *pti; if (SCM_UNBNDP (port)) port = scm_current_input_port (); SCM_VALIDATE_OPINPORT (1, port); + pti = SCM_PORT_GET_INTERNAL (port); + /* First, a couple fast paths. */ + first_byte = peek_byte_or_eof (port); + if (first_byte == EOF) + return SCM_EOF_VAL; + if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1) + return SCM_MAKE_CHAR (first_byte); + if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8 && first_byte < 0x80) + return SCM_MAKE_CHAR (first_byte); + + /* Now the slow paths. */ column = SCM_COL (port); line = SCM_LINUM (port); From 2b47043052565eb780ef5600e4968fc333643b0c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 28 Apr 2016 08:34:08 +0200 Subject: [PATCH 234/865] Remove port locks * libguile/ports.h (scm_t_port): Remove lock field. (scm_dynwind_lock_port, scm_c_lock_port, scm_c_try_lock_port): Remove. * libguile/ports.c (scm_i_port_property, scm_i_set_port_property_x): Remove locking. * libguile/ports.c (scm_c_make_port_with_encoding): Remove lock. (scm_i_read_bytes, scm_i_read, scm_i_write_bytes, scm_i_write): Remove "_unlocked" from names and adapt callers. --- libguile/ports.c | 83 +++++++++++++----------------------------------- libguile/ports.h | 38 ---------------------- 2 files changed, 22 insertions(+), 99 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 394d632e7..75bd1dd81 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -327,9 +327,7 @@ SCM_DEFINE (scm_i_port_property, "%port-property", 2, 0, 0, SCM_VALIDATE_OPPORT (1, port); pt = SCM_PTAB_ENTRY (port); - scm_i_pthread_mutex_lock (pt->lock); result = scm_assq_ref (pt->internal->alist, key); - scm_i_pthread_mutex_unlock (pt->lock); return result; } @@ -345,9 +343,7 @@ SCM_DEFINE (scm_i_set_port_property_x, "%set-port-property!", 3, 0, 0, SCM_VALIDATE_OPPORT (1, port); pt = SCM_PTAB_ENTRY (port); - scm_i_pthread_mutex_lock (pt->lock); pt->internal->alist = scm_assq_set_x (pt->internal->alist, key, value); - scm_i_pthread_mutex_unlock (pt->lock); return SCM_UNSPECIFIED; } @@ -690,9 +686,6 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits, SCM_SET_CELL_WORD_1 (ret, (scm_t_bits) entry); SCM_SET_CELL_WORD_2 (ret, (scm_t_bits) ptob); - entry->lock = scm_gc_malloc_pointerless (sizeof (*entry->lock), "port lock"); - scm_i_pthread_mutex_init (entry->lock, scm_i_pthread_mutexattr_recursive); - entry->internal = pti; entry->file_name = SCM_BOOL_F; /* By default, any port type with a seek function has random-access @@ -1324,38 +1317,6 @@ SCM_DEFINE (scm_set_port_conversion_strategy_x, "set-port-conversion-strategy!", #undef FUNC_NAME - - -/* The port lock. */ - -static void -lock_port (void *mutex) -{ - scm_i_pthread_mutex_lock ((scm_i_pthread_mutex_t *) mutex); -} - -static void -unlock_port (void *mutex) -{ - scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t *) mutex); -} - -void -scm_dynwind_lock_port (SCM port) -#define FUNC_NAME "dynwind-lock-port" -{ - scm_i_pthread_mutex_t *lock; - SCM_VALIDATE_OPPORT (SCM_ARG1, port); - scm_c_lock_port (port, &lock); - if (lock) - { - scm_dynwind_unwind_handler (unlock_port, lock, SCM_F_WIND_EXPLICITLY); - scm_dynwind_rewind_handler (lock_port, lock, 0); - } -} -#undef FUNC_NAME - - /* Input. */ @@ -1448,7 +1409,7 @@ scm_peek_byte_or_eof (SCM port) } static size_t -scm_i_read_bytes_unlocked (SCM port, SCM dst, size_t start, size_t count) +scm_i_read_bytes (SCM port, SCM dst, size_t start, size_t count) { size_t filled; scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port); @@ -1463,17 +1424,17 @@ scm_i_read_bytes_unlocked (SCM port, SCM dst, size_t start, size_t count) return filled; } -/* scm_i_read_unlocked is used internally to add bytes to the given port +/* scm_i_read is used internally to add bytes to the given port buffer. If the number of available bytes in the buffer does not - increase after a call to scm_i_read_unlocked, that indicates EOF. */ + increase after a call to scm_i_read, that indicates EOF. */ static void -scm_i_read_unlocked (SCM port, SCM buf) +scm_i_read (SCM port, SCM buf) { size_t count; - count = scm_i_read_bytes_unlocked (port, scm_port_buffer_bytevector (buf), - scm_to_size_t (scm_port_buffer_end (buf)), - scm_port_buffer_can_put (buf)); + count = scm_i_read_bytes (port, scm_port_buffer_bytevector (buf), + scm_to_size_t (scm_port_buffer_end (buf)), + scm_port_buffer_can_put (buf)); scm_port_buffer_did_put (buf, count); scm_port_buffer_set_has_eof_p (buf, scm_from_bool (count == 0)); } @@ -1529,9 +1490,9 @@ scm_c_read_bytes (SCM port, SCM dst, size_t start, size_t count) } else { - did_read = scm_i_read_bytes_unlocked (port, dst, - start + count - to_read, - to_read); + did_read = scm_i_read_bytes (port, dst, + start + count - to_read, + to_read); to_read -= did_read; dst_ptr += did_read; if (did_read == 0) @@ -2408,14 +2369,14 @@ SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0, } #undef FUNC_NAME -static void scm_i_write_unlocked (SCM port, SCM buf); +static void scm_i_write (SCM port, SCM buf); void scm_flush (SCM port) { SCM buf = SCM_PTAB_ENTRY (port)->write_buf; if (scm_port_buffer_can_take (buf)) - scm_i_write_unlocked (port, buf); + scm_i_write (port, buf); } SCM @@ -2438,7 +2399,7 @@ scm_fill_input (SCM port) else scm_port_buffer_reset (read_buf); - scm_i_read_unlocked (port, read_buf); + scm_i_read (port, read_buf); return read_buf; } @@ -2503,7 +2464,7 @@ scm_puts (const char *s, SCM port) } static void -scm_i_write_bytes_unlocked (SCM port, SCM src, size_t start, size_t count) +scm_i_write_bytes (SCM port, SCM src, size_t start, size_t count) { size_t written = 0; scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port); @@ -2519,7 +2480,7 @@ scm_i_write_bytes_unlocked (SCM port, SCM src, size_t start, size_t count) } static void -scm_i_write_unlocked (SCM port, SCM buf) +scm_i_write (SCM port, SCM buf) { size_t start, count; @@ -2532,8 +2493,8 @@ scm_i_write_unlocked (SCM port, SCM buf) start = scm_to_size_t (scm_port_buffer_cur (buf)); count = scm_port_buffer_can_take (buf); scm_port_buffer_reset (buf); - scm_i_write_bytes_unlocked (port, scm_port_buffer_bytevector (buf), start, - count); + scm_i_write_bytes (port, scm_port_buffer_bytevector (buf), start, + count); } /* Used by an application to write arbitrary number of bytes to an SCM @@ -2569,7 +2530,7 @@ scm_c_write_bytes (SCM port, SCM src, size_t start, size_t count) full after filling it with the new data; if that's the case, we flush then instead. */ if (scm_port_buffer_can_put (write_buf) < count) - scm_i_write_unlocked (port, write_buf); + scm_i_write (port, write_buf); { signed char *src_ptr = SCM_BYTEVECTOR_CONTENTS (src) + start; @@ -2577,16 +2538,16 @@ scm_c_write_bytes (SCM port, SCM src, size_t start, size_t count) } if (scm_port_buffer_can_put (write_buf) == 0) - scm_i_write_unlocked (port, write_buf); + scm_i_write (port, write_buf); } else { /* Our write would overflow the buffer. Flush buffered bytes (if needed), then write our bytes with just one syscall. */ if (scm_port_buffer_can_take (write_buf)) - scm_i_write_unlocked (port, write_buf); + scm_i_write (port, write_buf); - scm_i_write_bytes_unlocked (port, src, start, count); + scm_i_write_bytes (port, src, start, count); } } #undef FUNC_NAME @@ -2617,7 +2578,7 @@ scm_c_write (SCM port, const void *ptr, size_t size) written += did_put; src += did_put; if (scm_port_buffer_can_put (write_buf) == 0) - scm_i_write_unlocked (port, write_buf); + scm_i_write (port, write_buf); } } #undef FUNC_NAME diff --git a/libguile/ports.h b/libguile/ports.h index d88fb21bd..230137f68 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -84,9 +84,6 @@ typedef struct /* Link back to the port object. */ SCM port; - /* A recursive lock for this port. */ - scm_i_pthread_mutex_t *lock; - /* Pointer to internal-only port structure. */ struct scm_port_internal *internal; @@ -289,11 +286,6 @@ SCM_API SCM scm_set_port_encoding_x (SCM port, SCM encoding); SCM_API SCM scm_port_conversion_strategy (SCM port); SCM_API SCM scm_set_port_conversion_strategy_x (SCM port, SCM behavior); -/* Acquiring and releasing the port lock. */ -SCM_API void scm_dynwind_lock_port (SCM port); -SCM_INLINE int scm_c_lock_port (SCM port, scm_i_pthread_mutex_t **lock); -SCM_INLINE int scm_c_try_lock_port (SCM port, scm_i_pthread_mutex_t **lock); - /* Input. */ SCM_API int scm_get_byte_or_eof (SCM port); SCM_API int scm_peek_byte_or_eof (SCM port); @@ -363,36 +355,6 @@ SCM_API SCM scm_sys_make_void_port (SCM mode); SCM_INTERNAL void scm_init_ports (void); -/* Inline function implementations. */ - -#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES -SCM_INLINE_IMPLEMENTATION int -scm_c_lock_port (SCM port, scm_i_pthread_mutex_t **lock) -{ - *lock = SCM_PTAB_ENTRY (port)->lock; - - if (*lock) - return scm_i_pthread_mutex_lock (*lock); - else - return 0; -} - -SCM_INLINE_IMPLEMENTATION int -scm_c_try_lock_port (SCM port, scm_i_pthread_mutex_t **lock) -{ - *lock = SCM_PTAB_ENTRY (port)->lock; - if (*lock) - { - int ret = scm_i_pthread_mutex_trylock (*lock); - if (ret != 0) - *lock = NULL; - return ret; - } - else - return 0; -} -#endif /* SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES */ - #endif /* SCM_PORTS_H */ /* From 8bad621fec65d58768a38661278165ae259fabce Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 30 Apr 2016 11:59:33 +0200 Subject: [PATCH 235/865] Add SCM port read/write functions * libguile/ports.h (scm_t_ptob_descriptor): Add "scm_read" and "scm_write" members, for calling from Scheme. (scm_set_port_scm_read, scm_set_port_scm_write): New procedures. * libguile/ports.c (trampoline_to_c_read_subr) (trampoline_to_c_write_subr): New static variables. * libguile/ports.c (scm_make_port_type): Initialize scm_read and scm_write members to trampoline to C. (trampoline_to_c_read, trampoline_to_scm_read) (trampoline_to_c_write, trampoline_to_scm_write): New helpers. (scm_set_port_scm_read, scm_set_port_scm_write): New functions. (default_buffer_size): Move definition down. (scm_i_read_bytes, scm_i_write_bytes): Use new names for read and write procedures. (scm_init_ports): Initialize trampolines. --- libguile/ports.c | 72 ++++++++++++++++++++++++++++++++++++++++++++---- libguile/ports.h | 9 ++++-- 2 files changed, 73 insertions(+), 8 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 75bd1dd81..8c8276b26 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -224,8 +224,8 @@ scm_c_port_type_add_x (scm_t_ptob_descriptor *desc) return ret; } -/* Default buffer size. Used if the port type won't supply a value. */ -static const size_t default_buffer_size = 1024; +static SCM trampoline_to_c_read_subr; +static SCM trampoline_to_c_write_subr; scm_t_bits scm_make_port_type (char *name, @@ -242,8 +242,10 @@ scm_make_port_type (char *name, desc->name = name; desc->print = scm_port_print; - desc->read = read; - desc->write = write; + desc->c_read = read; + desc->c_write = write; + desc->scm_read = read ? trampoline_to_c_read_subr : SCM_BOOL_F; + desc->scm_write = write ? trampoline_to_c_write_subr : SCM_BOOL_F; ptobnum = scm_c_port_type_add_x (desc); @@ -254,6 +256,54 @@ scm_make_port_type (char *name, return scm_tc7_port + ptobnum * 256; } +static SCM +trampoline_to_c_read (SCM port, SCM dst, SCM start, SCM count) +{ + return scm_from_size_t + (SCM_PORT_DESCRIPTOR (port)->c_read + (port, dst, scm_to_size_t (start), scm_to_size_t (count))); +} + +static size_t +trampoline_to_scm_read (SCM port, SCM dst, size_t start, size_t count) +{ + return scm_to_size_t + (scm_call_4 (SCM_PORT_DESCRIPTOR (port)->scm_read, port, dst, + scm_from_size_t (start), scm_from_size_t (count))); +} + +static SCM +trampoline_to_c_write (SCM port, SCM src, SCM start, SCM count) +{ + return scm_from_size_t + (SCM_PORT_DESCRIPTOR (port)->c_write + (port, src, scm_to_size_t (start), scm_to_size_t (count))); +} + +static size_t +trampoline_to_scm_write (SCM port, SCM src, size_t start, size_t count) +{ + return scm_to_size_t + (scm_call_4 (SCM_PORT_DESCRIPTOR (port)->scm_write, port, src, + scm_from_size_t (start), scm_from_size_t (count))); +} + +void +scm_set_port_scm_read (scm_t_bits tc, SCM read) +{ + scm_t_ptob_descriptor *desc = scm_c_port_type_ref (SCM_TC2PTOBNUM (tc)); + desc->scm_read = read; + desc->c_read = trampoline_to_scm_read; +} + +void +scm_set_port_scm_write (scm_t_bits tc, SCM write) +{ + scm_t_ptob_descriptor *desc = scm_c_port_type_ref (SCM_TC2PTOBNUM (tc)); + desc->scm_write = write; + desc->c_write = trampoline_to_scm_write; +} + void scm_set_port_print (scm_t_bits tc, int (*print) (SCM exp, SCM port, scm_print_state *pstate)) @@ -637,6 +687,9 @@ finalize_port (void *ptr, void *data) +/* Default buffer size. Used if the port type won't supply a value. */ +static const size_t default_buffer_size = 1024; + static void initialize_port_buffers (SCM port) { @@ -1417,7 +1470,7 @@ scm_i_read_bytes (SCM port, SCM dst, size_t start, size_t count) assert (count <= SCM_BYTEVECTOR_LENGTH (dst)); assert (start + count <= SCM_BYTEVECTOR_LENGTH (dst)); - filled = ptob->read (port, dst, start, count); + filled = ptob->c_read (port, dst, start, count); assert (filled <= count); @@ -2473,7 +2526,7 @@ scm_i_write_bytes (SCM port, SCM src, size_t start, size_t count) assert (start + count <= SCM_BYTEVECTOR_LENGTH (src)); do - written += ptob->write (port, src, start + written, count - written); + written += ptob->c_write (port, src, start + written, count - written); while (written < count); assert (written == count); @@ -3108,6 +3161,13 @@ scm_init_ice_9_ports (void) void scm_init_ports (void) { + trampoline_to_c_read_subr = + scm_c_make_gsubr ("port-read", 4, 0, 0, + (scm_t_subr) trampoline_to_c_read); + trampoline_to_c_write_subr = + scm_c_make_gsubr ("port-write", 4, 0, 0, + (scm_t_subr) trampoline_to_c_write); + scm_tc16_void_port = scm_make_port_type ("void", void_port_read, void_port_write); diff --git a/libguile/ports.h b/libguile/ports.h index 230137f68..ba4bc2c3a 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -181,8 +181,11 @@ typedef struct scm_t_ptob_descriptor char *name; int (*print) (SCM exp, SCM port, scm_print_state *pstate); - size_t (*read) (SCM port, SCM dst, size_t start, size_t count); - size_t (*write) (SCM port, SCM src, size_t start, size_t count); + size_t (*c_read) (SCM port, SCM dst, size_t start, size_t count); + size_t (*c_write) (SCM port, SCM src, size_t start, size_t count); + SCM scm_read; + SCM scm_write; + scm_t_off (*seek) (SCM port, scm_t_off OFFSET, int WHENCE); void (*close) (SCM port); @@ -209,6 +212,8 @@ SCM_API scm_t_bits scm_make_port_type (char *name, size_t (*read) (SCM port, SCM dst, size_t start, size_t count), size_t (*write) (SCM port, SCM src, size_t start, size_t count)); +SCM_API void scm_set_port_scm_read (scm_t_bits tc, SCM read); +SCM_API void scm_set_port_scm_write (scm_t_bits tc, SCM write); SCM_API void scm_set_port_print (scm_t_bits tc, int (*print) (SCM exp, SCM port, From 555c934726636f1dfd5e1048cda4c31fbeaaa3f4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 30 Apr 2016 14:44:20 +0200 Subject: [PATCH 236/865] Refactor way the-eof-object is defined * libguile/ports.c (scm_init_ice_9_ports): Define the-eof-object here. Update a comment. * module/ice-9/ports.scm: Use the-eof-object definition from C. --- libguile/ports.c | 4 ++-- module/ice-9/ports.scm | 2 -- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 8c8276b26..058d7dcf3 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -3145,13 +3145,13 @@ scm_init_ice_9_ports (void) { #include "libguile/ports.x" + scm_c_define ("the-eof-object", SCM_EOF_VAL); + /* lseek() symbols. */ scm_c_define ("SEEK_SET", scm_from_int (SEEK_SET)); scm_c_define ("SEEK_CUR", scm_from_int (SEEK_CUR)); scm_c_define ("SEEK_END", scm_from_int (SEEK_END)); - /* These bindings are used when boot-9 turns `current-input-port' et - al into parameters. They are then removed from the guile module. */ scm_c_define ("%current-input-port-fluid", cur_inport_fluid); scm_c_define ("%current-output-port-fluid", cur_outport_fluid); scm_c_define ("%current-error-port-fluid", cur_errport_fluid); diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 0dd1df718..388b2584a 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -461,8 +461,6 @@ written into the port is returned." (call-with-output-string (lambda (p) (with-error-to-port p thunk)))) -(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p)))) - (define (inherit-print-state old-port new-port) (if (get-print-state old-port) (port-with-print-state new-port (get-print-state old-port)) From 300c85b0f0943f3af1c53b5df8937d4b2cef97a3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 30 Apr 2016 14:45:44 +0200 Subject: [PATCH 237/865] Tweak port initialization order * libguile/init.c (scm_i_init_guile): Initialize ports before strports/fports, so that we have initialized the read/write trampolines before making port types. --- libguile/init.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/init.c b/libguile/init.c index dd63574fd..7e0c30d9c 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -430,9 +430,9 @@ scm_i_init_guile (void *base) scm_init_control (); /* requires fluids */ scm_init_feature (); scm_init_backtrace (); + scm_init_ports (); scm_init_fports (); scm_init_strports (); - scm_init_ports (); scm_init_hash (); scm_init_hashtab (); scm_init_deprecation (); From 6a752bcf2ae78ee1ce25512a7c65307a909e99e1 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 30 Apr 2016 14:46:45 +0200 Subject: [PATCH 238/865] peek-byte in Scheme * libguile/ports.c (trampoline_to_c_read, trampoline_to_c_write): Since C might assume that the indices are within bounds of the bytevector, verify them more here. (scm_port_random_access_p, scm_port_read_buffering) (scm_set_port_read_buffer, scm_port_read, scm_port_write): New helpers exposed to (ice-9 ports). (scm_port_read_buffer, scm_port_write_buffer): Don't flush or validate port mode; we do that in Scheme. * module/ice-9/ports.scm: Implement enough of port machinery to implement peek-byte in Scheme. Not yet exported. --- libguile/ports.c | 110 ++++++++++++++++++++++++++++++----------- libguile/ports.h | 6 +++ module/ice-9/ports.scm | 83 +++++++++++++++++++++++++++++++ 3 files changed, 169 insertions(+), 30 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 058d7dcf3..319b5f5fa 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -258,11 +258,20 @@ scm_make_port_type (char *name, static SCM trampoline_to_c_read (SCM port, SCM dst, SCM start, SCM count) +#define FUNC_NAME "port-read" { + size_t c_start, c_count; + + SCM_VALIDATE_OPPORT (1, port); + c_start = scm_to_size_t (start); + c_count = scm_to_size_t (count); + SCM_ASSERT_RANGE (2, start, start <= count); + SCM_ASSERT_RANGE (3, count, c_start+c_count <= scm_c_bytevector_length (dst)); + return scm_from_size_t - (SCM_PORT_DESCRIPTOR (port)->c_read - (port, dst, scm_to_size_t (start), scm_to_size_t (count))); + (SCM_PORT_DESCRIPTOR (port)->c_read (port, dst, c_start, c_count)); } +#undef FUNC_NAME static size_t trampoline_to_scm_read (SCM port, SCM dst, size_t start, size_t count) @@ -274,11 +283,20 @@ trampoline_to_scm_read (SCM port, SCM dst, size_t start, size_t count) static SCM trampoline_to_c_write (SCM port, SCM src, SCM start, SCM count) +#define FUNC_NAME "port-write" { + size_t c_start, c_count; + + SCM_VALIDATE_OPPORT (1, port); + c_start = scm_to_size_t (start); + c_count = scm_to_size_t (count); + SCM_ASSERT_RANGE (2, start, c_start <= c_count); + SCM_ASSERT_RANGE (3, count, c_start+c_count <= scm_c_bytevector_length (src)); + return scm_from_size_t - (SCM_PORT_DESCRIPTOR (port)->c_write - (port, src, scm_to_size_t (start), scm_to_size_t (count))); + (SCM_PORT_DESCRIPTOR (port)->c_write (port, src, c_start, c_count)); } +#undef FUNC_NAME static size_t trampoline_to_scm_write (SCM port, SCM src, size_t start, size_t count) @@ -2457,43 +2475,75 @@ scm_fill_input (SCM port) return read_buf; } +SCM_DEFINE (scm_port_random_access_p, "port-random-access?", 1, 0, 0, + (SCM port), + "Return true if the port is random-access, or false otherwise.") +#define FUNC_NAME s_scm_port_random_access_p +{ + SCM_VALIDATE_OPPORT (1, port); + return scm_from_bool (SCM_PTAB_ENTRY (port)->rw_random); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_port_read_buffering, "port-read-buffering", 1, 0, 0, + (SCM port), + "Return the amount of read buffering on a port, in bytes.") +#define FUNC_NAME s_scm_port_read_buffering +{ + SCM_VALIDATE_OPINPORT (1, port); + return scm_from_size_t (SCM_PTAB_ENTRY (port)->read_buffering); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_set_port_read_buffer_x, "set-port-read-buffer!", 2, 0, 0, + (SCM port, SCM buf), + "Reset the read buffer on an input port.") +#define FUNC_NAME s_scm_set_port_read_buffer_x +{ + SCM_VALIDATE_OPINPORT (1, port); + SCM_ASSERT_TYPE (scm_is_vector (buf) && scm_c_vector_length (buf) >= 4, + buf, 2, FUNC_NAME, "port buffer"); + SCM_PTAB_ENTRY (port)->read_buf = buf; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_port_read, "port-read", 1, 0, 0, (SCM port), + "Return the read function for an input port.") +#define FUNC_NAME s_scm_port_read +{ + SCM_VALIDATE_OPINPORT (1, port); + return SCM_PORT_DESCRIPTOR (port)->scm_read; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_port_write, "port-write", 1, 0, 0, + (SCM port), + "Return the write function for an output port.") +#define FUNC_NAME s_scm_port_write +{ + SCM_VALIDATE_OPOUTPORT (1, port); + return SCM_PORT_DESCRIPTOR (port)->scm_write; +} +#undef FUNC_NAME + SCM_DEFINE (scm_port_read_buffer, "port-read-buffer", 1, 0, 0, (SCM port), - "Return the read buffer for a port. If the port is\n" - "random-access, its write buffer, if any, will be flushed\n" - "if needed.") + "Return the read buffer for a port.") #define FUNC_NAME s_scm_port_read_buffer { - scm_t_port *pt; - - SCM_VALIDATE_OPINPORT (1, port); - - pt = SCM_PTAB_ENTRY (port); - - if (pt->rw_random) - scm_flush (pt->port); - - return pt->read_buf; + SCM_VALIDATE_OPPORT (1, port); + return SCM_PTAB_ENTRY (port)->read_buf; } #undef FUNC_NAME SCM_DEFINE (scm_port_write_buffer, "port-write-buffer", 1, 0, 0, (SCM port), - "Return the write buffer for a port. If the port is\n" - "random-access, its read buffer, if any, will be discarded\n" - "if needed.") + "Return the write buffer for a port.") #define FUNC_NAME s_scm_port_write_buffer { - scm_t_port *pt; - - SCM_VALIDATE_OPOUTPORT (1, port); - - pt = SCM_PTAB_ENTRY (port); - - if (pt->rw_random) - scm_end_input (pt->port); - - return pt->write_buf; + SCM_VALIDATE_OPPORT (1, port); + return SCM_PTAB_ENTRY (port)->write_buf; } #undef FUNC_NAME diff --git a/libguile/ports.h b/libguile/ports.h index ba4bc2c3a..2a6e42c8b 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -316,6 +316,12 @@ SCM_API SCM scm_drain_input (SCM port); SCM_API void scm_end_input (SCM port); SCM_API SCM scm_force_output (SCM port); SCM_API void scm_flush (SCM port); + +SCM_INTERNAL SCM scm_port_random_access_p (SCM port); +SCM_INTERNAL SCM scm_port_read_buffering (SCM port); +SCM_INTERNAL SCM scm_set_port_read_buffer_x (SCM port, SCM buf); +SCM_INTERNAL SCM scm_port_read (SCM port); +SCM_INTERNAL SCM scm_port_write (SCM port); SCM_INTERNAL SCM scm_port_read_buffer (SCM port); SCM_INTERNAL SCM scm_port_write_buffer (SCM port); diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 388b2584a..8051549eb 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -26,6 +26,7 @@ (define-module (ice-9 ports) + #:use-module (rnrs bytevectors) #:export (;; Definitions from ports.c. %port-property %set-port-property! @@ -153,6 +154,88 @@ +(define-syntax-rule (port-buffer-bytevector buf) (vector-ref buf 0)) +(define-syntax-rule (port-buffer-cur buf) (vector-ref buf 1)) +(define-syntax-rule (port-buffer-end buf) (vector-ref buf 2)) +(define-syntax-rule (port-buffer-has-eof? buf) (vector-ref buf 3)) + +(define-syntax-rule (set-port-buffer-cur! buf cur) + (vector-set! buf 1 cur)) +(define-syntax-rule (set-port-buffer-end! buf end) + (vector-set! buf 2 end)) +(define-syntax-rule (set-port-buffer-has-eof?! buf has-eof?) + (vector-set! buf 3 has-eof?)) + +(define (make-port-buffer size) + (vector (make-bytevector size 0) 0 0 #f)) + +(define (write-bytes port src start count) + (let ((written ((port-write port) port src start count))) + (unless (<= 0 written count) + (error "bad return from port write function" written)) + (when (< written count) + (write-bytes port src (+ start written) (- count written))))) + +(define (flush-output port) + (let* ((buf (port-write-buffer port)) + (cur (port-buffer-cur buf)) + (end (port-buffer-end buf))) + (when (< cur end) + ;; Update cursors before attempting to write, assuming that I/O + ;; errors are sticky. That way if the write throws an error, + ;; causing the computation to abort, and possibly causing the port + ;; to be collected by GC when it's open, any subsequent close-port + ;; or force-output won't signal *another* error. + (set-port-buffer-cur! buf 0) + (set-port-buffer-end! buf 0) + (write-bytes port (port-buffer-bytevector buf) cur (- end cur))))) + +(define (read-bytes port dst start count) + (let ((read ((port-read port) port dst start count))) + (unless (<= 0 read count) + (error "bad return from port read function" read)) + read)) + +(define (fill-input port) + (let ((buf (port-read-buffer port))) + (cond + ((or (< (port-buffer-cur buf) (port-buffer-end buf)) + (port-buffer-has-eof? buf)) + buf) + (else + (unless (input-port? port) + (error "not an input port" port)) + (when (port-random-access? port) + (flush-output port)) + (let* ((read-buffering (port-read-buffering port)) + (buf (if (= (bytevector-length (port-buffer-bytevector buf)) + read-buffering) + buf + (let ((buf (make-port-buffer read-buffering))) + (set-port-read-buffer! port buf) + buf))) + (bv (port-buffer-bytevector buf)) + (start (port-buffer-end buf)) + (count (- (bytevector-length bv) start)) + (read (read-bytes port bv start count))) + (set-port-buffer-end! buf (+ start read)) + (set-port-buffer-has-eof?! buf (zero? count)) + buf))))) + +(define (peek-byte port) + (let* ((buf (port-read-buffer port)) + (cur (port-buffer-cur buf))) + (if (< cur (port-buffer-end buf)) + (bytevector-u8-ref (port-buffer-bytevector buf) cur) + (let* ((buf (fill-input port)) + (cur (port-buffer-cur buf))) + (if (< cur (port-buffer-end buf)) + (bytevector-u8-ref (port-buffer-bytevector buf) cur) + the-eof-object))))) + + + + ;;; Current ports as parameters. ;;; From 56c48d14ac99f0c7399a09873bd29d2120c48dbe Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 1 May 2016 14:29:17 +0200 Subject: [PATCH 239/865] scm_fill_input can guarantee a minimum fill amount * libguile/ports.h (scm_fill_input): Add "minimum_size" argument. Adapt all callers to pass 0 as this argument. * libguile/ports.c (scm_i_read): Inline into scm_fill_input. (scm_fill_input): "minimum_size" argument ensures that there are a certain number of bytes available, or EOF. Instead of shrinking the read buffer, only fill by the read_buffering amount, or the minimum_size, whichever is larger. * libguile/r6rs-ports.c: * libguile/read.c: Adapt scm_fill_input callers. --- libguile/ports.c | 77 +++++++++++++++++++++++++++---------------- libguile/ports.h | 2 +- libguile/r6rs-ports.c | 2 +- libguile/read.c | 2 +- 4 files changed, 52 insertions(+), 31 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 319b5f5fa..13e28954a 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1414,7 +1414,7 @@ get_byte_or_eof (SCM port) return ret; } - buf = scm_fill_input (port); + buf = scm_fill_input (port, 0); buf_bv = scm_port_buffer_bytevector (buf); buf_cur = scm_port_buffer_cur (buf); buf_end = scm_port_buffer_end (buf); @@ -1453,7 +1453,7 @@ peek_byte_or_eof (SCM port) return ret; } - buf = scm_fill_input (port); + buf = scm_fill_input (port, 0); buf_bv = scm_port_buffer_bytevector (buf); buf_cur = scm_port_buffer_cur (buf); buf_end = scm_port_buffer_end (buf); @@ -1495,21 +1495,6 @@ scm_i_read_bytes (SCM port, SCM dst, size_t start, size_t count) return filled; } -/* scm_i_read is used internally to add bytes to the given port - buffer. If the number of available bytes in the buffer does not - increase after a call to scm_i_read, that indicates EOF. */ -static void -scm_i_read (SCM port, SCM buf) -{ - size_t count; - - count = scm_i_read_bytes (port, scm_port_buffer_bytevector (buf), - scm_to_size_t (scm_port_buffer_end (buf)), - scm_port_buffer_can_put (buf)); - scm_port_buffer_did_put (buf, count); - scm_port_buffer_set_has_eof_p (buf, scm_from_bool (count == 0)); -} - /* Used by an application to read arbitrary number of bytes from an SCM port. Same semantics as libc read, except that scm_c_read_bytes only returns less than SIZE bytes if at end-of-file. @@ -1548,7 +1533,7 @@ scm_c_read_bytes (SCM port, SCM dst, size_t start, size_t count) buffer directly. */ if (to_read < pt->read_buffering) { - read_buf = scm_fill_input (port); + read_buf = scm_fill_input (port, 0); did_read = scm_port_buffer_take (read_buf, dst_ptr, to_read); dst_ptr += did_read; to_read -= did_read; @@ -1598,7 +1583,7 @@ scm_c_read (SCM port, void *buffer, size_t size) while (copied < size) { size_t count; - read_buf = scm_fill_input (port); + read_buf = scm_fill_input (port, 0); count = scm_port_buffer_take (read_buf, dst + copied, size - copied); copied += count; if (count == 0) @@ -2451,26 +2436,62 @@ scm_flush (SCM port) } SCM -scm_fill_input (SCM port) +scm_fill_input (SCM port, size_t minimum_size) { scm_t_port *pt = SCM_PTAB_ENTRY (port); SCM read_buf = pt->read_buf; + size_t buffered = scm_port_buffer_can_take (read_buf); - if (scm_port_buffer_can_take (read_buf) || - scm_is_true (scm_port_buffer_has_eof_p (read_buf))) + if (minimum_size == 0) + minimum_size = 1; + + if (buffered >= minimum_size + || scm_is_true (scm_port_buffer_has_eof_p (read_buf))) return read_buf; if (pt->rw_random) scm_flush (pt->port); - /* It could be that putback caused us to enlarge the buffer; now that - we've read all the bytes we need to shrink it again. */ - if (scm_port_buffer_size (read_buf) != pt->read_buffering) - read_buf = pt->read_buf = scm_c_make_port_buffer (pt->read_buffering); - else + /* Prepare to read. Make sure there is enough space in the buffer for + minimum_size, and ensure that cur is zero so that we fill towards + the end of the buffer. */ + if (minimum_size > scm_port_buffer_size (read_buf)) + { + /* Grow the read buffer. */ + SCM new_buf = scm_c_make_port_buffer (minimum_size); + scm_port_buffer_reset (new_buf); + scm_port_buffer_put (new_buf, + scm_port_buffer_take_pointer (read_buf), + buffered); + pt->read_buf = read_buf = new_buf; + } + else if (buffered == 0) scm_port_buffer_reset (read_buf); + else + { + const scm_t_uint8 *to_shift = scm_port_buffer_take_pointer (read_buf); + scm_port_buffer_reset (read_buf); + memmove (scm_port_buffer_put_pointer (read_buf), to_shift, buffered); + scm_port_buffer_did_put (read_buf, buffered); + } - scm_i_read (port, read_buf); + while (buffered < minimum_size + && !scm_is_true (scm_port_buffer_has_eof_p (read_buf))) + { + size_t count; + size_t buffering = pt->read_buffering; + size_t to_read; + + if (pt->read_buffering < minimum_size) + buffering = minimum_size; + to_read = buffering - buffered; + + count = scm_i_read_bytes (port, scm_port_buffer_bytevector (read_buf), + buffered, to_read); + buffered += count; + scm_port_buffer_did_put (read_buf, count); + scm_port_buffer_set_has_eof_p (read_buf, scm_from_bool (count == 0)); + } return read_buf; } diff --git a/libguile/ports.h b/libguile/ports.h index 2a6e42c8b..189141fe3 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -310,7 +310,7 @@ SCM_API SCM scm_unread_string (SCM str, SCM port); /* Manipulating the buffers. */ SCM_API SCM scm_setvbuf (SCM port, SCM mode, SCM size); -SCM_API SCM scm_fill_input (SCM port); +SCM_API SCM scm_fill_input (SCM port, size_t minimum_size); SCM_INTERNAL size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len); SCM_API SCM scm_drain_input (SCM port); SCM_API void scm_end_input (SCM port); diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 8a7fddd3b..aea1c3aba 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -474,7 +474,7 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0, SCM_VALIDATE_BINARY_INPUT_PORT (1, port); - buf = scm_fill_input (port); + buf = scm_fill_input (port, 0); size = scm_port_buffer_can_take (buf); if (size == 0) { diff --git a/libguile/read.c b/libguile/read.c index 20de0bb9b..cd90b205a 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -2073,7 +2073,7 @@ scm_i_scan_for_encoding (SCM port) if (scm_port_buffer_can_take (buf) == 0) { /* We can use the read buffer, and thus avoid a seek. */ - buf = scm_fill_input (port); + buf = scm_fill_input (port, 0); bytes_read = scm_port_buffer_can_take (buf); if (bytes_read > SCM_ENCODING_SEARCH_SIZE) bytes_read = SCM_ENCODING_SEARCH_SIZE; From 1309ab8093c7aaf4b6e37fc7e38b7a071fd70dd1 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 1 May 2016 16:58:57 +0200 Subject: [PATCH 240/865] Char readers peek into read buffer * libguile/ports.c (scm_i_set_pending_eof): Remove now-unused helper. (peek_utf8_codepoint, peek_latin1_codepoint, peek_iconv_codepoint): (peek_codepoint): Refactor the fundamental character readers in Guile to peek into the read buffer instead of reading then unreading. This will allow Scheme to use the port buffer to convert, when we port this to Scheme. (get_codepoint): Use peek_codepoint. (scm_getc): Adapt. (scm_peek_char): Use peek_codepoint. --- libguile/ports.c | 375 +++++++++++++++++++---------------------------- 1 file changed, 153 insertions(+), 222 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 13e28954a..ccae41dd0 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -372,12 +372,6 @@ scm_set_port_get_natural_buffer_sizes ptob->get_natural_buffer_sizes = get_natural_buffer_sizes; } -static void -scm_i_set_pending_eof (SCM port) -{ - scm_port_buffer_set_has_eof_p (SCM_PTAB_ENTRY (port)->read_buf, SCM_BOOL_T); -} - static void scm_i_clear_pending_eof (SCM port) { @@ -1664,166 +1658,128 @@ utf8_to_codepoint (const scm_t_uint8 *utf8_buf, size_t size) return codepoint; } -/* Read a UTF-8 sequence from PORT. On success, return 0 and set - *CODEPOINT to the codepoint that was read, fill BUF with its UTF-8 - representation, and set *LEN to the length in bytes. Return - `EILSEQ' on error. */ +/* Peek a UTF-8 sequence from PORT. On success, return 0, set + *CODEPOINT to the codepoint that was read, and set *LEN to the length + in bytes. Return `EILSEQ' on error, setting *LEN to the shortest + prefix that cannot begin a valid UTF-8 sequence. */ static int -get_utf8_codepoint (SCM port, scm_t_wchar *codepoint, - scm_t_uint8 buf[SCM_MBCHAR_BUF_SIZE], size_t *len) +peek_utf8_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) { -#define ASSERT_NOT_EOF(b) \ - if (SCM_UNLIKELY ((b) == EOF)) \ - goto invalid_seq -#define CONSUME_PEEKED_BYTE() \ - scm_port_buffer_did_take (pt->read_buf, 1) + int first_byte; - int byte; - scm_t_port *pt; - - *len = 0; - pt = SCM_PTAB_ENTRY (port); - - byte = get_byte_or_eof (port); - if (byte == EOF) + first_byte = peek_byte_or_eof (port); + if (first_byte == EOF) { *codepoint = EOF; return 0; } - - buf[0] = (scm_t_uint8) byte; - *len = 1; - - if (buf[0] <= 0x7f) - /* 1-byte form. */ - *codepoint = buf[0]; - else if (buf[0] >= 0xc2 && buf[0] <= 0xdf) + else if (first_byte < 0x80) { - /* 2-byte form. */ - byte = peek_byte_or_eof (port); - ASSERT_NOT_EOF (byte); - - if (SCM_UNLIKELY ((byte & 0xc0) != 0x80)) - goto invalid_seq; - - CONSUME_PEEKED_BYTE (); - buf[1] = (scm_t_uint8) byte; - *len = 2; - - *codepoint = ((scm_t_wchar) buf[0] & 0x1f) << 6UL - | (buf[1] & 0x3f); + *codepoint = first_byte; + *len = 1; + return 0; } - else if ((buf[0] & 0xf0) == 0xe0) + else if (first_byte >= 0xc2 && first_byte <= 0xdf) { - /* 3-byte form. */ - byte = peek_byte_or_eof (port); - ASSERT_NOT_EOF (byte); + SCM read_buf = scm_fill_input (port, 2); + size_t can_take = scm_port_buffer_can_take (read_buf); + const scm_t_uint8 *ptr = scm_port_buffer_take_pointer (read_buf); - if (SCM_UNLIKELY ((byte & 0xc0) != 0x80 - || (buf[0] == 0xe0 && byte < 0xa0) - || (buf[0] == 0xed && byte > 0x9f))) - goto invalid_seq; + if (can_take < 2 || (ptr[1] & 0xc0) != 0x80) + { + *len = 1; + return EILSEQ; + } - CONSUME_PEEKED_BYTE (); - buf[1] = (scm_t_uint8) byte; + *codepoint = (first_byte & 0x1f) << 6UL | (ptr[1] & 0x3f); *len = 2; - - byte = peek_byte_or_eof (port); - ASSERT_NOT_EOF (byte); - - if (SCM_UNLIKELY ((byte & 0xc0) != 0x80)) - goto invalid_seq; - - CONSUME_PEEKED_BYTE (); - buf[2] = (scm_t_uint8) byte; - *len = 3; - - *codepoint = ((scm_t_wchar) buf[0] & 0x0f) << 12UL - | ((scm_t_wchar) buf[1] & 0x3f) << 6UL - | (buf[2] & 0x3f); + return 0; } - else if (buf[0] >= 0xf0 && buf[0] <= 0xf4) + else if ((first_byte & 0xf0) == 0xe0) { - /* 4-byte form. */ - byte = peek_byte_or_eof (port); - ASSERT_NOT_EOF (byte); + SCM read_buf = scm_fill_input (port, 3); + size_t can_take = scm_port_buffer_can_take (read_buf); + const scm_t_uint8 *ptr = scm_port_buffer_take_pointer (read_buf); - if (SCM_UNLIKELY (((byte & 0xc0) != 0x80) - || (buf[0] == 0xf0 && byte < 0x90) - || (buf[0] == 0xf4 && byte > 0x8f))) - goto invalid_seq; + if (can_take < 2 || (ptr[1] & 0xc0) != 0x80 + || (ptr[0] == 0xe0 && ptr[1] < 0xa0) + || (ptr[0] == 0xed && ptr[1] > 0x9f)) + { + *len = 1; + return EILSEQ; + } - CONSUME_PEEKED_BYTE (); - buf[1] = (scm_t_uint8) byte; - *len = 2; + if (can_take < 3 || (ptr[2] & 0xc0) != 0x80) + { + *len = 2; + return EILSEQ; + } - byte = peek_byte_or_eof (port); - ASSERT_NOT_EOF (byte); - - if (SCM_UNLIKELY ((byte & 0xc0) != 0x80)) - goto invalid_seq; - - CONSUME_PEEKED_BYTE (); - buf[2] = (scm_t_uint8) byte; + *codepoint = ((scm_t_wchar) ptr[0] & 0x0f) << 12UL + | ((scm_t_wchar) ptr[1] & 0x3f) << 6UL + | (ptr[2] & 0x3f); *len = 3; + return 0; + } + else if (first_byte >= 0xf0 && first_byte <= 0xf4) + { + SCM read_buf = scm_fill_input (port, 4); + size_t can_take = scm_port_buffer_can_take (read_buf); + const scm_t_uint8 *ptr = scm_port_buffer_take_pointer (read_buf); - byte = peek_byte_or_eof (port); - ASSERT_NOT_EOF (byte); + if (can_take < 2 || (ptr[1] & 0xc0) != 0x80 + || (ptr[0] == 0xf0 && ptr[1] < 0x90) + || (ptr[0] == 0xf4 && ptr[1] > 0x8f)) + { + *len = 1; + return EILSEQ; + } - if (SCM_UNLIKELY ((byte & 0xc0) != 0x80)) - goto invalid_seq; + if (can_take < 3 || (ptr[2] & 0xc0) != 0x80) + { + *len = 2; + return EILSEQ; + } - CONSUME_PEEKED_BYTE (); - buf[3] = (scm_t_uint8) byte; + if (can_take < 4 || (ptr[3] & 0xc0) != 0x80) + { + *len = 3; + return EILSEQ; + } + + *codepoint = ((scm_t_wchar) ptr[0] & 0x07) << 18UL + | ((scm_t_wchar) ptr[1] & 0x3f) << 12UL + | ((scm_t_wchar) ptr[2] & 0x3f) << 6UL + | (ptr[3] & 0x3f); *len = 4; - - *codepoint = ((scm_t_wchar) buf[0] & 0x07) << 18UL - | ((scm_t_wchar) buf[1] & 0x3f) << 12UL - | ((scm_t_wchar) buf[2] & 0x3f) << 6UL - | (buf[3] & 0x3f); + return 0; } - else - goto invalid_seq; - - return 0; - - invalid_seq: - /* Here we could choose the consume the faulty byte when it's not a - valid starting byte, but it's not a requirement. What Section 3.9 - of Unicode 6.0.0 mandates, though, is to not consume a byte that - would otherwise be a valid starting byte. */ - - return EILSEQ; - -#undef CONSUME_PEEKED_BYTE -#undef ASSERT_NOT_EOF -} - -/* Read an ISO-8859-1 codepoint (a byte) from PORT. On success, return - 0 and set *CODEPOINT to the codepoint that was read, fill BUF with - its UTF-8 representation, and set *LEN to the length in bytes. - Return `EILSEQ' on error. */ -static int -get_latin1_codepoint (SCM port, scm_t_wchar *codepoint, - char buf[SCM_MBCHAR_BUF_SIZE], size_t *len) -{ - *codepoint = get_byte_or_eof (port); - - if (*codepoint == EOF) - *len = 0; else { *len = 1; - buf[0] = *codepoint; + return EILSEQ; } +} + +/* Peek an ISO-8859-1 codepoint (a byte) from PORT. On success, return + 0, set *CODEPOINT to the codepoint that was peeked, and set *LEN to + the length in bytes. No encoding error is possible. */ +static int +peek_latin1_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) +{ + *codepoint = peek_byte_or_eof (port); + if (*codepoint == EOF) + *len = 0; + else + *len = 1; return 0; } -/* Likewise, read a byte sequence from PORT, passing it through its - input conversion descriptor. */ +/* Peek a codepoint from PORT, decoding it through iconv. On success, + return 0, set *CODEPOINT to the codepoint that was peeked, and set + *LEN to the length in bytes. Return `EILSEQ' on decoding error. */ static int -get_iconv_codepoint (SCM port, scm_t_wchar *codepoint, - char buf[SCM_MBCHAR_BUF_SIZE], size_t *len) +peek_iconv_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) { scm_t_iconv_descriptors *id; scm_t_uint8 utf8_buf[SCM_MBCHAR_BUF_SIZE]; @@ -1833,40 +1789,38 @@ get_iconv_codepoint (SCM port, scm_t_wchar *codepoint, for (;;) { - int byte_read; + SCM read_buf; char *input, *output; size_t input_left, output_left, done; - byte_read = get_byte_or_eof (port); - if (SCM_UNLIKELY (byte_read == EOF)) + read_buf = scm_fill_input (port, input_size + 1); + if (scm_port_buffer_can_take (read_buf) <= input_size) { - if (SCM_LIKELY (input_size == 0)) + if (input_size == 0) + /* Normal EOF. */ { *codepoint = (scm_t_wchar) EOF; - *len = input_size; + *len = 0; return 0; } else - { - /* EOF found in the middle of a multibyte character. */ - scm_i_set_pending_eof (port); - return EILSEQ; - } + /* EOF found in the middle of a multibyte character. */ + return EILSEQ; } - buf[input_size++] = byte_read; - - input = buf; + input_size++; + input = (char *) scm_port_buffer_take_pointer (read_buf); input_left = input_size; output = (char *) utf8_buf; output_left = sizeof (utf8_buf); + /* FIXME: locking! */ done = iconv (id->input_cd, &input, &input_left, &output, &output_left); if (done == (size_t) -1) { int err = errno; - if (SCM_LIKELY (err == EINVAL)) + if (err == EINVAL) /* The input byte sequence did not form a complete character. Read another byte and try again. */ continue; @@ -1876,47 +1830,38 @@ get_iconv_codepoint (SCM port, scm_t_wchar *codepoint, else { size_t output_size = sizeof (utf8_buf) - output_left; - if (SCM_LIKELY (output_size > 0)) - { - /* iconv generated output. Convert the UTF8_BUF sequence - to a Unicode code point. */ - *codepoint = utf8_to_codepoint (utf8_buf, output_size); - *len = input_size; - return 0; - } - else - { - /* iconv consumed some bytes without producing any output. - Most likely this means that a Unicode byte-order mark - (BOM) was consumed, which should not be included in the - returned buf. Shift any remaining bytes to the beginning - of buf, and continue the loop. */ - memmove (buf, input, input_left); - input_size = input_left; - continue; - } + if (output_size == 0) + /* iconv consumed some bytes without producing any output. + Most likely this means that a Unicode byte-order mark + (BOM) was consumed. In any case, keep going until we get + output. */ + continue; + + /* iconv generated output. Convert the UTF8_BUF sequence + to a Unicode code point. */ + *codepoint = utf8_to_codepoint (utf8_buf, output_size); + *len = input_size; + return 0; } } } -/* Read a codepoint from PORT and return it in *CODEPOINT. Fill BUF - with the byte representation of the codepoint in PORT's encoding, and - set *LEN to the length in bytes of that representation. Return 0 on - success and an errno value on error. */ +/* Peek a codepoint from PORT and return it in *CODEPOINT. Set *LEN to + the length in bytes of that representation. Return 0 on success and + an errno value on error. */ static SCM_C_INLINE int -get_codepoint (SCM port, scm_t_wchar *codepoint, - char buf[SCM_MBCHAR_BUF_SIZE], size_t *len) +peek_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) { int err; scm_t_port *pt = SCM_PTAB_ENTRY (port); scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8) - err = get_utf8_codepoint (port, codepoint, (scm_t_uint8 *) buf, len); + err = peek_utf8_codepoint (port, codepoint, len); else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1) - err = get_latin1_codepoint (port, codepoint, buf, len); + err = peek_latin1_codepoint (port, codepoint, len); else - err = get_iconv_codepoint (port, codepoint, buf, len); + err = peek_iconv_codepoint (port, codepoint, len); if (SCM_LIKELY (err == 0)) { @@ -1934,31 +1879,50 @@ get_codepoint (SCM port, scm_t_wchar *codepoint, && (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8 || strcmp (pt->encoding, "UTF-16") == 0 || strcmp (pt->encoding, "UTF-32") == 0))) - return get_codepoint (port, codepoint, buf, len); + { + scm_port_buffer_did_take (pt->read_buf, *len); + return peek_codepoint (port, codepoint, len); + } } - update_port_lf (*codepoint, port); } else if (pt->ilseq_handler == SCM_ICONVEH_QUESTION_MARK) { *codepoint = '?'; err = 0; - update_port_lf (*codepoint, port); } return err; } +static SCM_C_INLINE int +get_codepoint (SCM port, scm_t_wchar *codepoint) +{ + int err; + size_t len = 0; + scm_t_port *pt = SCM_PTAB_ENTRY (port); + + err = peek_codepoint (port, codepoint, &len); + scm_port_buffer_did_take (pt->read_buf, len); + if (err != 0 && pt->ilseq_handler == SCM_ICONVEH_QUESTION_MARK) + { + *codepoint = '?'; + err = 0; + } + if (*codepoint == EOF) + scm_i_clear_pending_eof (port); + update_port_lf (*codepoint, port); + return err; +} + /* Read a codepoint from PORT and return it. */ scm_t_wchar scm_getc (SCM port) #define FUNC_NAME "scm_getc" { int err; - size_t len; scm_t_wchar codepoint; - char buf[SCM_MBCHAR_BUF_SIZE]; - err = get_codepoint (port, &codepoint, buf, &len); + err = get_codepoint (port, &codepoint); if (SCM_UNLIKELY (err != 0)) /* At this point PORT should point past the invalid encoding, as per R6RS-lib Section 8.2.4. */ @@ -2141,55 +2105,22 @@ SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0, "sequence when the error is raised.\n") #define FUNC_NAME s_scm_peek_char { - int first_byte, err; - SCM result; + int err; scm_t_wchar c; - char bytes[SCM_MBCHAR_BUF_SIZE]; - long column, line; size_t len = 0; - scm_t_port_internal *pti; if (SCM_UNBNDP (port)) port = scm_current_input_port (); SCM_VALIDATE_OPINPORT (1, port); - pti = SCM_PORT_GET_INTERNAL (port); - /* First, a couple fast paths. */ - first_byte = peek_byte_or_eof (port); - if (first_byte == EOF) - return SCM_EOF_VAL; - if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1) - return SCM_MAKE_CHAR (first_byte); - if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8 && first_byte < 0x80) - return SCM_MAKE_CHAR (first_byte); + err = peek_codepoint (port, &c, &len); - /* Now the slow paths. */ - column = SCM_COL (port); - line = SCM_LINUM (port); + if (err == 0) + return c == EOF ? SCM_EOF_VAL : SCM_MAKE_CHAR (c); - err = get_codepoint (port, &c, bytes, &len); - - scm_unget_bytes ((unsigned char *) bytes, len, port); - - SCM_COL (port) = column; - SCM_LINUM (port) = line; - - if (SCM_UNLIKELY (err != 0)) - { - scm_decoding_error (FUNC_NAME, err, "input decoding error", port); - - /* Shouldn't happen since `catch' always aborts to prompt. */ - result = SCM_BOOL_F; - } - else if (c == EOF) - { - scm_i_set_pending_eof (port); - result = SCM_EOF_VAL; - } - else - result = SCM_MAKE_CHAR (c); - - return result; + scm_decoding_error (FUNC_NAME, err, "input decoding error", port); + /* Not reached. */ + return SCM_BOOL_F; } #undef FUNC_NAME From 4ba59e94f988602cc07ab79b1e617194dd4d03b0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 1 May 2016 21:55:09 +0200 Subject: [PATCH 241/865] Changes to Scheme fill-input corresponding to C * module/ice-9/ports.scm (fill-input): Rewrite to make changes like the ones made to the C scm_fill_input: allow callers to specify a minimum amount of buffering. --- module/ice-9/ports.scm | 52 +++++++++++++++++++++++++++--------------- 1 file changed, 33 insertions(+), 19 deletions(-) diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 8051549eb..2bc12c5c3 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -196,31 +196,45 @@ (error "bad return from port read function" read)) read)) -(define (fill-input port) - (let ((buf (port-read-buffer port))) +(define* (fill-input port #:optional (minimum-buffering 1)) + (let* ((buf (port-read-buffer port)) + (cur (port-buffer-cur buf)) + (buffered (- (port-buffer-end buf) cur))) (cond - ((or (< (port-buffer-cur buf) (port-buffer-end buf)) - (port-buffer-has-eof? buf)) - buf) + ((or (<= minimum-buffering buffered) (port-buffer-has-eof? buf)) + (values buf buffered)) (else (unless (input-port? port) (error "not an input port" port)) (when (port-random-access? port) (flush-output port)) - (let* ((read-buffering (port-read-buffering port)) - (buf (if (= (bytevector-length (port-buffer-bytevector buf)) - read-buffering) - buf - (let ((buf (make-port-buffer read-buffering))) - (set-port-read-buffer! port buf) - buf))) - (bv (port-buffer-bytevector buf)) - (start (port-buffer-end buf)) - (count (- (bytevector-length bv) start)) - (read (read-bytes port bv start count))) - (set-port-buffer-end! buf (+ start read)) - (set-port-buffer-has-eof?! buf (zero? count)) - buf))))) + (let ((bv (port-buffer-bytevector buf))) + (cond + ((< (bytevector-length bv) minimum-buffering) + (let ((buf* (make-port-buffer minimum-buffering))) + (bytevector-copy! bv cur (port-buffer-bytevector buf*) 0 buffered) + (set-port-buffer-end! buf* buffered) + (set-port-read-buffer! port buf*) + (fill-input port minimum-buffering))) + (else + (when (< 0 cur) + (bytevector-copy! bv cur bv 0 buffered) + (set-port-buffer-cur! buf 0) + (set-port-buffer-end! buf buffered)) + (let ((buffering (max (port-read-buffering port) minimum-buffering))) + (let lp ((buffered buffered)) + (let* ((count (- buffering buffered)) + (read (read-bytes port bv buffered count))) + (cond + ((zero? read) + (set-port-buffer-has-eof?! buf #t) + (values buf buffered)) + (else + (let ((buffered (+ buffered read))) + (set-port-buffer-end! buf buffered) + (if (< buffered minimum-buffering) + (lp buffered) + (values buf buffered))))))))))))))) (define (peek-byte port) (let* ((buf (port-read-buffer port)) From 422f65fe09e93bff383cc3e818204902ed0d32d2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 1 May 2016 22:00:37 +0200 Subject: [PATCH 242/865] Minor tweak to Scheme peek-byte. * module/ice-9/ports.scm (peek-byte): Use second return from fill-input. --- module/ice-9/ports.scm | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 2bc12c5c3..db1c6f7fe 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -241,11 +241,12 @@ (cur (port-buffer-cur buf))) (if (< cur (port-buffer-end buf)) (bytevector-u8-ref (port-buffer-bytevector buf) cur) - (let* ((buf (fill-input port)) - (cur (port-buffer-cur buf))) - (if (< cur (port-buffer-end buf)) - (bytevector-u8-ref (port-buffer-bytevector buf) cur) - the-eof-object))))) + (call-with-values (lambda () (fill-input port)) + (lambda (buf buffered) + (if (zero? buffered) + the-eof-object + (bytevector-u8-ref (port-buffer-bytevector buf) + (port-buffer-cur buf)))))))) From d8711b97596fc52bad1d3139f5be4c8442e1b896 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 3 May 2016 10:52:54 +0200 Subject: [PATCH 243/865] Port encoding internally represented as symbol * libguile/ports-internal.h (scm_t_port_internal): Remove encoding_mode member. * libguile/ports.h (scm_t_port): "encoding" member is now a SCM symbol. * libguile/ports.c (scm_init_ports): Define symbols for the encodings that we handle explicitly. (encoding_matches): Adapt to check against an encoding as a symbol. (canonicalize_encoding): Return an encoding as a symbol. (scm_c_make_port_with_encoding, scm_i_set_default_port_encoding) (decide_utf16_encoding, decide_utf32_encoding) (scm_i_port_iconv_descriptors, scm_i_set_port_encoding_x) (scm_port_encoding, peek_codepoint, scm_ungetc): Adapt to encoding change. * libguile/print.c (display_string_using_iconv, display_string): * libguile/read.c (scm_read_character): * libguile/strings.c (scm_from_port_stringn, scm_to_port_stringn): Adapt to port encoding change. --- libguile/ports-internal.h | 1 - libguile/ports.c | 119 +++++++++++++++++--------------------- libguile/ports.h | 2 +- libguile/print.c | 17 ++++-- libguile/read.c | 7 ++- libguile/strings.c | 18 +++--- 6 files changed, 80 insertions(+), 84 deletions(-) diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index 5eeefb9b7..526337d01 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -221,7 +221,6 @@ struct scm_port_internal { unsigned at_stream_start_for_bom_read : 1; unsigned at_stream_start_for_bom_write : 1; - scm_t_port_encoding_mode encoding_mode; scm_t_iconv_descriptors *iconv_descriptors; SCM alist; }; diff --git a/libguile/ports.c b/libguile/ports.c index ccae41dd0..f6c9dc046 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -91,6 +91,18 @@ #endif + +/* We need these symbols early, before (ice-9 ports) loads in the + snarfed definitions, so we can't use SCM_SYMBOL. */ +static SCM sym_UTF_8; +static SCM sym_ISO_8859_1; +static SCM sym_UTF_16; +static SCM sym_UTF_16LE; +static SCM sym_UTF_16BE; +static SCM sym_UTF_32; +static SCM sym_UTF_32LE; +static SCM sym_UTF_32BE; + /* Port encodings are case-insensitive ASCII strings. */ static char ascii_toupper (char c) @@ -103,8 +115,10 @@ ascii_toupper (char c) on ports or in the default encoding fluid are in upper-case, and can be compared with strcmp. */ static int -encoding_matches (const char *enc, const char *upper) +encoding_matches (const char *enc, SCM upper_symbol) { + const char *upper = scm_i_symbol_chars (upper_symbol); + if (!enc) enc = "ISO-8859-1"; @@ -115,14 +129,16 @@ encoding_matches (const char *enc, const char *upper) return !*upper; } -static char* +static SCM canonicalize_encoding (const char *enc) { char *ret; int i; - if (!enc) - return "ISO-8859-1"; + if (!enc || encoding_matches (enc, sym_ISO_8859_1)) + return sym_ISO_8859_1; + if (encoding_matches (enc, sym_UTF_8)) + return sym_UTF_8; ret = scm_gc_strdup (enc, "port"); @@ -136,7 +152,7 @@ canonicalize_encoding (const char *enc) ret[i] = ascii_toupper (ret[i]); } - return ret; + return scm_from_latin1_symbol (ret); } @@ -758,22 +774,7 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits, entry->rw_random = ptob->seek != NULL; entry->port = ret; entry->stream = stream; - - if (encoding_matches (encoding, "UTF-8")) - { - pti->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8; - entry->encoding = "UTF-8"; - } - else if (encoding_matches (encoding, "ISO-8859-1")) - { - pti->encoding_mode = SCM_PORT_ENCODING_MODE_LATIN1; - entry->encoding = "ISO-8859-1"; - } - else - { - pti->encoding_mode = SCM_PORT_ENCODING_MODE_ICONV; - entry->encoding = canonicalize_encoding (encoding); - } + entry->encoding = canonicalize_encoding (encoding); entry->ilseq_handler = handler; pti->iconv_descriptors = NULL; @@ -970,11 +971,11 @@ static SCM default_port_encoding_var; void scm_i_set_default_port_encoding (const char *encoding) { - if (encoding_matches (encoding, "ISO-8859-1")) + if (encoding_matches (encoding, sym_ISO_8859_1)) scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var), SCM_BOOL_F); else scm_fluid_set_x (SCM_VARIABLE_REF (default_port_encoding_var), - scm_from_latin1_string (canonicalize_encoding (encoding))); + scm_symbol_to_string (canonicalize_encoding (encoding))); } /* Return the name of the default encoding for newly created ports. */ @@ -1079,29 +1080,29 @@ static const unsigned char scm_utf32le_bom[4] = {0xFF, 0xFE, 0x00, 0x00}; to determine the byte order. Otherwise we choose big endian, as recommended by the Unicode Standard. Note that the BOM (if any) is not consumed here. */ -static const char * +static SCM decide_utf16_encoding (SCM port, scm_t_port_rw_active mode) { if (mode == SCM_PORT_READ && SCM_PORT_GET_INTERNAL (port)->at_stream_start_for_bom_read && looking_at_bytes (port, scm_utf16le_bom, sizeof scm_utf16le_bom)) - return "UTF-16LE"; + return sym_UTF_16LE; else - return "UTF-16BE"; + return sym_UTF_16BE; } /* Decide what byte order to use for a UTF-32 port. Return "UTF-32BE" or "UTF-32LE". See the comment above 'decide_utf16_encoding' for details. */ -static const char * +static SCM decide_utf32_encoding (SCM port, scm_t_port_rw_active mode) { if (mode == SCM_PORT_READ && SCM_PORT_GET_INTERNAL (port)->at_stream_start_for_bom_read && looking_at_bytes (port, scm_utf32le_bom, sizeof scm_utf32le_bom)) - return "UTF-32LE"; + return sym_UTF_32LE; else - return "UTF-32BE"; + return sym_UTF_32BE; } static void @@ -1189,29 +1190,24 @@ close_iconv_descriptors (scm_t_iconv_descriptors *id) scm_t_iconv_descriptors * scm_i_port_iconv_descriptors (SCM port, scm_t_port_rw_active mode) { + scm_t_port *pt = SCM_PTAB_ENTRY (port); scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); - assert (pti->encoding_mode == SCM_PORT_ENCODING_MODE_ICONV); - if (!pti->iconv_descriptors) { - scm_t_port *pt = SCM_PTAB_ENTRY (port); - const char *precise_encoding; - - if (!pt->encoding) - pt->encoding = "ISO-8859-1"; + SCM precise_encoding; /* If the specified encoding is UTF-16 or UTF-32, then make that more precise by deciding what byte order to use. */ - if (strcmp (pt->encoding, "UTF-16") == 0) + if (scm_is_eq (pt->encoding, sym_UTF_16)) precise_encoding = decide_utf16_encoding (port, mode); - else if (strcmp (pt->encoding, "UTF-32") == 0) + else if (scm_is_eq (pt->encoding, sym_UTF_32)) precise_encoding = decide_utf32_encoding (port, mode); else precise_encoding = pt->encoding; pti->iconv_descriptors = - open_iconv_descriptors (precise_encoding, + open_iconv_descriptors (scm_i_symbol_chars (precise_encoding), SCM_INPUT_PORT_P (port), SCM_OUTPUT_PORT_P (port)); } @@ -1239,22 +1235,7 @@ scm_i_set_port_encoding_x (SCM port, const char *encoding) position. */ pti->at_stream_start_for_bom_read = 1; pti->at_stream_start_for_bom_write = 1; - - if (encoding_matches (encoding, "UTF-8")) - { - pt->encoding = "UTF-8"; - pti->encoding_mode = SCM_PORT_ENCODING_MODE_UTF8; - } - else if (encoding_matches (encoding, "ISO-8859-1")) - { - pt->encoding = "ISO-8859-1"; - pti->encoding_mode = SCM_PORT_ENCODING_MODE_LATIN1; - } - else - { - pt->encoding = canonicalize_encoding (encoding); - pti->encoding_mode = SCM_PORT_ENCODING_MODE_ICONV; - } + pt->encoding = canonicalize_encoding (encoding); pti->iconv_descriptors = NULL; if (prev) @@ -1269,7 +1250,7 @@ SCM_DEFINE (scm_port_encoding, "port-encoding", 1, 0, 0, { SCM_VALIDATE_PORT (1, port); - return scm_from_latin1_string (SCM_PTAB_ENTRY (port)->encoding); + return scm_symbol_to_string (SCM_PTAB_ENTRY (port)->encoding); } #undef FUNC_NAME @@ -1856,9 +1837,9 @@ peek_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) scm_t_port *pt = SCM_PTAB_ENTRY (port); scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); - if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8) + if (scm_is_eq (pt->encoding, sym_UTF_8)) err = peek_utf8_codepoint (port, codepoint, len); - else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1) + else if (scm_is_eq (pt->encoding, sym_ISO_8859_1)) err = peek_latin1_codepoint (port, codepoint, len); else err = peek_iconv_codepoint (port, codepoint, len); @@ -1876,9 +1857,9 @@ peek_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) then silently consume it and read another code point. */ if (SCM_UNLIKELY (*codepoint == SCM_UNICODE_BOM - && (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8 - || strcmp (pt->encoding, "UTF-16") == 0 - || strcmp (pt->encoding, "UTF-32") == 0))) + && (scm_is_eq (pt->encoding, sym_UTF_8) + || scm_is_eq (pt->encoding, sym_UTF_16) + || scm_is_eq (pt->encoding, sym_UTF_32)))) { scm_port_buffer_did_take (pt->read_buf, *len); return peek_codepoint (port, codepoint, len); @@ -2022,14 +2003,13 @@ scm_ungetc (scm_t_wchar c, SCM port) #define FUNC_NAME "scm_ungetc" { scm_t_port *pt = SCM_PTAB_ENTRY (port); - scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); char *result; char result_buf[10]; size_t len; len = sizeof (result_buf); - if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8) + if (scm_is_eq (pt->encoding, sym_UTF_8)) { if (c < 0x80) { @@ -2041,14 +2021,14 @@ scm_ungetc (scm_t_wchar c, SCM port) result = (char *) u32_to_u8 ((uint32_t *) &c, 1, (uint8_t *) result_buf, &len); } - else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1 && c <= 0xff) + else if (scm_is_eq (pt->encoding, sym_ISO_8859_1) && c <= 0xff) { result_buf[0] = (char) c; result = result_buf; len = 1; } else - result = u32_conv_to_encoding (pt->encoding, + result = u32_conv_to_encoding (scm_i_symbol_chars (pt->encoding), (enum iconv_ilseq_handler) pt->ilseq_handler, (uint32_t *) &c, 1, NULL, result_buf, &len); @@ -3163,6 +3143,15 @@ scm_init_ice_9_ports (void) void scm_init_ports (void) { + sym_UTF_8 = scm_from_latin1_symbol ("UTF-8"); + sym_ISO_8859_1 = scm_from_latin1_symbol ("ISO-8859-1"); + sym_UTF_16 = scm_from_latin1_symbol ("UTF-16"); + sym_UTF_16LE = scm_from_latin1_symbol ("UTF-16LE"); + sym_UTF_16BE = scm_from_latin1_symbol ("UTF-16BE"); + sym_UTF_32 = scm_from_latin1_symbol ("UTF-32"); + sym_UTF_32LE = scm_from_latin1_symbol ("UTF-32LE"); + sym_UTF_32BE = scm_from_latin1_symbol ("UTF-32BE"); + trampoline_to_c_read_subr = scm_c_make_gsubr ("port-read", 4, 0, 0, (scm_t_subr) trampoline_to_c_read); diff --git a/libguile/ports.h b/libguile/ports.h index 189141fe3..6cf19d991 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -114,7 +114,7 @@ typedef struct int rw_random; /* Character encoding support. */ - char *encoding; + SCM encoding; /* A symbol of upper-case ASCII. */ scm_t_string_failed_conversion_handler ilseq_handler; } scm_t_port; diff --git a/libguile/print.c b/libguile/print.c index ff0dab3ec..4eea12152 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -64,6 +64,11 @@ #define PORT_CONVERSION_HANDLER(port) \ SCM_PTAB_ENTRY (port)->ilseq_handler +SCM_SYMBOL (sym_UTF_8, "UTF-8"); +SCM_SYMBOL (sym_ISO_8859_1, "ISO-8859-1"); +SCM_SYMBOL (sym_UTF_16, "UTF-16"); +SCM_SYMBOL (sym_UTF_32, "UTF-32"); + static size_t display_string (const void *, int, size_t, SCM, scm_t_string_failed_conversion_handler); @@ -1036,8 +1041,8 @@ display_string_using_iconv (const void *str, int narrow_p, size_t len, pti->at_stream_start_for_bom_read = 0; /* Write a BOM if appropriate. */ - if (SCM_UNLIKELY (strcmp(pt->encoding, "UTF-16") == 0 - || strcmp(pt->encoding, "UTF-32") == 0)) + if (SCM_UNLIKELY (scm_is_eq (pt->encoding, sym_UTF_16) + || scm_is_eq (pt->encoding, sym_UTF_32))) display_character (SCM_UNICODE_BOM, port, iconveh_error); } @@ -1135,13 +1140,13 @@ display_string (const void *str, int narrow_p, size_t len, SCM port, scm_t_string_failed_conversion_handler strategy) { - scm_t_port_internal *pti; + scm_t_port *pt; - pti = SCM_PORT_GET_INTERNAL (port); + pt = SCM_PTAB_ENTRY (port); - if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8) + if (scm_is_eq (pt->encoding, sym_UTF_8)) return display_string_as_utf8 (str, narrow_p, len, port); - else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1) + else if (scm_is_eq (pt->encoding, sym_ISO_8859_1)) return display_string_as_latin1 (str, narrow_p, len, port, strategy); else return display_string_using_iconv (str, narrow_p, len, port, strategy); diff --git a/libguile/read.c b/libguile/read.c index cd90b205a..a4183d9a6 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -64,6 +64,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_dot, "."); SCM_SYMBOL (scm_keyword_prefix, "prefix"); SCM_SYMBOL (scm_keyword_postfix, "postfix"); SCM_SYMBOL (sym_nil, "nil"); +SCM_SYMBOL (sym_ISO_8859_1, "ISO-8859-1"); /* SRFI-105 curly infix expression support */ SCM_SYMBOL (sym_nfx, "$nfx$"); @@ -1040,7 +1041,7 @@ scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) size_t charname_len, bytes_read; scm_t_wchar cp; int overflow; - scm_t_port_internal *pti; + scm_t_port *pt; overflow = read_token (port, opts, buffer, READER_CHAR_NAME_MAX_SIZE, &bytes_read); @@ -1058,14 +1059,14 @@ scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) return (SCM_MAKE_CHAR (chr)); } - pti = SCM_PORT_GET_INTERNAL (port); + pt = SCM_PTAB_ENTRY (port); /* Simple ASCII characters can be processed immediately. Also, simple ISO-8859-1 characters can be processed immediately if the encoding for this port is ISO-8859-1. */ if (bytes_read == 1 && ((unsigned char) buffer[0] <= 127 - || pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1)) + || scm_is_eq (pt->encoding, sym_ISO_8859_1))) { SCM_COL (port) += 1; return SCM_MAKE_CHAR (buffer[0]); diff --git a/libguile/strings.c b/libguile/strings.c index ee43e815e..3a02c5889 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -51,6 +51,8 @@ /* {Strings} */ +SCM_SYMBOL (sym_UTF_8, "UTF-8"); +SCM_SYMBOL (sym_ISO_8859_1, "ISO-8859-1"); /* Stringbufs * @@ -1758,16 +1760,16 @@ SCM scm_from_port_stringn (const char *str, size_t len, SCM port) { scm_t_port *pt = SCM_PTAB_ENTRY (port); - scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); - if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1) + if (scm_is_eq (pt->encoding, sym_ISO_8859_1)) return scm_from_latin1_stringn (str, len); - else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8 + else if (scm_is_eq (pt->encoding, sym_UTF_8) && (pt->ilseq_handler == SCM_FAILED_CONVERSION_ERROR || (u8_check ((uint8_t *) str, len) == NULL))) return scm_from_utf8_stringn (str, len); else - return scm_from_stringn (str, len, pt->encoding, pt->ilseq_handler); + return scm_from_stringn (str, len, scm_i_symbol_chars (pt->encoding), + pt->ilseq_handler); } /* Create a new scheme string from the C string STR. The memory of @@ -2165,15 +2167,15 @@ char * scm_to_port_stringn (SCM str, size_t *lenp, SCM port) { scm_t_port *pt = SCM_PTAB_ENTRY (port); - scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); - if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_LATIN1 + if (scm_is_eq (pt->encoding, sym_ISO_8859_1) && pt->ilseq_handler == SCM_FAILED_CONVERSION_ERROR) return scm_to_latin1_stringn (str, lenp); - else if (pti->encoding_mode == SCM_PORT_ENCODING_MODE_UTF8) + else if (scm_is_eq (pt->encoding, sym_UTF_8)) return scm_to_utf8_stringn (str, lenp); else - return scm_to_stringn (str, lenp, pt->encoding, pt->ilseq_handler); + return scm_to_stringn (str, lenp, scm_i_symbol_chars (pt->encoding), + pt->ilseq_handler); } /* Return a malloc(3)-allocated buffer containing the contents of STR encoded From 383df7976f04c45b4f67d9138f238a2d02483e9a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 4 May 2016 10:31:21 +0200 Subject: [PATCH 244/865] Port conversion strategies internally are symbols * libguile/ports.h (scm_t_port): Represent the conversion strategy as a symbol, to make things easier for Scheme. Rename to "conversion_strategy". (scm_c_make_port_with_encoding): Change to take encoding and conversion_strategy arguments as symbols. (scm_i_string_failed_conversion_handler): New internal helper, to turn a symbol to a scm_t_string_failed_conversion_handler. (scm_i_default_port_encoding): Return the default port encoding as a symbol. (scm_i_default_port_conversion_strategy) (scm_i_set_default_port_conversion_strategy): Rename from scm_i_default_port_conversion_handler et al. Take and return Scheme symbols. * libguile/foreign.c (scm_string_to_pointer, scm_pointer_to_string): Use scm_i_default_string_failed_conversion_handler instead of scm_i_default_port_conversion_handler. * libguile/print.c (PORT_CONVERSION_HANDLER): Update definition. (print_normal_symbol): Use PORT_CONVERSION_HANDLER. * libguile/r6rs-ports.c (make_bytevector_input_port): (make_custom_binary_input_port, make_bytevector_output_port): Adapt to changes in scm_c_make_port_with_encoding. * libguile/strings.h: * libguile/strings.c (scm_i_default_string_failed_conversion_handler): New helper. (scm_from_locale_stringn, scm_from_port_stringn): (scm_to_locale_stringn, scm_to_port_stringn): Adapt to interface changes. * libguile/strports.c (scm_mkstrport): Adapt to scm_c_make_port_with_encoding change. * libguile/ports.c (scm_c_make_port): Adapt to scm_c_make_port_with_encoding change. (ascii_toupper, encoding_matches, canonicalize_encoding): Move down in the file. (peek_codepoint, get_codepoint, scm_ungetc): Adapt to port conversion strategy change. Remove duplicate case in get_codepoint. (scm_init_ports): Move symbol initializations to the same place. --- libguile/foreign.c | 4 +- libguile/ports.c | 250 +++++++++++++++++++----------------------- libguile/ports.h | 23 ++-- libguile/print.c | 4 +- libguile/r6rs-ports.c | 21 ++-- libguile/strings.c | 22 +++- libguile/strings.h | 3 + libguile/strports.c | 10 +- 8 files changed, 162 insertions(+), 175 deletions(-) diff --git a/libguile/foreign.c b/libguile/foreign.c index e6ba5331c..936f3419c 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -370,7 +370,7 @@ SCM_DEFINE (scm_string_to_pointer, "string->pointer", 1, 1, 0, ret = scm_from_pointer (scm_to_stringn (string, NULL, enc, - scm_i_default_port_conversion_handler ()), + scm_i_default_string_failed_conversion_handler ()), free); scm_dynwind_end (); @@ -415,7 +415,7 @@ SCM_DEFINE (scm_pointer_to_string, "pointer->string", 1, 2, 0, scm_dynwind_free (enc); ret = scm_from_stringn (SCM_POINTER_VALUE (pointer), len, enc, - scm_i_default_port_conversion_handler ()); + scm_i_default_string_failed_conversion_handler ()); scm_dynwind_end (); diff --git a/libguile/ports.c b/libguile/ports.c index f6c9dc046..a35a3a122 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -103,57 +103,10 @@ static SCM sym_UTF_32; static SCM sym_UTF_32LE; static SCM sym_UTF_32BE; -/* Port encodings are case-insensitive ASCII strings. */ -static char -ascii_toupper (char c) -{ - return (c < 'a' || c > 'z') ? c : ('A' + (c - 'a')); -} - -/* It is only necessary to use this function on encodings that come from - the user and have not been canonicalized yet. Encodings that are set - on ports or in the default encoding fluid are in upper-case, and can - be compared with strcmp. */ -static int -encoding_matches (const char *enc, SCM upper_symbol) -{ - const char *upper = scm_i_symbol_chars (upper_symbol); - - if (!enc) - enc = "ISO-8859-1"; - - while (*enc) - if (ascii_toupper (*enc++) != *upper++) - return 0; - - return !*upper; -} - -static SCM -canonicalize_encoding (const char *enc) -{ - char *ret; - int i; - - if (!enc || encoding_matches (enc, sym_ISO_8859_1)) - return sym_ISO_8859_1; - if (encoding_matches (enc, sym_UTF_8)) - return sym_UTF_8; - - ret = scm_gc_strdup (enc, "port"); - - for (i = 0; ret[i]; i++) - { - if (ret[i] > 127) - /* Restrict to ASCII. */ - scm_misc_error (NULL, "invalid character encoding ~s", - scm_list_1 (scm_from_latin1_string (enc))); - else - ret[i] = ascii_toupper (ret[i]); - } - - return scm_from_latin1_symbol (ret); -} +/* Port conversion strategies. */ +static SCM sym_error; +static SCM sym_substitute; +static SCM sym_escape; @@ -750,8 +703,7 @@ initialize_port_buffers (SCM port) SCM scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits, - const char *encoding, - scm_t_string_failed_conversion_handler handler, + SCM encoding, SCM conversion_strategy, scm_t_bits stream) { SCM ret; @@ -774,9 +726,8 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits, entry->rw_random = ptob->seek != NULL; entry->port = ret; entry->stream = stream; - entry->encoding = canonicalize_encoding (encoding); - - entry->ilseq_handler = handler; + entry->encoding = encoding; + entry->conversion_strategy = conversion_strategy; pti->iconv_descriptors = NULL; pti->at_stream_start_for_bom_read = 1; @@ -800,7 +751,7 @@ scm_c_make_port (scm_t_bits tag, unsigned long mode_bits, scm_t_bits stream) { return scm_c_make_port_with_encoding (tag, mode_bits, scm_i_default_port_encoding (), - scm_i_default_port_conversion_handler (), + scm_i_default_port_conversion_strategy (), stream); } @@ -962,6 +913,58 @@ SCM_DEFINE (scm_close_output_port, "close-output-port", 1, 0, 0, /* Encoding characters to byte streams, and decoding byte streams to characters. */ +/* Port encodings are case-insensitive ASCII strings. */ +static char +ascii_toupper (char c) +{ + return (c < 'a' || c > 'z') ? c : ('A' + (c - 'a')); +} + +/* It is only necessary to use this function on encodings that come from + the user and have not been canonicalized yet. Encodings that are set + on ports or in the default encoding fluid are in upper-case, and can + be compared with strcmp. */ +static int +encoding_matches (const char *enc, SCM upper_symbol) +{ + const char *upper = scm_i_symbol_chars (upper_symbol); + + if (!enc) + enc = "ISO-8859-1"; + + while (*enc) + if (ascii_toupper (*enc++) != *upper++) + return 0; + + return !*upper; +} + +static SCM +canonicalize_encoding (const char *enc) +{ + char *ret; + int i; + + if (!enc || encoding_matches (enc, sym_ISO_8859_1)) + return sym_ISO_8859_1; + if (encoding_matches (enc, sym_UTF_8)) + return sym_UTF_8; + + ret = scm_gc_strdup (enc, "port"); + + for (i = 0; ret[i]; i++) + { + if (ret[i] > 127) + /* Restrict to ASCII. */ + scm_misc_error (NULL, "invalid character encoding ~s", + scm_list_1 (scm_from_latin1_string (enc))); + else + ret[i] = ascii_toupper (ret[i]); + } + + return scm_from_latin1_symbol (ret); +} + /* A fluid specifying the default encoding for newly created ports. If it is a string, that is the encoding. If it is #f, it is in the "native" (Latin-1) encoding. */ @@ -979,73 +982,50 @@ scm_i_set_default_port_encoding (const char *encoding) } /* Return the name of the default encoding for newly created ports. */ -const char * +SCM scm_i_default_port_encoding (void) { SCM encoding; encoding = scm_fluid_ref (SCM_VARIABLE_REF (default_port_encoding_var)); if (!scm_is_string (encoding)) - return "ISO-8859-1"; + return sym_ISO_8859_1; else - return scm_i_string_chars (encoding); + return canonicalize_encoding (scm_i_string_chars (encoding)); } /* A fluid specifying the default conversion handler for newly created ports. Its value should be one of the symbols below. */ static SCM default_conversion_strategy_var; -/* The possible conversion strategies. */ -static SCM sym_error; -static SCM sym_substitute; -static SCM sym_escape; - /* Return the default failed encoding conversion policy for new created ports. */ -scm_t_string_failed_conversion_handler -scm_i_default_port_conversion_handler (void) +SCM +scm_i_default_port_conversion_strategy (void) { SCM value; value = scm_fluid_ref (SCM_VARIABLE_REF (default_conversion_strategy_var)); - if (scm_is_eq (sym_substitute, value)) - return SCM_FAILED_CONVERSION_QUESTION_MARK; - else if (scm_is_eq (sym_escape, value)) - return SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE; - else - /* Default to 'error also when the fluid's value is not one of - the valid symbols. */ - return SCM_FAILED_CONVERSION_ERROR; + if (scm_is_eq (sym_substitute, value) || scm_is_eq (sym_escape, value)) + return value; + + /* Default to 'error also when the fluid's value is not one of the + valid symbols. */ + return sym_error; } /* Use HANDLER as the default conversion strategy for future ports. */ void -scm_i_set_default_port_conversion_handler (scm_t_string_failed_conversion_handler - handler) +scm_i_set_default_port_conversion_strategy (SCM sym) { - SCM strategy; + if (!scm_is_eq (sym, sym_error) + && !scm_is_eq (sym, sym_substitute) + && !scm_is_eq (sym, sym_escape)) + /* Internal error. */ + abort (); - switch (handler) - { - case SCM_FAILED_CONVERSION_ERROR: - strategy = sym_error; - break; - - case SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE: - strategy = sym_escape; - break; - - case SCM_FAILED_CONVERSION_QUESTION_MARK: - strategy = sym_substitute; - break; - - default: - abort (); - } - - scm_fluid_set_x (SCM_VARIABLE_REF (default_conversion_strategy_var), - strategy); + scm_fluid_set_x (SCM_VARIABLE_REF (default_conversion_strategy_var), sym); } /* If the next LEN bytes from PORT are equal to those in BYTES, then @@ -1276,6 +1256,18 @@ SCM_DEFINE (scm_set_port_encoding_x, "set-port-encoding!", 2, 0, 0, } #undef FUNC_NAME +scm_t_string_failed_conversion_handler +scm_i_string_failed_conversion_handler (SCM conversion_strategy) +{ + if (scm_is_eq (conversion_strategy, sym_substitute)) + return SCM_FAILED_CONVERSION_QUESTION_MARK; + if (scm_is_eq (conversion_strategy, sym_escape)) + return SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE; + + /* Default to error. */ + return SCM_FAILED_CONVERSION_ERROR; +} + SCM_DEFINE (scm_port_conversion_strategy, "port-conversion-strategy", 1, 0, 0, (SCM port), "Returns the behavior of the port when handling a character that\n" @@ -1291,10 +1283,8 @@ SCM_DEFINE (scm_port_conversion_strategy, "port-conversion-strategy", "when they are created.\n") #define FUNC_NAME s_scm_port_conversion_strategy { - scm_t_string_failed_conversion_handler h; - if (scm_is_false (port)) - h = scm_i_default_port_conversion_handler (); + return scm_i_default_port_conversion_strategy (); else { scm_t_port *pt; @@ -1302,20 +1292,8 @@ SCM_DEFINE (scm_port_conversion_strategy, "port-conversion-strategy", SCM_VALIDATE_OPPORT (1, port); pt = SCM_PTAB_ENTRY (port); - h = pt->ilseq_handler; + return pt->conversion_strategy; } - - if (h == SCM_FAILED_CONVERSION_ERROR) - return scm_from_latin1_symbol ("error"); - else if (h == SCM_FAILED_CONVERSION_QUESTION_MARK) - return scm_from_latin1_symbol ("substitute"); - else if (h == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE) - return scm_from_latin1_symbol ("escape"); - else - abort (); - - /* Never gets here. */ - return SCM_UNDEFINED; } #undef FUNC_NAME @@ -1339,23 +1317,17 @@ SCM_DEFINE (scm_set_port_conversion_strategy_x, "set-port-conversion-strategy!", "this thread.\n") #define FUNC_NAME s_scm_set_port_conversion_strategy_x { - scm_t_string_failed_conversion_handler handler; - - if (scm_is_eq (sym, sym_error)) - handler = SCM_FAILED_CONVERSION_ERROR; - else if (scm_is_eq (sym, sym_substitute)) - handler = SCM_FAILED_CONVERSION_QUESTION_MARK; - else if (scm_is_eq (sym, sym_escape)) - handler = SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE; - else + if (!scm_is_eq (sym, sym_error) + && !scm_is_eq (sym, sym_substitute) + && !scm_is_eq (sym, sym_escape)) SCM_MISC_ERROR ("unknown conversion strategy ~s", scm_list_1 (sym)); if (scm_is_false (port)) - scm_i_set_default_port_conversion_handler (handler); + scm_i_set_default_port_conversion_strategy (sym); else { SCM_VALIDATE_OPPORT (1, port); - SCM_PTAB_ENTRY (port)->ilseq_handler = handler; + SCM_PTAB_ENTRY (port)->conversion_strategy = sym; } return SCM_UNSPECIFIED; @@ -1866,7 +1838,7 @@ peek_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) } } } - else if (pt->ilseq_handler == SCM_ICONVEH_QUESTION_MARK) + else if (scm_is_eq (pt->conversion_strategy, sym_substitute)) { *codepoint = '?'; err = 0; @@ -1884,11 +1856,6 @@ get_codepoint (SCM port, scm_t_wchar *codepoint) err = peek_codepoint (port, codepoint, &len); scm_port_buffer_did_take (pt->read_buf, len); - if (err != 0 && pt->ilseq_handler == SCM_ICONVEH_QUESTION_MARK) - { - *codepoint = '?'; - err = 0; - } if (*codepoint == EOF) scm_i_clear_pending_eof (port); update_port_lf (*codepoint, port); @@ -2028,10 +1995,15 @@ scm_ungetc (scm_t_wchar c, SCM port) len = 1; } else - result = u32_conv_to_encoding (scm_i_symbol_chars (pt->encoding), - (enum iconv_ilseq_handler) pt->ilseq_handler, - (uint32_t *) &c, 1, NULL, - result_buf, &len); + { + scm_t_string_failed_conversion_handler handler = + scm_i_string_failed_conversion_handler (pt->conversion_strategy); + + result = u32_conv_to_encoding (scm_i_symbol_chars (pt->encoding), + (enum iconv_ilseq_handler) handler, + (uint32_t *) &c, 1, NULL, + result_buf, &len); + } if (SCM_UNLIKELY (result == NULL || len == 0)) scm_encoding_error (FUNC_NAME, errno, @@ -3152,6 +3124,10 @@ scm_init_ports (void) sym_UTF_32LE = scm_from_latin1_symbol ("UTF-32LE"); sym_UTF_32BE = scm_from_latin1_symbol ("UTF-32BE"); + sym_substitute = scm_from_latin1_symbol ("substitute"); + sym_escape = scm_from_latin1_symbol ("escape"); + sym_error = scm_from_latin1_symbol ("error"); + trampoline_to_c_read_subr = scm_c_make_gsubr ("port-read", 4, 0, 0, (scm_t_subr) trampoline_to_c_read); @@ -3170,10 +3146,6 @@ scm_init_ports (void) cur_warnport_fluid = scm_make_fluid (); cur_loadport_fluid = scm_make_fluid (); - sym_substitute = scm_from_latin1_symbol ("substitute"); - sym_escape = scm_from_latin1_symbol ("escape"); - sym_error = scm_from_latin1_symbol ("error"); - /* Use Latin-1 as the default port encoding. */ default_port_encoding_var = scm_c_define ("%default-port-encoding", diff --git a/libguile/ports.h b/libguile/ports.h index 6cf19d991..1572e40e7 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -115,7 +115,7 @@ typedef struct /* Character encoding support. */ SCM encoding; /* A symbol of upper-case ASCII. */ - scm_t_string_failed_conversion_handler ilseq_handler; + SCM conversion_strategy; /* A symbol; either substitute, error, or escape. */ } scm_t_port; @@ -255,12 +255,11 @@ SCM_API long scm_mode_bits (char *modes); SCM_API SCM scm_port_mode (SCM port); /* Low-level constructors. */ -SCM_API SCM -scm_c_make_port_with_encoding (scm_t_bits tag, - unsigned long mode_bits, - const char *encoding, - scm_t_string_failed_conversion_handler handler, - scm_t_bits stream); +SCM_API SCM scm_c_make_port_with_encoding (scm_t_bits tag, + unsigned long mode_bits, + SCM encoding, + SCM conversion_strategy, + scm_t_bits stream); SCM_API SCM scm_c_make_port (scm_t_bits tag, unsigned long mode_bits, scm_t_bits stream); SCM_API SCM scm_new_port_table_entry (scm_t_bits tag); @@ -279,12 +278,12 @@ SCM_API SCM scm_close_output_port (SCM port); /* Encoding characters to byte streams, and decoding byte streams to characters. */ -SCM_INTERNAL const char *scm_i_default_port_encoding (void); -SCM_INTERNAL void scm_i_set_default_port_encoding (const char *); SCM_INTERNAL scm_t_string_failed_conversion_handler -scm_i_default_port_conversion_handler (void); -SCM_INTERNAL void -scm_i_set_default_port_conversion_handler (scm_t_string_failed_conversion_handler); +scm_i_string_failed_conversion_handler (SCM conversion_strategy); +SCM_INTERNAL SCM scm_i_default_port_encoding (void); +SCM_INTERNAL void scm_i_set_default_port_encoding (const char *encoding); +SCM_INTERNAL SCM scm_i_default_port_conversion_strategy (void); +SCM_INTERNAL void scm_i_set_default_port_conversion_strategy (SCM strategy); SCM_INTERNAL void scm_i_set_port_encoding_x (SCM port, const char *str); SCM_API SCM scm_port_encoding (SCM port); SCM_API SCM scm_set_port_encoding_x (SCM port, SCM encoding); diff --git a/libguile/print.c b/libguile/print.c index 4eea12152..0b2d19340 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -62,7 +62,7 @@ /* Character printers. */ #define PORT_CONVERSION_HANDLER(port) \ - SCM_PTAB_ENTRY (port)->ilseq_handler + scm_i_string_failed_conversion_handler (scm_port_conversion_strategy (port)) SCM_SYMBOL (sym_UTF_8, "UTF-8"); SCM_SYMBOL (sym_ISO_8859_1, "ISO-8859-1"); @@ -441,7 +441,7 @@ print_normal_symbol (SCM sym, SCM port) scm_t_string_failed_conversion_handler strategy; len = scm_i_symbol_length (sym); - strategy = SCM_PTAB_ENTRY (port)->ilseq_handler; + strategy = PORT_CONVERSION_HANDLER (port); if (scm_i_is_narrow_symbol (sym)) display_string (scm_i_symbol_chars (sym), 1, len, port, strategy); diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index aea1c3aba..6e6b2609d 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -37,6 +37,12 @@ #include "libguile/ports-internal.h" + + +SCM_SYMBOL (sym_ISO_8859_1, "ISO-8859-1"); +SCM_SYMBOL (sym_error, "error"); + + /* Unimplemented features. */ @@ -92,10 +98,8 @@ make_bytevector_input_port (SCM bv) stream = scm_gc_typed_calloc (struct bytevector_input_port); stream->bytevector = bv; stream->pos = 0; - return scm_c_make_port_with_encoding (bytevector_input_port_type, - mode_bits, - NULL, /* encoding */ - SCM_FAILED_CONVERSION_ERROR, + return scm_c_make_port_with_encoding (bytevector_input_port_type, mode_bits, + sym_ISO_8859_1, sym_error, (scm_t_bits) stream); } @@ -273,8 +277,7 @@ make_custom_binary_input_port (SCM read_proc, SCM get_position_proc, return scm_c_make_port_with_encoding (custom_binary_input_port_type, mode_bits, - NULL, /* encoding */ - SCM_FAILED_CONVERSION_ERROR, + sym_ISO_8859_1, sym_error, (scm_t_bits) stream); } @@ -739,8 +742,7 @@ make_bytevector_output_port (void) port = scm_c_make_port_with_encoding (bytevector_output_port_type, mode_bits, - NULL, /* encoding */ - SCM_FAILED_CONVERSION_ERROR, + sym_ISO_8859_1, sym_error, (scm_t_bits)buf); buf->port = port; @@ -877,8 +879,7 @@ make_custom_binary_output_port (SCM write_proc, SCM get_position_proc, return scm_c_make_port_with_encoding (custom_binary_output_port_type, mode_bits, - NULL, /* encoding */ - SCM_FAILED_CONVERSION_ERROR, + sym_ISO_8859_1, sym_error, (scm_t_bits) stream); } diff --git a/libguile/strings.c b/libguile/strings.c index 3a02c5889..00082295b 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -53,6 +53,7 @@ SCM_SYMBOL (sym_UTF_8, "UTF-8"); SCM_SYMBOL (sym_ISO_8859_1, "ISO-8859-1"); +SCM_SYMBOL (sym_error, "error"); /* Stringbufs * @@ -1613,11 +1614,18 @@ scm_from_locale_string (const char *str) return scm_from_locale_stringn (str, -1); } +scm_t_string_failed_conversion_handler +scm_i_default_string_failed_conversion_handler (void) +{ + return scm_i_string_failed_conversion_handler + (scm_i_default_port_conversion_strategy ()); +} + SCM scm_from_locale_stringn (const char *str, size_t len) { return scm_from_stringn (str, len, locale_charset (), - scm_i_default_port_conversion_handler ()); + scm_i_default_string_failed_conversion_handler ()); } SCM @@ -1764,12 +1772,13 @@ scm_from_port_stringn (const char *str, size_t len, SCM port) if (scm_is_eq (pt->encoding, sym_ISO_8859_1)) return scm_from_latin1_stringn (str, len); else if (scm_is_eq (pt->encoding, sym_UTF_8) - && (pt->ilseq_handler == SCM_FAILED_CONVERSION_ERROR + && (scm_is_eq (pt->conversion_strategy, sym_error) || (u8_check ((uint8_t *) str, len) == NULL))) return scm_from_utf8_stringn (str, len); else return scm_from_stringn (str, len, scm_i_symbol_chars (pt->encoding), - pt->ilseq_handler); + scm_i_string_failed_conversion_handler + (scm_port_conversion_strategy (port))); } /* Create a new scheme string from the C string STR. The memory of @@ -1940,7 +1949,7 @@ scm_to_locale_stringn (SCM str, size_t *lenp) { return scm_to_stringn (str, lenp, locale_charset (), - scm_i_default_port_conversion_handler ()); + scm_i_default_string_failed_conversion_handler ()); } char * @@ -2169,13 +2178,14 @@ scm_to_port_stringn (SCM str, size_t *lenp, SCM port) scm_t_port *pt = SCM_PTAB_ENTRY (port); if (scm_is_eq (pt->encoding, sym_ISO_8859_1) - && pt->ilseq_handler == SCM_FAILED_CONVERSION_ERROR) + && scm_is_eq (pt->conversion_strategy, sym_error)) return scm_to_latin1_stringn (str, lenp); else if (scm_is_eq (pt->encoding, sym_UTF_8)) return scm_to_utf8_stringn (str, lenp); else return scm_to_stringn (str, lenp, scm_i_symbol_chars (pt->encoding), - pt->ilseq_handler); + scm_i_string_failed_conversion_handler + (scm_port_conversion_strategy (port))); } /* Return a malloc(3)-allocated buffer containing the contents of STR encoded diff --git a/libguile/strings.h b/libguile/strings.h index 130c436a6..24471cd69 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -100,6 +100,9 @@ typedef enum SCM_INTERNAL SCM scm_nullstr; +SCM_INTERNAL scm_t_string_failed_conversion_handler +scm_i_default_string_failed_conversion_handler (void); + SCM_API SCM scm_string_p (SCM x); SCM_API SCM scm_string (SCM chrs); SCM_API SCM scm_make_string (SCM k, SCM chr); diff --git a/libguile/strports.c b/libguile/strports.c index e8ce67a8f..1aecc481b 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -52,6 +52,8 @@ * */ +SCM_SYMBOL (sym_UTF_8, "UTF-8"); + scm_t_bits scm_tc16_strport; struct string_port { @@ -178,10 +180,10 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) stream->pos = byte_pos; stream->len = len; - return scm_c_make_port_with_encoding (scm_tc16_strport, modes, - "UTF-8", - scm_i_default_port_conversion_handler (), - (scm_t_bits) stream); + return + scm_c_make_port_with_encoding (scm_tc16_strport, modes, sym_UTF_8, + scm_i_default_port_conversion_strategy (), + (scm_t_bits) stream); } /* Create a new string from the buffer of PORT, a string port, converting from From 36e32138f8559ac4e35ce97ba747b4dc58ba70d3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 4 May 2016 11:40:22 +0200 Subject: [PATCH 245/865] Port refactors to help Scheme peek-char * libguile/ports.h (scm_sys_port_encoding, scm_sys_set_port_encoding): New functions, to expose port encodings as symbols directly to (ice-9 ports). (scm_port_maybe_consume_initial_byte_order_mark): New function. * libguile/ports.c (scm_port_encoding): Dispatch to %port-encoding. (scm_set_port_encoding_x): Dispatch to %set-port-encoding!. (port_maybe_consume_initial_byte_order_mark): New helper, factored out of peek_codepoint. (scm_port_maybe_consume_initial_byte_order_mark, peek_codepoint): Call port_maybe_consume_initial_byte_order_mark. * module/ice-9/ports.scm (port-encoding): Implement in Scheme. --- libguile/ports.c | 100 +++++++++++++++++++++++++++-------------- libguile/ports.h | 3 ++ module/ice-9/ports.scm | 7 +++ 3 files changed, 77 insertions(+), 33 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index a35a3a122..da1af2ff3 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1222,40 +1222,48 @@ scm_i_set_port_encoding_x (SCM port, const char *encoding) close_iconv_descriptors (prev); } -SCM_DEFINE (scm_port_encoding, "port-encoding", 1, 0, 0, +SCM_DEFINE (scm_sys_port_encoding, "%port-encoding", 1, 0, 0, (SCM port), - "Returns, as a string, the character encoding that @var{port}\n" + "Returns, as a symbol, the character encoding that @var{port}\n" "uses to interpret its input and output.\n") -#define FUNC_NAME s_scm_port_encoding +#define FUNC_NAME s_scm_sys_port_encoding { SCM_VALIDATE_PORT (1, port); - return scm_symbol_to_string (SCM_PTAB_ENTRY (port)->encoding); + return SCM_PTAB_ENTRY (port)->encoding; } #undef FUNC_NAME -SCM_DEFINE (scm_set_port_encoding_x, "set-port-encoding!", 2, 0, 0, +SCM +scm_port_encoding (SCM port) +{ + return scm_symbol_to_string (scm_sys_port_encoding (port)); +} + +SCM_DEFINE (scm_sys_set_port_encoding_x, "%set-port-encoding!", 2, 0, 0, (SCM port, SCM enc), "Sets the character encoding that will be used to interpret all\n" "port I/O. New ports are created with the encoding\n" "appropriate for the current locale if @code{setlocale} has \n" "been called or ISO-8859-1 otherwise\n" "and this procedure can be used to modify that encoding.\n") -#define FUNC_NAME s_scm_set_port_encoding_x +#define FUNC_NAME s_scm_sys_set_port_encoding_x { - char *enc_str; - SCM_VALIDATE_PORT (1, port); - SCM_VALIDATE_STRING (2, enc); + SCM_VALIDATE_SYMBOL (2, enc); - enc_str = scm_to_latin1_string (enc); - scm_i_set_port_encoding_x (port, enc_str); - free (enc_str); + scm_i_set_port_encoding_x (port, scm_i_symbol_chars (enc)); return SCM_UNSPECIFIED; } #undef FUNC_NAME +SCM +scm_set_port_encoding_x (SCM port, SCM enc) +{ + return scm_sys_set_port_encoding_x (port, scm_string_to_symbol (enc)); +} + scm_t_string_failed_conversion_handler scm_i_string_failed_conversion_handler (SCM conversion_strategy) { @@ -1545,6 +1553,50 @@ scm_c_read (SCM port, void *buffer, size_t size) } #undef FUNC_NAME +static int +port_maybe_consume_initial_byte_order_mark (SCM port, scm_t_wchar codepoint, + size_t len) +{ + scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); + + if (!pti->at_stream_start_for_bom_read) return 0; + + /* Record that we're no longer at stream start. */ + pti->at_stream_start_for_bom_read = 0; + if (pt->rw_random) + pti->at_stream_start_for_bom_write = 0; + + if (codepoint != SCM_UNICODE_BOM) return 0; + + /* If we just read a BOM in an encoding that recognizes them, then + silently consume it. */ + if (scm_is_eq (pt->encoding, sym_UTF_8) + || scm_is_eq (pt->encoding, sym_UTF_16) + || scm_is_eq (pt->encoding, sym_UTF_32)) + { + scm_port_buffer_did_take (pt->read_buf, len); + return 1; + } + + return 0; +} + +SCM_DEFINE (scm_port_maybe_consume_initial_byte_order_mark, + "port-maybe-consume-initial-byte-order-mark", 3, 0, 0, + (SCM port, SCM codepoint, SCM len), + "") +#define FUNC_NAME s_scm_port_maybe_consume_initial_byte_order_mark +{ + SCM_VALIDATE_PORT (1, port); + return scm_from_bool + (port_maybe_consume_initial_byte_order_mark + (port, + SCM_CHARP (codepoint) ? SCM_CHAR (codepoint) : EOF, + scm_to_size_t (len))); +} +#undef FUNC_NAME + /* Update the line and column number of PORT after consumption of C. */ static inline void update_port_lf (scm_t_wchar c, SCM port) @@ -1807,7 +1859,6 @@ peek_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) { int err; scm_t_port *pt = SCM_PTAB_ENTRY (port); - scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); if (scm_is_eq (pt->encoding, sym_UTF_8)) err = peek_utf8_codepoint (port, codepoint, len); @@ -1818,25 +1869,8 @@ peek_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) if (SCM_LIKELY (err == 0)) { - if (SCM_UNLIKELY (pti->at_stream_start_for_bom_read)) - { - /* Record that we're no longer at stream start. */ - pti->at_stream_start_for_bom_read = 0; - if (pt->rw_random) - pti->at_stream_start_for_bom_write = 0; - - /* If we just read a BOM in an encoding that recognizes them, - then silently consume it and read another code point. */ - if (SCM_UNLIKELY - (*codepoint == SCM_UNICODE_BOM - && (scm_is_eq (pt->encoding, sym_UTF_8) - || scm_is_eq (pt->encoding, sym_UTF_16) - || scm_is_eq (pt->encoding, sym_UTF_32)))) - { - scm_port_buffer_did_take (pt->read_buf, *len); - return peek_codepoint (port, codepoint, len); - } - } + if (port_maybe_consume_initial_byte_order_mark (port, *codepoint, *len)) + return peek_codepoint (port, codepoint, len); } else if (scm_is_eq (pt->conversion_strategy, sym_substitute)) { @@ -3162,7 +3196,7 @@ scm_init_ports (void) /* The following bindings are used early in boot-9.scm. */ /* Used by `include'. */ - scm_c_define_gsubr (s_scm_set_port_encoding_x, 2, 0, 0, + scm_c_define_gsubr ("set-port-encoding!", 2, 0, 0, (scm_t_subr) scm_set_port_encoding_x); scm_c_define_gsubr (s_scm_eof_object_p, 1, 0, 0, (scm_t_subr) scm_eof_object_p); diff --git a/libguile/ports.h b/libguile/ports.h index 1572e40e7..cec60212c 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -285,12 +285,15 @@ SCM_INTERNAL void scm_i_set_default_port_encoding (const char *encoding); SCM_INTERNAL SCM scm_i_default_port_conversion_strategy (void); SCM_INTERNAL void scm_i_set_default_port_conversion_strategy (SCM strategy); SCM_INTERNAL void scm_i_set_port_encoding_x (SCM port, const char *str); +SCM_INTERNAL SCM scm_sys_port_encoding (SCM port); +SCM_INTERNAL SCM scm_sys_set_port_encoding_x (SCM port, SCM encoding); SCM_API SCM scm_port_encoding (SCM port); SCM_API SCM scm_set_port_encoding_x (SCM port, SCM encoding); SCM_API SCM scm_port_conversion_strategy (SCM port); SCM_API SCM scm_set_port_conversion_strategy_x (SCM port, SCM behavior); /* Input. */ +SCM_INTERNAL SCM scm_port_maybe_consume_initial_byte_order_mark (SCM, SCM, SCM); SCM_API int scm_get_byte_or_eof (SCM port); SCM_API int scm_peek_byte_or_eof (SCM port); SCM_API size_t scm_c_read (SCM port, void *buffer, size_t size); diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index db1c6f7fe..1bf13be7d 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -154,6 +154,13 @@ +(define (port-encoding port) + "Return, as a string, the character encoding that @var{port} uses to +interpret its input and output." + (symbol->string (%port-encoding port))) + + + (define-syntax-rule (port-buffer-bytevector buf) (vector-ref buf 0)) (define-syntax-rule (port-buffer-cur buf) (vector-ref buf 1)) (define-syntax-rule (port-buffer-end buf) (vector-ref buf 2)) From 2ba638092fc890cd33416c6adcbc107e5f5cd0d5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 4 May 2016 11:48:05 +0200 Subject: [PATCH 246/865] Initial peek-char implementation in Scheme * module/ice-9/ports.scm (EILSEQ, decoding-error, peek-char-and-len/utf8): (peek-char-and-len/iso-8859-1, peek-char-and-len/iconv): (peek-char-and-len, %peek-char): New definitions. Missing iconv1 for peek-char, but enough to benchmark. --- module/ice-9/ports.scm | 123 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 123 insertions(+) diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 1bf13be7d..9774e46d2 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -255,6 +255,129 @@ interpret its input and output." (bytevector-u8-ref (port-buffer-bytevector buf) (port-buffer-cur buf)))))))) +;; GNU/Linux definition; fixme? +(define-syntax EILSEQ (identifier-syntax 84)) + +(define-syntax-rule (decoding-error subr port) + (throw 'decoding-error subr "input decoding error" EILSEQ port)) + +(define-inlinable (peek-char-and-len/utf8 port) + (define (bad-utf8 len) + (if (eq? (port-conversion-strategy port) 'substitute) + (values #\? len) + (decoding-error "peek-char" port))) + (let ((first-byte (peek-byte port))) + (cond + ((eq? first-byte the-eof-object) + (values first-byte 0)) + ((< first-byte #x80) + (values (integer->char first-byte) 1)) + ((<= #xc2 first-byte #xdf) + (call-with-values (lambda () (fill-input port 2)) + (lambda (buf buffering) + (let ((bv (port-buffer-bytevector buf)) + (cur (port-buffer-cur buf))) + (define (ref n) + (bytevector-u8-ref bv (+ cur 1))) + (when (or (< buffering 2) + (not (= (logand (ref 1) #xc0) #x80))) + (bad-utf8 1)) + (values (integer->char + (logior (ash (logand first-byte #x1f) 6) + (logand (ref 1) #x3f))) + 2))))) + ((= (logand first-byte #xf0) #xe0) + (call-with-values (lambda () (fill-input port 3)) + (lambda (buf buffering) + (let ((bv (port-buffer-bytevector buf)) + (cur (port-buffer-cur buf))) + (define (ref n) + (bytevector-u8-ref bv (+ cur 1))) + (when (or (< buffering 2) + (not (= (logand (ref 1) #xc0) #x80)) + (and (eq? first-byte #xe0) (< (ref 1) #xa0)) + (and (eq? first-byte #xed) (< (ref 1) #x9f))) + (bad-utf8 1)) + (when (or (< buffering 3) + (not (= (logand (ref 2) #xc0) #x80))) + (bad-utf8 2)) + (values (integer->char + (logior (ash (logand first-byte #x0f) 12) + (ash (logand (ref 1) #x3f) 6) + (logand (ref 2) #x3f))) + 3))))) + ((<= #xf0 first-byte #xf4) + (call-with-values (lambda () (fill-input port 4)) + (lambda (buf buffering) + (let ((bv (port-buffer-bytevector buf)) + (cur (port-buffer-cur buf))) + (define (ref n) + (bytevector-u8-ref bv (+ cur 1))) + (when (or (< buffering 2) + (not (= (logand (ref 1) #xc0) #x80)) + (and (eq? first-byte #xf0) (< (ref 1) #x90)) + (and (eq? first-byte #xf4) (< (ref 1) #x8f))) + (bad-utf8 1)) + (when (or (< buffering 3) + (not (= (logand (ref 2) #xc0) #x80))) + (bad-utf8 2)) + (when (or (< buffering 4) + (not (= (logand (ref 3) #xc0) #x80))) + (bad-utf8 3)) + (values (integer->char + (logior (ash (logand first-byte #x07) 18) + (ash (logand (ref 1) #x3f) 12) + (ash (logand (ref 2) #x3f) 6) + (logand (ref 3) #x3f))) + 4))))) + (else + (bad-utf8 1))))) + +(define-inlinable (peek-char-and-len/iso-8859-1 port) + (let ((byte-or-eof (peek-byte port))) + (if (eof-object? byte-or-eof) + (values byte-or-eof 0) + (values (integer->char byte-or-eof) 1)))) + +(define (peek-char-and-len/iconv port) + (define (bad-input len) + (if (eq? (port-conversion-strategy port) 'substitute) + (values #\? len) + (decoding-error "peek-char" port))) + (let lp ((prev-input-size 0)) + (let* ((input-size (1+ prev-input-size)) + (buf (fill-input port input-size)) + (cur (port-buffer-cur buf))) + (cond + ((<= (- (port-buffer-end buf) cur) prev-input-size) + (if (zero? prev-input-size) + (values the-eof-object 0) + (bad-input prev-input-size))) + ;; fixme: takes port arg??? + ((iconv1 port (port-buffer-bytevector buf) cur input-size + (port-conversion-strategy port)) + => (lambda (char) + (values char input-size))) + (else + (lp input-size)))))) + +(define-inlinable (peek-char-and-len port) + (let ((enc (%port-encoding port))) + (call-with-values + (lambda () + (case enc + ((UTF-8) (peek-char-and-len/utf8 port)) + ((ISO-8859-1) (peek-char-and-len/iso-8859-1 port)) + (else (peek-char-and-len/iconv port)))) + (lambda (char len) + (if (port-maybe-consume-initial-byte-order-mark port char len) + (peek-char-and-len port) + (values char len)))))) + +(define (%peek-char port) + (call-with-values (lambda () (peek-char-and-len port)) + (lambda (char len) + char))) From f5b9a53bd07301bfd83e55d5c1d2dd13d4e4b250 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 4 May 2016 12:31:44 +0200 Subject: [PATCH 247/865] Add integer->char and char->integer opcodes * libguile/vm-engine.c (integer_to_char, char_to_integer): New opcodes. * libguile/vm.c (vm_error_not_a_char): New error case. * module/language/cps/compile-bytecode.scm (compile-function): * module/language/cps/slot-allocation.scm (compute-var-representations): * module/language/cps/types.scm: * module/language/tree-il/compile-cps.scm (convert): * doc/ref/vm.texi (Inlined Scheme Instructions): * module/system/vm/assembler.scm: Add support for new opcodes. --- doc/ref/vm.texi | 10 ++++++ libguile/vm-engine.c | 43 ++++++++++++++++++++++-- libguile/vm.c | 7 ++++ module/language/cps/compile-bytecode.scm | 4 +++ module/language/cps/slot-allocation.scm | 1 + module/language/cps/types.scm | 6 ++-- module/language/tree-il/compile-cps.scm | 11 ++++-- module/system/vm/assembler.scm | 2 ++ 8 files changed, 77 insertions(+), 7 deletions(-) diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 528b66d92..70aa364d9 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -1352,6 +1352,16 @@ Set the cdr of @var{dst} to @var{src}. Note that @code{caddr} and friends compile to a series of @code{car} and @code{cdr} instructions. +@deftypefn Instruction {} integer->char s12:@var{dst} s12:@var{src} +Convert the @code{u64} value in @var{src} to a Scheme character, and +place it in @var{dst}. +@end deftypefn + +@deftypefn Instruction {} char->integer s12:@var{dst} s12:@var{src} +Convert the Scheme character in @var{src} to an integer, and place it in +@var{dst} as an unboxed @code{u64} value. +@end deftypefn + @node Inlined Mathematical Instructions @subsubsection Inlined Mathematical Instructions diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 0bd3e78e9..018f32f04 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -3733,8 +3733,47 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, BR_U64_SCM_COMPARISON(x, y, y <= 0 || (scm_t_uint64) y <= x, scm_geq_p); } - VM_DEFINE_OP (175, unused_175, NULL, NOP) - VM_DEFINE_OP (176, unused_176, NULL, NOP) + /* integer->char a:12 b:12 + * + * Convert the U64 value in B to a Scheme character, and return it in + * A. + */ + VM_DEFINE_OP (175, integer_to_char, "integer->char", OP1 (X8_S12_S12) | OP_DST) + { + scm_t_uint16 dst, src; + scm_t_uint64 x; + + UNPACK_12_12 (op, dst, src); + x = SP_REF_U64 (src); + + if (SCM_UNLIKELY (x > (scm_t_uint64) SCM_CODEPOINT_MAX)) + vm_error_out_of_range_uint64 ("integer->char", x); + + SP_SET (dst, SCM_MAKE_ITAG8 ((scm_t_bits) (scm_t_wchar) x, scm_tc8_char)); + + NEXT (1); + } + + /* char->integer a:12 b:12 + * + * Untag the character in B to U64, and return it in A. + */ + VM_DEFINE_OP (176, char_to_integer, "char->integer", OP1 (X8_S12_S12) | OP_DST) + { + scm_t_uint16 dst, src; + SCM x; + + UNPACK_12_12 (op, dst, src); + x = SP_REF (src); + + if (SCM_UNLIKELY (!SCM_CHARP (x))) + vm_error_not_a_char ("char->integer", x); + + SP_SET_U64 (dst, SCM_CHAR (x)); + + NEXT (1); + } + VM_DEFINE_OP (177, unused_177, NULL, NOP) VM_DEFINE_OP (178, unused_178, NULL, NOP) VM_DEFINE_OP (179, unused_179, NULL, NOP) diff --git a/libguile/vm.c b/libguile/vm.c index 4899a8038..07d6c13ee 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -442,6 +442,7 @@ static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN SCM_NOINLINE; static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE; static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE; static void vm_error_improper_list (SCM x) SCM_NORETURN SCM_NOINLINE; +static void vm_error_not_a_char (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_string (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; @@ -556,6 +557,12 @@ vm_error_improper_list (SCM x) vm_error ("Expected a proper list, but got object with tail ~s", x); } +static void +vm_error_not_a_char (const char *subr, SCM x) +{ + scm_wrong_type_arg_msg (subr, 1, x, "char"); +} + static void vm_error_not_a_pair (const char *subr, SCM x) { diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 1cb85ad7b..ea5b59f38 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -181,6 +181,10 @@ (($ $primcall 'struct-ref/immediate (struct n)) (emit-struct-ref/immediate asm (from-sp dst) (from-sp (slot struct)) (constant n))) + (($ $primcall 'char->integer (src)) + (emit-char->integer asm (from-sp dst) (from-sp (slot src)))) + (($ $primcall 'integer->char (src)) + (emit-integer->char asm (from-sp dst) (from-sp (slot src)))) (($ $primcall 'add/immediate (x y)) (emit-add/immediate asm (from-sp dst) (from-sp (slot x)) (constant y))) (($ $primcall 'sub/immediate (x y)) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 6e9188aa0..654dbda39 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -802,6 +802,7 @@ are comparable with eqv?. A tmp slot may be used." 'fadd 'fsub 'fmul 'fdiv)) (intmap-add representations var 'f64)) (($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64 + 'char->integer 'bv-length 'vector-length 'string-length 'uadd 'usub 'umul 'ulogand 'ulogior 'ulogsub 'ursh 'ulsh diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 4cfc71fd6..f5a83a143 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -1422,15 +1422,15 @@ minimum, and maximum." ((logior &true &false) 0 0)) (define-type-aliases char=? char>?) -(define-simple-type-checker (integer->char (&exact-integer 0 #x10ffff))) +(define-simple-type-checker (integer->char (&u64 0 #x10ffff))) (define-type-inferrer (integer->char i result) - (restrict! i &exact-integer 0 #x10ffff) + (restrict! i &u64 0 #x10ffff) (define! result &char (&min/0 i) (min (&max i) #x10ffff))) (define-simple-type-checker (char->integer &char)) (define-type-inferrer (char->integer c result) (restrict! c &char 0 #x10ffff) - (define! result &exact-integer (&min/0 c) (min (&max c) #x10ffff))) + (define! result &u64 (&min/0 c) (min (&max c) #x10ffff))) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 419cb336b..0b9c834c4 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -576,8 +576,8 @@ (letk kbox ($kargs ('f64) (f64) ($continue k src ($primcall 'f64->scm (f64))))) kbox)) - ((string-length - vector-length + ((char->integer + string-length vector-length bv-length bv-u8-ref bv-u16-ref bv-u32-ref bv-u64-ref) (with-cps cps (letv u64) @@ -670,6 +670,13 @@ cps nfields 'scm->u64 (lambda (cps nfields) (have-args cps (list vtable nfields))))))) + ((integer->char) + (match args + ((integer) + (unbox-arg + cps integer 'scm->u64 + (lambda (cps integer) + (have-args cps (list integer))))))) (else (have-args cps args)))) (convert-args cps args (lambda (cps args) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 94ebf0368..117bc6cf3 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -166,6 +166,8 @@ emit-ulsh emit-ursh/immediate emit-ulsh/immediate + emit-char->integer + emit-integer->char emit-make-vector emit-make-vector/immediate emit-vector-length From d7a111b0ec96840ccf8ce4dc31e497e00c3a16a6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 4 May 2016 12:40:27 +0200 Subject: [PATCH 248/865] Spead tweaks to Scheme peek-char * module/ice-9/ports.scm: Speed tweaks to %peek-char. Ultimately somewhat fruitless; I can get 1.4s instead of 1.5s by only half-inlining the UTF-8 case though. --- module/ice-9/ports.scm | 170 ++++++++++++++++++++--------------------- 1 file changed, 85 insertions(+), 85 deletions(-) diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 9774e46d2..0c4233198 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -243,7 +243,7 @@ interpret its input and output." (lp buffered) (values buf buffered))))))))))))))) -(define (peek-byte port) +(define-inlinable (peek-byte port) (let* ((buf (port-read-buffer port)) (cur (port-buffer-cur buf))) (if (< cur (port-buffer-end buf)) @@ -261,85 +261,79 @@ interpret its input and output." (define-syntax-rule (decoding-error subr port) (throw 'decoding-error subr "input decoding error" EILSEQ port)) -(define-inlinable (peek-char-and-len/utf8 port) +(define-inlinable (peek-char-and-len/utf8 port first-byte) (define (bad-utf8 len) (if (eq? (port-conversion-strategy port) 'substitute) (values #\? len) (decoding-error "peek-char" port))) - (let ((first-byte (peek-byte port))) - (cond - ((eq? first-byte the-eof-object) - (values first-byte 0)) - ((< first-byte #x80) - (values (integer->char first-byte) 1)) - ((<= #xc2 first-byte #xdf) - (call-with-values (lambda () (fill-input port 2)) - (lambda (buf buffering) - (let ((bv (port-buffer-bytevector buf)) - (cur (port-buffer-cur buf))) - (define (ref n) - (bytevector-u8-ref bv (+ cur 1))) - (when (or (< buffering 2) - (not (= (logand (ref 1) #xc0) #x80))) - (bad-utf8 1)) - (values (integer->char - (logior (ash (logand first-byte #x1f) 6) - (logand (ref 1) #x3f))) - 2))))) - ((= (logand first-byte #xf0) #xe0) - (call-with-values (lambda () (fill-input port 3)) - (lambda (buf buffering) - (let ((bv (port-buffer-bytevector buf)) - (cur (port-buffer-cur buf))) - (define (ref n) - (bytevector-u8-ref bv (+ cur 1))) - (when (or (< buffering 2) - (not (= (logand (ref 1) #xc0) #x80)) - (and (eq? first-byte #xe0) (< (ref 1) #xa0)) - (and (eq? first-byte #xed) (< (ref 1) #x9f))) - (bad-utf8 1)) - (when (or (< buffering 3) - (not (= (logand (ref 2) #xc0) #x80))) - (bad-utf8 2)) - (values (integer->char - (logior (ash (logand first-byte #x0f) 12) - (ash (logand (ref 1) #x3f) 6) - (logand (ref 2) #x3f))) - 3))))) - ((<= #xf0 first-byte #xf4) - (call-with-values (lambda () (fill-input port 4)) - (lambda (buf buffering) - (let ((bv (port-buffer-bytevector buf)) - (cur (port-buffer-cur buf))) - (define (ref n) - (bytevector-u8-ref bv (+ cur 1))) - (when (or (< buffering 2) - (not (= (logand (ref 1) #xc0) #x80)) - (and (eq? first-byte #xf0) (< (ref 1) #x90)) - (and (eq? first-byte #xf4) (< (ref 1) #x8f))) - (bad-utf8 1)) - (when (or (< buffering 3) - (not (= (logand (ref 2) #xc0) #x80))) - (bad-utf8 2)) - (when (or (< buffering 4) - (not (= (logand (ref 3) #xc0) #x80))) - (bad-utf8 3)) - (values (integer->char - (logior (ash (logand first-byte #x07) 18) - (ash (logand (ref 1) #x3f) 12) - (ash (logand (ref 2) #x3f) 6) - (logand (ref 3) #x3f))) - 4))))) - (else - (bad-utf8 1))))) + (cond + ((< first-byte #x80) + (values (integer->char first-byte) 1)) + ((<= #xc2 first-byte #xdf) + (call-with-values (lambda () (fill-input port 2)) + (lambda (buf buffering) + (let ((bv (port-buffer-bytevector buf)) + (cur (port-buffer-cur buf))) + (define (ref n) + (bytevector-u8-ref bv (+ cur 1))) + (when (or (< buffering 2) + (not (= (logand (ref 1) #xc0) #x80))) + (bad-utf8 1)) + (values (integer->char + (logior (ash (logand first-byte #x1f) 6) + (logand (ref 1) #x3f))) + 2))))) + ((= (logand first-byte #xf0) #xe0) + (call-with-values (lambda () (fill-input port 3)) + (lambda (buf buffering) + (let ((bv (port-buffer-bytevector buf)) + (cur (port-buffer-cur buf))) + (define (ref n) + (bytevector-u8-ref bv (+ cur 1))) + (when (or (< buffering 2) + (not (= (logand (ref 1) #xc0) #x80)) + (and (eq? first-byte #xe0) (< (ref 1) #xa0)) + (and (eq? first-byte #xed) (< (ref 1) #x9f))) + (bad-utf8 1)) + (when (or (< buffering 3) + (not (= (logand (ref 2) #xc0) #x80))) + (bad-utf8 2)) + (values (integer->char + (logior (ash (logand first-byte #x0f) 12) + (ash (logand (ref 1) #x3f) 6) + (logand (ref 2) #x3f))) + 3))))) + ((<= #xf0 first-byte #xf4) + (call-with-values (lambda () (fill-input port 4)) + (lambda (buf buffering) + (let ((bv (port-buffer-bytevector buf)) + (cur (port-buffer-cur buf))) + (define (ref n) + (bytevector-u8-ref bv (+ cur 1))) + (when (or (< buffering 2) + (not (= (logand (ref 1) #xc0) #x80)) + (and (eq? first-byte #xf0) (< (ref 1) #x90)) + (and (eq? first-byte #xf4) (< (ref 1) #x8f))) + (bad-utf8 1)) + (when (or (< buffering 3) + (not (= (logand (ref 2) #xc0) #x80))) + (bad-utf8 2)) + (when (or (< buffering 4) + (not (= (logand (ref 3) #xc0) #x80))) + (bad-utf8 3)) + (values (integer->char + (logior (ash (logand first-byte #x07) 18) + (ash (logand (ref 1) #x3f) 12) + (ash (logand (ref 2) #x3f) 6) + (logand (ref 3) #x3f))) + 4))))) + (else + (bad-utf8 1)))) -(define-inlinable (peek-char-and-len/iso-8859-1 port) - (let ((byte-or-eof (peek-byte port))) - (if (eof-object? byte-or-eof) - (values byte-or-eof 0) - (values (integer->char byte-or-eof) 1)))) +(define-inlinable (peek-char-and-len/iso-8859-1 port first-byte) + (values (integer->char first-byte) 1)) -(define (peek-char-and-len/iconv port) +(define (peek-char-and-len/iconv port first-byte) (define (bad-input len) (if (eq? (port-conversion-strategy port) 'substitute) (values #\? len) @@ -362,17 +356,23 @@ interpret its input and output." (lp input-size)))))) (define-inlinable (peek-char-and-len port) - (let ((enc (%port-encoding port))) - (call-with-values - (lambda () - (case enc - ((UTF-8) (peek-char-and-len/utf8 port)) - ((ISO-8859-1) (peek-char-and-len/iso-8859-1 port)) - (else (peek-char-and-len/iconv port)))) - (lambda (char len) - (if (port-maybe-consume-initial-byte-order-mark port char len) - (peek-char-and-len port) - (values char len)))))) + (let ((first-byte (peek-byte port))) + (if (eq? first-byte the-eof-object) + (values first-byte 0) + (let ((first-byte (logand first-byte #xff))) + (call-with-values + (lambda () + (case (%port-encoding port) + ((UTF-8) + (peek-char-and-len/utf8 port first-byte)) + ((ISO-8859-1) + (peek-char-and-len/iso-8859-1 port first-byte)) + (else + (peek-char-and-len/iconv port first-byte)))) + (lambda (char len) + (if (port-maybe-consume-initial-byte-order-mark port char len) + (peek-char-and-len port) + (values char len)))))))) (define (%peek-char port) (call-with-values (lambda () (peek-char-and-len port)) From 86267af8b30be0901b6bb29cbdc730c0a5844bfd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 5 May 2016 13:00:19 +0200 Subject: [PATCH 249/865] Handle BOM around fill/flush instead of peek/put * libguile/print.c (display_string_using_iconv): Remove BOM handling; this is now handled by scm_lfwrite. * libguile/ports.c (open_iconv_descriptors): Refactor to take encoding as a symbol. (prepare_iconv_descriptors): New helper. (scm_i_port_iconv_descriptors): Remove scm_t_port_rw_active argument, and don't sniff UTF-16/UTF-32 byte orders here. Instead BOM handlers will call prepare_iconv_descriptors. (scm_c_read_bytes): Call new port_clear_stream_start_for_bom_read helper. (port_maybe_consume_initial_byte_order_mark) (scm_port_maybe_consume_initial_byte_order_mark): Remove. Leaves Scheme %peek-char broken but it's unused currently so that's OK. (peek_iconv_codepoint): Fetch iconv descriptors after doing fill-input because it's fill-input that will sniff the BOM. (peek_codepoint): Instead of handling BOM at every character, handle in fill-input instead. (maybe_consume_bom, port_clear_stream_start_for_bom_read) (port_clear_stream_start_for_bom_write): New helpers. (scm_fill_input): Slurp a BOM if needed. (scm_i_write): Clear the start-of-stream-for-bom-write flag. (scm_lfwrite): Write a BOM if needed. --- libguile/ports-internal.h | 10 +- libguile/ports.c | 309 ++++++++++++++++++++++---------------- libguile/print.c | 18 +-- 3 files changed, 185 insertions(+), 152 deletions(-) diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index 526337d01..689e61c17 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -210,6 +210,13 @@ typedef enum scm_port_encoding_mode scm_t_port_encoding_mode; cause finalizers to be registered. */ struct scm_iconv_descriptors { + /* This is the same as pt->encoding, except if pt->encoding is UTF-16 + or UTF-32, in which case this is UTF-16LE or a similar + byte-order-specialed version of UTF-16 or UTF-32. We don't re-set + pt->encoding because being just plain UTF-16 or UTF-32 has an + additional meaning, being that we should consume and produce byte + order marker codepoints as appropriate. */ + SCM precise_encoding; /* input/output iconv conversion descriptors */ void *input_cd; void *output_cd; @@ -237,7 +244,6 @@ typedef enum scm_t_port_rw_active { SCM_PORT_WRITE = 2 } scm_t_port_rw_active; -SCM_INTERNAL scm_t_iconv_descriptors * -scm_i_port_iconv_descriptors (SCM port, scm_t_port_rw_active mode); +SCM_INTERNAL scm_t_iconv_descriptors * scm_i_port_iconv_descriptors (SCM port); #endif diff --git a/libguile/ports.c b/libguile/ports.c index da1af2ff3..e8c79bcdf 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1028,63 +1028,12 @@ scm_i_set_default_port_conversion_strategy (SCM sym) scm_fluid_set_x (SCM_VARIABLE_REF (default_conversion_strategy_var), sym); } -/* If the next LEN bytes from PORT are equal to those in BYTES, then - return 1, else return 0. Leave the port position unchanged. */ -static int -looking_at_bytes (SCM port, const unsigned char *bytes, int len) -{ - scm_t_port *pt = SCM_PTAB_ENTRY (port); - int i = 0; - - while (i < len && scm_peek_byte_or_eof (port) == bytes[i]) - { - scm_port_buffer_did_take (pt->read_buf, 1); - i++; - } - scm_unget_bytes (bytes, i, port); - return (i == len); -} - static const unsigned char scm_utf8_bom[3] = {0xEF, 0xBB, 0xBF}; static const unsigned char scm_utf16be_bom[2] = {0xFE, 0xFF}; static const unsigned char scm_utf16le_bom[2] = {0xFF, 0xFE}; static const unsigned char scm_utf32be_bom[4] = {0x00, 0x00, 0xFE, 0xFF}; static const unsigned char scm_utf32le_bom[4] = {0xFF, 0xFE, 0x00, 0x00}; -/* Decide what byte order to use for a UTF-16 port. Return "UTF-16BE" - or "UTF-16LE". MODE must be either SCM_PORT_READ or SCM_PORT_WRITE, - and specifies which operation is about to be done. The MODE - determines how we will decide the byte order. We deliberately avoid - reading from the port unless the user is about to do so. If the user - is about to read, then we look for a BOM, and if present, we use it - to determine the byte order. Otherwise we choose big endian, as - recommended by the Unicode Standard. Note that the BOM (if any) is - not consumed here. */ -static SCM -decide_utf16_encoding (SCM port, scm_t_port_rw_active mode) -{ - if (mode == SCM_PORT_READ - && SCM_PORT_GET_INTERNAL (port)->at_stream_start_for_bom_read - && looking_at_bytes (port, scm_utf16le_bom, sizeof scm_utf16le_bom)) - return sym_UTF_16LE; - else - return sym_UTF_16BE; -} - -/* Decide what byte order to use for a UTF-32 port. Return "UTF-32BE" - or "UTF-32LE". See the comment above 'decide_utf16_encoding' for - details. */ -static SCM -decide_utf32_encoding (SCM port, scm_t_port_rw_active mode) -{ - if (mode == SCM_PORT_READ - && SCM_PORT_GET_INTERNAL (port)->at_stream_start_for_bom_read - && looking_at_bytes (port, scm_utf32le_bom, sizeof scm_utf32le_bom)) - return sym_UTF_32LE; - else - return sym_UTF_32BE; -} - static void finalize_iconv_descriptors (void *ptr, void *data) { @@ -1092,8 +1041,9 @@ finalize_iconv_descriptors (void *ptr, void *data) } static scm_t_iconv_descriptors * -open_iconv_descriptors (const char *encoding, int reading, int writing) +open_iconv_descriptors (SCM precise_encoding, int reading, int writing) { + const char *encoding; scm_t_iconv_descriptors *id; iconv_t input_cd, output_cd; size_t i; @@ -1101,6 +1051,7 @@ open_iconv_descriptors (const char *encoding, int reading, int writing) input_cd = (iconv_t) -1; output_cd = (iconv_t) -1; + encoding = scm_i_symbol_chars (precise_encoding); for (i = 0; encoding[i]; i++) if (encoding[i] > 127) goto invalid_encoding; @@ -1138,6 +1089,7 @@ open_iconv_descriptors (const char *encoding, int reading, int writing) } id = scm_gc_malloc_pointerless (sizeof (*id), "iconv descriptors"); + id->precise_encoding = precise_encoding; id->input_cd = input_cd; id->output_cd = output_cd; @@ -1147,13 +1099,9 @@ open_iconv_descriptors (const char *encoding, int reading, int writing) return id; invalid_encoding: - { - SCM err; - err = scm_from_latin1_string (encoding); - scm_misc_error ("open_iconv_descriptors", - "invalid or unknown character encoding ~s", - scm_list_1 (err)); - } + scm_misc_error ("open_iconv_descriptors", + "invalid or unknown character encoding ~s", + scm_list_1 (precise_encoding)); } static void @@ -1167,30 +1115,35 @@ close_iconv_descriptors (scm_t_iconv_descriptors *id) id->output_cd = (void *) -1; } -scm_t_iconv_descriptors * -scm_i_port_iconv_descriptors (SCM port, scm_t_port_rw_active mode) +static void +prepare_iconv_descriptors (SCM port, SCM encoding) +{ + scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); + scm_t_iconv_descriptors *desc = pti->iconv_descriptors; + + /* If the specified encoding is UTF-16 or UTF-32, then default to + big-endian byte order. This fallback isn't necessary if you read + on the port before writing to it, as the read will sniff the BOM if + any and specialize the encoding; see the manual. */ + if (scm_is_eq (encoding, sym_UTF_16)) + encoding = sym_UTF_16BE; + else if (scm_is_eq (encoding, sym_UTF_32)) + encoding = sym_UTF_32BE; + + if (desc && scm_is_eq (desc->precise_encoding, encoding)) + return; + + pti->iconv_descriptors = open_iconv_descriptors + (encoding, SCM_INPUT_PORT_P (port), SCM_OUTPUT_PORT_P (port)); +} + +scm_t_iconv_descriptors * +scm_i_port_iconv_descriptors (SCM port) { - scm_t_port *pt = SCM_PTAB_ENTRY (port); scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); if (!pti->iconv_descriptors) - { - SCM precise_encoding; - - /* If the specified encoding is UTF-16 or UTF-32, then make - that more precise by deciding what byte order to use. */ - if (scm_is_eq (pt->encoding, sym_UTF_16)) - precise_encoding = decide_utf16_encoding (port, mode); - else if (scm_is_eq (pt->encoding, sym_UTF_32)) - precise_encoding = decide_utf32_encoding (port, mode); - else - precise_encoding = pt->encoding; - - pti->iconv_descriptors = - open_iconv_descriptors (scm_i_symbol_chars (precise_encoding), - SCM_INPUT_PORT_P (port), - SCM_OUTPUT_PORT_P (port)); - } + prepare_iconv_descriptors (port, SCM_PTAB_ENTRY (port)->encoding); return pti->iconv_descriptors; } @@ -1450,6 +1403,14 @@ scm_i_read_bytes (SCM port, SCM dst, size_t start, size_t count) return filled; } +/* In text mode, we will slurp a BOM from the beginning of a UTF-8, + UTF-16, or UTF-32 stream, and write one at the beginning of a UTF-16 + or UTF-32 stream. In binary mode, we won't. The mode depends on the + caller. */ +enum bom_io_mode { BOM_IO_TEXT, BOM_IO_BINARY }; +static size_t port_clear_stream_start_for_bom_read (SCM, enum bom_io_mode); +static void port_clear_stream_start_for_bom_write (SCM, enum bom_io_mode); + /* Used by an application to read arbitrary number of bytes from an SCM port. Same semantics as libc read, except that scm_c_read_bytes only returns less than SIZE bytes if at end-of-file. @@ -1472,6 +1433,8 @@ scm_c_read_bytes (SCM port, SCM dst, size_t start, size_t count) if (pt->rw_random) scm_flush (port); + port_clear_stream_start_for_bom_read (port, BOM_IO_BINARY); + /* Take bytes first from the port's read buffer. */ { size_t did_read = scm_port_buffer_take (read_buf, dst_ptr, to_read); @@ -1553,50 +1516,6 @@ scm_c_read (SCM port, void *buffer, size_t size) } #undef FUNC_NAME -static int -port_maybe_consume_initial_byte_order_mark (SCM port, scm_t_wchar codepoint, - size_t len) -{ - scm_t_port *pt = SCM_PTAB_ENTRY (port); - scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); - - if (!pti->at_stream_start_for_bom_read) return 0; - - /* Record that we're no longer at stream start. */ - pti->at_stream_start_for_bom_read = 0; - if (pt->rw_random) - pti->at_stream_start_for_bom_write = 0; - - if (codepoint != SCM_UNICODE_BOM) return 0; - - /* If we just read a BOM in an encoding that recognizes them, then - silently consume it. */ - if (scm_is_eq (pt->encoding, sym_UTF_8) - || scm_is_eq (pt->encoding, sym_UTF_16) - || scm_is_eq (pt->encoding, sym_UTF_32)) - { - scm_port_buffer_did_take (pt->read_buf, len); - return 1; - } - - return 0; -} - -SCM_DEFINE (scm_port_maybe_consume_initial_byte_order_mark, - "port-maybe-consume-initial-byte-order-mark", 3, 0, 0, - (SCM port, SCM codepoint, SCM len), - "") -#define FUNC_NAME s_scm_port_maybe_consume_initial_byte_order_mark -{ - SCM_VALIDATE_PORT (1, port); - return scm_from_bool - (port_maybe_consume_initial_byte_order_mark - (port, - SCM_CHARP (codepoint) ? SCM_CHAR (codepoint) : EOF, - scm_to_size_t (len))); -} -#undef FUNC_NAME - /* Update the line and column number of PORT after consumption of C. */ static inline void update_port_lf (scm_t_wchar c, SCM port) @@ -1790,8 +1709,6 @@ peek_iconv_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) scm_t_uint8 utf8_buf[SCM_MBCHAR_BUF_SIZE]; size_t input_size = 0; - id = scm_i_port_iconv_descriptors (port, SCM_PORT_READ); - for (;;) { SCM read_buf; @@ -1799,6 +1716,8 @@ peek_iconv_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) size_t input_left, output_left, done; read_buf = scm_fill_input (port, input_size + 1); + id = scm_i_port_iconv_descriptors (port); + if (scm_port_buffer_can_take (read_buf) <= input_size) { if (input_size == 0) @@ -1867,12 +1786,7 @@ peek_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) else err = peek_iconv_codepoint (port, codepoint, len); - if (SCM_LIKELY (err == 0)) - { - if (port_maybe_consume_initial_byte_order_mark (port, *codepoint, *len)) - return peek_codepoint (port, codepoint, len); - } - else if (scm_is_eq (pt->conversion_strategy, sym_substitute)) + if (err != 0 && scm_is_eq (pt->conversion_strategy, sym_substitute)) { *codepoint = '?'; err = 0; @@ -2352,16 +2266,138 @@ scm_flush (SCM port) scm_i_write (port, buf); } +/* Return number of bytes consumed, or zero if no BOM was consumed. */ +static size_t +maybe_consume_bom (SCM port, const unsigned char *bom, size_t bom_len) +{ + SCM read_buf; + const scm_t_uint8 *buf; + + if (peek_byte_or_eof (port) != bom[0]) + return 0; + + /* Make sure there's enough space in the buffer for a BOM. Now that + we matched the first byte, we know we're going to have to read this + many bytes anyway. */ + read_buf = scm_fill_input (port, bom_len); + buf = scm_port_buffer_take_pointer (read_buf); + + if (scm_port_buffer_can_take (read_buf) < bom_len) + return 0; + + if (memcmp (buf, bom, bom_len) != 0) + return 0; + + scm_port_buffer_did_take (read_buf, bom_len); + return bom_len; +} + +static size_t +port_clear_stream_start_for_bom_read (SCM port, enum bom_io_mode io_mode) +{ + scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); + scm_t_port *pt; + + if (!pti->at_stream_start_for_bom_read) + return 0; + + /* Maybe slurp off a byte-order marker. */ + pt = SCM_PTAB_ENTRY (port); + pti->at_stream_start_for_bom_read = 0; + if (pt->rw_random) + pti->at_stream_start_for_bom_write = 0; + + if (io_mode == BOM_IO_BINARY) + return 0; + + if (scm_is_eq (pt->encoding, sym_UTF_8)) + return maybe_consume_bom (port, scm_utf8_bom, sizeof (scm_utf8_bom)); + + if (scm_is_eq (pt->encoding, sym_UTF_16)) + { + if (maybe_consume_bom (port, scm_utf16le_bom, sizeof (scm_utf16le_bom))) + { + prepare_iconv_descriptors (port, sym_UTF_16LE); + return 2; + } + if (maybe_consume_bom (port, scm_utf16be_bom, sizeof (scm_utf16be_bom))) + { + prepare_iconv_descriptors (port, sym_UTF_16BE); + return 2; + } + /* Big-endian by default. */ + prepare_iconv_descriptors (port, sym_UTF_16BE); + return 0; + } + + if (scm_is_eq (pt->encoding, sym_UTF_32)) + { + if (maybe_consume_bom (port, scm_utf32le_bom, sizeof (scm_utf32le_bom))) + { + /* Big-endian by default. */ + prepare_iconv_descriptors (port, sym_UTF_32LE); + return 4; + } + if (maybe_consume_bom (port, scm_utf32be_bom, sizeof (scm_utf32be_bom))) + { + prepare_iconv_descriptors (port, sym_UTF_32BE); + return 4; + } + /* Big-endian by default. */ + prepare_iconv_descriptors (port, sym_UTF_32BE); + return 0; + } + + return 0; +} + +static void +port_clear_stream_start_for_bom_write (SCM port, enum bom_io_mode io_mode) +{ + scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); + + if (!pti->at_stream_start_for_bom_write) + return; + + /* Record that we're no longer at stream start. */ + pti->at_stream_start_for_bom_write = 0; + if (pt->rw_random) + pti->at_stream_start_for_bom_read = 0; + + /* Write a BOM if appropriate. */ + if (scm_is_eq (pt->encoding, sym_UTF_16)) + { + scm_t_iconv_descriptors *id = scm_i_port_iconv_descriptors (port); + if (scm_is_eq (id->precise_encoding, sym_UTF_16LE)) + scm_c_write (port, scm_utf16le_bom, sizeof (scm_utf16le_bom)); + else + scm_c_write (port, scm_utf16be_bom, sizeof (scm_utf16be_bom)); + } + else if (scm_is_eq (pt->encoding, sym_UTF_32)) + { + scm_t_iconv_descriptors *id = scm_i_port_iconv_descriptors (port); + if (scm_is_eq (id->precise_encoding, sym_UTF_32LE)) + scm_c_write (port, scm_utf32le_bom, sizeof (scm_utf32le_bom)); + else + scm_c_write (port, scm_utf32be_bom, sizeof (scm_utf32be_bom)); + } +} + SCM scm_fill_input (SCM port, size_t minimum_size) { scm_t_port *pt = SCM_PTAB_ENTRY (port); - SCM read_buf = pt->read_buf; - size_t buffered = scm_port_buffer_can_take (read_buf); + SCM read_buf; + size_t buffered; if (minimum_size == 0) minimum_size = 1; + port_clear_stream_start_for_bom_read (port, BOM_IO_TEXT); + read_buf = pt->read_buf; + buffered = scm_port_buffer_can_take (read_buf); + if (buffered >= minimum_size || scm_is_true (scm_port_buffer_has_eof_p (read_buf))) return read_buf; @@ -2525,6 +2561,8 @@ scm_i_write (SCM port, SCM buf) { size_t start, count; + port_clear_stream_start_for_bom_write (port, BOM_IO_BINARY); + /* Update cursors before attempting to write, assuming that I/O errors are sticky. That way if the write throws an error, causing the computation to abort, and possibly causing the port to be collected @@ -2633,6 +2671,11 @@ scm_lfwrite (const char *ptr, size_t size, SCM port) { int saved_line; + if (size == 0) + return; + + port_clear_stream_start_for_bom_write (port, BOM_IO_TEXT); + scm_c_write (port, ptr, size); saved_line = SCM_LINUM (port); diff --git a/libguile/print.c b/libguile/print.c index 0b2d19340..8dcd375f9 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1027,24 +1027,8 @@ display_string_using_iconv (const void *str, int narrow_p, size_t len, { size_t printed; scm_t_iconv_descriptors *id; - scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); - id = scm_i_port_iconv_descriptors (port, SCM_PORT_WRITE); - - if (SCM_UNLIKELY (pti->at_stream_start_for_bom_write && len > 0)) - { - scm_t_port *pt = SCM_PTAB_ENTRY (port); - - /* Record that we're no longer at stream start. */ - pti->at_stream_start_for_bom_write = 0; - if (pt->rw_random) - pti->at_stream_start_for_bom_read = 0; - - /* Write a BOM if appropriate. */ - if (SCM_UNLIKELY (scm_is_eq (pt->encoding, sym_UTF_16) - || scm_is_eq (pt->encoding, sym_UTF_32))) - display_character (SCM_UNICODE_BOM, port, iconveh_error); - } + id = scm_i_port_iconv_descriptors (port); printed = 0; From 6d15a71e8f7c61d67b8e6a3f9ac751ac918382b6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 5 May 2016 22:54:58 +0200 Subject: [PATCH 250/865] Port to Scheme of new BOM handling * libguile/ports.c (scm_specialize_port_encoding_x) (scm_port_clear_stream_start_for_bom_read): New functions exported to (ice-9 ports). * module/ice-9/ports.scm (clear-stream-start-for-bom-read): (fill-input, peek-char-and-len): Rework to handle BOM in fill-input instead of once per peek-char. --- libguile/ports.c | 49 ++++++++++++++++++++++++++++++++ module/ice-9/ports.scm | 63 +++++++++++++++++++++++++++++++++--------- 2 files changed, 99 insertions(+), 13 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index e8c79bcdf..e82343672 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1137,6 +1137,22 @@ prepare_iconv_descriptors (SCM port, SCM encoding) (encoding, SCM_INPUT_PORT_P (port), SCM_OUTPUT_PORT_P (port)); } +SCM_INTERNAL SCM scm_specialize_port_encoding_x (SCM port, SCM encoding); +SCM_DEFINE (scm_specialize_port_encoding_x, + "specialize-port-encoding!", 2, 0, 0, + (SCM port, SCM encoding), + "") +#define FUNC_NAME s_scm_specialize_port_encoding_x +{ + SCM_VALIDATE_PORT (1, port); + SCM_VALIDATE_SYMBOL (2, encoding); + + prepare_iconv_descriptors (port, encoding); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + scm_t_iconv_descriptors * scm_i_port_iconv_descriptors (SCM port) { @@ -2351,6 +2367,39 @@ port_clear_stream_start_for_bom_read (SCM port, enum bom_io_mode io_mode) return 0; } +SCM_INTERNAL SCM scm_port_clear_stream_start_for_bom_read (SCM port); +SCM_DEFINE (scm_port_clear_stream_start_for_bom_read, + "port-clear-stream-start-for-bom-read", 1, 0, 0, + (SCM port), + "") +#define FUNC_NAME s_scm_port_clear_stream_start_for_bom_read +{ + scm_t_port_internal *pti; + scm_t_port *pt; + + SCM_VALIDATE_PORT (1, port); + + pti = SCM_PORT_GET_INTERNAL (port); + if (!pti->at_stream_start_for_bom_read) + return 0; + + /* Maybe slurp off a byte-order marker. */ + pt = SCM_PTAB_ENTRY (port); + pti->at_stream_start_for_bom_read = 0; + + if (!pti->at_stream_start_for_bom_read) + return SCM_BOOL_F; + + /* Maybe slurp off a byte-order marker. */ + pt = SCM_PTAB_ENTRY (port); + pti->at_stream_start_for_bom_read = 0; + if (pt->rw_random) + pti->at_stream_start_for_bom_write = 0; + + return SCM_BOOL_T; +} +#undef FUNC_NAME + static void port_clear_stream_start_for_bom_write (SCM port, enum bom_io_mode io_mode) { diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 0c4233198..41eb866e1 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -203,7 +203,50 @@ interpret its input and output." (error "bad return from port read function" read)) read)) +(define utf8-bom #vu8(#xEF #xBB #xBF)) +(define utf16be-bom #vu8(#xFE #xFF)) +(define utf16le-bom #vu8(#xFF #xFE)) +(define utf32be-bom #vu8(#x00 #x00 #xFE #xFF)) +(define utf32le-bom #vu8(#xFF #xFE #x00 #x00)) + +(define (clear-stream-start-for-bom-read port io-mode) + (define (maybe-consume-bom bom) + (and (eq? (peek-byte port) (bytevector-u8-ref bom 0)) + (let* ((buf (fill-input port (bytevector-length bom))) + (bv (port-buffer-bytevector buf)) + (cur (port-buffer-cur bv))) + (and (<= (bytevector-length bv) + (- (port-buffer-end buf) cur)) + (let lp ((i 1)) + (if (= i (bytevector-length bom)) + (begin + (set-port-buffer-cur! buf (+ cur i)) + #t) + (and (eq? (bytevector-u8-ref bv (+ cur i)) + (bytevector-u8-ref bom i)) + (lp (1+ i))))))))) + (when (and (port-clear-stream-start-for-bom-read port) + (eq? io-mode 'text)) + (case (port-encoding port) + ((UTF-8) + (maybe-consume-bom utf8-bom)) + ((UTF-16) + (cond + ((maybe-consume-bom utf16le-bom) + (specialize-port-encoding! port 'UTF-16LE)) + (else + (maybe-consume-bom utf16be-bom) + (specialize-port-encoding! port 'UTF-16BE)))) + ((UTF-32) + (cond + ((maybe-consume-bom utf32le-bom) + (specialize-port-encoding! port 'UTF-32LE)) + (else + (maybe-consume-bom utf32be-bom) + (specialize-port-encoding! port 'UTF-32BE))))))) + (define* (fill-input port #:optional (minimum-buffering 1)) + (clear-stream-start-for-bom-read port 'text) (let* ((buf (port-read-buffer port)) (cur (port-buffer-cur buf)) (buffered (- (port-buffer-end buf) cur))) @@ -360,19 +403,13 @@ interpret its input and output." (if (eq? first-byte the-eof-object) (values first-byte 0) (let ((first-byte (logand first-byte #xff))) - (call-with-values - (lambda () - (case (%port-encoding port) - ((UTF-8) - (peek-char-and-len/utf8 port first-byte)) - ((ISO-8859-1) - (peek-char-and-len/iso-8859-1 port first-byte)) - (else - (peek-char-and-len/iconv port first-byte)))) - (lambda (char len) - (if (port-maybe-consume-initial-byte-order-mark port char len) - (peek-char-and-len port) - (values char len)))))))) + (case (%port-encoding port) + ((UTF-8) + (peek-char-and-len/utf8 port first-byte)) + ((ISO-8859-1) + (peek-char-and-len/iso-8859-1 port first-byte)) + (else + (peek-char-and-len/iconv port first-byte))))))) (define (%peek-char port) (call-with-values (lambda () (peek-char-and-len port)) From 0b4b4db9fa088b854331a4d1e6a6ba7e04429f07 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 5 May 2016 22:57:33 +0200 Subject: [PATCH 251/865] Speed up peek-char * module/ice-9/ports.scm (peek-char-and-len): Only inline fast path for UTF-8. --- module/ice-9/ports.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 41eb866e1..7dc13d707 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -304,7 +304,7 @@ interpret its input and output." (define-syntax-rule (decoding-error subr port) (throw 'decoding-error subr "input decoding error" EILSEQ port)) -(define-inlinable (peek-char-and-len/utf8 port first-byte) +(define (peek-char-and-len/utf8 port first-byte) (define (bad-utf8 len) (if (eq? (port-conversion-strategy port) 'substitute) (values #\? len) @@ -405,7 +405,9 @@ interpret its input and output." (let ((first-byte (logand first-byte #xff))) (case (%port-encoding port) ((UTF-8) - (peek-char-and-len/utf8 port first-byte)) + (if (< first-byte #x80) + (values (integer->char first-byte) 1) + (peek-char-and-len/utf8 port first-byte))) ((ISO-8859-1) (peek-char-and-len/iso-8859-1 port first-byte)) (else From bed7bdc19cb15d04e7200a3b0226ba2450f3db50 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 5 May 2016 23:03:04 +0200 Subject: [PATCH 252/865] Fix use of port-encoding * module/ice-9/ports.scm (clear-stream-start-for-bom-read): Fix to use %port-encoding, which works in symbols. --- module/ice-9/ports.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 7dc13d707..27bcdd855 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -227,7 +227,7 @@ interpret its input and output." (lp (1+ i))))))))) (when (and (port-clear-stream-start-for-bom-read port) (eq? io-mode 'text)) - (case (port-encoding port) + (case (%port-encoding port) ((UTF-8) (maybe-consume-bom utf8-bom)) ((UTF-16) From 13f2128587d5e3e99a99ea49b16855ffb1ab9399 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 7 May 2016 12:40:46 +0200 Subject: [PATCH 253/865] Fix port-clear-stream-start-for-bom-read bug * libguile/ports.c (scm_port_clear_stream_start_for_bom_read): Fix to return SCM_BOOL_F instead of 0. --- libguile/ports.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/ports.c b/libguile/ports.c index e82343672..c70185e99 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -2381,7 +2381,7 @@ SCM_DEFINE (scm_port_clear_stream_start_for_bom_read, pti = SCM_PORT_GET_INTERNAL (port); if (!pti->at_stream_start_for_bom_read) - return 0; + return SCM_BOOL_F; /* Maybe slurp off a byte-order marker. */ pt = SCM_PTAB_ENTRY (port); From d77b50476a340338615aa9f9952a2001f5f139f1 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 7 May 2016 12:41:07 +0200 Subject: [PATCH 254/865] Speed refactors to Scheme %peek-char * module/ice-9/ports.scm (peek-bytes): New helper. (peek-byte): Use peek-bytes helper. (decoding-error): Don't inline; no need. (decode-utf8, bad-utf8-len): New helpers. (peek-char-and-len/utf8): Use new helpers. (peek-char-and-len): No fast paths, and not inline. Peek-char has its own fast path. (%peek-char): Use helpers to make fast path. --- module/ice-9/ports.scm | 232 +++++++++++++++++++++++++---------------- 1 file changed, 140 insertions(+), 92 deletions(-) diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 27bcdd855..a222e834a 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -286,94 +286,134 @@ interpret its input and output." (lp buffered) (values buf buffered))))))))))))))) -(define-inlinable (peek-byte port) +(define-inlinable (peek-bytes port count kfast kslow) (let* ((buf (port-read-buffer port)) - (cur (port-buffer-cur buf))) - (if (< cur (port-buffer-end buf)) - (bytevector-u8-ref (port-buffer-bytevector buf) cur) - (call-with-values (lambda () (fill-input port)) + (cur (port-buffer-cur buf)) + (buffered (- (port-buffer-end buf) cur))) + (if (<= count buffered) + (kfast buf (port-buffer-bytevector buf) cur buffered) + (call-with-values (lambda () (fill-input port count)) (lambda (buf buffered) - (if (zero? buffered) - the-eof-object - (bytevector-u8-ref (port-buffer-bytevector buf) - (port-buffer-cur buf)))))))) + (kslow buf (port-buffer-bytevector buf) (port-buffer-cur buf) + buffered)))))) -;; GNU/Linux definition; fixme? -(define-syntax EILSEQ (identifier-syntax 84)) +(define (peek-byte port) + (peek-bytes port 1 + (lambda (buf bv cur buffered) + (bytevector-u8-ref bv cur)) + (lambda (buf bv cur buffered) + (and (> buffered 0) + (bytevector-u8-ref bv cur))))) -(define-syntax-rule (decoding-error subr port) +(define (decoding-error subr port) + ;; GNU/Linux definition; fixme? + (define EILSEQ 84) (throw 'decoding-error subr "input decoding error" EILSEQ port)) +(define-inlinable (decode-utf8 bv start avail u8_0 kt kf) + (cond + ((< u8_0 #x80) + (kt (integer->char u8_0) 1)) + ((and (<= #xc2 u8_0 #xdf) (<= 2 avail)) + (let ((u8_1 (bytevector-u8-ref bv (1+ start)))) + (if (= (logand u8_1 #xc0) #x80) + (kt (integer->char + (logior (ash (logand u8_0 #x1f) 6) + (logand u8_1 #x3f))) + 2) + (kf)))) + ((and (= (logand u8_0 #xf0) #xe0) (<= 3 avail)) + (let ((u8_1 (bytevector-u8-ref bv (+ start 1))) + (u8_2 (bytevector-u8-ref bv (+ start 2)))) + (if (and (= (logand u8_1 #xc0) #x80) + (= (logand u8_2 #xc0) #x80) + (case u8_0 + ((#xe0) (>= u8_1 #xa0)) + ((#xed) (>= u8_1 #x9f)) + (else #t))) + (kt (integer->char + (logior (ash (logand u8_0 #x0f) 12) + (ash (logand u8_1 #x3f) 6) + (logand u8_2 #x3f))) + 3) + (kf)))) + ((and (<= #xf0 u8_0 #xf4) (<= 4 avail)) + (let ((u8_1 (bytevector-u8-ref bv (+ start 1))) + (u8_2 (bytevector-u8-ref bv (+ start 2))) + (u8_3 (bytevector-u8-ref bv (+ start 3)))) + (if (and (= (logand u8_1 #xc0) #x80) + (= (logand u8_2 #xc0) #x80) + (= (logand u8_3 #xc0) #x80) + (case u8_0 + ((#xf0) (>= u8_1 #x90)) + ((#xf4) (>= u8_1 #x8f)) + (else #t))) + (kt (integer->char + (logior (ash (logand u8_0 #x07) 18) + (ash (logand u8_1 #x3f) 12) + (ash (logand u8_2 #x3f) 6) + (logand u8_3 #x3f))) + 4) + (kf)))) + (else (kf)))) + +(define (bad-utf8-len bv cur buffering first-byte) + (define (ref n) + (bytevector-u8-ref bv (+ cur 1))) + (cond + ((< first-byte #x80) 0) + ((<= #xc2 first-byte #xdf) + (cond + ((< buffering 2) 1) + ((not (= (logand (ref 1) #xc0) #x80)) 1) + (else 0))) + ((= (logand first-byte #xf0) #xe0) + (cond + ((< buffering 2) 1) + ((not (= (logand (ref 1) #xc0) #x80)) 1) + ((and (eq? first-byte #xe0) (< (ref 1) #xa0)) 1) + ((and (eq? first-byte #xed) (< (ref 1) #x9f)) 1) + ((< buffering 3) 2) + ((not (= (logand (ref 2) #xc0) #x80)) 2) + (else 0))) + ((<= #xf0 first-byte #xf4) + (cond + ((< buffering 2) 1) + ((not (= (logand (ref 1) #xc0) #x80)) 1) + ((and (eq? first-byte #xf0) (< (ref 1) #x90)) 1) + ((and (eq? first-byte #xf4) (< (ref 1) #x8f)) 1) + ((< buffering 3) 2) + ((not (= (logand (ref 2) #xc0) #x80)) 2) + ((< buffering 4) 3) + ((not (= (logand (ref 3) #xc0) #x80)) 3) + (else 0))) + (else 1))) + (define (peek-char-and-len/utf8 port first-byte) (define (bad-utf8 len) (if (eq? (port-conversion-strategy port) 'substitute) (values #\? len) (decoding-error "peek-char" port))) - (cond - ((< first-byte #x80) - (values (integer->char first-byte) 1)) - ((<= #xc2 first-byte #xdf) - (call-with-values (lambda () (fill-input port 2)) - (lambda (buf buffering) - (let ((bv (port-buffer-bytevector buf)) - (cur (port-buffer-cur buf))) - (define (ref n) - (bytevector-u8-ref bv (+ cur 1))) - (when (or (< buffering 2) - (not (= (logand (ref 1) #xc0) #x80))) - (bad-utf8 1)) - (values (integer->char - (logior (ash (logand first-byte #x1f) 6) - (logand (ref 1) #x3f))) - 2))))) - ((= (logand first-byte #xf0) #xe0) - (call-with-values (lambda () (fill-input port 3)) - (lambda (buf buffering) - (let ((bv (port-buffer-bytevector buf)) - (cur (port-buffer-cur buf))) - (define (ref n) - (bytevector-u8-ref bv (+ cur 1))) - (when (or (< buffering 2) - (not (= (logand (ref 1) #xc0) #x80)) - (and (eq? first-byte #xe0) (< (ref 1) #xa0)) - (and (eq? first-byte #xed) (< (ref 1) #x9f))) - (bad-utf8 1)) - (when (or (< buffering 3) - (not (= (logand (ref 2) #xc0) #x80))) - (bad-utf8 2)) - (values (integer->char - (logior (ash (logand first-byte #x0f) 12) - (ash (logand (ref 1) #x3f) 6) - (logand (ref 2) #x3f))) - 3))))) - ((<= #xf0 first-byte #xf4) - (call-with-values (lambda () (fill-input port 4)) - (lambda (buf buffering) - (let ((bv (port-buffer-bytevector buf)) - (cur (port-buffer-cur buf))) - (define (ref n) - (bytevector-u8-ref bv (+ cur 1))) - (when (or (< buffering 2) - (not (= (logand (ref 1) #xc0) #x80)) - (and (eq? first-byte #xf0) (< (ref 1) #x90)) - (and (eq? first-byte #xf4) (< (ref 1) #x8f))) - (bad-utf8 1)) - (when (or (< buffering 3) - (not (= (logand (ref 2) #xc0) #x80))) - (bad-utf8 2)) - (when (or (< buffering 4) - (not (= (logand (ref 3) #xc0) #x80))) - (bad-utf8 3)) - (values (integer->char - (logior (ash (logand first-byte #x07) 18) - (ash (logand (ref 1) #x3f) 12) - (ash (logand (ref 2) #x3f) 6) - (logand (ref 3) #x3f))) - 4))))) - (else - (bad-utf8 1)))) + (if (< first-byte #x80) + (values (integer->char first-byte) 1) + (call-with-values (lambda () + (fill-input port + (cond + ((<= #xc2 first-byte #xdf) 2) + ((= (logand first-byte #xf0) #xe0) 3) + (else 4)))) + (lambda (buf buffering) + (let* ((bv (port-buffer-bytevector buf)) + (cur (port-buffer-cur buf))) + (define (bad-utf8) + (let ((len (bad-utf8-len bv cur buffering first-byte))) + (when (zero? len) (error "internal error")) + (if (eq? (port-conversion-strategy port) 'substitute) + (values #\? len) + (decoding-error "peek-char" port)))) + (decode-utf8 bv cur buffering first-byte values bad-utf8)))))) -(define-inlinable (peek-char-and-len/iso-8859-1 port first-byte) +(define (peek-char-and-len/iso-8859-1 port first-byte) (values (integer->char first-byte) 1)) (define (peek-char-and-len/iconv port first-byte) @@ -398,25 +438,33 @@ interpret its input and output." (else (lp input-size)))))) -(define-inlinable (peek-char-and-len port) +(define (peek-char-and-len port) (let ((first-byte (peek-byte port))) - (if (eq? first-byte the-eof-object) - (values first-byte 0) - (let ((first-byte (logand first-byte #xff))) - (case (%port-encoding port) - ((UTF-8) - (if (< first-byte #x80) - (values (integer->char first-byte) 1) - (peek-char-and-len/utf8 port first-byte))) - ((ISO-8859-1) - (peek-char-and-len/iso-8859-1 port first-byte)) - (else - (peek-char-and-len/iconv port first-byte))))))) + (if (not first-byte) + (values the-eof-object 0) + (case (%port-encoding port) + ((UTF-8) + (peek-char-and-len/utf8 port first-byte)) + ((ISO-8859-1) + (peek-char-and-len/iso-8859-1 port first-byte)) + (else + (peek-char-and-len/iconv port first-byte)))))) (define (%peek-char port) - (call-with-values (lambda () (peek-char-and-len port)) - (lambda (char len) - char))) + (define (slow-path) + (call-with-values (lambda () (peek-char-and-len port)) + (lambda (char len) + char))) + (define (fast-path buf bv cur buffered) + (let ((u8 (bytevector-u8-ref bv cur)) + (enc (%port-encoding port))) + (case enc + ((UTF-8) (decode-utf8 bv cur buffered u8 (lambda (char len) char) + slow-path)) + ((ISO-8859-1) (integer->char u8)) + (else (slow-path))))) + (peek-bytes port 1 fast-path + (lambda (buf bv cur buffered) (slow-path)))) From 83e5ccb02f1edc3a288409558be86d7dec96349f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 10 May 2016 11:08:41 +0200 Subject: [PATCH 255/865] Fix bug in trampoline_to_c_read * libguile/ports.c (trampoline_to_c_read): Fix bug comparing SCM values. --- libguile/ports.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/ports.c b/libguile/ports.c index c70185e99..49e10792f 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -234,7 +234,7 @@ trampoline_to_c_read (SCM port, SCM dst, SCM start, SCM count) SCM_VALIDATE_OPPORT (1, port); c_start = scm_to_size_t (start); c_count = scm_to_size_t (count); - SCM_ASSERT_RANGE (2, start, start <= count); + SCM_ASSERT_RANGE (2, start, c_start <= c_count); SCM_ASSERT_RANGE (3, count, c_start+c_count <= scm_c_bytevector_length (dst)); return scm_from_size_t From 1953d2903801806a2648e29e284c694459ae9cf5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 10 May 2016 11:34:17 +0200 Subject: [PATCH 256/865] Decoding errors do not advance read pointer * libguile/ports.c (scm_getc): If the port conversion strategy is 'error, signal an error before advancing the read pointer. This is a change from previous behavior; before, we advanced the read pointer under an understanding that that was what R6RS required. But, that seems to be not the case. * test-suite/tests/ports.test ("string ports"): Update decoding-error tests to assume that read-char with an error doesn't advance the read pointer. * test-suite/tests/rdelim.test ("read-line"): Likewise. --- libguile/ports.c | 26 +++++++------------------- test-suite/tests/ports.test | 19 +++++++++++++++---- test-suite/tests/rdelim.test | 5 ++--- 3 files changed, 24 insertions(+), 26 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 49e10792f..6b9c4f5db 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1811,34 +1811,22 @@ peek_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) return err; } -static SCM_C_INLINE int -get_codepoint (SCM port, scm_t_wchar *codepoint) -{ - int err; - size_t len = 0; - scm_t_port *pt = SCM_PTAB_ENTRY (port); - - err = peek_codepoint (port, codepoint, &len); - scm_port_buffer_did_take (pt->read_buf, len); - if (*codepoint == EOF) - scm_i_clear_pending_eof (port); - update_port_lf (*codepoint, port); - return err; -} - /* Read a codepoint from PORT and return it. */ scm_t_wchar scm_getc (SCM port) #define FUNC_NAME "scm_getc" { int err; - scm_t_wchar codepoint; + size_t len = 0; + scm_t_wchar codepoint = EOF; - err = get_codepoint (port, &codepoint); + err = peek_codepoint (port, &codepoint, &len); if (SCM_UNLIKELY (err != 0)) - /* At this point PORT should point past the invalid encoding, as per - R6RS-lib Section 8.2.4. */ scm_decoding_error (FUNC_NAME, err, "input decoding error", port); + scm_port_buffer_did_take (SCM_PTAB_ENTRY (port)->read_buf, len); + if (codepoint == EOF) + scm_i_clear_pending_eof (port); + update_port_lf (codepoint, port); return codepoint; } diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index 33050fd7f..3bb001e4d 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -822,21 +822,32 @@ ;; Mini DSL to test decoding error handling. (letrec-syntax ((decoding-error? (syntax-rules () - ((_ port exp) + ((_ port proc) (catch 'decoding-error (lambda () - (pk 'exp exp) + (pk 'proc (proc port)) #f) (lambda (key subr message errno p) + (define (skip-over-error) + (let ((strategy (port-conversion-strategy p))) + (set-port-conversion-strategy! p 'substitute) + ;; If `proc' is `read-char', this will + ;; skip over the bad bytes. + (let ((c (proc p))) + (unless (eqv? c #\?) + (error "unexpected char" c)) + (set-port-conversion-strategy! p strategy) + #t))) (and (eq? p port) - (not (= 0 errno)))))))) + (not (= 0 errno)) + (skip-over-error))))))) (make-check (syntax-rules (-> error eof) ((_ port (proc -> error)) (if (eq? 'substitute (port-conversion-strategy port)) (eqv? (proc port) #\?) - (decoding-error? port (proc port)))) + (decoding-error? port proc))) ((_ port (proc -> eof)) (eof-object? (proc port))) ((_ port (proc -> char)) diff --git a/test-suite/tests/rdelim.test b/test-suite/tests/rdelim.test index 617e65167..de384c508 100644 --- a/test-suite/tests/rdelim.test +++ b/test-suite/tests/rdelim.test @@ -19,7 +19,7 @@ (define-module (test-suite test-rdelim) #:use-module (ice-9 rdelim) - #:use-module ((rnrs io ports) #:select (open-bytevector-input-port)) + #:use-module ((rnrs io ports) #:select (open-bytevector-input-port get-u8)) #:use-module (test-suite lib)) (with-test-prefix "read-line" @@ -79,8 +79,7 @@ #f) (lambda (key subr message err port) (and (eq? port p) - - ;; PORT should now point past the error. + (eqv? (get-u8 p) 255) (string=? (read-line p) "BCD") (eof-object? (read-line p))))))) From 08c67dbef87e343de19eb744b076d24b31f0508c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 10 May 2016 12:09:30 +0200 Subject: [PATCH 257/865] Simplify decoding error handling * libguile/ports.c (peek_utf8_codepoint, peek_latin1_codepoint): (peek_iconv_codepoint, peek_codepoint): Refactor to push error handling to the leaves, where errors happen. Just return the (possibly substituted) codepoint, without an error code; if there's really an error, we should raise it. (scm_getc, scm_peek_char): Adapt. --- libguile/ports.c | 201 +++++++++++++++++++++-------------------------- 1 file changed, 88 insertions(+), 113 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 6b9c4f5db..bbe38678a 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1598,27 +1598,27 @@ utf8_to_codepoint (const scm_t_uint8 *utf8_buf, size_t size) return codepoint; } -/* Peek a UTF-8 sequence from PORT. On success, return 0, set - *CODEPOINT to the codepoint that was read, and set *LEN to the length - in bytes. Return `EILSEQ' on error, setting *LEN to the shortest - prefix that cannot begin a valid UTF-8 sequence. */ -static int -peek_utf8_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) +/* Peek a UTF-8 sequence from PORT. On success, return the codepoint + that was read, and set *LEN to the length in bytes. If there was a + decoding error and the port conversion strategy was `substitute', + then return #\? and set *LEN to the length of the shortest prefix + that cannot begin a valid UTF-8 sequence. Otherwise signal an + error. */ +static scm_t_wchar +peek_utf8_codepoint (SCM port, size_t *len) { +#define DECODING_ERROR(bytes) \ + do { *len = bytes; goto decoding_error; } while (0) +#define RETURN(bytes, codepoint) \ + do { *len = bytes; return codepoint; } while (0) + int first_byte; first_byte = peek_byte_or_eof (port); if (first_byte == EOF) - { - *codepoint = EOF; - return 0; - } + RETURN (0, EOF); else if (first_byte < 0x80) - { - *codepoint = first_byte; - *len = 1; - return 0; - } + RETURN (1, first_byte); else if (first_byte >= 0xc2 && first_byte <= 0xdf) { SCM read_buf = scm_fill_input (port, 2); @@ -1626,14 +1626,9 @@ peek_utf8_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) const scm_t_uint8 *ptr = scm_port_buffer_take_pointer (read_buf); if (can_take < 2 || (ptr[1] & 0xc0) != 0x80) - { - *len = 1; - return EILSEQ; - } + DECODING_ERROR (1); - *codepoint = (first_byte & 0x1f) << 6UL | (ptr[1] & 0x3f); - *len = 2; - return 0; + RETURN (2, (first_byte & 0x1f) << 6UL | (ptr[1] & 0x3f)); } else if ((first_byte & 0xf0) == 0xe0) { @@ -1644,22 +1639,15 @@ peek_utf8_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) if (can_take < 2 || (ptr[1] & 0xc0) != 0x80 || (ptr[0] == 0xe0 && ptr[1] < 0xa0) || (ptr[0] == 0xed && ptr[1] > 0x9f)) - { - *len = 1; - return EILSEQ; - } + DECODING_ERROR (1); if (can_take < 3 || (ptr[2] & 0xc0) != 0x80) - { - *len = 2; - return EILSEQ; - } + DECODING_ERROR (2); - *codepoint = ((scm_t_wchar) ptr[0] & 0x0f) << 12UL - | ((scm_t_wchar) ptr[1] & 0x3f) << 6UL - | (ptr[2] & 0x3f); - *len = 3; - return 0; + RETURN (3, + ((scm_t_wchar) ptr[0] & 0x0f) << 12UL + | ((scm_t_wchar) ptr[1] & 0x3f) << 6UL + | (ptr[2] & 0x3f)); } else if (first_byte >= 0xf0 && first_byte <= 0xf4) { @@ -1670,56 +1658,55 @@ peek_utf8_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) if (can_take < 2 || (ptr[1] & 0xc0) != 0x80 || (ptr[0] == 0xf0 && ptr[1] < 0x90) || (ptr[0] == 0xf4 && ptr[1] > 0x8f)) - { - *len = 1; - return EILSEQ; - } + DECODING_ERROR (1); if (can_take < 3 || (ptr[2] & 0xc0) != 0x80) - { - *len = 2; - return EILSEQ; - } + DECODING_ERROR (2); if (can_take < 4 || (ptr[3] & 0xc0) != 0x80) - { - *len = 3; - return EILSEQ; - } + DECODING_ERROR (3); - *codepoint = ((scm_t_wchar) ptr[0] & 0x07) << 18UL - | ((scm_t_wchar) ptr[1] & 0x3f) << 12UL - | ((scm_t_wchar) ptr[2] & 0x3f) << 6UL - | (ptr[3] & 0x3f); - *len = 4; - return 0; + RETURN (4, + ((scm_t_wchar) ptr[0] & 0x07) << 18UL + | ((scm_t_wchar) ptr[1] & 0x3f) << 12UL + | ((scm_t_wchar) ptr[2] & 0x3f) << 6UL + | (ptr[3] & 0x3f)); } else - { - *len = 1; - return EILSEQ; - } + DECODING_ERROR (1); + + decoding_error: + if (scm_is_eq (SCM_PTAB_ENTRY (port)->conversion_strategy, sym_substitute)) + /* *len already set. */ + return '?'; + + scm_decoding_error ("peek-char", EILSEQ, "input decoding error", port); + /* Not reached. */ + return 0; +#undef DECODING_ERROR +#undef RETURN } /* Peek an ISO-8859-1 codepoint (a byte) from PORT. On success, return - 0, set *CODEPOINT to the codepoint that was peeked, and set *LEN to - the length in bytes. No encoding error is possible. */ -static int -peek_latin1_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) + the codepoint, and set *LEN to 1. Otherwise on EOF set *LEN to 0. */ +static scm_t_wchar +peek_latin1_codepoint (SCM port, size_t *len) { - *codepoint = peek_byte_or_eof (port); - if (*codepoint == EOF) - *len = 0; - else - *len = 1; - return 0; + scm_t_wchar ret = peek_byte_or_eof (port); + + *len = ret == EOF ? 0 : 1; + + return ret; } /* Peek a codepoint from PORT, decoding it through iconv. On success, - return 0, set *CODEPOINT to the codepoint that was peeked, and set - *LEN to the length in bytes. Return `EILSEQ' on decoding error. */ -static int -peek_iconv_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) + return the codepoint and set *LEN to the length in bytes. If there + was a decoding error and the port conversion strategy was + `substitute', then return #\? and set *LEN to the length of the + shortest prefix that cannot begin a valid UTF-8 sequence. Otherwise + signal an error. */ +static scm_t_wchar +peek_iconv_codepoint (SCM port, size_t *len) { scm_t_iconv_descriptors *id; scm_t_uint8 utf8_buf[SCM_MBCHAR_BUF_SIZE]; @@ -1736,16 +1723,13 @@ peek_iconv_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) if (scm_port_buffer_can_take (read_buf) <= input_size) { + *len = input_size; if (input_size == 0) /* Normal EOF. */ - { - *codepoint = (scm_t_wchar) EOF; - *len = 0; - return 0; - } - else - /* EOF found in the middle of a multibyte character. */ - return EILSEQ; + return EOF; + + /* EOF found in the middle of a multibyte character. */ + goto decoding_error; } input_size++; @@ -1764,8 +1748,9 @@ peek_iconv_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) /* The input byte sequence did not form a complete character. Read another byte and try again. */ continue; - else - return err; + + *len = input_size; + goto decoding_error; } else { @@ -1779,36 +1764,35 @@ peek_iconv_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) /* iconv generated output. Convert the UTF8_BUF sequence to a Unicode code point. */ - *codepoint = utf8_to_codepoint (utf8_buf, output_size); *len = input_size; - return 0; + return utf8_to_codepoint (utf8_buf, output_size); } } + + decoding_error: + if (scm_is_eq (SCM_PTAB_ENTRY (port)->conversion_strategy, sym_substitute)) + return '?'; + + scm_decoding_error ("peek-char", EILSEQ, "input decoding error", + port); + /* Not reached. */ + return 0; } /* Peek a codepoint from PORT and return it in *CODEPOINT. Set *LEN to the length in bytes of that representation. Return 0 on success and an errno value on error. */ -static SCM_C_INLINE int -peek_codepoint (SCM port, scm_t_wchar *codepoint, size_t *len) +static SCM_C_INLINE scm_t_wchar +peek_codepoint (SCM port, size_t *len) { - int err; - scm_t_port *pt = SCM_PTAB_ENTRY (port); + SCM encoding = SCM_PTAB_ENTRY (port)->encoding; - if (scm_is_eq (pt->encoding, sym_UTF_8)) - err = peek_utf8_codepoint (port, codepoint, len); - else if (scm_is_eq (pt->encoding, sym_ISO_8859_1)) - err = peek_latin1_codepoint (port, codepoint, len); + if (scm_is_eq (encoding, sym_UTF_8)) + return peek_utf8_codepoint (port, len); + else if (scm_is_eq (encoding, sym_ISO_8859_1)) + return peek_latin1_codepoint (port, len); else - err = peek_iconv_codepoint (port, codepoint, len); - - if (err != 0 && scm_is_eq (pt->conversion_strategy, sym_substitute)) - { - *codepoint = '?'; - err = 0; - } - - return err; + return peek_iconv_codepoint (port, len); } /* Read a codepoint from PORT and return it. */ @@ -1816,13 +1800,10 @@ scm_t_wchar scm_getc (SCM port) #define FUNC_NAME "scm_getc" { - int err; size_t len = 0; - scm_t_wchar codepoint = EOF; + scm_t_wchar codepoint; - err = peek_codepoint (port, &codepoint, &len); - if (SCM_UNLIKELY (err != 0)) - scm_decoding_error (FUNC_NAME, err, "input decoding error", port); + codepoint = peek_codepoint (port, &len); scm_port_buffer_did_take (SCM_PTAB_ENTRY (port)->read_buf, len); if (codepoint == EOF) scm_i_clear_pending_eof (port); @@ -2009,7 +1990,6 @@ SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0, "sequence when the error is raised.\n") #define FUNC_NAME s_scm_peek_char { - int err; scm_t_wchar c; size_t len = 0; @@ -2017,14 +1997,9 @@ SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0, port = scm_current_input_port (); SCM_VALIDATE_OPINPORT (1, port); - err = peek_codepoint (port, &c, &len); + c = peek_codepoint (port, &len); - if (err == 0) - return c == EOF ? SCM_EOF_VAL : SCM_MAKE_CHAR (c); - - scm_decoding_error (FUNC_NAME, err, "input decoding error", port); - /* Not reached. */ - return SCM_BOOL_F; + return c == EOF ? SCM_EOF_VAL : SCM_MAKE_CHAR (c); } #undef FUNC_NAME From 8ee189980de6d86fa270775b4bc4020352596d98 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 10 May 2016 12:45:56 +0200 Subject: [PATCH 258/865] Factor out iconv to port-decode-char * libguile/ports.c (scm_port_decode_char): New helper, exported to (ice-9 ports). (peek_iconv_codepoint): Use scm_port_decode_char. --- libguile/ports.c | 133 ++++++++++++++++++++++++++++------------------- 1 file changed, 80 insertions(+), 53 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index bbe38678a..c81bf9a97 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1699,6 +1699,62 @@ peek_latin1_codepoint (SCM port, size_t *len) return ret; } +SCM_INTERNAL SCM scm_port_decode_char (SCM, SCM, SCM, SCM); +SCM_DEFINE (scm_port_decode_char, "port-decode-char", 4, 0, 0, + (SCM port, SCM bv, SCM start, SCM count), + "") +#define FUNC_NAME s_scm_port_decode_char +{ + char *input, *output; + scm_t_uint8 utf8_buf[SCM_MBCHAR_BUF_SIZE]; + scm_t_iconv_descriptors *id; + size_t c_start, c_count; + size_t input_left, output_left, done; + + SCM_VALIDATE_OPINPORT (1, port); + SCM_VALIDATE_BYTEVECTOR (2, bv); + c_start = scm_to_size_t (start); + c_count = scm_to_size_t (count); + SCM_ASSERT_RANGE (3, start, c_start <= SCM_BYTEVECTOR_LENGTH (bv)); + SCM_ASSERT_RANGE (4, count, c_count <= SCM_BYTEVECTOR_LENGTH (bv) - c_start); + + id = scm_i_port_iconv_descriptors (port); + input = (char *) SCM_BYTEVECTOR_CONTENTS (bv) + c_start; + input_left = c_count; + output = (char *) utf8_buf; + output_left = sizeof (utf8_buf); + + /* FIXME: locking! */ + done = iconv (id->input_cd, &input, &input_left, &output, &output_left); + + if (done == (size_t) -1) + { + int err = errno; + if (err == EINVAL) + /* The input byte sequence did not form a complete + character. Read another byte and try again. */ + return SCM_BOOL_F; + else if (scm_is_eq (SCM_PTAB_ENTRY (port)->conversion_strategy, + sym_substitute)) + return SCM_MAKE_CHAR ('?'); + else + scm_decoding_error ("decode-char", err, "input decoding error", port); + } + + { + size_t output_size = sizeof (utf8_buf) - output_left; + if (output_size == 0) + /* iconv consumed some bytes without producing any output. + Most likely this means that a Unicode byte-order mark + (BOM) was consumed. In any case, keep going until we get + output. */ + return SCM_BOOL_F; + + return SCM_MAKE_CHAR (utf8_to_codepoint (utf8_buf, output_size)); + } +} +#undef FUNC_NAME + /* Peek a codepoint from PORT, decoding it through iconv. On success, return the codepoint and set *LEN to the length in bytes. If there was a decoding error and the port conversion strategy was @@ -1708,75 +1764,46 @@ peek_latin1_codepoint (SCM port, size_t *len) static scm_t_wchar peek_iconv_codepoint (SCM port, size_t *len) { - scm_t_iconv_descriptors *id; - scm_t_uint8 utf8_buf[SCM_MBCHAR_BUF_SIZE]; size_t input_size = 0; + SCM maybe_char = SCM_BOOL_F; - for (;;) + while (scm_is_false (maybe_char)) { - SCM read_buf; - char *input, *output; - size_t input_left, output_left, done; - - read_buf = scm_fill_input (port, input_size + 1); - id = scm_i_port_iconv_descriptors (port); + SCM read_buf = scm_fill_input (port, input_size + 1); if (scm_port_buffer_can_take (read_buf) <= input_size) { *len = input_size; if (input_size == 0) /* Normal EOF. */ - return EOF; + { + /* Make sure iconv descriptors have been opened even if + there were no bytes, to be sure that a decoding error + is signalled if the encoding itself was invalid. */ + scm_i_port_iconv_descriptors (port); + return EOF; + } /* EOF found in the middle of a multibyte character. */ - goto decoding_error; + if (scm_is_eq (SCM_PTAB_ENTRY (port)->conversion_strategy, + sym_substitute)) + return '?'; + + scm_decoding_error ("peek-char", EILSEQ, + "input decoding error", port); + /* Not reached. */ + return 0; } input_size++; - input = (char *) scm_port_buffer_take_pointer (read_buf); - input_left = input_size; - output = (char *) utf8_buf; - output_left = sizeof (utf8_buf); - - /* FIXME: locking! */ - done = iconv (id->input_cd, &input, &input_left, &output, &output_left); - - if (done == (size_t) -1) - { - int err = errno; - if (err == EINVAL) - /* The input byte sequence did not form a complete - character. Read another byte and try again. */ - continue; - - *len = input_size; - goto decoding_error; - } - else - { - size_t output_size = sizeof (utf8_buf) - output_left; - if (output_size == 0) - /* iconv consumed some bytes without producing any output. - Most likely this means that a Unicode byte-order mark - (BOM) was consumed. In any case, keep going until we get - output. */ - continue; - - /* iconv generated output. Convert the UTF8_BUF sequence - to a Unicode code point. */ - *len = input_size; - return utf8_to_codepoint (utf8_buf, output_size); - } + maybe_char = scm_port_decode_char (port, + scm_port_buffer_bytevector (read_buf), + scm_port_buffer_cur (read_buf), + SCM_I_MAKINUM (input_size)); } - decoding_error: - if (scm_is_eq (SCM_PTAB_ENTRY (port)->conversion_strategy, sym_substitute)) - return '?'; - - scm_decoding_error ("peek-char", EILSEQ, "input decoding error", - port); - /* Not reached. */ - return 0; + *len = input_size; + return SCM_CHAR (maybe_char); } /* Peek a codepoint from PORT and return it in *CODEPOINT. Set *LEN to From 837a7e0810f27c2c00991015836fc45925d76fd7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 10 May 2016 12:48:10 +0200 Subject: [PATCH 259/865] Scheme peek-char can handle iconv encodings * module/ice-9/ports.scm (peek-char-and-len/iconv): Fully implement. --- module/ice-9/ports.scm | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index a222e834a..6078b6a1d 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -417,22 +417,21 @@ interpret its input and output." (values (integer->char first-byte) 1)) (define (peek-char-and-len/iconv port first-byte) - (define (bad-input len) - (if (eq? (port-conversion-strategy port) 'substitute) - (values #\? len) - (decoding-error "peek-char" port))) (let lp ((prev-input-size 0)) (let* ((input-size (1+ prev-input-size)) (buf (fill-input port input-size)) (cur (port-buffer-cur buf))) (cond - ((<= (- (port-buffer-end buf) cur) prev-input-size) - (if (zero? prev-input-size) - (values the-eof-object 0) - (bad-input prev-input-size))) - ;; fixme: takes port arg??? - ((iconv1 port (port-buffer-bytevector buf) cur input-size - (port-conversion-strategy port)) + ((< (- (port-buffer-end buf) cur) input-size) + ;; Buffer failed to fill; EOF, possibly premature. + (cond + ((zero? prev-input-size) + (values the-eof-object 0)) + ((eq? (port-conversion-strategy port) 'substitute) + (values #\? prev-input-size)) + (else + (decoding-error "peek-char" port)))) + ((port-decode-char port (port-buffer-bytevector buf) cur input-size) => (lambda (char) (values char input-size))) (else From 502e3a221319bcb89a1850676445b6c026cec06a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 10 May 2016 15:36:06 +0200 Subject: [PATCH 260/865] Fix port-clear-stream-start-for-bom-read logic. * libguile/ports.c (scm_port_clear_stream_start_for_bom_read): Fix logic. --- libguile/ports.c | 7 ------- 1 file changed, 7 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index c81bf9a97..69afb4e9a 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -2370,13 +2370,6 @@ SCM_DEFINE (scm_port_clear_stream_start_for_bom_read, SCM_VALIDATE_PORT (1, port); pti = SCM_PORT_GET_INTERNAL (port); - if (!pti->at_stream_start_for_bom_read) - return SCM_BOOL_F; - - /* Maybe slurp off a byte-order marker. */ - pt = SCM_PTAB_ENTRY (port); - pti->at_stream_start_for_bom_read = 0; - if (!pti->at_stream_start_for_bom_read) return SCM_BOOL_F; From 0dd18191bc864a53230963ceb485d7815e058006 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 10 May 2016 15:36:31 +0200 Subject: [PATCH 261/865] clear-stream-start-for-bom-read refactor * module/ice-9/ports.scm (clear-stream-start-for-bom-read): Use the "buffered" value that fill-input returns. --- module/ice-9/ports.scm | 27 ++++++++++++++------------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 6078b6a1d..ad9c088a4 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -212,19 +212,20 @@ interpret its input and output." (define (clear-stream-start-for-bom-read port io-mode) (define (maybe-consume-bom bom) (and (eq? (peek-byte port) (bytevector-u8-ref bom 0)) - (let* ((buf (fill-input port (bytevector-length bom))) - (bv (port-buffer-bytevector buf)) - (cur (port-buffer-cur bv))) - (and (<= (bytevector-length bv) - (- (port-buffer-end buf) cur)) - (let lp ((i 1)) - (if (= i (bytevector-length bom)) - (begin - (set-port-buffer-cur! buf (+ cur i)) - #t) - (and (eq? (bytevector-u8-ref bv (+ cur i)) - (bytevector-u8-ref bom i)) - (lp (1+ i))))))))) + (call-with-values (lambda () + (fill-input port (bytevector-length bom))) + (lambda (buf buffered) + (and (<= (bytevector-length bom) buffered) + (let ((bv (port-buffer-bytevector buf)) + (cur (port-buffer-cur buf))) + (let lp ((i 1)) + (if (= i (bytevector-length bom)) + (begin + (set-port-buffer-cur! buf (+ cur i)) + #t) + (and (eq? (bytevector-u8-ref bv (+ cur i)) + (bytevector-u8-ref bom i)) + (lp (1+ i))))))))))) (when (and (port-clear-stream-start-for-bom-read port) (eq? io-mode 'text)) (case (%port-encoding port) From 9c02ede07e0f614440ec4741ce925ef00a1a7e1d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 10 May 2016 15:37:11 +0200 Subject: [PATCH 262/865] Fix bad-utf8-len bug. * module/ice-9/ports.scm (bad-utf8-len): Fix bug. --- module/ice-9/ports.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index ad9c088a4..e672b2c9b 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -360,7 +360,7 @@ interpret its input and output." (define (bad-utf8-len bv cur buffering first-byte) (define (ref n) - (bytevector-u8-ref bv (+ cur 1))) + (bytevector-u8-ref bv (+ cur n))) (cond ((< first-byte #x80) 0) ((<= #xc2 first-byte #xdf) From 3ccfa213c10af1db748597123ee982b4e4069275 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 10 May 2016 15:37:42 +0200 Subject: [PATCH 263/865] peek-char-and-len/iconv uses both returns from fill-input * module/ice-9/ports.scm (peek-char-and-len/iconv): Use buffered value from fill-input. --- module/ice-9/ports.scm | 37 +++++++++++++++++++------------------ 1 file changed, 19 insertions(+), 18 deletions(-) diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index e672b2c9b..742e7025e 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -419,24 +419,25 @@ interpret its input and output." (define (peek-char-and-len/iconv port first-byte) (let lp ((prev-input-size 0)) - (let* ((input-size (1+ prev-input-size)) - (buf (fill-input port input-size)) - (cur (port-buffer-cur buf))) - (cond - ((< (- (port-buffer-end buf) cur) input-size) - ;; Buffer failed to fill; EOF, possibly premature. - (cond - ((zero? prev-input-size) - (values the-eof-object 0)) - ((eq? (port-conversion-strategy port) 'substitute) - (values #\? prev-input-size)) - (else - (decoding-error "peek-char" port)))) - ((port-decode-char port (port-buffer-bytevector buf) cur input-size) - => (lambda (char) - (values char input-size))) - (else - (lp input-size)))))) + (let ((input-size (1+ prev-input-size))) + (call-with-values (lambda () (fill-input port input-size)) + (lambda (buf buffered) + (cond + ((< buffered input-size) + ;; Buffer failed to fill; EOF, possibly premature. + (cond + ((zero? prev-input-size) + (values the-eof-object 0)) + ((eq? (port-conversion-strategy port) 'substitute) + (values #\? prev-input-size)) + (else + (decoding-error "peek-char" port)))) + ((port-decode-char port (port-buffer-bytevector buf) + (port-buffer-cur buf) input-size) + => (lambda (char) + (values char input-size))) + (else + (lp input-size)))))))) (define (peek-char-and-len port) (let ((first-byte (peek-byte port))) From ab21af544a6bc97a7cef4605365bd8799424200b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 10 May 2016 15:38:11 +0200 Subject: [PATCH 264/865] %peek-char port argument optional. * module/ice-9/ports.scm (%peek-char): Port argument is optional. --- module/ice-9/ports.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 742e7025e..cdfd011ed 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -451,7 +451,7 @@ interpret its input and output." (else (peek-char-and-len/iconv port first-byte)))))) -(define (%peek-char port) +(define* (%peek-char #:optional (port (current-input-port))) (define (slow-path) (call-with-values (lambda () (peek-char-and-len port)) (lambda (char len) From d28d1a57bf0ff50b4292a64bc4146f9a9488c3d5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 10 May 2016 15:38:30 +0200 Subject: [PATCH 265/865] Implement read-char in Scheme. * module/ice-9/ports.scm (%read-char): New function. --- module/ice-9/ports.scm | 45 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index cdfd011ed..43283e7e4 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -467,6 +467,51 @@ interpret its input and output." (peek-bytes port 1 fast-path (lambda (buf bv cur buffered) (slow-path)))) +(define* (%read-char #:optional (port (current-input-port))) + (define (update-position! char) + (case char + ((#\alarm) #t) ; No change. + ((#\backspace) + (let ((col (port-column port))) + (when (> col 0) + (set-port-column! port (1- col))))) + ((#\newline) + (set-port-line! port (1+ (port-line port))) + (set-port-column! port 0)) + ((#\return) + (set-port-column! port 0)) + ((#\tab) + (let ((col (port-column port))) + (set-port-column! port (- (+ col 8) (remainder col 8))))) + (else + (set-port-column! port (1+ (port-column port))))) + char) + (define (slow-path) + (call-with-values (lambda () (peek-char-and-len port)) + (lambda (char len) + (let ((buf (port-read-buffer port))) + (set-port-buffer-cur! buf (+ (port-buffer-cur buf) len)) + (if (eq? char the-eof-object) + (set-port-buffer-has-eof?! buf #f) + (update-position! char)) + char)))) + (define (fast-path buf bv cur buffered) + (let ((u8 (bytevector-u8-ref bv cur)) + (enc (%port-encoding port))) + (case enc + ((UTF-8) + (decode-utf8 bv cur buffered u8 + (lambda (char len) + (set-port-buffer-cur! buf (+ cur len)) + (update-position! char)) + slow-path)) + ((ISO-8859-1) + (set-port-buffer-cur! buf (+ cur 1)) + (update-position! (integer->char u8))) + (else (slow-path))))) + (peek-bytes port 1 fast-path + (lambda (buf bv cur buffered) (slow-path)))) + ;;; Current ports as parameters. From a8fe0f42f3483e79ac633d2e7451ad186d5a3b79 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 10 May 2016 16:30:50 +0200 Subject: [PATCH 266/865] %read-char speedup * module/ice-9/ports.scm (%read-char): Always call update-position! with the same continuation, so that it will contify. --- module/ice-9/ports.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 43283e7e4..27a57089b 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -492,9 +492,10 @@ interpret its input and output." (let ((buf (port-read-buffer port))) (set-port-buffer-cur! buf (+ (port-buffer-cur buf) len)) (if (eq? char the-eof-object) - (set-port-buffer-has-eof?! buf #f) - (update-position! char)) - char)))) + (begin + (set-port-buffer-has-eof?! buf #f) + char) + (update-position! char)))))) (define (fast-path buf bv cur buffered) (let ((u8 (bytevector-u8-ref bv cur)) (enc (%port-encoding port))) From df0dade9b7b3e1d488a5049d3cc730abd67c6692 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 12 May 2016 08:57:01 +0200 Subject: [PATCH 267/865] Implement lookahead-u8, get-u8 in Scheme * module/ice-9/ports.scm (%lookahead-u8, %get-u8): Scheme implementations. --- module/ice-9/ports.scm | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 27a57089b..9d2e36d40 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -306,6 +306,27 @@ interpret its input and output." (and (> buffered 0) (bytevector-u8-ref bv cur))))) +(define* (%lookahead-u8 port) + (define (fast-path buf bv cur buffered) + (bytevector-u8-ref bv cur)) + (define (slow-path buf bv cur buffered) + (if (zero? buffered) + the-eof-object + (fast-path buf bv cur buffered))) + (peek-bytes port 1 fast-path slow-path)) + +(define* (%get-u8 port) + (define (fast-path buf bv cur buffered) + (set-port-buffer-cur! buf (1+ cur)) + (bytevector-u8-ref bv cur)) + (define (slow-path buf bv cur buffered) + (if (zero? buffered) + (begin + (set-port-buffer-has-eof?! buf #f) + the-eof-object) + (fast-path buf bv cur buffered))) + (peek-bytes port 1 fast-path slow-path)) + (define (decoding-error subr port) ;; GNU/Linux definition; fixme? (define EILSEQ 84) From d1bb400c3f378f28a72eb9e39178d9fed1d44b2d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 13 May 2016 08:53:36 +0200 Subject: [PATCH 268/865] Beginnings of shunting ports-in-scheme off to a module * libguile/ports.c (scm_specialize_port_encoding_x): Add some sanity checks. (scm_unget_bytes): Use scm_expand_port_read_buffer_x. (port_clear_stream_start_for_bom_read): Use scm_specialize_port_encoding_x. (scm_fill_input): Use scm_expand_port_read_buffer_x. (scm_expand_port_read_buffer_x): Rename from scm_set_port_read_buffer_x and actually expand the buffer. * libguile/ports.h: Adapt to scm_expand_port_read_buffer_x change. * module/ice-9/ports.scm: Remove ports-in-scheme stuff, and instead expose the ports internals via an auxiliary module. This will let ports-in-scheme live in a module during Guile 2.2. --- libguile/ports.c | 99 ++++++---- libguile/ports.h | 3 +- module/ice-9/ports.scm | 397 ++++------------------------------------- 3 files changed, 105 insertions(+), 394 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 69afb4e9a..1ad5db096 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1147,6 +1147,21 @@ SCM_DEFINE (scm_specialize_port_encoding_x, SCM_VALIDATE_PORT (1, port); SCM_VALIDATE_SYMBOL (2, encoding); + if (scm_is_eq (SCM_PTAB_ENTRY (port)->encoding, sym_UTF_16)) + { + if (!scm_is_eq (encoding, sym_UTF_16LE) + && !scm_is_eq (encoding, sym_UTF_16BE)) + SCM_OUT_OF_RANGE (2, encoding); + } + else if (scm_is_eq (SCM_PTAB_ENTRY (port)->encoding, sym_UTF_32)) + { + if (!scm_is_eq (encoding, sym_UTF_32LE) + && !scm_is_eq (encoding, sym_UTF_32BE)) + SCM_OUT_OF_RANGE (2, encoding); + } + else + SCM_OUT_OF_RANGE (2, encoding); + prepare_iconv_descriptors (port, encoding); return SCM_UNSPECIFIED; @@ -1898,19 +1913,11 @@ scm_unget_bytes (const scm_t_uint8 *buf, size_t len, SCM port) else { /* Bah, have to expand the read_buf for the putback. */ - SCM new_buf; - while (size < len + buffered) size *= 2; - - new_buf = scm_c_make_port_buffer (size); - scm_port_buffer_reset_end (new_buf); - scm_port_buffer_set_has_eof_p (new_buf, - scm_port_buffer_has_eof_p (read_buf)); - scm_port_buffer_putback (new_buf, - scm_port_buffer_take_pointer (read_buf), - buffered); - pt->read_buf = read_buf = new_buf; + read_buf = scm_expand_port_read_buffer_x (port, + scm_from_size_t (size), + SCM_BOOL_T); } } @@ -2323,16 +2330,16 @@ port_clear_stream_start_for_bom_read (SCM port, enum bom_io_mode io_mode) { if (maybe_consume_bom (port, scm_utf16le_bom, sizeof (scm_utf16le_bom))) { - prepare_iconv_descriptors (port, sym_UTF_16LE); + scm_specialize_port_encoding_x (port, sym_UTF_16LE); return 2; } if (maybe_consume_bom (port, scm_utf16be_bom, sizeof (scm_utf16be_bom))) { - prepare_iconv_descriptors (port, sym_UTF_16BE); + scm_specialize_port_encoding_x (port, sym_UTF_16BE); return 2; } /* Big-endian by default. */ - prepare_iconv_descriptors (port, sym_UTF_16BE); + scm_specialize_port_encoding_x (port, sym_UTF_16BE); return 0; } @@ -2341,16 +2348,16 @@ port_clear_stream_start_for_bom_read (SCM port, enum bom_io_mode io_mode) if (maybe_consume_bom (port, scm_utf32le_bom, sizeof (scm_utf32le_bom))) { /* Big-endian by default. */ - prepare_iconv_descriptors (port, sym_UTF_32LE); + scm_specialize_port_encoding_x (port, sym_UTF_32LE); return 4; } if (maybe_consume_bom (port, scm_utf32be_bom, sizeof (scm_utf32be_bom))) { - prepare_iconv_descriptors (port, sym_UTF_32BE); + scm_specialize_port_encoding_x (port, sym_UTF_32BE); return 4; } /* Big-endian by default. */ - prepare_iconv_descriptors (port, sym_UTF_32BE); + scm_specialize_port_encoding_x (port, sym_UTF_32BE); return 0; } @@ -2441,15 +2448,10 @@ scm_fill_input (SCM port, size_t minimum_size) minimum_size, and ensure that cur is zero so that we fill towards the end of the buffer. */ if (minimum_size > scm_port_buffer_size (read_buf)) - { - /* Grow the read buffer. */ - SCM new_buf = scm_c_make_port_buffer (minimum_size); - scm_port_buffer_reset (new_buf); - scm_port_buffer_put (new_buf, - scm_port_buffer_take_pointer (read_buf), - buffered); - pt->read_buf = read_buf = new_buf; - } + /* Grow the read buffer. */ + read_buf = scm_expand_port_read_buffer_x (port, + scm_from_size_t (minimum_size), + SCM_BOOL_F); else if (buffered == 0) scm_port_buffer_reset (read_buf); else @@ -2501,16 +2503,45 @@ SCM_DEFINE (scm_port_read_buffering, "port-read-buffering", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_set_port_read_buffer_x, "set-port-read-buffer!", 2, 0, 0, - (SCM port, SCM buf), - "Reset the read buffer on an input port.") -#define FUNC_NAME s_scm_set_port_read_buffer_x +SCM_DEFINE (scm_expand_port_read_buffer_x, "expand-port-read-buffer!", 2, 1, 0, + (SCM port, SCM size, SCM putback_p), + "Expand the read buffer of @var{port} to @var{size}. Copy the\n" + "old buffered data, if, any, to the beginning of the new\n" + "buffer, unless @var{putback_p} is true, in which case copy it\n" + "to the end instead. Return the new buffer.") +#define FUNC_NAME s_scm_expand_port_read_buffer_x { + scm_t_port *pt; + size_t c_size; + SCM new_buf; + SCM_VALIDATE_OPINPORT (1, port); - SCM_ASSERT_TYPE (scm_is_vector (buf) && scm_c_vector_length (buf) >= 4, - buf, 2, FUNC_NAME, "port buffer"); - SCM_PTAB_ENTRY (port)->read_buf = buf; - return SCM_UNSPECIFIED; + pt = SCM_PTAB_ENTRY (port); + c_size = scm_to_size_t (size); + SCM_ASSERT_RANGE (2, size, c_size > scm_port_buffer_size (pt->read_buf)); + if (SCM_UNBNDP (putback_p)) + putback_p = SCM_BOOL_F; + + new_buf = scm_c_make_port_buffer (c_size); + scm_port_buffer_set_has_eof_p (new_buf, + scm_port_buffer_has_eof_p (pt->read_buf)); + if (scm_is_true (putback_p)) + { + scm_port_buffer_reset_end (new_buf); + scm_port_buffer_putback (new_buf, + scm_port_buffer_take_pointer (pt->read_buf), + scm_port_buffer_can_take (pt->read_buf)); + } + else + { + scm_port_buffer_reset (new_buf); + scm_port_buffer_put (new_buf, + scm_port_buffer_take_pointer (pt->read_buf), + scm_port_buffer_can_take (pt->read_buf)); + } + pt->read_buf = new_buf; + + return new_buf; } #undef FUNC_NAME diff --git a/libguile/ports.h b/libguile/ports.h index cec60212c..dc0b30dce 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -321,7 +321,8 @@ SCM_API void scm_flush (SCM port); SCM_INTERNAL SCM scm_port_random_access_p (SCM port); SCM_INTERNAL SCM scm_port_read_buffering (SCM port); -SCM_INTERNAL SCM scm_set_port_read_buffer_x (SCM port, SCM buf); +SCM_INTERNAL SCM scm_expand_port_read_buffer_x (SCM port, SCM size, + SCM putback_p); SCM_INTERNAL SCM scm_port_read (SCM port); SCM_INTERNAL SCM scm_port_write (SCM port); SCM_INTERNAL SCM scm_port_read_buffer (SCM port); diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 9d2e36d40..34191a546 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -26,7 +26,6 @@ (define-module (ice-9 ports) - #:use-module (rnrs bytevectors) #:export (;; Definitions from ports.c. %port-property %set-port-property! @@ -161,6 +160,26 @@ interpret its input and output." +(define-module (ice-9 ports internal) + #:use-module (ice-9 ports) + #:export (port-read-buffer + port-write-buffer + expand-port-read-buffer! + port-buffer-bytevector + port-buffer-cur + port-buffer-end + port-buffer-has-eof? + set-port-buffer-cur! + set-port-buffer-end! + set-port-buffer-has-eof?! + port-read + port-write + port-clear-stream-start-for-bom-read + %port-encoding + specialize-port-encoding! + port-random-access? + port-read-buffering)) + (define-syntax-rule (port-buffer-bytevector buf) (vector-ref buf 0)) (define-syntax-rule (port-buffer-cur buf) (vector-ref buf 1)) (define-syntax-rule (port-buffer-end buf) (vector-ref buf 2)) @@ -173,366 +192,26 @@ interpret its input and output." (define-syntax-rule (set-port-buffer-has-eof?! buf has-eof?) (vector-set! buf 3 has-eof?)) -(define (make-port-buffer size) - (vector (make-bytevector size 0) 0 0 #f)) +(eval-when (expand) + (define-syntax-rule (private-port-bindings binding ...) + (begin + (define binding (@@ (ice-9 ports) binding)) + ...))) -(define (write-bytes port src start count) - (let ((written ((port-write port) port src start count))) - (unless (<= 0 written count) - (error "bad return from port write function" written)) - (when (< written count) - (write-bytes port src (+ start written) (- count written))))) +(private-port-bindings port-read-buffer + port-write-buffer + expand-port-read-buffer! + port-read + port-write + port-clear-stream-start-for-bom-read + %port-encoding + specialize-port-encoding! + port-decode-char + port-random-access? + port-read-buffering) -(define (flush-output port) - (let* ((buf (port-write-buffer port)) - (cur (port-buffer-cur buf)) - (end (port-buffer-end buf))) - (when (< cur end) - ;; Update cursors before attempting to write, assuming that I/O - ;; errors are sticky. That way if the write throws an error, - ;; causing the computation to abort, and possibly causing the port - ;; to be collected by GC when it's open, any subsequent close-port - ;; or force-output won't signal *another* error. - (set-port-buffer-cur! buf 0) - (set-port-buffer-end! buf 0) - (write-bytes port (port-buffer-bytevector buf) cur (- end cur))))) - -(define (read-bytes port dst start count) - (let ((read ((port-read port) port dst start count))) - (unless (<= 0 read count) - (error "bad return from port read function" read)) - read)) - -(define utf8-bom #vu8(#xEF #xBB #xBF)) -(define utf16be-bom #vu8(#xFE #xFF)) -(define utf16le-bom #vu8(#xFF #xFE)) -(define utf32be-bom #vu8(#x00 #x00 #xFE #xFF)) -(define utf32le-bom #vu8(#xFF #xFE #x00 #x00)) - -(define (clear-stream-start-for-bom-read port io-mode) - (define (maybe-consume-bom bom) - (and (eq? (peek-byte port) (bytevector-u8-ref bom 0)) - (call-with-values (lambda () - (fill-input port (bytevector-length bom))) - (lambda (buf buffered) - (and (<= (bytevector-length bom) buffered) - (let ((bv (port-buffer-bytevector buf)) - (cur (port-buffer-cur buf))) - (let lp ((i 1)) - (if (= i (bytevector-length bom)) - (begin - (set-port-buffer-cur! buf (+ cur i)) - #t) - (and (eq? (bytevector-u8-ref bv (+ cur i)) - (bytevector-u8-ref bom i)) - (lp (1+ i))))))))))) - (when (and (port-clear-stream-start-for-bom-read port) - (eq? io-mode 'text)) - (case (%port-encoding port) - ((UTF-8) - (maybe-consume-bom utf8-bom)) - ((UTF-16) - (cond - ((maybe-consume-bom utf16le-bom) - (specialize-port-encoding! port 'UTF-16LE)) - (else - (maybe-consume-bom utf16be-bom) - (specialize-port-encoding! port 'UTF-16BE)))) - ((UTF-32) - (cond - ((maybe-consume-bom utf32le-bom) - (specialize-port-encoding! port 'UTF-32LE)) - (else - (maybe-consume-bom utf32be-bom) - (specialize-port-encoding! port 'UTF-32BE))))))) - -(define* (fill-input port #:optional (minimum-buffering 1)) - (clear-stream-start-for-bom-read port 'text) - (let* ((buf (port-read-buffer port)) - (cur (port-buffer-cur buf)) - (buffered (- (port-buffer-end buf) cur))) - (cond - ((or (<= minimum-buffering buffered) (port-buffer-has-eof? buf)) - (values buf buffered)) - (else - (unless (input-port? port) - (error "not an input port" port)) - (when (port-random-access? port) - (flush-output port)) - (let ((bv (port-buffer-bytevector buf))) - (cond - ((< (bytevector-length bv) minimum-buffering) - (let ((buf* (make-port-buffer minimum-buffering))) - (bytevector-copy! bv cur (port-buffer-bytevector buf*) 0 buffered) - (set-port-buffer-end! buf* buffered) - (set-port-read-buffer! port buf*) - (fill-input port minimum-buffering))) - (else - (when (< 0 cur) - (bytevector-copy! bv cur bv 0 buffered) - (set-port-buffer-cur! buf 0) - (set-port-buffer-end! buf buffered)) - (let ((buffering (max (port-read-buffering port) minimum-buffering))) - (let lp ((buffered buffered)) - (let* ((count (- buffering buffered)) - (read (read-bytes port bv buffered count))) - (cond - ((zero? read) - (set-port-buffer-has-eof?! buf #t) - (values buf buffered)) - (else - (let ((buffered (+ buffered read))) - (set-port-buffer-end! buf buffered) - (if (< buffered minimum-buffering) - (lp buffered) - (values buf buffered))))))))))))))) - -(define-inlinable (peek-bytes port count kfast kslow) - (let* ((buf (port-read-buffer port)) - (cur (port-buffer-cur buf)) - (buffered (- (port-buffer-end buf) cur))) - (if (<= count buffered) - (kfast buf (port-buffer-bytevector buf) cur buffered) - (call-with-values (lambda () (fill-input port count)) - (lambda (buf buffered) - (kslow buf (port-buffer-bytevector buf) (port-buffer-cur buf) - buffered)))))) - -(define (peek-byte port) - (peek-bytes port 1 - (lambda (buf bv cur buffered) - (bytevector-u8-ref bv cur)) - (lambda (buf bv cur buffered) - (and (> buffered 0) - (bytevector-u8-ref bv cur))))) - -(define* (%lookahead-u8 port) - (define (fast-path buf bv cur buffered) - (bytevector-u8-ref bv cur)) - (define (slow-path buf bv cur buffered) - (if (zero? buffered) - the-eof-object - (fast-path buf bv cur buffered))) - (peek-bytes port 1 fast-path slow-path)) - -(define* (%get-u8 port) - (define (fast-path buf bv cur buffered) - (set-port-buffer-cur! buf (1+ cur)) - (bytevector-u8-ref bv cur)) - (define (slow-path buf bv cur buffered) - (if (zero? buffered) - (begin - (set-port-buffer-has-eof?! buf #f) - the-eof-object) - (fast-path buf bv cur buffered))) - (peek-bytes port 1 fast-path slow-path)) - -(define (decoding-error subr port) - ;; GNU/Linux definition; fixme? - (define EILSEQ 84) - (throw 'decoding-error subr "input decoding error" EILSEQ port)) - -(define-inlinable (decode-utf8 bv start avail u8_0 kt kf) - (cond - ((< u8_0 #x80) - (kt (integer->char u8_0) 1)) - ((and (<= #xc2 u8_0 #xdf) (<= 2 avail)) - (let ((u8_1 (bytevector-u8-ref bv (1+ start)))) - (if (= (logand u8_1 #xc0) #x80) - (kt (integer->char - (logior (ash (logand u8_0 #x1f) 6) - (logand u8_1 #x3f))) - 2) - (kf)))) - ((and (= (logand u8_0 #xf0) #xe0) (<= 3 avail)) - (let ((u8_1 (bytevector-u8-ref bv (+ start 1))) - (u8_2 (bytevector-u8-ref bv (+ start 2)))) - (if (and (= (logand u8_1 #xc0) #x80) - (= (logand u8_2 #xc0) #x80) - (case u8_0 - ((#xe0) (>= u8_1 #xa0)) - ((#xed) (>= u8_1 #x9f)) - (else #t))) - (kt (integer->char - (logior (ash (logand u8_0 #x0f) 12) - (ash (logand u8_1 #x3f) 6) - (logand u8_2 #x3f))) - 3) - (kf)))) - ((and (<= #xf0 u8_0 #xf4) (<= 4 avail)) - (let ((u8_1 (bytevector-u8-ref bv (+ start 1))) - (u8_2 (bytevector-u8-ref bv (+ start 2))) - (u8_3 (bytevector-u8-ref bv (+ start 3)))) - (if (and (= (logand u8_1 #xc0) #x80) - (= (logand u8_2 #xc0) #x80) - (= (logand u8_3 #xc0) #x80) - (case u8_0 - ((#xf0) (>= u8_1 #x90)) - ((#xf4) (>= u8_1 #x8f)) - (else #t))) - (kt (integer->char - (logior (ash (logand u8_0 #x07) 18) - (ash (logand u8_1 #x3f) 12) - (ash (logand u8_2 #x3f) 6) - (logand u8_3 #x3f))) - 4) - (kf)))) - (else (kf)))) - -(define (bad-utf8-len bv cur buffering first-byte) - (define (ref n) - (bytevector-u8-ref bv (+ cur n))) - (cond - ((< first-byte #x80) 0) - ((<= #xc2 first-byte #xdf) - (cond - ((< buffering 2) 1) - ((not (= (logand (ref 1) #xc0) #x80)) 1) - (else 0))) - ((= (logand first-byte #xf0) #xe0) - (cond - ((< buffering 2) 1) - ((not (= (logand (ref 1) #xc0) #x80)) 1) - ((and (eq? first-byte #xe0) (< (ref 1) #xa0)) 1) - ((and (eq? first-byte #xed) (< (ref 1) #x9f)) 1) - ((< buffering 3) 2) - ((not (= (logand (ref 2) #xc0) #x80)) 2) - (else 0))) - ((<= #xf0 first-byte #xf4) - (cond - ((< buffering 2) 1) - ((not (= (logand (ref 1) #xc0) #x80)) 1) - ((and (eq? first-byte #xf0) (< (ref 1) #x90)) 1) - ((and (eq? first-byte #xf4) (< (ref 1) #x8f)) 1) - ((< buffering 3) 2) - ((not (= (logand (ref 2) #xc0) #x80)) 2) - ((< buffering 4) 3) - ((not (= (logand (ref 3) #xc0) #x80)) 3) - (else 0))) - (else 1))) - -(define (peek-char-and-len/utf8 port first-byte) - (define (bad-utf8 len) - (if (eq? (port-conversion-strategy port) 'substitute) - (values #\? len) - (decoding-error "peek-char" port))) - (if (< first-byte #x80) - (values (integer->char first-byte) 1) - (call-with-values (lambda () - (fill-input port - (cond - ((<= #xc2 first-byte #xdf) 2) - ((= (logand first-byte #xf0) #xe0) 3) - (else 4)))) - (lambda (buf buffering) - (let* ((bv (port-buffer-bytevector buf)) - (cur (port-buffer-cur buf))) - (define (bad-utf8) - (let ((len (bad-utf8-len bv cur buffering first-byte))) - (when (zero? len) (error "internal error")) - (if (eq? (port-conversion-strategy port) 'substitute) - (values #\? len) - (decoding-error "peek-char" port)))) - (decode-utf8 bv cur buffering first-byte values bad-utf8)))))) - -(define (peek-char-and-len/iso-8859-1 port first-byte) - (values (integer->char first-byte) 1)) - -(define (peek-char-and-len/iconv port first-byte) - (let lp ((prev-input-size 0)) - (let ((input-size (1+ prev-input-size))) - (call-with-values (lambda () (fill-input port input-size)) - (lambda (buf buffered) - (cond - ((< buffered input-size) - ;; Buffer failed to fill; EOF, possibly premature. - (cond - ((zero? prev-input-size) - (values the-eof-object 0)) - ((eq? (port-conversion-strategy port) 'substitute) - (values #\? prev-input-size)) - (else - (decoding-error "peek-char" port)))) - ((port-decode-char port (port-buffer-bytevector buf) - (port-buffer-cur buf) input-size) - => (lambda (char) - (values char input-size))) - (else - (lp input-size)))))))) - -(define (peek-char-and-len port) - (let ((first-byte (peek-byte port))) - (if (not first-byte) - (values the-eof-object 0) - (case (%port-encoding port) - ((UTF-8) - (peek-char-and-len/utf8 port first-byte)) - ((ISO-8859-1) - (peek-char-and-len/iso-8859-1 port first-byte)) - (else - (peek-char-and-len/iconv port first-byte)))))) - -(define* (%peek-char #:optional (port (current-input-port))) - (define (slow-path) - (call-with-values (lambda () (peek-char-and-len port)) - (lambda (char len) - char))) - (define (fast-path buf bv cur buffered) - (let ((u8 (bytevector-u8-ref bv cur)) - (enc (%port-encoding port))) - (case enc - ((UTF-8) (decode-utf8 bv cur buffered u8 (lambda (char len) char) - slow-path)) - ((ISO-8859-1) (integer->char u8)) - (else (slow-path))))) - (peek-bytes port 1 fast-path - (lambda (buf bv cur buffered) (slow-path)))) - -(define* (%read-char #:optional (port (current-input-port))) - (define (update-position! char) - (case char - ((#\alarm) #t) ; No change. - ((#\backspace) - (let ((col (port-column port))) - (when (> col 0) - (set-port-column! port (1- col))))) - ((#\newline) - (set-port-line! port (1+ (port-line port))) - (set-port-column! port 0)) - ((#\return) - (set-port-column! port 0)) - ((#\tab) - (let ((col (port-column port))) - (set-port-column! port (- (+ col 8) (remainder col 8))))) - (else - (set-port-column! port (1+ (port-column port))))) - char) - (define (slow-path) - (call-with-values (lambda () (peek-char-and-len port)) - (lambda (char len) - (let ((buf (port-read-buffer port))) - (set-port-buffer-cur! buf (+ (port-buffer-cur buf) len)) - (if (eq? char the-eof-object) - (begin - (set-port-buffer-has-eof?! buf #f) - char) - (update-position! char)))))) - (define (fast-path buf bv cur buffered) - (let ((u8 (bytevector-u8-ref bv cur)) - (enc (%port-encoding port))) - (case enc - ((UTF-8) - (decode-utf8 bv cur buffered u8 - (lambda (char len) - (set-port-buffer-cur! buf (+ cur len)) - (update-position! char)) - slow-path)) - ((ISO-8859-1) - (set-port-buffer-cur! buf (+ cur 1)) - (update-position! (integer->char u8))) - (else (slow-path))))) - (peek-bytes port 1 fast-path - (lambda (buf bv cur buffered) (slow-path)))) +;; And we're back. +(define-module (ice-9 ports)) From 704c42870d63eb469c52375575d1a8e3f8eadce3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 13 May 2016 09:22:36 +0200 Subject: [PATCH 269/865] Add (ice-9 sports) module * module/ice-9/sports.scm: New module. * module/Makefile.am (SOURCES): Add new module. --- module/Makefile.am | 1 + module/ice-9/sports.scm | 412 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 413 insertions(+) create mode 100644 module/ice-9/sports.scm diff --git a/module/Makefile.am b/module/Makefile.am index 71b265ae4..7f8284e18 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -106,6 +106,7 @@ SOURCES = \ ice-9/serialize.scm \ ice-9/session.scm \ ice-9/slib.scm \ + ice-9/sports.scm \ ice-9/stack-catch.scm \ ice-9/streams.scm \ ice-9/string-fun.scm \ diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm new file mode 100644 index 000000000..55f507866 --- /dev/null +++ b/module/ice-9/sports.scm @@ -0,0 +1,412 @@ +;;; Ports, implemented in Scheme +;;; Copyright (C) 2016 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 License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this program. If not, see +;;; . + +;;; Commentary: +;;; +;;; We would like to be able to implement green threads using delimited +;;; continuations. When a green thread would block on I/O, it should +;;; suspend and arrange to be resumed when it can make progress. +;;; +;;; The problem is that the ports code is written in C. A delimited +;;; continuation that captures a C activation can't be resumed, because +;;; Guile doesn't know about the internal structure of the C activation +;;; (stack frame) and so can't compose it with the current continuation. +;;; For that reason, to implement this desired future, we have to +;;; implement ports in Scheme. +;;; +;;; If Scheme were fast enough, we would just implement ports in Scheme +;;; early in Guile's boot, and that would be that. However currently +;;; that's not the case: character-by-character I/O is about three or +;;; four times slower in Scheme than in C. This is mostly bytecode +;;; overhead, though there are some ways that compiler improvements +;;; could help us too. +;;; +;;; Note that the difference between Scheme and C is much less for +;;; batched operations, like read-bytes or read-line. +;;; +;;; So the upshot is that we need to keep the C I/O routines around for +;;; performance reasons. We can still have our Scheme routines +;;; available as a module, though, for use by people working with green +;;; threads. That's this module. People that want green threads can +;;; even replace the core bindings, which enables green threading over +;;; other generic routines like the HTTP server. +;;; +;;; Code: + + +(define-module (ice-9 sports) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 ports internal) + #:replace (peek-char + read-char) + #:export (lookahead-u8 + get-u8)) + +(define (write-bytes port src start count) + (let ((written ((port-write port) port src start count))) + (unless (<= 0 written count) + (error "bad return from port write function" written)) + (when (< written count) + (write-bytes port src (+ start written) (- count written))))) + +(define (flush-output port) + (let* ((buf (port-write-buffer port)) + (cur (port-buffer-cur buf)) + (end (port-buffer-end buf))) + (when (< cur end) + ;; Update cursors before attempting to write, assuming that I/O + ;; errors are sticky. That way if the write throws an error, + ;; causing the computation to abort, and possibly causing the port + ;; to be collected by GC when it's open, any subsequent close-port + ;; or force-output won't signal *another* error. + (set-port-buffer-cur! buf 0) + (set-port-buffer-end! buf 0) + (write-bytes port (port-buffer-bytevector buf) cur (- end cur))))) + +(define (read-bytes port dst start count) + (let ((read ((port-read port) port dst start count))) + (unless (<= 0 read count) + (error "bad return from port read function" read)) + read)) + +(define utf8-bom #vu8(#xEF #xBB #xBF)) +(define utf16be-bom #vu8(#xFE #xFF)) +(define utf16le-bom #vu8(#xFF #xFE)) +(define utf32be-bom #vu8(#x00 #x00 #xFE #xFF)) +(define utf32le-bom #vu8(#xFF #xFE #x00 #x00)) + +(define (clear-stream-start-for-bom-read port io-mode) + (define (maybe-consume-bom bom) + (and (eq? (peek-byte port) (bytevector-u8-ref bom 0)) + (call-with-values (lambda () + (fill-input port (bytevector-length bom))) + (lambda (buf buffered) + (and (<= (bytevector-length bom) buffered) + (let ((bv (port-buffer-bytevector buf)) + (cur (port-buffer-cur buf))) + (let lp ((i 1)) + (if (= i (bytevector-length bom)) + (begin + (set-port-buffer-cur! buf (+ cur i)) + #t) + (and (eq? (bytevector-u8-ref bv (+ cur i)) + (bytevector-u8-ref bom i)) + (lp (1+ i))))))))))) + (when (and (port-clear-stream-start-for-bom-read port) + (eq? io-mode 'text)) + (case (%port-encoding port) + ((UTF-8) + (maybe-consume-bom utf8-bom)) + ((UTF-16) + (cond + ((maybe-consume-bom utf16le-bom) + (specialize-port-encoding! port 'UTF-16LE)) + (else + (maybe-consume-bom utf16be-bom) + (specialize-port-encoding! port 'UTF-16BE)))) + ((UTF-32) + (cond + ((maybe-consume-bom utf32le-bom) + (specialize-port-encoding! port 'UTF-32LE)) + (else + (maybe-consume-bom utf32be-bom) + (specialize-port-encoding! port 'UTF-32BE))))))) + +(define* (fill-input port #:optional (minimum-buffering 1)) + (clear-stream-start-for-bom-read port 'text) + (let* ((buf (port-read-buffer port)) + (cur (port-buffer-cur buf)) + (buffered (- (port-buffer-end buf) cur))) + (cond + ((or (<= minimum-buffering buffered) (port-buffer-has-eof? buf)) + (values buf buffered)) + (else + (unless (input-port? port) + (error "not an input port" port)) + (when (port-random-access? port) + (flush-output port)) + (let ((bv (port-buffer-bytevector buf))) + (cond + ((< (bytevector-length bv) minimum-buffering) + (expand-port-read-buffer! port minimum-buffering) + (fill-input port minimum-buffering)) + (else + (when (< 0 cur) + (bytevector-copy! bv cur bv 0 buffered) + (set-port-buffer-cur! buf 0) + (set-port-buffer-end! buf buffered)) + (let ((buffering (max (port-read-buffering port) minimum-buffering))) + (let lp ((buffered buffered)) + (let* ((count (- buffering buffered)) + (read (read-bytes port bv buffered count))) + (cond + ((zero? read) + (set-port-buffer-has-eof?! buf #t) + (values buf buffered)) + (else + (let ((buffered (+ buffered read))) + (set-port-buffer-end! buf buffered) + (if (< buffered minimum-buffering) + (lp buffered) + (values buf buffered))))))))))))))) + +(define-inlinable (peek-bytes port count kfast kslow) + (let* ((buf (port-read-buffer port)) + (cur (port-buffer-cur buf)) + (buffered (- (port-buffer-end buf) cur))) + (if (<= count buffered) + (kfast buf (port-buffer-bytevector buf) cur buffered) + (call-with-values (lambda () (fill-input port count)) + (lambda (buf buffered) + (kslow buf (port-buffer-bytevector buf) (port-buffer-cur buf) + buffered)))))) + +(define (peek-byte port) + (peek-bytes port 1 + (lambda (buf bv cur buffered) + (bytevector-u8-ref bv cur)) + (lambda (buf bv cur buffered) + (and (> buffered 0) + (bytevector-u8-ref bv cur))))) + +(define* (lookahead-u8 port) + (define (fast-path buf bv cur buffered) + (bytevector-u8-ref bv cur)) + (define (slow-path buf bv cur buffered) + (if (zero? buffered) + the-eof-object + (fast-path buf bv cur buffered))) + (peek-bytes port 1 fast-path slow-path)) + +(define* (get-u8 port) + (define (fast-path buf bv cur buffered) + (set-port-buffer-cur! buf (1+ cur)) + (bytevector-u8-ref bv cur)) + (define (slow-path buf bv cur buffered) + (if (zero? buffered) + (begin + (set-port-buffer-has-eof?! buf #f) + the-eof-object) + (fast-path buf bv cur buffered))) + (peek-bytes port 1 fast-path slow-path)) + +(define (decoding-error subr port) + ;; GNU definition; fixme? + (define EILSEQ 84) + (throw 'decoding-error subr "input decoding error" EILSEQ port)) + +(define-inlinable (decode-utf8 bv start avail u8_0 kt kf) + (cond + ((< u8_0 #x80) + (kt (integer->char u8_0) 1)) + ((and (<= #xc2 u8_0 #xdf) (<= 2 avail)) + (let ((u8_1 (bytevector-u8-ref bv (1+ start)))) + (if (= (logand u8_1 #xc0) #x80) + (kt (integer->char + (logior (ash (logand u8_0 #x1f) 6) + (logand u8_1 #x3f))) + 2) + (kf)))) + ((and (= (logand u8_0 #xf0) #xe0) (<= 3 avail)) + (let ((u8_1 (bytevector-u8-ref bv (+ start 1))) + (u8_2 (bytevector-u8-ref bv (+ start 2)))) + (if (and (= (logand u8_1 #xc0) #x80) + (= (logand u8_2 #xc0) #x80) + (case u8_0 + ((#xe0) (>= u8_1 #xa0)) + ((#xed) (>= u8_1 #x9f)) + (else #t))) + (kt (integer->char + (logior (ash (logand u8_0 #x0f) 12) + (ash (logand u8_1 #x3f) 6) + (logand u8_2 #x3f))) + 3) + (kf)))) + ((and (<= #xf0 u8_0 #xf4) (<= 4 avail)) + (let ((u8_1 (bytevector-u8-ref bv (+ start 1))) + (u8_2 (bytevector-u8-ref bv (+ start 2))) + (u8_3 (bytevector-u8-ref bv (+ start 3)))) + (if (and (= (logand u8_1 #xc0) #x80) + (= (logand u8_2 #xc0) #x80) + (= (logand u8_3 #xc0) #x80) + (case u8_0 + ((#xf0) (>= u8_1 #x90)) + ((#xf4) (>= u8_1 #x8f)) + (else #t))) + (kt (integer->char + (logior (ash (logand u8_0 #x07) 18) + (ash (logand u8_1 #x3f) 12) + (ash (logand u8_2 #x3f) 6) + (logand u8_3 #x3f))) + 4) + (kf)))) + (else (kf)))) + +(define (bad-utf8-len bv cur buffering first-byte) + (define (ref n) + (bytevector-u8-ref bv (+ cur n))) + (cond + ((< first-byte #x80) 0) + ((<= #xc2 first-byte #xdf) + (cond + ((< buffering 2) 1) + ((not (= (logand (ref 1) #xc0) #x80)) 1) + (else 0))) + ((= (logand first-byte #xf0) #xe0) + (cond + ((< buffering 2) 1) + ((not (= (logand (ref 1) #xc0) #x80)) 1) + ((and (eq? first-byte #xe0) (< (ref 1) #xa0)) 1) + ((and (eq? first-byte #xed) (< (ref 1) #x9f)) 1) + ((< buffering 3) 2) + ((not (= (logand (ref 2) #xc0) #x80)) 2) + (else 0))) + ((<= #xf0 first-byte #xf4) + (cond + ((< buffering 2) 1) + ((not (= (logand (ref 1) #xc0) #x80)) 1) + ((and (eq? first-byte #xf0) (< (ref 1) #x90)) 1) + ((and (eq? first-byte #xf4) (< (ref 1) #x8f)) 1) + ((< buffering 3) 2) + ((not (= (logand (ref 2) #xc0) #x80)) 2) + ((< buffering 4) 3) + ((not (= (logand (ref 3) #xc0) #x80)) 3) + (else 0))) + (else 1))) + +(define (peek-char-and-len/utf8 port first-byte) + (define (bad-utf8 len) + (if (eq? (port-conversion-strategy port) 'substitute) + (values #\? len) + (decoding-error "peek-char" port))) + (if (< first-byte #x80) + (values (integer->char first-byte) 1) + (call-with-values (lambda () + (fill-input port + (cond + ((<= #xc2 first-byte #xdf) 2) + ((= (logand first-byte #xf0) #xe0) 3) + (else 4)))) + (lambda (buf buffering) + (let* ((bv (port-buffer-bytevector buf)) + (cur (port-buffer-cur buf))) + (define (bad-utf8) + (let ((len (bad-utf8-len bv cur buffering first-byte))) + (when (zero? len) (error "internal error")) + (if (eq? (port-conversion-strategy port) 'substitute) + (values #\? len) + (decoding-error "peek-char" port)))) + (decode-utf8 bv cur buffering first-byte values bad-utf8)))))) + +(define (peek-char-and-len/iso-8859-1 port first-byte) + (values (integer->char first-byte) 1)) + +(define (peek-char-and-len/iconv port first-byte) + (let lp ((prev-input-size 0)) + (let ((input-size (1+ prev-input-size))) + (call-with-values (lambda () (fill-input port input-size)) + (lambda (buf buffered) + (cond + ((< buffered input-size) + ;; Buffer failed to fill; EOF, possibly premature. + (cond + ((zero? prev-input-size) + (values the-eof-object 0)) + ((eq? (port-conversion-strategy port) 'substitute) + (values #\? prev-input-size)) + (else + (decoding-error "peek-char" port)))) + ((port-decode-char port (port-buffer-bytevector buf) + (port-buffer-cur buf) input-size) + => (lambda (char) + (values char input-size))) + (else + (lp input-size)))))))) + +(define (peek-char-and-len port) + (let ((first-byte (peek-byte port))) + (if (not first-byte) + (values the-eof-object 0) + (case (%port-encoding port) + ((UTF-8) + (peek-char-and-len/utf8 port first-byte)) + ((ISO-8859-1) + (peek-char-and-len/iso-8859-1 port first-byte)) + (else + (peek-char-and-len/iconv port first-byte)))))) + +(define* (peek-char #:optional (port (current-input-port))) + (define (slow-path) + (call-with-values (lambda () (peek-char-and-len port)) + (lambda (char len) + char))) + (define (fast-path buf bv cur buffered) + (let ((u8 (bytevector-u8-ref bv cur)) + (enc (%port-encoding port))) + (case enc + ((UTF-8) (decode-utf8 bv cur buffered u8 (lambda (char len) char) + slow-path)) + ((ISO-8859-1) (integer->char u8)) + (else (slow-path))))) + (peek-bytes port 1 fast-path + (lambda (buf bv cur buffered) (slow-path)))) + +(define* (read-char #:optional (port (current-input-port))) + (define (update-position! char) + (case char + ((#\alarm) #t) ; No change. + ((#\backspace) + (let ((col (port-column port))) + (when (> col 0) + (set-port-column! port (1- col))))) + ((#\newline) + (set-port-line! port (1+ (port-line port))) + (set-port-column! port 0)) + ((#\return) + (set-port-column! port 0)) + ((#\tab) + (let ((col (port-column port))) + (set-port-column! port (- (+ col 8) (remainder col 8))))) + (else + (set-port-column! port (1+ (port-column port))))) + char) + (define (slow-path) + (call-with-values (lambda () (peek-char-and-len port)) + (lambda (char len) + (let ((buf (port-read-buffer port))) + (set-port-buffer-cur! buf (+ (port-buffer-cur buf) len)) + (if (eq? char the-eof-object) + (begin + (set-port-buffer-has-eof?! buf #f) + char) + (update-position! char)))))) + (define (fast-path buf bv cur buffered) + (let ((u8 (bytevector-u8-ref bv cur)) + (enc (%port-encoding port))) + (case enc + ((UTF-8) + (decode-utf8 bv cur buffered u8 + (lambda (char len) + (set-port-buffer-cur! buf (+ cur len)) + (update-position! char)) + slow-path)) + ((ISO-8859-1) + (set-port-buffer-cur! buf (+ cur 1)) + (update-position! (integer->char u8))) + (else (slow-path))))) + (peek-bytes port 1 fast-path + (lambda (buf bv cur buffered) (slow-path)))) From 6ff542ee7138ad6eb837f5a5ac59572a04ef3e45 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 13 May 2016 10:05:23 +0200 Subject: [PATCH 270/865] Add random_access_p port type method * doc/ref/api-io.texi (I/O Extensions): Update documentation on implementing port types. Document get_natural_buffer_sizes. Document the new random_access_p. * libguile/fports.c (scm_i_fdes_to_port, fport_random_access_p): (scm_make_fptob): Instead of frobbing rw_random manually, implement a random_access_p function. * libguile/ports.c (default_random_access_p) (scm_set_port_random_access_p): New functions. scm_make_port_type, scm_c_make_port_with_encoding): Arrange for random_access_p to work. --- doc/ref/api-io.texi | 102 +++++++++++++++++++------------------------- libguile/fports.c | 8 +++- libguile/ports.c | 19 +++++++-- libguile/ports.h | 3 ++ 4 files changed, 71 insertions(+), 61 deletions(-) diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 78f7caec7..1a9c8212d 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -2263,72 +2263,20 @@ interface works internally. @cindex ptob @tindex scm_t_ptob_descriptor @tindex scm_t_port -@tindex scm_t_port_buffer @findex SCM_PTAB_ENTRY @findex SCM_PTOBNUM @vindex scm_ptobs -Guile's port facility consists of three main data structures. A port -type object (ptob) is of type @code{scm_t_ptob_descriptor}, and holds -pointers to the methods that implement the port type. A port instance -is of type @code{scm_t_port}, and holds all state for the port. Finally -the read and write buffers are the @code{read_buf} and @code{write_buf} -members of the port instance, and are of type @code{scm_t_port_buffer}. +Guile's port facility consists of two main data types: port type objects +and port instances. A port type object (or @dfn{ptob}) is of type +@code{scm_t_ptob_descriptor}, and holds pointers to the methods that +implement the port type. A port instance is of type @code{scm_t_port}, +and holds all state for the port. Given an @code{SCM} variable which points to a port, the corresponding C port object can be obtained using the @code{SCM_PTAB_ENTRY} macro. The ptob can be obtained by using @code{SCM_PTOBNUM} to give an index into the @code{scm_ptobs} global array. -@subsubheading Port buffers - -An input port always has a read buffer and an output port always has a -write buffer. @xref{Buffering}. These buffers are represented in C by -@code{scm_t_port_buffer} objects. - -The port buffer consists of data as a byte array, pointed to by its -@code{buf} field. The valid data in the buffer is between the -@code{cur} and @code{end} indices into @code{buf}; @code{cur} must -always be less than or equal to @code{end}, which in turn must be less -than or equal to the buffer size @code{size}. The @code{buf} pointer is -actually a pointer to the start of a bytevector, stored in the -@code{bytevector} member. Using bytevectors to back port buffers allows -Scheme to manipulate these buffers. - -``Valid data'' for a read buffer is data that has been buffered, but not -yet read by the user. A port's @code{read} procedure fills a read -buffer from the @code{end} element. For a write buffer, the ``valid -data'' is data which has been written by the user, but not yet flushed -to the mutable store. A port's @code{write} procedure will consume the -data between @code{cur} and @code{end} (not including @code{end}) and -advance @code{cur}. - -The size of the buffers is controlled by the user, via @code{setvbuf}. -A port implementation can provide an idea of what the ``natural'' size -for its buffers are, but it has no guarantee that the buffer will be -those sizes. It's also possible for big reads or writes to work on -auxiliary buffers, and it's possible for @code{unget-bytevector} to -cause a read buffer to expand temporarily; port implementations can't -assume that the buffer they have been given to fill or empty corresponds -to the port's designated read or write buffer. - -Port read buffers also have a flag indicating that the last read did not -advance @code{end}, which indicates end-of-stream. It is cleared by -Guile when Guile gives the user an EOF object. - -@subsubheading The @code{rw_random} flag - -Special treatment is required for ports which can be seeked at random. -Before various operations, such as seeking the port or changing from -input to output on a bidirectional port or vice versa. Seeking on a -port with buffered input, or switching to writing after reading, will -cause the buffered input to be discarded and Guile will seek the port -back the buffered number of bytes. Likewise seeking on a port with -buffered output, or switching to reading after writing, will flush -pending bytes with a call to the @code{write} procedure. Indicate to -Guile that your port needs this behavior by setting the @code{rw_random} -flag. This flag is set by default if the port type supplies a seek -implementation. - @subsubheading C interface A port type object is created by calling @code{scm_make_port_type}. @@ -2403,6 +2351,46 @@ before hand, as appropriate. Set using @deftypefun void scm_set_port_truncate (scm_t_bits tc, void (*truncate) (SCM port, scm_t_off length)) @end deftypefun +@item random_access_p +Determine whether this port is a random-access port. + +@cindex random access +Seeking on a random-access port with buffered input, or switching to +writing after reading, will cause the buffered input to be discarded and +Guile will seek the port back the buffered number of bytes. Likewise +seeking on a random-access port with buffered output, or switching to +reading after writing, will flush pending bytes with a call to the +@code{write} procedure. @xref{Buffering}. + +Indicate to Guile that your port needs this behavior by returning a +nonzero value from your @code{random_access_p} function. The default +implementation of this function returns nonzero if the port type +supplies a seek implementation. + +@deftypefun void scm_set_port_random_access_p (scm_t_bits tc, int (*random_access_p) (SCM port)); +@end deftypefun + +@item get_natural_buffer_sizes +Guile will internally attach buffers to ports. An input port always has +a read buffer and an output port always has a write buffer. +@xref{Buffering}. A port buffer consists of a bytevector, along with +some cursors into that bytevector denoting where to get and put data. + +Port implementations generally don't have to be concerned with +buffering: a port type's @code{read} or @code{write} function will +receive the buffer's bytevector as an argument, along with an offset and +a length into that bytevector, and should then either fill or empty that +bytevector. However in some cases, port implementations may be able to +provide an appropriate default buffer size to Guile. + +@deftypefun void scm_set_port_get_natural_buffer_sizes @ + (scm_t_bits tc, void (*get_natural_buffer_sizes) (SCM, size_t *read_buf_size, size_t *write_buf_size)) +Fill in @var{read_buf_size} and @var{write_buf_size} with an appropriate buffer size for this port, if one is known. +@end deftypefun + +File ports implement a @code{get_natural_buffer_sizes} to let the +operating system inform Guile about the appropriate buffer sizes for the +particular file opened by the port. @end table @node BOM Handling diff --git a/libguile/fports.c b/libguile/fports.c index c6071febb..aab83c9d3 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -418,7 +418,6 @@ scm_i_fdes_to_port (int fdes, long mode_bits, SCM name) port = scm_c_make_port (scm_tc16_fport, mode_bits, (scm_t_bits)fp); - SCM_PTAB_ENTRY (port)->rw_random = SCM_FDES_RANDOM_P (fdes); SCM_SET_FILENAME (port, name); return port; @@ -639,6 +638,12 @@ fport_close (SCM port) scm_syserror ("fport_close"); } +static int +fport_random_access_p (SCM port) +{ + return SCM_FDES_RANDOM_P (SCM_FSTREAM (port)->fdes); +} + /* Query the OS to get the natural buffering for FPORT, if available. */ static void fport_get_natural_buffer_sizes (SCM port, size_t *read_size, size_t *write_size) @@ -663,6 +668,7 @@ scm_make_fptob () scm_set_port_seek (tc, fport_seek); scm_set_port_truncate (tc, fport_truncate); scm_set_port_input_waiting (tc, fport_input_waiting); + scm_set_port_random_access_p (tc, fport_random_access_p); scm_set_port_get_natural_buffer_sizes (tc, fport_get_natural_buffer_sizes); return tc; diff --git a/libguile/ports.c b/libguile/ports.c index 1ad5db096..a2509fb7a 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -196,6 +196,12 @@ scm_c_port_type_add_x (scm_t_ptob_descriptor *desc) static SCM trampoline_to_c_read_subr; static SCM trampoline_to_c_write_subr; +static int +default_random_access_p (SCM port) +{ + return SCM_PORT_DESCRIPTOR (port)->seek != NULL; +} + scm_t_bits scm_make_port_type (char *name, size_t (*read) (SCM port, SCM dst, size_t start, @@ -215,6 +221,7 @@ scm_make_port_type (char *name, desc->c_write = write; desc->scm_read = read ? trampoline_to_c_read_subr : SCM_BOOL_F; desc->scm_write = write ? trampoline_to_c_write_subr : SCM_BOOL_F; + desc->random_access_p = default_random_access_p; ptobnum = scm_c_port_type_add_x (desc); @@ -333,6 +340,13 @@ scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SCM)) scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->input_waiting = input_waiting; } +void +scm_set_port_random_access_p (scm_t_bits tc, int (*random_access_p) (SCM)) +{ + scm_t_ptob_descriptor *ptob = scm_c_port_type_ref (SCM_TC2PTOBNUM (tc)); + ptob->random_access_p = random_access_p; +} + void scm_set_port_get_natural_buffer_sizes (scm_t_bits tc, void (*get_natural_buffer_sizes) (SCM, size_t *, size_t *)) @@ -721,9 +735,6 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits, entry->internal = pti; entry->file_name = SCM_BOOL_F; - /* By default, any port type with a seek function has random-access - ports. */ - entry->rw_random = ptob->seek != NULL; entry->port = ret; entry->stream = stream; entry->encoding = encoding; @@ -743,6 +754,8 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits, initialize_port_buffers (ret); + entry->rw_random = ptob->random_access_p (ret); + return ret; } diff --git a/libguile/ports.h b/libguile/ports.h index dc0b30dce..f9b638961 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -191,6 +191,7 @@ typedef struct scm_t_ptob_descriptor void (*get_natural_buffer_sizes) (SCM port, size_t *read_size, size_t *write_size); + int (*random_access_p) (SCM port); int (*input_waiting) (SCM port); @@ -230,6 +231,8 @@ SCM_API void scm_set_port_truncate (scm_t_bits tc, SCM_API void scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SCM)); SCM_API void scm_set_port_get_natural_buffer_sizes (scm_t_bits tc, void (*get_natural_buffer_sizes) (SCM, size_t *, size_t *)); +SCM_API void scm_set_port_random_access_p (scm_t_bits tc, + int (*random_access_p) (SCM port)); /* The input, output, error, and load ports. */ SCM_API SCM scm_current_input_port (void); From fe7ceff9691e20723d466542b3ff4132d78f2a3b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 13 May 2016 10:16:27 +0200 Subject: [PATCH 271/865] Remove SCM backlink in port structure * libguile/ports.h (scm_t_port): Remove port backlink. * libguile/ports.c (scm_c_make_port_with_encoding, scm_fill_input) (scm_seek): Adapt. --- libguile/ports.c | 7 +++---- libguile/ports.h | 3 --- 2 files changed, 3 insertions(+), 7 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index a2509fb7a..6003129e2 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -735,7 +735,6 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits, entry->internal = pti; entry->file_name = SCM_BOOL_F; - entry->port = ret; entry->stream = stream; entry->encoding = encoding; entry->conversion_strategy = conversion_strategy; @@ -2455,7 +2454,7 @@ scm_fill_input (SCM port, size_t minimum_size) return read_buf; if (pt->rw_random) - scm_flush (pt->port); + scm_flush (port); /* Prepare to read. Make sure there is enough space in the buffer for minimum_size, and ensure that cur is zero so that we fill towards @@ -2874,8 +2873,8 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, /* FIXME: Avoid flushing buffers for SEEK_CUR with an offset of 0. */ - scm_end_input (pt->port); - scm_flush (pt->port); + scm_end_input (fd_port); + scm_flush (fd_port); rv = ptob->seek (fd_port, off, how); diff --git a/libguile/ports.h b/libguile/ports.h index f9b638961..84f4e0183 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -81,9 +81,6 @@ enum scm_port_buffer_field { typedef struct { - /* Link back to the port object. */ - SCM port; - /* Pointer to internal-only port structure. */ struct scm_port_internal *internal; From 209d50c7d8c1f8e5e365eb7d88d53c297d71621e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 13 May 2016 10:24:32 +0200 Subject: [PATCH 272/865] Embed scm_t_port in scm_t_port_internal * libguile/ports-internal.h (scm_t_port_internal) * libguile/ports.h (scm_t_port): Embed scm_t_port in scm_t_port_internal so that we have just one allocation. * libguile/ports-internal.h (SCM_PORT_GET_INTERNAL): Adapt. * libguile/ports.c (scm_i_port_property, scm_i_set_port_property_x) (scm_c_make_port_with_encoding): Adapt. --- libguile/ports-internal.h | 3 ++- libguile/ports.c | 17 +++++------------ libguile/ports.h | 3 --- 3 files changed, 7 insertions(+), 16 deletions(-) diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index 689e61c17..a7d61d405 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -226,6 +226,7 @@ typedef struct scm_iconv_descriptors scm_t_iconv_descriptors; struct scm_port_internal { + scm_t_port pt; unsigned at_stream_start_for_bom_read : 1; unsigned at_stream_start_for_bom_write : 1; scm_t_iconv_descriptors *iconv_descriptors; @@ -236,7 +237,7 @@ typedef struct scm_port_internal scm_t_port_internal; #define SCM_UNICODE_BOM 0xFEFFUL /* Unicode byte-order mark */ -#define SCM_PORT_GET_INTERNAL(x) (SCM_PTAB_ENTRY(x)->internal) +#define SCM_PORT_GET_INTERNAL(x) ((scm_t_port_internal*) SCM_PTAB_ENTRY(x)) typedef enum scm_t_port_rw_active { SCM_PORT_NEITHER = 0, diff --git a/libguile/ports.c b/libguile/ports.c index 6003129e2..c3d5f5ee1 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -366,15 +366,9 @@ SCM_DEFINE (scm_i_port_property, "%port-property", 2, 0, 0, "Return the property of @var{port} associated with @var{key}.") #define FUNC_NAME s_scm_i_port_property { - SCM result; - scm_t_port *pt; - SCM_VALIDATE_OPPORT (1, port); - pt = SCM_PTAB_ENTRY (port); - result = scm_assq_ref (pt->internal->alist, key); - - return result; + return scm_assq_ref (SCM_PORT_GET_INTERNAL (port)->alist, key); } #undef FUNC_NAME @@ -383,12 +377,12 @@ SCM_DEFINE (scm_i_set_port_property_x, "%set-port-property!", 3, 0, 0, "Set the property of @var{port} associated with @var{key} to @var{value}.") #define FUNC_NAME s_scm_i_set_port_property_x { - scm_t_port *pt; + scm_t_port_internal *pti; SCM_VALIDATE_OPPORT (1, port); - pt = SCM_PTAB_ENTRY (port); - pt->internal->alist = scm_assq_set_x (pt->internal->alist, key, value); + pti = SCM_PORT_GET_INTERNAL (port); + pti->alist = scm_assq_set_x (pti->alist, key, value); return SCM_UNSPECIFIED; } @@ -725,15 +719,14 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits, scm_t_port_internal *pti; scm_t_ptob_descriptor *ptob; - entry = scm_gc_typed_calloc (scm_t_port); pti = scm_gc_typed_calloc (scm_t_port_internal); + entry = &pti->pt; ptob = scm_c_port_type_ref (SCM_TC2PTOBNUM (tag)); ret = scm_words (tag | mode_bits, 3); SCM_SET_CELL_WORD_1 (ret, (scm_t_bits) entry); SCM_SET_CELL_WORD_2 (ret, (scm_t_bits) ptob); - entry->internal = pti; entry->file_name = SCM_BOOL_F; entry->stream = stream; entry->encoding = encoding; diff --git a/libguile/ports.h b/libguile/ports.h index 84f4e0183..793523b71 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -81,9 +81,6 @@ enum scm_port_buffer_field { typedef struct { - /* Pointer to internal-only port structure. */ - struct scm_port_internal *internal; - /* Data for the underlying port implementation as a raw C value. */ scm_t_bits stream; From 8af64975be43a5055e6a74e9eef89a9c9955af7d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 13 May 2016 10:31:01 +0200 Subject: [PATCH 273/865] Make file/line/column fields of ports private * libguile/ports-internal.h (scm_t_port_internal): Move file_name, line_number, and column_number here. (SCM_FILENAME, SCM_SET_FILENAME, SCM_LINUM, SCM_COL, SCM_INCLINE): (SCM_ZEROCOL, SCM_INCCOL, SCM_DECCOL, SCM_TABCOL): Make internal. * libguile/ports.c (scm_c_make_port_with_encoding) (scm_set_port_line_x, scm_set_port_column_x): Adapt to change. --- libguile/ports-internal.h | 17 +++++++++++++++++ libguile/ports.c | 6 +++--- libguile/ports.h | 16 ---------------- 3 files changed, 20 insertions(+), 19 deletions(-) diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index a7d61d405..28b9c5f2d 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -227,6 +227,12 @@ typedef struct scm_iconv_descriptors scm_t_iconv_descriptors; struct scm_port_internal { scm_t_port pt; + + /* Source location information. */ + SCM file_name; + long line_number; + int column_number; + unsigned at_stream_start_for_bom_read : 1; unsigned at_stream_start_for_bom_write : 1; scm_t_iconv_descriptors *iconv_descriptors; @@ -239,6 +245,17 @@ typedef struct scm_port_internal scm_t_port_internal; #define SCM_PORT_GET_INTERNAL(x) ((scm_t_port_internal*) SCM_PTAB_ENTRY(x)) +#define SCM_FILENAME(x) (SCM_PORT_GET_INTERNAL(x)->file_name) +#define SCM_SET_FILENAME(x, n) (SCM_PORT_GET_INTERNAL(x)->file_name = (n)) +#define SCM_LINUM(x) (SCM_PORT_GET_INTERNAL(x)->line_number) +#define SCM_COL(x) (SCM_PORT_GET_INTERNAL(x)->column_number) + +#define SCM_INCLINE(port) do {SCM_LINUM (port) += 1; SCM_COL (port) = 0;} while (0) +#define SCM_ZEROCOL(port) do {SCM_COL (port) = 0;} while (0) +#define SCM_INCCOL(port) do {SCM_COL (port) += 1;} while (0) +#define SCM_DECCOL(port) do {if (SCM_COL (port) > 0) SCM_COL (port) -= 1;} while (0) +#define SCM_TABCOL(port) do {SCM_COL (port) += 8 - SCM_COL (port) % 8;} while (0) + typedef enum scm_t_port_rw_active { SCM_PORT_NEITHER = 0, SCM_PORT_READ = 1, diff --git a/libguile/ports.c b/libguile/ports.c index c3d5f5ee1..fe877acd8 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -727,10 +727,10 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits, SCM_SET_CELL_WORD_1 (ret, (scm_t_bits) entry); SCM_SET_CELL_WORD_2 (ret, (scm_t_bits) ptob); - entry->file_name = SCM_BOOL_F; entry->stream = stream; entry->encoding = encoding; entry->conversion_strategy = conversion_strategy; + pti->file_name = SCM_BOOL_F; pti->iconv_descriptors = NULL; pti->at_stream_start_for_bom_read = 1; @@ -3017,7 +3017,7 @@ SCM_DEFINE (scm_set_port_line_x, "set-port-line!", 2, 0, 0, { port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); - SCM_PTAB_ENTRY (port)->line_number = scm_to_long (line); + SCM_PORT_GET_INTERNAL (port)->line_number = scm_to_long (line); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -3048,7 +3048,7 @@ SCM_DEFINE (scm_set_port_column_x, "set-port-column!", 2, 0, 0, { port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); - SCM_PTAB_ENTRY (port)->column_number = scm_to_int (column); + SCM_PORT_GET_INTERNAL (port)->column_number = scm_to_int (column); return SCM_UNSPECIFIED; } #undef FUNC_NAME diff --git a/libguile/ports.h b/libguile/ports.h index 793523b71..efaa7654f 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -84,11 +84,6 @@ typedef struct /* Data for the underlying port implementation as a raw C value. */ scm_t_bits stream; - /* Source location information. */ - SCM file_name; - long line_number; - int column_number; - /* Port buffers. */ SCM read_buf; SCM write_buf; @@ -147,17 +142,6 @@ SCM_INTERNAL SCM scm_i_port_weak_set; #define SCM_SETPTAB_ENTRY(x, ent) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (ent))) #define SCM_STREAM(x) (SCM_PTAB_ENTRY(x)->stream) #define SCM_SETSTREAM(x, s) (SCM_PTAB_ENTRY(x)->stream = (scm_t_bits) (s)) -#define SCM_FILENAME(x) (SCM_PTAB_ENTRY(x)->file_name) -#define SCM_SET_FILENAME(x, n) (SCM_PTAB_ENTRY(x)->file_name = (n)) -#define SCM_LINUM(x) (SCM_PTAB_ENTRY(x)->line_number) -#define SCM_COL(x) (SCM_PTAB_ENTRY(x)->column_number) - -#define SCM_INCLINE(port) do {SCM_LINUM (port) += 1; SCM_COL (port) = 0;} while (0) -#define SCM_ZEROCOL(port) do {SCM_COL (port) = 0;} while (0) -#define SCM_INCCOL(port) do {SCM_COL (port) += 1;} while (0) -#define SCM_DECCOL(port) do {if (SCM_COL (port) > 0) SCM_COL (port) -= 1;} while (0) -#define SCM_TABCOL(port) do {SCM_COL (port) += 8 - SCM_COL (port) % 8;} while (0) - /* Maximum number of port types. */ #define SCM_I_MAX_PORT_TYPE_COUNT 256 From 9a9e0cceae8433ba45e2ab9b37c02dd3b3c71d9a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 13 May 2016 10:58:19 +0200 Subject: [PATCH 274/865] Make port buffering fields private * libguile/ports-internal.h (enum scm_port_buffer_field) (scm_t_port_internal): Make port buffering fields private. * libguile/ports.h (scm_t_port): Adapt. * libguile/filesys.c (set_element): * libguile/ioext.c (scm_redirect_port): * libguile/poll.c (scm_primitive_poll): * libguile/ports.c: * libguile/read.c (scm_i_scan_for_encoding): * libguile/rw.c (scm_write_string_partial): Adapt users. --- libguile/filesys.c | 8 +- libguile/ioext.c | 8 +- libguile/poll.c | 12 +-- libguile/ports-internal.h | 51 +++++++++++++ libguile/ports.c | 153 +++++++++++++++++--------------------- libguile/ports.h | 51 ------------- libguile/read.c | 8 +- libguile/rw.c | 2 +- 8 files changed, 141 insertions(+), 152 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index 3264b29f9..35e15cba8 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -651,18 +651,18 @@ set_element (fd_set *set, SCM *ports_ready, SCM element, int pos) if (pos == SCM_ARG1) { /* check whether port has buffered input. */ - scm_t_port *pt = SCM_PTAB_ENTRY (element); + scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (element); - if (scm_port_buffer_can_take (pt->read_buf) > 0) + if (scm_port_buffer_can_take (pti->read_buf) > 0) use_buf = 1; } else if (pos == SCM_ARG2) { /* check whether port's output buffer has room. */ - scm_t_port *pt = SCM_PTAB_ENTRY (element); + scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (element); /* > 1 since writing the last byte in the buffer causes flush. */ - if (scm_port_buffer_can_put (pt->write_buf) > 1) + if (scm_port_buffer_can_put (pti->write_buf) > 1) use_buf = 1; } fd = use_buf ? -1 : SCM_FPORT_FDES (element); diff --git a/libguile/ioext.c b/libguile/ioext.c index f39771eec..36ca07baa 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -34,6 +34,7 @@ #include "libguile/hashtab.h" #include "libguile/ioext.h" #include "libguile/ports.h" +#include "libguile/ports-internal.h" #include "libguile/strings.h" #include "libguile/validate.h" @@ -90,19 +91,20 @@ SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0, buffers. */ if (SCM_OUTPUT_PORT_P (old)) scm_flush (old); - if (SCM_INPUT_PORT_P (old) && SCM_PTAB_ENTRY (old)->rw_random) + if (SCM_INPUT_PORT_P (old) && SCM_PORT_GET_INTERNAL (old)->rw_random) scm_end_input (old); if (SCM_OUTPUT_PORT_P (new)) scm_flush (new); - if (SCM_INPUT_PORT_P (new) && SCM_PTAB_ENTRY (new)->rw_random) + if (SCM_INPUT_PORT_P (new) && SCM_PORT_GET_INTERNAL (new)->rw_random) scm_end_input (new); ans = dup2 (oldfd, newfd); if (ans == -1) SCM_SYSERROR; - SCM_PTAB_ENTRY (new)->rw_random = SCM_PTAB_ENTRY (old)->rw_random; + SCM_PORT_GET_INTERNAL (new)->rw_random = + SCM_PORT_GET_INTERNAL (old)->rw_random; } return SCM_UNSPECIFIED; } diff --git a/libguile/poll.c b/libguile/poll.c index 9557339c2..fa90abbcd 100644 --- a/libguile/poll.c +++ b/libguile/poll.c @@ -107,13 +107,13 @@ scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout) revents |= POLLERR; else { - scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); - if (scm_port_buffer_can_take (pt->read_buf) > 0) + if (scm_port_buffer_can_take (pti->read_buf) > 0) /* Buffered input waiting to be read. */ revents |= POLLIN; if (SCM_OUTPUT_PORT_P (port) - && scm_port_buffer_can_put (pt->write_buf) > 1) + && scm_port_buffer_can_put (pti->write_buf) > 1) /* Buffered output possible. The "> 1" is because writing the last byte would flush the port. */ revents |= POLLOUT; @@ -145,13 +145,13 @@ scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout) revents |= POLLERR; else { - scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); - if (scm_port_buffer_can_take (pt->read_buf) > 0) + if (scm_port_buffer_can_take (pti->read_buf) > 0) /* Buffered input waiting to be read. */ revents |= POLLIN; if (SCM_OUTPUT_PORT_P (port) - && scm_port_buffer_can_put (pt->write_buf) > 1) + && scm_port_buffer_can_put (pti->write_buf) > 1) /* Buffered output possible. The "> 1" is because writing the last byte would flush the port. */ revents |= POLLOUT; diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index 28b9c5f2d..948c27bcb 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -27,6 +27,39 @@ #include "libguile/_scm.h" #include "libguile/ports.h" +/* Port buffers. + + It's important to avoid calling into the kernel too many times. For + that reason we buffer the input and output, using "port buffer" + objects. Port buffers are represented as vectors containing the + buffer, two cursors, and a flag. The bytes in a read buffer are laid + out like this: + + |already read | not yet | invalid + | data | read | data + readbuf: #vu8(|r r r r r r r|u u u u u|x x x x x|) + ^buf ^cur ^end ^size(buf) + + Similarly for a write buffer: + + |already written | not yet | invalid + | data | written | data + writebuf: #vu8(|w w w w w w w w |u u u u u|x x x x x|) + ^buf ^cur ^end ^size(buf) + + We use the same port buffer data structure for both purposes. Port + buffers are implemented as their own object so that they can be + atomically swapped in or out of ports, and as Scheme vectors so they + can be manipulated from Scheme. */ + +enum scm_port_buffer_field { + SCM_PORT_BUFFER_FIELD_BYTEVECTOR, + SCM_PORT_BUFFER_FIELD_CUR, + SCM_PORT_BUFFER_FIELD_END, + SCM_PORT_BUFFER_FIELD_HAS_EOF_P, + SCM_PORT_BUFFER_FIELD_COUNT +}; + /* The port buffers are exposed to Scheme, which can mutate their fields. We have to do dynamic checks to ensure that potentially-malicious Scheme doesn't invalidate our invariants. @@ -233,6 +266,24 @@ struct scm_port_internal long line_number; int column_number; + /* Port buffers. */ + SCM read_buf; + SCM write_buf; + + /* All ports have read and write buffers; an unbuffered port simply + has a one-byte buffer. However unreading bytes can expand the read + buffer, but that doesn't mean that we want to increase the input + buffering. For that reason `read_buffering' is a separate + indication of how many characters to buffer on the read side. + There isn't a write_buf_size because there isn't an + `unwrite-byte'. */ + size_t read_buffering; + + /* True if the port is random access. Implies that the buffers must + be flushed before switching between reading and writing, seeking, + and so on. */ + int rw_random; + unsigned at_stream_start_for_bom_read : 1; unsigned at_stream_start_for_bom_write : 1; scm_t_iconv_descriptors *iconv_descriptors; diff --git a/libguile/ports.c b/libguile/ports.c index fe877acd8..763e006bc 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -358,7 +358,8 @@ scm_set_port_get_natural_buffer_sizes static void scm_i_clear_pending_eof (SCM port) { - scm_port_buffer_set_has_eof_p (SCM_PTAB_ENTRY (port)->read_buf, SCM_BOOL_F); + scm_port_buffer_set_has_eof_p (SCM_PORT_GET_INTERNAL (port)->read_buf, + SCM_BOOL_F); } SCM_DEFINE (scm_i_port_property, "%port-property", 2, 0, 0, @@ -682,7 +683,7 @@ static const size_t default_buffer_size = 1024; static void initialize_port_buffers (SCM port) { - scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port); size_t read_buf_size, write_buf_size; @@ -704,9 +705,9 @@ initialize_port_buffers (SCM port) if (!SCM_OUTPUT_PORT_P (port)) write_buf_size = 1; - pt->read_buffering = read_buf_size; - pt->read_buf = scm_c_make_port_buffer (read_buf_size); - pt->write_buf = scm_c_make_port_buffer (write_buf_size); + pti->read_buffering = read_buf_size; + pti->read_buf = scm_c_make_port_buffer (read_buf_size); + pti->write_buf = scm_c_make_port_buffer (write_buf_size); } SCM @@ -746,7 +747,7 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits, initialize_port_buffers (ret); - entry->rw_random = ptob->random_access_p (ret); + pti->rw_random = ptob->random_access_p (ret); return ret; } @@ -1282,15 +1283,9 @@ SCM_DEFINE (scm_port_conversion_strategy, "port-conversion-strategy", { if (scm_is_false (port)) return scm_i_default_port_conversion_strategy (); - else - { - scm_t_port *pt; - SCM_VALIDATE_OPPORT (1, port); - pt = SCM_PTAB_ENTRY (port); - - return pt->conversion_strategy; - } + SCM_VALIDATE_OPPORT (1, port); + return SCM_PTAB_ENTRY (port)->conversion_strategy; } #undef FUNC_NAME @@ -1339,7 +1334,7 @@ SCM_DEFINE (scm_set_port_conversion_strategy_x, "set-port-conversion-strategy!", static int get_byte_or_eof (SCM port) { - SCM buf = SCM_PTAB_ENTRY (port)->read_buf; + SCM buf = SCM_PORT_GET_INTERNAL (port)->read_buf; SCM buf_bv, buf_cur, buf_end; size_t cur; @@ -1380,7 +1375,7 @@ get_byte_or_eof (SCM port) static int peek_byte_or_eof (SCM port) { - SCM buf = SCM_PTAB_ENTRY (port)->read_buf; + SCM buf = SCM_PORT_GET_INTERNAL (port)->read_buf; SCM buf_bv, buf_cur, buf_end; size_t cur; @@ -1457,16 +1452,16 @@ scm_c_read_bytes (SCM port, SCM dst, size_t start, size_t count) #define FUNC_NAME "scm_c_read_bytes" { size_t to_read = count; - scm_t_port *pt; + scm_t_port_internal *pti; SCM read_buf; scm_t_uint8 *dst_ptr = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (dst) + start; SCM_VALIDATE_OPINPORT (1, port); - pt = SCM_PTAB_ENTRY (port); - read_buf = pt->read_buf; + pti = SCM_PORT_GET_INTERNAL (port); + read_buf = pti->read_buf; - if (pt->rw_random) + if (pti->rw_random) scm_flush (port); port_clear_stream_start_for_bom_read (port, BOM_IO_BINARY); @@ -1485,7 +1480,7 @@ scm_c_read_bytes (SCM port, SCM dst, size_t start, size_t count) /* If the read is smaller than the buffering on the read side of this port, then go through the buffer. Otherwise fill our buffer directly. */ - if (to_read < pt->read_buffering) + if (to_read < pti->read_buffering) { read_buf = scm_fill_input (port, 0); did_read = scm_port_buffer_take (read_buf, dst_ptr, to_read); @@ -1522,16 +1517,16 @@ scm_c_read (SCM port, void *buffer, size_t size) #define FUNC_NAME "scm_c_read" { size_t copied = 0; - scm_t_port *pt; + scm_t_port_internal *pti; SCM read_buf; scm_t_uint8 *dst = buffer; SCM_VALIDATE_OPINPORT (1, port); - pt = SCM_PTAB_ENTRY (port); - read_buf = pt->read_buf; + pti = SCM_PORT_GET_INTERNAL (port); + read_buf = pti->read_buf; - if (pt->rw_random) + if (pti->rw_random) scm_flush (port); while (copied < size) @@ -1851,7 +1846,7 @@ scm_getc (SCM port) scm_t_wchar codepoint; codepoint = peek_codepoint (port, &len); - scm_port_buffer_did_take (SCM_PTAB_ENTRY (port)->read_buf, len); + scm_port_buffer_did_take (SCM_PORT_GET_INTERNAL (port)->read_buf, len); if (codepoint == EOF) scm_i_clear_pending_eof (port); update_port_lf (codepoint, port); @@ -1893,10 +1888,10 @@ void scm_unget_bytes (const scm_t_uint8 *buf, size_t len, SCM port) #define FUNC_NAME "scm_unget_bytes" { - scm_t_port *pt = SCM_PTAB_ENTRY (port); - SCM read_buf = pt->read_buf; + scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); + SCM read_buf = pti->read_buf; - if (pt->rw_random) + if (pti->rw_random) scm_flush (port); if (scm_port_buffer_can_putback (read_buf) < len) @@ -2115,7 +2110,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, #define FUNC_NAME s_scm_setvbuf { long csize; - scm_t_port *pt; + scm_t_port_internal *pti; scm_t_ptob_descriptor *ptob; scm_t_bits tag_word; size_t read_buf_size, write_buf_size; @@ -2124,7 +2119,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); - pt = SCM_PTAB_ENTRY (port); + pti = SCM_PORT_GET_INTERNAL (port); ptob = SCM_PORT_DESCRIPTOR (port); tag_word = SCM_CELL_WORD_0 (port) & ~(SCM_BUF0 | SCM_BUFLINE); @@ -2168,12 +2163,12 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, if (SCM_OUTPUT_PORT_P (port)) scm_flush (port); - saved_read_buf = pt->read_buf; + saved_read_buf = pti->read_buf; SCM_SET_CELL_WORD_0 (port, tag_word); - pt->read_buffering = read_buf_size; - pt->read_buf = scm_c_make_port_buffer (read_buf_size); - pt->write_buf = scm_c_make_port_buffer (write_buf_size); + pti->read_buffering = read_buf_size; + pti->read_buf = scm_c_make_port_buffer (read_buf_size); + pti->write_buf = scm_c_make_port_buffer (write_buf_size); if (saved_read_buf) scm_unget_bytes (scm_port_buffer_take_pointer (saved_read_buf), @@ -2181,7 +2176,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, port); if (saved_read_buf) - scm_port_buffer_set_has_eof_p (pt->read_buf, + scm_port_buffer_set_has_eof_p (pti->read_buf, scm_port_buffer_has_eof_p (saved_read_buf)); return SCM_UNSPECIFIED; @@ -2194,7 +2189,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len) { - SCM read_buf = SCM_PTAB_ENTRY (port)->read_buf; + SCM read_buf = SCM_PORT_GET_INTERNAL (port)->read_buf; return scm_port_buffer_take (read_buf, (scm_t_uint8 *) dest, read_len); } @@ -2216,14 +2211,11 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, "for further input.") #define FUNC_NAME s_scm_drain_input { - SCM result; - scm_t_port *pt; - SCM read_buf; + SCM read_buf, result; long count; SCM_VALIDATE_OPINPORT (1, port); - pt = SCM_PTAB_ENTRY (port); - read_buf = pt->read_buf; + read_buf = SCM_PORT_GET_INTERNAL (port)->read_buf; count = scm_port_buffer_can_take (read_buf); if (count) @@ -2245,7 +2237,7 @@ scm_end_input (SCM port) SCM buf; size_t discarded; - buf = SCM_PTAB_ENTRY (port)->read_buf; + buf = SCM_PORT_GET_INTERNAL (port)->read_buf; discarded = scm_port_buffer_take (buf, NULL, (size_t) -1); if (discarded != 0) @@ -2279,7 +2271,7 @@ static void scm_i_write (SCM port, SCM buf); void scm_flush (SCM port) { - SCM buf = SCM_PTAB_ENTRY (port)->write_buf; + SCM buf = SCM_PORT_GET_INTERNAL (port)->write_buf; if (scm_port_buffer_can_take (buf)) scm_i_write (port, buf); } @@ -2314,15 +2306,14 @@ static size_t port_clear_stream_start_for_bom_read (SCM port, enum bom_io_mode io_mode) { scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); - scm_t_port *pt; + scm_t_port *pt = SCM_PTAB_ENTRY (port); if (!pti->at_stream_start_for_bom_read) return 0; /* Maybe slurp off a byte-order marker. */ - pt = SCM_PTAB_ENTRY (port); pti->at_stream_start_for_bom_read = 0; - if (pt->rw_random) + if (pti->rw_random) pti->at_stream_start_for_bom_write = 0; if (io_mode == BOM_IO_BINARY) @@ -2377,7 +2368,6 @@ SCM_DEFINE (scm_port_clear_stream_start_for_bom_read, #define FUNC_NAME s_scm_port_clear_stream_start_for_bom_read { scm_t_port_internal *pti; - scm_t_port *pt; SCM_VALIDATE_PORT (1, port); @@ -2386,9 +2376,8 @@ SCM_DEFINE (scm_port_clear_stream_start_for_bom_read, return SCM_BOOL_F; /* Maybe slurp off a byte-order marker. */ - pt = SCM_PTAB_ENTRY (port); pti->at_stream_start_for_bom_read = 0; - if (pt->rw_random) + if (pti->rw_random) pti->at_stream_start_for_bom_write = 0; return SCM_BOOL_T; @@ -2406,7 +2395,7 @@ port_clear_stream_start_for_bom_write (SCM port, enum bom_io_mode io_mode) /* Record that we're no longer at stream start. */ pti->at_stream_start_for_bom_write = 0; - if (pt->rw_random) + if (pti->rw_random) pti->at_stream_start_for_bom_read = 0; /* Write a BOM if appropriate. */ @@ -2431,7 +2420,7 @@ port_clear_stream_start_for_bom_write (SCM port, enum bom_io_mode io_mode) SCM scm_fill_input (SCM port, size_t minimum_size) { - scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); SCM read_buf; size_t buffered; @@ -2439,14 +2428,14 @@ scm_fill_input (SCM port, size_t minimum_size) minimum_size = 1; port_clear_stream_start_for_bom_read (port, BOM_IO_TEXT); - read_buf = pt->read_buf; + read_buf = pti->read_buf; buffered = scm_port_buffer_can_take (read_buf); if (buffered >= minimum_size || scm_is_true (scm_port_buffer_has_eof_p (read_buf))) return read_buf; - if (pt->rw_random) + if (pti->rw_random) scm_flush (port); /* Prepare to read. Make sure there is enough space in the buffer for @@ -2471,10 +2460,10 @@ scm_fill_input (SCM port, size_t minimum_size) && !scm_is_true (scm_port_buffer_has_eof_p (read_buf))) { size_t count; - size_t buffering = pt->read_buffering; + size_t buffering = pti->read_buffering; size_t to_read; - if (pt->read_buffering < minimum_size) + if (pti->read_buffering < minimum_size) buffering = minimum_size; to_read = buffering - buffered; @@ -2494,7 +2483,7 @@ SCM_DEFINE (scm_port_random_access_p, "port-random-access?", 1, 0, 0, #define FUNC_NAME s_scm_port_random_access_p { SCM_VALIDATE_OPPORT (1, port); - return scm_from_bool (SCM_PTAB_ENTRY (port)->rw_random); + return scm_from_bool (SCM_PORT_GET_INTERNAL (port)->rw_random); } #undef FUNC_NAME @@ -2504,7 +2493,7 @@ SCM_DEFINE (scm_port_read_buffering, "port-read-buffering", 1, 0, 0, #define FUNC_NAME s_scm_port_read_buffering { SCM_VALIDATE_OPINPORT (1, port); - return scm_from_size_t (SCM_PTAB_ENTRY (port)->read_buffering); + return scm_from_size_t (SCM_PORT_GET_INTERNAL (port)->read_buffering); } #undef FUNC_NAME @@ -2516,35 +2505,35 @@ SCM_DEFINE (scm_expand_port_read_buffer_x, "expand-port-read-buffer!", 2, 1, 0, "to the end instead. Return the new buffer.") #define FUNC_NAME s_scm_expand_port_read_buffer_x { - scm_t_port *pt; + scm_t_port_internal *pti; size_t c_size; SCM new_buf; SCM_VALIDATE_OPINPORT (1, port); - pt = SCM_PTAB_ENTRY (port); + pti = SCM_PORT_GET_INTERNAL (port); c_size = scm_to_size_t (size); - SCM_ASSERT_RANGE (2, size, c_size > scm_port_buffer_size (pt->read_buf)); + SCM_ASSERT_RANGE (2, size, c_size > scm_port_buffer_size (pti->read_buf)); if (SCM_UNBNDP (putback_p)) putback_p = SCM_BOOL_F; new_buf = scm_c_make_port_buffer (c_size); scm_port_buffer_set_has_eof_p (new_buf, - scm_port_buffer_has_eof_p (pt->read_buf)); + scm_port_buffer_has_eof_p (pti->read_buf)); if (scm_is_true (putback_p)) { scm_port_buffer_reset_end (new_buf); scm_port_buffer_putback (new_buf, - scm_port_buffer_take_pointer (pt->read_buf), - scm_port_buffer_can_take (pt->read_buf)); + scm_port_buffer_take_pointer (pti->read_buf), + scm_port_buffer_can_take (pti->read_buf)); } else { scm_port_buffer_reset (new_buf); scm_port_buffer_put (new_buf, - scm_port_buffer_take_pointer (pt->read_buf), - scm_port_buffer_can_take (pt->read_buf)); + scm_port_buffer_take_pointer (pti->read_buf), + scm_port_buffer_can_take (pti->read_buf)); } - pt->read_buf = new_buf; + pti->read_buf = new_buf; return new_buf; } @@ -2575,7 +2564,7 @@ SCM_DEFINE (scm_port_read_buffer, "port-read-buffer", 1, 0, 0, #define FUNC_NAME s_scm_port_read_buffer { SCM_VALIDATE_OPPORT (1, port); - return SCM_PTAB_ENTRY (port)->read_buf; + return SCM_PORT_GET_INTERNAL (port)->read_buf; } #undef FUNC_NAME @@ -2585,7 +2574,7 @@ SCM_DEFINE (scm_port_write_buffer, "port-write-buffer", 1, 0, 0, #define FUNC_NAME s_scm_port_write_buffer { SCM_VALIDATE_OPPORT (1, port); - return SCM_PTAB_ENTRY (port)->write_buf; + return SCM_PORT_GET_INTERNAL (port)->write_buf; } #undef FUNC_NAME @@ -2653,15 +2642,15 @@ void scm_c_write_bytes (SCM port, SCM src, size_t start, size_t count) #define FUNC_NAME "scm_c_write_bytes" { - scm_t_port *pt; + scm_t_port_internal *pti; SCM write_buf; SCM_VALIDATE_OPOUTPORT (1, port); - pt = SCM_PTAB_ENTRY (port); - write_buf = pt->write_buf; + pti = SCM_PORT_GET_INTERNAL (port); + write_buf = pti->write_buf; - if (pt->rw_random) + if (pti->rw_random) scm_end_input (port); if (count < scm_port_buffer_size (write_buf)) @@ -2706,17 +2695,17 @@ void scm_c_write (SCM port, const void *ptr, size_t size) #define FUNC_NAME "scm_c_write" { - scm_t_port *pt; + scm_t_port_internal *pti; SCM write_buf; size_t written = 0; const scm_t_uint8 *src = ptr; SCM_VALIDATE_OPOUTPORT (1, port); - pt = SCM_PTAB_ENTRY (port); - write_buf = pt->write_buf; + pti = SCM_PORT_GET_INTERNAL (port); + write_buf = pti->write_buf; - if (pt->rw_random) + if (pti->rw_random) scm_end_input (port); while (written < size) @@ -2788,7 +2777,6 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, "interactive port that has no ready characters.") #define FUNC_NAME s_scm_char_ready_p { - scm_t_port *pt; SCM read_buf; if (SCM_UNBNDP (port)) @@ -2797,8 +2785,7 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, this case. */ SCM_VALIDATE_OPINPORT (1, port); - pt = SCM_PTAB_ENTRY (port); - read_buf = pt->read_buf; + read_buf = SCM_PORT_GET_INTERNAL (port)->read_buf; if (scm_port_buffer_can_take (read_buf) || scm_is_true (scm_port_buffer_has_eof_p (read_buf))) @@ -2853,13 +2840,12 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, if (SCM_OPPORTP (fd_port)) { - scm_t_port *pt = SCM_PTAB_ENTRY (fd_port); scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (fd_port); scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (fd_port); off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset); off_t_or_off64_t rv; - if (!ptob->seek || !pt->rw_random) + if (!ptob->seek || !pti->rw_random) SCM_MISC_ERROR ("port is not seekable", scm_cons (fd_port, SCM_EOL)); @@ -2970,7 +2956,8 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, scm_i_clear_pending_eof (object); - if (SCM_INPUT_PORT_P (object) && SCM_PTAB_ENTRY (object)->rw_random) + if (SCM_INPUT_PORT_P (object) + && SCM_PORT_GET_INTERNAL (object)->rw_random) scm_end_input (object); scm_flush (object); diff --git a/libguile/ports.h b/libguile/ports.h index efaa7654f..14f4c83db 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -44,39 +44,6 @@ /* An internal-only structure defined in ports-internal.h. */ struct scm_port_internal; -/* Port buffers. - - It's important to avoid calling into the kernel too many times. For - that reason we buffer the input and output, using "port buffer" - objects. Port buffers are represented as vectors containing the - buffer, two cursors, and a flag. The bytes in a read buffer are laid - out like this: - - |already read | not yet | invalid - | data | read | data - readbuf: #vu8(|r r r r r r r|u u u u u|x x x x x|) - ^buf ^cur ^end ^size(buf) - - Similarly for a write buffer: - - |already written | not yet | invalid - | data | written | data - writebuf: #vu8(|w w w w w w w w |u u u u u|x x x x x|) - ^buf ^cur ^end ^size(buf) - - We use the same port buffer data structure for both purposes. Port - buffers are implemented as their own object so that they can be - atomically swapped in or out of ports, and as Scheme vectors so they - can be manipulated from Scheme. */ - -enum scm_port_buffer_field { - SCM_PORT_BUFFER_FIELD_BYTEVECTOR, - SCM_PORT_BUFFER_FIELD_CUR, - SCM_PORT_BUFFER_FIELD_END, - SCM_PORT_BUFFER_FIELD_HAS_EOF_P, - SCM_PORT_BUFFER_FIELD_COUNT -}; - /* C representation of a Scheme port. */ typedef struct @@ -84,24 +51,6 @@ typedef struct /* Data for the underlying port implementation as a raw C value. */ scm_t_bits stream; - /* Port buffers. */ - SCM read_buf; - SCM write_buf; - - /* All ports have read and write buffers; an unbuffered port simply - has a one-byte buffer. However unreading bytes can expand the read - buffer, but that doesn't mean that we want to increase the input - buffering. For that reason `read_buffering' is a separate - indication of how many characters to buffer on the read side. - There isn't a write_buf_size because there isn't an - `unwrite-byte'. */ - size_t read_buffering; - - /* True if the port is random access. Implies that the buffers must - be flushed before switching between reading and writing, seeking, - and so on. */ - int rw_random; - /* Character encoding support. */ SCM encoding; /* A symbol of upper-case ASCII. */ SCM conversion_strategy; /* A symbol; either substitute, error, or escape. */ diff --git a/libguile/read.c b/libguile/read.c index a4183d9a6..ede8a613c 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -2057,7 +2057,7 @@ is_encoding_char (char c) char * scm_i_scan_for_encoding (SCM port) { - scm_t_port *pt; + scm_t_port_internal *pti; SCM buf; char header[SCM_ENCODING_SEARCH_SIZE+1]; size_t bytes_read, encoding_length, i; @@ -2065,10 +2065,10 @@ scm_i_scan_for_encoding (SCM port) char *pos, *encoding_start; int in_comment; - pt = SCM_PTAB_ENTRY (port); - buf = pt->read_buf; + pti = SCM_PORT_GET_INTERNAL (port); + buf = pti->read_buf; - if (pt->rw_random) + if (pti->rw_random) scm_flush (port); if (scm_port_buffer_can_take (buf) == 0) diff --git a/libguile/rw.c b/libguile/rw.c index b3d1f1614..0b89bc2e7 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -236,7 +236,7 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0, SCM_VALIDATE_OPFPORT (2, port); SCM_VALIDATE_OUTPUT_PORT (2, port); - write_buf = SCM_PTAB_ENTRY (port)->write_buf; + write_buf = SCM_PORT_GET_INTERNAL (port)->write_buf; /* Filling the last character in the buffer would require a flush. */ From e5d2f4e566586f768bda99c28a74fd2303ecace1 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 13 May 2016 11:21:41 +0200 Subject: [PATCH 275/865] Make scm_t_port private * libguile/ports-internal.h (enum scm_port_encoding_mode): Remove unused enum. (scm_t_port_internal, scm_t_port): Make encoding and conversion_strategy private. Instead of scm_t_port_internal containing scm_t_port, now that all members are private, we can store the user's "stream" in a word in the port object itself and make the whole of scm_t_port private. The next commit will remove scm_t_port_internal. (SCM_PTAB_ENTRY, SCM_PORT_DESCRIPTOR): Make private. * libguile/ports.c (scm_c_make_port_with_encoding): Adapt to new port layout. (scm_port_print): Use SCM_PTAB_ENTRY when printing. * libguile/ports.h: Remove scm_t_port definition. * libguile/ioext.c (get_matching_port): Simplify. * libguile/fports.c (scm_i_evict_port): Simplify. --- libguile/fports.c | 11 ++--------- libguile/ioext.c | 4 +--- libguile/ports-internal.h | 22 ++++++++++------------ libguile/ports.c | 34 ++++++++++++++++------------------ libguile/ports.h | 24 +++--------------------- 5 files changed, 32 insertions(+), 63 deletions(-) diff --git a/libguile/fports.c b/libguile/fports.c index aab83c9d3..c756129d7 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -83,16 +83,9 @@ scm_i_evict_port (void *closure, SCM port) { int fd = * (int*) closure; - if (SCM_FPORTP (port)) + if (SCM_OPFPORTP (port)) { - scm_t_port *p; - scm_t_fport *fp; - - /* XXX: In some cases, we can encounter a port with no associated ptab - entry. */ - p = SCM_PTAB_ENTRY (port); - fp = (p != NULL) ? (scm_t_fport *) p->stream : NULL; - + scm_t_fport *fp = SCM_FSTREAM (port); if ((fp != NULL) && (fp->fdes == fd)) { fp->fdes = dup (fd); diff --git a/libguile/ioext.c b/libguile/ioext.c index 36ca07baa..68f069313 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -276,10 +276,8 @@ static SCM get_matching_port (void *closure, SCM port, SCM result) { int fd = * (int *) closure; - scm_t_port *entry = SCM_PTAB_ENTRY (port); - if (SCM_OPFPORTP (port) - && ((scm_t_fport *) entry->stream)->fdes == fd) + if (SCM_OPFPORTP (port) && SCM_FSTREAM (port)->fdes == fd) result = scm_cons (port, result); return result; diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index 948c27bcb..e2a672d8b 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -231,14 +231,6 @@ scm_port_buffer_putback (SCM buf, const scm_t_uint8 *src, size_t count) src, count); } -enum scm_port_encoding_mode { - SCM_PORT_ENCODING_MODE_UTF8, - SCM_PORT_ENCODING_MODE_LATIN1, - SCM_PORT_ENCODING_MODE_ICONV -}; - -typedef enum scm_port_encoding_mode scm_t_port_encoding_mode; - /* This is a separate object so that only those ports that use iconv cause finalizers to be registered. */ struct scm_iconv_descriptors @@ -257,10 +249,8 @@ struct scm_iconv_descriptors typedef struct scm_iconv_descriptors scm_t_iconv_descriptors; -struct scm_port_internal +struct scm_port { - scm_t_port pt; - /* Source location information. */ SCM file_name; long line_number; @@ -284,13 +274,21 @@ struct scm_port_internal and so on. */ int rw_random; + /* Character encoding support. */ + SCM encoding; /* A symbol of upper-case ASCII. */ + SCM conversion_strategy; /* A symbol; either substitute, error, or escape. */ + unsigned at_stream_start_for_bom_read : 1; unsigned at_stream_start_for_bom_write : 1; scm_t_iconv_descriptors *iconv_descriptors; SCM alist; }; -typedef struct scm_port_internal scm_t_port_internal; +typedef struct scm_port scm_t_port; +typedef scm_t_port scm_t_port_internal; + +#define SCM_PTAB_ENTRY(x) ((scm_t_port *) SCM_CELL_WORD_2 (x)) +#define SCM_PORT_DESCRIPTOR(port) ((scm_t_ptob_descriptor *) SCM_CELL_WORD_3 (port)) #define SCM_UNICODE_BOM 0xFEFFUL /* Unicode byte-order mark */ diff --git a/libguile/ports.c b/libguile/ports.c index 763e006bc..ba6be67c3 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -55,7 +55,7 @@ #include "libguile/strings.h" #include "libguile/mallocs.h" #include "libguile/validate.h" -#include "libguile/ports.h" +//#include "libguile/ports.h" #include "libguile/ports-internal.h" #include "libguile/vectors.h" #include "libguile/weak-set.h" @@ -716,28 +716,26 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits, scm_t_bits stream) { SCM ret; - scm_t_port *entry; - scm_t_port_internal *pti; + scm_t_port *pt; scm_t_ptob_descriptor *ptob; - pti = scm_gc_typed_calloc (scm_t_port_internal); - entry = &pti->pt; + pt = scm_gc_typed_calloc (scm_t_port); ptob = scm_c_port_type_ref (SCM_TC2PTOBNUM (tag)); - ret = scm_words (tag | mode_bits, 3); - SCM_SET_CELL_WORD_1 (ret, (scm_t_bits) entry); - SCM_SET_CELL_WORD_2 (ret, (scm_t_bits) ptob); + ret = scm_words (tag | mode_bits, 4); + SCM_SET_CELL_WORD_1 (ret, stream); + SCM_SET_CELL_WORD_2 (ret, (scm_t_bits) pt); + SCM_SET_CELL_WORD_3 (ret, (scm_t_bits) ptob); - entry->stream = stream; - entry->encoding = encoding; - entry->conversion_strategy = conversion_strategy; - pti->file_name = SCM_BOOL_F; - pti->iconv_descriptors = NULL; + pt->encoding = encoding; + pt->conversion_strategy = conversion_strategy; + pt->file_name = SCM_BOOL_F; + pt->iconv_descriptors = NULL; - pti->at_stream_start_for_bom_read = 1; - pti->at_stream_start_for_bom_write = 1; + pt->at_stream_start_for_bom_read = 1; + pt->at_stream_start_for_bom_write = 1; - pti->alist = SCM_EOL; + pt->alist = SCM_EOL; if (SCM_PORT_DESCRIPTOR (ret)->flags & SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC) { @@ -747,7 +745,7 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits, initialize_port_buffers (ret); - pti->rw_random = ptob->random_access_p (ret); + pt->rw_random = ptob->random_access_p (ret); return ret; } @@ -3098,7 +3096,7 @@ scm_port_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) scm_print_port_mode (exp, port); scm_puts (type, port); scm_putc (' ', port); - scm_uintprint (SCM_CELL_WORD_1 (exp), 16, port); + scm_uintprint ((scm_t_bits) SCM_PTAB_ENTRY (exp), 16, port); scm_putc ('>', port); return 1; } diff --git a/libguile/ports.h b/libguile/ports.h index 14f4c83db..f90a6b6c5 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -41,22 +41,6 @@ -/* An internal-only structure defined in ports-internal.h. */ -struct scm_port_internal; - -/* C representation of a Scheme port. */ - -typedef struct -{ - /* Data for the underlying port implementation as a raw C value. */ - scm_t_bits stream; - - /* Character encoding support. */ - SCM encoding; /* A symbol of upper-case ASCII. */ - SCM conversion_strategy; /* A symbol; either substitute, error, or escape. */ -} scm_t_port; - - SCM_INTERNAL SCM scm_i_port_weak_set; @@ -86,11 +70,9 @@ SCM_INTERNAL SCM scm_i_port_weak_set; #define SCM_CLR_PORT_OPEN_FLAG(p) \ SCM_SET_CELL_WORD_0 ((p), SCM_CELL_WORD_0 (p) & ~SCM_OPN) -#define SCM_PTAB_ENTRY(x) ((scm_t_port *) SCM_CELL_WORD_1 (x)) -#define SCM_PORT_DESCRIPTOR(port) ((scm_t_ptob_descriptor *) SCM_CELL_WORD_2 (port)) -#define SCM_SETPTAB_ENTRY(x, ent) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (ent))) -#define SCM_STREAM(x) (SCM_PTAB_ENTRY(x)->stream) -#define SCM_SETSTREAM(x, s) (SCM_PTAB_ENTRY(x)->stream = (scm_t_bits) (s)) +#define SCM_STREAM(port) (SCM_CELL_WORD_1 (port)) +#define SCM_SETSTREAM(port, stream) (SCM_SET_CELL_WORD_1 (port, stream)) + /* Maximum number of port types. */ #define SCM_I_MAX_PORT_TYPE_COUNT 256 From 08574987d95c1dbe019398ef5aeb5642f08ac49c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 13 May 2016 11:34:52 +0200 Subject: [PATCH 276/865] Remove scm_t_port_internal * libguile/ports-internal.h (SCM_PORT): Rename from SCM_PTAB_ENTRY. (scm_t_port_internal, SCM_PORT_GET_INTERNAL): Remove. (SCM_FILENAME, SCM_SET_FILENAME, SCM_LINUM, SCM_COL): Adapt. * libguile/ports.c: * libguile/poll.c: * libguile/ioext.c: * libguile/fports.c: * libguile/filesys.c: * libguile/print.c: * libguile/read.c: * libguile/rw.c: * libguile/strings.c: Adapt. --- libguile/filesys.c | 14 +-- libguile/fports.c | 2 +- libguile/ioext.c | 7 +- libguile/poll.c | 12 +- libguile/ports-internal.h | 13 +-- libguile/ports.c | 230 +++++++++++++++++++------------------- libguile/print.c | 2 +- libguile/read.c | 10 +- libguile/rw.c | 2 +- libguile/strings.c | 4 +- 10 files changed, 142 insertions(+), 154 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index 35e15cba8..273de9790 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -650,19 +650,15 @@ set_element (fd_set *set, SCM *ports_ready, SCM element, int pos) SCM_ASSERT (SCM_OPFPORTP (element), element, pos, "select"); if (pos == SCM_ARG1) { - /* check whether port has buffered input. */ - scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (element); - - if (scm_port_buffer_can_take (pti->read_buf) > 0) + /* Check whether port has input buffered. */ + if (scm_port_buffer_can_take (SCM_PORT (element)->read_buf) > 0) use_buf = 1; } else if (pos == SCM_ARG2) { - /* check whether port's output buffer has room. */ - scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (element); - - /* > 1 since writing the last byte in the buffer causes flush. */ - if (scm_port_buffer_can_put (pti->write_buf) > 1) + /* Check whether port's output buffer has room. > 1 since + writing the last byte in the buffer causes flush. */ + if (scm_port_buffer_can_put (SCM_PORT (element)->write_buf) > 1) use_buf = 1; } fd = use_buf ? -1 : SCM_FPORT_FDES (element); diff --git a/libguile/fports.c b/libguile/fports.c index c756129d7..dd1c1ac79 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -562,7 +562,7 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port); scm_putc (' ', port); - scm_uintprint ((scm_t_bits) SCM_PTAB_ENTRY (exp), 16, port); + scm_uintprint ((scm_t_bits) SCM_PORT (exp), 16, port); } scm_putc ('>', port); return 1; diff --git a/libguile/ioext.c b/libguile/ioext.c index 68f069313..58a6219f3 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -91,20 +91,19 @@ SCM_DEFINE (scm_redirect_port, "redirect-port", 2, 0, 0, buffers. */ if (SCM_OUTPUT_PORT_P (old)) scm_flush (old); - if (SCM_INPUT_PORT_P (old) && SCM_PORT_GET_INTERNAL (old)->rw_random) + if (SCM_INPUT_PORT_P (old) && SCM_PORT (old)->rw_random) scm_end_input (old); if (SCM_OUTPUT_PORT_P (new)) scm_flush (new); - if (SCM_INPUT_PORT_P (new) && SCM_PORT_GET_INTERNAL (new)->rw_random) + if (SCM_INPUT_PORT_P (new) && SCM_PORT (new)->rw_random) scm_end_input (new); ans = dup2 (oldfd, newfd); if (ans == -1) SCM_SYSERROR; - SCM_PORT_GET_INTERNAL (new)->rw_random = - SCM_PORT_GET_INTERNAL (old)->rw_random; + SCM_PORT (new)->rw_random = SCM_PORT (old)->rw_random; } return SCM_UNSPECIFIED; } diff --git a/libguile/poll.c b/libguile/poll.c index fa90abbcd..64f3cef24 100644 --- a/libguile/poll.c +++ b/libguile/poll.c @@ -107,13 +107,13 @@ scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout) revents |= POLLERR; else { - scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); + scm_t_port *pt = SCM_PORT (port); - if (scm_port_buffer_can_take (pti->read_buf) > 0) + if (scm_port_buffer_can_take (pt->read_buf) > 0) /* Buffered input waiting to be read. */ revents |= POLLIN; if (SCM_OUTPUT_PORT_P (port) - && scm_port_buffer_can_put (pti->write_buf) > 1) + && scm_port_buffer_can_put (pt->write_buf) > 1) /* Buffered output possible. The "> 1" is because writing the last byte would flush the port. */ revents |= POLLOUT; @@ -145,13 +145,13 @@ scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout) revents |= POLLERR; else { - scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); + scm_t_port *pt = SCM_PORT (port); - if (scm_port_buffer_can_take (pti->read_buf) > 0) + if (scm_port_buffer_can_take (pt->read_buf) > 0) /* Buffered input waiting to be read. */ revents |= POLLIN; if (SCM_OUTPUT_PORT_P (port) - && scm_port_buffer_can_put (pti->write_buf) > 1) + && scm_port_buffer_can_put (pt->write_buf) > 1) /* Buffered output possible. The "> 1" is because writing the last byte would flush the port. */ revents |= POLLOUT; diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index e2a672d8b..e56d40ba1 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -285,19 +285,16 @@ struct scm_port }; typedef struct scm_port scm_t_port; -typedef scm_t_port scm_t_port_internal; -#define SCM_PTAB_ENTRY(x) ((scm_t_port *) SCM_CELL_WORD_2 (x)) +#define SCM_PORT(x) ((scm_t_port *) SCM_CELL_WORD_2 (x)) #define SCM_PORT_DESCRIPTOR(port) ((scm_t_ptob_descriptor *) SCM_CELL_WORD_3 (port)) #define SCM_UNICODE_BOM 0xFEFFUL /* Unicode byte-order mark */ -#define SCM_PORT_GET_INTERNAL(x) ((scm_t_port_internal*) SCM_PTAB_ENTRY(x)) - -#define SCM_FILENAME(x) (SCM_PORT_GET_INTERNAL(x)->file_name) -#define SCM_SET_FILENAME(x, n) (SCM_PORT_GET_INTERNAL(x)->file_name = (n)) -#define SCM_LINUM(x) (SCM_PORT_GET_INTERNAL(x)->line_number) -#define SCM_COL(x) (SCM_PORT_GET_INTERNAL(x)->column_number) +#define SCM_FILENAME(x) (SCM_PORT (x)->file_name) +#define SCM_SET_FILENAME(x, n) (SCM_PORT (x)->file_name = (n)) +#define SCM_LINUM(x) (SCM_PORT (x)->line_number) +#define SCM_COL(x) (SCM_PORT (x)->column_number) #define SCM_INCLINE(port) do {SCM_LINUM (port) += 1; SCM_COL (port) = 0;} while (0) #define SCM_ZEROCOL(port) do {SCM_COL (port) = 0;} while (0) diff --git a/libguile/ports.c b/libguile/ports.c index ba6be67c3..9db949e4a 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -358,7 +358,7 @@ scm_set_port_get_natural_buffer_sizes static void scm_i_clear_pending_eof (SCM port) { - scm_port_buffer_set_has_eof_p (SCM_PORT_GET_INTERNAL (port)->read_buf, + scm_port_buffer_set_has_eof_p (SCM_PORT (port)->read_buf, SCM_BOOL_F); } @@ -369,7 +369,7 @@ SCM_DEFINE (scm_i_port_property, "%port-property", 2, 0, 0, { SCM_VALIDATE_OPPORT (1, port); - return scm_assq_ref (SCM_PORT_GET_INTERNAL (port)->alist, key); + return scm_assq_ref (SCM_PORT (port)->alist, key); } #undef FUNC_NAME @@ -378,12 +378,12 @@ SCM_DEFINE (scm_i_set_port_property_x, "%set-port-property!", 3, 0, 0, "Set the property of @var{port} associated with @var{key} to @var{value}.") #define FUNC_NAME s_scm_i_set_port_property_x { - scm_t_port_internal *pti; + scm_t_port *pt; SCM_VALIDATE_OPPORT (1, port); - pti = SCM_PORT_GET_INTERNAL (port); - pti->alist = scm_assq_set_x (pti->alist, key, value); + pt = SCM_PORT (port); + pt->alist = scm_assq_set_x (pt->alist, key, value); return SCM_UNSPECIFIED; } @@ -683,7 +683,7 @@ static const size_t default_buffer_size = 1024; static void initialize_port_buffers (SCM port) { - scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); + scm_t_port *pt = SCM_PORT (port); scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port); size_t read_buf_size, write_buf_size; @@ -705,9 +705,9 @@ initialize_port_buffers (SCM port) if (!SCM_OUTPUT_PORT_P (port)) write_buf_size = 1; - pti->read_buffering = read_buf_size; - pti->read_buf = scm_c_make_port_buffer (read_buf_size); - pti->write_buf = scm_c_make_port_buffer (write_buf_size); + pt->read_buffering = read_buf_size; + pt->read_buf = scm_c_make_port_buffer (read_buf_size); + pt->write_buf = scm_c_make_port_buffer (write_buf_size); } SCM @@ -845,7 +845,7 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, "descriptors.") #define FUNC_NAME s_scm_close_port { - scm_t_port_internal *pti; + scm_t_port *pt; port = SCM_COERCE_OUTPORT (port); @@ -857,7 +857,7 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, if (SCM_OUTPUT_PORT_P (port)) scm_flush (port); - pti = SCM_PORT_GET_INTERNAL (port); + pt = SCM_PORT (port); SCM_CLR_PORT_OPEN_FLAG (port); if (SCM_PORT_DESCRIPTOR (port)->flags & SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC) @@ -868,12 +868,12 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, should be resilient to non-local exits. */ SCM_PORT_DESCRIPTOR (port)->close (port); - if (pti->iconv_descriptors) + if (pt->iconv_descriptors) { /* If we don't get here, the iconv_descriptors finalizer will clean up. */ - close_iconv_descriptors (pti->iconv_descriptors); - pti->iconv_descriptors = NULL; + close_iconv_descriptors (pt->iconv_descriptors); + pt->iconv_descriptors = NULL; } return SCM_BOOL_T; @@ -1122,8 +1122,8 @@ close_iconv_descriptors (scm_t_iconv_descriptors *id) static void prepare_iconv_descriptors (SCM port, SCM encoding) { - scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); - scm_t_iconv_descriptors *desc = pti->iconv_descriptors; + scm_t_port *pt = SCM_PORT (port); + scm_t_iconv_descriptors *desc = pt->iconv_descriptors; /* If the specified encoding is UTF-16 or UTF-32, then default to big-endian byte order. This fallback isn't necessary if you read @@ -1137,7 +1137,7 @@ prepare_iconv_descriptors (SCM port, SCM encoding) if (desc && scm_is_eq (desc->precise_encoding, encoding)) return; - pti->iconv_descriptors = open_iconv_descriptors + pt->iconv_descriptors = open_iconv_descriptors (encoding, SCM_INPUT_PORT_P (port), SCM_OUTPUT_PORT_P (port)); } @@ -1151,13 +1151,13 @@ SCM_DEFINE (scm_specialize_port_encoding_x, SCM_VALIDATE_PORT (1, port); SCM_VALIDATE_SYMBOL (2, encoding); - if (scm_is_eq (SCM_PTAB_ENTRY (port)->encoding, sym_UTF_16)) + if (scm_is_eq (SCM_PORT (port)->encoding, sym_UTF_16)) { if (!scm_is_eq (encoding, sym_UTF_16LE) && !scm_is_eq (encoding, sym_UTF_16BE)) SCM_OUT_OF_RANGE (2, encoding); } - else if (scm_is_eq (SCM_PTAB_ENTRY (port)->encoding, sym_UTF_32)) + else if (scm_is_eq (SCM_PORT (port)->encoding, sym_UTF_32)) { if (!scm_is_eq (encoding, sym_UTF_32LE) && !scm_is_eq (encoding, sym_UTF_32BE)) @@ -1175,12 +1175,12 @@ SCM_DEFINE (scm_specialize_port_encoding_x, scm_t_iconv_descriptors * scm_i_port_iconv_descriptors (SCM port) { - scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); + scm_t_port *pt = SCM_PORT (port); - if (!pti->iconv_descriptors) - prepare_iconv_descriptors (port, SCM_PTAB_ENTRY (port)->encoding); + if (!pt->iconv_descriptors) + prepare_iconv_descriptors (port, pt->encoding); - return pti->iconv_descriptors; + return pt->iconv_descriptors; } /* The name of the encoding is itself encoded in ASCII. */ @@ -1188,24 +1188,22 @@ void scm_i_set_port_encoding_x (SCM port, const char *encoding) { scm_t_port *pt; - scm_t_port_internal *pti; scm_t_iconv_descriptors *prev; /* Set the character encoding for this port. */ - pt = SCM_PTAB_ENTRY (port); - pti = SCM_PORT_GET_INTERNAL (port); - prev = pti->iconv_descriptors; + pt = SCM_PORT (port); + prev = pt->iconv_descriptors; /* In order to handle cases where the encoding changes mid-stream (e.g. within an HTTP stream, or within a file that is composed of segments with different encodings), we consider this to be "stream start" for purposes of BOM handling, regardless of our actual file position. */ - pti->at_stream_start_for_bom_read = 1; - pti->at_stream_start_for_bom_write = 1; + pt->at_stream_start_for_bom_read = 1; + pt->at_stream_start_for_bom_write = 1; pt->encoding = canonicalize_encoding (encoding); - pti->iconv_descriptors = NULL; + pt->iconv_descriptors = NULL; if (prev) close_iconv_descriptors (prev); } @@ -1218,7 +1216,7 @@ SCM_DEFINE (scm_sys_port_encoding, "%port-encoding", 1, 0, 0, { SCM_VALIDATE_PORT (1, port); - return SCM_PTAB_ENTRY (port)->encoding; + return SCM_PORT (port)->encoding; } #undef FUNC_NAME @@ -1283,7 +1281,7 @@ SCM_DEFINE (scm_port_conversion_strategy, "port-conversion-strategy", return scm_i_default_port_conversion_strategy (); SCM_VALIDATE_OPPORT (1, port); - return SCM_PTAB_ENTRY (port)->conversion_strategy; + return SCM_PORT (port)->conversion_strategy; } #undef FUNC_NAME @@ -1317,7 +1315,7 @@ SCM_DEFINE (scm_set_port_conversion_strategy_x, "set-port-conversion-strategy!", else { SCM_VALIDATE_OPPORT (1, port); - SCM_PTAB_ENTRY (port)->conversion_strategy = sym; + SCM_PORT (port)->conversion_strategy = sym; } return SCM_UNSPECIFIED; @@ -1332,7 +1330,7 @@ SCM_DEFINE (scm_set_port_conversion_strategy_x, "set-port-conversion-strategy!", static int get_byte_or_eof (SCM port) { - SCM buf = SCM_PORT_GET_INTERNAL (port)->read_buf; + SCM buf = SCM_PORT (port)->read_buf; SCM buf_bv, buf_cur, buf_end; size_t cur; @@ -1373,7 +1371,7 @@ get_byte_or_eof (SCM port) static int peek_byte_or_eof (SCM port) { - SCM buf = SCM_PORT_GET_INTERNAL (port)->read_buf; + SCM buf = SCM_PORT (port)->read_buf; SCM buf_bv, buf_cur, buf_end; size_t cur; @@ -1450,16 +1448,16 @@ scm_c_read_bytes (SCM port, SCM dst, size_t start, size_t count) #define FUNC_NAME "scm_c_read_bytes" { size_t to_read = count; - scm_t_port_internal *pti; + scm_t_port *pt; SCM read_buf; scm_t_uint8 *dst_ptr = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (dst) + start; SCM_VALIDATE_OPINPORT (1, port); - pti = SCM_PORT_GET_INTERNAL (port); - read_buf = pti->read_buf; + pt = SCM_PORT (port); + read_buf = pt->read_buf; - if (pti->rw_random) + if (pt->rw_random) scm_flush (port); port_clear_stream_start_for_bom_read (port, BOM_IO_BINARY); @@ -1478,7 +1476,7 @@ scm_c_read_bytes (SCM port, SCM dst, size_t start, size_t count) /* If the read is smaller than the buffering on the read side of this port, then go through the buffer. Otherwise fill our buffer directly. */ - if (to_read < pti->read_buffering) + if (to_read < pt->read_buffering) { read_buf = scm_fill_input (port, 0); did_read = scm_port_buffer_take (read_buf, dst_ptr, to_read); @@ -1515,16 +1513,16 @@ scm_c_read (SCM port, void *buffer, size_t size) #define FUNC_NAME "scm_c_read" { size_t copied = 0; - scm_t_port_internal *pti; + scm_t_port *pt; SCM read_buf; scm_t_uint8 *dst = buffer; SCM_VALIDATE_OPINPORT (1, port); - pti = SCM_PORT_GET_INTERNAL (port); - read_buf = pti->read_buf; + pt = SCM_PORT (port); + read_buf = pt->read_buf; - if (pti->rw_random) + if (pt->rw_random) scm_flush (port); while (copied < size) @@ -1689,7 +1687,7 @@ peek_utf8_codepoint (SCM port, size_t *len) DECODING_ERROR (1); decoding_error: - if (scm_is_eq (SCM_PTAB_ENTRY (port)->conversion_strategy, sym_substitute)) + if (scm_is_eq (SCM_PORT (port)->conversion_strategy, sym_substitute)) /* *len already set. */ return '?'; @@ -1747,7 +1745,7 @@ SCM_DEFINE (scm_port_decode_char, "port-decode-char", 4, 0, 0, /* The input byte sequence did not form a complete character. Read another byte and try again. */ return SCM_BOOL_F; - else if (scm_is_eq (SCM_PTAB_ENTRY (port)->conversion_strategy, + else if (scm_is_eq (SCM_PORT (port)->conversion_strategy, sym_substitute)) return SCM_MAKE_CHAR ('?'); else @@ -1798,7 +1796,7 @@ peek_iconv_codepoint (SCM port, size_t *len) } /* EOF found in the middle of a multibyte character. */ - if (scm_is_eq (SCM_PTAB_ENTRY (port)->conversion_strategy, + if (scm_is_eq (SCM_PORT (port)->conversion_strategy, sym_substitute)) return '?'; @@ -1825,7 +1823,7 @@ peek_iconv_codepoint (SCM port, size_t *len) static SCM_C_INLINE scm_t_wchar peek_codepoint (SCM port, size_t *len) { - SCM encoding = SCM_PTAB_ENTRY (port)->encoding; + SCM encoding = SCM_PORT (port)->encoding; if (scm_is_eq (encoding, sym_UTF_8)) return peek_utf8_codepoint (port, len); @@ -1844,7 +1842,7 @@ scm_getc (SCM port) scm_t_wchar codepoint; codepoint = peek_codepoint (port, &len); - scm_port_buffer_did_take (SCM_PORT_GET_INTERNAL (port)->read_buf, len); + scm_port_buffer_did_take (SCM_PORT (port)->read_buf, len); if (codepoint == EOF) scm_i_clear_pending_eof (port); update_port_lf (codepoint, port); @@ -1886,10 +1884,10 @@ void scm_unget_bytes (const scm_t_uint8 *buf, size_t len, SCM port) #define FUNC_NAME "scm_unget_bytes" { - scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); - SCM read_buf = pti->read_buf; + scm_t_port *pt = SCM_PORT (port); + SCM read_buf = pt->read_buf; - if (pti->rw_random) + if (pt->rw_random) scm_flush (port); if (scm_port_buffer_can_putback (read_buf) < len) @@ -1934,7 +1932,7 @@ void scm_ungetc (scm_t_wchar c, SCM port) #define FUNC_NAME "scm_ungetc" { - scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PORT (port); char *result; char result_buf[10]; size_t len; @@ -2108,7 +2106,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, #define FUNC_NAME s_scm_setvbuf { long csize; - scm_t_port_internal *pti; + scm_t_port *pt; scm_t_ptob_descriptor *ptob; scm_t_bits tag_word; size_t read_buf_size, write_buf_size; @@ -2117,7 +2115,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); - pti = SCM_PORT_GET_INTERNAL (port); + pt = SCM_PORT (port); ptob = SCM_PORT_DESCRIPTOR (port); tag_word = SCM_CELL_WORD_0 (port) & ~(SCM_BUF0 | SCM_BUFLINE); @@ -2161,12 +2159,12 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, if (SCM_OUTPUT_PORT_P (port)) scm_flush (port); - saved_read_buf = pti->read_buf; + saved_read_buf = pt->read_buf; SCM_SET_CELL_WORD_0 (port, tag_word); - pti->read_buffering = read_buf_size; - pti->read_buf = scm_c_make_port_buffer (read_buf_size); - pti->write_buf = scm_c_make_port_buffer (write_buf_size); + pt->read_buffering = read_buf_size; + pt->read_buf = scm_c_make_port_buffer (read_buf_size); + pt->write_buf = scm_c_make_port_buffer (write_buf_size); if (saved_read_buf) scm_unget_bytes (scm_port_buffer_take_pointer (saved_read_buf), @@ -2174,7 +2172,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, port); if (saved_read_buf) - scm_port_buffer_set_has_eof_p (pti->read_buf, + scm_port_buffer_set_has_eof_p (pt->read_buf, scm_port_buffer_has_eof_p (saved_read_buf)); return SCM_UNSPECIFIED; @@ -2187,7 +2185,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len) { - SCM read_buf = SCM_PORT_GET_INTERNAL (port)->read_buf; + SCM read_buf = SCM_PORT (port)->read_buf; return scm_port_buffer_take (read_buf, (scm_t_uint8 *) dest, read_len); } @@ -2213,7 +2211,7 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, long count; SCM_VALIDATE_OPINPORT (1, port); - read_buf = SCM_PORT_GET_INTERNAL (port)->read_buf; + read_buf = SCM_PORT (port)->read_buf; count = scm_port_buffer_can_take (read_buf); if (count) @@ -2235,7 +2233,7 @@ scm_end_input (SCM port) SCM buf; size_t discarded; - buf = SCM_PORT_GET_INTERNAL (port)->read_buf; + buf = SCM_PORT (port)->read_buf; discarded = scm_port_buffer_take (buf, NULL, (size_t) -1); if (discarded != 0) @@ -2269,7 +2267,7 @@ static void scm_i_write (SCM port, SCM buf); void scm_flush (SCM port) { - SCM buf = SCM_PORT_GET_INTERNAL (port)->write_buf; + SCM buf = SCM_PORT (port)->write_buf; if (scm_port_buffer_can_take (buf)) scm_i_write (port, buf); } @@ -2303,16 +2301,15 @@ maybe_consume_bom (SCM port, const unsigned char *bom, size_t bom_len) static size_t port_clear_stream_start_for_bom_read (SCM port, enum bom_io_mode io_mode) { - scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); - scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PORT (port); - if (!pti->at_stream_start_for_bom_read) + if (!pt->at_stream_start_for_bom_read) return 0; /* Maybe slurp off a byte-order marker. */ - pti->at_stream_start_for_bom_read = 0; - if (pti->rw_random) - pti->at_stream_start_for_bom_write = 0; + pt->at_stream_start_for_bom_read = 0; + if (pt->rw_random) + pt->at_stream_start_for_bom_write = 0; if (io_mode == BOM_IO_BINARY) return 0; @@ -2365,18 +2362,18 @@ SCM_DEFINE (scm_port_clear_stream_start_for_bom_read, "") #define FUNC_NAME s_scm_port_clear_stream_start_for_bom_read { - scm_t_port_internal *pti; + scm_t_port *pt; SCM_VALIDATE_PORT (1, port); - pti = SCM_PORT_GET_INTERNAL (port); - if (!pti->at_stream_start_for_bom_read) + pt = SCM_PORT (port); + if (!pt->at_stream_start_for_bom_read) return SCM_BOOL_F; /* Maybe slurp off a byte-order marker. */ - pti->at_stream_start_for_bom_read = 0; - if (pti->rw_random) - pti->at_stream_start_for_bom_write = 0; + pt->at_stream_start_for_bom_read = 0; + if (pt->rw_random) + pt->at_stream_start_for_bom_write = 0; return SCM_BOOL_T; } @@ -2385,16 +2382,15 @@ SCM_DEFINE (scm_port_clear_stream_start_for_bom_read, static void port_clear_stream_start_for_bom_write (SCM port, enum bom_io_mode io_mode) { - scm_t_port *pt = SCM_PTAB_ENTRY (port); - scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); + scm_t_port *pt = SCM_PORT (port); - if (!pti->at_stream_start_for_bom_write) + if (!pt->at_stream_start_for_bom_write) return; /* Record that we're no longer at stream start. */ - pti->at_stream_start_for_bom_write = 0; - if (pti->rw_random) - pti->at_stream_start_for_bom_read = 0; + pt->at_stream_start_for_bom_write = 0; + if (pt->rw_random) + pt->at_stream_start_for_bom_read = 0; /* Write a BOM if appropriate. */ if (scm_is_eq (pt->encoding, sym_UTF_16)) @@ -2418,7 +2414,7 @@ port_clear_stream_start_for_bom_write (SCM port, enum bom_io_mode io_mode) SCM scm_fill_input (SCM port, size_t minimum_size) { - scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (port); + scm_t_port *pt = SCM_PORT (port); SCM read_buf; size_t buffered; @@ -2426,14 +2422,14 @@ scm_fill_input (SCM port, size_t minimum_size) minimum_size = 1; port_clear_stream_start_for_bom_read (port, BOM_IO_TEXT); - read_buf = pti->read_buf; + read_buf = pt->read_buf; buffered = scm_port_buffer_can_take (read_buf); if (buffered >= minimum_size || scm_is_true (scm_port_buffer_has_eof_p (read_buf))) return read_buf; - if (pti->rw_random) + if (pt->rw_random) scm_flush (port); /* Prepare to read. Make sure there is enough space in the buffer for @@ -2458,10 +2454,10 @@ scm_fill_input (SCM port, size_t minimum_size) && !scm_is_true (scm_port_buffer_has_eof_p (read_buf))) { size_t count; - size_t buffering = pti->read_buffering; + size_t buffering = pt->read_buffering; size_t to_read; - if (pti->read_buffering < minimum_size) + if (pt->read_buffering < minimum_size) buffering = minimum_size; to_read = buffering - buffered; @@ -2481,7 +2477,7 @@ SCM_DEFINE (scm_port_random_access_p, "port-random-access?", 1, 0, 0, #define FUNC_NAME s_scm_port_random_access_p { SCM_VALIDATE_OPPORT (1, port); - return scm_from_bool (SCM_PORT_GET_INTERNAL (port)->rw_random); + return scm_from_bool (SCM_PORT (port)->rw_random); } #undef FUNC_NAME @@ -2491,7 +2487,7 @@ SCM_DEFINE (scm_port_read_buffering, "port-read-buffering", 1, 0, 0, #define FUNC_NAME s_scm_port_read_buffering { SCM_VALIDATE_OPINPORT (1, port); - return scm_from_size_t (SCM_PORT_GET_INTERNAL (port)->read_buffering); + return scm_from_size_t (SCM_PORT (port)->read_buffering); } #undef FUNC_NAME @@ -2503,35 +2499,35 @@ SCM_DEFINE (scm_expand_port_read_buffer_x, "expand-port-read-buffer!", 2, 1, 0, "to the end instead. Return the new buffer.") #define FUNC_NAME s_scm_expand_port_read_buffer_x { - scm_t_port_internal *pti; + scm_t_port *pt; size_t c_size; SCM new_buf; SCM_VALIDATE_OPINPORT (1, port); - pti = SCM_PORT_GET_INTERNAL (port); + pt = SCM_PORT (port); c_size = scm_to_size_t (size); - SCM_ASSERT_RANGE (2, size, c_size > scm_port_buffer_size (pti->read_buf)); + SCM_ASSERT_RANGE (2, size, c_size > scm_port_buffer_size (pt->read_buf)); if (SCM_UNBNDP (putback_p)) putback_p = SCM_BOOL_F; new_buf = scm_c_make_port_buffer (c_size); scm_port_buffer_set_has_eof_p (new_buf, - scm_port_buffer_has_eof_p (pti->read_buf)); + scm_port_buffer_has_eof_p (pt->read_buf)); if (scm_is_true (putback_p)) { scm_port_buffer_reset_end (new_buf); scm_port_buffer_putback (new_buf, - scm_port_buffer_take_pointer (pti->read_buf), - scm_port_buffer_can_take (pti->read_buf)); + scm_port_buffer_take_pointer (pt->read_buf), + scm_port_buffer_can_take (pt->read_buf)); } else { scm_port_buffer_reset (new_buf); scm_port_buffer_put (new_buf, - scm_port_buffer_take_pointer (pti->read_buf), - scm_port_buffer_can_take (pti->read_buf)); + scm_port_buffer_take_pointer (pt->read_buf), + scm_port_buffer_can_take (pt->read_buf)); } - pti->read_buf = new_buf; + pt->read_buf = new_buf; return new_buf; } @@ -2562,7 +2558,7 @@ SCM_DEFINE (scm_port_read_buffer, "port-read-buffer", 1, 0, 0, #define FUNC_NAME s_scm_port_read_buffer { SCM_VALIDATE_OPPORT (1, port); - return SCM_PORT_GET_INTERNAL (port)->read_buf; + return SCM_PORT (port)->read_buf; } #undef FUNC_NAME @@ -2572,7 +2568,7 @@ SCM_DEFINE (scm_port_write_buffer, "port-write-buffer", 1, 0, 0, #define FUNC_NAME s_scm_port_write_buffer { SCM_VALIDATE_OPPORT (1, port); - return SCM_PORT_GET_INTERNAL (port)->write_buf; + return SCM_PORT (port)->write_buf; } #undef FUNC_NAME @@ -2640,15 +2636,15 @@ void scm_c_write_bytes (SCM port, SCM src, size_t start, size_t count) #define FUNC_NAME "scm_c_write_bytes" { - scm_t_port_internal *pti; + scm_t_port *pt; SCM write_buf; SCM_VALIDATE_OPOUTPORT (1, port); - pti = SCM_PORT_GET_INTERNAL (port); - write_buf = pti->write_buf; + pt = SCM_PORT (port); + write_buf = pt->write_buf; - if (pti->rw_random) + if (pt->rw_random) scm_end_input (port); if (count < scm_port_buffer_size (write_buf)) @@ -2693,17 +2689,17 @@ void scm_c_write (SCM port, const void *ptr, size_t size) #define FUNC_NAME "scm_c_write" { - scm_t_port_internal *pti; + scm_t_port *pt; SCM write_buf; size_t written = 0; const scm_t_uint8 *src = ptr; SCM_VALIDATE_OPOUTPORT (1, port); - pti = SCM_PORT_GET_INTERNAL (port); - write_buf = pti->write_buf; + pt = SCM_PORT (port); + write_buf = pt->write_buf; - if (pti->rw_random) + if (pt->rw_random) scm_end_input (port); while (written < size) @@ -2783,7 +2779,7 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, this case. */ SCM_VALIDATE_OPINPORT (1, port); - read_buf = SCM_PORT_GET_INTERNAL (port)->read_buf; + read_buf = SCM_PORT (port)->read_buf; if (scm_port_buffer_can_take (read_buf) || scm_is_true (scm_port_buffer_has_eof_p (read_buf))) @@ -2838,12 +2834,12 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, if (SCM_OPPORTP (fd_port)) { - scm_t_port_internal *pti = SCM_PORT_GET_INTERNAL (fd_port); + scm_t_port *pt = SCM_PORT (fd_port); scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (fd_port); off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset); off_t_or_off64_t rv; - if (!ptob->seek || !pti->rw_random) + if (!ptob->seek || !pt->rw_random) SCM_MISC_ERROR ("port is not seekable", scm_cons (fd_port, SCM_EOL)); @@ -2856,8 +2852,8 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, rv = ptob->seek (fd_port, off, how); /* Set stream-start flags according to new position. */ - pti->at_stream_start_for_bom_read = (rv == 0); - pti->at_stream_start_for_bom_write = (rv == 0); + pt->at_stream_start_for_bom_read = (rv == 0); + pt->at_stream_start_for_bom_write = (rv == 0); scm_i_clear_pending_eof (fd_port); @@ -2955,7 +2951,7 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, scm_i_clear_pending_eof (object); if (SCM_INPUT_PORT_P (object) - && SCM_PORT_GET_INTERNAL (object)->rw_random) + && SCM_PORT (object)->rw_random) scm_end_input (object); scm_flush (object); @@ -3002,7 +2998,7 @@ SCM_DEFINE (scm_set_port_line_x, "set-port-line!", 2, 0, 0, { port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); - SCM_PORT_GET_INTERNAL (port)->line_number = scm_to_long (line); + SCM_PORT (port)->line_number = scm_to_long (line); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -3033,7 +3029,7 @@ SCM_DEFINE (scm_set_port_column_x, "set-port-column!", 2, 0, 0, { port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); - SCM_PORT_GET_INTERNAL (port)->column_number = scm_to_int (column); + SCM_PORT (port)->column_number = scm_to_int (column); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -3096,7 +3092,7 @@ scm_port_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) scm_print_port_mode (exp, port); scm_puts (type, port); scm_putc (' ', port); - scm_uintprint ((scm_t_bits) SCM_PTAB_ENTRY (exp), 16, port); + scm_uintprint ((scm_t_bits) SCM_PORT (exp), 16, port); scm_putc ('>', port); return 1; } diff --git a/libguile/print.c b/libguile/print.c index 8dcd375f9..b0e6691ff 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1126,7 +1126,7 @@ display_string (const void *str, int narrow_p, { scm_t_port *pt; - pt = SCM_PTAB_ENTRY (port); + pt = SCM_PORT (port); if (scm_is_eq (pt->encoding, sym_UTF_8)) return display_string_as_utf8 (str, narrow_p, len, port); diff --git a/libguile/read.c b/libguile/read.c index ede8a613c..3d2a7fde9 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -1059,7 +1059,7 @@ scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) return (SCM_MAKE_CHAR (chr)); } - pt = SCM_PTAB_ENTRY (port); + pt = SCM_PORT (port); /* Simple ASCII characters can be processed immediately. Also, simple ISO-8859-1 characters can be processed immediately if the encoding for this @@ -2057,7 +2057,7 @@ is_encoding_char (char c) char * scm_i_scan_for_encoding (SCM port) { - scm_t_port_internal *pti; + scm_t_port *pt; SCM buf; char header[SCM_ENCODING_SEARCH_SIZE+1]; size_t bytes_read, encoding_length, i; @@ -2065,10 +2065,10 @@ scm_i_scan_for_encoding (SCM port) char *pos, *encoding_start; int in_comment; - pti = SCM_PORT_GET_INTERNAL (port); - buf = pti->read_buf; + pt = SCM_PORT (port); + buf = pt->read_buf; - if (pti->rw_random) + if (pt->rw_random) scm_flush (port); if (scm_port_buffer_can_take (buf) == 0) diff --git a/libguile/rw.c b/libguile/rw.c index 0b89bc2e7..91941a4fb 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -236,7 +236,7 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0, SCM_VALIDATE_OPFPORT (2, port); SCM_VALIDATE_OUTPUT_PORT (2, port); - write_buf = SCM_PORT_GET_INTERNAL (port)->write_buf; + write_buf = SCM_PORT (port)->write_buf; /* Filling the last character in the buffer would require a flush. */ diff --git a/libguile/strings.c b/libguile/strings.c index 00082295b..2e5647e6d 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -1767,7 +1767,7 @@ scm_from_port_string (const char *str, SCM port) SCM scm_from_port_stringn (const char *str, size_t len, SCM port) { - scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PORT (port); if (scm_is_eq (pt->encoding, sym_ISO_8859_1)) return scm_from_latin1_stringn (str, len); @@ -2175,7 +2175,7 @@ scm_to_port_string (SCM str, SCM port) char * scm_to_port_stringn (SCM str, size_t *lenp, SCM port) { - scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_port *pt = SCM_PORT (port); if (scm_is_eq (pt->encoding, sym_ISO_8859_1) && scm_is_eq (pt->conversion_strategy, sym_error)) From af1c443f83b492d97cba80648d9f3d7299440978 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 13 May 2016 16:48:02 +0200 Subject: [PATCH 277/865] Update port documentation * doc/ref/api-io.texi: Update for refactorings. --- doc/ref/api-io.texi | 120 +++++++++++++++----------------------------- 1 file changed, 41 insertions(+), 79 deletions(-) diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 1a9c8212d..41efb3547 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -230,9 +230,9 @@ Return the next character available from @var{port}, updating @var{port} to point to the following character. If no more characters are available, the end-of-file object is returned. -When @var{port}'s data cannot be decoded according to its -character encoding, a @code{decoding-error} is raised and -@var{port} points past the erroneous byte sequence. +When @var{port}'s data cannot be decoded according to its character +encoding, a @code{decoding-error} is raised and @var{port} is not +advanced past the erroneous byte sequence. @end deffn @deftypefn {C Function} size_t scm_c_read (SCM port, void *buffer, size_t size) @@ -263,9 +263,7 @@ an interactive port will hang waiting for input whenever a call to @code{read-char} would have hung. As for @code{read-char}, a @code{decoding-error} may be raised -if such a situation occurs. However, unlike with @code{read-char}, -@var{port} still points at the beginning of the erroneous byte -sequence when the error is raised. +if such a situation occurs. @end deffn @deffn {Scheme Procedure} unread-char cobj [port] @@ -355,17 +353,13 @@ a print state, the old print state is reused. @deffn {Scheme Procedure} simple-format destination message . args @deffnx {C Function} scm_simple_format (destination, message, args) -Write @var{message} to @var{destination}, defaulting to -the current output port. -@var{message} can contain @code{~A} (was @code{%s}) and -@code{~S} (was @code{%S}) escapes. When printed, -the escapes are replaced with corresponding members of -@var{args}: -@code{~A} formats using @code{display} and @code{~S} formats -using @code{write}. -If @var{destination} is @code{#t}, then use the current output -port, if @var{destination} is @code{#f}, then return a string -containing the formatted text. Does not add a trailing newline. +Write @var{message} to @var{destination}, defaulting to the current +output port. @var{message} can contain @code{~A} and @code{~S} escapes. +When printed, the escapes are replaced with corresponding members of +@var{args}: @code{~A} formats using @code{display} and @code{~S} formats +using @code{write}. If @var{destination} is @code{#t}, then use the +current output port, if @var{destination} is @code{#f}, then return a +string containing the formatted text. Does not add a trailing newline. @end deffn @rnindex write-char @@ -415,10 +409,10 @@ all open output ports. The return value is unspecified. @deffn {Scheme Procedure} close-port port @deffnx {C Function} scm_close_port (port) -Close the specified port object. Return @code{#t} if it -successfully closes a port or @code{#f} if it was already -closed. An exception may be raised if an error occurs, for -example when flushing buffered output. See also @ref{Ports and +Close the specified port object. Return @code{#t} if it successfully +closes a port or @code{#f} if it was already closed. An exception may +be raised if an error occurs, for example when flushing buffered output. +@xref{Buffering}, for more on buffered output. See also @ref{Ports and File Descriptors, close}, for a procedure which can close file descriptors. @end deffn @@ -499,7 +493,7 @@ as a block, without regard to what is in the block. Likewise reads are read in at the block size, though if there are fewer bytes available to read, the buffer may not be entirely filled. -Note that reads or writes that are larger than the buffer size go +Note that binary reads or writes that are larger than the buffer size go directly to the mutable store without passing through the buffers. If your access pattern involves many big reads or writes, buffering might not matter so much to you. @@ -923,8 +917,6 @@ initialized with the @var{port} argument. @cindex Types of ports @cindex Port, types -[Types of port; how to make them.] - @menu * File Ports:: Ports on an operating system file. * String Ports:: Ports on a Scheme string. @@ -1017,25 +1009,6 @@ is requested. If a file cannot be opened with the access requested, @code{open-file} throws an exception. - -When the file is opened, its encoding is set to the current -@code{%default-port-encoding}, unless the @code{b} flag was supplied. -Sometimes it is desirable to honor Emacs-style coding declarations in -files@footnote{Guile 2.0.0 to 2.0.7 would do this by default. This -behavior was deemed inappropriate and disabled starting from Guile -2.0.8.}. When that is the case, the @code{file-encoding} procedure can -be used as follows (@pxref{Character Encoding of Source Files, -@code{file-encoding}}): - -@example -(let* ((port (open-input-file file)) - (encoding (file-encoding port))) - (set-port-encoding! port (or encoding (port-encoding port)))) -@end example - -In theory we could create read/write ports which were buffered -in one direction only. However this isn't included in the -current interfaces. @end deffn @rnindex open-input-file @@ -2256,47 +2229,36 @@ the representation, will return an object equal (in the sense of @node I/O Extensions @subsection Implementing New Port Types in C -This section describes how to implement a new port type in C. Before -getting to the details, here is a summary of how the generic port -interface works internally. +This section describes how to implement a new port type in C. Although +ports support many operations, as a data structure they present an +opaque interface to the user. To the port implementor, you have two +additional pieces of information: the port type code, which you allocate +when defining your port type; and a port's ``stream'', which you +allocate when you create a port. -@cindex ptob -@tindex scm_t_ptob_descriptor -@tindex scm_t_port -@findex SCM_PTAB_ENTRY -@findex SCM_PTOBNUM -@vindex scm_ptobs -Guile's port facility consists of two main data types: port type objects -and port instances. A port type object (or @dfn{ptob}) is of type -@code{scm_t_ptob_descriptor}, and holds pointers to the methods that -implement the port type. A port instance is of type @code{scm_t_port}, -and holds all state for the port. +The type code helps you identify which ports are actually yours. The +``stream'' is the private data associated with that port which you and +only you control. Get a stream from a port using the @code{SCM_STREAM} +macro. -Given an @code{SCM} variable which points to a port, the corresponding C -port object can be obtained using the @code{SCM_PTAB_ENTRY} macro. The -ptob can be obtained by using @code{SCM_PTOBNUM} to give an index into -the @code{scm_ptobs} global array. - -@subsubheading C interface - -A port type object is created by calling @code{scm_make_port_type}. +A port type is created by calling @code{scm_make_port_type}. @deftypefun scm_t_bits scm_make_port_type (char *name, size_t (*read) (SCM port, SCM dst, size_t start, size_t count), size_t (*write) (SCM port, SCM src, size_t start, size_t count)) -Return a new port type object. The @var{name}, @var{read} and -@var{write} parameters are initial values for those port type fields, as -described below. The other fields are initialized with default values -and can be changed later. +Define a new port type. The @var{name}, @var{read} and @var{write} +parameters are initial values for those port type fields, as described +below. The other fields are initialized with default values and can be +changed later. @end deftypefun -All of the elements of the port type object, apart from @code{name}, are -procedures which collectively implement the port behaviour. Creating a -new port type mostly involves writing these procedures. +The port type has a number of associate procedures and properties which +collectively implement the port's behavior. Creating a new port type +mostly involves writing these procedures. @table @code @item name A pointer to a NUL terminated string: the name of the port type. This -is the only element of @code{scm_t_ptob_descriptor} which is not -a procedure. Set via the first argument to @code{scm_make_port_type}. +property is initialized via the first argument to +@code{scm_make_port_type}. @item read A port's @code{read} implementation fills read buffers. It should copy @@ -2312,12 +2274,12 @@ starting at offset @code{start} and continuing for @code{count} bytes, and return the number of bytes that were written. @item print -Called when @code{write} is called on the port object, to print a -port description. E.g., for an fport it may produce something like: -@code{#}. Set using +Called when @code{write} is called on the port, to print a port +description. For example, for a file port it may produce something +like: @code{#}. Set using @deftypefun void scm_set_port_print (scm_t_bits tc, int (*print) (SCM port, SCM dest_port, scm_print_state *pstate)) -The first argument @var{port} is the object being printed, the second +The first argument @var{port} is the port being printed, the second argument @var{dest_port} is where its description should go. @end deftypefun @@ -2455,7 +2417,7 @@ BOM. Similarly, if the user writes first, then later reads will @emph{not} consume a BOM. @item -For ports that do not support seeking (e.g. pipes, sockets, and +For ports that are not random access (e.g. pipes, sockets, and terminals), the input and output streams are considered @emph{independent} for purposes of BOM handling: the first read will consume a BOM (if appropriate), and the first write will @emph{also} From 17f90360b6057034135ec93ffae340fa514208af Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 13 May 2016 17:14:59 +0200 Subject: [PATCH 278/865] Make scm_t_ptob_descriptor private. * libguile/goops.c: Use port internals header. * libguile/ports-internal.h (scm_t_port_type_flags) (struct scm_t_ptob_descriptor): Make private. * libguile/ports.h: Adapt. --- libguile/goops.c | 1 + libguile/ports-internal.h | 31 +++++++++++++++++++++++++++++++ libguile/ports.h | 31 +------------------------------ 3 files changed, 33 insertions(+), 30 deletions(-) diff --git a/libguile/goops.c b/libguile/goops.c index 1f7ec90c8..cb9b6a612 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -40,6 +40,7 @@ #include "libguile/macros.h" #include "libguile/modules.h" #include "libguile/ports.h" +#include "libguile/ports-internal.h" #include "libguile/procprop.h" #include "libguile/programs.h" #include "libguile/smob.h" diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index e56d40ba1..394eaf8f5 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -27,6 +27,37 @@ #include "libguile/_scm.h" #include "libguile/ports.h" +typedef enum scm_t_port_type_flags { + /* Indicates that the port should be closed if it is garbage collected + while it is open. */ + SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC = 1 << 0 +} scm_t_port_type_flags; + +/* port-type description. */ +struct scm_t_ptob_descriptor +{ + char *name; + int (*print) (SCM exp, SCM port, scm_print_state *pstate); + + size_t (*c_read) (SCM port, SCM dst, size_t start, size_t count); + size_t (*c_write) (SCM port, SCM src, size_t start, size_t count); + SCM scm_read; + SCM scm_write; + + scm_t_off (*seek) (SCM port, scm_t_off OFFSET, int WHENCE); + void (*close) (SCM port); + + void (*get_natural_buffer_sizes) (SCM port, size_t *read_size, + size_t *write_size); + int (*random_access_p) (SCM port); + + int (*input_waiting) (SCM port); + + void (*truncate) (SCM port, scm_t_off length); + + unsigned flags; +}; + /* Port buffers. It's important to avoid calling into the kernel too many times. For diff --git a/libguile/ports.h b/libguile/ports.h index f90a6b6c5..18de70f65 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -78,36 +78,7 @@ SCM_INTERNAL SCM scm_i_port_weak_set; -typedef enum scm_t_port_type_flags { - /* Indicates that the port should be closed if it is garbage collected - while it is open. */ - SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC = 1 << 0 -} scm_t_port_type_flags; - -/* port-type description. */ -typedef struct scm_t_ptob_descriptor -{ - char *name; - int (*print) (SCM exp, SCM port, scm_print_state *pstate); - - size_t (*c_read) (SCM port, SCM dst, size_t start, size_t count); - size_t (*c_write) (SCM port, SCM src, size_t start, size_t count); - SCM scm_read; - SCM scm_write; - - scm_t_off (*seek) (SCM port, scm_t_off OFFSET, int WHENCE); - void (*close) (SCM port); - - void (*get_natural_buffer_sizes) (SCM port, size_t *read_size, - size_t *write_size); - int (*random_access_p) (SCM port); - - int (*input_waiting) (SCM port); - - void (*truncate) (SCM port, scm_t_off length); - - unsigned flags; -} scm_t_ptob_descriptor; +typedef struct scm_t_ptob_descriptor scm_t_ptob_descriptor; #define SCM_TC2PTOBNUM(x) (0x0ff & ((x) >> 8)) #define SCM_PTOBNUM(x) (SCM_TC2PTOBNUM (SCM_CELL_TYPE (x))) From cd51ce81d047a10c55c450ea7b2bf5ab8b8340be Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 13 May 2016 18:23:47 +0200 Subject: [PATCH 279/865] Use heap-allocated port types instead of ptobnums This removes a limitation on the number of port types, simplifies the API, and removes a central point of coordination. * libguile/ports-internal.h (struct scm_t_port_type): Rename from scm_t_ptob_descriptor, now that it's private. Add GOOPS class fields. (struct scm_t_port): Rename from struct scm_port, especially considering that deprecated.h redefines scm_port using the preprocessor :(. * libguile/ports.h: Add definitions of SCM_PORT and SCM_PORT_TYPE, though the scm_t_port and scm_t_port_type types are incomplete. (SCM_TC2PTOBNUM, SCM_PTOBNUM, SCM_PTOBNAME): Remove, as there are no more typecodes for port types. (scm_c_num_port_types, scm_c_port_type_ref, scm_c_port_type_add_x): Remove. (scm_make_port_type): Return a scm_t_port_type*. All methods adapted to take a scm_t_port_type* instead of a ptobnum. (scm_c_make_port_with_encoding, scm_c_make_port): Take a port type pointer instead of a tag. (scm_new_port_table_entry): Remove; not useful. * libguile/ports.c: Remove things related to the port kind table. Adapt uses of SCM_PORT_DESCRIPTOR / scm_t_ptob_descriptor to use SCM_PORT_TYPE and scm_t_port_type. * libguile/deprecated.c: * libguile/deprecated.h: * libguile/filesys.c: * libguile/fports.c: * libguile/fports.h: * libguile/print.c: * libguile/r6rs-ports.c: * libguile/strports.c: * libguile/strports.h: * libguile/tags.h: * libguile/vports.c: * test-suite/standalone/test-scm-c-read.c: Adapt to change. * libguile/goops.c (scm_class_of, make_port_classes) (scm_make_port_classes, create_port_classes): Adapt to store the classes in the ptob. --- libguile/deprecated.c | 1 - libguile/deprecated.h | 3 +- libguile/filesys.c | 1 + libguile/fports.c | 32 ++-- libguile/fports.h | 5 +- libguile/goops.c | 84 ++++++---- libguile/goops.h | 3 +- libguile/ports-internal.h | 12 +- libguile/ports.c | 210 +++++++----------------- libguile/ports.h | 46 +++--- libguile/print.c | 4 +- libguile/r6rs-ports.c | 10 +- libguile/strports.c | 18 +- libguile/strports.h | 5 +- libguile/tags.h | 2 - libguile/vports.c | 22 +-- test-suite/standalone/test-scm-c-read.c | 4 +- 17 files changed, 190 insertions(+), 272 deletions(-) diff --git a/libguile/deprecated.c b/libguile/deprecated.c index b8c3c8ce1..af7643487 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -202,7 +202,6 @@ scm_init_deprecated_goops (void) scm_class_output_port = scm_variable_ref (scm_c_lookup ("")); scm_class_input_output_port = scm_variable_ref (scm_c_lookup ("")); - scm_port_class = scm_i_port_class; scm_smob_class = scm_i_smob_class; } diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 1f13bde83..04c540e22 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -116,7 +116,7 @@ SCM_DEPRECATED SCM scm_internal_dynamic_wind (scm_t_guard before, #define scm_option scm_option__GONE__REPLACE_WITH__scm_t_option #define scm_port scm_port__GONE__REPLACE_WITH__scm_t_port #define scm_port_rw_active scm_port_rw_active__GONE__REPLACE_WITH__scm_t_port_rw_active -#define scm_ptob_descriptor scm_ptob_descriptor__GONE__REPLACE_WITH__scm_t_ptob_descriptor +#define scm_ptob_descriptor scm_ptob_descriptor__GONE__REPLACE_WITH__scm_t_port_type #define scm_rng scm_rng__GONE__REPLACE_WITH__scm_t_rng #define scm_rstate scm_rstate__GONE__REPLACE_WITH__scm_t_rstate #define scm_sizet scm_sizet__GONE__REPLACE_WITH__size_t @@ -203,7 +203,6 @@ SCM_DEPRECATED SCM scm_class_int; SCM_DEPRECATED SCM scm_class_float; SCM_DEPRECATED SCM scm_class_double; -SCM_DEPRECATED SCM *scm_port_class; SCM_DEPRECATED SCM *scm_smob_class; SCM_INTERNAL void scm_init_deprecated_goops (void); diff --git a/libguile/filesys.c b/libguile/filesys.c index 273de9790..43d1be636 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -47,6 +47,7 @@ #include "libguile/strings.h" #include "libguile/vectors.h" #include "libguile/dynwind.h" +#include "libguile/ports.h" #include "libguile/ports-internal.h" #include "libguile/validate.h" diff --git a/libguile/fports.c b/libguile/fports.c index dd1c1ac79..046a844e9 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -72,7 +72,7 @@ #error Oops, unknown OFF_T size #endif -scm_t_bits scm_tc16_fport; +scm_t_port_type *scm_file_port_type; /* Move ports with the specified file descriptor to new descriptors, @@ -409,7 +409,7 @@ scm_i_fdes_to_port (int fdes, long mode_bits, SCM name) "file port"); fp->fdes = fdes; - port = scm_c_make_port (scm_tc16_fport, mode_bits, (scm_t_bits)fp); + port = scm_c_make_port (scm_file_port_type, mode_bits, (scm_t_bits)fp); SCM_SET_FILENAME (port, name); @@ -547,7 +547,7 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) if (scm_is_string (name) || scm_is_symbol (name)) scm_display (name, port); else - scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port); + scm_puts (SCM_PORT_TYPE (exp)->name, port); scm_putc (' ', port); fdes = (SCM_FSTREAM (exp))->fdes; @@ -560,7 +560,7 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) } else { - scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port); + scm_puts (SCM_PORT_TYPE (exp)->name, port); scm_putc (' ', port); scm_uintprint ((scm_t_bits) SCM_PORT (exp), 16, port); } @@ -650,21 +650,21 @@ fport_get_natural_buffer_sizes (SCM port, size_t *read_size, size_t *write_size) #endif } -static scm_t_bits +static scm_t_port_type * scm_make_fptob () { - scm_t_bits tc = scm_make_port_type ("file", fport_read, fport_write); + scm_t_port_type *ptob = scm_make_port_type ("file", fport_read, fport_write); - scm_set_port_print (tc, fport_print); - scm_set_port_needs_close_on_gc (tc, 1); - scm_set_port_close (tc, fport_close); - scm_set_port_seek (tc, fport_seek); - scm_set_port_truncate (tc, fport_truncate); - scm_set_port_input_waiting (tc, fport_input_waiting); - scm_set_port_random_access_p (tc, fport_random_access_p); - scm_set_port_get_natural_buffer_sizes (tc, fport_get_natural_buffer_sizes); + scm_set_port_print (ptob, fport_print); + scm_set_port_needs_close_on_gc (ptob, 1); + scm_set_port_close (ptob, fport_close); + scm_set_port_seek (ptob, fport_seek); + scm_set_port_truncate (ptob, fport_truncate); + scm_set_port_input_waiting (ptob, fport_input_waiting); + scm_set_port_random_access_p (ptob, fport_random_access_p); + scm_set_port_get_natural_buffer_sizes (ptob, fport_get_natural_buffer_sizes); - return tc; + return ptob; } /* We can't initialize the keywords from 'scm_init_fports', because @@ -685,7 +685,7 @@ scm_init_ice_9_fports (void) void scm_init_fports () { - scm_tc16_fport = scm_make_fptob (); + scm_file_port_type = scm_make_fptob (); scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, "scm_init_ice_9_fports", diff --git a/libguile/fports.h b/libguile/fports.h index 4ea698a5a..6b15bd971 100644 --- a/libguile/fports.h +++ b/libguile/fports.h @@ -37,12 +37,13 @@ typedef struct scm_t_fport { */ } scm_t_fport; -SCM_API scm_t_bits scm_tc16_fport; +SCM_API scm_t_port_type *scm_file_port_type; #define SCM_FSTREAM(x) ((scm_t_fport *) SCM_STREAM (x)) #define SCM_FPORT_FDES(x) (SCM_FSTREAM (x)->fdes) -#define SCM_FPORTP(x) (SCM_HAS_TYP16 (x, scm_tc16_fport)) +#define SCM_FPORTP(x) \ + (SCM_PORTP (x) && SCM_PORT_TYPE (x) == scm_file_port_type) #define SCM_OPFPORTP(x) (SCM_FPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_OPN)) #define SCM_OPINFPORTP(x) (SCM_OPFPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_RDNG)) #define SCM_OPOUTFPORTP(x) (SCM_OPFPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_WRTNG)) diff --git a/libguile/goops.c b/libguile/goops.c index cb9b6a612..88a065fd2 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -51,11 +51,6 @@ #include "libguile/validate.h" #include "libguile/goops.h" -/* Port classes */ -#define SCM_IN_PCLASS_INDEX 0 -#define SCM_OUT_PCLASS_INDEX SCM_I_MAX_PORT_TYPE_COUNT -#define SCM_INOUT_PCLASS_INDEX (2 * SCM_I_MAX_PORT_TYPE_COUNT) - /* Objects have identity, so references to classes and instances are by value, not by reference. Redefinition of a class or modification of an instance causes in-place update; you can think of GOOPS as @@ -138,11 +133,6 @@ static SCM class_bitvector; static SCM vtable_class_map = SCM_BOOL_F; -/* Port classes. Allocate 3 times the maximum number of port types so that - input ports, output ports, and in/out ports can be stored at different - offsets. See `SCM_IN_PCLASS_INDEX' et al. */ -SCM scm_i_port_class[3 * SCM_I_MAX_PORT_TYPE_COUNT]; - /* SMOB classes. */ SCM scm_i_smob_class[SCM_I_MAX_SMOB_TYPE_COUNT]; @@ -277,11 +267,16 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, /* fall through to ports */ } case scm_tc7_port: - return scm_i_port_class[(SCM_WRTNG & SCM_CELL_WORD_0 (x) - ? (SCM_RDNG & SCM_CELL_WORD_0 (x) - ? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x) - : SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x)) - : SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))]; + { + scm_t_port_type *ptob = SCM_PORT_TYPE (x); + if (SCM_INPUT_PORT_P (x)) + { + if (SCM_OUTPUT_PORT_P (x)) + return ptob->input_output_class; + return ptob->input_class; + } + return ptob->output_class; + } case scm_tcs_struct: if (SCM_OBJ_CLASS_FLAGS (x) & SCM_CLASSF_GOOPS_VALID) /* A GOOPS object with a valid class. */ @@ -759,40 +754,67 @@ create_smob_classes (void) scm_smobs[i].apply != 0); } -void -scm_make_port_classes (long ptobnum, char *type_name) +struct pre_goops_port_type +{ + scm_t_port_type *ptob; + struct pre_goops_port_type *prev; +}; +struct pre_goops_port_type *pre_goops_port_types; + +static void +make_port_classes (scm_t_port_type *ptob) { SCM name, meta, super, supers; meta = class_class; - name = make_class_name ("<", type_name, "-port>"); + name = make_class_name ("<", ptob->name, "-port>"); supers = scm_list_1 (class_port); super = scm_make_standard_class (meta, name, supers, SCM_EOL); - name = make_class_name ("<", type_name, "-input-port>"); + name = make_class_name ("<", ptob->name, "-input-port>"); supers = scm_list_2 (super, class_input_port); - scm_i_port_class[SCM_IN_PCLASS_INDEX + ptobnum] - = scm_make_standard_class (meta, name, supers, SCM_EOL); + ptob->input_class = scm_make_standard_class (meta, name, supers, SCM_EOL); - name = make_class_name ("<", type_name, "-output-port>"); + name = make_class_name ("<", ptob->name, "-output-port>"); supers = scm_list_2 (super, class_output_port); - scm_i_port_class[SCM_OUT_PCLASS_INDEX + ptobnum] - = scm_make_standard_class (meta, name, supers, SCM_EOL); + ptob->output_class = scm_make_standard_class (meta, name, supers, SCM_EOL); - name = make_class_name ("<", type_name, "-input-output-port>"); + name = make_class_name ("<", ptob->name, "-input-output-port>"); supers = scm_list_2 (super, class_input_output_port); - scm_i_port_class[SCM_INOUT_PCLASS_INDEX + ptobnum] - = scm_make_standard_class (meta, name, supers, SCM_EOL); + ptob->input_output_class = + scm_make_standard_class (meta, name, supers, SCM_EOL); +} + +void +scm_make_port_classes (scm_t_port_type *ptob) +{ + ptob->input_class = SCM_BOOL_F; + ptob->output_class = SCM_BOOL_F; + ptob->input_output_class = SCM_BOOL_F; + + if (!goops_loaded_p) + { + /* Not really a pair. */ + struct pre_goops_port_type *link; + link = scm_gc_typed_calloc (struct pre_goops_port_type); + link->ptob = ptob; + link->prev = pre_goops_port_types; + pre_goops_port_types = link; + return; + } + + make_port_classes (ptob); } static void create_port_classes (void) { - long i; - - for (i = scm_c_num_port_types () - 1; i >= 0; i--) - scm_make_port_classes (i, SCM_PTOBNAME (i)); + while (pre_goops_port_types) + { + make_port_classes (pre_goops_port_types->ptob); + pre_goops_port_types = pre_goops_port_types->prev; + } } SCM diff --git a/libguile/goops.h b/libguile/goops.h index cc743a685..790c0b448 100644 --- a/libguile/goops.h +++ b/libguile/goops.h @@ -82,7 +82,6 @@ #define SCM_SET_CLASS_DESTRUCTOR(c, d) SCM_SET_VTABLE_DESTRUCTOR (c, d) -SCM_INTERNAL SCM scm_i_port_class[]; SCM_INTERNAL SCM scm_i_smob_class[]; SCM_API SCM scm_module_goops; @@ -90,7 +89,7 @@ SCM_API SCM scm_module_goops; SCM_API SCM scm_goops_version (void); SCM_API void scm_load_goops (void); SCM_API SCM scm_make_extended_class (char const *type_name, int applicablep); -SCM_API void scm_make_port_classes (long ptobnum, char *type_name); +SCM_INTERNAL void scm_make_port_classes (scm_t_port_type *ptob); SCM_API SCM scm_ensure_accessor (SCM name); SCM_API SCM scm_class_of (SCM obj); diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index 394eaf8f5..161213b6f 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -34,7 +34,7 @@ typedef enum scm_t_port_type_flags { } scm_t_port_type_flags; /* port-type description. */ -struct scm_t_ptob_descriptor +struct scm_t_port_type { char *name; int (*print) (SCM exp, SCM port, scm_print_state *pstate); @@ -56,6 +56,9 @@ struct scm_t_ptob_descriptor void (*truncate) (SCM port, scm_t_off length); unsigned flags; + + /* GOOPS tomfoolery. */ + SCM input_class, output_class, input_output_class; }; /* Port buffers. @@ -280,7 +283,7 @@ struct scm_iconv_descriptors typedef struct scm_iconv_descriptors scm_t_iconv_descriptors; -struct scm_port +struct scm_t_port { /* Source location information. */ SCM file_name; @@ -315,11 +318,6 @@ struct scm_port SCM alist; }; -typedef struct scm_port scm_t_port; - -#define SCM_PORT(x) ((scm_t_port *) SCM_CELL_WORD_2 (x)) -#define SCM_PORT_DESCRIPTOR(port) ((scm_t_ptob_descriptor *) SCM_CELL_WORD_3 (port)) - #define SCM_UNICODE_BOM 0xFEFFUL /* Unicode byte-order mark */ #define SCM_FILENAME(x) (SCM_PORT (x)->file_name) diff --git a/libguile/ports.c b/libguile/ports.c index 9db949e4a..464f8f2a9 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -110,88 +110,6 @@ static SCM sym_escape; -/* The port kind table --- a dynamically resized array of port types. */ - - -/* scm_ptobs scm_numptob - * implement a dynamically resized array of ptob records. - * Indexes into this table are used when generating type - * tags for smobjects (if you know a tag you can get an index and conversely). - */ -static scm_t_ptob_descriptor **scm_ptobs = NULL; -static long scm_numptob = 0; /* Number of port types. */ -static long scm_ptobs_size = 0; /* Number of slots in the port type - table. */ -static scm_i_pthread_mutex_t scm_ptobs_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; - -long -scm_c_num_port_types (void) -{ - long ret; - - scm_i_pthread_mutex_lock (&scm_ptobs_lock); - ret = scm_numptob; - scm_i_pthread_mutex_unlock (&scm_ptobs_lock); - - return ret; -} - -scm_t_ptob_descriptor* -scm_c_port_type_ref (long ptobnum) -{ - scm_t_ptob_descriptor *ret = NULL; - - scm_i_pthread_mutex_lock (&scm_ptobs_lock); - - if (0 <= ptobnum && ptobnum < scm_numptob) - ret = scm_ptobs[ptobnum]; - - scm_i_pthread_mutex_unlock (&scm_ptobs_lock); - - if (!ret) - scm_out_of_range ("scm_c_port_type_ref", scm_from_long (ptobnum)); - - return ret; -} - -long -scm_c_port_type_add_x (scm_t_ptob_descriptor *desc) -{ - long ret = -1; - - scm_i_pthread_mutex_lock (&scm_ptobs_lock); - - if (scm_numptob + 1 < SCM_I_MAX_PORT_TYPE_COUNT) - { - if (scm_numptob == scm_ptobs_size) - { - unsigned long old_size = scm_ptobs_size; - scm_t_ptob_descriptor **old_ptobs = scm_ptobs; - - /* Currently there are only 9 predefined port types, so one - resize will cover it. */ - scm_ptobs_size = old_size + 10; - - if (scm_ptobs_size >= SCM_I_MAX_PORT_TYPE_COUNT) - scm_ptobs_size = SCM_I_MAX_PORT_TYPE_COUNT; - - scm_ptobs = scm_gc_malloc (sizeof (*scm_ptobs) * scm_ptobs_size, - "scm_ptobs"); - - memcpy (scm_ptobs, old_ptobs, sizeof (*scm_ptobs) * scm_numptob); - } - - ret = scm_numptob++; - scm_ptobs[ret] = desc; - } - - scm_i_pthread_mutex_unlock (&scm_ptobs_lock); - - if (ret < 0) - scm_out_of_range ("scm_c_port_type_add_x", scm_from_long (scm_numptob)); - - return ret; -} static SCM trampoline_to_c_read_subr; static SCM trampoline_to_c_write_subr; @@ -199,18 +117,17 @@ static SCM trampoline_to_c_write_subr; static int default_random_access_p (SCM port) { - return SCM_PORT_DESCRIPTOR (port)->seek != NULL; + return SCM_PORT_TYPE (port)->seek != NULL; } -scm_t_bits +scm_t_port_type * scm_make_port_type (char *name, size_t (*read) (SCM port, SCM dst, size_t start, size_t count), size_t (*write) (SCM port, SCM src, size_t start, size_t count)) { - scm_t_ptob_descriptor *desc; - long ptobnum; + scm_t_port_type *desc; desc = scm_gc_malloc_pointerless (sizeof (*desc), "port-type"); memset (desc, 0, sizeof (*desc)); @@ -222,14 +139,9 @@ scm_make_port_type (char *name, desc->scm_read = read ? trampoline_to_c_read_subr : SCM_BOOL_F; desc->scm_write = write ? trampoline_to_c_write_subr : SCM_BOOL_F; desc->random_access_p = default_random_access_p; + scm_make_port_classes (desc); - ptobnum = scm_c_port_type_add_x (desc); - - /* Make a class object if GOOPS is present. */ - if (SCM_UNPACK (scm_i_port_class[0]) != 0) - scm_make_port_classes (ptobnum, name); - - return scm_tc7_port + ptobnum * 256; + return desc; } static SCM @@ -245,7 +157,7 @@ trampoline_to_c_read (SCM port, SCM dst, SCM start, SCM count) SCM_ASSERT_RANGE (3, count, c_start+c_count <= scm_c_bytevector_length (dst)); return scm_from_size_t - (SCM_PORT_DESCRIPTOR (port)->c_read (port, dst, c_start, c_count)); + (SCM_PORT_TYPE (port)->c_read (port, dst, c_start, c_count)); } #undef FUNC_NAME @@ -253,7 +165,7 @@ static size_t trampoline_to_scm_read (SCM port, SCM dst, size_t start, size_t count) { return scm_to_size_t - (scm_call_4 (SCM_PORT_DESCRIPTOR (port)->scm_read, port, dst, + (scm_call_4 (SCM_PORT_TYPE (port)->scm_read, port, dst, scm_from_size_t (start), scm_from_size_t (count))); } @@ -270,7 +182,7 @@ trampoline_to_c_write (SCM port, SCM src, SCM start, SCM count) SCM_ASSERT_RANGE (3, count, c_start+c_count <= scm_c_bytevector_length (src)); return scm_from_size_t - (SCM_PORT_DESCRIPTOR (port)->c_write (port, src, c_start, c_count)); + (SCM_PORT_TYPE (port)->c_write (port, src, c_start, c_count)); } #undef FUNC_NAME @@ -278,44 +190,40 @@ static size_t trampoline_to_scm_write (SCM port, SCM src, size_t start, size_t count) { return scm_to_size_t - (scm_call_4 (SCM_PORT_DESCRIPTOR (port)->scm_write, port, src, + (scm_call_4 (SCM_PORT_TYPE (port)->scm_write, port, src, scm_from_size_t (start), scm_from_size_t (count))); } void -scm_set_port_scm_read (scm_t_bits tc, SCM read) +scm_set_port_scm_read (scm_t_port_type *ptob, SCM read) { - scm_t_ptob_descriptor *desc = scm_c_port_type_ref (SCM_TC2PTOBNUM (tc)); - desc->scm_read = read; - desc->c_read = trampoline_to_scm_read; + ptob->scm_read = read; + ptob->c_read = trampoline_to_scm_read; } void -scm_set_port_scm_write (scm_t_bits tc, SCM write) +scm_set_port_scm_write (scm_t_port_type *ptob, SCM write) { - scm_t_ptob_descriptor *desc = scm_c_port_type_ref (SCM_TC2PTOBNUM (tc)); - desc->scm_write = write; - desc->c_write = trampoline_to_scm_write; + ptob->scm_write = write; + ptob->c_write = trampoline_to_scm_write; } void -scm_set_port_print (scm_t_bits tc, int (*print) (SCM exp, SCM port, - scm_print_state *pstate)) +scm_set_port_print (scm_t_port_type *ptob, + int (*print) (SCM exp, SCM port, scm_print_state *pstate)) { - scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->print = print; + ptob->print = print; } void -scm_set_port_close (scm_t_bits tc, void (*close) (SCM)) +scm_set_port_close (scm_t_port_type *ptob, void (*close) (SCM)) { - scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->close = close; + ptob->close = close; } void -scm_set_port_needs_close_on_gc (scm_t_bits tc, int needs_close_p) +scm_set_port_needs_close_on_gc (scm_t_port_type *ptob, int needs_close_p) { - scm_t_ptob_descriptor *ptob = scm_c_port_type_ref (SCM_TC2PTOBNUM (tc)); - if (needs_close_p) ptob->flags |= SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC; else @@ -323,35 +231,36 @@ scm_set_port_needs_close_on_gc (scm_t_bits tc, int needs_close_p) } void -scm_set_port_seek (scm_t_bits tc, scm_t_off (*seek) (SCM, scm_t_off, int)) +scm_set_port_seek (scm_t_port_type *ptob, + scm_t_off (*seek) (SCM, scm_t_off, int)) { - scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->seek = seek; + ptob->seek = seek; } void -scm_set_port_truncate (scm_t_bits tc, void (*truncate) (SCM, scm_t_off)) +scm_set_port_truncate (scm_t_port_type *ptob, void (*truncate) (SCM, scm_t_off)) { - scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->truncate = truncate; + ptob->truncate = truncate; } void -scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SCM)) +scm_set_port_input_waiting (scm_t_port_type *ptob, int (*input_waiting) (SCM)) { - scm_c_port_type_ref (SCM_TC2PTOBNUM (tc))->input_waiting = input_waiting; + ptob->input_waiting = input_waiting; } void -scm_set_port_random_access_p (scm_t_bits tc, int (*random_access_p) (SCM)) +scm_set_port_random_access_p (scm_t_port_type *ptob, + int (*random_access_p) (SCM)) { - scm_t_ptob_descriptor *ptob = scm_c_port_type_ref (SCM_TC2PTOBNUM (tc)); ptob->random_access_p = random_access_p; } void scm_set_port_get_natural_buffer_sizes - (scm_t_bits tc, void (*get_natural_buffer_sizes) (SCM, size_t *, size_t *)) + (scm_t_port_type *ptob, + void (*get_natural_buffer_sizes) (SCM, size_t *, size_t *)) { - scm_t_ptob_descriptor *ptob = scm_c_port_type_ref (SCM_TC2PTOBNUM (tc)); ptob->get_natural_buffer_sizes = get_natural_buffer_sizes; } @@ -684,7 +593,7 @@ static void initialize_port_buffers (SCM port) { scm_t_port *pt = SCM_PORT (port); - scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port); + scm_t_port_type *ptob = SCM_PORT_TYPE (port); size_t read_buf_size, write_buf_size; if (SCM_CELL_WORD_0 (port) & SCM_BUF0) @@ -711,18 +620,16 @@ initialize_port_buffers (SCM port) } SCM -scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits, +scm_c_make_port_with_encoding (scm_t_port_type *ptob, unsigned long mode_bits, SCM encoding, SCM conversion_strategy, scm_t_bits stream) { SCM ret; scm_t_port *pt; - scm_t_ptob_descriptor *ptob; pt = scm_gc_typed_calloc (scm_t_port); - ptob = scm_c_port_type_ref (SCM_TC2PTOBNUM (tag)); - ret = scm_words (tag | mode_bits, 4); + ret = scm_words (scm_tc7_port | mode_bits, 4); SCM_SET_CELL_WORD_1 (ret, stream); SCM_SET_CELL_WORD_2 (ret, (scm_t_bits) pt); SCM_SET_CELL_WORD_3 (ret, (scm_t_bits) ptob); @@ -737,7 +644,7 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits, pt->alist = SCM_EOL; - if (SCM_PORT_DESCRIPTOR (ret)->flags & SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC) + if (SCM_PORT_TYPE (ret)->flags & SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC) { scm_i_set_finalizer (SCM2PTR (ret), finalize_port, NULL); scm_weak_set_add_x (scm_i_port_weak_set, ret); @@ -751,20 +658,15 @@ scm_c_make_port_with_encoding (scm_t_bits tag, unsigned long mode_bits, } SCM -scm_c_make_port (scm_t_bits tag, unsigned long mode_bits, scm_t_bits stream) +scm_c_make_port (scm_t_port_type *ptob, + unsigned long mode_bits, scm_t_bits stream) { - return scm_c_make_port_with_encoding (tag, mode_bits, + return scm_c_make_port_with_encoding (ptob, mode_bits, scm_i_default_port_encoding (), scm_i_default_port_conversion_strategy (), stream); } -SCM -scm_new_port_table_entry (scm_t_bits tag) -{ - return scm_c_make_port (tag, 0, 0); -} - /* Predicates. */ @@ -860,13 +762,13 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, pt = SCM_PORT (port); SCM_CLR_PORT_OPEN_FLAG (port); - if (SCM_PORT_DESCRIPTOR (port)->flags & SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC) + if (SCM_PORT_TYPE (port)->flags & SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC) scm_weak_set_remove_x (scm_i_port_weak_set, port); - if (SCM_PORT_DESCRIPTOR (port)->close) + if (SCM_PORT_TYPE (port)->close) /* Note! This may throw an exception. Anything after this point should be resilient to non-local exits. */ - SCM_PORT_DESCRIPTOR (port)->close (port); + SCM_PORT_TYPE (port)->close (port); if (pt->iconv_descriptors) { @@ -1418,7 +1320,7 @@ static size_t scm_i_read_bytes (SCM port, SCM dst, size_t start, size_t count) { size_t filled; - scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port); + scm_t_port_type *ptob = SCM_PORT_TYPE (port); assert (count <= SCM_BYTEVECTOR_LENGTH (dst)); assert (start + count <= SCM_BYTEVECTOR_LENGTH (dst)); @@ -2107,7 +2009,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, { long csize; scm_t_port *pt; - scm_t_ptob_descriptor *ptob; + scm_t_port_type *ptob; scm_t_bits tag_word; size_t read_buf_size, write_buf_size; SCM saved_read_buf; @@ -2116,7 +2018,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, SCM_VALIDATE_OPENPORT (1, port); pt = SCM_PORT (port); - ptob = SCM_PORT_DESCRIPTOR (port); + ptob = SCM_PORT_TYPE (port); tag_word = SCM_CELL_WORD_0 (port) & ~(SCM_BUF0 | SCM_BUFLINE); if (scm_is_eq (mode, sym_none)) @@ -2237,7 +2139,7 @@ scm_end_input (SCM port) discarded = scm_port_buffer_take (buf, NULL, (size_t) -1); if (discarded != 0) - SCM_PORT_DESCRIPTOR (port)->seek (port, -discarded, SEEK_CUR); + SCM_PORT_TYPE (port)->seek (port, -discarded, SEEK_CUR); } SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0, @@ -2538,7 +2440,7 @@ SCM_DEFINE (scm_port_read, "port-read", 1, 0, 0, (SCM port), #define FUNC_NAME s_scm_port_read { SCM_VALIDATE_OPINPORT (1, port); - return SCM_PORT_DESCRIPTOR (port)->scm_read; + return SCM_PORT_TYPE (port)->scm_read; } #undef FUNC_NAME @@ -2548,7 +2450,7 @@ SCM_DEFINE (scm_port_write, "port-write", 1, 0, 0, #define FUNC_NAME s_scm_port_write { SCM_VALIDATE_OPOUTPORT (1, port); - return SCM_PORT_DESCRIPTOR (port)->scm_write; + return SCM_PORT_TYPE (port)->scm_write; } #undef FUNC_NAME @@ -2595,7 +2497,7 @@ static void scm_i_write_bytes (SCM port, SCM src, size_t start, size_t count) { size_t written = 0; - scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port); + scm_t_port_type *ptob = SCM_PORT_TYPE (port); assert (count <= SCM_BYTEVECTOR_LENGTH (src)); assert (start + count <= SCM_BYTEVECTOR_LENGTH (src)); @@ -2787,7 +2689,7 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, return SCM_BOOL_T; else { - scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (port); + scm_t_port_type *ptob = SCM_PORT_TYPE (port); if (ptob->input_waiting) return scm_from_bool (ptob->input_waiting (port)); @@ -2835,7 +2737,7 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, if (SCM_OPPORTP (fd_port)) { scm_t_port *pt = SCM_PORT (fd_port); - scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (fd_port); + scm_t_port_type *ptob = SCM_PORT_TYPE (fd_port); off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset); off_t_or_off64_t rv; @@ -2943,7 +2845,7 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, else if (SCM_OPOUTPORTP (object)) { off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length); - scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (object); + scm_t_port_type *ptob = SCM_PORT_TYPE (object); if (!ptob->truncate) SCM_MISC_ERROR ("port is not truncatable", SCM_EOL); @@ -3085,7 +2987,7 @@ scm_print_port_mode (SCM exp, SCM port) int scm_port_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { - char *type = SCM_PTOBNAME (SCM_PTOBNUM (exp)); + char *type = SCM_PORT_TYPE (port)->name; if (!type) type = "port"; scm_puts ("#<", port); @@ -3177,7 +3079,7 @@ SCM_DEFINE (scm_flush_all_ports, "flush-all-ports", 0, 0, 0, /* Void ports. */ -scm_t_bits scm_tc16_void_port = 0; +scm_t_port_type *scm_void_port_type = 0; static size_t void_port_read (SCM port, SCM dst, size_t start, size_t count) @@ -3194,7 +3096,7 @@ void_port_write (SCM port, SCM src, size_t start, size_t count) static SCM scm_i_void_port (long mode_bits) { - return scm_c_make_port (scm_tc16_void_port, mode_bits, 0); + return scm_c_make_port (scm_void_port_type, mode_bits, 0); } SCM @@ -3261,7 +3163,7 @@ scm_init_ports (void) scm_c_make_gsubr ("port-write", 4, 0, 0, (scm_t_subr) trampoline_to_c_write); - scm_tc16_void_port = scm_make_port_type ("void", void_port_read, + scm_void_port_type = scm_make_port_type ("void", void_port_read, void_port_write); scm_i_port_weak_set = scm_c_make_weak_set (31); diff --git a/libguile/ports.h b/libguile/ports.h index 18de70f65..709086c90 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -70,48 +70,47 @@ SCM_INTERNAL SCM scm_i_port_weak_set; #define SCM_CLR_PORT_OPEN_FLAG(p) \ SCM_SET_CELL_WORD_0 ((p), SCM_CELL_WORD_0 (p) & ~SCM_OPN) +typedef struct scm_t_port_type scm_t_port_type; +typedef struct scm_t_port scm_t_port; + #define SCM_STREAM(port) (SCM_CELL_WORD_1 (port)) #define SCM_SETSTREAM(port, stream) (SCM_SET_CELL_WORD_1 (port, stream)) +#define SCM_PORT(x) ((scm_t_port *) SCM_CELL_WORD_2 (x)) +#define SCM_PORT_TYPE(port) ((scm_t_port_type *) SCM_CELL_WORD_3 (port)) /* Maximum number of port types. */ #define SCM_I_MAX_PORT_TYPE_COUNT 256 + -typedef struct scm_t_ptob_descriptor scm_t_ptob_descriptor; - -#define SCM_TC2PTOBNUM(x) (0x0ff & ((x) >> 8)) -#define SCM_PTOBNUM(x) (SCM_TC2PTOBNUM (SCM_CELL_TYPE (x))) -/* SCM_PTOBNAME can be 0 if name is missing */ -#define SCM_PTOBNAME(ptobnum) (scm_c_port_type_ref (ptobnum)->name) - /* Port types, and their vtables. */ -SCM_INTERNAL long scm_c_num_port_types (void); -SCM_API scm_t_ptob_descriptor* scm_c_port_type_ref (long ptobnum); -SCM_API long scm_c_port_type_add_x (scm_t_ptob_descriptor *desc); -SCM_API scm_t_bits scm_make_port_type +SCM_API scm_t_port_type *scm_make_port_type (char *name, size_t (*read) (SCM port, SCM dst, size_t start, size_t count), size_t (*write) (SCM port, SCM src, size_t start, size_t count)); -SCM_API void scm_set_port_scm_read (scm_t_bits tc, SCM read); -SCM_API void scm_set_port_scm_write (scm_t_bits tc, SCM write); -SCM_API void scm_set_port_print (scm_t_bits tc, +SCM_API void scm_set_port_scm_read (scm_t_port_type *ptob, SCM read); +SCM_API void scm_set_port_scm_write (scm_t_port_type *ptob, SCM write); +SCM_API void scm_set_port_print (scm_t_port_type *ptob, int (*print) (SCM exp, SCM port, scm_print_state *pstate)); -SCM_API void scm_set_port_close (scm_t_bits tc, void (*close) (SCM)); -SCM_API void scm_set_port_needs_close_on_gc (scm_t_bits tc, int needs_close_p); -SCM_API void scm_set_port_seek (scm_t_bits tc, +SCM_API void scm_set_port_close (scm_t_port_type *ptob, void (*close) (SCM)); +SCM_API void scm_set_port_needs_close_on_gc (scm_t_port_type *ptob, + int needs_close_p); +SCM_API void scm_set_port_seek (scm_t_port_type *ptob, scm_t_off (*seek) (SCM port, scm_t_off OFFSET, int WHENCE)); -SCM_API void scm_set_port_truncate (scm_t_bits tc, +SCM_API void scm_set_port_truncate (scm_t_port_type *ptob, void (*truncate) (SCM port, scm_t_off length)); -SCM_API void scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SCM)); +SCM_API void scm_set_port_input_waiting (scm_t_port_type *ptob, + int (*input_waiting) (SCM)); SCM_API void scm_set_port_get_natural_buffer_sizes - (scm_t_bits tc, void (*get_natural_buffer_sizes) (SCM, size_t *, size_t *)); -SCM_API void scm_set_port_random_access_p (scm_t_bits tc, + (scm_t_port_type *ptob, + void (*get_natural_buffer_sizes) (SCM, size_t *, size_t *)); +SCM_API void scm_set_port_random_access_p (scm_t_port_type *ptob, int (*random_access_p) (SCM port)); /* The input, output, error, and load ports. */ @@ -138,14 +137,13 @@ SCM_API long scm_mode_bits (char *modes); SCM_API SCM scm_port_mode (SCM port); /* Low-level constructors. */ -SCM_API SCM scm_c_make_port_with_encoding (scm_t_bits tag, +SCM_API SCM scm_c_make_port_with_encoding (scm_t_port_type *ptob, unsigned long mode_bits, SCM encoding, SCM conversion_strategy, scm_t_bits stream); -SCM_API SCM scm_c_make_port (scm_t_bits tag, unsigned long mode_bits, +SCM_API SCM scm_c_make_port (scm_t_port_type *ptob, unsigned long mode_bits, scm_t_bits stream); -SCM_API SCM scm_new_port_table_entry (scm_t_bits tag); /* Predicates. */ SCM_API SCM scm_port_p (SCM x); diff --git a/libguile/print.c b/libguile/print.c index b0e6691ff..b1ddf58b6 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -815,7 +815,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) break; case scm_tc7_port: { - scm_t_ptob_descriptor *ptob = SCM_PORT_DESCRIPTOR (exp); + scm_t_port_type *ptob = SCM_PORT_TYPE (exp); if (ptob->print && ptob->print (exp, port, pstate)) break; goto punk; @@ -1691,7 +1691,7 @@ static int port_with_ps_print (SCM obj, SCM port, scm_print_state *pstate) { obj = SCM_PORT_WITH_PS_PORT (obj); - return SCM_PORT_DESCRIPTOR (obj)->print (obj, port, pstate); + return SCM_PORT_TYPE (obj)->print (obj, port, pstate); } SCM diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 6e6b2609d..7b18d8294 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -82,7 +82,7 @@ SCM_DEFINE (scm_eof_object, "eof-object", 0, 0, 0, #endif /* Bytevector input ports. */ -static scm_t_bits bytevector_input_port_type = 0; +static scm_t_port_type *bytevector_input_port_type = 0; struct bytevector_input_port { SCM bytevector; @@ -259,7 +259,7 @@ custom_binary_port_close (SCM port) /* Custom binary input ports. */ -static scm_t_bits custom_binary_input_port_type = 0; +static scm_t_port_type *custom_binary_input_port_type = 0; static inline SCM make_custom_binary_input_port (SCM read_proc, SCM get_position_proc, @@ -668,7 +668,7 @@ SCM_DEFINE (scm_unget_bytevector, "unget-bytevector", 2, 2, 0, XXX: Access to a bytevector output port's internal buffer is not thread-safe. */ -static scm_t_bits bytevector_output_port_type = 0; +static scm_t_port_type *bytevector_output_port_type = 0; SCM_SMOB (bytevector_output_port_procedure, "r6rs-bytevector-output-port-procedure", @@ -860,7 +860,7 @@ initialize_bytevector_output_ports (void) /* Custom binary output ports. */ -static scm_t_bits custom_binary_output_port_type; +static scm_t_port_type *custom_binary_output_port_type; static inline SCM @@ -950,7 +950,7 @@ initialize_custom_binary_output_ports (void) /* Transcoded ports. */ -static scm_t_bits transcoded_port_type = 0; +static scm_t_port_type *transcoded_port_type = 0; #define SCM_TRANSCODED_PORT_BINARY_PORT(_port) SCM_PACK (SCM_STREAM (_port)) diff --git a/libguile/strports.c b/libguile/strports.c index 1aecc481b..1a893ac34 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -54,7 +54,7 @@ SCM_SYMBOL (sym_UTF_8, "UTF-8"); -scm_t_bits scm_tc16_strport; +scm_t_port_type *scm_string_port_type; struct string_port { SCM bytevector; @@ -181,7 +181,7 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) stream->len = len; return - scm_c_make_port_with_encoding (scm_tc16_strport, modes, sym_UTF_8, + scm_c_make_port_with_encoding (scm_string_port_type, modes, sym_UTF_8, scm_i_default_port_conversion_strategy (), (scm_t_bits) stream); } @@ -375,21 +375,21 @@ scm_eval_string (SCM string) return scm_eval_string_in_module (string, SCM_UNDEFINED); } -static scm_t_bits +static scm_t_port_type * scm_make_string_port_type () { - scm_t_bits tc = scm_make_port_type ("string", - string_port_read, - string_port_write); - scm_set_port_seek (tc, string_port_seek); + scm_t_port_type *ptob = scm_make_port_type ("string", + string_port_read, + string_port_write); + scm_set_port_seek (ptob, string_port_seek); - return tc; + return ptob; } void scm_init_strports () { - scm_tc16_strport = scm_make_string_port_type (); + scm_string_port_type = scm_make_string_port_type (); #include "libguile/strports.x" } diff --git a/libguile/strports.h b/libguile/strports.h index b4bafdfc0..42080928b 100644 --- a/libguile/strports.h +++ b/libguile/strports.h @@ -28,7 +28,8 @@ -#define SCM_STRPORTP(x) (SCM_HAS_TYP16 (x, scm_tc16_strport)) +#define SCM_STRPORTP(x) \ + (SCM_PORTP (x) && SCM_PORT_TYPE (x) == scm_string_port_type) #define SCM_OPSTRPORTP(x) (SCM_STRPORTP (x) && \ (SCM_CELL_WORD_0 (x) & SCM_OPN)) #define SCM_OPINSTRPORTP(x) (SCM_OPSTRPORTP (x) && \ @@ -38,7 +39,7 @@ -SCM_API scm_t_bits scm_tc16_strport; +SCM_API scm_t_port_type *scm_string_port_type; diff --git a/libguile/tags.h b/libguile/tags.h index a5082f849..1c9dce4b9 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -434,8 +434,6 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; #define scm_tc7_unused_14 111 #define scm_tc7_unused_15 117 #define scm_tc7_unused_16 119 - -/* There are 256 port subtypes. */ #define scm_tc7_port 125 /* There are 256 smob subtypes. [**] If you change scm_tc7_smob, you must diff --git a/libguile/vports.c b/libguile/vports.c index 5ef54fdce..0f3823bc2 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -50,7 +50,7 @@ */ -static scm_t_bits scm_tc16_soft_port; +static scm_t_port_type *scm_soft_port_type; #define ENCODE_BUF_SIZE 10 @@ -221,31 +221,31 @@ SCM_DEFINE (scm_make_soft_port, "make-soft-port", 2, 0, 0, stream->input_waiting = vlen == 6 ? SCM_SIMPLE_VECTOR_REF (pv, 5) : SCM_BOOL_F; - return scm_c_make_port (scm_tc16_soft_port, scm_i_mode_bits (modes), + return scm_c_make_port (scm_soft_port_type, scm_i_mode_bits (modes), (scm_t_bits) stream); } #undef FUNC_NAME -static scm_t_bits +static scm_t_port_type * scm_make_sfptob () { - scm_t_bits tc = scm_make_port_type ("soft", soft_port_read, - soft_port_write); + scm_t_port_type *ptob = scm_make_port_type ("soft", soft_port_read, + soft_port_write); - scm_set_port_close (tc, soft_port_close); - scm_set_port_needs_close_on_gc (tc, 1); - scm_set_port_get_natural_buffer_sizes (tc, + scm_set_port_close (ptob, soft_port_close); + scm_set_port_needs_close_on_gc (ptob, 1); + scm_set_port_get_natural_buffer_sizes (ptob, soft_port_get_natural_buffer_sizes); - scm_set_port_input_waiting (tc, soft_port_input_waiting); + scm_set_port_input_waiting (ptob, soft_port_input_waiting); - return tc; + return ptob; } void scm_init_vports () { - scm_tc16_soft_port = scm_make_sfptob (); + scm_soft_port_type = scm_make_sfptob (); #include "libguile/vports.x" } diff --git a/test-suite/standalone/test-scm-c-read.c b/test-suite/standalone/test-scm-c-read.c index 7850f3447..c4dbf6251 100644 --- a/test-suite/standalone/test-scm-c-read.c +++ b/test-suite/standalone/test-scm-c-read.c @@ -43,7 +43,7 @@ struct custom_port /* Return a new port of type PORT_TYPE. */ static inline SCM -make_port (scm_t_bits port_type) +make_port (scm_t_port_type *port_type) { struct custom_port *stream = scm_gc_typed_calloc (struct custom_port); @@ -88,7 +88,7 @@ static void * do_start (void *arg) { SCM port; - scm_t_bits port_type; + scm_t_port_type *port_type; char buffer[PORT_BUFFER_SIZE + (PORT_BUFFER_SIZE / 2)]; size_t read, last_read; From 9322902d02ecc23ec4c8534dbbc03c3074b78217 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 13 May 2016 18:34:12 +0200 Subject: [PATCH 280/865] Update port type documentation * doc/ref/api-io.texi (I/O Extensions): Update for port type change. --- doc/ref/api-io.texi | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 41efb3547..8c91bae7f 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -2232,18 +2232,19 @@ the representation, will return an object equal (in the sense of This section describes how to implement a new port type in C. Although ports support many operations, as a data structure they present an opaque interface to the user. To the port implementor, you have two -additional pieces of information: the port type code, which you allocate -when defining your port type; and a port's ``stream'', which you -allocate when you create a port. +additional pieces of information: the port type, which is an opaque +pointer allocated when defining your port type; and a port's ``stream'', +which you allocate when you create a port. The type code helps you identify which ports are actually yours. The ``stream'' is the private data associated with that port which you and only you control. Get a stream from a port using the @code{SCM_STREAM} -macro. +macro. Note that your port methods are only ever called with ports of +your type. A port type is created by calling @code{scm_make_port_type}. -@deftypefun scm_t_bits scm_make_port_type (char *name, size_t (*read) (SCM port, SCM dst, size_t start, size_t count), size_t (*write) (SCM port, SCM src, size_t start, size_t count)) +@deftypefun scm_t_port_type* scm_make_port_type (char *name, size_t (*read) (SCM port, SCM dst, size_t start, size_t count), size_t (*write) (SCM port, SCM src, size_t start, size_t count)) Define a new port type. The @var{name}, @var{read} and @var{write} parameters are initial values for those port type fields, as described below. The other fields are initialized with default values and can be @@ -2278,7 +2279,7 @@ Called when @code{write} is called on the port, to print a port description. For example, for a file port it may produce something like: @code{#}. Set using -@deftypefun void scm_set_port_print (scm_t_bits tc, int (*print) (SCM port, SCM dest_port, scm_print_state *pstate)) +@deftypefun void scm_set_port_print (scm_t_port_type *type, int (*print) (SCM port, SCM dest_port, scm_print_state *pstate)) The first argument @var{port} is the port being printed, the second argument @var{dest_port} is where its description should go. @end deftypefun @@ -2287,7 +2288,7 @@ argument @var{dest_port} is where its description should go. Called when the port is closed. It should free any resources used by the port. Set using -@deftypefun void scm_set_port_close (scm_t_bits tc, void (*close) (SCM port)) +@deftypefun void scm_set_port_close (scm_t_port_type *type, void (*close) (SCM port)) @end deftypefun By default, ports that are garbage collected just go away without @@ -2296,21 +2297,21 @@ a file descriptor, or needs to make sure that its internal buffers are flushed even if the port is collected while it was open, then mark the port type as needing a close on GC. -@deftypefun void scm_set_port_needs_close_on_gc (scm_t_bits tc, int needs_close_p) +@deftypefun void scm_set_port_needs_close_on_gc (scm_t_port_type *type, int needs_close_p) @end deftypefun @item seek Set the current position of the port. Guile will flush read and/or write buffers before seeking, as appropriate. -@deftypefun void scm_set_port_seek (scm_t_bits tc, scm_t_off (*seek) (SCM port, scm_t_off offset, int whence)) +@deftypefun void scm_set_port_seek (scm_t_port_type *type, scm_t_off (*seek) (SCM port, scm_t_off offset, int whence)) @end deftypefun @item truncate Truncate the port data to be specified length. Guile will flush buffers before hand, as appropriate. Set using -@deftypefun void scm_set_port_truncate (scm_t_bits tc, void (*truncate) (SCM port, scm_t_off length)) +@deftypefun void scm_set_port_truncate (scm_t_port_type *type, void (*truncate) (SCM port, scm_t_off length)) @end deftypefun @item random_access_p @@ -2329,7 +2330,7 @@ nonzero value from your @code{random_access_p} function. The default implementation of this function returns nonzero if the port type supplies a seek implementation. -@deftypefun void scm_set_port_random_access_p (scm_t_bits tc, int (*random_access_p) (SCM port)); +@deftypefun void scm_set_port_random_access_p (scm_t_port_type *type, int (*random_access_p) (SCM port)); @end deftypefun @item get_natural_buffer_sizes @@ -2346,7 +2347,7 @@ bytevector. However in some cases, port implementations may be able to provide an appropriate default buffer size to Guile. @deftypefun void scm_set_port_get_natural_buffer_sizes @ - (scm_t_bits tc, void (*get_natural_buffer_sizes) (SCM, size_t *read_buf_size, size_t *write_buf_size)) + (scm_t_port_type *type, void (*get_natural_buffer_sizes) (SCM, size_t *read_buf_size, size_t *write_buf_size)) Fill in @var{read_buf_size} and @var{write_buf_size} with an appropriate buffer size for this port, if one is known. @end deftypefun From 9ecf77a82d6060a26f6891181f4582cc19dec65e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 14 May 2016 12:38:49 +0200 Subject: [PATCH 281/865] Add SCM_OPN to mode bits when making ports * libguile/ports.c (scm_c_make_port_with_encoding): Add SCM_OPN to mode bits, so that users don't have to. (scm_i_mode_bits_n): * libguile/print.c (scm_simple_format) * libguile/r6rs-ports.c (make_bytevector_input_port) (make_custom_binary_input_port, make_bytevector_output_port) (make_custom_binary_output_port, make_transcoded_port) * libguile/strports.c (scm_object_to_string, scm_open_input_string) (scm_open_output_string, scm_c_read_string): Remove now-unneeded SCM_OPN mentions. --- libguile/ports.c | 7 +++---- libguile/print.c | 4 +--- libguile/r6rs-ports.c | 15 +++++---------- libguile/strports.c | 23 +++++++---------------- 4 files changed, 16 insertions(+), 33 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 464f8f2a9..a89c7e48e 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -485,9 +485,8 @@ scm_c_make_port_buffer (size_t size) static long scm_i_mode_bits_n (SCM modes) { - return (SCM_OPN - | (scm_i_string_contains_char (modes, 'r') - || scm_i_string_contains_char (modes, '+') ? SCM_RDNG : 0) + return ((scm_i_string_contains_char (modes, 'r') + || scm_i_string_contains_char (modes, '+') ? SCM_RDNG : 0) | (scm_i_string_contains_char (modes, 'w') || scm_i_string_contains_char (modes, 'a') || scm_i_string_contains_char (modes, '+') ? SCM_WRTNG : 0) @@ -629,7 +628,7 @@ scm_c_make_port_with_encoding (scm_t_port_type *ptob, unsigned long mode_bits, pt = scm_gc_typed_calloc (scm_t_port); - ret = scm_words (scm_tc7_port | mode_bits, 4); + ret = scm_words (scm_tc7_port | mode_bits | SCM_OPN, 4); SCM_SET_CELL_WORD_1 (ret, stream); SCM_SET_CELL_WORD_2 (ret, (scm_t_bits) pt); SCM_SET_CELL_WORD_3 (ret, (scm_t_bits) ptob); diff --git a/libguile/print.c b/libguile/print.c index b1ddf58b6..562057722 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1565,9 +1565,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, else if (scm_is_false (destination)) { fReturnString = 1; - port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F, - SCM_OPN | SCM_WRTNG, - FUNC_NAME); + port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F, SCM_WRTNG, FUNC_NAME); destination = port; } else diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 7b18d8294..c53b53bf2 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -92,7 +92,7 @@ struct bytevector_input_port { static inline SCM make_bytevector_input_port (SCM bv) { - const unsigned long mode_bits = SCM_OPN | SCM_RDNG; + const unsigned long mode_bits = SCM_RDNG; struct bytevector_input_port *stream; stream = scm_gc_typed_calloc (struct bytevector_input_port); @@ -266,7 +266,7 @@ make_custom_binary_input_port (SCM read_proc, SCM get_position_proc, SCM set_position_proc, SCM close_proc) { struct custom_binary_port *stream; - const unsigned long mode_bits = SCM_OPN | SCM_RDNG; + const unsigned long mode_bits = SCM_RDNG; stream = scm_gc_typed_calloc (struct custom_binary_port); stream->read = read_proc; @@ -734,7 +734,7 @@ make_bytevector_output_port (void) { SCM port, proc; scm_t_bytevector_output_port_buffer *buf; - const unsigned long mode_bits = SCM_OPN | SCM_WRTNG; + const unsigned long mode_bits = SCM_WRTNG; buf = (scm_t_bytevector_output_port_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BYTEVECTOR_OUTPUT_PORT); @@ -868,7 +868,7 @@ make_custom_binary_output_port (SCM write_proc, SCM get_position_proc, SCM set_position_proc, SCM close_proc) { struct custom_binary_port *stream; - const unsigned long mode_bits = SCM_OPN | SCM_WRTNG; + const unsigned long mode_bits = SCM_WRTNG; stream = scm_gc_typed_calloc (struct custom_binary_port); stream->read = SCM_BOOL_F; @@ -957,13 +957,8 @@ static scm_t_port_type *transcoded_port_type = 0; static inline SCM make_transcoded_port (SCM binary_port, unsigned long mode) { - SCM port; - const unsigned long mode_bits = SCM_OPN | mode; - - port = scm_c_make_port (transcoded_port_type, mode_bits, + return scm_c_make_port (transcoded_port_type, mode, SCM_UNPACK (binary_port)); - - return port; } static size_t diff --git a/libguile/strports.c b/libguile/strports.c index 1a893ac34..e2bbe53ca 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -215,8 +215,7 @@ SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0, if (!SCM_UNBNDP (printer)) SCM_VALIDATE_PROC (2, printer); - port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F, - SCM_OPN | SCM_WRTNG, FUNC_NAME); + port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F, SCM_WRTNG, FUNC_NAME); if (SCM_UNBNDP (printer)) scm_write (obj, port); @@ -267,8 +266,7 @@ SCM_DEFINE (scm_open_input_string, "open-input-string", 1, 0, 0, "by the garbage collector if it becomes inaccessible.") #define FUNC_NAME s_scm_open_input_string { - SCM p = scm_mkstrport (SCM_INUM0, str, SCM_OPN | SCM_RDNG, FUNC_NAME); - return p; + return scm_mkstrport (SCM_INUM0, str, SCM_RDNG, FUNC_NAME); } #undef FUNC_NAME @@ -281,12 +279,7 @@ SCM_DEFINE (scm_open_output_string, "open-output-string", 0, 0, 0, "inaccessible.") #define FUNC_NAME s_scm_open_output_string { - SCM p; - - p = scm_mkstrport (SCM_INUM0, SCM_BOOL_F, - SCM_OPN | SCM_WRTNG, - FUNC_NAME); - return p; + return scm_mkstrport (SCM_INUM0, SCM_BOOL_F, SCM_WRTNG, FUNC_NAME); } #undef FUNC_NAME @@ -308,15 +301,13 @@ SCM_DEFINE (scm_get_output_string, "get-output-string", 1, 0, 0, SCM scm_c_read_string (const char *expr) { - SCM port = scm_mkstrport (SCM_INUM0, - scm_from_locale_string (expr), - SCM_OPN | SCM_RDNG, - "scm_c_read_string"); - SCM form; + SCM port, form; + port = scm_mkstrport (SCM_INUM0, scm_from_locale_string (expr), + SCM_RDNG, "scm_c_read_string"); form = scm_read (port); - scm_close_port (port); + return form; } From a9d0fe9ea136563aaac3423faffe8041f0db68fe Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 14 May 2016 23:25:39 +0200 Subject: [PATCH 282/865] Update port mode bits documentation. * libguile/ports.h: Update documentation of port mode bits. --- libguile/ports.h | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/libguile/ports.h b/libguile/ports.h index 709086c90..43cd7458d 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -48,16 +48,15 @@ SCM_INTERNAL SCM scm_i_port_weak_set; #define SCM_EOF_OBJECT_P(x) (scm_is_eq ((x), SCM_EOF_VAL)) -/* PORT FLAGS - * A set of flags characterizes a port. - * Note that we reserve the bits 1 << 24 and above for use by the - * routines in the port's scm_ptobfuns structure. - */ -#define SCM_OPN (1L<<16) /* Is the port open? */ -#define SCM_RDNG (2L<<16) /* Is it a readable port? */ -#define SCM_WRTNG (4L<<16) /* Is it writable? */ -#define SCM_BUF0 (8L<<16) /* Is it unbuffered? */ -#define SCM_BUFLINE (64L<<16) /* Is it line-buffered? */ +/* A port's first word contains its tag, which is a tc7 value. Above + there is a flag indicating whether the port is open or not, and then + some "mode bits": flags indicating whether the port is an input + and/or an output port and how Guile should buffer the port. */ +#define SCM_OPN (1U<<16) /* Is the port open? */ +#define SCM_RDNG (1U<<17) /* Is it a readable port? */ +#define SCM_WRTNG (1U<<18) /* Is it writable? */ +#define SCM_BUF0 (1U<<19) /* Is it unbuffered? */ +#define SCM_BUFLINE (1U<<20) /* Is it line-buffered? */ #define SCM_PORTP(x) (SCM_HAS_TYP7 (x, scm_tc7_port)) #define SCM_OPPORTP(x) (SCM_PORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_OPN)) From 556ac9777b06c0d53713752b1b3ccd6480baf118 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 14 May 2016 23:27:38 +0200 Subject: [PATCH 283/865] Document scm_c_make_port and friends * doc/ref/api-io.texi (I/O Extensions): Document scm_c_make_port and friends, and document "mode bits". --- doc/ref/api-io.texi | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 8c91bae7f..23d3b50cd 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -2242,7 +2242,9 @@ only you control. Get a stream from a port using the @code{SCM_STREAM} macro. Note that your port methods are only ever called with ports of your type. -A port type is created by calling @code{scm_make_port_type}. +A port type is created by calling @code{scm_make_port_type}. Once you +have your port type, you can create ports with @code{scm_c_make_port}, +or @code{scm_c_make_port_with_encoding}. @deftypefun scm_t_port_type* scm_make_port_type (char *name, size_t (*read) (SCM port, SCM dst, size_t start, size_t count), size_t (*write) (SCM port, SCM src, size_t start, size_t count)) Define a new port type. The @var{name}, @var{read} and @var{write} @@ -2251,6 +2253,24 @@ below. The other fields are initialized with default values and can be changed later. @end deftypefun +@deftypefun SCM scm_c_make_port_with_encoding (scm_t_port_type *type, unsigned long mode_bits, SCM encoding, SCM conversion_strategy, scm_t_bits stream) +@deftypefunx SCM scm_c_make_port (scm_t_port_type *type, unsigned long mode_bits, scm_t_bits stream) +Make a port with the given @var{type}. The @var{stream} indicates the +private data associated with the port, which your port implementation +may later retrieve with @code{SCM_STREAM}. The mode bits should include +one or more of the flags @code{SCM_RDNG} or @code{SCM_WRTNG}, indicating +that the port is an input and/or an output port, respectively. The mode +bits may also include @code{SCM_BUF0} or @code{SCM_BUFLINE}, indicating +that the port should be unbuffered or line-buffered, respectively. The +default is that the port will be block-buffered. @xref{Buffering}. + +As you would imagine, @var{encoding} and @var{conversion_strategy} +specify the port's initial textual encoding and conversion strategy. +Both are symbols. @code{scm_c_make_port} is the same as +@code{scm_c_make_port_with_encoding}, except it uses the default port +encoding and conversion strategy. +@end deftypefun + The port type has a number of associate procedures and properties which collectively implement the port's behavior. Creating a new port type mostly involves writing these procedures. From 745cbb491806929a342c016c73afcdc117f2398b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 14 May 2016 23:46:17 +0200 Subject: [PATCH 284/865] Remove unused type from ports-internal * libguile/ports-internal.h: Remove unused scm_t_port_rw_active. * libguile/deprecated.h (scm_port_rw_active): Remove deprecation shim, as this thing is just gone now. --- libguile/deprecated.h | 1 - libguile/ports-internal.h | 6 ------ 2 files changed, 7 deletions(-) diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 04c540e22..592dc98d5 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -115,7 +115,6 @@ SCM_DEPRECATED SCM scm_internal_dynamic_wind (scm_t_guard before, #define scm_listify scm_listify__GONE__REPLACE_WITH__scm_list_n #define scm_option scm_option__GONE__REPLACE_WITH__scm_t_option #define scm_port scm_port__GONE__REPLACE_WITH__scm_t_port -#define scm_port_rw_active scm_port_rw_active__GONE__REPLACE_WITH__scm_t_port_rw_active #define scm_ptob_descriptor scm_ptob_descriptor__GONE__REPLACE_WITH__scm_t_port_type #define scm_rng scm_rng__GONE__REPLACE_WITH__scm_t_rng #define scm_rstate scm_rstate__GONE__REPLACE_WITH__scm_t_rstate diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index 161213b6f..54ce3e4b0 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -331,12 +331,6 @@ struct scm_t_port #define SCM_DECCOL(port) do {if (SCM_COL (port) > 0) SCM_COL (port) -= 1;} while (0) #define SCM_TABCOL(port) do {SCM_COL (port) += 8 - SCM_COL (port) % 8;} while (0) -typedef enum scm_t_port_rw_active { - SCM_PORT_NEITHER = 0, - SCM_PORT_READ = 1, - SCM_PORT_WRITE = 2 -} scm_t_port_rw_active; - SCM_INTERNAL scm_t_iconv_descriptors * scm_i_port_iconv_descriptors (SCM port); #endif From d6922b4af41b110cb46b32cf317a45e92bfbc419 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 15 May 2016 22:26:34 +0200 Subject: [PATCH 285/865] Update NEWS for release * NEWS: Try to tell the port story better. --- NEWS | 77 ++++++++++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 67 insertions(+), 10 deletions(-) diff --git a/NEWS b/NEWS index 85cf5f576..7165f8d9e 100644 --- a/NEWS +++ b/NEWS @@ -9,6 +9,28 @@ Please send Guile bug reports to bug-guile@gnu.org. Changes in 2.1.3 (changes since the 2.1.2 alpha release): * Notable changes +** Complete overhaul of port internals + +Guile's ports have been completely overhauled to allow Guile developers +and eventually Guile users to write low-level input and output routines +in Scheme. The new internals will eventually allow for user-space +tasklets or green threads that suspend to a scheduler when they would +cause blocking I/O, allowing users to write straightforward network +services that parse their input and send their output as if it were +blocking, while under the hood Guile can multiplex many active +connections at once. + +At the same time, this change makes Guile's ports implementation much +more maintainable, rationalizing the many legacy port internals and +making sure that the abstractions between the user, Guile's core ports +facility, and the port implementations result in a system that is as +performant and expressive as possible. + +The interface to the user has no significant change, neither on the C +side nor on the Scheme side. However this refactoring has changed the +interface to the port implementor in an incompatible way. See below for +full details. + ** All ports are now buffered, can be targets of `setvbuf' See "Buffering" in the manual, for more. A port with a buffer size of 1 @@ -16,6 +38,18 @@ is equivalent to an unbuffered port. Ports may set their default buffer sizes, and some ports (for example soft ports) are unbuffered by default for historical reasons. +** Removal of port locks + +As part of the 2.2 series, we introduced recursive locks on each port, +and arranged to lock them to avoid crashes but also to serialize I/O in +some ways. This turned out to be a mistake: the port lock does not +necessarily correspond to a program's desired atomic unit of I/O, so +correct programs would likely have to have their own locking. At the +same time the port buffering refactoring made it possible for us to +avoid the crashes that led to the introduction of locking, but without +locks. For that reason we have removed port locks, and removed the +"_unlocked" port API variants that were introduced in 2.1.0. + * New deprecations ** `_IONBF', `_IOLBF', and `_IOFBF' @@ -23,14 +57,24 @@ Instead, use the symbol values `none', `line', or `block', respectively, as arguments to the `setvbuf' function. * Incompatible changes + +** Decoding errors do not advance the read pointer before erroring + +When the user sets a port's conversion strategy to "error", indicating +that Guile should throw an error if it tries to read from a port whose +incoming bytes are not valid for the port's encoding, it used to be that +Guile would advance the read pointer past the bad bytes, and then throw +an error. This would allow the following `read-char' invocation to +proceed after the bad bytes. This behavior is incompatible with the +final R6RS standard, and besides contravenes the user's intention to +raise an error on bad input. Guile now raises an error without +advancing the read pointer. To skip over a bad encoding, set the port +conversion strategy to "substitute" and read a substitute character. + ** API to define new port types from C has changed -In Guile 2.2 the API used to define new port types has changed. This -largely shouldn't affect port users, modulo the buffering port mentioned -above. However, in order to enable all ports to have buffers -implemented in the same way, which is a prerequisite to non-blocking -I/O, the port API has changed. See "I/O Extensions" in the manual, for -full details. Notably: +See the newly expanded "I/O Extensions" in the manual, for full details. +Notably: *** Remove `scm_set_port_mark' @@ -61,12 +105,25 @@ manage an implementation-side buffer are no longer needed. *** Change prototype of `scm_make_port_type' -The `read' (renamed from `fill_input') and `write' functions now return -void and take a port buffer. +The `read' (renamed from `fill_input') and `write' functions now operate +on bytevectors. Also the `mode_bits' argument now inplicitly includes +SCM_OPN, so you don't need to include these. -*** Remove `SCM_INITIAL_PUTBACK_BUF_SIZE', `SCM_READ_BUFFER_EMPTY_P' +*** Change prototype of port `close' function -Probably nobody used these. +The port close function now returns void. + +*** Port and port type data structures are now opaque + +Port type implementations should now use API to access port state. +However, since the change to handle port buffering centrally, port type +implementations rarely need to access unrelated port state. + +*** Port types are now `scm_t_port_type*', not a tc16 value + +`scm_make_port_type' now returns an opaque pointer, not a tc16. +Relatedly, the limitation that there only be 256 port types has been +lifted. From da456d23beb1b13063a9817d63797aa08949ba20 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 16 May 2016 09:38:09 +0200 Subject: [PATCH 286/865] Bump objcode version * libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): * module/system/vm/assembler.scm (*bytecode-minor-version*): Bump for Guile 2.1.3. --- libguile/_scm.h | 2 +- module/system/vm/assembler.scm | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/_scm.h b/libguile/_scm.h index d84209c92..2792fd29e 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -268,7 +268,7 @@ void scm_ia64_longjmp (scm_i_jmp_buf *, int); /* Major and minor versions must be single characters. */ #define SCM_OBJCODE_MAJOR_VERSION 3 -#define SCM_OBJCODE_MINOR_VERSION 7 +#define SCM_OBJCODE_MINOR_VERSION 8 #define SCM_OBJCODE_MAJOR_VERSION_STRING \ SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION) #define SCM_OBJCODE_MINOR_VERSION_STRING \ diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 117bc6cf3..2ee608111 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -1754,7 +1754,7 @@ needed." ;; FIXME: Define these somewhere central, shared with C. (define *bytecode-major-version* #x0202) -(define *bytecode-minor-version* 7) +(define *bytecode-minor-version* 8) (define (link-dynamic-section asm text rw rw-init frame-maps) "Link the dynamic section for an ELF image with bytecode @var{text}, From 1e058add7b9568fb3a37e4fa82360d183d0a26ee Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 16 May 2016 10:44:21 +0200 Subject: [PATCH 287/865] U+FFFD is the input substitution character * libguile/ports.c (UNICODE_REPLACEMENT_CHARACTER): * libguile/ports.c (peek_utf8_codepoint) (scm_port_decode_char, peek_iconv_codepoint): * module/ice-9/sports.scm (peek-char-and-len/utf8): (peek-char-and-len/iconv): Return U+FFFD when we get a decoding error when reading, instead of '?', in accordance with Unicode recommendations. * test-suite/tests/iconv.test: * test-suite/tests/ports.test: * test-suite/tests/rdelim.test: Update tests. * NEWS: Update. --- NEWS | 7 ++++ doc/ref/api-io.texi | 76 ++++++++++++++++++++---------------- libguile/ports.c | 12 ++++-- module/ice-9/sports.scm | 6 +-- test-suite/tests/iconv.test | 2 +- test-suite/tests/ports.test | 4 +- test-suite/tests/rdelim.test | 2 +- 7 files changed, 65 insertions(+), 44 deletions(-) diff --git a/NEWS b/NEWS index 7165f8d9e..3e64129e4 100644 --- a/NEWS +++ b/NEWS @@ -71,6 +71,13 @@ raise an error on bad input. Guile now raises an error without advancing the read pointer. To skip over a bad encoding, set the port conversion strategy to "substitute" and read a substitute character. +** Decoding errors with `substitute' strategy return U+FFFD + +It used to be that decoding errors with the `substitute' conversion +strategy would replace the bad bytes with a `?' character. This has +been changed to use the standard U+FFFD REPLACEMENT CHARACTER, in +accordance with the Unicode recommendations. + ** API to define new port types from C has changed See the newly expanded "I/O Extensions" in the manual, for full details. diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 23d3b50cd..5b200977b 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -78,11 +78,17 @@ string doesn't depend on its context: the same byte sequence will always return the same string. A couple of modal encodings are in common use, like ISO-2022-JP and ISO-2022-KR, and they are not yet supported. -Each port also has an associated conversion strategy: what to do when -a Guile character can't be converted to the port's encoded character -representation for output. There are three possible strategies: to -raise an error, to replace the character with a hex escape, or to -replace the character with a substitute character. +@cindex port conversion strategy +@cindex conversion strategy, port +@cindex decoding error +@cindex encoding error +Each port also has an associated conversion strategy, which determines +what to do when a Guile character can't be converted to the port's +encoded character representation for output. There are three possible +strategies: to raise an error, to replace the character with a hex +escape, or to replace the character with a substitute character. Port +conversion strategies are also used when decoding characters from an +input port. Finally, all ports have associated input and output buffers, as appropriate. Buffering is a common strategy to limit the overhead of @@ -142,14 +148,10 @@ its input and output. The value @code{#f} is equivalent to @code{"ISO-8859-1"}. @deffn {Scheme Procedure} set-port-conversion-strategy! port sym @deffnx {C Function} scm_set_port_conversion_strategy_x (port, sym) -Sets the behavior of the interpreter when outputting a character that -is not representable in the port's current encoding. @var{sym} can be -either @code{'error}, @code{'substitute}, or @code{'escape}. If it is -@code{'error}, an error will be thrown when an nonconvertible character -is encountered. If it is @code{'substitute}, then nonconvertible -characters will be replaced with approximate characters, or with -question marks if no approximately correct character is available. If -it is @code{'escape}, it will appear as a hex escape when output. +Sets the behavior of Guile when outputting a character that is not +representable in the port's current encoding, or when Guile encounters a +decoding error when trying to read a character. @var{sym} can be either +@code{error}, @code{substitute}, or @code{escape}. If @var{port} is an open port, the conversion error behavior is set for that port. If it is @code{#f}, it is set as the @@ -157,15 +159,27 @@ default behavior for any future ports that get created in this thread. @end deffn +For an output port, a there are three possible port conversion +strategies. The @code{error} strategy will throw an error when a +nonconvertible character is encountered. The @code{substitute} strategy +will replace nonconvertible characters with a question mark (@samp{?}). +Finally the @code{escape} strategy will print nonconvertible characters +as a hex escape, using the escaping that is recognized by Guile's string +syntax. Note that if the port's encoding is a Unicode encoding, like +@code{UTF-8}, then encoding errors are impossible. + +For an input port, the @code{error} strategy will cause Guile to throw +an error if it encounters an invalid encoding, such as might happen if +you tried to read @code{ISO-8859-1} as @code{UTF-8}. The error is +thrown before advancing the read position. The @code{substitute} +strategy will replace the bad bytes with a U+FFFD replacement character, +in accordance with Unicode recommendations. When reading from an input +port, the @code{escape} strategy is treated as if it were @code{error}. + @deffn {Scheme Procedure} port-conversion-strategy port @deffnx {C Function} scm_port_conversion_strategy (port) -Returns the behavior of the port when outputting a character that is -not representable in the port's current encoding. It returns the -symbol @code{error} if unrepresentable characters should cause -exceptions, @code{substitute} if the port should try to replace -unrepresentable characters with question marks or approximate -characters, or @code{escape} if unrepresentable characters should be -converted to string escapes. +Returns the behavior of the port when outputting a character that is not +representable in the port's current encoding. If @var{port} is @code{#f}, then the current default behavior will be returned. New ports will have this default behavior when they are @@ -179,9 +193,9 @@ and for other conversion routines such as @code{scm_to_stringn}, @code{pointer->string}. Its value must be one of the symbols described above, with the same -semantics: @code{'error}, @code{'substitute}, or @code{'escape}. +semantics: @code{error}, @code{substitute}, or @code{escape}. -When Guile starts, its value is @code{'substitute}. +When Guile starts, its value is @code{substitute}. Note that @code{(set-port-conversion-strategy! #f @var{sym})} is equivalent to @code{(fluid-set! %default-port-conversion-strategy @@ -226,13 +240,10 @@ interactive port that has no ready characters. @rnindex read-char @deffn {Scheme Procedure} read-char [port] @deffnx {C Function} scm_read_char (port) -Return the next character available from @var{port}, updating -@var{port} to point to the following character. If no more -characters are available, the end-of-file object is returned. - -When @var{port}'s data cannot be decoded according to its character -encoding, a @code{decoding-error} is raised and @var{port} is not -advanced past the erroneous byte sequence. +Return the next character available from @var{port}, updating @var{port} +to point to the following character. If no more characters are +available, the end-of-file object is returned. A decoding error, if +any, is handled in accordance with the port's conversion strategy. @end deffn @deftypefn {C Function} size_t scm_c_read (SCM port, void *buffer, size_t size) @@ -262,8 +273,8 @@ return the value returned by the preceding call to an interactive port will hang waiting for input whenever a call to @code{read-char} would have hung. -As for @code{read-char}, a @code{decoding-error} may be raised -if such a situation occurs. +As for @code{read-char}, decoding errors are handled in accordance with +the port's conversion strategy. @end deffn @deffn {Scheme Procedure} unread-char cobj [port] @@ -627,9 +638,6 @@ Push the terminating delimiter (if any) back on to the port. Return a pair containing the string read from the port and the terminating delimiter or end-of-file object. @end table - -Like @code{read-char}, this procedure can throw to @code{decoding-error} -(@pxref{Reading, @code{read-char}}). @end deffn @c begin (scm-doc-string "rdelim.scm" "read-line!") diff --git a/libguile/ports.c b/libguile/ports.c index a89c7e48e..c67bdf53b 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -109,6 +109,12 @@ static SCM sym_substitute; static SCM sym_escape; + + +/* See Unicode 8.0 section 5.22, "Best Practice for U+FFFD + Substitution". */ +static const scm_t_wchar UNICODE_REPLACEMENT_CHARACTER = 0xFFFD; + static SCM trampoline_to_c_read_subr; @@ -1590,7 +1596,7 @@ peek_utf8_codepoint (SCM port, size_t *len) decoding_error: if (scm_is_eq (SCM_PORT (port)->conversion_strategy, sym_substitute)) /* *len already set. */ - return '?'; + return UNICODE_REPLACEMENT_CHARACTER; scm_decoding_error ("peek-char", EILSEQ, "input decoding error", port); /* Not reached. */ @@ -1648,7 +1654,7 @@ SCM_DEFINE (scm_port_decode_char, "port-decode-char", 4, 0, 0, return SCM_BOOL_F; else if (scm_is_eq (SCM_PORT (port)->conversion_strategy, sym_substitute)) - return SCM_MAKE_CHAR ('?'); + return SCM_MAKE_CHAR (UNICODE_REPLACEMENT_CHARACTER); else scm_decoding_error ("decode-char", err, "input decoding error", port); } @@ -1699,7 +1705,7 @@ peek_iconv_codepoint (SCM port, size_t *len) /* EOF found in the middle of a multibyte character. */ if (scm_is_eq (SCM_PORT (port)->conversion_strategy, sym_substitute)) - return '?'; + return UNICODE_REPLACEMENT_CHARACTER; scm_decoding_error ("peek-char", EILSEQ, "input decoding error", port); diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm index 55f507866..6fd7ddd31 100644 --- a/module/ice-9/sports.scm +++ b/module/ice-9/sports.scm @@ -291,7 +291,7 @@ (define (peek-char-and-len/utf8 port first-byte) (define (bad-utf8 len) (if (eq? (port-conversion-strategy port) 'substitute) - (values #\? len) + (values #\xFFFD len) (decoding-error "peek-char" port))) (if (< first-byte #x80) (values (integer->char first-byte) 1) @@ -308,7 +308,7 @@ (let ((len (bad-utf8-len bv cur buffering first-byte))) (when (zero? len) (error "internal error")) (if (eq? (port-conversion-strategy port) 'substitute) - (values #\? len) + (values #\xFFFD len) (decoding-error "peek-char" port)))) (decode-utf8 bv cur buffering first-byte values bad-utf8)))))) @@ -327,7 +327,7 @@ ((zero? prev-input-size) (values the-eof-object 0)) ((eq? (port-conversion-strategy port) 'substitute) - (values #\? prev-input-size)) + (values #\xFFFD prev-input-size)) (else (decoding-error "peek-char" port)))) ((port-decode-char port (port-buffer-bytevector buf) diff --git a/test-suite/tests/iconv.test b/test-suite/tests/iconv.test index be36336f3..676d94821 100644 --- a/test-suite/tests/iconv.test +++ b/test-suite/tests/iconv.test @@ -97,7 +97,7 @@ (pass-if "misparse latin1 as utf8 with substitutions" (equal? (bytevector->string (string->bytevector s "latin1") "utf-8" 'substitute) - "?t?")) + "\uFFFDt\uFFFD")) (pass-if-exception "misparse latin1 as ascii" exception:decoding-error (bytevector->string (string->bytevector s "latin1") "ascii")))) diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index 3bb001e4d..029dd2dd9 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -834,7 +834,7 @@ ;; If `proc' is `read-char', this will ;; skip over the bad bytes. (let ((c (proc p))) - (unless (eqv? c #\?) + (unless (eqv? c #\xFFFD) (error "unexpected char" c)) (set-port-conversion-strategy! p strategy) #t))) @@ -846,7 +846,7 @@ ((_ port (proc -> error)) (if (eq? 'substitute (port-conversion-strategy port)) - (eqv? (proc port) #\?) + (eqv? (proc port) #\xFFFD) (decoding-error? port proc))) ((_ port (proc -> eof)) (eof-object? (proc port))) diff --git a/test-suite/tests/rdelim.test b/test-suite/tests/rdelim.test index de384c508..3aaa0b253 100644 --- a/test-suite/tests/rdelim.test +++ b/test-suite/tests/rdelim.test @@ -87,7 +87,7 @@ (let ((p (open-bytevector-input-port #vu8(65 255 66 67 68)))) (set-port-encoding! p "UTF-8") (set-port-conversion-strategy! p 'substitute) - (and (string=? (read-line p) "A?BCD") + (and (string=? (read-line p) "A\uFFFDBCD") (eof-object? (read-line p)))))) From e32dcf214eb140c81c269e17de477e6f1932ee62 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 16 May 2016 14:04:54 +0200 Subject: [PATCH 288/865] Test Scheme port implementation * module/ice-9/ports.scm: Add port-decode-char to internals export list. * test-suite/Makefile.am: * test-suite/tests/sports.test: Add new test. --- module/ice-9/ports.scm | 1 + test-suite/Makefile.am | 1 + test-suite/tests/sports.test | 51 ++++++++++++++++++++++++++++++++++++ 3 files changed, 53 insertions(+) create mode 100644 test-suite/tests/sports.test diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 34191a546..a7f237347 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -178,6 +178,7 @@ interpret its input and output." %port-encoding specialize-port-encoding! port-random-access? + port-decode-char port-read-buffering)) (define-syntax-rule (port-buffer-bytevector buf) (vector-ref buf 0)) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 41c5549cc..775a04f07 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -127,6 +127,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/session.test \ tests/signals.test \ tests/sort.test \ + tests/sports.test \ tests/srcprop.test \ tests/srfi-1.test \ tests/srfi-6.test \ diff --git a/test-suite/tests/sports.test b/test-suite/tests/sports.test new file mode 100644 index 000000000..89ec4569d --- /dev/null +++ b/test-suite/tests/sports.test @@ -0,0 +1,51 @@ +;;;; Scheme implementation of Guile ports -*- scheme -*- +;;;; +;;;; Copyright (C) 2016 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 License as +;;;; published by the Free Software Foundation, either version 3 of the +;;;; License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library. If not, see +;;;; . + +(define-module (test-suite test-ports) + #:use-module (ice-9 sports)) + +;; Include tests from ports.test. + +(define-syntax import-uses + (syntax-rules () + ((_) #t) + ((_ #:use-module mod . uses) + (begin (use-modules mod) (import-uses . uses))))) + +(define-syntax include-one + (syntax-rules (define-module) + ((_ (define-module mod . uses)) + (import-uses . uses)) + ((_ exp) exp))) + +(define-syntax include-tests + (lambda (x) + (syntax-case x () + ((include-tests file) + (call-with-input-file (in-vicinity (getenv "TEST_SUITE_DIR") + (syntax->datum #'file)) + (lambda (port) + #`(begin + . #,(let lp () + (let ((exp (read port))) + (if (eof-object? exp) + #'() + (let ((exp (datum->syntax #'include-tests exp))) + #`((include-one #,exp) . #,(lp))))))))))))) + +(include-tests "tests/ports.test") From 8b6f4df3f4e26bb4fe148507b481182fc14578a4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 18 May 2016 22:11:32 +0200 Subject: [PATCH 289/865] Fix sports.test * test-suite/tests/sports.test (include-tests): Fix encoding when reading ports.test. --- test-suite/tests/sports.test | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/sports.test b/test-suite/tests/sports.test index 89ec4569d..6eb422ef5 100644 --- a/test-suite/tests/sports.test +++ b/test-suite/tests/sports.test @@ -46,6 +46,7 @@ (if (eof-object? exp) #'() (let ((exp (datum->syntax #'include-tests exp))) - #`((include-one #,exp) . #,(lp))))))))))))) + #`((include-one #,exp) . #,(lp)))))))) + #:guess-encoding #t))))) (include-tests "tests/ports.test") From 534139e45852f5b59ef4a75c99d757c7456ce19c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 20 May 2016 14:51:51 +0200 Subject: [PATCH 290/865] Support for non-blocking I/O * doc/ref/api-io.texi (I/O Extensions): Document read_wait_fd / write_wait_fd members. (Non-Blocking I/O): New section. * libguile/fports.c (fport_read, fport_write): Return -1 if the operation would block. (fport_wait_fd, scm_make_fptob): Add read/write wait-fd implementation. * libguile/ports-internal.h (scm_t_port_type): Add read_wait_fd / write_wait_fd. * libguile/ports.c (default_read_wait_fd, default_write_wait_fd): New functions. (scm_make_port_type): Initialize default read/write wait fd impls. (trampoline_to_c_read, trampoline_to_scm_read) (trampoline_to_c_write, trampoline_to_scm_write): To Scheme, a return of #f indicates EWOULDBLOCk. (scm_set_port_read_wait_fd, scm_set_port_write_wait_fd): New functions. (port_read_wait_fd, port_write_wait_fd, scm_port_read_wait_fd) (scm_port_write_wait_fd, port_poll, scm_port_poll): New functions. (scm_i_read_bytes, scm_i_write_bytes): Poll if the read or write would block. * libguile/ports.h (scm_set_port_read_wait_fd) (scm_set_port_write_wait_fd): Add declarations. * module/ice-9/ports.scm: Shunt port-poll and port-{read,write}-wait-fd to the internals module. * module/ice-9/sports.scm (current-write-waiter): (current-read-waiter): Implement. * test-suite/tests/ports.test: Adapt non-blocking test to new behavior. * NEWS: Add entry. --- NEWS | 4 + doc/ref/api-io.texi | 87 ++++++++++++++++++ libguile/fports.c | 46 +++++++-- libguile/ports-internal.h | 3 + libguile/ports.c | 179 +++++++++++++++++++++++++++++++++--- libguile/ports.h | 4 + module/ice-9/ports.scm | 10 +- module/ice-9/sports.scm | 26 +++++- test-suite/tests/ports.test | 27 +++--- 9 files changed, 344 insertions(+), 42 deletions(-) diff --git a/NEWS b/NEWS index 3e64129e4..e887ec447 100644 --- a/NEWS +++ b/NEWS @@ -38,6 +38,10 @@ is equivalent to an unbuffered port. Ports may set their default buffer sizes, and some ports (for example soft ports) are unbuffered by default for historical reasons. +** Support for non-blocking I/O + +See "Non-Blocking I/O" in the manual, for more. + ** Removal of port locks As part of the 2.2 series, we introduced recursive locks on each port, diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 5b200977b..313204593 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -20,6 +20,7 @@ * Port Types:: Types of port and how to make them. * R6RS I/O Ports:: The R6RS port API. * I/O Extensions:: Implementing new port types in C. +* Non-Blocking I/O:: How Guile deals with EWOULDBLOCK. * BOM Handling:: Handling of Unicode byte order marks. @end menu @@ -2302,6 +2303,24 @@ It should write out bytes from the supplied bytevector @code{src}, starting at offset @code{start} and continuing for @code{count} bytes, and return the number of bytes that were written. +@item read_wait_fd +@itemx write_wait_fd +If a port's @code{read} or @code{write} function returns @code{(size_t) +-1}, that indicates that reading or writing would block. In that case +to preserve the illusion of a blocking read or write operation, Guile's +C port run-time will @code{poll} on the file descriptor returned by +either the port's @code{read_wait_fd} or @code{write_wait_fd} function. +Set using + +@deftypefun void scm_set_port_read_wait_fd (scm_t_port_type *type, int (*wait_fd) (SCM port)) +@deftypefunx void scm_set_port_write_wait_fd (scm_t_port_type *type, int (*wait_fd) (SCM port)) +@end deftypefun + +Only a port type which implements the @code{read_wait_fd} or +@code{write_wait_fd} port methods can usefully return @code{(size_t) -1} +from a read or write function. @xref{Non-Blocking I/O}, for more on +non-blocking I/O in Guile. + @item print Called when @code{write} is called on the port, to print a port description. For example, for a file port it may produce something @@ -2384,6 +2403,74 @@ operating system inform Guile about the appropriate buffer sizes for the particular file opened by the port. @end table +@node Non-Blocking I/O +@subsection Non-Blocking I/O + +Most ports in Guile are @dfn{blocking}: when you try to read a character +from a port, Guile will block on the read until a character is ready, or +end-of-stream is detected. Likewise whenever Guile goes to write +(possibly buffered) data to an output port, Guile will block until all +the data is written. + +Interacting with ports in blocking mode is very convenient: you can +write straightforward, sequential algorithms whose code flow reflects +the flow of data. However, blocking I/O has two main limitations. + +The first is that it's easy to get into a situation where code is +waiting on data. Time spent waiting on data when code could be doing +something else is wasteful and prevents your program from reaching its +peak throughput. If you implement a web server that sequentially +handles requests from clients, it's very easy for the server to end up +waiting on a client to finish its HTTP request, or waiting on it to +consume the response. The end result is that you are able to serve +fewer requests per second than you'd like to serve. + +The second limitation is related: a blocking parser over user-controlled +input is a denial-of-service vulnerability. Indeed the so-called ``slow +loris'' attack of the early 2010s was just that: an attack on common web +servers that drip-fed HTTP requests, one character at a time. All it +took was a handful of slow loris connections to occupy an entire web +server. + +In Guile we would like to preserve the ability to write straightforward +blocking networking processes of all kinds, but under the hood to allow +those processes to suspend their requests if they would block. + +To do this, the first piece is to allow Guile ports to declare +themselves as being nonblocking. This is currently supported only for +file ports, which also includes sockets, terminals, or any other port +that is backed by a file descriptor. To do that, we use an arcane UNIX +incantation: + +@example +(let ((flags (fcntl socket F_GETFL))) + (fcntl socket F_SETFL (logior O_NONBLOCK flags))) +@end example + +Now the file descriptor is open in non-blocking mode. If Guile tries to +read or write from this file descriptor in C, it will block by polling +on the socket's @code{read_wait_fd}, to preserve the illusion of a +blocking read or write. @xref{I/O Extensions} for more on that internal +interface. + +However if a user uses the new and experimental Scheme implementation of +ports in @code{(ice-9 sports)}, Guile instead calls the value of the +@code{current-read-waiter} or @code{current-write-waiter} parameters on +the port before re-trying the read or write. The default value of these +parameters does the same thing as the C port runtime: it blocks. +However it's possible to dynamically bind these parameters to handlers +that can suspend the current coroutine to a scheduler, to be later +re-animated once the port becomes readable or writable in the future. +In the mean-time the scheduler can run other code, for example servicing +other web requests. + +Guile does not currently include such a scheduler. Currently we want to +make sure that we're providing the right primitives that can be used to +build schedulers and other user-space concurrency patterns. In the +meantime, have a look at 8sync (@url{https://gnu.org/software/8sync}) +for a prototype of an asynchronous I/O and concurrency facility. + + @node BOM Handling @subsection Handling of Unicode byte order marks. @cindex BOM diff --git a/libguile/fports.c b/libguile/fports.c index 046a844e9..271f3a0a1 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -573,14 +573,24 @@ fport_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) static size_t fport_read (SCM port, SCM dst, size_t start, size_t count) { - long res; scm_t_fport *fp = SCM_FSTREAM (port); signed char *ptr = SCM_BYTEVECTOR_CONTENTS (dst) + start; + ssize_t ret; - SCM_SYSCALL (res = read (fp->fdes, ptr, count)); - if (res == -1) - scm_syserror ("fport_read"); - return res; + retry: + ret = read (fp->fdes, ptr, count); + if (ret < 0) + { + if (errno == EINTR) + { + SCM_ASYNC_TICK; + goto retry; + } + if (errno == EWOULDBLOCK || errno == EAGAIN) + return -1; + scm_syserror ("fport_read"); + } + return ret; } static size_t @@ -588,11 +598,23 @@ fport_write (SCM port, SCM src, size_t start, size_t count) { int fd = SCM_FPORT_FDES (port); signed char *ptr = SCM_BYTEVECTOR_CONTENTS (src) + start; + ssize_t ret; - if (full_write (fd, ptr, count) < count) - scm_syserror ("fport_write"); + retry: + ret = write (fd, ptr, count); + if (ret < 0) + { + if (errno == EINTR) + { + SCM_ASYNC_TICK; + goto retry; + } + if (errno == EWOULDBLOCK || errno == EAGAIN) + return -1; + scm_syserror ("fport_write"); + } - return count; + return ret; } static scm_t_off @@ -637,6 +659,12 @@ fport_random_access_p (SCM port) return SCM_FDES_RANDOM_P (SCM_FSTREAM (port)->fdes); } +static int +fport_wait_fd (SCM port) +{ + return SCM_FSTREAM (port)->fdes; +} + /* Query the OS to get the natural buffering for FPORT, if available. */ static void fport_get_natural_buffer_sizes (SCM port, size_t *read_size, size_t *write_size) @@ -660,6 +688,8 @@ scm_make_fptob () scm_set_port_close (ptob, fport_close); scm_set_port_seek (ptob, fport_seek); scm_set_port_truncate (ptob, fport_truncate); + scm_set_port_read_wait_fd (ptob, fport_wait_fd); + scm_set_port_write_wait_fd (ptob, fport_wait_fd); scm_set_port_input_waiting (ptob, fport_input_waiting); scm_set_port_random_access_p (ptob, fport_random_access_p); scm_set_port_get_natural_buffer_sizes (ptob, fport_get_natural_buffer_sizes); diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index 54ce3e4b0..38da49eb7 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -44,6 +44,9 @@ struct scm_t_port_type SCM scm_read; SCM scm_write; + int (*read_wait_fd) (SCM port); + int (*write_wait_fd) (SCM port); + scm_t_off (*seek) (SCM port, scm_t_off OFFSET, int WHENCE); void (*close) (SCM port); diff --git a/libguile/ports.c b/libguile/ports.c index c67bdf53b..ba3755507 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -33,6 +33,7 @@ #include /* for chsize on mingw */ #include #include +#include #include #include #include @@ -126,6 +127,18 @@ default_random_access_p (SCM port) return SCM_PORT_TYPE (port)->seek != NULL; } +static int +default_read_wait_fd (SCM port) +{ + scm_misc_error ("read_wait_fd", "unimplemented", SCM_EOL); +} + +static int +default_write_wait_fd (SCM port) +{ + scm_misc_error ("write_wait_fd", "unimplemented", SCM_EOL); +} + scm_t_port_type * scm_make_port_type (char *name, size_t (*read) (SCM port, SCM dst, size_t start, @@ -144,6 +157,8 @@ scm_make_port_type (char *name, desc->c_write = write; desc->scm_read = read ? trampoline_to_c_read_subr : SCM_BOOL_F; desc->scm_write = write ? trampoline_to_c_write_subr : SCM_BOOL_F; + desc->read_wait_fd = default_read_wait_fd; + desc->write_wait_fd = default_write_wait_fd; desc->random_access_p = default_random_access_p; scm_make_port_classes (desc); @@ -154,7 +169,7 @@ static SCM trampoline_to_c_read (SCM port, SCM dst, SCM start, SCM count) #define FUNC_NAME "port-read" { - size_t c_start, c_count; + size_t c_start, c_count, ret; SCM_VALIDATE_OPPORT (1, port); c_start = scm_to_size_t (start); @@ -162,24 +177,25 @@ trampoline_to_c_read (SCM port, SCM dst, SCM start, SCM count) SCM_ASSERT_RANGE (2, start, c_start <= c_count); SCM_ASSERT_RANGE (3, count, c_start+c_count <= scm_c_bytevector_length (dst)); - return scm_from_size_t - (SCM_PORT_TYPE (port)->c_read (port, dst, c_start, c_count)); + ret = SCM_PORT_TYPE (port)->c_read (port, dst, c_start, c_count); + + return ret == (size_t) -1 ? SCM_BOOL_F : scm_from_size_t (ret); } #undef FUNC_NAME static size_t trampoline_to_scm_read (SCM port, SCM dst, size_t start, size_t count) { - return scm_to_size_t - (scm_call_4 (SCM_PORT_TYPE (port)->scm_read, port, dst, - scm_from_size_t (start), scm_from_size_t (count))); + SCM ret = scm_call_4 (SCM_PORT_TYPE (port)->scm_read, port, dst, + scm_from_size_t (start), scm_from_size_t (count)); + return scm_is_true (ret) ? scm_to_size_t (ret) : (size_t) -1; } static SCM trampoline_to_c_write (SCM port, SCM src, SCM start, SCM count) #define FUNC_NAME "port-write" { - size_t c_start, c_count; + size_t c_start, c_count, ret; SCM_VALIDATE_OPPORT (1, port); c_start = scm_to_size_t (start); @@ -187,17 +203,18 @@ trampoline_to_c_write (SCM port, SCM src, SCM start, SCM count) SCM_ASSERT_RANGE (2, start, c_start <= c_count); SCM_ASSERT_RANGE (3, count, c_start+c_count <= scm_c_bytevector_length (src)); - return scm_from_size_t - (SCM_PORT_TYPE (port)->c_write (port, src, c_start, c_count)); + ret = SCM_PORT_TYPE (port)->c_write (port, src, c_start, c_count); + + return ret == (size_t) -1 ? SCM_BOOL_F : scm_from_size_t (ret); } #undef FUNC_NAME static size_t trampoline_to_scm_write (SCM port, SCM src, size_t start, size_t count) { - return scm_to_size_t - (scm_call_4 (SCM_PORT_TYPE (port)->scm_write, port, src, - scm_from_size_t (start), scm_from_size_t (count))); + SCM ret = scm_call_4 (SCM_PORT_TYPE (port)->scm_write, port, src, + scm_from_size_t (start), scm_from_size_t (count)); + return scm_is_true (ret) ? scm_to_size_t (ret) : (size_t) -1; } void @@ -214,6 +231,18 @@ scm_set_port_scm_write (scm_t_port_type *ptob, SCM write) ptob->c_write = trampoline_to_scm_write; } +void +scm_set_port_read_wait_fd (scm_t_port_type *ptob, int (*get_fd) (SCM)) +{ + ptob->read_wait_fd = get_fd; +} + +void +scm_set_port_write_wait_fd (scm_t_port_type *ptob, int (*get_fd) (SCM)) +{ + ptob->write_wait_fd = get_fd; +} + void scm_set_port_print (scm_t_port_type *ptob, int (*print) (SCM exp, SCM port, scm_print_state *pstate)) @@ -1230,6 +1259,116 @@ SCM_DEFINE (scm_set_port_conversion_strategy_x, "set-port-conversion-strategy!", #undef FUNC_NAME + + +/* Non-blocking I/O. */ + +static int +port_read_wait_fd (SCM port) +{ + scm_t_port_type *ptob = SCM_PORT_TYPE (port); + return ptob->read_wait_fd (port); +} + +static int +port_write_wait_fd (SCM port) +{ + scm_t_port_type *ptob = SCM_PORT_TYPE (port); + return ptob->write_wait_fd (port); +} + +SCM_INTERNAL SCM scm_port_read_wait_fd (SCM); +SCM_DEFINE (scm_port_read_wait_fd, "port-read-wait-fd", 1, 0, 0, + (SCM port), "") +#define FUNC_NAME s_scm_port_read_wait_fd +{ + int fd; + + port = SCM_COERCE_OUTPORT (port); + SCM_VALIDATE_OPINPORT (1, port); + + fd = port_read_wait_fd (port); + return fd < 0 ? SCM_BOOL_F : scm_from_int (fd); +} +#undef FUNC_NAME + +SCM_INTERNAL SCM scm_port_write_wait_fd (SCM); +SCM_DEFINE (scm_port_write_wait_fd, "port-write-wait-fd", 1, 0, 0, + (SCM port), "") +#define FUNC_NAME s_scm_port_write_wait_fd +{ + int fd; + + port = SCM_COERCE_OUTPORT (port); + SCM_VALIDATE_OPOUTPORT (1, port); + + fd = port_write_wait_fd (port); + return fd < 0 ? SCM_BOOL_F : scm_from_int (fd); +} +#undef FUNC_NAME + +static int +port_poll (SCM port, short events, int timeout) +#define FUNC_NAME "port-poll" +{ + struct pollfd pollfd[2]; + int nfds = 0, rv = 0; + + if (events & POLLIN) + { + pollfd[nfds].fd = port_read_wait_fd (port); + pollfd[nfds].events = events & (POLLIN | POLLPRI); + pollfd[nfds].revents = 0; + nfds++; + } + if (events & POLLOUT) + { + pollfd[nfds].fd = port_write_wait_fd (port); + pollfd[nfds].events = events & (POLLOUT | POLLPRI); + pollfd[nfds].revents = 0; + nfds++; + } + + if (nfds == 2 && pollfd[0].fd == pollfd[1].fd) + { + pollfd[0].events |= pollfd[1].events; + nfds--; + } + + SCM_SYSCALL (rv = poll (pollfd, nfds, timeout)); + if (rv < 0) + SCM_SYSERROR; + + return rv; +} +#undef FUNC_NAME + +SCM_INTERNAL SCM scm_port_poll (SCM, SCM, SCM); +SCM_DEFINE (scm_port_poll, "port-poll", 2, 1, 0, + (SCM port, SCM events, SCM timeout), + "") +#define FUNC_NAME s_scm_port_poll +{ + short c_events = 0; + int c_timeout; + + port = SCM_COERCE_OUTPORT (port); + SCM_VALIDATE_PORT (1, port); + SCM_VALIDATE_STRING (2, events); + c_timeout = SCM_UNBNDP (timeout) ? -1 : SCM_NUM2INT (3, timeout); + + if (scm_i_string_contains_char (events, 'r')) + c_events |= POLLIN; + if (scm_i_string_contains_char (events, '!')) + c_events |= POLLPRI; + if (scm_i_string_contains_char (events, 'w')) + c_events |= POLLIN; + + return scm_from_int (port_poll (port, c_events, c_timeout)); +} +#undef FUNC_NAME + + /* Input. */ @@ -1330,8 +1469,15 @@ scm_i_read_bytes (SCM port, SCM dst, size_t start, size_t count) assert (count <= SCM_BYTEVECTOR_LENGTH (dst)); assert (start + count <= SCM_BYTEVECTOR_LENGTH (dst)); + retry: filled = ptob->c_read (port, dst, start, count); + if (filled == (size_t) -1) + { + port_poll (port, POLLIN, -1); + goto retry; + } + assert (filled <= count); return filled; @@ -2508,7 +2654,14 @@ scm_i_write_bytes (SCM port, SCM src, size_t start, size_t count) assert (start + count <= SCM_BYTEVECTOR_LENGTH (src)); do - written += ptob->c_write (port, src, start + written, count - written); + { + size_t ret = ptob->c_write (port, src, start + written, count - written); + + if (ret == (size_t) -1) + port_poll (port, POLLOUT, -1); + else + written += ret; + } while (written < count); assert (written == count); diff --git a/libguile/ports.h b/libguile/ports.h index 43cd7458d..2905f68db 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -90,6 +90,10 @@ SCM_API scm_t_port_type *scm_make_port_type size_t (*write) (SCM port, SCM src, size_t start, size_t count)); SCM_API void scm_set_port_scm_read (scm_t_port_type *ptob, SCM read); SCM_API void scm_set_port_scm_write (scm_t_port_type *ptob, SCM write); +SCM_API void scm_set_port_read_wait_fd (scm_t_port_type *ptob, + int (*wait_fd) (SCM port)); +SCM_API void scm_set_port_write_wait_fd (scm_t_port_type *ptob, + int (*wait_fd) (SCM port)); SCM_API void scm_set_port_print (scm_t_port_type *ptob, int (*print) (SCM exp, SCM port, diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index a7f237347..4330ebedf 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -179,7 +179,10 @@ interpret its input and output." specialize-port-encoding! port-random-access? port-decode-char - port-read-buffering)) + port-read-buffering + port-poll + port-read-wait-fd + port-write-wait-fd)) (define-syntax-rule (port-buffer-bytevector buf) (vector-ref buf 0)) (define-syntax-rule (port-buffer-cur buf) (vector-ref buf 1)) @@ -209,7 +212,10 @@ interpret its input and output." specialize-port-encoding! port-decode-char port-random-access? - port-read-buffering) + port-read-buffering + port-poll + port-read-wait-fd + port-write-wait-fd) ;; And we're back. (define-module (ice-9 ports)) diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm index 6fd7ddd31..c178b7310 100644 --- a/module/ice-9/sports.scm +++ b/module/ice-9/sports.scm @@ -54,7 +54,9 @@ #:replace (peek-char read-char) #:export (lookahead-u8 - get-u8)) + get-u8 + current-read-waiter + current-write-waiter)) (define (write-bytes port src start count) (let ((written ((port-write port) port src start count))) @@ -77,11 +79,25 @@ (set-port-buffer-end! buf 0) (write-bytes port (port-buffer-bytevector buf) cur (- end cur))))) +(define (default-read-waiter port) (port-poll port "r")) +(define (default-write-waiter port) (port-poll port "w")) + +(define current-read-waiter (make-parameter default-read-waiter)) +(define current-write-waiter (make-parameter default-write-waiter)) + +(define (wait-for-readable port) ((current-read-waiter) port)) +(define (wait-for-writable port) ((current-write-waiter) port)) + (define (read-bytes port dst start count) - (let ((read ((port-read port) port dst start count))) - (unless (<= 0 read count) - (error "bad return from port read function" read)) - read)) + (cond + (((port-read port) port dst start count) + => (lambda (read) + (unless (<= 0 read count) + (error "bad return from port read function" read)) + read)) + (else + (wait-for-readable port) + (read-bytes port dst start count)))) (define utf8-bom #vu8(#xEF #xBB #xBF)) (define utf16be-bom #vu8(#xFE #xFF)) diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index 029dd2dd9..dfa430e5a 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -23,6 +23,7 @@ #:use-module (test-suite guile-test) #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) + #:use-module (ice-9 threads) #:use-module (rnrs bytevectors) #:use-module ((ice-9 binary-ports) #:select (open-bytevector-input-port open-bytevector-output-port @@ -601,20 +602,18 @@ (pass-if "unread residue" (string=? (read-line) "moon")))) -;;; non-blocking mode on a port. create a pipe and set O_NONBLOCK on -;;; the reading end. try to read a byte: should get EAGAIN or -;;; EWOULDBLOCK error. -(let* ((p (pipe)) - (r (car p))) - (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK)) - (pass-if "non-blocking-I/O" - (catch 'system-error - (lambda () (read-char r) #f) - (lambda (key . args) - (and (eq? key 'system-error) - (let ((errno (car (list-ref args 3)))) - (or (= errno EAGAIN) - (= errno EWOULDBLOCK)))))))) +(when (provided? 'threads) + (let* ((p (pipe)) + (r (car p)) + (w (cdr p))) + (fcntl r F_SETFL (logior (fcntl r F_GETFL) O_NONBLOCK)) + (let ((thread (call-with-new-thread + (lambda () + (usleep (* 250 1000)) + (write-char #\a w) + (force-output w))))) + (pass-if-equal "non-blocking-I/O" #\a (read-char r)) + (join-thread thread)))) ;;;; Pipe (popen) ports. From 1852633a9bf449e4a2399de969db70a0d095a5ea Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 20 May 2016 23:14:56 +0200 Subject: [PATCH 291/865] Add install-sports!, uninstall-sports! functions * module/ice-9/sports.scm (install-sports!, uninstall-sports!): New functions. --- module/ice-9/sports.scm | 37 ++++++++++++++++++++++++++++++++++++- 1 file changed, 36 insertions(+), 1 deletion(-) diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm index c178b7310..91e51e37a 100644 --- a/module/ice-9/sports.scm +++ b/module/ice-9/sports.scm @@ -51,12 +51,15 @@ (define-module (ice-9 sports) #:use-module (rnrs bytevectors) #:use-module (ice-9 ports internal) + #:use-module (ice-9 match) #:replace (peek-char read-char) #:export (lookahead-u8 get-u8 current-read-waiter - current-write-waiter)) + current-write-waiter + install-sports! + uninstall-sports!)) (define (write-bytes port src start count) (let ((written ((port-write port) port src start count))) @@ -426,3 +429,35 @@ (else (slow-path))))) (peek-bytes port 1 fast-path (lambda (buf bv cur buffered) (slow-path)))) + +(define saved-port-bindings #f) +(define port-bindings + '(((guile) read-char peek-char) + ((ice-9 binary-ports) get-u8 lookahead-u8))) +(define (install-sports!) + (unless saved-port-bindings + (set! saved-port-bindings (make-hash-table)) + (for-each + (match-lambda + ((mod . syms) + (let ((mod (resolve-module mod))) + (for-each (lambda (sym) + (hashq-set! saved-port-bindings sym + (module-ref mod sym)) + (module-set! mod sym + (module-ref (current-module) sym))) + syms)))) + port-bindings))) + +(define (uninstall-sports!) + (when saved-port-bindings + (for-each + (match-lambda + ((mod . syms) + (let ((mod (resolve-module mod))) + (for-each (lambda (sym) + (let ((saved (hashq-ref saved-port-bindings sym))) + (module-set! mod sym saved))) + syms)))) + port-bindings) + (set! saved-port-bindings #f))) From fd5e69d3c153c5a023695ecd1452cad865cb3776 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 22 May 2016 13:42:00 +0200 Subject: [PATCH 292/865] Sports refactor * module/ice-9/sports.scm (port-advance-position!): Factor out to a helper. (read-char): Use port-advance-position!. --- module/ice-9/sports.scm | 24 +++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm index 91e51e37a..3b55e63dd 100644 --- a/module/ice-9/sports.scm +++ b/module/ice-9/sports.scm @@ -384,10 +384,16 @@ (peek-bytes port 1 fast-path (lambda (buf bv cur buffered) (slow-path)))) -(define* (read-char #:optional (port (current-input-port))) - (define (update-position! char) +(define-inlinable (port-advance-position! port char) + ;; FIXME: this cond is a speed hack; really we should just compile + ;; `case' better. + (cond + ;; FIXME: char>? et al should compile well. + ((<= (char->integer #\space) (char->integer char)) + (set-port-column! port (1+ (port-column port)))) + (else (case char - ((#\alarm) #t) ; No change. + ((#\alarm) #t) ; No change. ((#\backspace) (let ((col (port-column port))) (when (> col 0) @@ -401,7 +407,11 @@ (let ((col (port-column port))) (set-port-column! port (- (+ col 8) (remainder col 8))))) (else - (set-port-column! port (1+ (port-column port))))) + (set-port-column! port (1+ (port-column port)))))))) + +(define* (read-char #:optional (port (current-input-port))) + (define (finish char) + (port-advance-position! port char) char) (define (slow-path) (call-with-values (lambda () (peek-char-and-len port)) @@ -412,7 +422,7 @@ (begin (set-port-buffer-has-eof?! buf #f) char) - (update-position! char)))))) + (finish char)))))) (define (fast-path buf bv cur buffered) (let ((u8 (bytevector-u8-ref bv cur)) (enc (%port-encoding port))) @@ -421,11 +431,11 @@ (decode-utf8 bv cur buffered u8 (lambda (char len) (set-port-buffer-cur! buf (+ cur len)) - (update-position! char)) + (finish char)) slow-path)) ((ISO-8859-1) (set-port-buffer-cur! buf (+ cur 1)) - (update-position! (integer->char u8))) + (finish (integer->char u8))) (else (slow-path))))) (peek-bytes port 1 fast-path (lambda (buf bv cur buffered) (slow-path)))) From a4b06357f644c41188d4e3c555ff60c71631493f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 22 May 2016 13:42:48 +0200 Subject: [PATCH 293/865] Implementation of read-delimited in Scheme * module/ice-9/sports.scm (port-fold-chars/iso-8859-1): (port-fold-chars, read-delimited, read-line, %read-line): Initial implementation of read-delimited. --- module/ice-9/sports.scm | 81 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 81 insertions(+) diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm index 3b55e63dd..265b70557 100644 --- a/module/ice-9/sports.scm +++ b/module/ice-9/sports.scm @@ -440,6 +440,87 @@ (peek-bytes port 1 fast-path (lambda (buf bv cur buffered) (slow-path)))) +(define-inlinable (port-fold-chars/iso-8859-1 port proc seed) + (let fold-buffer ((buf (port-read-buffer port)) + (seed seed)) + (let ((bv (port-buffer-bytevector buf)) + (end (port-buffer-end buf))) + (let fold-chars ((cur (port-buffer-cur buf)) + (seed seed)) + (cond + ((= end cur) + (call-with-values (lambda () (fill-input port)) + (lambda (buf buffered) + (if (zero? buffered) + (call-with-values (lambda () (proc the-eof-object seed)) + (lambda (seed done?) + (if done? seed (fold-buffer buf seed)))) + (fold-buffer buf seed))))) + (else + (let ((ch (integer->char (bytevector-u8-ref bv cur))) + (cur (1+ cur))) + (set-port-buffer-cur! buf cur) + (port-advance-position! port ch) + (call-with-values (lambda () (proc ch seed)) + (lambda (seed done?) + (if done? seed (fold-chars cur seed))))))))))) + +(define-inlinable (port-fold-chars port proc seed) + (case (%port-encoding port) + ((ISO-8859-1) (port-fold-chars/iso-8859-1 port proc seed)) + (else + (let lp ((seed seed)) + (let ((ch (read-char port))) + (call-with-values (lambda () (proc ch seed)) + (lambda (seed done?) + (if done? seed (lp seed))))))))) + +(define* (read-delimited delims #:optional (port (current-input-port)) + (handle-delim 'trim)) + ;; Currently this function conses characters into a list, then uses + ;; reverse-list->string. It wastes 2 words per character but it still + ;; seems to be the fastest thing at the moment. + (define (finish delim chars) + (define (->string chars) + (if (and (null? chars) (not (char? delim))) + the-eof-object + (reverse-list->string chars))) + (case handle-delim + ((trim) (->string chars)) + ((split) (cons (->string chars) delim)) + ((concat) + (->string (if (char? delim) (cons delim chars) chars))) + ((peek) + (when (char? delim) (unread-char delim port)) + (->string chars)) + (else + (error "unexpected handle-delim value: " handle-delim)))) + (define-syntax-rule (make-folder delimiter?) + (lambda (char chars) + (if (or (not (char? char)) (delimiter? char)) + (values (finish char chars) #t) + (values (cons char chars) #f)))) + (define-syntax-rule (specialized-fold delimiter?) + (port-fold-chars port (make-folder delimiter?) '())) + (case (string-length delims) + ((0) (specialized-fold (lambda (char) #f))) + ((1) (let ((delim (string-ref delims 0))) + (specialized-fold (lambda (char) (eqv? char delim))))) + (else => (lambda (ndelims) + (specialized-fold + (lambda (char) + (let lp ((i 0)) + (and (< i ndelims) + (or (eqv? char (string-ref delims i)) + (lp (1+ i))))))))))) + +(define* (read-line #:optional (port (current-input-port)) + (handle-delim 'trim)) + (read-delimited "\n" port handle-delim)) + +(define* (%read-line port) + (read-line port 'split)) + (define saved-port-bindings #f) (define port-bindings '(((guile) read-char peek-char) From fd17cf9f72bcfc1832775c848e678e695d05dbd8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 22 May 2016 18:16:19 +0200 Subject: [PATCH 294/865] Speed up port position access from Scheme * libguile/ports-internal.h (scm_port_buffer_position): (scm_port_position_line, scm_port_position_set_line): (scm_port_position_column, scm_port_position_set_column): New helpers. (scm_t_port): Ports now hold position as a pair, so that Scheme can access it easily. (SCM_LINUM, SCM_COL, SCM_INCLINE, SCM_ZEROCOL, SCM_INCCOL) (SCM_DECCOL, SCM_TABCOL): Remove. * libguile/ports.c (make_port_buffer): Rename from scm_c_make_port_buffer, make static, and take port as an argument so we can initialize the position field. (initialize_port_buffers): Adapt make_port_buffer change. (scm_c_make_port_with_encoding): Initialize position. (update_port_position): Rename from update_port_lf, and operate on port position objects. (scm_ungetc): Operate on port position objects. (scm_setvbuf, scm_expand_port_read_buffer_x): Adapt to make_port_buffer change. (scm_lfwrite): Adapt to call update_port_position. (scm_port_line, scm_set_port_line_x, scm_port_column) (scm_set_port_column_x): Adapt to use port positions. * libguile/ports.h (scm_c_make_port_buffer): Remove internal decl. * libguile/read.c: Adapt to use scm_port_line / scm_port_column instead of SCM_LINUM et al. * module/ice-9/ports.scm (port-buffer-position, port-position-line) (port-position-column, set-port-position-line!) (set-port-position-column!): New accessors for the internals module. * module/ice-9/sports.scm (advance-port-position!): Rename from port-advance-position! and use the new accessors. (read-char, port-fold-chars/iso-8859-1): Adapt to use advance-port-position!. --- libguile/ports-internal.h | 45 ++++++++++++++++++------ libguile/ports.c | 73 +++++++++++++++++++++++++-------------- libguile/ports.h | 3 -- libguile/read.c | 58 +++++++++++++++++-------------- module/ice-9/ports.scm | 15 ++++++++ module/ice-9/sports.scm | 32 ++++++++--------- 6 files changed, 147 insertions(+), 79 deletions(-) diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index 38da49eb7..0bfda4f35 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -94,6 +94,7 @@ enum scm_port_buffer_field { SCM_PORT_BUFFER_FIELD_CUR, SCM_PORT_BUFFER_FIELD_END, SCM_PORT_BUFFER_FIELD_HAS_EOF_P, + SCM_PORT_BUFFER_FIELD_POSITION, SCM_PORT_BUFFER_FIELD_COUNT }; @@ -152,6 +153,39 @@ scm_port_buffer_set_has_eof_p (SCM buf, SCM has_eof_p) has_eof_p); } +/* The port position object is a pair that is referenced by the port. + To make things easier for Scheme port code, it is also referenced by + port buffers. */ +static inline SCM +scm_port_buffer_position (SCM buf) +{ + return SCM_SIMPLE_VECTOR_REF (buf, SCM_PORT_BUFFER_FIELD_POSITION); +} + +static inline SCM +scm_port_position_line (SCM position) +{ + return scm_car (position); +} + +static inline void +scm_port_position_set_line (SCM position, SCM line) +{ + scm_set_car_x (position, line); +} + +static inline SCM +scm_port_position_column (SCM position) +{ + return scm_cdr (position); +} + +static inline void +scm_port_position_set_column (SCM position, SCM column) +{ + scm_set_cdr_x (position, column); +} + static inline size_t scm_port_buffer_size (SCM buf) { @@ -290,8 +324,7 @@ struct scm_t_port { /* Source location information. */ SCM file_name; - long line_number; - int column_number; + SCM position; /* Port buffers. */ SCM read_buf; @@ -325,14 +358,6 @@ struct scm_t_port #define SCM_FILENAME(x) (SCM_PORT (x)->file_name) #define SCM_SET_FILENAME(x, n) (SCM_PORT (x)->file_name = (n)) -#define SCM_LINUM(x) (SCM_PORT (x)->line_number) -#define SCM_COL(x) (SCM_PORT (x)->column_number) - -#define SCM_INCLINE(port) do {SCM_LINUM (port) += 1; SCM_COL (port) = 0;} while (0) -#define SCM_ZEROCOL(port) do {SCM_COL (port) = 0;} while (0) -#define SCM_INCCOL(port) do {SCM_COL (port) += 1;} while (0) -#define SCM_DECCOL(port) do {if (SCM_COL (port) > 0) SCM_COL (port) -= 1;} while (0) -#define SCM_TABCOL(port) do {SCM_COL (port) += 8 - SCM_COL (port) % 8;} while (0) SCM_INTERNAL scm_t_iconv_descriptors * scm_i_port_iconv_descriptors (SCM port); diff --git a/libguile/ports.c b/libguile/ports.c index ba3755507..445ccc076 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -494,13 +494,15 @@ scm_i_dynwind_current_load_port (SCM port) /* Port buffers. */ -SCM -scm_c_make_port_buffer (size_t size) +static SCM +make_port_buffer (SCM port, size_t size) { SCM ret = scm_c_make_vector (SCM_PORT_BUFFER_FIELD_COUNT, SCM_INUM0); SCM_SIMPLE_VECTOR_SET (ret, SCM_PORT_BUFFER_FIELD_BYTEVECTOR, scm_c_make_bytevector (size)); + SCM_SIMPLE_VECTOR_SET (ret, SCM_PORT_BUFFER_FIELD_POSITION, + SCM_PORT (port)->position); scm_port_buffer_set_has_eof_p (ret, SCM_BOOL_F); return ret; @@ -649,8 +651,8 @@ initialize_port_buffers (SCM port) write_buf_size = 1; pt->read_buffering = read_buf_size; - pt->read_buf = scm_c_make_port_buffer (read_buf_size); - pt->write_buf = scm_c_make_port_buffer (write_buf_size); + pt->read_buf = make_port_buffer (port, read_buf_size); + pt->write_buf = make_port_buffer (port, write_buf_size); } SCM @@ -672,6 +674,7 @@ scm_c_make_port_with_encoding (scm_t_port_type *ptob, unsigned long mode_bits, pt->conversion_strategy = conversion_strategy; pt->file_name = SCM_BOOL_F; pt->iconv_descriptors = NULL; + pt->position = scm_cons (SCM_INUM0, SCM_INUM0); pt->at_stream_start_for_bom_read = 1; pt->at_stream_start_for_bom_write = 1; @@ -1598,27 +1601,34 @@ scm_c_read (SCM port, void *buffer, size_t size) /* Update the line and column number of PORT after consumption of C. */ static inline void -update_port_lf (scm_t_wchar c, SCM port) +update_port_position (SCM port, scm_t_wchar c) { + SCM position = SCM_PORT (port)->position; + long line = scm_to_long (scm_port_position_line (position)); + int column = scm_to_int (scm_port_position_column (position)); + switch (c) { case '\a': case EOF: break; case '\b': - SCM_DECCOL (port); + if (column > 0) + scm_port_position_set_column (position, scm_from_int (column - 1)); break; case '\n': - SCM_INCLINE (port); + scm_port_position_set_line (position, scm_from_long (line + 1)); + scm_port_position_set_column (position, SCM_INUM0); break; case '\r': - SCM_ZEROCOL (port); + scm_port_position_set_column (position, SCM_INUM0); break; case '\t': - SCM_TABCOL (port); + scm_port_position_set_column (position, + scm_from_int (column + 8 - column % 8)); break; default: - SCM_INCCOL (port); + scm_port_position_set_column (position, scm_from_int (column + 1)); break; } } @@ -1898,7 +1908,7 @@ scm_getc (SCM port) scm_port_buffer_did_take (SCM_PORT (port)->read_buf, len); if (codepoint == EOF) scm_i_clear_pending_eof (port); - update_port_lf (codepoint, port); + update_port_position (port, codepoint); return codepoint; } @@ -2031,9 +2041,18 @@ scm_ungetc (scm_t_wchar c, SCM port) if (SCM_UNLIKELY (result != result_buf)) free (result); - if (c == '\n') - SCM_LINUM (port) -= 1; - SCM_DECCOL (port); + { + long line; + int column; + + line = scm_to_long (scm_port_position_line (pt->position)); + column = scm_to_int (scm_port_position_column (pt->position)); + + if (c == '\n') + scm_port_position_set_line (pt->position, scm_from_long (line - 1)); + if (column > 0) + scm_port_position_set_column (pt->position, scm_from_int (column - 1)); + } } #undef FUNC_NAME @@ -2216,8 +2235,8 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, SCM_SET_CELL_WORD_0 (port, tag_word); pt->read_buffering = read_buf_size; - pt->read_buf = scm_c_make_port_buffer (read_buf_size); - pt->write_buf = scm_c_make_port_buffer (write_buf_size); + pt->read_buf = make_port_buffer (port, read_buf_size); + pt->write_buf = make_port_buffer (port, write_buf_size); if (saved_read_buf) scm_unget_bytes (scm_port_buffer_take_pointer (saved_read_buf), @@ -2563,7 +2582,7 @@ SCM_DEFINE (scm_expand_port_read_buffer_x, "expand-port-read-buffer!", 2, 1, 0, if (SCM_UNBNDP (putback_p)) putback_p = SCM_BOOL_F; - new_buf = scm_c_make_port_buffer (c_size); + new_buf = make_port_buffer (port, c_size); scm_port_buffer_set_has_eof_p (new_buf, scm_port_buffer_has_eof_p (pt->read_buf)); if (scm_is_true (putback_p)) @@ -2780,7 +2799,7 @@ scm_c_write (SCM port, const void *ptr, size_t size) void scm_lfwrite (const char *ptr, size_t size, SCM port) { - int saved_line; + SCM position, saved_line; if (size == 0) return; @@ -2789,12 +2808,14 @@ scm_lfwrite (const char *ptr, size_t size, SCM port) scm_c_write (port, ptr, size); - saved_line = SCM_LINUM (port); + position = SCM_PORT (port)->position; + saved_line = scm_port_position_line (position); for (; size; ptr++, size--) - update_port_lf ((scm_t_wchar) (unsigned char) *ptr, port); + update_port_position (port, (scm_t_wchar) (unsigned char) *ptr); /* Handle line buffering. */ - if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && saved_line != SCM_LINUM (port)) + if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && + !scm_is_eq (saved_line, scm_port_position_line (position))) scm_flush (port); } @@ -3046,7 +3067,7 @@ SCM_DEFINE (scm_port_line, "port-line", 1, 0, 0, { port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); - return scm_from_long (SCM_LINUM (port)); + return scm_port_position_line (SCM_PORT (port)->position); } #undef FUNC_NAME @@ -3058,7 +3079,8 @@ SCM_DEFINE (scm_set_port_line_x, "set-port-line!", 2, 0, 0, { port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); - SCM_PORT (port)->line_number = scm_to_long (line); + scm_to_long (line); + scm_port_position_set_line (SCM_PORT (port)->position, line); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -3077,7 +3099,7 @@ SCM_DEFINE (scm_port_column, "port-column", 1, 0, 0, { port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); - return scm_from_int (SCM_COL (port)); + return scm_port_position_column (SCM_PORT (port)->position); } #undef FUNC_NAME @@ -3089,7 +3111,8 @@ SCM_DEFINE (scm_set_port_column_x, "set-port-column!", 2, 0, 0, { port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPENPORT (1, port); - SCM_PORT (port)->column_number = scm_to_int (column); + scm_to_int (column); + scm_port_position_set_column (SCM_PORT (port)->position, column); return SCM_UNSPECIFIED; } #undef FUNC_NAME diff --git a/libguile/ports.h b/libguile/ports.h index 2905f68db..2ebcf0632 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -131,9 +131,6 @@ SCM_API void scm_dynwind_current_output_port (SCM port); SCM_API void scm_dynwind_current_error_port (SCM port); SCM_INTERNAL void scm_i_dynwind_current_load_port (SCM port); -/* Port buffers. */ -SCM_INTERNAL SCM scm_c_make_port_buffer (size_t size); - /* Mode bits. */ SCM_INTERNAL long scm_i_mode_bits (SCM modes); SCM_API long scm_mode_bits (char *modes); diff --git a/libguile/read.c b/libguile/read.c index 3d2a7fde9..afad5975a 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -149,8 +149,8 @@ scm_i_input_error (char const *function, scm_simple_format (string_port, scm_from_locale_string ("~A:~S:~S: ~A"), scm_list_4 (fn, - scm_from_long (SCM_LINUM (port) + 1), - scm_from_int (SCM_COL (port) + 1), + scm_sum (scm_port_line (port), SCM_INUM1), + scm_sum (scm_port_column (port), SCM_INUM1), scm_from_locale_string (message))); string = scm_get_output_string (string_port); @@ -434,8 +434,8 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) : ')')); /* Need to capture line and column numbers here. */ - long line = SCM_LINUM (port); - int column = SCM_COL (port) - 1; + long line = scm_to_long (scm_port_line (port)); + int column = scm_to_int (scm_port_column (port)) - 1; c = flush_ws (port, opts, FUNC_NAME); if (terminating_char == c) @@ -612,8 +612,8 @@ scm_read_string_like_syntax (int chr, SCM port, scm_t_read_opts *opts) scm_t_wchar c, c_str[READER_STRING_BUFFER_SIZE]; /* Need to capture line and column numbers here. */ - long line = SCM_LINUM (port); - int column = SCM_COL (port) - 1; + long line = scm_to_long (scm_port_line (port)); + int column = scm_to_int (scm_port_column (port)) - 1; while (chr != (c = scm_getc (port))) { @@ -739,8 +739,8 @@ scm_read_number (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) size_t bytes_read; /* Need to capture line and column numbers here. */ - long line = SCM_LINUM (port); - int column = SCM_COL (port) - 1; + long line = scm_to_long (scm_port_line (port)); + int column = scm_to_int (scm_port_column (port)) - 1; scm_ungetc (chr, port); buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer, @@ -759,7 +759,9 @@ scm_read_number (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) else if (SCM_NIMP (result)) result = maybe_annotate_source (result, port, opts, line, column); - SCM_COL (port) += scm_i_string_length (str); + scm_set_port_column_x (port, + scm_sum (scm_port_column (port), + scm_string_length (str))); return result; } @@ -796,7 +798,9 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) result = scm_string_to_symbol (str); } - SCM_COL (port) += scm_i_string_length (str); + scm_set_port_column_x (port, + scm_sum (scm_port_column (port), + scm_string_length (str))); return result; } @@ -845,7 +849,9 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) result = scm_string_to_number (str, scm_from_uint (radix)); - SCM_COL (port) += scm_i_string_length (str); + scm_set_port_column_x (port, + scm_sum (scm_port_column (port), + scm_string_length (str))); if (scm_is_true (result)) return result; @@ -860,8 +866,8 @@ static SCM scm_read_quote (int chr, SCM port, scm_t_read_opts *opts) { SCM p; - long line = SCM_LINUM (port); - int column = SCM_COL (port) - 1; + long line = scm_to_long (scm_port_line (port)); + int column = scm_to_int (scm_port_column (port)) - 1; switch (chr) { @@ -907,8 +913,8 @@ static SCM scm_read_syntax (int chr, SCM port, scm_t_read_opts *opts) { SCM p; - long line = SCM_LINUM (port); - int column = SCM_COL (port) - 1; + long line = scm_to_long (scm_port_line (port)); + int column = scm_to_int (scm_port_column (port)) - 1; switch (chr) { @@ -1068,7 +1074,7 @@ scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) ((unsigned char) buffer[0] <= 127 || scm_is_eq (pt->encoding, sym_ISO_8859_1))) { - SCM_COL (port) += 1; + scm_set_port_column_x (port, scm_sum (scm_port_column (port), SCM_INUM1)); return SCM_MAKE_CHAR (buffer[0]); } @@ -1076,7 +1082,9 @@ scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) processing. */ charname = scm_from_port_stringn (buffer, bytes_read, port); charname_len = scm_i_string_length (charname); - SCM_COL (port) += charname_len; + scm_set_port_column_x (port, + scm_sum (scm_port_column (port), + scm_from_size_t (charname_len))); cp = scm_i_string_ref (charname, 0); if (charname_len == 1) return SCM_MAKE_CHAR (cp); @@ -1629,8 +1637,8 @@ scm_read_sharp_extension (int chr, SCM port, scm_t_read_opts *opts) proc = scm_get_hash_procedure (chr); if (scm_is_true (scm_procedure_p (proc))) { - long line = SCM_LINUM (port); - int column = SCM_COL (port) - 2; + long line = scm_to_long (scm_port_line (port)); + int column = scm_to_int (scm_port_column (port)) - 2; SCM got; got = scm_call_2 (proc, SCM_MAKE_CHAR (chr), port); @@ -1782,8 +1790,8 @@ read_inner_expression (SCM port, scm_t_read_opts *opts) be part of an unescaped symbol. We might as well do something useful with it, so we adopt Kawa's convention: [...] => ($bracket-list$ ...) */ - long line = SCM_LINUM (port); - int column = SCM_COL (port) - 1; + long line = scm_to_long (scm_port_line (port)); + int column = scm_to_int (scm_port_column (port)) - 1; return maybe_annotate_source (scm_cons (sym_bracket_list, scm_read_sexp (chr, port, opts)), port, opts, line, column); @@ -1805,8 +1813,8 @@ read_inner_expression (SCM port, scm_t_read_opts *opts) return (scm_read_quote (chr, port, opts)); case '#': { - long line = SCM_LINUM (port); - int column = SCM_COL (port) - 1; + long line = scm_to_long (scm_port_line (port)); + int column = scm_to_int (scm_port_column (port)) - 1; SCM result = scm_read_sharp (chr, port, opts, line, column); if (scm_is_eq (result, SCM_UNSPECIFIED)) /* We read a comment or some such. */ @@ -1870,8 +1878,8 @@ scm_read_expression (SCM port, scm_t_read_opts *opts) if (c == EOF) return SCM_EOF_VAL; scm_ungetc (c, port); - line = SCM_LINUM (port); - column = SCM_COL (port); + line = scm_to_long (scm_port_line (port)); + column = scm_to_int (scm_port_column (port)); } expr = read_inner_expression (port, opts); diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 4330ebedf..4b7462585 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -169,9 +169,14 @@ interpret its input and output." port-buffer-cur port-buffer-end port-buffer-has-eof? + port-buffer-position set-port-buffer-cur! set-port-buffer-end! set-port-buffer-has-eof?! + port-position-line + port-position-column + set-port-position-line! + set-port-position-column! port-read port-write port-clear-stream-start-for-bom-read @@ -188,6 +193,7 @@ interpret its input and output." (define-syntax-rule (port-buffer-cur buf) (vector-ref buf 1)) (define-syntax-rule (port-buffer-end buf) (vector-ref buf 2)) (define-syntax-rule (port-buffer-has-eof? buf) (vector-ref buf 3)) +(define-syntax-rule (port-buffer-position buf) (vector-ref buf 4)) (define-syntax-rule (set-port-buffer-cur! buf cur) (vector-set! buf 1 cur)) @@ -196,6 +202,15 @@ interpret its input and output." (define-syntax-rule (set-port-buffer-has-eof?! buf has-eof?) (vector-set! buf 3 has-eof?)) +(define-syntax-rule (port-position-line position) + (car position)) +(define-syntax-rule (port-position-column position) + (cdr position)) +(define-syntax-rule (set-port-position-line! position line) + (set-car! position line)) +(define-syntax-rule (set-port-position-column! position column) + (set-cdr! position column)) + (eval-when (expand) (define-syntax-rule (private-port-bindings binding ...) (begin diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm index 265b70557..2ee97340b 100644 --- a/module/ice-9/sports.scm +++ b/module/ice-9/sports.scm @@ -384,34 +384,34 @@ (peek-bytes port 1 fast-path (lambda (buf bv cur buffered) (slow-path)))) -(define-inlinable (port-advance-position! port char) +(define-inlinable (advance-port-position! pos char) ;; FIXME: this cond is a speed hack; really we should just compile ;; `case' better. (cond ;; FIXME: char>? et al should compile well. ((<= (char->integer #\space) (char->integer char)) - (set-port-column! port (1+ (port-column port)))) + (set-port-position-column! pos (1+ (port-position-column pos)))) (else (case char ((#\alarm) #t) ; No change. ((#\backspace) - (let ((col (port-column port))) + (let ((col (port-position-column pos))) (when (> col 0) - (set-port-column! port (1- col))))) + (set-port-position-column! pos (1- col))))) ((#\newline) - (set-port-line! port (1+ (port-line port))) - (set-port-column! port 0)) + (set-port-position-line! pos (1+ (port-position-line pos))) + (set-port-position-column! pos 0)) ((#\return) - (set-port-column! port 0)) + (set-port-position-column! pos 0)) ((#\tab) - (let ((col (port-column port))) - (set-port-column! port (- (+ col 8) (remainder col 8))))) + (let ((col (port-position-column pos))) + (set-port-position-column! pos (- (+ col 8) (remainder col 8))))) (else - (set-port-column! port (1+ (port-column port)))))))) + (set-port-position-column! pos (1+ (port-position-column pos)))))))) (define* (read-char #:optional (port (current-input-port))) - (define (finish char) - (port-advance-position! port char) + (define (finish buf char) + (advance-port-position! (port-buffer-position buf) char) char) (define (slow-path) (call-with-values (lambda () (peek-char-and-len port)) @@ -422,7 +422,7 @@ (begin (set-port-buffer-has-eof?! buf #f) char) - (finish char)))))) + (finish buf char)))))) (define (fast-path buf bv cur buffered) (let ((u8 (bytevector-u8-ref bv cur)) (enc (%port-encoding port))) @@ -431,11 +431,11 @@ (decode-utf8 bv cur buffered u8 (lambda (char len) (set-port-buffer-cur! buf (+ cur len)) - (finish char)) + (finish buf char)) slow-path)) ((ISO-8859-1) (set-port-buffer-cur! buf (+ cur 1)) - (finish (integer->char u8))) + (finish buf (integer->char u8))) (else (slow-path))))) (peek-bytes port 1 fast-path (lambda (buf bv cur buffered) (slow-path)))) @@ -460,7 +460,7 @@ (let ((ch (integer->char (bytevector-u8-ref bv cur))) (cur (1+ cur))) (set-port-buffer-cur! buf cur) - (port-advance-position! port ch) + (advance-port-position! (port-buffer-position buf) ch) (call-with-values (lambda () (proc ch seed)) (lambda (seed done?) (if done? seed (fold-chars cur seed))))))))))) From c6d88d12345a3722bf78b124c69f15d73da23dc0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 1 Mar 2015 22:46:55 +0100 Subject: [PATCH 295/865] tests: Use 'pass-if-equal' in web-http chunked encoding tests. * test-suite/tests/web-http.test ("chunked encoding"): Use 'pass-if-equal' where appropriate. --- test-suite/tests/web-http.test | 31 ++++++++++++++++--------------- 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test index f01a8326d..09b029064 100644 --- a/test-suite/tests/web-http.test +++ b/test-suite/tests/web-http.test @@ -1,6 +1,6 @@ ;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010, 2011, 2014, 2016 Free Software Foundation, Inc. +;;;; Copyright (C) 2010-2011, 2014-2016 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 @@ -369,18 +369,19 @@ (with-test-prefix "chunked encoding" (let* ((s "5\r\nFirst\r\nA\r\n line\n Sec\r\n8\r\nond line\r\n0\r\n") (p (make-chunked-input-port (open-input-string s)))) - (pass-if (equal? "First line\n Second line" - (get-string-all p))) + (pass-if-equal + "First line\n Second line" + (get-string-all p)) (pass-if (port-eof? (make-chunked-input-port (open-input-string "0\r\n"))))) - (pass-if - (equal? (call-with-output-string - (lambda (out-raw) - (let ((out-chunked (make-chunked-output-port out-raw - #:keep-alive? #t))) - (display "First chunk" out-chunked) - (force-output out-chunked) - (display "Second chunk" out-chunked) - (force-output out-chunked) - (display "Third chunk" out-chunked) - (close-port out-chunked)))) - "b\r\nFirst chunk\r\nc\r\nSecond chunk\r\nb\r\nThird chunk\r\n0\r\n"))) + (pass-if-equal + (call-with-output-string + (lambda (out-raw) + (let ((out-chunked (make-chunked-output-port out-raw + #:keep-alive? #t))) + (display "First chunk" out-chunked) + (force-output out-chunked) + (display "Second chunk" out-chunked) + (force-output out-chunked) + (display "Third chunk" out-chunked) + (close-port out-chunked)))) + "b\r\nFirst chunk\r\nc\r\nSecond chunk\r\nb\r\nThird chunk\r\n0\r\n")) From 751a55e3552547c84cc3cc0ad69fc6f26bd7251e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 1 Mar 2015 23:41:01 +0100 Subject: [PATCH 296/865] http: Do not buffer HTTP chunks. Fixes . * module/web/http.scm (read-chunk, read-chunk-body): Remove. (make-chunked-input-port)[next-chunk, buffer-, buffer-size, buffer-pointer]: Remove. [chunk-size, remaining]: New variables. [read!]: Rewrite to write directly to BV. * test-suite/tests/web-http.test ("chunked encoding")["reads chunks without buffering", "reads across chunk boundaries"]: New tests. --- module/web/http.scm | 66 +++++++++++++++++----------------- test-suite/tests/web-http.test | 54 ++++++++++++++++++++++++++-- 2 files changed, 84 insertions(+), 36 deletions(-) diff --git a/module/web/http.scm b/module/web/http.scm index 9e8e4a3a5..8093ed21d 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -1,6 +1,6 @@ ;;; HTTP messages -;; Copyright (C) 2010, 2011, 2012, 2013, 2014, 2016 Free Software Foundation, Inc. +;; Copyright (C) 2010-2016 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 @@ -1914,6 +1914,7 @@ treated specially, and is just returned as a plain string." ;; Chunked Responses (define (read-chunk-header port) + "Read a chunk header and return the chunk size." (let* ((str (read-line port)) (extension-start (string-index str (lambda (c) (or (char=? c #\;) (char=? c #\return))))) @@ -1923,53 +1924,50 @@ treated specially, and is just returned as a plain string." 16))) size)) -(define (read-chunk port) - (let ((size (read-chunk-header port))) - (read-chunk-body port size))) - -(define (read-chunk-body port size) - (let ((bv (get-bytevector-n port size))) - (get-u8 port) ; CR - (get-u8 port) ; LF - bv)) - (define* (make-chunked-input-port port #:key (keep-alive? #f)) "Returns a new port which translates HTTP chunked transfer encoded data from PORT into a non-encoded format. Returns eof when it has read the final chunk from PORT. This does not necessarily mean that there is no more data on PORT. When the returned port is closed it will also close PORT, unless the KEEP-ALIVE? is true." - (define (next-chunk) - (read-chunk port)) - (define finished? #f) (define (close) (unless keep-alive? (close-port port))) - (define buffer #vu8()) - (define buffer-size 0) - (define buffer-pointer 0) + + (define chunk-size 0) ;size of the current chunk + (define remaining 0) ;number of bytes left from the current chunk + (define finished? #f) ;did we get all the chunks? + (define (read! bv idx to-read) (define (loop to-read num-read) (cond ((or finished? (zero? to-read)) num-read) - ((<= to-read (- buffer-size buffer-pointer)) - (bytevector-copy! buffer buffer-pointer - bv (+ idx num-read) - to-read) - (set! buffer-pointer (+ buffer-pointer to-read)) - (loop 0 (+ num-read to-read))) - (else - (let ((n (- buffer-size buffer-pointer))) - (bytevector-copy! buffer buffer-pointer - bv (+ idx num-read) - n) - (set! buffer (next-chunk)) - (set! buffer-pointer 0) - (set! buffer-size (bytevector-length buffer)) - (set! finished? (= buffer-size 0)) - (loop (- to-read n) - (+ num-read n)))))) + ((zero? remaining) ;get a new chunk + (let ((size (read-chunk-header port))) + (set! chunk-size size) + (set! remaining size) + (if (zero? size) + (begin + (set! finished? #t) + num-read) + (loop to-read num-read)))) + (else ;read from the current chunk + (let* ((ask-for (min to-read remaining)) + (read (get-bytevector-n! port bv (+ idx num-read) + ask-for))) + (if (eof-object? read) + (begin ;premature termination + (set! finished? #t) + num-read) + (let ((left (- remaining read))) + (set! remaining left) + (when (zero? left) + ;; We're done with this chunk; read CR and LF. + (get-u8 port) (get-u8 port)) + (loop (- to-read read) + (+ num-read read)))))))) (loop to-read 0)) + (make-custom-binary-input-port "chunked input port" read! #f #f close)) (define* (make-chunked-output-port port #:key (keep-alive? #f) diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test index 09b029064..8a7a29542 100644 --- a/test-suite/tests/web-http.test +++ b/test-suite/tests/web-http.test @@ -1,4 +1,4 @@ -;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8; -*- +;;;; web-http.test --- HTTP library -*- mode: scheme; coding: utf-8; -*- ;;;; ;;;; Copyright (C) 2010-2011, 2014-2016 Free Software Foundation, Inc. ;;;; @@ -20,6 +20,7 @@ (define-module (test-suite web-http) #:use-module (web uri) #:use-module (web http) + #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (ice-9 regex) #:use-module (ice-9 control) @@ -372,7 +373,56 @@ (pass-if-equal "First line\n Second line" (get-string-all p)) - (pass-if (port-eof? (make-chunked-input-port (open-input-string "0\r\n"))))) + (pass-if (port-eof? (make-chunked-input-port (open-input-string "0\r\n")))) + + (pass-if-equal "reads chunks without buffering" + ;; Make sure the chunked input port does not read more than what + ;; the client asked. See + `("First " "chunk." "Second " "chunk." + (1 1 1 6 6 1 1 + 1 1 1 7 6 1 1)) + (let* ((str "C\r\nFirst chunk.\r\nD\r\nSecond chunk.\r\n") + (requests '()) + (read! (let ((port (open-input-string str))) + (lambda (bv index count) + (set! requests (cons count requests)) + (let ((n (get-bytevector-n! port bv index + count))) + (if (eof-object? n) 0 n))))) + (input (make-custom-binary-input-port "chunky" read! + #f #f #f)) + (port (make-chunked-input-port input))) + (setvbuf input _IONBF) + (setvbuf port _IONBF) + (list (utf8->string (get-bytevector-n port 6)) + (utf8->string (get-bytevector-n port 6)) + (utf8->string (get-bytevector-n port 7)) + (utf8->string (get-bytevector-n port 6)) + (reverse requests)))) + + (pass-if-equal "reads across chunk boundaries" + ;; Same, but read across chunk boundaries. + `("First " "chunk.Second " "chunk." + (1 1 1 6 6 1 1 + 1 1 1 7 6 1 1)) + (let* ((str "C\r\nFirst chunk.\r\nD\r\nSecond chunk.\r\n") + (requests '()) + (read! (let ((port (open-input-string str))) + (lambda (bv index count) + (set! requests (cons count requests)) + (let ((n (get-bytevector-n! port bv index + count))) + (if (eof-object? n) 0 n))))) + (input (make-custom-binary-input-port "chunky" read! + #f #f #f)) + (port (make-chunked-input-port input))) + (setvbuf input _IONBF) + (setvbuf port _IONBF) + (list (utf8->string (get-bytevector-n port 6)) + (utf8->string (get-bytevector-n port 13)) + (utf8->string (get-bytevector-n port 6)) + (reverse requests))))) + (pass-if-equal (call-with-output-string (lambda (out-raw) From e390e5760b8811be04665e160d0eb79d3721c453 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 22 Jan 2015 01:22:19 -0500 Subject: [PATCH 297/865] Implement 'string-utf8-length' and 'scm_c_string_utf8_length'. * libguile/strings.c (utf8_length, scm_c_string_utf8_length) (scm_string_utf8_length): New functions. * libguile/strings.h (scm_c_string_utf8_length, scm_string_utf8_length): New prototypes. * doc/ref/api-data.texi (Bytevectors as Strings): Add docs. * doc/ref/guile.texi: Update manual copyright date to 2015. * test-suite/tests/strings.test (string-utf8-length): Add tests. --- doc/ref/api-data.texi | 8 +++++++- doc/ref/guile.texi | 2 +- libguile/strings.c | 34 +++++++++++++++++++++++++++++++++- libguile/strings.h | 5 ++++- test-suite/tests/strings.test | 20 ++++++++++++++++++-- 5 files changed, 63 insertions(+), 6 deletions(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 3f787b1c9..3a3a8e4ac 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000-2004, 2006-2014 +@c Copyright (C) 1996, 1997, 2000-2004, 2006-2015 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -4983,6 +4983,12 @@ in one of the most commonly available encoding formats. @result{} #vu8(99 97 102 195 169) @end lisp +@deftypefn {Scheme Procedure} {} string-utf8-length str +@deftypefnx {C function} SCM scm_string_utf8_length (str) +@deftypefnx {C function} size_t scm_c_string_utf8_length (str) +Return the number of bytes in the UTF-8 representation of @var{str}. +@end deftypefn + @deffn {Scheme Procedure} string->utf8 str @deffnx {Scheme Procedure} string->utf16 str [endianness] @deffnx {Scheme Procedure} string->utf32 str [endianness] diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index 5f21188fa..cb4c431f2 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -14,7 +14,7 @@ This manual documents Guile version @value{VERSION}. Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2009, -2010, 2011, 2012, 2013, 2014 Free Software Foundation. +2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation. Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or diff --git a/libguile/strings.c b/libguile/strings.c index 2e5647e6d..dc2e4f5fe 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2004, 2006, - * 2008-2015 Free Software Foundation, Inc. + * 2008-2016 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 License @@ -2065,6 +2065,38 @@ u32_u8_length_in_bytes (const scm_t_uint32 *str, size_t len) return ret; } +static size_t +utf8_length (SCM str) +{ + if (scm_i_is_narrow_string (str)) + return latin1_u8_strlen ((scm_t_uint8 *) scm_i_string_chars (str), + scm_i_string_length (str)); + else + return u32_u8_length_in_bytes + ((scm_t_uint32 *) scm_i_string_wide_chars (str), + scm_i_string_length (str)); +} + +size_t +scm_c_string_utf8_length (SCM string) +#define FUNC_NAME "scm_c_string_utf8_length" +{ + SCM_VALIDATE_STRING (1, string); + return utf8_length (string); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_utf8_length, "string-utf8-length", 1, 0, 0, + (SCM string), + "Returns the number of bytes in the UTF-8 representation of " + "@var{string}.") +#define FUNC_NAME s_scm_string_utf8_length +{ + SCM_VALIDATE_STRING (1, string); + return scm_from_size_t (utf8_length (string)); +} +#undef FUNC_NAME + char * scm_to_utf8_stringn (SCM str, size_t *lenp) #define FUNC_NAME "scm_to_utf8_stringn" diff --git a/libguile/strings.h b/libguile/strings.h index 24471cd69..882e7ce64 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -3,7 +3,8 @@ #ifndef SCM_STRINGS_H #define SCM_STRINGS_H -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2005, 2006, 2008, 2009, 2010, 2011, 2013 Free Software Foundation, Inc. +/* Copyright (C) 1995-1998, 2000, 2001, 2004-2006, 2008-2011, 2013, + * 2015-2016 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 License @@ -107,6 +108,7 @@ SCM_API SCM scm_string_p (SCM x); SCM_API SCM scm_string (SCM chrs); SCM_API SCM scm_make_string (SCM k, SCM chr); SCM_API SCM scm_string_length (SCM str); +SCM_API SCM scm_string_utf8_length (SCM str); SCM_API SCM scm_string_bytes_per_char (SCM str); SCM_API SCM scm_string_ref (SCM str, SCM k); SCM_API SCM scm_string_set_x (SCM str, SCM k, SCM chr); @@ -120,6 +122,7 @@ SCM_API SCM scm_from_stringn (const char *str, size_t len, const char *encoding, scm_t_string_failed_conversion_handler handler); SCM_API SCM scm_c_make_string (size_t len, SCM chr); SCM_API size_t scm_c_string_length (SCM str); +SCM_API size_t scm_c_string_utf8_length (SCM str); SCM_API size_t scm_c_symbol_length (SCM sym); SCM_API SCM scm_c_string_ref (SCM str, size_t pos); SCM_API void scm_c_string_set_x (SCM str, size_t pos, SCM chr); diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test index 56c898c8b..66c8a6b95 100644 --- a/test-suite/tests/strings.test +++ b/test-suite/tests/strings.test @@ -1,8 +1,8 @@ ;;;; strings.test --- test suite for Guile's string functions -*- scheme -*- ;;;; Jim Blandy --- August 1999 ;;;; -;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2008, 2009, 2010, -;;;; 2011, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001, 2004-2006, 2008-2011, 2013, +;;;; 2015 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 @@ -457,6 +457,22 @@ (pass-if "compatibility composition is equal?" (equal? (string-normalize-nfkc "\u1e9b\u0323") "\u1e69"))) +;; +;; string-utf8-length +;; + +(with-test-prefix "string-utf8-length" + + (pass-if-exception "wrong type argument" + exception:wrong-type-arg + (string-utf8-length 50)) + + (pass-if-equal 0 (string-utf8-length "")) + (pass-if-equal 1 (string-utf8-length "\0")) + (pass-if-equal 5 (string-utf8-length "hello")) + (pass-if-equal 7 (string-utf8-length "helloλ")) + (pass-if-equal 9 (string-utf8-length "ሠላም"))) + ;; ;; string-ref ;; From 30db824b923ba9cdb3dc1783af03f9b164a87f6e Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 18 Feb 2015 16:32:21 -0500 Subject: [PATCH 298/865] Don't return expressions from void functions in numbers.c Although popular compilers allow it as long as the expression is of type void, it violates C99 and some compilers choke on it. * libguile/numbers.c (scm_euclidean_divide, scm_floor_divide) (scm_ceiling_divide, scm_truncate_divide, scm_centered_divide) (scm_round_divide): Don't use the return statement with an expression from functions with return type void. --- libguile/numbers.c | 246 ++++++++++++++++++++------------------------- 1 file changed, 108 insertions(+), 138 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 4f740c583..9cc72d269 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1,6 +1,4 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, - * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, - * 2013, 2014 Free Software Foundation, Inc. +/* Copyright (C) 1995-2015 Free Software Foundation, Inc. * * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories * and Bellcore. See scm_divide. @@ -1173,9 +1171,9 @@ void scm_euclidean_divide (SCM x, SCM y, SCM *qp, SCM *rp) { if (scm_is_false (scm_negative_p (y))) - return scm_floor_divide (x, y, qp, rp); + scm_floor_divide (x, y, qp, rp); else - return scm_ceiling_divide (x, y, qp, rp); + scm_ceiling_divide (x, y, qp, rp); } static SCM scm_i_inexact_floor_quotient (double x, double y); @@ -1549,7 +1547,6 @@ scm_floor_divide (SCM x, SCM y, SCM *qp, SCM *rp) *qp = scm_i_inum2big (qq); *rp = SCM_I_MAKINUM (rr); } - return; } else if (SCM_BIGP (y)) { @@ -1584,15 +1581,14 @@ scm_floor_divide (SCM x, SCM y, SCM *qp, SCM *rp) *qp = SCM_I_MAKINUM (-1); *rp = scm_i_normbig (r); } - return; } else if (SCM_REALP (y)) - return scm_i_inexact_floor_divide (xx, SCM_REAL_VALUE (y), qp, rp); + scm_i_inexact_floor_divide (xx, SCM_REAL_VALUE (y), qp, rp); else if (SCM_FRACTIONP (y)) - return scm_i_exact_rational_floor_divide (x, y, qp, rp); + scm_i_exact_rational_floor_divide (x, y, qp, rp); else - return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2, - s_scm_floor_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2, + s_scm_floor_divide, qp, rp); } else if (SCM_BIGP (x)) { @@ -1618,7 +1614,6 @@ scm_floor_divide (SCM x, SCM y, SCM *qp, SCM *rp) *qp = scm_i_normbig (q); *rp = scm_i_normbig (r); } - return; } else if (SCM_BIGP (y)) { @@ -1629,41 +1624,40 @@ scm_floor_divide (SCM x, SCM y, SCM *qp, SCM *rp) scm_remember_upto_here_2 (x, y); *qp = scm_i_normbig (q); *rp = scm_i_normbig (r); - return; } else if (SCM_REALP (y)) - return scm_i_inexact_floor_divide - (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp); + scm_i_inexact_floor_divide (scm_i_big2dbl (x), SCM_REAL_VALUE (y), + qp, rp); else if (SCM_FRACTIONP (y)) - return scm_i_exact_rational_floor_divide (x, y, qp, rp); + scm_i_exact_rational_floor_divide (x, y, qp, rp); else - return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2, - s_scm_floor_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2, + s_scm_floor_divide, qp, rp); } else if (SCM_REALP (x)) { if (SCM_REALP (y) || SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)) - return scm_i_inexact_floor_divide - (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp); + scm_i_inexact_floor_divide (SCM_REAL_VALUE (x), scm_to_double (y), + qp, rp); else - return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2, - s_scm_floor_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2, + s_scm_floor_divide, qp, rp); } else if (SCM_FRACTIONP (x)) { if (SCM_REALP (y)) - return scm_i_inexact_floor_divide - (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp); + scm_i_inexact_floor_divide + (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp); else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)) - return scm_i_exact_rational_floor_divide (x, y, qp, rp); + scm_i_exact_rational_floor_divide (x, y, qp, rp); else - return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2, - s_scm_floor_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2, + s_scm_floor_divide, qp, rp); } else - return two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG1, - s_scm_floor_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG1, + s_scm_floor_divide, qp, rp); } static void @@ -2090,7 +2084,6 @@ scm_ceiling_divide (SCM x, SCM y, SCM *qp, SCM *rp) *qp = scm_i_inum2big (qq); *rp = SCM_I_MAKINUM (rr); } - return; } else if (SCM_BIGP (y)) { @@ -2136,15 +2129,14 @@ scm_ceiling_divide (SCM x, SCM y, SCM *qp, SCM *rp) *qp = SCM_INUM1; *rp = scm_i_normbig (r); } - return; } else if (SCM_REALP (y)) - return scm_i_inexact_ceiling_divide (xx, SCM_REAL_VALUE (y), qp, rp); + scm_i_inexact_ceiling_divide (xx, SCM_REAL_VALUE (y), qp, rp); else if (SCM_FRACTIONP (y)) - return scm_i_exact_rational_ceiling_divide (x, y, qp, rp); + scm_i_exact_rational_ceiling_divide (x, y, qp, rp); else - return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2, - s_scm_ceiling_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2, + s_scm_ceiling_divide, qp, rp); } else if (SCM_BIGP (x)) { @@ -2170,7 +2162,6 @@ scm_ceiling_divide (SCM x, SCM y, SCM *qp, SCM *rp) *qp = scm_i_normbig (q); *rp = scm_i_normbig (r); } - return; } else if (SCM_BIGP (y)) { @@ -2181,41 +2172,40 @@ scm_ceiling_divide (SCM x, SCM y, SCM *qp, SCM *rp) scm_remember_upto_here_2 (x, y); *qp = scm_i_normbig (q); *rp = scm_i_normbig (r); - return; } else if (SCM_REALP (y)) - return scm_i_inexact_ceiling_divide - (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp); + scm_i_inexact_ceiling_divide (scm_i_big2dbl (x), SCM_REAL_VALUE (y), + qp, rp); else if (SCM_FRACTIONP (y)) - return scm_i_exact_rational_ceiling_divide (x, y, qp, rp); + scm_i_exact_rational_ceiling_divide (x, y, qp, rp); else - return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2, - s_scm_ceiling_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2, + s_scm_ceiling_divide, qp, rp); } else if (SCM_REALP (x)) { if (SCM_REALP (y) || SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)) - return scm_i_inexact_ceiling_divide - (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp); + scm_i_inexact_ceiling_divide (SCM_REAL_VALUE (x), scm_to_double (y), + qp, rp); else - return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2, - s_scm_ceiling_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2, + s_scm_ceiling_divide, qp, rp); } else if (SCM_FRACTIONP (x)) { if (SCM_REALP (y)) - return scm_i_inexact_ceiling_divide + scm_i_inexact_ceiling_divide (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp); else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)) - return scm_i_exact_rational_ceiling_divide (x, y, qp, rp); + scm_i_exact_rational_ceiling_divide (x, y, qp, rp); else - return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2, - s_scm_ceiling_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2, + s_scm_ceiling_divide, qp, rp); } else - return two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG1, - s_scm_ceiling_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG1, + s_scm_ceiling_divide, qp, rp); } static void @@ -2573,7 +2563,6 @@ scm_truncate_divide (SCM x, SCM y, SCM *qp, SCM *rp) *qp = scm_i_inum2big (qq); *rp = SCM_I_MAKINUM (rr); } - return; } else if (SCM_BIGP (y)) { @@ -2591,16 +2580,14 @@ scm_truncate_divide (SCM x, SCM y, SCM *qp, SCM *rp) *qp = SCM_INUM0; *rp = x; } - return; } else if (SCM_REALP (y)) - return scm_i_inexact_truncate_divide (xx, SCM_REAL_VALUE (y), qp, rp); + scm_i_inexact_truncate_divide (xx, SCM_REAL_VALUE (y), qp, rp); else if (SCM_FRACTIONP (y)) - return scm_i_exact_rational_truncate_divide (x, y, qp, rp); + scm_i_exact_rational_truncate_divide (x, y, qp, rp); else - return two_valued_wta_dispatch_2 - (g_scm_truncate_divide, x, y, SCM_ARG2, - s_scm_truncate_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_truncate_divide, x, y, SCM_ARG2, + s_scm_truncate_divide, qp, rp); } else if (SCM_BIGP (x)) { @@ -2627,7 +2614,6 @@ scm_truncate_divide (SCM x, SCM y, SCM *qp, SCM *rp) *qp = scm_i_normbig (q); *rp = SCM_I_MAKINUM (rr); } - return; } else if (SCM_BIGP (y)) { @@ -2640,41 +2626,38 @@ scm_truncate_divide (SCM x, SCM y, SCM *qp, SCM *rp) *rp = scm_i_normbig (r); } else if (SCM_REALP (y)) - return scm_i_inexact_truncate_divide - (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp); + scm_i_inexact_truncate_divide (scm_i_big2dbl (x), SCM_REAL_VALUE (y), + qp, rp); else if (SCM_FRACTIONP (y)) - return scm_i_exact_rational_truncate_divide (x, y, qp, rp); + scm_i_exact_rational_truncate_divide (x, y, qp, rp); else - return two_valued_wta_dispatch_2 - (g_scm_truncate_divide, x, y, SCM_ARG2, - s_scm_truncate_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_truncate_divide, x, y, SCM_ARG2, + s_scm_truncate_divide, qp, rp); } else if (SCM_REALP (x)) { if (SCM_REALP (y) || SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)) - return scm_i_inexact_truncate_divide - (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp); + scm_i_inexact_truncate_divide (SCM_REAL_VALUE (x), scm_to_double (y), + qp, rp); else - return two_valued_wta_dispatch_2 - (g_scm_truncate_divide, x, y, SCM_ARG2, - s_scm_truncate_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_truncate_divide, x, y, SCM_ARG2, + s_scm_truncate_divide, qp, rp); } else if (SCM_FRACTIONP (x)) { if (SCM_REALP (y)) - return scm_i_inexact_truncate_divide + scm_i_inexact_truncate_divide (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp); else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)) - return scm_i_exact_rational_truncate_divide (x, y, qp, rp); + scm_i_exact_rational_truncate_divide (x, y, qp, rp); else - return two_valued_wta_dispatch_2 - (g_scm_truncate_divide, x, y, SCM_ARG2, - s_scm_truncate_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_truncate_divide, x, y, SCM_ARG2, + s_scm_truncate_divide, qp, rp); } else - return two_valued_wta_dispatch_2 (g_scm_truncate_divide, x, y, SCM_ARG1, - s_scm_truncate_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_truncate_divide, x, y, SCM_ARG1, + s_scm_truncate_divide, qp, rp); } static void @@ -3217,22 +3200,18 @@ scm_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp) *qp = scm_i_inum2big (qq); *rp = SCM_I_MAKINUM (rr); } - return; } else if (SCM_BIGP (y)) - { - /* Pass a denormalized bignum version of x (even though it - can fit in a fixnum) to scm_i_bigint_centered_divide */ - return scm_i_bigint_centered_divide (scm_i_long2big (xx), y, qp, rp); - } + /* Pass a denormalized bignum version of x (even though it + can fit in a fixnum) to scm_i_bigint_centered_divide */ + scm_i_bigint_centered_divide (scm_i_long2big (xx), y, qp, rp); else if (SCM_REALP (y)) - return scm_i_inexact_centered_divide (xx, SCM_REAL_VALUE (y), qp, rp); + scm_i_inexact_centered_divide (xx, SCM_REAL_VALUE (y), qp, rp); else if (SCM_FRACTIONP (y)) - return scm_i_exact_rational_centered_divide (x, y, qp, rp); + scm_i_exact_rational_centered_divide (x, y, qp, rp); else - return two_valued_wta_dispatch_2 - (g_scm_centered_divide, x, y, SCM_ARG2, - s_scm_centered_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG2, + s_scm_centered_divide, qp, rp); } else if (SCM_BIGP (x)) { @@ -3276,46 +3255,42 @@ scm_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp) *qp = scm_i_normbig (q); *rp = SCM_I_MAKINUM (rr); } - return; } else if (SCM_BIGP (y)) - return scm_i_bigint_centered_divide (x, y, qp, rp); + scm_i_bigint_centered_divide (x, y, qp, rp); else if (SCM_REALP (y)) - return scm_i_inexact_centered_divide - (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp); + scm_i_inexact_centered_divide (scm_i_big2dbl (x), SCM_REAL_VALUE (y), + qp, rp); else if (SCM_FRACTIONP (y)) - return scm_i_exact_rational_centered_divide (x, y, qp, rp); + scm_i_exact_rational_centered_divide (x, y, qp, rp); else - return two_valued_wta_dispatch_2 - (g_scm_centered_divide, x, y, SCM_ARG2, - s_scm_centered_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG2, + s_scm_centered_divide, qp, rp); } else if (SCM_REALP (x)) { if (SCM_REALP (y) || SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)) - return scm_i_inexact_centered_divide - (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp); + scm_i_inexact_centered_divide (SCM_REAL_VALUE (x), scm_to_double (y), + qp, rp); else - return two_valued_wta_dispatch_2 - (g_scm_centered_divide, x, y, SCM_ARG2, - s_scm_centered_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG2, + s_scm_centered_divide, qp, rp); } else if (SCM_FRACTIONP (x)) { if (SCM_REALP (y)) - return scm_i_inexact_centered_divide - (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp); + scm_i_inexact_centered_divide + (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp); else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)) - return scm_i_exact_rational_centered_divide (x, y, qp, rp); + scm_i_exact_rational_centered_divide (x, y, qp, rp); else - return two_valued_wta_dispatch_2 - (g_scm_centered_divide, x, y, SCM_ARG2, - s_scm_centered_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG2, + s_scm_centered_divide, qp, rp); } else - return two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG1, - s_scm_centered_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG1, + s_scm_centered_divide, qp, rp); } static void @@ -3897,22 +3872,18 @@ scm_round_divide (SCM x, SCM y, SCM *qp, SCM *rp) *qp = scm_i_inum2big (qq); *rp = SCM_I_MAKINUM (rr); } - return; } else if (SCM_BIGP (y)) - { - /* Pass a denormalized bignum version of x (even though it - can fit in a fixnum) to scm_i_bigint_round_divide */ - return scm_i_bigint_round_divide - (scm_i_long2big (SCM_I_INUM (x)), y, qp, rp); - } + /* Pass a denormalized bignum version of x (even though it + can fit in a fixnum) to scm_i_bigint_round_divide */ + scm_i_bigint_round_divide (scm_i_long2big (SCM_I_INUM (x)), y, qp, rp); else if (SCM_REALP (y)) - return scm_i_inexact_round_divide (xx, SCM_REAL_VALUE (y), qp, rp); + scm_i_inexact_round_divide (xx, SCM_REAL_VALUE (y), qp, rp); else if (SCM_FRACTIONP (y)) - return scm_i_exact_rational_round_divide (x, y, qp, rp); + scm_i_exact_rational_round_divide (x, y, qp, rp); else - return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2, - s_scm_round_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2, + s_scm_round_divide, qp, rp); } else if (SCM_BIGP (x)) { @@ -3955,43 +3926,42 @@ scm_round_divide (SCM x, SCM y, SCM *qp, SCM *rp) *qp = scm_i_normbig (q); *rp = SCM_I_MAKINUM (rr); } - return; } else if (SCM_BIGP (y)) - return scm_i_bigint_round_divide (x, y, qp, rp); + scm_i_bigint_round_divide (x, y, qp, rp); else if (SCM_REALP (y)) - return scm_i_inexact_round_divide - (scm_i_big2dbl (x), SCM_REAL_VALUE (y), qp, rp); + scm_i_inexact_round_divide (scm_i_big2dbl (x), SCM_REAL_VALUE (y), + qp, rp); else if (SCM_FRACTIONP (y)) - return scm_i_exact_rational_round_divide (x, y, qp, rp); + scm_i_exact_rational_round_divide (x, y, qp, rp); else - return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2, - s_scm_round_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2, + s_scm_round_divide, qp, rp); } else if (SCM_REALP (x)) { if (SCM_REALP (y) || SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)) - return scm_i_inexact_round_divide - (SCM_REAL_VALUE (x), scm_to_double (y), qp, rp); + scm_i_inexact_round_divide (SCM_REAL_VALUE (x), scm_to_double (y), + qp, rp); else - return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2, - s_scm_round_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2, + s_scm_round_divide, qp, rp); } else if (SCM_FRACTIONP (x)) { if (SCM_REALP (y)) - return scm_i_inexact_round_divide + scm_i_inexact_round_divide (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp); else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y)) - return scm_i_exact_rational_round_divide (x, y, qp, rp); + scm_i_exact_rational_round_divide (x, y, qp, rp); else - return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2, - s_scm_round_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2, + s_scm_round_divide, qp, rp); } else - return two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG1, - s_scm_round_divide, qp, rp); + two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG1, + s_scm_round_divide, qp, rp); } static void From 05bea208b3c0cb26a1a1a800e82d8e29e73bfba4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 4 Mar 2015 09:43:46 +0100 Subject: [PATCH 299/865] tests: Make 'test-guild-compile' more reliable. Before that it would occasionally fail because the "$target" (not the intermediate temporary file) would be produced. * test-suite/standalone/test-guild-compile: Call 'pause' before 'sleep' in test program. --- test-suite/standalone/test-guild-compile | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test-suite/standalone/test-guild-compile b/test-suite/standalone/test-guild-compile index 525ecc6e0..5972d5474 100755 --- a/test-suite/standalone/test-guild-compile +++ b/test-suite/standalone/test-guild-compile @@ -10,6 +10,11 @@ trap 'rm -f "$source" "$target"' EXIT cat > "$source"< Date: Wed, 4 Mar 2015 09:49:31 +0100 Subject: [PATCH 300/865] tests: Gracefully handle ENOSYS return for 'setaffinity'. Fixes . Reported by John Paul Adrian Glaubitz . * test-suite/tests/posix.test ("affinity")["setaffinity"]: Wrap in 'catch' and throw 'unresolved upon ENOSYS. --- test-suite/tests/posix.test | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/test-suite/tests/posix.test b/test-suite/tests/posix.test index 9a0e489b4..f57001a24 100644 --- a/test-suite/tests/posix.test +++ b/test-suite/tests/posix.test @@ -1,6 +1,7 @@ ;;;; posix.test --- Test suite for Guile POSIX functions. -*- scheme -*- ;;;; -;;;; Copyright 2003, 2004, 2006, 2007, 2010, 2012 Free Software Foundation, Inc. +;;;; Copyright 2003, 2004, 2006, 2007, 2010, 2012, +;;;; 2015 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 @@ -195,9 +196,18 @@ (pass-if "setaffinity" (if (and (defined? 'setaffinity) (defined? 'getaffinity)) - (let ((mask (getaffinity (getpid)))) - (setaffinity (getpid) mask) - (equal? mask (getaffinity (getpid)))) + (catch 'system-error + (lambda () + (let ((mask (getaffinity (getpid)))) + (setaffinity (getpid) mask) + (equal? mask (getaffinity (getpid))))) + (lambda args + ;; On some platforms such as sh4-linux-gnu, 'setaffinity' + ;; returns ENOSYS. + (let ((errno (system-error-errno args))) + (if (= errno ENOSYS) + (throw 'unresolved) + (apply throw args))))) (throw 'unresolved)))) ;; From 704c9118933329bc270b0e58d7b4bc02ca359454 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?= Date: Thu, 5 Mar 2015 22:44:17 +0100 Subject: [PATCH 301/865] Correct docstring of 'symlink'. * libguile/filesys.c (symlink): Correct the docstring, which had 'oldpath' and 'newpath' confused. --- libguile/filesys.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index 43d1be636..7674498a4 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -992,8 +992,8 @@ SCM_DEFINE (scm_fsync, "fsync", 1, 0, 0, #ifdef HAVE_SYMLINK SCM_DEFINE (scm_symlink, "symlink", 2, 0, 0, (SCM oldpath, SCM newpath), - "Create a symbolic link named @var{oldpath} with the value\n" - "(i.e., pointing to) @var{newpath}. The return value is\n" + "Create a symbolic link named @var{newpath} with the value\n" + "(i.e., pointing to) @var{oldpath}. The return value is\n" "unspecified.") #define FUNC_NAME s_scm_symlink { From d848067b896ff075eaac9d9814c5189e517775da Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 10 Mar 2015 09:01:24 +0100 Subject: [PATCH 302/865] web: Export 'server-impl' procedures and the 'http' server implementation. * module/web/server.scm: Export the 'server-impl' procedures. * module/web/server/http.scm: Export 'http'. --- module/web/server.scm | 11 ++++++++++- module/web/server/http.scm | 5 +++-- 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/module/web/server.scm b/module/web/server.scm index 471bb98de..80028fd7e 100644 --- a/module/web/server.scm +++ b/module/web/server.scm @@ -1,6 +1,6 @@ ;;; Web server -;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011, 2012, 2013, 2015 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 @@ -84,6 +84,15 @@ #:use-module (ice-9 iconv) #:export (define-server-impl lookup-server-impl + + make-server-impl + server-impl? + server-impl-name + server-impl-open + server-impl-read + server-impl-write + server-impl-close + open-server read-client handle-request diff --git a/module/web/server/http.scm b/module/web/server/http.scm index 2184ad8a2..05bf46bf0 100644 --- a/module/web/server/http.scm +++ b/module/web/server/http.scm @@ -1,6 +1,6 @@ ;;; Web I/O: HTTP -;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011, 2012, 2015 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 @@ -34,7 +34,8 @@ #:use-module (web request) #:use-module (web response) #:use-module (web server) - #:use-module (ice-9 poll)) + #:use-module (ice-9 poll) + #:export (http)) (define (make-default-socket family addr port) From 8dcf3c6163bba444cd459d9ffd22cc5f627fe6c8 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 26 Mar 2015 22:51:16 -0400 Subject: [PATCH 303/865] Work around requirement that size be non-zero in GDB 'open-memory'. * module/system/base/types.scm (memory-port): Handle zero size case specially. --- module/system/base/types.scm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/module/system/base/types.scm b/module/system/base/types.scm index ea2f3bcaf..73681715e 100644 --- a/module/system/base/types.scm +++ b/module/system/base/types.scm @@ -117,8 +117,12 @@ SIZE is omitted, return an unbounded port to the memory at ADDRESS." (let ((open (memory-backend-open backend))) (open address #f))) ((_ backend address size) - (let ((open (memory-backend-open backend))) - (open address size))))) + (if (zero? size) + ;; GDB's 'open-memory' raises an error when size + ;; is zero, so we must handle that case specially. + (open-bytevector-input-port '#vu8()) + (let ((open (memory-backend-open backend))) + (open address size)))))) (define (get-word port) "Read a word from PORT and return it as an integer." From 7b1069269b14b24a52cc5b315b215f8691978165 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 26 Mar 2015 23:13:47 -0400 Subject: [PATCH 304/865] Handle zero-length bytevectors correctly in (system base types). * module/system/base/types.scm (cell->object): Use 'get-bytevector-n' instead of 'get-bytevector-all', so that the zero-length case does not return EOF. --- module/system/base/types.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/system/base/types.scm b/module/system/base/types.scm index 73681715e..0e7371baa 100644 --- a/module/system/base/types.scm +++ b/module/system/base/types.scm @@ -444,7 +444,7 @@ using BACKEND." ('big "UTF-32BE"))))) (((_ & #x7f = %tc7-bytevector) len address) (let ((bv-port (memory-port backend address len))) - (get-bytevector-all bv-port))) + (get-bytevector-n bv-port len))) ((((len << 8) || %tc7-vector)) (let ((words (get-bytevector-n port (* len %word-size))) (vector (make-vector len))) From 82357f7bd875afce351a2965a15baabf864338e3 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 28 Mar 2015 16:01:23 -0400 Subject: [PATCH 305/865] Add more R6RS port encoding tests Originally applied to stable-2.0 as "Fix bytevector and custom binary ports to actually use ISO-8859-1 encoding.", commit d574d96f879c147c6c14df43f2e4ff9e8a6876b9. Related to http://bugs.gnu.org/20200, which was introduced in in stable-2.0 but never existed on master. Test modified by Andy Wingo to add a `force-output' where needed. * test-suite/tests/r6rs-ports.test: Add tests. --- test-suite/tests/r6rs-ports.test | 47 ++++++++++++++++++++++++++++++++ 1 file changed, 47 insertions(+) diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index 1441daf1b..4941dd718 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -356,6 +356,11 @@ (with-fluids ((%default-port-encoding "UTF-8")) (binary-port? (open-bytevector-input-port #vu8(1 2 3))))) + (pass-if-equal "bytevector-input-port uses ISO-8859-1 (Guile extension)" + "©©" + (with-fluids ((%default-port-encoding "UTF-8")) + (get-string-all (open-bytevector-input-port #vu8(194 169 194 169))))) + (pass-if-exception "bytevector-input-port is read-only" exception:wrong-type-arg @@ -416,6 +421,23 @@ (input-port? port) (bytevector=? (get-bytevector-all port) source)))) + (pass-if-equal "make-custom-binary-input-port uses ISO-8859-1 (Guile extension)" + "©©" + (with-fluids ((%default-port-encoding "UTF-8")) + (let* ((source #vu8(194 169 194 169)) + (read! (let ((pos 0) + (len (bytevector-length source))) + (lambda (bv start count) + (let ((amount (min count (- len pos)))) + (if (> amount 0) + (bytevector-copy! source pos + bv start amount)) + (set! pos (+ pos amount)) + amount)))) + (port (make-custom-binary-input-port "the port" read! + #f #f #f))) + (get-string-all port)))) + (pass-if "custom binary input port does not support `port-position'" (let* ((str "Hello Port!") (source (open-bytevector-input-port @@ -716,6 +738,14 @@ not `set-port-position!'" (pass-if "bytevector-output-port is binary" (binary-port? (open-bytevector-output-port))) + (pass-if-equal "bytevector-output-port uses ISO-8859-1 (Guile extension)" + #vu8(194 169 194 169) + (with-fluids ((%default-port-encoding "UTF-8")) + (let-values (((port get-content) + (open-bytevector-output-port))) + (put-string port "©©") + (get-content)))) + (pass-if "open-bytevector-output-port [extract after close]" (let-values (((port get-content) (open-bytevector-output-port))) @@ -819,6 +849,23 @@ not `set-port-position!'" (not eof?) (bytevector=? sink source)))) + (pass-if-equal "custom-binary-output-port uses ISO-8859-1 (Guile extension)" + '(194 169 194 169) + (with-fluids ((%default-port-encoding "UTF-8")) + (let* ((sink '()) + (write! (lambda (bv start count) + (if (= 0 count) ; EOF + 0 + (let ((u8 (bytevector-u8-ref bv start))) + ;; Get one byte at a time. + (set! sink (cons u8 sink)) + 1)))) + (port (make-custom-binary-output-port "cbop" write! + #f #f #f))) + (put-string port "©©") + (force-output port) + (reverse sink)))) + (pass-if "standard-output-port is binary" (with-fluids ((%default-port-encoding "UTF-8")) (binary-port? (standard-output-port)))) From 93c3b060c16242f069d74123b9629d6df2bc2c73 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 3 Apr 2015 16:35:54 +0200 Subject: [PATCH 306/865] doc: Update libgc URL. * doc/ref/data-rep.texi (Conservative GC): Update libgc URL. --- doc/ref/data-rep.texi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/ref/data-rep.texi b/doc/ref/data-rep.texi index d0a76e9be..bb7f74afe 100644 --- a/doc/ref/data-rep.texi +++ b/doc/ref/data-rep.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2010 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2010, 2015 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -339,7 +339,7 @@ actually garbage, and should be freed. In practice, this is not a problem. The alternative, an explicitly maintained list of local variable addresses, is effectively much less reliable, due to programmer error. Interested readers should see the BDW-GC web page at -@uref{http://www.hpl.hp.com/personal/Hans_Boehm/gc}, for more +@uref{http://www.hboehm.info/gc/}, for more information. From e7cde8be9e3ddb66a09b8c914e5d58fa8e37d5ad Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Fri, 12 Jun 2015 19:30:17 +0300 Subject: [PATCH 307/865] Fix typo in manual. * doc/ref/api-modules.texi (Using Guile Modules): Remove extra "yet". --- doc/ref/api-modules.texi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/ref/api-modules.texi b/doc/ref/api-modules.texi index 4c46f2984..8f18b1e62 100644 --- a/doc/ref/api-modules.texi +++ b/doc/ref/api-modules.texi @@ -171,8 +171,8 @@ of @code{@@} and should only be used as a last resort or for debugging, for example. Note that just as with a @code{use-modules} statement, any module that -has not yet been loaded yet will be loaded when referenced by a -@code{@@} or @code{@@@@} form. +has not yet been loaded will be loaded when referenced by a @code{@@} or +@code{@@@@} form. You can also use the @code{@@} and @code{@@@@} syntaxes as the target of a @code{set!} when the binding refers to a variable. From 96b299045fff0304b7ffc5304b85129cdd78f322 Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Sun, 14 Jun 2015 19:09:34 +0300 Subject: [PATCH 308/865] Fix typo in the man page. * doc/guile.1: "--no-autocompile" -> "--no-auto-compile". --- doc/guile.1 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/guile.1 b/doc/guile.1 index 5d8b4e158..7b3d23292 100644 --- a/doc/guile.1 +++ b/doc/guile.1 @@ -125,7 +125,7 @@ is being run interactively. Compile source files automatically (default behavior). . .TP -.B --no-autocompile +.B --no-auto-compile Disable automatic source file compilation. . .TP From 7413430fd742bbe867f5f1358e729514b5a08973 Mon Sep 17 00:00:00 2001 From: Natanael Copa Date: Mon, 15 Jun 2015 10:05:41 +0200 Subject: [PATCH 309/865] i18n: Check for non-POSIX strtol_l. * configure.ac: Check for strtol_l. * libguile/i18n.c: Check HAVE_STRTOL_L before using strtol_l. --- configure.ac | 5 +++-- libguile/i18n.c | 2 +- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/configure.ac b/configure.ac index 0eb2368ec..3a8f77291 100644 --- a/configure.ac +++ b/configure.ac @@ -752,6 +752,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h]) # isblank - available as a GNU extension or in C99 # _NSGetEnviron - Darwin specific # strcoll_l, newlocale, uselocale, utimensat - POSIX.1-2008 +# strtol_l - non-POSIX, found in glibc # fork - unavailable on Windows # sched_getaffinity, sched_setaffinity - GNU extensions (glibc) # sendfile - non-POSIX, found in glibc @@ -765,8 +766,8 @@ AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \ strdup system usleep atexit on_exit chown link fcntl ttyname getpwent \ getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp \ index bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron \ - strcoll strcoll_l newlocale uselocale utimensat sched_getaffinity \ - sched_setaffinity sendfile]) + strcoll strcoll_l strtol_l newlocale uselocale utimensat \ + sched_getaffinity sched_setaffinity sendfile]) # Reasons for testing: # netdb.h - not in mingw diff --git a/libguile/i18n.c b/libguile/i18n.c index f0e344329..17e9eca61 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -1373,7 +1373,7 @@ SCM_DEFINE (scm_locale_string_to_integer, "locale-string->integer", if (c_locale != NULL) { -#ifdef USE_GNU_LOCALE_API +#if defined(USE_GNU_LOCALE_API) && defined(HAVE_STRTOL_L) c_result = strtol_l (c_str, &c_endptr, c_base, c_locale); #else RUN_IN_LOCALE_SECTION (c_locale, From ea8fa622ecc6e05520c21616b52949049d94f8a0 Mon Sep 17 00:00:00 2001 From: Mathieu Lirzin Date: Fri, 15 May 2015 13:27:54 +0200 Subject: [PATCH 310/865] doc: Fix parameter of 'set-record-type-printer!'. * doc/ref/api-compound.texi (SRFI-9 Records)[set-record-type-printer!]: Fix parameter name. --- doc/ref/api-compound.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index 8ec32d687..b4ae79c26 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -2322,7 +2322,7 @@ You may use @code{set-record-type-printer!} to customize the default printing behavior of records. This is a Guile extension and is not part of SRFI-9. It is located in the @nicode{(srfi srfi-9 gnu)} module. -@deffn {Scheme Syntax} set-record-type-printer! name proc +@deffn {Scheme Syntax} set-record-type-printer! type proc Where @var{type} corresponds to the first argument of @code{define-record-type}, and @var{proc} is a procedure accepting two arguments, the record to print, and an output port. From aa13da51892de89d3acdb84dce11699597a9fe05 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 22 Jul 2015 20:56:18 -0400 Subject: [PATCH 311/865] Fix atan procedure when applied to complex numbers. Fixes a regression introduced in commit ad79736c68a803a59814fbfc0cb4b092c2b4cddf. * libguile/numbers.c (scm_atan): Fix the complex case. * test-suite/tests/numbers.test ("atan"): Add test. --- libguile/numbers.c | 4 ++-- test-suite/tests/numbers.test | 7 ++++--- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 9cc72d269..d0f6e628d 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -8993,8 +8993,8 @@ SCM_PRIMITIVE_GENERIC (scm_atan, "atan", 1, 1, 0, double v, w; v = SCM_COMPLEX_REAL (z); w = SCM_COMPLEX_IMAG (z); - return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (v, w - 1.0), - scm_c_make_rectangular (v, w + 1.0))), + return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (-v, 1.0 - w), + scm_c_make_rectangular ( v, 1.0 + w))), scm_c_make_rectangular (0, 2)); } else diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 847f93962..0adf21637 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -1,6 +1,6 @@ ;;;; numbers.test --- tests guile's numbers -*- scheme -*- -;;;; Copyright (C) 2000, 2001, 2003, 2004, 2005, 2006, 2009, 2010, 2011, -;;;; 2012, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 2000, 2001, 2003-2006, 2009-2013, +;;;; 2015 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 @@ -4467,7 +4467,8 @@ (pass-if (eqv? 0 (atan 0))) (pass-if (eqv? 0.0 (atan 0.0))) (pass-if (eqv-loosely? 1.57 (atan +inf.0))) - (pass-if (eqv-loosely? -1.57 (atan -inf.0)))) + (pass-if (eqv-loosely? -1.57 (atan -inf.0))) + (pass-if (eqv-loosely? -1.42+0.5i (atan -0.5+2.0i)))) ;;; ;;; sinh From d77247b90b836e149b58e9efccdd9861a28a7576 Mon Sep 17 00:00:00 2001 From: Andreas Rottmann Date: Tue, 28 Jul 2015 23:06:36 +0200 Subject: [PATCH 312/865] Heed the reader settings implied by #!r6rs When encountering the #!r6rs directive, apply the appropriate reader settings to the port. * libguile/read.scm (read-string-as-list): New helper procedure. (scm_read_shebang): Set reader options implied by the R6RS syntax upon encountering the #!r6rs directive. * test-suite/tests/reader.test (per-port-read-options): Add tests for the #!r6rs directive. --- NEWS | 20 ++++++++++++++++ libguile/read.c | 40 ++++++++++++++++++++++++++++++-- test-suite/tests/reader.test | 45 +++++++++++++++++++++++++++++++----- 3 files changed, 97 insertions(+), 8 deletions(-) diff --git a/NEWS b/NEWS index e887ec447..8d2ec86fb 100644 --- a/NEWS +++ b/NEWS @@ -738,6 +738,26 @@ longer installed to the libdir. This change should be transparent to users, but packagers may be interested. + +Changes in 2.0.12 (since 2.0.11): + +[Note: these changes come to 2.2 via 2.0 branch, but 2.0.12 hasn't been +released yet at the time of this writing.] + +* Notable changes + +** The #!r6rs directive now influences read syntax + +The #!r6rs directive now changes the per-port reader options to make +Guile's reader conform more closely to the R6RS syntax. In particular: + +- It makes the reader case sensitive. +- It disables the recognition of keyword syntax in conflict with the + R6RS (and R5RS). +- It enables the `square-brackets', `hungry-eol-escapes' and + `r6rs-hex-escapes' reader options. + + Changes in 2.0.11 (since 2.0.10): diff --git a/libguile/read.c b/libguile/read.c index afad5975a..c724fbbc8 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995-1997, 1999-2001, 2003, 2004, 2006-2012, 2014 +/* Copyright (C) 1995-1997, 1999-2001, 2003, 2004, 2006-2012, 2014, 2015 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -1430,6 +1430,12 @@ static void set_port_square_brackets_p (SCM port, scm_t_read_opts *opts, int value); static void set_port_curly_infix_p (SCM port, scm_t_read_opts *opts, int value); +static void set_port_r6rs_hex_escapes_p (SCM port, scm_t_read_opts *opts, + int value); +static void set_port_hungry_eol_escapes_p (SCM port, scm_t_read_opts *opts, + int value); +static void set_port_keyword_style (SCM port, scm_t_read_opts *opts, + enum t_keyword_style value); static SCM scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) @@ -1451,7 +1457,13 @@ scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) scm_ungetc (c, port); name[i] = '\0'; if (0 == strcmp ("r6rs", name)) - ; /* Silently ignore */ + { + set_port_case_insensitive_p (port, opts, 0); + set_port_r6rs_hex_escapes_p (port, opts, 1); + set_port_square_brackets_p (port, opts, 1); + set_port_keyword_style (port, opts, KEYWORD_STYLE_HASH_PREFIX); + set_port_hungry_eol_escapes_p (port, opts, 1); + } else if (0 == strcmp ("fold-case", name)) set_port_case_insensitive_p (port, opts, 1); else if (0 == strcmp ("no-fold-case", name)) @@ -2299,6 +2311,30 @@ set_port_curly_infix_p (SCM port, scm_t_read_opts *opts, int value) set_port_read_option (port, READ_OPTION_CURLY_INFIX_P, value); } +/* Set OPTS and PORT's r6rs_hex_escapes_p option according to VALUE. */ +static void +set_port_r6rs_hex_escapes_p (SCM port, scm_t_read_opts *opts, int value) +{ + value = !!value; + opts->r6rs_escapes_p = value; + set_port_read_option (port, READ_OPTION_R6RS_ESCAPES_P, value); +} + +static void +set_port_hungry_eol_escapes_p (SCM port, scm_t_read_opts *opts, int value) +{ + value = !!value; + opts->hungry_eol_escapes_p = value; + set_port_read_option (port, READ_OPTION_HUNGRY_EOL_ESCAPES_P, value); +} + +static void +set_port_keyword_style (SCM port, scm_t_read_opts *opts, enum t_keyword_style value) +{ + opts->keyword_style = value; + set_port_read_option (port, READ_OPTION_KEYWORD_STYLE, value); +} + /* Initialize OPTS based on PORT's read options and the global read options. */ static void diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test index 5eb368d9b..a931f0416 100644 --- a/test-suite/tests/reader.test +++ b/test-suite/tests/reader.test @@ -60,6 +60,11 @@ (lambda () (read-options saved-options))))) +(define (read-string-as-list s) + (with-input-from-string s + (lambda () + (unfold eof-object? values (lambda (x) (read)) (read))))) + (with-test-prefix "reading" (pass-if "0" @@ -432,14 +437,42 @@ (equal? '(guile GuiLe gUIle) (with-read-options '(case-insensitive) (lambda () - (with-input-from-string "GUIle #!no-fold-case GuiLe gUIle" - (lambda () - (list (read) (read) (read)))))))) + (read-string-as-list "GUIle #!no-fold-case GuiLe gUIle"))))) (pass-if "case-insensitive" (equal? '(GUIle guile guile) - (with-input-from-string "GUIle #!fold-case GuiLe gUIle" - (lambda () - (list (read) (read) (read))))))) + (read-string-as-list "GUIle #!fold-case GuiLe gUIle"))) + (with-test-prefix "r6rs" + (pass-if-equal "case sensitive" + '(guile GuiLe gUIle) + (with-read-options '(case-insensitive) + (lambda () + (read-string-as-list "GUIle #!r6rs GuiLe gUIle")))) + (pass-if-equal "square brackets" + '((a b c) (foo 42 bar) (x . y)) + (read-string-as-list "(a b c) #!r6rs [foo 42 bar] [x . y]")) + (pass-if-equal "hex string escapes" + '("native\x7fsyntax" + "\0" + "ascii\x7fcontrol" + "U\u0100BMP" + "U\U010402SMP") + (read-string-as-list (string-append "\"native\\x7fsyntax\" " + "#!r6rs " + "\"\\x0;\" " + "\"ascii\\x7f;control\" " + "\"U\\x100;BMP\" " + "\"U\\x10402;SMP\""))) + (with-test-prefix "keyword style" + (pass-if-equal "postfix disabled" + '(#:regular #:postfix postfix: #:regular2) + (with-read-options '(keywords postfix) + (lambda () + (read-string-as-list "#:regular postfix: #!r6rs postfix: #:regular2")))) + (pass-if-equal "prefix disabled" + '(#:regular #:prefix :prefix #:regular2) + (with-read-options '(keywords prefix) + (lambda () + (read-string-as-list "#:regular :prefix #!r6rs :prefix #:regular2"))))))) (with-test-prefix "#;" (for-each From 3cf70e36f11b211fc2fa88bf4ecc59a6f8812bc3 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 2 Sep 2015 13:51:05 -0400 Subject: [PATCH 313/865] Fix uses of 'scm_gc_protect', which does not exist, in the manual. * doc/ref/api-memory.texi (Garbage Collection Functions), doc/ref/libguile-concepts.texi (Garbage Collection): Change 'scm_gc_protect' --> 'scm_gc_protect_object'. --- doc/ref/api-memory.texi | 4 ++-- doc/ref/libguile-concepts.texi | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/doc/ref/api-memory.texi b/doc/ref/api-memory.texi index 0e37d16fc..a2a27e43b 100644 --- a/doc/ref/api-memory.texi +++ b/doc/ref/api-memory.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010, 2012, 2013, 2014 +@c Copyright (C) 1996, 1997, 2000-2004, 2009, 2010, 2012-2016 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -36,7 +36,7 @@ explicitly. It is called automatically when appropriate. Protects @var{obj} from being freed by the garbage collector, when it otherwise might be. When you are done with the object, call @code{scm_gc_unprotect_object} on the object. Calls to -@code{scm_gc_protect}/@code{scm_gc_unprotect_object} can be nested, and +@code{scm_gc_protect_object}/@code{scm_gc_unprotect_object} can be nested, and the object remains protected until it has been unprotected as many times as it was protected. It is an error to unprotect an object more times than it has been protected. Returns the SCM object it was passed. diff --git a/doc/ref/libguile-concepts.texi b/doc/ref/libguile-concepts.texi index 9e2eb7503..9785f4d6f 100644 --- a/doc/ref/libguile-concepts.texi +++ b/doc/ref/libguile-concepts.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010, -@c 2011, 2013, 2014 Free Software Foundation, Inc. +@c Copyright (C) 1996-1997, 2000-2005, 2010-2011, 2013-2016 +@c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node General Libguile Concepts @@ -197,7 +197,7 @@ sections, function arguments or local variables on the C and Scheme stacks, and values in machine registers. Other references to @code{SCM} objects, such as those in other random data structures in the C heap that contain fields of type @code{SCM}, can be made visible to the -garbage collector by calling the functions @code{scm_gc_protect} or +garbage collector by calling the functions @code{scm_gc_protect_object} or @code{scm_permanent_object}. Collectively, these values form the ``root set'' of garbage collection; any value on the heap that is referenced directly or indirectly by a member of the root set is preserved, and all From a04c849b096f01f2a73d3a9e7b395ca4c7f8df41 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?= Date: Sun, 30 Aug 2015 10:24:52 +0200 Subject: [PATCH 314/865] Clarify datum->syntax documentation. * doc/ref/api-macros.texi (Syntax Case): Make it clear that the first argument to datum->syntax must be an identifier. --- doc/ref/api-macros.texi | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi index 9964e6b06..ef0621415 100644 --- a/doc/ref/api-macros.texi +++ b/doc/ref/api-macros.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010, 2011, -@c 2012, 2013, 2014 Free Software Foundation, Inc. +@c Copyright (C) 1996, 1997, 2000-2004, 2009-2015 +@c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Macros @@ -618,9 +618,9 @@ won't have access to the binding of @code{it}. But they can, if we explicitly introduce a binding via @code{datum->syntax}. -@deffn {Scheme Procedure} datum->syntax for-syntax datum +@deffn {Scheme Procedure} datum->syntax template-id datum Create a syntax object that wraps @var{datum}, within the lexical context -corresponding to the syntax object @var{for-syntax}. +corresponding to the identifier @var{template-id}. @end deffn For completeness, we should mention that it is possible to strip the metadata From bb7075dc1a9084305160b690ad918cf98401e1dd Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 3 Sep 2015 02:51:00 -0400 Subject: [PATCH 315/865] psyntax: Fix bug in match-each+. Reported by Panicz Maciej Godek in . * module/ice-9/psyntax.scm (match-each+): Fix the case where a non-pair syntax object is encountered in a dotted tail. * module/ice-9/psyntax-pp.scm: Regenerate. --- module/ice-9/psyntax-pp.scm | 3 ++- module/ice-9/psyntax.scm | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 0d30b7c3f..3cd6035f7 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -2509,7 +2509,8 @@ (values '() (cdr y-pat) (match (car e) (car y-pat) w r mod))) (values #f #f #f))))) ((syntax-object? e) - (f (syntax-object-expression e) (join-wraps w e))) + (f (syntax-object-expression e) + (join-wraps w (syntax-object-wrap e)))) (else (values '() y-pat (match e z-pat w r mod))))))) (match-each-any (lambda (e w mod) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 0bc602431..a45353aa3 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -2849,7 +2849,8 @@ (match (car e) (car y-pat) w r mod))) (values #f #f #f))))) ((syntax-object? e) - (f (syntax-object-expression e) (join-wraps w e))) + (f (syntax-object-expression e) + (join-wraps w (syntax-object-wrap e)))) (else (values '() y-pat (match e z-pat w r mod))))))) From b6c1018d9696b8b9e0117932a15d9bd07c8a8351 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Sun, 30 Aug 2015 10:58:42 +0200 Subject: [PATCH 316/865] doc: Add SXPath documentation from sources MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . * doc/ref/sxml.texi (SXPath): Add procedure documentation from sources. Signed-off-by: Ludovic Courtès --- doc/ref/sxml.texi | 302 ++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 267 insertions(+), 35 deletions(-) diff --git a/doc/ref/sxml.texi b/doc/ref/sxml.texi index 75867f3a6..03f0324f6 100644 --- a/doc/ref/sxml.texi +++ b/doc/ref/sxml.texi @@ -3,6 +3,10 @@ @c Copyright (C) 2013 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. +@c SXPath documentation based on SXPath.scm by Oleg Kiselyov, +@c which is in the public domain according to +@c and . + @node SXML @section SXML @@ -250,8 +254,8 @@ internal and external parsed entities, user-controlled handling of whitespace, and validation. This module therefore is intended to be a framework, a set of ``Lego blocks'' you can use to build a parser following any discipline and performing validation to any degree. As an -example of the parser construction, this file includes a semi-validating -SXML parser. +example of the parser construction, the source file includes a +semi-validating SXML parser. SSAX has a ``sequential'' feel of SAX yet a ``functional style'' of DOM. Like a SAX parser, the framework scans the document only once and @@ -725,95 +729,323 @@ location path is a relative path applied to the root node. Similarly to XPath, SXPath defines full and abbreviated notations for location paths. In both cases, the abbreviated notation can be mechanically expanded into the full form by simple rewriting rules. In -case of SXPath the corresponding rules are given as comments to a sxpath -function, below. The regression test suite at the end of this file shows -a representative sample of SXPaths in both notations, juxtaposed with -the corresponding XPath expressions. Most of the samples are borrowed -literally from the XPath specification, while the others are adjusted -for our running example, tree1. +the case of SXPath the corresponding rules are given in the +documentation of the @code{sxpath} procedure. +@xref{sxpath-procedure-docs,,SXPath procedure documentation}. + +The regression test suite at the end of the file @file{SXPATH-old.scm} +shows a representative sample of SXPaths in both notations, juxtaposed +with the corresponding XPath expressions. Most of the samples are +borrowed literally from the XPath specification. + +Much of the following material is taken from the SXPath sources by Oleg +Kiselyov et al. + +@subsubsection Basic Converters and Applicators + +A converter is a function mapping a nodeset (or a single node) to another +nodeset. Its type can be represented like this: + +@example +type Converter = Node|Nodeset -> Nodeset +@end example + +A converter can also play the role of a predicate: in that case, if a +converter, applied to a node or a nodeset, yields a non-empty nodeset, +the converter-predicate is deemed satisfied. Likewise, an empty nodeset +is equivalent to @code{#f} in denoting failure. -@subsubsection Usage @deffn {Scheme Procedure} nodeset? x +Return @code{#t} if @var{x} is a nodeset. @end deffn @deffn {Scheme Procedure} node-typeof? crit +This function implements a 'Node test' as defined in Sec. 2.3 of the +XPath document. A node test is one of the components of a location +step. It is also a converter-predicate in SXPath. + +The function @code{node-typeof?} takes a type criterion and returns a +function, which, when applied to a node, will tell if the node satisfies +the test. + +The criterion @var{crit} is a symbol, one of the following: + +@table @code +@item id +tests if the node has the right name (id) + +@item @@ +tests if the node is an + +@item * +tests if the node is an + +@item *text* +tests if the node is a text node + +@item *PI* +tests if the node is a PI (processing instruction) node + +@item *any* +@code{#t} for any type of node +@end table @end deffn @deffn {Scheme Procedure} node-eq? other +A curried equivalence converter predicate that takes a node @var{other} +and returns a function that takes another node. The two nodes are +compared using @code{eq?}. @end deffn @deffn {Scheme Procedure} node-equal? other +A curried equivalence converter predicate that takes a node @var{other} +and returns a function that takes another node. The two nodes are +compared using @code{equal?}. @end deffn @deffn {Scheme Procedure} node-pos n +Select the @var{n}'th element of a nodeset and return as a singular +nodeset. If the @var{n}'th element does not exist, return an empty +nodeset. If @var{n} is a negative number the node is picked from the +tail of the list. + +@example +((node-pos 1) nodeset) ; return the the head of the nodeset (if exists) +((node-pos 2) nodeset) ; return the node after that (if exists) +((node-pos -1) nodeset) ; selects the last node of a non-empty nodeset +((node-pos -2) nodeset) ; selects the last but one node, if exists. +@end example @end deffn @deffn {Scheme Procedure} filter pred? -@verbatim - -- Scheme Procedure: filter pred list - Return all the elements of 2nd arg LIST that satisfy predicate - PRED. The list is not disordered - elements that appear in the - result list occur in the same order as they occur in the argument - list. The returned list may share a common tail with the argument - list. The dynamic order in which the various applications of pred - are made is not specified. - - (filter even? '(0 7 8 8 43 -4)) => (0 8 8 -4) - - -@end verbatim +A filter applicator, which introduces a filtering context. The argument +converter @var{pred?} is considered a predicate, with either @code{#f} +or @code{nil} meaning failure. @end deffn @deffn {Scheme Procedure} take-until pred? +@example +take-until:: Converter -> Converter, or +take-until:: Pred -> Node|Nodeset -> Nodeset +@end example + +Given a converter-predicate @var{pred?} and a nodeset, apply the +predicate to each element of the nodeset, until the predicate yields +anything but @code{#f} or @code{nil}. Return the elements of the input +nodeset that have been processed until that moment (that is, which fail +the predicate). + +@code{take-until} is a variation of the @code{filter} above: +@code{take-until} passes elements of an ordered input set up to (but not +including) the first element that satisfies the predicate. The nodeset +returned by @code{((take-until (not pred)) nset)} is a subset -- to be +more precise, a prefix -- of the nodeset returned by @code{((filter +pred) nset)}. @end deffn @deffn {Scheme Procedure} take-after pred? +@example +take-after:: Converter -> Converter, or +take-after:: Pred -> Node|Nodeset -> Nodeset +@end example + +Given a converter-predicate @var{pred?} and a nodeset, apply the +predicate to each element of the nodeset, until the predicate yields +anything but @code{#f} or @code{nil}. Return the elements of the input +nodeset that have not been processed: that is, return the elements of +the input nodeset that follow the first element that satisfied the +predicate. + +@code{take-after} along with @code{take-until} partition an input +nodeset into three parts: the first element that satisfies a predicate, +all preceding elements and all following elements. @end deffn @deffn {Scheme Procedure} map-union proc lst +Apply @var{proc} to each element of @var{lst} and return the list of results. +If @var{proc} returns a nodeset, splice it into the result + +From another point of view, @code{map-union} is a function +@code{Converter->Converter}, which places an argument-converter in a joining +context. @end deffn @deffn {Scheme Procedure} node-reverse node-or-nodeset +@example +node-reverse :: Converter, or +node-reverse:: Node|Nodeset -> Nodeset +@end example + +Reverses the order of nodes in the nodeset. This basic converter is +needed to implement a reverse document order (see the XPath +Recommendation). @end deffn @deffn {Scheme Procedure} node-trace title +@example +node-trace:: String -> Converter +@end example + +@code{(node-trace title)} is an identity converter. In addition it +prints out the node or nodeset it is applied to, prefixed with the +@var{title}. This converter is very useful for debugging. @end deffn +@subsubsection Converter Combinators + +Combinators are higher-order functions that transmogrify a converter or +glue a sequence of converters into a single, non-trivial converter. The +goal is to arrive at converters that correspond to XPath location paths. + +From a different point of view, a combinator is a fixed, named +@dfn{pattern} of applying converters. Given below is a complete set of +such patterns that together implement XPath location path specification. +As it turns out, all these combinators can be built from a small number +of basic blocks: regular functional composition, @code{map-union} and +@code{filter} applicators, and the nodeset union. + @deffn {Scheme Procedure} select-kids test-pred? +@code{select-kids} takes a converter (or a predicate) as an argument and +returns another converter. The resulting converter applied to a nodeset +returns an ordered subset of its children that satisfy the predicate +@var{test-pred?}. @end deffn @deffn {Scheme Procedure} node-self pred? -@verbatim - -- Scheme Procedure: filter pred list - Return all the elements of 2nd arg LIST that satisfy predicate - PRED. The list is not disordered - elements that appear in the - result list occur in the same order as they occur in the argument - list. The returned list may share a common tail with the argument - list. The dynamic order in which the various applications of pred - are made is not specified. - - (filter even? '(0 7 8 8 43 -4)) => (0 8 8 -4) - - -@end verbatim +Similar to @code{select-kids} except that the predicate @var{pred?} is +applied to the node itself rather than to its children. The resulting +nodeset will contain either one component, or will be empty if the node +failed the predicate. @end deffn @deffn {Scheme Procedure} node-join . selectors +@example +node-join:: [LocPath] -> Node|Nodeset -> Nodeset, or +node-join:: [Converter] -> Converter +@end example + +Join the sequence of location steps or paths as described above. @end deffn @deffn {Scheme Procedure} node-reduce . converters +@example +node-reduce:: [LocPath] -> Node|Nodeset -> Nodeset, or +node-reduce:: [Converter] -> Converter +@end example + +A regular functional composition of converters. From a different point +of view, @code{((apply node-reduce converters) nodeset)} is equivalent +to @code{(foldl apply nodeset converters)}, i.e., folding, or reducing, +a list of converters with the nodeset as a seed. @end deffn @deffn {Scheme Procedure} node-or . converters +@example +node-or:: [Converter] -> Converter +@end example + +This combinator applies all converters to a given node and produces the +union of their results. This combinator corresponds to a union +(@code{|} operation) for XPath location paths. @end deffn @deffn {Scheme Procedure} node-closure test-pred? +@example +node-closure:: Converter -> Converter +@end example + +Select all @emph{descendants} of a node that satisfy a +converter-predicate @var{test-pred?}. This combinator is similar to +@code{select-kids} but applies to grand... children as well. This +combinator implements the @code{descendant::} XPath axis. Conceptually, +this combinator can be expressed as + +@example +(define (node-closure f) + (node-or + (select-kids f) + (node-reduce (select-kids (node-typeof? '*)) (node-closure f)))) +@end example + +This definition, as written, looks somewhat like a fixpoint, and it will +run forever. It is obvious however that sooner or later +@code{(select-kids (node-typeof? '*))} will return an empty nodeset. At +this point further iterations will no longer affect the result and can +be stopped. @end deffn @deffn {Scheme Procedure} node-parent rootnode +@example +node-parent:: RootNode -> Converter +@end example + +@code{(node-parent rootnode)} yields a converter that returns a parent +of a node it is applied to. If applied to a nodeset, it returns the +list of parents of nodes in the nodeset. The @var{rootnode} does not +have to be the root node of the whole SXML tree -- it may be a root node +of a branch of interest. + +Given the notation of Philip Wadler's paper on semantics of XSLT, + +@verbatim + parent(x) = { y | y=subnode*(root), x=subnode(y) } +@end verbatim + +Therefore, @code{node-parent} is not the fundamental converter: it can +be expressed through the existing ones. Yet @code{node-parent} is a +rather convenient converter. It corresponds to a @code{parent::} axis +of SXPath. Note that the @code{parent::} axis can be used with an +attribute node as well. @end deffn +@anchor{sxpath-procedure-docs} @deffn {Scheme Procedure} sxpath path +Evaluate an abbreviated SXPath. + +@example +sxpath:: AbbrPath -> Converter, or +sxpath:: AbbrPath -> Node|Nodeset -> Nodeset +@end example + +@var{path} is a list. It is translated to the full SXPath according to +the following rewriting rules: + +@example +(sxpath '()) +@result{} (node-join) + +(sxpath '(path-component ...)) +@result{} (node-join (sxpath1 path-component) (sxpath '(...))) + +(sxpath1 '//) +@result{} (node-or + (node-self (node-typeof? '*any*)) + (node-closure (node-typeof? '*any*))) + +(sxpath1 '(equal? x)) +@result{} (select-kids (node-equal? x)) + +(sxpath1 '(eq? x)) +@result{} (select-kids (node-eq? x)) + +(sxpath1 ?symbol) +@result{} (select-kids (node-typeof? ?symbol) + +(sxpath1 procedure) +@result{} procedure + +(sxpath1 '(?symbol ...)) +@result{} (sxpath1 '((?symbol) ...)) + +(sxpath1 '(path reducer ...)) +@result{} (node-reduce (sxpath path) (sxpathr reducer) ...) + +(sxpathr number) +@result{} (node-pos number) + +(sxpathr path-filter) +@result{} (filter (sxpath path-filter)) +@end example @end deffn @node sxml ssax input-parse From e8d3733521a86da201528d4a34d6fd894b090d51 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 4 Sep 2015 22:44:06 +0200 Subject: [PATCH 317/865] doc: Fix menu order for SXML. * doc/ref/sxml.texi (SXML): Add missing quotes in example. Fix node order in menu. --- doc/ref/sxml.texi | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/doc/ref/sxml.texi b/doc/ref/sxml.texi index 03f0324f6..17c3d01b7 100644 --- a/doc/ref/sxml.texi +++ b/doc/ref/sxml.texi @@ -21,7 +21,7 @@ fragment: may be represented with the following SXML: @example -(parrot (@@ (type "African Grey)) (name "Alfie")) +(parrot (@@ (type "African Grey")) (name "Alfie")) @end example SXML is very general, and is capable of representing all of XML. @@ -32,14 +32,14 @@ Guile includes several facilities for working with XML and SXML: parsers, serializers, and transformers. @menu -* SXML Overview:: XML, as it was meant to be -* Reading and Writing XML:: Convenient XML parsing and serializing -* SSAX:: Custom functional-style XML parsers -* Transforming SXML:: Munging SXML with @code{pre-post-order} -* SXML Tree Fold:: Fold-based SXML transformations -* SXPath:: XPath for SXML -* sxml apply-templates:: A more XSLT-like approach to SXML transformations -* sxml ssax input-parse:: The SSAX tokenizer, optimized for Guile +* SXML Overview:: XML, as it was meant to be +* Reading and Writing XML:: Convenient XML parsing and serializing +* SSAX:: Custom functional-style XML parsers +* Transforming SXML:: Munging SXML with @code{pre-post-order} +* SXML Tree Fold:: Fold-based SXML transformations +* SXPath:: XPath for SXML +* sxml ssax input-parse:: The SSAX tokenizer, optimized for Guile +* sxml apply-templates:: A more XSLT-like approach to SXML transformations @end menu @node SXML Overview From 013e69838c1b424a924c531399aa475d4a241b6e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 4 Sep 2015 22:53:59 +0200 Subject: [PATCH 318/865] Thank Ricardo. --- THANKS | 1 + 1 file changed, 1 insertion(+) diff --git a/THANKS b/THANKS index d5e8222fb..fbb15ada2 100644 --- a/THANKS +++ b/THANKS @@ -199,6 +199,7 @@ For fixes or providing information which led to a fix: Jon Wilson Andy Wingo Keith Wright + Ricardo Wurmus William Xu Atom X Zane From d52edc05d3ef565446f4710f3bf275b340eccc10 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 10 Sep 2015 22:20:54 +0200 Subject: [PATCH 319/865] web: Fix 'close' method of delimited input ports. * module/web/response.scm (make-delimited-input-port)[close]: Replace erroneous self-recursive call with a call to 'close-port'. * test-suite/tests/web-response.test ("example-1")["response-body-port + close"]: New test. --- module/web/response.scm | 4 ++-- test-suite/tests/web-response.test | 14 ++++++++++++-- 2 files changed, 14 insertions(+), 4 deletions(-) diff --git a/module/web/response.scm b/module/web/response.scm index 58e3f1141..614abcd55 100644 --- a/module/web/response.scm +++ b/module/web/response.scm @@ -1,6 +1,6 @@ ;;; HTTP response objects -;; Copyright (C) 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011, 2012, 2013, 2014, 2015 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 @@ -265,7 +265,7 @@ closes PORT, unless KEEP-ALIVE? is true." (define close (and (not keep-alive?) (lambda () - (close port)))) + (close-port port)))) (make-custom-binary-input-port "delimited input port" read! #f #f close)) diff --git a/test-suite/tests/web-response.test b/test-suite/tests/web-response.test index 3c1894e13..848a7265a 100644 --- a/test-suite/tests/web-response.test +++ b/test-suite/tests/web-response.test @@ -1,6 +1,6 @@ ;;;; web-response.test --- HTTP responses -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;;;; Copyright (C) 2010-2016 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 @@ -119,7 +119,17 @@ consectetur adipisicing elit,\r (with-fluids ((%default-port-encoding #f)) (let* ((r (read-response (open-input-string example-1))) (p (response-body-port r))) - (list (port-encoding p) (get-bytevector-all p))))))) + (list (port-encoding p) (get-bytevector-all p))))) + + (pass-if "response-body-port + close" + (with-fluids ((%default-port-encoding #f)) + (let* ((r (read-response (open-input-string example-1))) + (p (response-body-port r #:keep-alive? #f))) + ;; Before, calling 'close-port' here would yield a + ;; wrong-arg-num error when calling the delimited input port's + ;; 'close' procedure. + (close-port p) + (port-closed? p)))))) (with-test-prefix "example-2" (let* ((r (read-response (open-input-string example-2))) From d975a8dec6b2517dc180f60e01f37fc9bd1aaa07 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 17 Sep 2015 22:32:10 -0400 Subject: [PATCH 320/865] docs: Fix external representation of in tree-il. * doc/ref/compiler.texi (Tree-IL): Provide the correct external representation of . --- doc/ref/compiler.texi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/ref/compiler.texi b/doc/ref/compiler.texi index 6696360bd..057ebe817 100644 --- a/doc/ref/compiler.texi +++ b/doc/ref/compiler.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 +@c Copyright (C) 2008-2016 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -363,7 +363,7 @@ Sets a variable in the current procedure's module. @end deftp @deftp {Scheme Variable} src name exp -@deftpx {External Representation} (define (toplevel @var{name}) @var{exp}) +@deftpx {External Representation} (define @var{name} @var{exp}) Defines a new top-level variable in the current procedure's module. @end deftp From 0bcf5d78ecb40871fb48cf0f1a6065be38a3a14b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 26 Sep 2015 11:04:23 +0200 Subject: [PATCH 321/865] web: Gracefully handle premature EOF when reading chunk header. * module/web/http.scm (read-chunk-header): Return 0 when 'read-line' returns EOF. --- module/web/http.scm | 25 ++++++++++++++++--------- test-suite/tests/web-http.test | 10 ++++++++++ 2 files changed, 26 insertions(+), 9 deletions(-) diff --git a/module/web/http.scm b/module/web/http.scm index 8093ed21d..5ce7e7c67 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -34,6 +34,7 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-19) #:use-module (ice-9 rdelim) + #:use-module (ice-9 match) #:use-module (ice-9 q) #:use-module (ice-9 binary-ports) #:use-module (rnrs bytevectors) @@ -1914,15 +1915,21 @@ treated specially, and is just returned as a plain string." ;; Chunked Responses (define (read-chunk-header port) - "Read a chunk header and return the chunk size." - (let* ((str (read-line port)) - (extension-start (string-index str (lambda (c) (or (char=? c #\;) - (char=? c #\return))))) - (size (string->number (if extension-start ; unnecessary? - (substring str 0 extension-start) - str) - 16))) - size)) + "Read a chunk header from PORT and return the size in bytes of the +upcoming chunk." + (match (read-line port) + ((? eof-object?) + ;; Connection closed prematurely: there's nothing left to read. + 0) + (str + (let ((extension-start (string-index str + (lambda (c) + (or (char=? c #\;) + (char=? c #\return)))))) + (string->number (if extension-start ; unnecessary? + (substring str 0 extension-start) + str) + 16))))) (define* (make-chunked-input-port port #:key (keep-alive? #f)) "Returns a new port which translates HTTP chunked transfer encoded diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test index 8a7a29542..bd14de9b9 100644 --- a/test-suite/tests/web-http.test +++ b/test-suite/tests/web-http.test @@ -423,6 +423,16 @@ (utf8->string (get-bytevector-n port 6)) (reverse requests))))) + (pass-if-equal "EOF instead of chunk header" + "Only chunk." + ;; Omit the second chunk header, leading to a premature EOF. This + ;; used to cause 'read-chunk-header' to throw to wrong-type-arg. + ;; See the backtrace at + ;; . + (let* ((str "B\r\nOnly chunk.") + (port (make-chunked-input-port (open-input-string str)))) + (get-string-all port))) + (pass-if-equal (call-with-output-string (lambda (out-raw) From 2e3f6c3c678b28a839d6c751db5bc4c50a956c8e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 29 Oct 2015 23:17:51 +0100 Subject: [PATCH 322/865] i18n: Add new collation test for posterity. * test-suite/tests/i18n.test ("text collation (Czech)"): New test prefix. --- test-suite/tests/i18n.test | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index c63e3ac5b..73502a01e 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -1,7 +1,7 @@ ;;;; i18n.test --- Exercise the i18n API. -*- coding: utf-8; mode: scheme; -*- ;;;; ;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011, 2012, -;;;; 2013, 2014 Free Software Foundation, Inc. +;;;; 2013, 2014, 2015 Free Software Foundation, Inc. ;;;; Ludovic Courtès ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -270,6 +270,23 @@ (let ((gr (make-locale LC_ALL %greek-utf8-locale-name))) (string-locale-ci=? "ΧΑΟΣ" "χαος" gr)))))) + +(with-test-prefix "text collation (Czech)" + + (pass-if "string-locale. For + ;; now, just skip it if it fails (XXX). + (or (and (string-locale>? "chxxx" "cxxx") + (string-locale>? "chxxx" "hxxx") + (string-locale Date: Wed, 22 Jul 2015 12:48:24 -0400 Subject: [PATCH 323/865] Fix the rule to check for new signals and errors MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . * libguile/Makefile.am (chknew-E chknew-SIG): Remove the line continuation after the targets, and include numbers in the recipe's signal/error regexp to catch names like E2BIG. Signed-off-by: Ludovic Courtès --- libguile/.gitignore | 1 + libguile/Makefile.am | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/libguile/.gitignore b/libguile/.gitignore index 16c60ec38..41a8f7a56 100644 --- a/libguile/.gitignore +++ b/libguile/.gitignore @@ -13,3 +13,4 @@ libpath.h scmconfig.h version.h vm-i-*.i +*.NEW diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 3bc9952a9..ae546dd61 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -815,13 +815,13 @@ MKDEP = gcc -M -MG $(DEFS) $(AM_CPPFLAGS) $(CPPFLAGS) $(CFLAGS) # Write $(srcdir)/cpp-{E,SIG}.syms.NEW if there are any not-yet-seen # ("new" to us) E* or SIG* symbols in or , respectively. -chknew-E chknew-SIG: \ +chknew-E chknew-SIG: @bit=`echo $@ | sed s/^chknew-//` ; \ old="$(srcdir)/cpp-$$bit.syms" ; \ echo "#include <$${bit}.h>" \ | sed 's/E/errno/;s/SIG/signal/' \ | gcc -dM -E - \ - | sed 's/^#define //;/^'$$bit'[A-Z][A-Z]*/!d;s/ .*//' \ + | sed 's/^#define //;/^'$$bit'[0-9A-Z][0-9A-Z]*/!d;s/ .*//' \ | sort | diff -u $$old - | sed '1,2d;/^+/!d;s/^.//' \ > TMP ; \ if [ -s TMP ] ; then new="$$old.NEW" ; \ From cdd0dc8213f625fe39a6813af0885a92b549ed12 Mon Sep 17 00:00:00 2001 From: David Michael Date: Wed, 22 Jul 2015 12:49:46 -0400 Subject: [PATCH 324/865] Add new Linux errno constants. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * libguile/cpp-E.syms (EHWPOISON, ERFKILL): New definitions. Signed-off-by: Ludovic Courtès --- libguile/cpp-E.syms | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libguile/cpp-E.syms b/libguile/cpp-E.syms index 3fbcbfe3a..3d3b0c3c6 100644 --- a/libguile/cpp-E.syms +++ b/libguile/cpp-E.syms @@ -33,6 +33,7 @@ EFAULT EFBIG EHOSTDOWN EHOSTUNREACH +EHWPOISON EIDRM EILSEQ EINPROGRESS @@ -112,6 +113,7 @@ EREMCHG EREMOTE EREMOTEIO ERESTART +ERFKILL EROFS ESHUTDOWN ESOCKTNOSUPPORT From befaad0c14d15d178caa5984cd32a8d64c536b32 Mon Sep 17 00:00:00 2001 From: David Michael Date: Wed, 22 Jul 2015 12:52:27 -0400 Subject: [PATCH 325/865] Add Hurd signal and error constants. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * libguile/cpp-E.syms (EAUTH, EBACKGROUND): New definitions. (EBADRPC, ED, EDIED, EFTYPE, EGRATUITOUS, EGREGIOUS): Likewise. (EIEIO, ENEEDAUTH, EPROCLIM, EPROCUNAVAIL): Likewise. (EPROGMISMATCH, EPROGUNAVAIL, ERPCMISMATCH): Likewise. * libguile/cpp-SIG.syms (SIGEMT, SIGEV_MAX_SIZE): Likewise. (SIGEV_PAD_SIZE, SIGINFO, SIGLOST): Likewise. Signed-off-by: Ludovic Courtès --- libguile/cpp-E.syms | 15 +++++++++++++++ libguile/cpp-SIG.syms | 5 +++++ 2 files changed, 20 insertions(+) diff --git a/libguile/cpp-E.syms b/libguile/cpp-E.syms index 3d3b0c3c6..53302febe 100644 --- a/libguile/cpp-E.syms +++ b/libguile/cpp-E.syms @@ -6,11 +6,14 @@ EADV EAFNOSUPPORT EAGAIN EALREADY +EAUTH +EBACKGROUND EBADE EBADF EBADFD EBADMSG EBADR +EBADRPC EBADRQC EBADSLT EBFONT @@ -22,19 +25,25 @@ ECOMM ECONNABORTED ECONNREFUSED ECONNRESET +ED EDEADLK EDEADLOCK EDESTADDRREQ +EDIED EDOM EDOTDOT EDQUOT EEXIST EFAULT EFBIG +EFTYPE +EGRATUITOUS +EGREGIOUS EHOSTDOWN EHOSTUNREACH EHWPOISON EIDRM +EIEIO EILSEQ EINPROGRESS EINTR @@ -64,6 +73,7 @@ EMSGSIZE EMULTIHOP ENAMETOOLONG ENAVAIL +ENEEDAUTH ENETDOWN ENETRESET ENETUNREACH @@ -105,6 +115,10 @@ EOWNERDEAD EPERM EPFNOSUPPORT EPIPE +EPROCLIM +EPROCUNAVAIL +EPROGMISMATCH +EPROGUNAVAIL EPROTO EPROTONOSUPPORT EPROTOTYPE @@ -115,6 +129,7 @@ EREMOTEIO ERESTART ERFKILL EROFS +ERPCMISMATCH ESHUTDOWN ESOCKTNOSUPPORT ESPIPE diff --git a/libguile/cpp-SIG.syms b/libguile/cpp-SIG.syms index bc5737679..2a619ce2d 100644 --- a/libguile/cpp-SIG.syms +++ b/libguile/cpp-SIG.syms @@ -5,17 +5,22 @@ SIGBUS SIGCHLD SIGCLD SIGCONT +SIGEMT +SIGEV_MAX_SIZE SIGEV_NONE +SIGEV_PAD_SIZE SIGEV_SIGNAL SIGEV_THREAD SIGEV_THREAD_ID SIGFPE SIGHUP SIGILL +SIGINFO SIGINT SIGIO SIGIOT SIGKILL +SIGLOST SIGPIPE SIGPOLL SIGPROF From 41f28a9b0e7c1d60c3465fcbc25e40a77d59aa14 Mon Sep 17 00:00:00 2001 From: David Michael Date: Wed, 22 Jul 2015 12:54:32 -0400 Subject: [PATCH 326/865] Remove SIGEV constant definitions. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * libguile/Makefile.am (chknew-E chknew-SIG): Anchor the end of the signal/error name pattern to only match alphanumeric symbols. * libguile/cpp-SIG.syms (SIGEV_MAX_SIZE, SIGEV_NONE): Remove. (SIGEV_PAD_SIZE, SIGEV_SIGNAL, SIGEV_THREAD): Likewise. (SIGEV_THREAD_ID): Likewise. Signed-off-by: Ludovic Courtès --- libguile/Makefile.am | 2 +- libguile/cpp-SIG.syms | 6 ------ 2 files changed, 1 insertion(+), 7 deletions(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index ae546dd61..f6d7515df 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -821,7 +821,7 @@ chknew-E chknew-SIG: echo "#include <$${bit}.h>" \ | sed 's/E/errno/;s/SIG/signal/' \ | gcc -dM -E - \ - | sed 's/^#define //;/^'$$bit'[0-9A-Z][0-9A-Z]*/!d;s/ .*//' \ + | sed 's/^#define //;/^'$$bit'[0-9A-Z][0-9A-Z]* /!d;s/ .*//' \ | sort | diff -u $$old - | sed '1,2d;/^+/!d;s/^.//' \ > TMP ; \ if [ -s TMP ] ; then new="$$old.NEW" ; \ diff --git a/libguile/cpp-SIG.syms b/libguile/cpp-SIG.syms index 2a619ce2d..728a29457 100644 --- a/libguile/cpp-SIG.syms +++ b/libguile/cpp-SIG.syms @@ -6,12 +6,6 @@ SIGCHLD SIGCLD SIGCONT SIGEMT -SIGEV_MAX_SIZE -SIGEV_NONE -SIGEV_PAD_SIZE -SIGEV_SIGNAL -SIGEV_THREAD -SIGEV_THREAD_ID SIGFPE SIGHUP SIGILL From 7c36145075450a78322f41622ebbf99f6be88eb0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 29 Oct 2015 23:55:05 +0100 Subject: [PATCH 327/865] build: Remove libguile/mkstemp.c, redundant with Gnulib. Fixes . Reported by Kouhei Sutou . * configure.ac: Remove 'AC_REPLACE_FUNCS' for 'mkstemp'. * libguile/Makefile.am (EXTRA_libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES): Remove mkstemp.c. * libguile/mkstemp.c: Remove. --- configure.ac | 2 +- libguile/Makefile.am | 2 +- libguile/mkstemp.c | 129 ------------------------------------------- 3 files changed, 2 insertions(+), 131 deletions(-) delete mode 100644 libguile/mkstemp.c diff --git a/configure.ac b/configure.ac index 3a8f77291..b1bd7f1a8 100644 --- a/configure.ac +++ b/configure.ac @@ -1125,7 +1125,7 @@ if test "$enable_regex" = yes; then AC_DEFINE([ENABLE_REGEX], 1, [Define when regex support is enabled.]) fi -AC_REPLACE_FUNCS([strerror memmove mkstemp]) +AC_REPLACE_FUNCS([strerror memmove]) # Reasons for testing: # asinh, acosh, atanh, trunc - C99 standard, generally not available on diff --git a/libguile/Makefile.am b/libguile/Makefile.am index f6d7515df..bb3dc7ed7 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -455,7 +455,7 @@ EXTRA_libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = _scm.h \ memmove.c strerror.c \ dynl.c regex-posix.c \ posix.c net_db.c socket.c \ - debug-malloc.c mkstemp.c \ + debug-malloc.c \ win32-uname.c \ locale-categories.h diff --git a/libguile/mkstemp.c b/libguile/mkstemp.c deleted file mode 100644 index d752d0714..000000000 --- a/libguile/mkstemp.c +++ /dev/null @@ -1,129 +0,0 @@ -/* Copyright (C) 1991, 1992, 1996, 1998, 2001, 2006, 2013, - 2014 Free Software Foundation, Inc. - - This file is derived from mkstemps.c from the GNU Libiberty Library - which in turn is derived from the GNU C Library. - - The GNU C Library is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public License as - published by the Free Software Foundation; either version 2 of the - License, or (at your option) any later version. - - The GNU C Library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with the GNU C Library; see the file COPYING.LIB. If not, - write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - Boston, MA 02110-1301, USA. -*/ - -#ifdef HAVE_CONFIG_H -# include -#endif - -#include "libguile/__scm.h" - -#ifdef HAVE_STDLIB_H -#include -#endif -#ifdef HAVE_STRING_H -#include -#endif -#include -#include -#include -#include -#ifdef HAVE_SYS_TIME_H -#include -#endif -#ifdef __MINGW32__ -#include -#endif - -#ifndef TMP_MAX -#define TMP_MAX 16384 -#endif - -/* We provide this prototype to avoid compiler warnings. If this ever - conflicts with a declaration in a system header file, we'll find - out, because we should include that header file here. */ -int mkstemp (char *); - -/* Generate a unique temporary file name from TEMPLATE. - - TEMPLATE has the form: - - /ccXXXXXX - - The last six characters of TEMPLATE must be "XXXXXX"; they are - replaced with a string that makes the filename unique. - - Returns a file descriptor open on the file for reading and writing. */ -int -mkstemp (template) - char *template; -{ - static const char letters[] - = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"; - static scm_t_uint64 value; -#ifdef HAVE_GETTIMEOFDAY - struct timeval tv; -#endif - char *XXXXXX; - size_t len; - int count; - - len = strlen (template); - - if ((int) len < 6 - || strncmp (&template[len - 6], "XXXXXX", 6)) - { - return -1; - } - - XXXXXX = &template[len - 6]; - -#ifdef HAVE_GETTIMEOFDAY - /* Get some more or less random data. */ - gettimeofday (&tv, NULL); - value += ((scm_t_uint64) tv.tv_usec << 16) ^ tv.tv_sec ^ getpid (); -#else - value += getpid (); -#endif - - for (count = 0; count < TMP_MAX; ++count) - { - scm_t_uint64 v = value; - int fd; - - /* Fill in the random bits. */ - XXXXXX[0] = letters[v % 62]; - v /= 62; - XXXXXX[1] = letters[v % 62]; - v /= 62; - XXXXXX[2] = letters[v % 62]; - v /= 62; - XXXXXX[3] = letters[v % 62]; - v /= 62; - XXXXXX[4] = letters[v % 62]; - v /= 62; - XXXXXX[5] = letters[v % 62]; - - fd = open (template, O_RDWR|O_CREAT|O_EXCL|O_BINARY, 0600); - if (fd >= 0) - /* The file does not exist. */ - return fd; - - /* This is a random value. It is only necessary that the next - TMP_MAX values generated by adding 7777 to VALUE are different - with (module 2^32). */ - value += 7777; - } - - /* We return the null string if we can't find a unique file name. */ - template[0] = '\0'; - return -1; -} From 34428bc5df1efe3f721c24fcbba99c380594c1af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 29 Oct 2015 23:59:02 +0100 Subject: [PATCH 328/865] Thank David and Kouhei. --- THANKS | 2 ++ 1 file changed, 2 insertions(+) diff --git a/THANKS b/THANKS index fbb15ada2..616d3b04b 100644 --- a/THANKS +++ b/THANKS @@ -134,6 +134,7 @@ For fixes or providing information which led to a fix: Dan McMahill Roger Mc Murtrie Scott McPeak + David Michael Glenn Michaels Andrew Milkowski Tim Mooney @@ -170,6 +171,7 @@ For fixes or providing information which led to a fix: Dale Smith Cesar Strauss Klaus Stehle + Kouhei Sutou Rainer Tammer Frank Terbeck Samuel Thibault From a88f94ff5ecfbf67d621cac44fcc8772d8fb5bc4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 30 Oct 2015 17:15:24 +0100 Subject: [PATCH 329/865] doc: Mention a known-good Flex version number. Suggested by Jamil Egdemir . * HACKING: Mention a Flex version number. --- HACKING | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/HACKING b/HACKING index b08f7c2d4..f3011d932 100644 --- a/HACKING +++ b/HACKING @@ -1,6 +1,7 @@ -*-text-*- Guile Hacking Guide -Copyright (c) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2008, 2012 Free software Foundation, Inc. +Copyright (c) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2008, 2012, + 2015 Free software Foundation, Inc. Permission is granted to anyone to make or distribute verbatim copies of this document as received, in any medium, provided that the @@ -69,7 +70,7 @@ gettext --- a system for rigging a program so that it can output its itself. flex --- a scanner generator. It's probably not essential to have the - latest version. + latest version; Flex 2.5.37 is known to work. One false move and you will be lost in a little maze of automatically generated files, all different. From 5de910ba2880b72cdc9fbeda6eccf806448f67ea Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sun, 6 Sep 2015 07:33:55 -0400 Subject: [PATCH 330/865] build: Add SCM_T_OFF_MAX and SCM_T_OFF_MIN to scmconfig.h. * libguile/gen-scmconfig.c (main): Add SCM_T_OFF_MAX and SCM_T_OFF_MIN to the generated 'scmconfig.h' file. --- libguile/gen-scmconfig.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c index 11020cfb2..f825e9b2b 100644 --- a/libguile/gen-scmconfig.c +++ b/libguile/gen-scmconfig.c @@ -376,10 +376,16 @@ main (int argc, char *argv[]) #if defined GUILE_USE_64_CALLS && defined HAVE_STAT64 pf ("typedef scm_t_int64 scm_t_off;\n"); + pf ("#define SCM_T_OFF_MAX SCM_T_INT64_MAX\n"); + pf ("#define SCM_T_OFF_MIN SCM_T_INT64_MIN\n"); #elif SIZEOF_OFF_T == SIZEOF_INT pf ("typedef int scm_t_off;\n"); + pf ("#define SCM_T_OFF_MAX INT_MAX\n"); + pf ("#define SCM_T_OFF_MIN INT_MIN\n"); #else pf ("typedef long int scm_t_off;\n"); + pf ("#define SCM_T_OFF_MAX LONG_MAX\n"); + pf ("#define SCM_T_OFF_MIN LONG_MIN\n"); #endif pf ("/* Define to 1 if the compiler supports the " From cfd4401a2ca723a6984e1ba2739e064bdca76199 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 5 Nov 2015 19:15:14 +0100 Subject: [PATCH 331/865] Regenerate SRFI-14 character set data. Suggested by Mike Gran . * libguile/srfi-14.i.c: Regenerate for Unicode 8.0.0, with SHA256 38b17e1118206489a7e0ab5d29d7932212d38838df7d3ec025ecb58e8798ec20. --- libguile/srfi-14.i.c | 1730 ++++++++++++++++++++++++++++++++---------- 1 file changed, 1311 insertions(+), 419 deletions(-) diff --git a/libguile/srfi-14.i.c b/libguile/srfi-14.i.c index 42a1c2cf2..0b08742d2 100644 --- a/libguile/srfi-14.i.c +++ b/libguile/srfi-14.i.c @@ -363,7 +363,7 @@ scm_t_char_range cs_lower_case_ranges[] = { , {0x03ed, 0x03ed} , - {0x03ef, 0x03f2} + {0x03ef, 0x03f3} , {0x03f5, 0x03f5} , @@ -563,8 +563,18 @@ scm_t_char_range cs_lower_case_ranges[] = { , {0x0527, 0x0527} , + {0x0529, 0x0529} + , + {0x052b, 0x052b} + , + {0x052d, 0x052d} + , + {0x052f, 0x052f} + , {0x0561, 0x0587} , + {0x13f8, 0x13fd} + , {0x1930, 0x1938} , {0x1d02, 0x1d02} @@ -593,7 +603,7 @@ scm_t_char_range cs_lower_case_ranges[] = { , {0x1de0, 0x1de0} , - {0x1de3, 0x1de6} + {0x1de3, 0x1df4} , {0x1e01, 0x1e01} , @@ -953,6 +963,10 @@ scm_t_char_range cs_lower_case_ranges[] = { , {0xa697, 0xa697} , + {0xa699, 0xa699} + , + {0xa69b, 0xa69b} + , {0xa723, 0xa723} , {0xa725, 0xa725} @@ -1053,7 +1067,17 @@ scm_t_char_range cs_lower_case_ranges[] = { , {0xa791, 0xa791} , - {0xa793, 0xa793} + {0xa793, 0xa795} + , + {0xa797, 0xa797} + , + {0xa799, 0xa799} + , + {0xa79b, 0xa79b} + , + {0xa79d, 0xa79d} + , + {0xa79f, 0xa79f} , {0xa7a1, 0xa7a1} , @@ -1065,8 +1089,20 @@ scm_t_char_range cs_lower_case_ranges[] = { , {0xa7a9, 0xa7a9} , + {0xa7b5, 0xa7b5} + , + {0xa7b7, 0xa7b7} + , {0xa7f9, 0xa7f9} , + {0xab30, 0xab45} + , + {0xab47, 0xab5a} + , + {0xab60, 0xab64} + , + {0xab70, 0xabbf} + , {0xfb00, 0xfb06} , {0xfb13, 0xfb17} @@ -1075,13 +1111,17 @@ scm_t_char_range cs_lower_case_ranges[] = { , {0x10428, 0x1044f} , + {0x10cc0, 0x10cf2} + , + {0x118c0, 0x118df} + , {0x1f521, 0x1f521} , {0xe0061, 0xe007a} }; scm_t_char_set cs_lower_case = { - 536, + 556, cs_lower_case_ranges }; @@ -1380,6 +1420,8 @@ scm_t_char_range cs_upper_case_ranges[] = { , {0x0376, 0x0376} , + {0x037f, 0x037f} + , {0x0386, 0x0386} , {0x0388, 0x038a} @@ -1616,6 +1658,14 @@ scm_t_char_range cs_upper_case_ranges[] = { , {0x0526, 0x0526} , + {0x0528, 0x0528} + , + {0x052a, 0x052a} + , + {0x052c, 0x052c} + , + {0x052e, 0x052e} + , {0x0531, 0x0556} , {0x10a0, 0x10c5} @@ -1624,6 +1674,8 @@ scm_t_char_range cs_upper_case_ranges[] = { , {0x10cd, 0x10cd} , + {0x13a0, 0x13f5} + , {0x1d7b, 0x1d7b} , {0x1d7e, 0x1d7e} @@ -1982,6 +2034,10 @@ scm_t_char_range cs_upper_case_ranges[] = { , {0xa696, 0xa696} , + {0xa698, 0xa698} + , + {0xa69a, 0xa69a} + , {0xa722, 0xa722} , {0xa724, 0xa724} @@ -2080,6 +2136,16 @@ scm_t_char_range cs_upper_case_ranges[] = { , {0xa792, 0xa792} , + {0xa796, 0xa796} + , + {0xa798, 0xa798} + , + {0xa79a, 0xa79a} + , + {0xa79c, 0xa79c} + , + {0xa79e, 0xa79e} + , {0xa7a0, 0xa7a0} , {0xa7a2, 0xa7a2} @@ -2090,12 +2156,20 @@ scm_t_char_range cs_upper_case_ranges[] = { , {0xa7a8, 0xa7a8} , - {0xa7aa, 0xa7aa} + {0xa7aa, 0xa7ad} + , + {0xa7b0, 0xa7b4} + , + {0xa7b6, 0xa7b6} , {0xff21, 0xff3a} , {0x10400, 0x10427} , + {0x10c80, 0x10cb2} + , + {0x118a0, 0x118bf} + , {0x1f110, 0x1f12c} , {0x1f130, 0x1f149} @@ -2110,7 +2184,7 @@ scm_t_char_range cs_upper_case_ranges[] = { }; scm_t_char_set cs_upper_case = { - 511, + 528, cs_upper_case_ranges }; @@ -2172,6 +2246,8 @@ scm_t_char_range cs_letter_ranges[] = { , {0x037a, 0x037d} , + {0x037f, 0x037f} + , {0x0386, 0x0386} , {0x0388, 0x038a} @@ -2184,7 +2260,7 @@ scm_t_char_range cs_letter_ranges[] = { , {0x03f7, 0x0481} , - {0x048a, 0x0527} + {0x048a, 0x052f} , {0x0531, 0x0556} , @@ -2236,9 +2312,7 @@ scm_t_char_range cs_letter_ranges[] = { , {0x0840, 0x0858} , - {0x08a0, 0x08a0} - , - {0x08a2, 0x08ac} + {0x08a0, 0x08b4} , {0x0904, 0x0939} , @@ -2248,9 +2322,7 @@ scm_t_char_range cs_letter_ranges[] = { , {0x0958, 0x0961} , - {0x0971, 0x0977} - , - {0x0979, 0x097f} + {0x0971, 0x0980} , {0x0985, 0x098c} , @@ -2312,6 +2384,8 @@ scm_t_char_range cs_letter_ranges[] = { , {0x0ae0, 0x0ae1} , + {0x0af9, 0x0af9} + , {0x0b05, 0x0b0c} , {0x0b0f, 0x0b10} @@ -2360,13 +2434,11 @@ scm_t_char_range cs_letter_ranges[] = { , {0x0c12, 0x0c28} , - {0x0c2a, 0x0c33} - , - {0x0c35, 0x0c39} + {0x0c2a, 0x0c39} , {0x0c3d, 0x0c3d} , - {0x0c58, 0x0c59} + {0x0c58, 0x0c5a} , {0x0c60, 0x0c61} , @@ -2398,7 +2470,7 @@ scm_t_char_range cs_letter_ranges[] = { , {0x0d4e, 0x0d4e} , - {0x0d60, 0x0d61} + {0x0d5f, 0x0d61} , {0x0d7a, 0x0d7f} , @@ -2520,7 +2592,9 @@ scm_t_char_range cs_letter_ranges[] = { , {0x1380, 0x138f} , - {0x13a0, 0x13f4} + {0x13a0, 0x13f5} + , + {0x13f8, 0x13fd} , {0x1401, 0x166c} , @@ -2530,6 +2604,8 @@ scm_t_char_range cs_letter_ranges[] = { , {0x16a0, 0x16ea} , + {0x16f1, 0x16f8} + , {0x1700, 0x170c} , {0x170e, 0x1711} @@ -2556,7 +2632,7 @@ scm_t_char_range cs_letter_ranges[] = { , {0x18b0, 0x18f5} , - {0x1900, 0x191c} + {0x1900, 0x191e} , {0x1950, 0x196d} , @@ -2564,7 +2640,7 @@ scm_t_char_range cs_letter_ranges[] = { , {0x1980, 0x19ab} , - {0x19c1, 0x19c7} + {0x19b0, 0x19c9} , {0x1a00, 0x1a16} , @@ -2732,7 +2808,7 @@ scm_t_char_range cs_letter_ranges[] = { , {0x3400, 0x4db5} , - {0x4e00, 0x9fcc} + {0x4e00, 0x9fd5} , {0xa000, 0xa48c} , @@ -2746,7 +2822,7 @@ scm_t_char_range cs_letter_ranges[] = { , {0xa640, 0xa66e} , - {0xa67f, 0xa697} + {0xa67f, 0xa69d} , {0xa6a0, 0xa6e5} , @@ -2754,13 +2830,11 @@ scm_t_char_range cs_letter_ranges[] = { , {0xa722, 0xa788} , - {0xa78b, 0xa78e} + {0xa78b, 0xa7ad} , - {0xa790, 0xa793} + {0xa7b0, 0xa7b7} , - {0xa7a0, 0xa7aa} - , - {0xa7f8, 0xa801} + {0xa7f7, 0xa801} , {0xa803, 0xa805} , @@ -2776,6 +2850,8 @@ scm_t_char_range cs_letter_ranges[] = { , {0xa8fb, 0xa8fb} , + {0xa8fd, 0xa8fd} + , {0xa90a, 0xa925} , {0xa930, 0xa946} @@ -2786,6 +2862,12 @@ scm_t_char_range cs_letter_ranges[] = { , {0xa9cf, 0xa9cf} , + {0xa9e0, 0xa9e4} + , + {0xa9e6, 0xa9ef} + , + {0xa9fa, 0xa9fe} + , {0xaa00, 0xaa28} , {0xaa40, 0xaa42} @@ -2796,7 +2878,7 @@ scm_t_char_range cs_letter_ranges[] = { , {0xaa7a, 0xaa7a} , - {0xaa80, 0xaaaf} + {0xaa7e, 0xaaaf} , {0xaab1, 0xaab1} , @@ -2824,7 +2906,11 @@ scm_t_char_range cs_letter_ranges[] = { , {0xab28, 0xab2e} , - {0xabc0, 0xabe2} + {0xab30, 0xab5a} + , + {0xab5c, 0xab65} + , + {0xab70, 0xabe2} , {0xac00, 0xd7a3} , @@ -2900,12 +2986,14 @@ scm_t_char_range cs_letter_ranges[] = { , {0x102a0, 0x102d0} , - {0x10300, 0x1031e} + {0x10300, 0x1031f} , {0x10330, 0x10340} , {0x10342, 0x10349} , + {0x10350, 0x10375} + , {0x10380, 0x1039d} , {0x103a0, 0x103c3} @@ -2914,6 +3002,16 @@ scm_t_char_range cs_letter_ranges[] = { , {0x10400, 0x1049d} , + {0x10500, 0x10527} + , + {0x10530, 0x10563} + , + {0x10600, 0x10736} + , + {0x10740, 0x10755} + , + {0x10760, 0x10767} + , {0x10800, 0x10805} , {0x10808, 0x10808} @@ -2926,6 +3024,14 @@ scm_t_char_range cs_letter_ranges[] = { , {0x1083f, 0x10855} , + {0x10860, 0x10876} + , + {0x10880, 0x1089e} + , + {0x108e0, 0x108f2} + , + {0x108f4, 0x108f5} + , {0x10900, 0x10915} , {0x10920, 0x10939} @@ -2944,14 +3050,26 @@ scm_t_char_range cs_letter_ranges[] = { , {0x10a60, 0x10a7c} , + {0x10a80, 0x10a9c} + , + {0x10ac0, 0x10ac7} + , + {0x10ac9, 0x10ae4} + , {0x10b00, 0x10b35} , {0x10b40, 0x10b55} , {0x10b60, 0x10b72} , + {0x10b80, 0x10b91} + , {0x10c00, 0x10c48} , + {0x10c80, 0x10cb2} + , + {0x10cc0, 0x10cf2} + , {0x11003, 0x11037} , {0x11083, 0x110af} @@ -2960,18 +3078,98 @@ scm_t_char_range cs_letter_ranges[] = { , {0x11103, 0x11126} , + {0x11150, 0x11172} + , + {0x11176, 0x11176} + , {0x11183, 0x111b2} , {0x111c1, 0x111c4} , + {0x111da, 0x111da} + , + {0x111dc, 0x111dc} + , + {0x11200, 0x11211} + , + {0x11213, 0x1122b} + , + {0x11280, 0x11286} + , + {0x11288, 0x11288} + , + {0x1128a, 0x1128d} + , + {0x1128f, 0x1129d} + , + {0x1129f, 0x112a8} + , + {0x112b0, 0x112de} + , + {0x11305, 0x1130c} + , + {0x1130f, 0x11310} + , + {0x11313, 0x11328} + , + {0x1132a, 0x11330} + , + {0x11332, 0x11333} + , + {0x11335, 0x11339} + , + {0x1133d, 0x1133d} + , + {0x11350, 0x11350} + , + {0x1135d, 0x11361} + , + {0x11480, 0x114af} + , + {0x114c4, 0x114c5} + , + {0x114c7, 0x114c7} + , + {0x11580, 0x115ae} + , + {0x115d8, 0x115db} + , + {0x11600, 0x1162f} + , + {0x11644, 0x11644} + , {0x11680, 0x116aa} , - {0x12000, 0x1236e} + {0x11700, 0x11719} + , + {0x118a0, 0x118df} + , + {0x118ff, 0x118ff} + , + {0x11ac0, 0x11af8} + , + {0x12000, 0x12399} + , + {0x12480, 0x12543} , {0x13000, 0x1342e} , + {0x14400, 0x14646} + , {0x16800, 0x16a38} , + {0x16a40, 0x16a5e} + , + {0x16ad0, 0x16aed} + , + {0x16b00, 0x16b2f} + , + {0x16b40, 0x16b43} + , + {0x16b63, 0x16b77} + , + {0x16b7d, 0x16b8f} + , {0x16f00, 0x16f44} , {0x16f50, 0x16f50} @@ -2980,6 +3178,14 @@ scm_t_char_range cs_letter_ranges[] = { , {0x1b000, 0x1b001} , + {0x1bc00, 0x1bc6a} + , + {0x1bc70, 0x1bc7c} + , + {0x1bc80, 0x1bc88} + , + {0x1bc90, 0x1bc99} + , {0x1d400, 0x1d454} , {0x1d456, 0x1d49c} @@ -3040,6 +3246,8 @@ scm_t_char_range cs_letter_ranges[] = { , {0x1d7c4, 0x1d7cb} , + {0x1e800, 0x1e8c4} + , {0x1ee00, 0x1ee03} , {0x1ee05, 0x1ee1f} @@ -3112,11 +3320,13 @@ scm_t_char_range cs_letter_ranges[] = { , {0x2b740, 0x2b81d} , + {0x2b820, 0x2cea1} + , {0x2f800, 0x2fa1d} }; scm_t_char_set cs_letter = { - 486, + 554, cs_letter_ranges }; @@ -3147,6 +3357,8 @@ scm_t_char_range cs_digit_ranges[] = { , {0x0d66, 0x0d6f} , + {0x0de6, 0x0def} + , {0x0e50, 0x0e59} , {0x0ed0, 0x0ed9} @@ -3185,6 +3397,8 @@ scm_t_char_range cs_digit_ranges[] = { , {0xa9d0, 0xa9d9} , + {0xa9f0, 0xa9f9} + , {0xaa50, 0xaa59} , {0xabf0, 0xabf9} @@ -3201,13 +3415,27 @@ scm_t_char_range cs_digit_ranges[] = { , {0x111d0, 0x111d9} , + {0x112f0, 0x112f9} + , + {0x114d0, 0x114d9} + , + {0x11650, 0x11659} + , {0x116c0, 0x116c9} , + {0x11730, 0x11739} + , + {0x118e0, 0x118e9} + , + {0x16a60, 0x16a69} + , + {0x16b50, 0x16b59} + , {0x1d7ce, 0x1d7ff} }; scm_t_char_set cs_digit = { - 42, + 51, cs_digit_ranges }; @@ -3257,6 +3485,8 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0x037a, 0x037d} , + {0x037f, 0x037f} + , {0x0386, 0x0386} , {0x0388, 0x038a} @@ -3269,7 +3499,7 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0x03f7, 0x0481} , - {0x048a, 0x0527} + {0x048a, 0x052f} , {0x0531, 0x0556} , @@ -3321,9 +3551,7 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0x0840, 0x0858} , - {0x08a0, 0x08a0} - , - {0x08a2, 0x08ac} + {0x08a0, 0x08b4} , {0x0904, 0x0939} , @@ -3335,9 +3563,7 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0x0966, 0x096f} , - {0x0971, 0x0977} - , - {0x0979, 0x097f} + {0x0971, 0x0980} , {0x0985, 0x098c} , @@ -3403,6 +3629,8 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0x0ae6, 0x0aef} , + {0x0af9, 0x0af9} + , {0x0b05, 0x0b0c} , {0x0b0f, 0x0b10} @@ -3455,13 +3683,11 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0x0c12, 0x0c28} , - {0x0c2a, 0x0c33} - , - {0x0c35, 0x0c39} + {0x0c2a, 0x0c39} , {0x0c3d, 0x0c3d} , - {0x0c58, 0x0c59} + {0x0c58, 0x0c5a} , {0x0c60, 0x0c61} , @@ -3497,7 +3723,7 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0x0d4e, 0x0d4e} , - {0x0d60, 0x0d61} + {0x0d5f, 0x0d61} , {0x0d66, 0x0d6f} , @@ -3513,6 +3739,8 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0x0dc0, 0x0dc6} , + {0x0de6, 0x0def} + , {0x0e01, 0x0e30} , {0x0e32, 0x0e33} @@ -3629,7 +3857,9 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0x1380, 0x138f} , - {0x13a0, 0x13f4} + {0x13a0, 0x13f5} + , + {0x13f8, 0x13fd} , {0x1401, 0x166c} , @@ -3639,6 +3869,8 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0x16a0, 0x16ea} , + {0x16f1, 0x16f8} + , {0x1700, 0x170c} , {0x170e, 0x1711} @@ -3669,7 +3901,7 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0x18b0, 0x18f5} , - {0x1900, 0x191c} + {0x1900, 0x191e} , {0x1946, 0x196d} , @@ -3677,7 +3909,7 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0x1980, 0x19ab} , - {0x19c1, 0x19c7} + {0x19b0, 0x19c9} , {0x19d0, 0x19d9} , @@ -3851,7 +4083,7 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0x3400, 0x4db5} , - {0x4e00, 0x9fcc} + {0x4e00, 0x9fd5} , {0xa000, 0xa48c} , @@ -3863,7 +4095,7 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0xa640, 0xa66e} , - {0xa67f, 0xa697} + {0xa67f, 0xa69d} , {0xa6a0, 0xa6e5} , @@ -3871,13 +4103,11 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0xa722, 0xa788} , - {0xa78b, 0xa78e} + {0xa78b, 0xa7ad} , - {0xa790, 0xa793} + {0xa7b0, 0xa7b7} , - {0xa7a0, 0xa7aa} - , - {0xa7f8, 0xa801} + {0xa7f7, 0xa801} , {0xa803, 0xa805} , @@ -3895,6 +4125,8 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0xa8fb, 0xa8fb} , + {0xa8fd, 0xa8fd} + , {0xa900, 0xa925} , {0xa930, 0xa946} @@ -3905,6 +4137,10 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0xa9cf, 0xa9d9} , + {0xa9e0, 0xa9e4} + , + {0xa9e6, 0xa9fe} + , {0xaa00, 0xaa28} , {0xaa40, 0xaa42} @@ -3917,7 +4153,7 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0xaa7a, 0xaa7a} , - {0xaa80, 0xaaaf} + {0xaa7e, 0xaaaf} , {0xaab1, 0xaab1} , @@ -3945,7 +4181,11 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0xab28, 0xab2e} , - {0xabc0, 0xabe2} + {0xab30, 0xab5a} + , + {0xab5c, 0xab65} + , + {0xab70, 0xabe2} , {0xabf0, 0xabf9} , @@ -4025,12 +4265,14 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0x102a0, 0x102d0} , - {0x10300, 0x1031e} + {0x10300, 0x1031f} , {0x10330, 0x10340} , {0x10342, 0x10349} , + {0x10350, 0x10375} + , {0x10380, 0x1039d} , {0x103a0, 0x103c3} @@ -4041,6 +4283,16 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0x104a0, 0x104a9} , + {0x10500, 0x10527} + , + {0x10530, 0x10563} + , + {0x10600, 0x10736} + , + {0x10740, 0x10755} + , + {0x10760, 0x10767} + , {0x10800, 0x10805} , {0x10808, 0x10808} @@ -4053,6 +4305,14 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0x1083f, 0x10855} , + {0x10860, 0x10876} + , + {0x10880, 0x1089e} + , + {0x108e0, 0x108f2} + , + {0x108f4, 0x108f5} + , {0x10900, 0x10915} , {0x10920, 0x10939} @@ -4071,14 +4331,26 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0x10a60, 0x10a7c} , + {0x10a80, 0x10a9c} + , + {0x10ac0, 0x10ac7} + , + {0x10ac9, 0x10ae4} + , {0x10b00, 0x10b35} , {0x10b40, 0x10b55} , {0x10b60, 0x10b72} , + {0x10b80, 0x10b91} + , {0x10c00, 0x10c48} , + {0x10c80, 0x10cb2} + , + {0x10cc0, 0x10cf2} + , {0x11003, 0x11037} , {0x11066, 0x1106f} @@ -4093,22 +4365,112 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0x11136, 0x1113f} , + {0x11150, 0x11172} + , + {0x11176, 0x11176} + , {0x11183, 0x111b2} , {0x111c1, 0x111c4} , - {0x111d0, 0x111d9} + {0x111d0, 0x111da} + , + {0x111dc, 0x111dc} + , + {0x11200, 0x11211} + , + {0x11213, 0x1122b} + , + {0x11280, 0x11286} + , + {0x11288, 0x11288} + , + {0x1128a, 0x1128d} + , + {0x1128f, 0x1129d} + , + {0x1129f, 0x112a8} + , + {0x112b0, 0x112de} + , + {0x112f0, 0x112f9} + , + {0x11305, 0x1130c} + , + {0x1130f, 0x11310} + , + {0x11313, 0x11328} + , + {0x1132a, 0x11330} + , + {0x11332, 0x11333} + , + {0x11335, 0x11339} + , + {0x1133d, 0x1133d} + , + {0x11350, 0x11350} + , + {0x1135d, 0x11361} + , + {0x11480, 0x114af} + , + {0x114c4, 0x114c5} + , + {0x114c7, 0x114c7} + , + {0x114d0, 0x114d9} + , + {0x11580, 0x115ae} + , + {0x115d8, 0x115db} + , + {0x11600, 0x1162f} + , + {0x11644, 0x11644} + , + {0x11650, 0x11659} , {0x11680, 0x116aa} , {0x116c0, 0x116c9} , - {0x12000, 0x1236e} + {0x11700, 0x11719} + , + {0x11730, 0x11739} + , + {0x118a0, 0x118e9} + , + {0x118ff, 0x118ff} + , + {0x11ac0, 0x11af8} + , + {0x12000, 0x12399} + , + {0x12480, 0x12543} , {0x13000, 0x1342e} , + {0x14400, 0x14646} + , {0x16800, 0x16a38} , + {0x16a40, 0x16a5e} + , + {0x16a60, 0x16a69} + , + {0x16ad0, 0x16aed} + , + {0x16b00, 0x16b2f} + , + {0x16b40, 0x16b43} + , + {0x16b50, 0x16b59} + , + {0x16b63, 0x16b77} + , + {0x16b7d, 0x16b8f} + , {0x16f00, 0x16f44} , {0x16f50, 0x16f50} @@ -4117,6 +4479,14 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0x1b000, 0x1b001} , + {0x1bc00, 0x1bc6a} + , + {0x1bc70, 0x1bc7c} + , + {0x1bc80, 0x1bc88} + , + {0x1bc90, 0x1bc99} + , {0x1d400, 0x1d454} , {0x1d456, 0x1d49c} @@ -4179,6 +4549,8 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0x1d7ce, 0x1d7ff} , + {0x1e800, 0x1e8c4} + , {0x1ee00, 0x1ee03} , {0x1ee05, 0x1ee1f} @@ -4251,11 +4623,13 @@ scm_t_char_range cs_letter_plus_digit_ranges[] = { , {0x2b740, 0x2b81d} , + {0x2b820, 0x2cea1} + , {0x2f800, 0x2fa1d} }; scm_t_char_set cs_letter_plus_digit = { - 514, + 587, cs_letter_plus_digit_ranges }; @@ -4266,7 +4640,7 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x00ae, 0x0377} , - {0x037a, 0x037e} + {0x037a, 0x037f} , {0x0384, 0x038a} , @@ -4274,7 +4648,7 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x038e, 0x03a1} , - {0x03a3, 0x0527} + {0x03a3, 0x052f} , {0x0531, 0x0556} , @@ -4284,7 +4658,7 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x0589, 0x058a} , - {0x058f, 0x058f} + {0x058d, 0x058f} , {0x0591, 0x05c7} , @@ -4312,17 +4686,9 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x085e, 0x085e} , - {0x08a0, 0x08a0} + {0x08a0, 0x08b4} , - {0x08a2, 0x08ac} - , - {0x08e4, 0x08fe} - , - {0x0900, 0x0977} - , - {0x0979, 0x097f} - , - {0x0981, 0x0983} + {0x08e3, 0x0983} , {0x0985, 0x098c} , @@ -4408,6 +4774,8 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x0ae6, 0x0af1} , + {0x0af9, 0x0af9} + , {0x0b01, 0x0b03} , {0x0b05, 0x0b0c} @@ -4468,7 +4836,7 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x0be6, 0x0bfa} , - {0x0c01, 0x0c03} + {0x0c00, 0x0c03} , {0x0c05, 0x0c0c} , @@ -4476,9 +4844,7 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x0c12, 0x0c28} , - {0x0c2a, 0x0c33} - , - {0x0c35, 0x0c39} + {0x0c2a, 0x0c39} , {0x0c3d, 0x0c44} , @@ -4488,7 +4854,7 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x0c55, 0x0c56} , - {0x0c58, 0x0c59} + {0x0c58, 0x0c5a} , {0x0c60, 0x0c63} , @@ -4496,7 +4862,7 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x0c78, 0x0c7f} , - {0x0c82, 0x0c83} + {0x0c81, 0x0c83} , {0x0c85, 0x0c8c} , @@ -4524,7 +4890,7 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x0cf1, 0x0cf2} , - {0x0d02, 0x0d03} + {0x0d01, 0x0d03} , {0x0d05, 0x0d0c} , @@ -4540,7 +4906,7 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x0d57, 0x0d57} , - {0x0d60, 0x0d63} + {0x0d5f, 0x0d63} , {0x0d66, 0x0d75} , @@ -4566,6 +4932,8 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x0dd8, 0x0ddf} , + {0x0de6, 0x0def} + , {0x0df2, 0x0df4} , {0x0e01, 0x0e3a} @@ -4662,13 +5030,15 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x1380, 0x1399} , - {0x13a0, 0x13f4} + {0x13a0, 0x13f5} + , + {0x13f8, 0x13fd} , {0x1400, 0x167f} , {0x1681, 0x169c} , - {0x16a0, 0x16f0} + {0x16a0, 0x16f8} , {0x1700, 0x170c} , @@ -4700,7 +5070,7 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x18b0, 0x18f5} , - {0x1900, 0x191c} + {0x1900, 0x191e} , {0x1920, 0x192b} , @@ -4730,6 +5100,8 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x1aa0, 0x1aad} , + {0x1ab0, 0x1abe} + , {0x1b00, 0x1b4b} , {0x1b50, 0x1b7c} @@ -4746,7 +5118,9 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x1cd0, 0x1cf6} , - {0x1d00, 0x1de6} + {0x1cf8, 0x1cf9} + , + {0x1d00, 0x1df5} , {0x1dfc, 0x1f15} , @@ -4790,23 +5164,29 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x2090, 0x209c} , - {0x20a0, 0x20ba} + {0x20a0, 0x20be} , {0x20d0, 0x20f0} , - {0x2100, 0x2189} + {0x2100, 0x218b} , - {0x2190, 0x23f3} + {0x2190, 0x23fa} , {0x2400, 0x2426} , {0x2440, 0x244a} , - {0x2460, 0x26ff} + {0x2460, 0x2b73} , - {0x2701, 0x2b4c} + {0x2b76, 0x2b95} , - {0x2b50, 0x2b59} + {0x2b98, 0x2bb9} + , + {0x2bbd, 0x2bc8} + , + {0x2bca, 0x2bd1} + , + {0x2bec, 0x2bef} , {0x2c00, 0x2c2e} , @@ -4842,7 +5222,7 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x2dd8, 0x2dde} , - {0x2de0, 0x2e3b} + {0x2de0, 0x2e42} , {0x2e80, 0x2e99} , @@ -4872,7 +5252,7 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x3300, 0x4db5} , - {0x4dc0, 0x9fcc} + {0x4dc0, 0x9fd5} , {0xa000, 0xa48c} , @@ -4880,17 +5260,13 @@ scm_t_char_range cs_graphic_ranges[] = { , {0xa4d0, 0xa62b} , - {0xa640, 0xa697} + {0xa640, 0xa6f7} , - {0xa69f, 0xa6f7} + {0xa700, 0xa7ad} , - {0xa700, 0xa78e} + {0xa7b0, 0xa7b7} , - {0xa790, 0xa793} - , - {0xa7a0, 0xa7aa} - , - {0xa7f8, 0xa82b} + {0xa7f7, 0xa82b} , {0xa830, 0xa839} , @@ -4900,7 +5276,7 @@ scm_t_char_range cs_graphic_ranges[] = { , {0xa8ce, 0xa8d9} , - {0xa8e0, 0xa8fb} + {0xa8e0, 0xa8fd} , {0xa900, 0xa953} , @@ -4910,7 +5286,7 @@ scm_t_char_range cs_graphic_ranges[] = { , {0xa9cf, 0xa9d9} , - {0xa9de, 0xa9df} + {0xa9de, 0xa9fe} , {0xaa00, 0xaa36} , @@ -4918,9 +5294,7 @@ scm_t_char_range cs_graphic_ranges[] = { , {0xaa50, 0xaa59} , - {0xaa5c, 0xaa7b} - , - {0xaa80, 0xaac2} + {0xaa5c, 0xaac2} , {0xaadb, 0xaaf6} , @@ -4934,7 +5308,9 @@ scm_t_char_range cs_graphic_ranges[] = { , {0xab28, 0xab2e} , - {0xabc0, 0xabed} + {0xab30, 0xab65} + , + {0xab70, 0xabed} , {0xabf0, 0xabf9} , @@ -4974,9 +5350,7 @@ scm_t_char_range cs_graphic_ranges[] = { , {0xfe00, 0xfe19} , - {0xfe20, 0xfe26} - , - {0xfe30, 0xfe52} + {0xfe20, 0xfe52} , {0xfe54, 0xfe66} , @@ -5020,22 +5394,26 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x10107, 0x10133} , - {0x10137, 0x1018a} + {0x10137, 0x1018c} , {0x10190, 0x1019b} , + {0x101a0, 0x101a0} + , {0x101d0, 0x101fd} , {0x10280, 0x1029c} , {0x102a0, 0x102d0} , - {0x10300, 0x1031e} + {0x102e0, 0x102fb} , - {0x10320, 0x10323} + {0x10300, 0x10323} , {0x10330, 0x1034a} , + {0x10350, 0x1037a} + , {0x10380, 0x1039d} , {0x1039f, 0x103c3} @@ -5046,6 +5424,18 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x104a0, 0x104a9} , + {0x10500, 0x10527} + , + {0x10530, 0x10563} + , + {0x1056f, 0x1056f} + , + {0x10600, 0x10736} + , + {0x10740, 0x10755} + , + {0x10760, 0x10767} + , {0x10800, 0x10805} , {0x10808, 0x10808} @@ -5058,9 +5448,15 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x1083f, 0x10855} , - {0x10857, 0x1085f} + {0x10857, 0x1089e} , - {0x10900, 0x1091b} + {0x108a7, 0x108af} + , + {0x108e0, 0x108f2} + , + {0x108f4, 0x108f5} + , + {0x108fb, 0x1091b} , {0x1091f, 0x10939} , @@ -5068,9 +5464,9 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x10980, 0x109b7} , - {0x109be, 0x109bf} + {0x109bc, 0x109cf} , - {0x10a00, 0x10a03} + {0x109d2, 0x10a03} , {0x10a05, 0x10a06} , @@ -5086,7 +5482,11 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x10a50, 0x10a58} , - {0x10a60, 0x10a7f} + {0x10a60, 0x10a9f} + , + {0x10ac0, 0x10ae6} + , + {0x10aeb, 0x10af6} , {0x10b00, 0x10b35} , @@ -5094,17 +5494,27 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x10b58, 0x10b72} , - {0x10b78, 0x10b7f} + {0x10b78, 0x10b91} + , + {0x10b99, 0x10b9c} + , + {0x10ba9, 0x10baf} , {0x10c00, 0x10c48} , + {0x10c80, 0x10cb2} + , + {0x10cc0, 0x10cf2} + , + {0x10cfa, 0x10cff} + , {0x10e60, 0x10e7e} , {0x11000, 0x1104d} , {0x11052, 0x1106f} , - {0x11080, 0x110bc} + {0x1107f, 0x110bc} , {0x110be, 0x110c1} , @@ -5116,24 +5526,124 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x11136, 0x11143} , - {0x11180, 0x111c8} + {0x11150, 0x11176} , - {0x111d0, 0x111d9} + {0x11180, 0x111cd} + , + {0x111d0, 0x111df} + , + {0x111e1, 0x111f4} + , + {0x11200, 0x11211} + , + {0x11213, 0x1123d} + , + {0x11280, 0x11286} + , + {0x11288, 0x11288} + , + {0x1128a, 0x1128d} + , + {0x1128f, 0x1129d} + , + {0x1129f, 0x112a9} + , + {0x112b0, 0x112ea} + , + {0x112f0, 0x112f9} + , + {0x11300, 0x11303} + , + {0x11305, 0x1130c} + , + {0x1130f, 0x11310} + , + {0x11313, 0x11328} + , + {0x1132a, 0x11330} + , + {0x11332, 0x11333} + , + {0x11335, 0x11339} + , + {0x1133c, 0x11344} + , + {0x11347, 0x11348} + , + {0x1134b, 0x1134d} + , + {0x11350, 0x11350} + , + {0x11357, 0x11357} + , + {0x1135d, 0x11363} + , + {0x11366, 0x1136c} + , + {0x11370, 0x11374} + , + {0x11480, 0x114c7} + , + {0x114d0, 0x114d9} + , + {0x11580, 0x115b5} + , + {0x115b8, 0x115dd} + , + {0x11600, 0x11644} + , + {0x11650, 0x11659} , {0x11680, 0x116b7} , {0x116c0, 0x116c9} , - {0x12000, 0x1236e} + {0x11700, 0x11719} , - {0x12400, 0x12462} + {0x1171d, 0x1172b} , - {0x12470, 0x12473} + {0x11730, 0x1173f} + , + {0x118a0, 0x118f2} + , + {0x118ff, 0x118ff} + , + {0x11ac0, 0x11af8} + , + {0x12000, 0x12399} + , + {0x12400, 0x1246e} + , + {0x12470, 0x12474} + , + {0x12480, 0x12543} , {0x13000, 0x1342e} , + {0x14400, 0x14646} + , {0x16800, 0x16a38} , + {0x16a40, 0x16a5e} + , + {0x16a60, 0x16a69} + , + {0x16a6e, 0x16a6f} + , + {0x16ad0, 0x16aed} + , + {0x16af0, 0x16af5} + , + {0x16b00, 0x16b45} + , + {0x16b50, 0x16b59} + , + {0x16b5b, 0x16b61} + , + {0x16b63, 0x16b77} + , + {0x16b7d, 0x16b8f} + , {0x16f00, 0x16f44} , {0x16f50, 0x16f7e} @@ -5142,13 +5652,23 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x1b000, 0x1b001} , + {0x1bc00, 0x1bc6a} + , + {0x1bc70, 0x1bc7c} + , + {0x1bc80, 0x1bc88} + , + {0x1bc90, 0x1bc99} + , + {0x1bc9c, 0x1bc9f} + , {0x1d000, 0x1d0f5} , {0x1d100, 0x1d126} , {0x1d129, 0x1d172} , - {0x1d17b, 0x1d1dd} + {0x1d17b, 0x1d1e8} , {0x1d200, 0x1d245} , @@ -5196,7 +5716,15 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x1d6a8, 0x1d7cb} , - {0x1d7ce, 0x1d7ff} + {0x1d7ce, 0x1da8b} + , + {0x1da9b, 0x1da9f} + , + {0x1daa1, 0x1daaf} + , + {0x1e800, 0x1e8c4} + , + {0x1e8c7, 0x1e8d6} , {0x1ee00, 0x1ee03} , @@ -5272,13 +5800,13 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x1f0a0, 0x1f0ae} , - {0x1f0b1, 0x1f0be} + {0x1f0b1, 0x1f0bf} , {0x1f0c1, 0x1f0cf} , - {0x1f0d1, 0x1f0df} + {0x1f0d1, 0x1f0f5} , - {0x1f100, 0x1f10a} + {0x1f100, 0x1f10c} , {0x1f110, 0x1f12e} , @@ -5294,55 +5822,51 @@ scm_t_char_range cs_graphic_ranges[] = { , {0x1f250, 0x1f251} , - {0x1f300, 0x1f320} + {0x1f300, 0x1f579} , - {0x1f330, 0x1f335} + {0x1f57b, 0x1f5a3} , - {0x1f337, 0x1f37c} + {0x1f5a5, 0x1f6d0} , - {0x1f380, 0x1f393} + {0x1f6e0, 0x1f6ec} , - {0x1f3a0, 0x1f3c4} - , - {0x1f3c6, 0x1f3ca} - , - {0x1f3e0, 0x1f3f0} - , - {0x1f400, 0x1f43e} - , - {0x1f440, 0x1f440} - , - {0x1f442, 0x1f4f7} - , - {0x1f4f9, 0x1f4fc} - , - {0x1f500, 0x1f53d} - , - {0x1f540, 0x1f543} - , - {0x1f550, 0x1f567} - , - {0x1f5fb, 0x1f640} - , - {0x1f645, 0x1f64f} - , - {0x1f680, 0x1f6c5} + {0x1f6f0, 0x1f6f3} , {0x1f700, 0x1f773} , + {0x1f780, 0x1f7d4} + , + {0x1f800, 0x1f80b} + , + {0x1f810, 0x1f847} + , + {0x1f850, 0x1f859} + , + {0x1f860, 0x1f887} + , + {0x1f890, 0x1f8ad} + , + {0x1f910, 0x1f918} + , + {0x1f980, 0x1f984} + , + {0x1f9c0, 0x1f9c0} + , {0x20000, 0x2a6d6} , {0x2a700, 0x2b734} , {0x2b740, 0x2b81d} , + {0x2b820, 0x2cea1} + , {0x2f800, 0x2fa1d} , {0xe0100, 0xe01ef} }; scm_t_char_set cs_graphic = { - 540, + 615, cs_graphic_ranges }; @@ -5355,8 +5879,6 @@ scm_t_char_range cs_whitespace_ranges[] = { , {0x1680, 0x1680} , - {0x180e, 0x180e} - , {0x2000, 0x200a} , {0x2028, 0x2029} @@ -5369,7 +5891,7 @@ scm_t_char_range cs_whitespace_ranges[] = { }; scm_t_char_set cs_whitespace = { - 10, + 9, cs_whitespace_ranges }; @@ -5382,7 +5904,7 @@ scm_t_char_range cs_printing_ranges[] = { , {0x00ae, 0x0377} , - {0x037a, 0x037e} + {0x037a, 0x037f} , {0x0384, 0x038a} , @@ -5390,7 +5912,7 @@ scm_t_char_range cs_printing_ranges[] = { , {0x038e, 0x03a1} , - {0x03a3, 0x0527} + {0x03a3, 0x052f} , {0x0531, 0x0556} , @@ -5400,7 +5922,7 @@ scm_t_char_range cs_printing_ranges[] = { , {0x0589, 0x058a} , - {0x058f, 0x058f} + {0x058d, 0x058f} , {0x0591, 0x05c7} , @@ -5428,17 +5950,9 @@ scm_t_char_range cs_printing_ranges[] = { , {0x085e, 0x085e} , - {0x08a0, 0x08a0} + {0x08a0, 0x08b4} , - {0x08a2, 0x08ac} - , - {0x08e4, 0x08fe} - , - {0x0900, 0x0977} - , - {0x0979, 0x097f} - , - {0x0981, 0x0983} + {0x08e3, 0x0983} , {0x0985, 0x098c} , @@ -5524,6 +6038,8 @@ scm_t_char_range cs_printing_ranges[] = { , {0x0ae6, 0x0af1} , + {0x0af9, 0x0af9} + , {0x0b01, 0x0b03} , {0x0b05, 0x0b0c} @@ -5584,7 +6100,7 @@ scm_t_char_range cs_printing_ranges[] = { , {0x0be6, 0x0bfa} , - {0x0c01, 0x0c03} + {0x0c00, 0x0c03} , {0x0c05, 0x0c0c} , @@ -5592,9 +6108,7 @@ scm_t_char_range cs_printing_ranges[] = { , {0x0c12, 0x0c28} , - {0x0c2a, 0x0c33} - , - {0x0c35, 0x0c39} + {0x0c2a, 0x0c39} , {0x0c3d, 0x0c44} , @@ -5604,7 +6118,7 @@ scm_t_char_range cs_printing_ranges[] = { , {0x0c55, 0x0c56} , - {0x0c58, 0x0c59} + {0x0c58, 0x0c5a} , {0x0c60, 0x0c63} , @@ -5612,7 +6126,7 @@ scm_t_char_range cs_printing_ranges[] = { , {0x0c78, 0x0c7f} , - {0x0c82, 0x0c83} + {0x0c81, 0x0c83} , {0x0c85, 0x0c8c} , @@ -5640,7 +6154,7 @@ scm_t_char_range cs_printing_ranges[] = { , {0x0cf1, 0x0cf2} , - {0x0d02, 0x0d03} + {0x0d01, 0x0d03} , {0x0d05, 0x0d0c} , @@ -5656,7 +6170,7 @@ scm_t_char_range cs_printing_ranges[] = { , {0x0d57, 0x0d57} , - {0x0d60, 0x0d63} + {0x0d5f, 0x0d63} , {0x0d66, 0x0d75} , @@ -5682,6 +6196,8 @@ scm_t_char_range cs_printing_ranges[] = { , {0x0dd8, 0x0ddf} , + {0x0de6, 0x0def} + , {0x0df2, 0x0df4} , {0x0e01, 0x0e3a} @@ -5778,11 +6294,13 @@ scm_t_char_range cs_printing_ranges[] = { , {0x1380, 0x1399} , - {0x13a0, 0x13f4} + {0x13a0, 0x13f5} + , + {0x13f8, 0x13fd} , {0x1400, 0x169c} , - {0x16a0, 0x16f0} + {0x16a0, 0x16f8} , {0x1700, 0x170c} , @@ -5804,7 +6322,7 @@ scm_t_char_range cs_printing_ranges[] = { , {0x17f0, 0x17f9} , - {0x1800, 0x180e} + {0x1800, 0x180d} , {0x1810, 0x1819} , @@ -5814,7 +6332,7 @@ scm_t_char_range cs_printing_ranges[] = { , {0x18b0, 0x18f5} , - {0x1900, 0x191c} + {0x1900, 0x191e} , {0x1920, 0x192b} , @@ -5844,6 +6362,8 @@ scm_t_char_range cs_printing_ranges[] = { , {0x1aa0, 0x1aad} , + {0x1ab0, 0x1abe} + , {0x1b00, 0x1b4b} , {0x1b50, 0x1b7c} @@ -5860,7 +6380,9 @@ scm_t_char_range cs_printing_ranges[] = { , {0x1cd0, 0x1cf6} , - {0x1d00, 0x1de6} + {0x1cf8, 0x1cf9} + , + {0x1d00, 0x1df5} , {0x1dfc, 0x1f15} , @@ -5906,23 +6428,29 @@ scm_t_char_range cs_printing_ranges[] = { , {0x2090, 0x209c} , - {0x20a0, 0x20ba} + {0x20a0, 0x20be} , {0x20d0, 0x20f0} , - {0x2100, 0x2189} + {0x2100, 0x218b} , - {0x2190, 0x23f3} + {0x2190, 0x23fa} , {0x2400, 0x2426} , {0x2440, 0x244a} , - {0x2460, 0x26ff} + {0x2460, 0x2b73} , - {0x2701, 0x2b4c} + {0x2b76, 0x2b95} , - {0x2b50, 0x2b59} + {0x2b98, 0x2bb9} + , + {0x2bbd, 0x2bc8} + , + {0x2bca, 0x2bd1} + , + {0x2bec, 0x2bef} , {0x2c00, 0x2c2e} , @@ -5958,7 +6486,7 @@ scm_t_char_range cs_printing_ranges[] = { , {0x2dd8, 0x2dde} , - {0x2de0, 0x2e3b} + {0x2de0, 0x2e42} , {0x2e80, 0x2e99} , @@ -5988,7 +6516,7 @@ scm_t_char_range cs_printing_ranges[] = { , {0x3300, 0x4db5} , - {0x4dc0, 0x9fcc} + {0x4dc0, 0x9fd5} , {0xa000, 0xa48c} , @@ -5996,17 +6524,13 @@ scm_t_char_range cs_printing_ranges[] = { , {0xa4d0, 0xa62b} , - {0xa640, 0xa697} + {0xa640, 0xa6f7} , - {0xa69f, 0xa6f7} + {0xa700, 0xa7ad} , - {0xa700, 0xa78e} + {0xa7b0, 0xa7b7} , - {0xa790, 0xa793} - , - {0xa7a0, 0xa7aa} - , - {0xa7f8, 0xa82b} + {0xa7f7, 0xa82b} , {0xa830, 0xa839} , @@ -6016,7 +6540,7 @@ scm_t_char_range cs_printing_ranges[] = { , {0xa8ce, 0xa8d9} , - {0xa8e0, 0xa8fb} + {0xa8e0, 0xa8fd} , {0xa900, 0xa953} , @@ -6026,7 +6550,7 @@ scm_t_char_range cs_printing_ranges[] = { , {0xa9cf, 0xa9d9} , - {0xa9de, 0xa9df} + {0xa9de, 0xa9fe} , {0xaa00, 0xaa36} , @@ -6034,9 +6558,7 @@ scm_t_char_range cs_printing_ranges[] = { , {0xaa50, 0xaa59} , - {0xaa5c, 0xaa7b} - , - {0xaa80, 0xaac2} + {0xaa5c, 0xaac2} , {0xaadb, 0xaaf6} , @@ -6050,7 +6572,9 @@ scm_t_char_range cs_printing_ranges[] = { , {0xab28, 0xab2e} , - {0xabc0, 0xabed} + {0xab30, 0xab65} + , + {0xab70, 0xabed} , {0xabf0, 0xabf9} , @@ -6090,9 +6614,7 @@ scm_t_char_range cs_printing_ranges[] = { , {0xfe00, 0xfe19} , - {0xfe20, 0xfe26} - , - {0xfe30, 0xfe52} + {0xfe20, 0xfe52} , {0xfe54, 0xfe66} , @@ -6136,22 +6658,26 @@ scm_t_char_range cs_printing_ranges[] = { , {0x10107, 0x10133} , - {0x10137, 0x1018a} + {0x10137, 0x1018c} , {0x10190, 0x1019b} , + {0x101a0, 0x101a0} + , {0x101d0, 0x101fd} , {0x10280, 0x1029c} , {0x102a0, 0x102d0} , - {0x10300, 0x1031e} + {0x102e0, 0x102fb} , - {0x10320, 0x10323} + {0x10300, 0x10323} , {0x10330, 0x1034a} , + {0x10350, 0x1037a} + , {0x10380, 0x1039d} , {0x1039f, 0x103c3} @@ -6162,6 +6688,18 @@ scm_t_char_range cs_printing_ranges[] = { , {0x104a0, 0x104a9} , + {0x10500, 0x10527} + , + {0x10530, 0x10563} + , + {0x1056f, 0x1056f} + , + {0x10600, 0x10736} + , + {0x10740, 0x10755} + , + {0x10760, 0x10767} + , {0x10800, 0x10805} , {0x10808, 0x10808} @@ -6174,9 +6712,15 @@ scm_t_char_range cs_printing_ranges[] = { , {0x1083f, 0x10855} , - {0x10857, 0x1085f} + {0x10857, 0x1089e} , - {0x10900, 0x1091b} + {0x108a7, 0x108af} + , + {0x108e0, 0x108f2} + , + {0x108f4, 0x108f5} + , + {0x108fb, 0x1091b} , {0x1091f, 0x10939} , @@ -6184,9 +6728,9 @@ scm_t_char_range cs_printing_ranges[] = { , {0x10980, 0x109b7} , - {0x109be, 0x109bf} + {0x109bc, 0x109cf} , - {0x10a00, 0x10a03} + {0x109d2, 0x10a03} , {0x10a05, 0x10a06} , @@ -6202,7 +6746,11 @@ scm_t_char_range cs_printing_ranges[] = { , {0x10a50, 0x10a58} , - {0x10a60, 0x10a7f} + {0x10a60, 0x10a9f} + , + {0x10ac0, 0x10ae6} + , + {0x10aeb, 0x10af6} , {0x10b00, 0x10b35} , @@ -6210,17 +6758,27 @@ scm_t_char_range cs_printing_ranges[] = { , {0x10b58, 0x10b72} , - {0x10b78, 0x10b7f} + {0x10b78, 0x10b91} + , + {0x10b99, 0x10b9c} + , + {0x10ba9, 0x10baf} , {0x10c00, 0x10c48} , + {0x10c80, 0x10cb2} + , + {0x10cc0, 0x10cf2} + , + {0x10cfa, 0x10cff} + , {0x10e60, 0x10e7e} , {0x11000, 0x1104d} , {0x11052, 0x1106f} , - {0x11080, 0x110bc} + {0x1107f, 0x110bc} , {0x110be, 0x110c1} , @@ -6232,24 +6790,124 @@ scm_t_char_range cs_printing_ranges[] = { , {0x11136, 0x11143} , - {0x11180, 0x111c8} + {0x11150, 0x11176} , - {0x111d0, 0x111d9} + {0x11180, 0x111cd} + , + {0x111d0, 0x111df} + , + {0x111e1, 0x111f4} + , + {0x11200, 0x11211} + , + {0x11213, 0x1123d} + , + {0x11280, 0x11286} + , + {0x11288, 0x11288} + , + {0x1128a, 0x1128d} + , + {0x1128f, 0x1129d} + , + {0x1129f, 0x112a9} + , + {0x112b0, 0x112ea} + , + {0x112f0, 0x112f9} + , + {0x11300, 0x11303} + , + {0x11305, 0x1130c} + , + {0x1130f, 0x11310} + , + {0x11313, 0x11328} + , + {0x1132a, 0x11330} + , + {0x11332, 0x11333} + , + {0x11335, 0x11339} + , + {0x1133c, 0x11344} + , + {0x11347, 0x11348} + , + {0x1134b, 0x1134d} + , + {0x11350, 0x11350} + , + {0x11357, 0x11357} + , + {0x1135d, 0x11363} + , + {0x11366, 0x1136c} + , + {0x11370, 0x11374} + , + {0x11480, 0x114c7} + , + {0x114d0, 0x114d9} + , + {0x11580, 0x115b5} + , + {0x115b8, 0x115dd} + , + {0x11600, 0x11644} + , + {0x11650, 0x11659} , {0x11680, 0x116b7} , {0x116c0, 0x116c9} , - {0x12000, 0x1236e} + {0x11700, 0x11719} , - {0x12400, 0x12462} + {0x1171d, 0x1172b} , - {0x12470, 0x12473} + {0x11730, 0x1173f} + , + {0x118a0, 0x118f2} + , + {0x118ff, 0x118ff} + , + {0x11ac0, 0x11af8} + , + {0x12000, 0x12399} + , + {0x12400, 0x1246e} + , + {0x12470, 0x12474} + , + {0x12480, 0x12543} , {0x13000, 0x1342e} , + {0x14400, 0x14646} + , {0x16800, 0x16a38} , + {0x16a40, 0x16a5e} + , + {0x16a60, 0x16a69} + , + {0x16a6e, 0x16a6f} + , + {0x16ad0, 0x16aed} + , + {0x16af0, 0x16af5} + , + {0x16b00, 0x16b45} + , + {0x16b50, 0x16b59} + , + {0x16b5b, 0x16b61} + , + {0x16b63, 0x16b77} + , + {0x16b7d, 0x16b8f} + , {0x16f00, 0x16f44} , {0x16f50, 0x16f7e} @@ -6258,13 +6916,23 @@ scm_t_char_range cs_printing_ranges[] = { , {0x1b000, 0x1b001} , + {0x1bc00, 0x1bc6a} + , + {0x1bc70, 0x1bc7c} + , + {0x1bc80, 0x1bc88} + , + {0x1bc90, 0x1bc99} + , + {0x1bc9c, 0x1bc9f} + , {0x1d000, 0x1d0f5} , {0x1d100, 0x1d126} , {0x1d129, 0x1d172} , - {0x1d17b, 0x1d1dd} + {0x1d17b, 0x1d1e8} , {0x1d200, 0x1d245} , @@ -6312,7 +6980,15 @@ scm_t_char_range cs_printing_ranges[] = { , {0x1d6a8, 0x1d7cb} , - {0x1d7ce, 0x1d7ff} + {0x1d7ce, 0x1da8b} + , + {0x1da9b, 0x1da9f} + , + {0x1daa1, 0x1daaf} + , + {0x1e800, 0x1e8c4} + , + {0x1e8c7, 0x1e8d6} , {0x1ee00, 0x1ee03} , @@ -6388,13 +7064,13 @@ scm_t_char_range cs_printing_ranges[] = { , {0x1f0a0, 0x1f0ae} , - {0x1f0b1, 0x1f0be} + {0x1f0b1, 0x1f0bf} , {0x1f0c1, 0x1f0cf} , - {0x1f0d1, 0x1f0df} + {0x1f0d1, 0x1f0f5} , - {0x1f100, 0x1f10a} + {0x1f100, 0x1f10c} , {0x1f110, 0x1f12e} , @@ -6410,55 +7086,51 @@ scm_t_char_range cs_printing_ranges[] = { , {0x1f250, 0x1f251} , - {0x1f300, 0x1f320} + {0x1f300, 0x1f579} , - {0x1f330, 0x1f335} + {0x1f57b, 0x1f5a3} , - {0x1f337, 0x1f37c} + {0x1f5a5, 0x1f6d0} , - {0x1f380, 0x1f393} + {0x1f6e0, 0x1f6ec} , - {0x1f3a0, 0x1f3c4} - , - {0x1f3c6, 0x1f3ca} - , - {0x1f3e0, 0x1f3f0} - , - {0x1f400, 0x1f43e} - , - {0x1f440, 0x1f440} - , - {0x1f442, 0x1f4f7} - , - {0x1f4f9, 0x1f4fc} - , - {0x1f500, 0x1f53d} - , - {0x1f540, 0x1f543} - , - {0x1f550, 0x1f567} - , - {0x1f5fb, 0x1f640} - , - {0x1f645, 0x1f64f} - , - {0x1f680, 0x1f6c5} + {0x1f6f0, 0x1f6f3} , {0x1f700, 0x1f773} , + {0x1f780, 0x1f7d4} + , + {0x1f800, 0x1f80b} + , + {0x1f810, 0x1f847} + , + {0x1f850, 0x1f859} + , + {0x1f860, 0x1f887} + , + {0x1f890, 0x1f8ad} + , + {0x1f910, 0x1f918} + , + {0x1f980, 0x1f984} + , + {0x1f9c0, 0x1f9c0} + , {0x20000, 0x2a6d6} , {0x2a700, 0x2b734} , {0x2b740, 0x2b81d} , + {0x2b820, 0x2cea1} + , {0x2f800, 0x2fa1d} , {0xe0100, 0xe01ef} }; scm_t_char_set cs_printing = { - 541, + 616, cs_printing_ranges }; @@ -6620,6 +7292,8 @@ scm_t_char_range cs_punctuation_ranges[] = { , {0x208d, 0x208e} , + {0x2308, 0x230b} + , {0x2329, 0x232a} , {0x2768, 0x2775} @@ -6642,7 +7316,7 @@ scm_t_char_range cs_punctuation_ranges[] = { , {0x2e00, 0x2e2e} , - {0x2e30, 0x2e3b} + {0x2e30, 0x2e42} , {0x3001, 0x3003} , @@ -6674,6 +7348,8 @@ scm_t_char_range cs_punctuation_ranges[] = { , {0xa8f8, 0xa8fa} , + {0xa8fc, 0xa8fc} + , {0xa92e, 0xa92f} , {0xa95f, 0xa95f} @@ -6730,6 +7406,8 @@ scm_t_char_range cs_punctuation_ranges[] = { , {0x103d0, 0x103d0} , + {0x1056f, 0x1056f} + , {0x10857, 0x10857} , {0x1091f, 0x1091f} @@ -6740,8 +7418,12 @@ scm_t_char_range cs_punctuation_ranges[] = { , {0x10a7f, 0x10a7f} , + {0x10af0, 0x10af6} + , {0x10b39, 0x10b3f} , + {0x10b99, 0x10b9c} + , {0x11047, 0x1104d} , {0x110bb, 0x110bc} @@ -6750,13 +7432,45 @@ scm_t_char_range cs_punctuation_ranges[] = { , {0x11140, 0x11143} , - {0x111c5, 0x111c8} + {0x11174, 0x11175} , - {0x12470, 0x12473} + {0x111c5, 0x111c9} + , + {0x111cd, 0x111cd} + , + {0x111db, 0x111db} + , + {0x111dd, 0x111df} + , + {0x11238, 0x1123d} + , + {0x112a9, 0x112a9} + , + {0x114c6, 0x114c6} + , + {0x115c1, 0x115d7} + , + {0x11641, 0x11643} + , + {0x1173c, 0x1173e} + , + {0x12470, 0x12474} + , + {0x16a6e, 0x16a6f} + , + {0x16af5, 0x16af5} + , + {0x16b37, 0x16b3b} + , + {0x16b44, 0x16b44} + , + {0x1bc9f, 0x1bc9f} + , + {0x1da87, 0x1da8b} }; scm_t_char_set cs_punctuation = { - 140, + 161, cs_punctuation_ranges }; @@ -6809,7 +7523,7 @@ scm_t_char_range cs_symbol_ranges[] = { , {0x0482, 0x0482} , - {0x058f, 0x058f} + {0x058d, 0x058f} , {0x0606, 0x0608} , @@ -6897,7 +7611,7 @@ scm_t_char_range cs_symbol_ranges[] = { , {0x208a, 0x208c} , - {0x20a0, 0x20ba} + {0x20a0, 0x20be} , {0x2100, 0x2101} , @@ -6927,9 +7641,13 @@ scm_t_char_range cs_symbol_ranges[] = { , {0x214f, 0x214f} , - {0x2190, 0x2328} + {0x218a, 0x218b} , - {0x232b, 0x23f3} + {0x2190, 0x2307} + , + {0x230c, 0x2328} + , + {0x232b, 0x23fa} , {0x2400, 0x2426} , @@ -6937,9 +7655,7 @@ scm_t_char_range cs_symbol_ranges[] = { , {0x249c, 0x24e9} , - {0x2500, 0x26ff} - , - {0x2701, 0x2767} + {0x2500, 0x2767} , {0x2794, 0x27c4} , @@ -6951,9 +7667,17 @@ scm_t_char_range cs_symbol_ranges[] = { , {0x29dc, 0x29fb} , - {0x29fe, 0x2b4c} + {0x29fe, 0x2b73} , - {0x2b50, 0x2b59} + {0x2b76, 0x2b95} + , + {0x2b98, 0x2bb9} + , + {0x2bbd, 0x2bc8} + , + {0x2bca, 0x2bd1} + , + {0x2bec, 0x2bef} , {0x2ce5, 0x2cea} , @@ -7013,6 +7737,8 @@ scm_t_char_range cs_symbol_ranges[] = { , {0xaa77, 0xaa79} , + {0xab5b, 0xab5b} + , {0xfb29, 0xfb29} , {0xfbb2, 0xfbc1} @@ -7049,10 +7775,26 @@ scm_t_char_range cs_symbol_ranges[] = { , {0x10179, 0x10189} , + {0x1018c, 0x1018c} + , {0x10190, 0x1019b} , + {0x101a0, 0x101a0} + , {0x101d0, 0x101fc} , + {0x10877, 0x10878} + , + {0x10ac8, 0x10ac8} + , + {0x1173f, 0x1173f} + , + {0x16b3c, 0x16b3f} + , + {0x16b45, 0x16b45} + , + {0x1bc9c, 0x1bc9c} + , {0x1d000, 0x1d0f5} , {0x1d100, 0x1d126} @@ -7065,7 +7807,7 @@ scm_t_char_range cs_symbol_ranges[] = { , {0x1d18c, 0x1d1a9} , - {0x1d1ae, 0x1d1dd} + {0x1d1ae, 0x1d1e8} , {0x1d200, 0x1d241} , @@ -7093,6 +7835,16 @@ scm_t_char_range cs_symbol_ranges[] = { , {0x1d7c3, 0x1d7c3} , + {0x1d800, 0x1d9ff} + , + {0x1da37, 0x1da3a} + , + {0x1da6d, 0x1da74} + , + {0x1da76, 0x1da83} + , + {0x1da85, 0x1da86} + , {0x1eef0, 0x1eef1} , {0x1f000, 0x1f02b} @@ -7101,11 +7853,11 @@ scm_t_char_range cs_symbol_ranges[] = { , {0x1f0a0, 0x1f0ae} , - {0x1f0b1, 0x1f0be} + {0x1f0b1, 0x1f0bf} , {0x1f0c1, 0x1f0cf} , - {0x1f0d1, 0x1f0df} + {0x1f0d1, 0x1f0f5} , {0x1f110, 0x1f12e} , @@ -7121,45 +7873,39 @@ scm_t_char_range cs_symbol_ranges[] = { , {0x1f250, 0x1f251} , - {0x1f300, 0x1f320} + {0x1f300, 0x1f579} , - {0x1f330, 0x1f335} + {0x1f57b, 0x1f5a3} , - {0x1f337, 0x1f37c} + {0x1f5a5, 0x1f6d0} , - {0x1f380, 0x1f393} + {0x1f6e0, 0x1f6ec} , - {0x1f3a0, 0x1f3c4} - , - {0x1f3c6, 0x1f3ca} - , - {0x1f3e0, 0x1f3f0} - , - {0x1f400, 0x1f43e} - , - {0x1f440, 0x1f440} - , - {0x1f442, 0x1f4f7} - , - {0x1f4f9, 0x1f4fc} - , - {0x1f500, 0x1f53d} - , - {0x1f540, 0x1f543} - , - {0x1f550, 0x1f567} - , - {0x1f5fb, 0x1f640} - , - {0x1f645, 0x1f64f} - , - {0x1f680, 0x1f6c5} + {0x1f6f0, 0x1f6f3} , {0x1f700, 0x1f773} + , + {0x1f780, 0x1f7d4} + , + {0x1f800, 0x1f80b} + , + {0x1f810, 0x1f847} + , + {0x1f850, 0x1f859} + , + {0x1f860, 0x1f887} + , + {0x1f890, 0x1f8ad} + , + {0x1f910, 0x1f918} + , + {0x1f980, 0x1f984} + , + {0x1f9c0, 0x1f9c0} }; scm_t_char_set cs_symbol = { - 198, + 214, cs_symbol_ranges }; @@ -7172,8 +7918,6 @@ scm_t_char_range cs_blank_ranges[] = { , {0x1680, 0x1680} , - {0x180e, 0x180e} - , {0x2000, 0x200a} , {0x202f, 0x202f} @@ -7184,7 +7928,7 @@ scm_t_char_range cs_blank_ranges[] = { }; scm_t_char_set cs_blank = { - 9, + 8, cs_blank_ranges }; @@ -7208,7 +7952,7 @@ scm_t_char_set cs_empty = { scm_t_char_range cs_designated_ranges[] = { {0x0000, 0x0377} , - {0x037a, 0x037e} + {0x037a, 0x037f} , {0x0384, 0x038a} , @@ -7216,7 +7960,7 @@ scm_t_char_range cs_designated_ranges[] = { , {0x038e, 0x03a1} , - {0x03a3, 0x0527} + {0x03a3, 0x052f} , {0x0531, 0x0556} , @@ -7226,7 +7970,7 @@ scm_t_char_range cs_designated_ranges[] = { , {0x0589, 0x058a} , - {0x058f, 0x058f} + {0x058d, 0x058f} , {0x0591, 0x05c7} , @@ -7234,9 +7978,7 @@ scm_t_char_range cs_designated_ranges[] = { , {0x05f0, 0x05f4} , - {0x0600, 0x0604} - , - {0x0606, 0x061b} + {0x0600, 0x061c} , {0x061e, 0x070d} , @@ -7254,17 +7996,9 @@ scm_t_char_range cs_designated_ranges[] = { , {0x085e, 0x085e} , - {0x08a0, 0x08a0} + {0x08a0, 0x08b4} , - {0x08a2, 0x08ac} - , - {0x08e4, 0x08fe} - , - {0x0900, 0x0977} - , - {0x0979, 0x097f} - , - {0x0981, 0x0983} + {0x08e3, 0x0983} , {0x0985, 0x098c} , @@ -7350,6 +8084,8 @@ scm_t_char_range cs_designated_ranges[] = { , {0x0ae6, 0x0af1} , + {0x0af9, 0x0af9} + , {0x0b01, 0x0b03} , {0x0b05, 0x0b0c} @@ -7410,7 +8146,7 @@ scm_t_char_range cs_designated_ranges[] = { , {0x0be6, 0x0bfa} , - {0x0c01, 0x0c03} + {0x0c00, 0x0c03} , {0x0c05, 0x0c0c} , @@ -7418,9 +8154,7 @@ scm_t_char_range cs_designated_ranges[] = { , {0x0c12, 0x0c28} , - {0x0c2a, 0x0c33} - , - {0x0c35, 0x0c39} + {0x0c2a, 0x0c39} , {0x0c3d, 0x0c44} , @@ -7430,7 +8164,7 @@ scm_t_char_range cs_designated_ranges[] = { , {0x0c55, 0x0c56} , - {0x0c58, 0x0c59} + {0x0c58, 0x0c5a} , {0x0c60, 0x0c63} , @@ -7438,7 +8172,7 @@ scm_t_char_range cs_designated_ranges[] = { , {0x0c78, 0x0c7f} , - {0x0c82, 0x0c83} + {0x0c81, 0x0c83} , {0x0c85, 0x0c8c} , @@ -7466,7 +8200,7 @@ scm_t_char_range cs_designated_ranges[] = { , {0x0cf1, 0x0cf2} , - {0x0d02, 0x0d03} + {0x0d01, 0x0d03} , {0x0d05, 0x0d0c} , @@ -7482,7 +8216,7 @@ scm_t_char_range cs_designated_ranges[] = { , {0x0d57, 0x0d57} , - {0x0d60, 0x0d63} + {0x0d5f, 0x0d63} , {0x0d66, 0x0d75} , @@ -7508,6 +8242,8 @@ scm_t_char_range cs_designated_ranges[] = { , {0x0dd8, 0x0ddf} , + {0x0de6, 0x0def} + , {0x0df2, 0x0df4} , {0x0e01, 0x0e3a} @@ -7604,11 +8340,13 @@ scm_t_char_range cs_designated_ranges[] = { , {0x1380, 0x1399} , - {0x13a0, 0x13f4} + {0x13a0, 0x13f5} + , + {0x13f8, 0x13fd} , {0x1400, 0x169c} , - {0x16a0, 0x16f0} + {0x16a0, 0x16f8} , {0x1700, 0x170c} , @@ -7640,7 +8378,7 @@ scm_t_char_range cs_designated_ranges[] = { , {0x18b0, 0x18f5} , - {0x1900, 0x191c} + {0x1900, 0x191e} , {0x1920, 0x192b} , @@ -7670,6 +8408,8 @@ scm_t_char_range cs_designated_ranges[] = { , {0x1aa0, 0x1aad} , + {0x1ab0, 0x1abe} + , {0x1b00, 0x1b4b} , {0x1b50, 0x1b7c} @@ -7686,7 +8426,9 @@ scm_t_char_range cs_designated_ranges[] = { , {0x1cd0, 0x1cf6} , - {0x1d00, 0x1de6} + {0x1cf8, 0x1cf9} + , + {0x1d00, 0x1df5} , {0x1dfc, 0x1f15} , @@ -7722,29 +8464,35 @@ scm_t_char_range cs_designated_ranges[] = { , {0x2000, 0x2064} , - {0x206a, 0x2071} + {0x2066, 0x2071} , {0x2074, 0x208e} , {0x2090, 0x209c} , - {0x20a0, 0x20ba} + {0x20a0, 0x20be} , {0x20d0, 0x20f0} , - {0x2100, 0x2189} + {0x2100, 0x218b} , - {0x2190, 0x23f3} + {0x2190, 0x23fa} , {0x2400, 0x2426} , {0x2440, 0x244a} , - {0x2460, 0x26ff} + {0x2460, 0x2b73} , - {0x2701, 0x2b4c} + {0x2b76, 0x2b95} , - {0x2b50, 0x2b59} + {0x2b98, 0x2bb9} + , + {0x2bbd, 0x2bc8} + , + {0x2bca, 0x2bd1} + , + {0x2bec, 0x2bef} , {0x2c00, 0x2c2e} , @@ -7780,7 +8528,7 @@ scm_t_char_range cs_designated_ranges[] = { , {0x2dd8, 0x2dde} , - {0x2de0, 0x2e3b} + {0x2de0, 0x2e42} , {0x2e80, 0x2e99} , @@ -7810,7 +8558,7 @@ scm_t_char_range cs_designated_ranges[] = { , {0x3300, 0x4db5} , - {0x4dc0, 0x9fcc} + {0x4dc0, 0x9fd5} , {0xa000, 0xa48c} , @@ -7818,17 +8566,13 @@ scm_t_char_range cs_designated_ranges[] = { , {0xa4d0, 0xa62b} , - {0xa640, 0xa697} + {0xa640, 0xa6f7} , - {0xa69f, 0xa6f7} + {0xa700, 0xa7ad} , - {0xa700, 0xa78e} + {0xa7b0, 0xa7b7} , - {0xa790, 0xa793} - , - {0xa7a0, 0xa7aa} - , - {0xa7f8, 0xa82b} + {0xa7f7, 0xa82b} , {0xa830, 0xa839} , @@ -7838,7 +8582,7 @@ scm_t_char_range cs_designated_ranges[] = { , {0xa8ce, 0xa8d9} , - {0xa8e0, 0xa8fb} + {0xa8e0, 0xa8fd} , {0xa900, 0xa953} , @@ -7848,7 +8592,7 @@ scm_t_char_range cs_designated_ranges[] = { , {0xa9cf, 0xa9d9} , - {0xa9de, 0xa9df} + {0xa9de, 0xa9fe} , {0xaa00, 0xaa36} , @@ -7856,9 +8600,7 @@ scm_t_char_range cs_designated_ranges[] = { , {0xaa50, 0xaa59} , - {0xaa5c, 0xaa7b} - , - {0xaa80, 0xaac2} + {0xaa5c, 0xaac2} , {0xaadb, 0xaaf6} , @@ -7872,7 +8614,9 @@ scm_t_char_range cs_designated_ranges[] = { , {0xab28, 0xab2e} , - {0xabc0, 0xabed} + {0xab30, 0xab65} + , + {0xab70, 0xabed} , {0xabf0, 0xabf9} , @@ -7912,9 +8656,7 @@ scm_t_char_range cs_designated_ranges[] = { , {0xfe00, 0xfe19} , - {0xfe20, 0xfe26} - , - {0xfe30, 0xfe52} + {0xfe20, 0xfe52} , {0xfe54, 0xfe66} , @@ -7960,22 +8702,26 @@ scm_t_char_range cs_designated_ranges[] = { , {0x10107, 0x10133} , - {0x10137, 0x1018a} + {0x10137, 0x1018c} , {0x10190, 0x1019b} , + {0x101a0, 0x101a0} + , {0x101d0, 0x101fd} , {0x10280, 0x1029c} , {0x102a0, 0x102d0} , - {0x10300, 0x1031e} + {0x102e0, 0x102fb} , - {0x10320, 0x10323} + {0x10300, 0x10323} , {0x10330, 0x1034a} , + {0x10350, 0x1037a} + , {0x10380, 0x1039d} , {0x1039f, 0x103c3} @@ -7986,6 +8732,18 @@ scm_t_char_range cs_designated_ranges[] = { , {0x104a0, 0x104a9} , + {0x10500, 0x10527} + , + {0x10530, 0x10563} + , + {0x1056f, 0x1056f} + , + {0x10600, 0x10736} + , + {0x10740, 0x10755} + , + {0x10760, 0x10767} + , {0x10800, 0x10805} , {0x10808, 0x10808} @@ -7998,9 +8756,15 @@ scm_t_char_range cs_designated_ranges[] = { , {0x1083f, 0x10855} , - {0x10857, 0x1085f} + {0x10857, 0x1089e} , - {0x10900, 0x1091b} + {0x108a7, 0x108af} + , + {0x108e0, 0x108f2} + , + {0x108f4, 0x108f5} + , + {0x108fb, 0x1091b} , {0x1091f, 0x10939} , @@ -8008,9 +8772,9 @@ scm_t_char_range cs_designated_ranges[] = { , {0x10980, 0x109b7} , - {0x109be, 0x109bf} + {0x109bc, 0x109cf} , - {0x10a00, 0x10a03} + {0x109d2, 0x10a03} , {0x10a05, 0x10a06} , @@ -8026,7 +8790,11 @@ scm_t_char_range cs_designated_ranges[] = { , {0x10a50, 0x10a58} , - {0x10a60, 0x10a7f} + {0x10a60, 0x10a9f} + , + {0x10ac0, 0x10ae6} + , + {0x10aeb, 0x10af6} , {0x10b00, 0x10b35} , @@ -8034,17 +8802,27 @@ scm_t_char_range cs_designated_ranges[] = { , {0x10b58, 0x10b72} , - {0x10b78, 0x10b7f} + {0x10b78, 0x10b91} + , + {0x10b99, 0x10b9c} + , + {0x10ba9, 0x10baf} , {0x10c00, 0x10c48} , + {0x10c80, 0x10cb2} + , + {0x10cc0, 0x10cf2} + , + {0x10cfa, 0x10cff} + , {0x10e60, 0x10e7e} , {0x11000, 0x1104d} , {0x11052, 0x1106f} , - {0x11080, 0x110c1} + {0x1107f, 0x110c1} , {0x110d0, 0x110e8} , @@ -8054,24 +8832,124 @@ scm_t_char_range cs_designated_ranges[] = { , {0x11136, 0x11143} , - {0x11180, 0x111c8} + {0x11150, 0x11176} , - {0x111d0, 0x111d9} + {0x11180, 0x111cd} + , + {0x111d0, 0x111df} + , + {0x111e1, 0x111f4} + , + {0x11200, 0x11211} + , + {0x11213, 0x1123d} + , + {0x11280, 0x11286} + , + {0x11288, 0x11288} + , + {0x1128a, 0x1128d} + , + {0x1128f, 0x1129d} + , + {0x1129f, 0x112a9} + , + {0x112b0, 0x112ea} + , + {0x112f0, 0x112f9} + , + {0x11300, 0x11303} + , + {0x11305, 0x1130c} + , + {0x1130f, 0x11310} + , + {0x11313, 0x11328} + , + {0x1132a, 0x11330} + , + {0x11332, 0x11333} + , + {0x11335, 0x11339} + , + {0x1133c, 0x11344} + , + {0x11347, 0x11348} + , + {0x1134b, 0x1134d} + , + {0x11350, 0x11350} + , + {0x11357, 0x11357} + , + {0x1135d, 0x11363} + , + {0x11366, 0x1136c} + , + {0x11370, 0x11374} + , + {0x11480, 0x114c7} + , + {0x114d0, 0x114d9} + , + {0x11580, 0x115b5} + , + {0x115b8, 0x115dd} + , + {0x11600, 0x11644} + , + {0x11650, 0x11659} , {0x11680, 0x116b7} , {0x116c0, 0x116c9} , - {0x12000, 0x1236e} + {0x11700, 0x11719} , - {0x12400, 0x12462} + {0x1171d, 0x1172b} , - {0x12470, 0x12473} + {0x11730, 0x1173f} + , + {0x118a0, 0x118f2} + , + {0x118ff, 0x118ff} + , + {0x11ac0, 0x11af8} + , + {0x12000, 0x12399} + , + {0x12400, 0x1246e} + , + {0x12470, 0x12474} + , + {0x12480, 0x12543} , {0x13000, 0x1342e} , + {0x14400, 0x14646} + , {0x16800, 0x16a38} , + {0x16a40, 0x16a5e} + , + {0x16a60, 0x16a69} + , + {0x16a6e, 0x16a6f} + , + {0x16ad0, 0x16aed} + , + {0x16af0, 0x16af5} + , + {0x16b00, 0x16b45} + , + {0x16b50, 0x16b59} + , + {0x16b5b, 0x16b61} + , + {0x16b63, 0x16b77} + , + {0x16b7d, 0x16b8f} + , {0x16f00, 0x16f44} , {0x16f50, 0x16f7e} @@ -8080,11 +8958,21 @@ scm_t_char_range cs_designated_ranges[] = { , {0x1b000, 0x1b001} , + {0x1bc00, 0x1bc6a} + , + {0x1bc70, 0x1bc7c} + , + {0x1bc80, 0x1bc88} + , + {0x1bc90, 0x1bc99} + , + {0x1bc9c, 0x1bca3} + , {0x1d000, 0x1d0f5} , {0x1d100, 0x1d126} , - {0x1d129, 0x1d1dd} + {0x1d129, 0x1d1e8} , {0x1d200, 0x1d245} , @@ -8132,7 +9020,15 @@ scm_t_char_range cs_designated_ranges[] = { , {0x1d6a8, 0x1d7cb} , - {0x1d7ce, 0x1d7ff} + {0x1d7ce, 0x1da8b} + , + {0x1da9b, 0x1da9f} + , + {0x1daa1, 0x1daaf} + , + {0x1e800, 0x1e8c4} + , + {0x1e8c7, 0x1e8d6} , {0x1ee00, 0x1ee03} , @@ -8208,13 +9104,13 @@ scm_t_char_range cs_designated_ranges[] = { , {0x1f0a0, 0x1f0ae} , - {0x1f0b1, 0x1f0be} + {0x1f0b1, 0x1f0bf} , {0x1f0c1, 0x1f0cf} , - {0x1f0d1, 0x1f0df} + {0x1f0d1, 0x1f0f5} , - {0x1f100, 0x1f10a} + {0x1f100, 0x1f10c} , {0x1f110, 0x1f12e} , @@ -8230,48 +9126,44 @@ scm_t_char_range cs_designated_ranges[] = { , {0x1f250, 0x1f251} , - {0x1f300, 0x1f320} + {0x1f300, 0x1f579} , - {0x1f330, 0x1f335} + {0x1f57b, 0x1f5a3} , - {0x1f337, 0x1f37c} + {0x1f5a5, 0x1f6d0} , - {0x1f380, 0x1f393} + {0x1f6e0, 0x1f6ec} , - {0x1f3a0, 0x1f3c4} - , - {0x1f3c6, 0x1f3ca} - , - {0x1f3e0, 0x1f3f0} - , - {0x1f400, 0x1f43e} - , - {0x1f440, 0x1f440} - , - {0x1f442, 0x1f4f7} - , - {0x1f4f9, 0x1f4fc} - , - {0x1f500, 0x1f53d} - , - {0x1f540, 0x1f543} - , - {0x1f550, 0x1f567} - , - {0x1f5fb, 0x1f640} - , - {0x1f645, 0x1f64f} - , - {0x1f680, 0x1f6c5} + {0x1f6f0, 0x1f6f3} , {0x1f700, 0x1f773} , + {0x1f780, 0x1f7d4} + , + {0x1f800, 0x1f80b} + , + {0x1f810, 0x1f847} + , + {0x1f850, 0x1f859} + , + {0x1f860, 0x1f887} + , + {0x1f890, 0x1f8ad} + , + {0x1f910, 0x1f918} + , + {0x1f980, 0x1f984} + , + {0x1f9c0, 0x1f9c0} + , {0x20000, 0x2a6d6} , {0x2a700, 0x2b734} , {0x2b740, 0x2b81d} , + {0x2b820, 0x2cea1} + , {0x2f800, 0x2fa1d} , {0xe0001, 0xe0001} @@ -8286,6 +9178,6 @@ scm_t_char_range cs_designated_ranges[] = { }; scm_t_char_set cs_designated = { - 539, + 613, cs_designated_ranges }; From 7d7e4bc6c0e9a109eafc68ae7e5494f6a1dcaab9 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 13 Nov 2015 11:38:13 -0500 Subject: [PATCH 332/865] Fix getsockopt/setsockopt handling of SO_SNDBUF/SO_RCVBUF options. Reported by Park SungMin in . * libguile/socket.c (scm_getsockopt, scm_setsockopt): Remove code that incorrectly assumed that the argument for SO_SNDBUF and SO_RCVBUF options was of type 'size_t'. Both the Linux and POSIX documentation indicates that the argument is of type 'int', as is the case for most options. --- libguile/socket.c | 30 ++---------------------------- 1 file changed, 2 insertions(+), 28 deletions(-) diff --git a/libguile/socket.c b/libguile/socket.c index 2a9be5471..a6f1e5fca 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -1,5 +1,5 @@ -/* Copyright (C) 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, - * 2006, 2007, 2009, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +/* Copyright (C) 1996-1998, 2000-2007, 2009, 2011-2015 + * 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 License @@ -508,19 +508,7 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0, scm_from_int (0)); #endif } - else #endif - if (0 -#ifdef SO_SNDBUF - || ioptname == SO_SNDBUF -#endif -#ifdef SO_RCVBUF - || ioptname == SO_RCVBUF -#endif - ) - { - return scm_from_size_t (*(size_t *) &optval); - } } return scm_from_int (*(int *) &optval); } @@ -649,21 +637,7 @@ SCM_DEFINE (scm_setsockopt, "setsockopt", 4, 0, 0, optval = &opt_int; #endif } - else #endif - if (0 -#ifdef SO_SNDBUF - || ioptname == SO_SNDBUF -#endif -#ifdef SO_RCVBUF - || ioptname == SO_RCVBUF -#endif - ) - { - opt_int = scm_to_int (value); - optlen = sizeof (size_t); - optval = &opt_int; - } } #ifdef HAVE_STRUCT_IP_MREQ From 95d146ff51741df1673ec650ff3774a99c72bbf3 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 28 Nov 2015 12:38:16 -0500 Subject: [PATCH 333/865] Bump user-visible copyright years to 2015. * module/ice-9/command-line.scm (version-etc): Bump 'copyright-year' to 2015. * module/system/repl/common.scm (*version*): Add 2015 to the range of copyright years. --- module/ice-9/command-line.scm | 2 +- module/system/repl/common.scm | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm index 0d2f3d601..83f301d92 100644 --- a/module/ice-9/command-line.scm +++ b/module/ice-9/command-line.scm @@ -66,7 +66,7 @@ There is NO WARRANTY, to the extent permitted by law.")) (define* (version-etc package version #:key (port (current-output-port)) ;; FIXME: authors - (copyright-year 2014) + (copyright-year 2015) (copyright-holder "Free Software Foundation, Inc.") (copyright (format #f "Copyright (C) ~a ~a" copyright-year copyright-holder)) diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm index f0e6e03a0..3df7852bd 100644 --- a/module/system/repl/common.scm +++ b/module/system/repl/common.scm @@ -41,7 +41,7 @@ (define *version* (format #f "GNU Guile ~A -Copyright (C) 1995-2014 Free Software Foundation, Inc. +Copyright (C) 1995-2015 Free Software Foundation, Inc. Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'. This program is free software, and you are welcome to redistribute it From 3829047ec78d8001bf559fd0fb8ceae100f77e8f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 6 Jan 2016 15:06:52 +0100 Subject: [PATCH 334/865] http: Test that responses lacking CR/LF are rejected. * test-suite/tests/web-http.test ("read-response-line")["missing CR/LF"]: New test. --- test-suite/tests/web-http.test | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test index bd14de9b9..de2ccaa5b 100644 --- a/test-suite/tests/web-http.test +++ b/test-suite/tests/web-http.test @@ -186,6 +186,11 @@ (1 . 1))) (with-test-prefix "read-response-line" + (pass-if-exception "missing CR/LF" + `(bad-header . "") + (call-with-input-string "HTTP/1.1 200 Almost okay" + (lambda (port) + (read-response-line port)))) (pass-if-read-response-line "HTTP/1.0 404 Not Found" (1 . 0) 404 "Not Found") (pass-if-read-response-line "HTTP/1.1 200 OK" From f53145d41cbf6908959e230dc53cfccf38d92380 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 6 Jan 2016 14:56:00 +0100 Subject: [PATCH 335/865] http: Accept empty reason phrases. Fixes . Reported by Ricardo Wurmus . * module/web/http.scm (read-header-line): New procedure. (read-response-line): Use it instead of 'read-line*'. * test-suite/tests/web-http.test ("read-response-line"): Add test. --- module/web/http.scm | 25 ++++++++++++++++++++----- test-suite/tests/web-http.test | 6 +++++- 2 files changed, 25 insertions(+), 6 deletions(-) diff --git a/module/web/http.scm b/module/web/http.scm index 5ce7e7c67..f46c384ce 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -144,7 +144,22 @@ The default writer is ‘display’." (header-decl-writer decl) display))) -(define (read-line* port) +(define (read-header-line port) + "Read an HTTP header line and return it without its final CRLF or LF. +Raise a 'bad-header' exception if the line does not end in CRLF or LF, +or if EOF is reached." + (match (%read-line port) + (((? string? line) . #\newline) + ;; '%read-line' does not consider #\return a delimiter; so if it's + ;; there, remove it. We are more tolerant than the RFC in that we + ;; tolerate LF-only endings. + (if (string-suffix? "\r" line) + (string-drop-right line 1) + line)) + ((line . _) ;EOF or missing delimiter + (bad-header 'read-header-line line)))) + +(define* (read-line* port) (let* ((pair (%read-line port)) (line (car pair)) (delim (cdr pair))) @@ -1155,10 +1170,10 @@ three values: the method, the URI, and the version." (display "\r\n" port)) (define (read-response-line port) - "Read the first line of an HTTP response from PORT, returning -three values: the HTTP version, the response code, and the \"reason -phrase\"." - (let* ((line (read-line* port)) + "Read the first line of an HTTP response from PORT, returning three +values: the HTTP version, the response code, and the (possibly empty) +\"reason phrase\"." + (let* ((line (read-header-line port)) (d0 (string-index line char-set:whitespace)) ; "delimiter zero" (d1 (and d0 (string-index line char-set:whitespace (skip-whitespace line d0))))) diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test index de2ccaa5b..f88f011a6 100644 --- a/test-suite/tests/web-http.test +++ b/test-suite/tests/web-http.test @@ -194,7 +194,11 @@ (pass-if-read-response-line "HTTP/1.0 404 Not Found" (1 . 0) 404 "Not Found") (pass-if-read-response-line "HTTP/1.1 200 OK" - (1 . 1) 200 "OK")) + (1 . 1) 200 "OK") + + ;; Empty reason phrases are valid; see . + (pass-if-read-response-line "HTTP/1.1 302 " + (1 . 1) 302 "")) (with-test-prefix "write-response-line" (pass-if-write-response-line "HTTP/1.0 404 Not Found" From 66bc464542808a7038662f0a4ea932f3eabcf2ca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 6 Jan 2016 17:15:20 +0100 Subject: [PATCH 336/865] http: Use 'read-header-line' instead of 'read-line*'. * module/web/http.scm (read-line*): Remove. (read-continuation-line, read-header, read-request-line): Use 'read-header-line' instead of 'read-line*'. --- module/web/http.scm | 22 +++------------------- 1 file changed, 3 insertions(+), 19 deletions(-) diff --git a/module/web/http.scm b/module/web/http.scm index f46c384ce..0bcd9058b 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -159,28 +159,12 @@ or if EOF is reached." ((line . _) ;EOF or missing delimiter (bad-header 'read-header-line line)))) -(define* (read-line* port) - (let* ((pair (%read-line port)) - (line (car pair)) - (delim (cdr pair))) - (if (and (string? line) (char? delim)) - (let ((orig-len (string-length line))) - (let lp ((len orig-len)) - (if (and (> len 0) - (char-whitespace? (string-ref line (1- len)))) - (lp (1- len)) - (if (= len orig-len) - line - (substring line 0 len))))) - (bad-header '%read line)))) - (define (read-continuation-line port val) (if (or (eqv? (peek-char port) #\space) (eqv? (peek-char port) #\tab)) (read-continuation-line port (string-append val - (begin - (read-line* port)))) + (read-header-line port))) val)) (define *eof* (call-with-input-string "" read)) @@ -192,7 +176,7 @@ was known but the value was invalid. Returns the end-of-file object for both values if the end of the message body was reached (i.e., a blank line)." - (let ((line (read-line* port))) + (let ((line (read-header-line port))) (if (or (string-null? line) (string=? line "\r")) (values *eof* *eof*) @@ -1101,7 +1085,7 @@ not have to have a scheme or host name. The result is a URI object." (define (read-request-line port) "Read the first line of an HTTP request from PORT, returning three values: the method, the URI, and the version." - (let* ((line (read-line* port)) + (let* ((line (read-header-line port)) (d0 (string-index line char-set:whitespace)) ; "delimiter zero" (d1 (string-rindex line char-set:whitespace))) (if (and d0 d1 (< d0 d1)) From 994b7d70e6063e83f2c6d933c0f979aa77130a94 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 6 Jan 2016 16:39:13 -0500 Subject: [PATCH 337/865] SRFI-19: Update the table of leap seconds. * module/srfi/srfi-19.scm (leap-second-table): Update to include the most recent leap second. --- module/srfi/srfi-19.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm index 6d86ee638..658ccd915 100644 --- a/module/srfi/srfi-19.scm +++ b/module/srfi/srfi-19.scm @@ -1,7 +1,7 @@ ;;; srfi-19.scm --- Time/Date Library -;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008, 2009, 2010, -;; 2011, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2001-2003, 2005-2011, 2014, 2016 +;; 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 @@ -203,7 +203,8 @@ ;; each entry is (tai seconds since epoch . # seconds to subtract for utc) ;; note they go higher to lower, and end in 1972. (define leap-second-table - '((1341100800 . 35) + '((1435708800 . 36) + (1341100800 . 35) (1230768000 . 34) (1136073600 . 33) (915148800 . 32) From 140496cc00736f61d5c8710207288cd9c7acd975 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 5 Jan 2016 16:33:25 -0500 Subject: [PATCH 338/865] Bump user-visible copyright years to 2016. * doc/ref/guile.texi: Add 2016 to user-visible copyright notice. * module/ice-9/command-line.scm (version-etc): Bump 'copyright-year' to 2016. * module/system/repl/common.scm (*version*): Add 2016 to the range of copyright years. --- doc/ref/guile.texi | 2 +- module/ice-9/command-line.scm | 4 ++-- module/system/repl/common.scm | 5 ++--- 3 files changed, 5 insertions(+), 6 deletions(-) diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index cb4c431f2..0ab536b27 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -14,7 +14,7 @@ This manual documents Guile version @value{VERSION}. Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2009, -2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation. +2010, 2011, 2012, 2013, 2014, 2015, 2016 Free Software Foundation. Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm index 83f301d92..98d385569 100644 --- a/module/ice-9/command-line.scm +++ b/module/ice-9/command-line.scm @@ -1,6 +1,6 @@ ;;; Parsing Guile's command-line -;;; Copyright (C) 1994-1998, 2000-2015 Free Software Foundation, Inc. +;;; Copyright (C) 1994-1998, 2000-2016 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 @@ -66,7 +66,7 @@ There is NO WARRANTY, to the extent permitted by law.")) (define* (version-etc package version #:key (port (current-output-port)) ;; FIXME: authors - (copyright-year 2015) + (copyright-year 2016) (copyright-holder "Free Software Foundation, Inc.") (copyright (format #f "Copyright (C) ~a ~a" copyright-year copyright-holder)) diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm index 3df7852bd..3bd049159 100644 --- a/module/system/repl/common.scm +++ b/module/system/repl/common.scm @@ -1,7 +1,6 @@ ;;; Repl common routines -;; Copyright (C) 2001, 2008, 2009, 2010, 2011, 2012, -;; 2013, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2008-2016 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 @@ -41,7 +40,7 @@ (define *version* (format #f "GNU Guile ~A -Copyright (C) 1995-2015 Free Software Foundation, Inc. +Copyright (C) 1995-2016 Free Software Foundation, Inc. Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'. This program is free software, and you are welcome to redistribute it From b9f6e89a271c04741231b64b03fe7fc294723f1d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 8 May 2016 21:52:33 +0200 Subject: [PATCH 339/865] http: Accept date strings with a leading space for hours. Fixes . Reported by Ricardo Wurmus . * module/web/http.scm (parse-rfc-822-date): Add two clauses for hours with a leading space. * test-suite/tests/web-http.test ("general headers"): Add two tests. --- module/web/http.scm | 20 ++++++++++++++++++++ test-suite/tests/web-http.test | 10 ++++++++++ 2 files changed, 30 insertions(+) diff --git a/module/web/http.scm b/module/web/http.scm index 0bcd9058b..8e95fc755 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -751,6 +751,26 @@ as an ordered alist." (minute (parse-non-negative-integer str 19 21)) (second (parse-non-negative-integer str 22 24))) (make-date 0 second minute hour date month year zone-offset))) + + ;; The next two clauses match dates that have a space instead of + ;; a leading zero for hours, like " 8:49:37". + ((string-match? (substring str 0 space) "aaa, dd aaa dddd d:dd:dd") + (let ((date (parse-non-negative-integer str 5 7)) + (month (parse-month str 8 11)) + (year (parse-non-negative-integer str 12 16)) + (hour (parse-non-negative-integer str 18 19)) + (minute (parse-non-negative-integer str 20 22)) + (second (parse-non-negative-integer str 23 25))) + (make-date 0 second minute hour date month year zone-offset))) + ((string-match? (substring str 0 space) "aaa, d aaa dddd d:dd:dd") + (let ((date (parse-non-negative-integer str 5 6)) + (month (parse-month str 7 10)) + (year (parse-non-negative-integer str 11 15)) + (hour (parse-non-negative-integer str 17 18)) + (minute (parse-non-negative-integer str 19 21)) + (second (parse-non-negative-integer str 22 24))) + (make-date 0 second minute hour date month year zone-offset))) + (else (bad-header 'date str) ; prevent tail call #f))) diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test index f88f011a6..3fda4f9fb 100644 --- a/test-suite/tests/web-http.test +++ b/test-suite/tests/web-http.test @@ -236,6 +236,16 @@ (pass-if-parse date "Wed, 7 Sep 2011 11:25:00 GMT" (string->date "Wed, 7 Sep 2011 11:25:00 +0000" "~a,~e ~b ~Y ~H:~M:~S ~z")) + + ;; This is a non-conforming date (lack of leading zero for the hours) + ;; that some HTTP servers provide. See . + (pass-if-parse date "Sun, 06 Nov 1994 8:49:37 GMT" + (string->date "Sun, 6 Nov 1994 08:49:37 +0000" + "~a,~e ~b ~Y ~H:~M:~S ~z")) + (pass-if-parse date "Sun, 6 Nov 1994 8:49:37 GMT" + (string->date "Sun, 6 Nov 1994 08:49:37 +0000" + "~a,~e ~b ~Y ~H:~M:~S ~z")) + (pass-if-parse-error date "Tue, 15 Nov 1994 08:12:31 EST" date) (pass-if-any-error date "Tue, 15 Qux 1994 08:12:31 EST") From a7d0a0de2fa5fd99f001b1c6d42c0ae497a2cb1f Mon Sep 17 00:00:00 2001 From: Luribert Date: Thu, 21 Apr 2016 18:56:58 +0200 Subject: [PATCH 340/865] doc: Fix typo in Web documentation. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * doc/ref/web.texi (Http Headers): Fixed typo. Signed-off-by: Ludovic Courtès --- doc/ref/web.texi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/ref/web.texi b/doc/ref/web.texi index 2311b8225..b078929e4 100644 --- a/doc/ref/web.texi +++ b/doc/ref/web.texi @@ -747,9 +747,9 @@ a resource. @deftypevr {HTTP Header} List content-type The MIME type of a resource, as a symbol, along with any parameters. @example -(parse-header 'content-length "text/plain") +(parse-header 'content-type "text/plain") @result{} (text/plain) -(parse-header 'content-length "text/plain;charset=utf-8") +(parse-header 'content-type "text/plain;charset=utf-8") @result{} (text/plain (charset . "utf-8")) @end example Note that the @code{charset} parameter is something is a misnomer, and From 2c95a2102711c990d81bd8908506cd35b9b71022 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 22 May 2016 20:39:03 +0200 Subject: [PATCH 341/865] More thorough ice-9 sports testing * module/ice-9/sports.scm: Export read-line, %read-line, and read-delimited. Add these latest three to install-sports!, and fix install-sports! if the current module isn't (ice-9 sports). * test-suite/tests/sports.test: Use install-sports! instead of lexical bindings, to allow us to nicely frob bindings in rdelim. Include rdelim tests. --- module/ice-9/sports.scm | 29 +++++++++++++++++------------ test-suite/tests/sports.test | 7 ++++++- 2 files changed, 23 insertions(+), 13 deletions(-) diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm index 2ee97340b..ce782d856 100644 --- a/module/ice-9/sports.scm +++ b/module/ice-9/sports.scm @@ -56,6 +56,9 @@ read-char) #:export (lookahead-u8 get-u8 + %read-line + read-line + read-delimited current-read-waiter current-write-waiter install-sports! @@ -524,21 +527,23 @@ (define saved-port-bindings #f) (define port-bindings '(((guile) read-char peek-char) - ((ice-9 binary-ports) get-u8 lookahead-u8))) + ((ice-9 binary-ports) get-u8 lookahead-u8) + ((ice-9 rdelim) %read-line read-line read-delimited))) (define (install-sports!) (unless saved-port-bindings (set! saved-port-bindings (make-hash-table)) - (for-each - (match-lambda - ((mod . syms) - (let ((mod (resolve-module mod))) - (for-each (lambda (sym) - (hashq-set! saved-port-bindings sym - (module-ref mod sym)) - (module-set! mod sym - (module-ref (current-module) sym))) - syms)))) - port-bindings))) + (let ((sports (resolve-module '(ice-9 sports)))) + (for-each + (match-lambda + ((mod . syms) + (let ((mod (resolve-module mod))) + (for-each (lambda (sym) + (hashq-set! saved-port-bindings sym + (module-ref mod sym)) + (module-set! mod sym + (module-ref sports sym))) + syms)))) + port-bindings)))) (define (uninstall-sports!) (when saved-port-bindings diff --git a/test-suite/tests/sports.test b/test-suite/tests/sports.test index 6eb422ef5..6707f562a 100644 --- a/test-suite/tests/sports.test +++ b/test-suite/tests/sports.test @@ -17,7 +17,7 @@ ;;;; . (define-module (test-suite test-ports) - #:use-module (ice-9 sports)) + #:use-module ((ice-9 sports) #:select (install-sports! uninstall-sports!))) ;; Include tests from ports.test. @@ -49,4 +49,9 @@ #`((include-one #,exp) . #,(lp)))))))) #:guess-encoding #t))))) +(install-sports!) + (include-tests "tests/ports.test") +(include-tests "tests/rdelim.test") + +(uninstall-sports!) From 4e288ec2ff9c5387951dcb7f78f3193261228878 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 22 May 2016 22:33:46 +0200 Subject: [PATCH 342/865] Fix range checking in new Scheme-to-C port code * libguile/ports.c (trampoline_to_c_read, trampoline_to_c_write): Fix bugs checking ranges of start and count parameters. --- libguile/ports.c | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 445ccc076..ff1db9d35 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -172,10 +172,11 @@ trampoline_to_c_read (SCM port, SCM dst, SCM start, SCM count) size_t c_start, c_count, ret; SCM_VALIDATE_OPPORT (1, port); + SCM_VALIDATE_BYTEVECTOR (2, dst); c_start = scm_to_size_t (start); c_count = scm_to_size_t (count); - SCM_ASSERT_RANGE (2, start, c_start <= c_count); - SCM_ASSERT_RANGE (3, count, c_start+c_count <= scm_c_bytevector_length (dst)); + SCM_ASSERT_RANGE (3, start, c_start <= SCM_BYTEVECTOR_LENGTH (dst)); + SCM_ASSERT_RANGE (4, count, c_count <= SCM_BYTEVECTOR_LENGTH (dst) - c_start); ret = SCM_PORT_TYPE (port)->c_read (port, dst, c_start, c_count); @@ -198,10 +199,11 @@ trampoline_to_c_write (SCM port, SCM src, SCM start, SCM count) size_t c_start, c_count, ret; SCM_VALIDATE_OPPORT (1, port); + SCM_VALIDATE_BYTEVECTOR (2, src); c_start = scm_to_size_t (start); c_count = scm_to_size_t (count); - SCM_ASSERT_RANGE (2, start, c_start <= c_count); - SCM_ASSERT_RANGE (3, count, c_start+c_count <= scm_c_bytevector_length (src)); + SCM_ASSERT_RANGE (3, start, c_start <= SCM_BYTEVECTOR_LENGTH (src)); + SCM_ASSERT_RANGE (4, count, c_count <= SCM_BYTEVECTOR_LENGTH (src) - c_start); ret = SCM_PORT_TYPE (port)->c_write (port, src, c_start, c_count); From c95a19376b1f2fd26c60fb56c1c9892eef1acfc4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 22 May 2016 23:02:41 +0200 Subject: [PATCH 343/865] get-bytevector-n in Scheme. * module/ice-9/sports.scm (fill-input): Add io-mode optional arg. (get-bytevector-n): New implementation. (port-bindings): Add get-bytevector-n. * test-suite/tests/sports.test: Add r6rs-ports tests. --- module/ice-9/sports.scm | 53 ++++++++++++++++++++++++++++++++++-- test-suite/tests/sports.test | 1 + 2 files changed, 51 insertions(+), 3 deletions(-) diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm index ce782d856..807eada0b 100644 --- a/module/ice-9/sports.scm +++ b/module/ice-9/sports.scm @@ -56,6 +56,7 @@ read-char) #:export (lookahead-u8 get-u8 + get-bytevector-n %read-line read-line read-delimited @@ -148,8 +149,8 @@ (maybe-consume-bom utf32be-bom) (specialize-port-encoding! port 'UTF-32BE))))))) -(define* (fill-input port #:optional (minimum-buffering 1)) - (clear-stream-start-for-bom-read port 'text) +(define* (fill-input port #:optional (minimum-buffering 1) (io-mode 'text)) + (clear-stream-start-for-bom-read port io-mode) (let* ((buf (port-read-buffer port)) (cur (port-buffer-cur buf)) (buffered (- (port-buffer-end buf) cur))) @@ -226,6 +227,52 @@ (fast-path buf bv cur buffered))) (peek-bytes port 1 fast-path slow-path)) +(define* (get-bytevector-n port count) + (let ((ret (make-bytevector count))) + (define (port-buffer-take! pos buf cur to-copy) + (bytevector-copy! (port-buffer-bytevector buf) cur + ret pos to-copy) + (set-port-buffer-cur! buf (+ cur to-copy)) + (+ pos to-copy)) + (define (take-already-buffered) + (let* ((buf (port-read-buffer port)) + (cur (port-buffer-cur buf)) + (buffered (- (port-buffer-end buf) cur))) + (port-buffer-take! 0 buf cur (min count buffered)))) + (define (trim-and-return len) + (if (zero? len) + the-eof-object + (let ((partial (make-bytevector len))) + (bytevector-copy! ret 0 partial 0 len) + partial))) + (define (buffer-and-fill pos) + (call-with-values (lambda () (fill-input port 1 'binary)) + (lambda (buf buffered) + (if (zero? buffered) + (begin + (set-port-buffer-has-eof?! buf #f) + (trim-and-return pos)) + (let ((pos (port-buffer-take! pos buf (port-buffer-cur buf) + (min (- count pos) buffered)))) + (if (= pos count) + ret + (buffer-and-fill pos))))))) + (define (fill-directly pos) + (when (port-random-access? port) + (flush-output port)) + (port-clear-stream-start-for-bom-read port) + (let lp ((pos pos)) + (let ((read (read-bytes port ret pos (- count pos)))) + (cond + ((= read (- count pos)) ret) + ((zero? read) (trim-and-return pos)) + (else (lp (+ pos read))))))) + (let ((pos (take-already-buffered))) + (cond + ((= pos count) (if (zero? pos) the-eof-object ret)) + ((< (- count pos) (port-read-buffering port)) (buffer-and-fill pos)) + (else (fill-directly pos)))))) + (define (decoding-error subr port) ;; GNU definition; fixme? (define EILSEQ 84) @@ -527,7 +574,7 @@ (define saved-port-bindings #f) (define port-bindings '(((guile) read-char peek-char) - ((ice-9 binary-ports) get-u8 lookahead-u8) + ((ice-9 binary-ports) get-u8 lookahead-u8 get-bytevector-n) ((ice-9 rdelim) %read-line read-line read-delimited))) (define (install-sports!) (unless saved-port-bindings diff --git a/test-suite/tests/sports.test b/test-suite/tests/sports.test index 6707f562a..453e35fab 100644 --- a/test-suite/tests/sports.test +++ b/test-suite/tests/sports.test @@ -53,5 +53,6 @@ (include-tests "tests/ports.test") (include-tests "tests/rdelim.test") +(include-tests "tests/r6rs-ports.test") (uninstall-sports!) From 6bf7ec0c9c615f0b3bbb03bae15ebb10194e2bf8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 23 May 2016 16:37:23 +0200 Subject: [PATCH 344/865] Thread-safety fixes for iconv and ports * libguile/ports-internal.h (scm_t_port): Rework to store iconv descriptors inline, so that the port finalizer doesn't race with the iconv descriptor finalizer. Access is serialized through a lock. Fixes a bug whereby if the port finalizer and the descriptor finalizer run on different threads, the close-port run by the port finalizer could try to free the iconv descriptors at the same time as the descriptor finalizer. * libguile/ports.c (iconv_lock): New static variable. (scm_c_make_port_with_encoding): Initialize iconv-related fields. (scm_close_port): Lock while frobbing iconv descriptors. (prepare_iconv_descriptors): Adapt. (scm_specialize_port_encoding_x, scm_i_set_port_encoding_x): Lock while preparing iconv descriptors. (scm_port_acquire_iconv_descriptors) (scm_port_release_iconv_descriptors): New functions, which replace scm_i_port_iconv_descriptors. (scm_port_decode_char): Lock around iconv operations. (port_clear_stream_start_for_bom_write): Acquire iconv descriptors before checking precise_encoding, to make sure precise_encoding is initialized. * libguile/print.c (display_string_using_iconv): Adapt to use the new interface to get iconv descriptors from a port. --- libguile/ports-internal.h | 43 ++++---- libguile/ports.c | 201 +++++++++++++++++++------------------- libguile/print.c | 14 +-- 3 files changed, 128 insertions(+), 130 deletions(-) diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index 0bfda4f35..7aabee769 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -23,6 +23,7 @@ #define SCM_PORTS_INTERNAL #include +#include #include "libguile/_scm.h" #include "libguile/ports.h" @@ -302,24 +303,6 @@ scm_port_buffer_putback (SCM buf, const scm_t_uint8 *src, size_t count) src, count); } -/* This is a separate object so that only those ports that use iconv - cause finalizers to be registered. */ -struct scm_iconv_descriptors -{ - /* This is the same as pt->encoding, except if pt->encoding is UTF-16 - or UTF-32, in which case this is UTF-16LE or a similar - byte-order-specialed version of UTF-16 or UTF-32. We don't re-set - pt->encoding because being just plain UTF-16 or UTF-32 has an - additional meaning, being that we should consume and produce byte - order marker codepoints as appropriate. */ - SCM precise_encoding; - /* input/output iconv conversion descriptors */ - void *input_cd; - void *output_cd; -}; - -typedef struct scm_iconv_descriptors scm_t_iconv_descriptors; - struct scm_t_port { /* Source location information. */ @@ -342,15 +325,26 @@ struct scm_t_port /* True if the port is random access. Implies that the buffers must be flushed before switching between reading and writing, seeking, and so on. */ - int rw_random; + unsigned rw_random : 1; + unsigned at_stream_start_for_bom_read : 1; + unsigned at_stream_start_for_bom_write : 1; /* Character encoding support. */ SCM encoding; /* A symbol of upper-case ASCII. */ SCM conversion_strategy; /* A symbol; either substitute, error, or escape. */ - unsigned at_stream_start_for_bom_read : 1; - unsigned at_stream_start_for_bom_write : 1; - scm_t_iconv_descriptors *iconv_descriptors; + /* This is the same as pt->encoding, except if `encoding' is UTF-16 or + UTF-32, in which case this is UTF-16LE or a similar + byte-order-specialed version of UTF-16 or UTF-32. This is a + separate field from `encoding' because being just plain UTF-16 or + UTF-32 has an additional meaning, being that we should consume and + produce byte order marker codepoints as appropriate. Set to #f + before the iconv descriptors have been opened. */ + SCM precise_encoding; /* with iconv_lock */ + iconv_t input_cd; /* with iconv_lock */ + iconv_t output_cd; /* with iconv_lock */ + + /* Port properties. */ SCM alist; }; @@ -359,6 +353,9 @@ struct scm_t_port #define SCM_FILENAME(x) (SCM_PORT (x)->file_name) #define SCM_SET_FILENAME(x, n) (SCM_PORT (x)->file_name = (n)) -SCM_INTERNAL scm_t_iconv_descriptors * scm_i_port_iconv_descriptors (SCM port); +SCM_INTERNAL void scm_port_acquire_iconv_descriptors (SCM port, + iconv_t *input_cd, + iconv_t *output_cd); +SCM_INTERNAL void scm_port_release_iconv_descriptors (SCM port); #endif diff --git a/libguile/ports.c b/libguile/ports.c index ff1db9d35..f58da4be9 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -110,6 +110,11 @@ static SCM sym_substitute; static SCM sym_escape; + + +/* We have to serialize operations on any given iconv descriptor. */ +static scm_i_pthread_mutex_t iconv_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; + /* See Unicode 8.0 section 5.22, "Best Practice for U+FFFD @@ -675,12 +680,15 @@ scm_c_make_port_with_encoding (scm_t_port_type *ptob, unsigned long mode_bits, pt->encoding = encoding; pt->conversion_strategy = conversion_strategy; pt->file_name = SCM_BOOL_F; - pt->iconv_descriptors = NULL; pt->position = scm_cons (SCM_INUM0, SCM_INUM0); pt->at_stream_start_for_bom_read = 1; pt->at_stream_start_for_bom_write = 1; + pt->precise_encoding = SCM_BOOL_F; + pt->input_cd = (iconv_t) -1; + pt->output_cd = (iconv_t) -1; + pt->alist = SCM_EOL; if (SCM_PORT_TYPE (ret)->flags & SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC) @@ -770,12 +778,6 @@ SCM_DEFINE (scm_eof_object_p, "eof-object?", 1, 0, 0, /* Closing ports. */ -static void close_iconv_descriptors (scm_t_iconv_descriptors *id); - -/* scm_close_port - * Call the close operation on a port object. - * see also scm_close. - */ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, (SCM port), "Close the specified port object. Return @code{#t} if it\n" @@ -809,13 +811,17 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, should be resilient to non-local exits. */ SCM_PORT_TYPE (port)->close (port); - if (pt->iconv_descriptors) + scm_i_pthread_mutex_lock (&iconv_lock); + if (scm_is_true (pt->precise_encoding)) { - /* If we don't get here, the iconv_descriptors finalizer will - clean up. */ - close_iconv_descriptors (pt->iconv_descriptors); - pt->iconv_descriptors = NULL; + if (pt->input_cd != (iconv_t) -1) + iconv_close (pt->input_cd); + if (pt->output_cd != (iconv_t) -1) + iconv_close (pt->output_cd); + pt->precise_encoding = SCM_BOOL_F; + pt->input_cd = pt->output_cd = (iconv_t) -1; } + scm_i_pthread_mutex_unlock (&iconv_lock); return SCM_BOOL_T; } @@ -979,51 +985,53 @@ static const unsigned char scm_utf16le_bom[2] = {0xFF, 0xFE}; static const unsigned char scm_utf32be_bom[4] = {0x00, 0x00, 0xFE, 0xFF}; static const unsigned char scm_utf32le_bom[4] = {0xFF, 0xFE, 0x00, 0x00}; +/* Called with the iconv lock. Will release the lock before throwing + any error. */ static void -finalize_iconv_descriptors (void *ptr, void *data) +prepare_iconv_descriptors (SCM port, SCM precise_encoding) { - close_iconv_descriptors (ptr); -} - -static scm_t_iconv_descriptors * -open_iconv_descriptors (SCM precise_encoding, int reading, int writing) -{ - const char *encoding; - scm_t_iconv_descriptors *id; + scm_t_port *pt = SCM_PORT (port); iconv_t input_cd, output_cd; + const char *encoding; size_t i; - input_cd = (iconv_t) -1; - output_cd = (iconv_t) -1; + /* If the specified encoding is UTF-16 or UTF-32, then default to + big-endian byte order. This fallback isn't necessary if you read + on the port before writing to it, as the read will sniff the BOM if + any and specialize the encoding; see the manual. */ + if (scm_is_eq (precise_encoding, sym_UTF_16)) + precise_encoding = sym_UTF_16BE; + else if (scm_is_eq (precise_encoding, sym_UTF_32)) + precise_encoding = sym_UTF_32BE; + + if (scm_is_eq (pt->precise_encoding, precise_encoding)) + return; + + input_cd = output_cd = (iconv_t) -1; + + if (!scm_is_symbol (precise_encoding)) + goto invalid_encoding; encoding = scm_i_symbol_chars (precise_encoding); for (i = 0; encoding[i]; i++) if (encoding[i] > 127) goto invalid_encoding; - if (reading) + /* Open a iconv conversion descriptors between ENCODING and UTF-8. We + choose UTF-8, not UTF-32, because iconv implementations can + typically convert from anything to UTF-8, but not to UTF-32 (see + http://lists.gnu.org/archive/html/bug-libunistring/2010-09/msg00007.html, + for more details). */ + + if (SCM_INPUT_PORT_P (port)) { - /* Open an input iconv conversion descriptor, from ENCODING - to UTF-8. We choose UTF-8, not UTF-32, because iconv - implementations can typically convert from anything to - UTF-8, but not to UTF-32 (see - ). */ - - /* Assume opening an iconv descriptor causes about 16 KB of - allocation. */ - scm_gc_register_allocation (16 * 1024); - input_cd = iconv_open ("UTF-8", encoding); if (input_cd == (iconv_t) -1) goto invalid_encoding; } - if (writing) + if (SCM_OUTPUT_PORT_P (port)) { - /* Assume opening an iconv descriptor causes about 16 KB of - allocation. */ - scm_gc_register_allocation (16 * 1024); - output_cd = iconv_open (encoding, "UTF-8"); if (output_cd == (iconv_t) -1) { @@ -1033,55 +1041,27 @@ open_iconv_descriptors (SCM precise_encoding, int reading, int writing) } } - id = scm_gc_malloc_pointerless (sizeof (*id), "iconv descriptors"); - id->precise_encoding = precise_encoding; - id->input_cd = input_cd; - id->output_cd = output_cd; + if (pt->input_cd != (iconv_t) -1) + iconv_close (pt->input_cd); + if (pt->output_cd != (iconv_t) -1) + iconv_close (pt->output_cd); - /* Register a finalizer to close the descriptors. */ - scm_i_set_finalizer (id, finalize_iconv_descriptors, NULL); + pt->precise_encoding = precise_encoding; + pt->input_cd = input_cd; + pt->output_cd = output_cd; - return id; + /* Make sure this port has a finalizer. */ + scm_i_set_finalizer (SCM2PTR (port), finalize_port, NULL); + + return; invalid_encoding: + scm_i_pthread_mutex_unlock (&iconv_lock); scm_misc_error ("open_iconv_descriptors", "invalid or unknown character encoding ~s", scm_list_1 (precise_encoding)); } -static void -close_iconv_descriptors (scm_t_iconv_descriptors *id) -{ - if (id->input_cd != (iconv_t) -1) - iconv_close (id->input_cd); - if (id->output_cd != (iconv_t) -1) - iconv_close (id->output_cd); - id->input_cd = (void *) -1; - id->output_cd = (void *) -1; -} - -static void -prepare_iconv_descriptors (SCM port, SCM encoding) -{ - scm_t_port *pt = SCM_PORT (port); - scm_t_iconv_descriptors *desc = pt->iconv_descriptors; - - /* If the specified encoding is UTF-16 or UTF-32, then default to - big-endian byte order. This fallback isn't necessary if you read - on the port before writing to it, as the read will sniff the BOM if - any and specialize the encoding; see the manual. */ - if (scm_is_eq (encoding, sym_UTF_16)) - encoding = sym_UTF_16BE; - else if (scm_is_eq (encoding, sym_UTF_32)) - encoding = sym_UTF_32BE; - - if (desc && scm_is_eq (desc->precise_encoding, encoding)) - return; - - pt->iconv_descriptors = open_iconv_descriptors - (encoding, SCM_INPUT_PORT_P (port), SCM_OUTPUT_PORT_P (port)); -} - SCM_INTERNAL SCM scm_specialize_port_encoding_x (SCM port, SCM encoding); SCM_DEFINE (scm_specialize_port_encoding_x, "specialize-port-encoding!", 2, 0, 0, @@ -1107,33 +1087,41 @@ SCM_DEFINE (scm_specialize_port_encoding_x, else SCM_OUT_OF_RANGE (2, encoding); + scm_i_pthread_mutex_lock (&iconv_lock); prepare_iconv_descriptors (port, encoding); + scm_i_pthread_mutex_unlock (&iconv_lock); return SCM_UNSPECIFIED; } #undef FUNC_NAME -scm_t_iconv_descriptors * -scm_i_port_iconv_descriptors (SCM port) +/* Acquire the iconv lock and fill in *INPUT_CD and/or *OUTPUT_CD. */ +void +scm_port_acquire_iconv_descriptors (SCM port, iconv_t *input_cd, + iconv_t *output_cd) { scm_t_port *pt = SCM_PORT (port); - if (!pt->iconv_descriptors) + scm_i_pthread_mutex_lock (&iconv_lock); + if (scm_is_false (pt->precise_encoding)) prepare_iconv_descriptors (port, pt->encoding); + if (input_cd) + *input_cd = pt->input_cd; + if (output_cd) + *output_cd = pt->output_cd; +} - return pt->iconv_descriptors; +void +scm_port_release_iconv_descriptors (SCM port) +{ + scm_i_pthread_mutex_unlock (&iconv_lock); } /* The name of the encoding is itself encoded in ASCII. */ void scm_i_set_port_encoding_x (SCM port, const char *encoding) { - scm_t_port *pt; - scm_t_iconv_descriptors *prev; - - /* Set the character encoding for this port. */ - pt = SCM_PORT (port); - prev = pt->iconv_descriptors; + scm_t_port *pt = SCM_PORT (port); /* In order to handle cases where the encoding changes mid-stream (e.g. within an HTTP stream, or within a file that is composed of @@ -1144,9 +1132,14 @@ scm_i_set_port_encoding_x (SCM port, const char *encoding) pt->at_stream_start_for_bom_write = 1; pt->encoding = canonicalize_encoding (encoding); - pt->iconv_descriptors = NULL; - if (prev) - close_iconv_descriptors (prev); + scm_i_pthread_mutex_lock (&iconv_lock); + if (pt->input_cd != (iconv_t) -1) + iconv_close (pt->input_cd); + if (pt->output_cd != (iconv_t) -1) + iconv_close (pt->output_cd); + pt->precise_encoding = SCM_BOOL_F; + pt->input_cd = pt->output_cd = (iconv_t) -1; + scm_i_pthread_mutex_unlock (&iconv_lock); } SCM_DEFINE (scm_sys_port_encoding, "%port-encoding", 1, 0, 0, @@ -1783,7 +1776,7 @@ SCM_DEFINE (scm_port_decode_char, "port-decode-char", 4, 0, 0, { char *input, *output; scm_t_uint8 utf8_buf[SCM_MBCHAR_BUF_SIZE]; - scm_t_iconv_descriptors *id; + iconv_t input_cd; size_t c_start, c_count; size_t input_left, output_left, done; @@ -1794,14 +1787,15 @@ SCM_DEFINE (scm_port_decode_char, "port-decode-char", 4, 0, 0, SCM_ASSERT_RANGE (3, start, c_start <= SCM_BYTEVECTOR_LENGTH (bv)); SCM_ASSERT_RANGE (4, count, c_count <= SCM_BYTEVECTOR_LENGTH (bv) - c_start); - id = scm_i_port_iconv_descriptors (port); input = (char *) SCM_BYTEVECTOR_CONTENTS (bv) + c_start; input_left = c_count; output = (char *) utf8_buf; output_left = sizeof (utf8_buf); /* FIXME: locking! */ - done = iconv (id->input_cd, &input, &input_left, &output, &output_left); + scm_port_acquire_iconv_descriptors (port, &input_cd, NULL); + done = iconv (input_cd, &input, &input_left, &output, &output_left); + scm_port_release_iconv_descriptors (port); if (done == (size_t) -1) { @@ -1856,7 +1850,8 @@ peek_iconv_codepoint (SCM port, size_t *len) /* Make sure iconv descriptors have been opened even if there were no bytes, to be sure that a decoding error is signalled if the encoding itself was invalid. */ - scm_i_port_iconv_descriptors (port); + scm_port_acquire_iconv_descriptors (port, NULL, NULL); + scm_port_release_iconv_descriptors (port); return EOF; } @@ -2469,16 +2464,22 @@ port_clear_stream_start_for_bom_write (SCM port, enum bom_io_mode io_mode) /* Write a BOM if appropriate. */ if (scm_is_eq (pt->encoding, sym_UTF_16)) { - scm_t_iconv_descriptors *id = scm_i_port_iconv_descriptors (port); - if (scm_is_eq (id->precise_encoding, sym_UTF_16LE)) + SCM precise_encoding; + scm_port_acquire_iconv_descriptors (port, NULL, NULL); + precise_encoding = pt->precise_encoding; + scm_port_release_iconv_descriptors (port); + if (scm_is_eq (precise_encoding, sym_UTF_16LE)) scm_c_write (port, scm_utf16le_bom, sizeof (scm_utf16le_bom)); else scm_c_write (port, scm_utf16be_bom, sizeof (scm_utf16be_bom)); } else if (scm_is_eq (pt->encoding, sym_UTF_32)) { - scm_t_iconv_descriptors *id = scm_i_port_iconv_descriptors (port); - if (scm_is_eq (id->precise_encoding, sym_UTF_32LE)) + SCM precise_encoding; + scm_port_acquire_iconv_descriptors (port, NULL, NULL); + precise_encoding = pt->precise_encoding; + scm_port_release_iconv_descriptors (port); + if (scm_is_eq (precise_encoding, sym_UTF_32LE)) scm_c_write (port, scm_utf32le_bom, sizeof (scm_utf32le_bom)); else scm_c_write (port, scm_utf32be_bom, sizeof (scm_utf32be_bom)); diff --git a/libguile/print.c b/libguile/print.c index 562057722..84c9455b3 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -24,7 +24,6 @@ #endif #include -#include #include #include @@ -1026,9 +1025,7 @@ display_string_using_iconv (const void *str, int narrow_p, size_t len, scm_t_string_failed_conversion_handler strategy) { size_t printed; - scm_t_iconv_descriptors *id; - - id = scm_i_port_iconv_descriptors (port); + iconv_t output_cd; printed = 0; @@ -1057,8 +1054,9 @@ display_string_using_iconv (const void *str, int narrow_p, size_t len, output = encoded_output; output_left = sizeof (encoded_output); - done = iconv (id->output_cd, &input, &input_left, - &output, &output_left); + scm_port_acquire_iconv_descriptors (port, NULL, &output_cd); + done = iconv (output_cd, &input, &input_left, &output, &output_left); + scm_port_release_iconv_descriptors (port); output_len = sizeof (encoded_output) - output_left; @@ -1067,7 +1065,9 @@ display_string_using_iconv (const void *str, int narrow_p, size_t len, int errno_save = errno; /* Reset the `iconv' state. */ - iconv (id->output_cd, NULL, NULL, NULL, NULL); + scm_port_acquire_iconv_descriptors (port, NULL, &output_cd); + iconv (output_cd, NULL, NULL, NULL, NULL); + scm_port_release_iconv_descriptors (port); /* Print the OUTPUT_LEN bytes successfully converted. */ scm_lfwrite (encoded_output, output_len, port); From 690b856d59e392b0f493abf21ec08e90bb47d334 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 24 May 2016 07:06:45 +0200 Subject: [PATCH 345/865] Add force-output to sports * module/ice-9/sports.scm (force-output): New implementation. (port-bindings): Add force-output. --- module/ice-9/sports.scm | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm index 807eada0b..b506703d6 100644 --- a/module/ice-9/sports.scm +++ b/module/ice-9/sports.scm @@ -53,7 +53,8 @@ #:use-module (ice-9 ports internal) #:use-module (ice-9 match) #:replace (peek-char - read-char) + read-char + force-output) #:export (lookahead-u8 get-u8 get-bytevector-n @@ -86,6 +87,11 @@ (set-port-buffer-end! buf 0) (write-bytes port (port-buffer-bytevector buf) cur (- end cur))))) +(define* (force-output #:optional (port (current-output-port))) + (unless (and (output-port? port) (not (port-closed? port))) + (error "not an open output port" port)) + (flush-output port)) + (define (default-read-waiter port) (port-poll port "r")) (define (default-write-waiter port) (port-poll port "w")) @@ -573,7 +579,7 @@ (define saved-port-bindings #f) (define port-bindings - '(((guile) read-char peek-char) + '(((guile) read-char peek-char force-output) ((ice-9 binary-ports) get-u8 lookahead-u8 get-bytevector-n) ((ice-9 rdelim) %read-line read-line read-delimited))) (define (install-sports!) From 25381bdbc05a54d59cff6af0f85b64c4032033f2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 24 May 2016 07:14:26 +0200 Subject: [PATCH 346/865] close-port implementation in sports * module/ice-9/sports.scm (close-port): New function. (port-bindings): Add close-port. --- module/ice-9/sports.scm | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm index b506703d6..3f6107905 100644 --- a/module/ice-9/sports.scm +++ b/module/ice-9/sports.scm @@ -54,7 +54,8 @@ #:use-module (ice-9 match) #:replace (peek-char read-char - force-output) + force-output + close-port) #:export (lookahead-u8 get-u8 get-bytevector-n @@ -92,6 +93,15 @@ (error "not an open output port" port)) (flush-output port)) +(define close-port + (let ((%close-port (@ (guile) close-port))) + (lambda (port) + (cond + ((port-closed? port) #f) + (else + (when (output-port? port) (flush-output port)) + (%close-port port)))))) + (define (default-read-waiter port) (port-poll port "r")) (define (default-write-waiter port) (port-poll port "w")) @@ -579,7 +589,7 @@ (define saved-port-bindings #f) (define port-bindings - '(((guile) read-char peek-char force-output) + '(((guile) read-char peek-char force-output close-port) ((ice-9 binary-ports) get-u8 lookahead-u8 get-bytevector-n) ((ice-9 rdelim) %read-line read-line read-delimited))) (define (install-sports!) From 9686b04a265974f605848af64cf1348b6e452ad2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 24 May 2016 07:21:30 +0200 Subject: [PATCH 347/865] Wire up non-blocking support in sport writes * module/ice-9/sports.scm (write-bytes): Support non-blocking writes. (force-output, flush-output): Rearrange placement. --- module/ice-9/sports.scm | 75 ++++++++++++++++++++++------------------- 1 file changed, 40 insertions(+), 35 deletions(-) diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm index 3f6107905..cfa824c83 100644 --- a/module/ice-9/sports.scm +++ b/module/ice-9/sports.scm @@ -67,41 +67,6 @@ install-sports! uninstall-sports!)) -(define (write-bytes port src start count) - (let ((written ((port-write port) port src start count))) - (unless (<= 0 written count) - (error "bad return from port write function" written)) - (when (< written count) - (write-bytes port src (+ start written) (- count written))))) - -(define (flush-output port) - (let* ((buf (port-write-buffer port)) - (cur (port-buffer-cur buf)) - (end (port-buffer-end buf))) - (when (< cur end) - ;; Update cursors before attempting to write, assuming that I/O - ;; errors are sticky. That way if the write throws an error, - ;; causing the computation to abort, and possibly causing the port - ;; to be collected by GC when it's open, any subsequent close-port - ;; or force-output won't signal *another* error. - (set-port-buffer-cur! buf 0) - (set-port-buffer-end! buf 0) - (write-bytes port (port-buffer-bytevector buf) cur (- end cur))))) - -(define* (force-output #:optional (port (current-output-port))) - (unless (and (output-port? port) (not (port-closed? port))) - (error "not an open output port" port)) - (flush-output port)) - -(define close-port - (let ((%close-port (@ (guile) close-port))) - (lambda (port) - (cond - ((port-closed? port) #f) - (else - (when (output-port? port) (flush-output port)) - (%close-port port)))))) - (define (default-read-waiter port) (port-poll port "r")) (define (default-write-waiter port) (port-poll port "w")) @@ -122,6 +87,32 @@ (wait-for-readable port) (read-bytes port dst start count)))) +(define (write-bytes port src start count) + (cond + (((port-write port) port src start count) + => (lambda (written) + (unless (<= 0 written count) + (error "bad return from port write function" written)) + (when (< written count) + (write-bytes port src (+ start written) (- count written))))) + (else + (wait-for-writable port) + (write-bytes port src start count)))) + +(define (flush-output port) + (let* ((buf (port-write-buffer port)) + (cur (port-buffer-cur buf)) + (end (port-buffer-end buf))) + (when (< cur end) + ;; Update cursors before attempting to write, assuming that I/O + ;; errors are sticky. That way if the write throws an error, + ;; causing the computation to abort, and possibly causing the port + ;; to be collected by GC when it's open, any subsequent close-port + ;; or force-output won't signal *another* error. + (set-port-buffer-cur! buf 0) + (set-port-buffer-end! buf 0) + (write-bytes port (port-buffer-bytevector buf) cur (- end cur))))) + (define utf8-bom #vu8(#xEF #xBB #xBF)) (define utf16be-bom #vu8(#xFE #xFF)) (define utf16le-bom #vu8(#xFF #xFE)) @@ -203,6 +194,20 @@ (lp buffered) (values buf buffered))))))))))))))) +(define* (force-output #:optional (port (current-output-port))) + (unless (and (output-port? port) (not (port-closed? port))) + (error "not an open output port" port)) + (flush-output port)) + +(define close-port + (let ((%close-port (@ (guile) close-port))) + (lambda (port) + (cond + ((port-closed? port) #f) + (else + (when (output-port? port) (flush-output port)) + (%close-port port)))))) + (define-inlinable (peek-bytes port count kfast kslow) (let* ((buf (port-read-buffer port)) (cur (port-buffer-cur buf)) From ba917410634e193e83ae408c5e0fffc04362544b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 24 May 2016 08:05:01 +0200 Subject: [PATCH 348/865] `put-bytevector' in Scheme * module/ice-9/sports.scm (flush-input): New helper. (put-bytevector): New function. (port-bindings): Add put-bytevector. --- module/ice-9/sports.scm | 56 ++++++++++++++++++++++++++++++++++++++--- 1 file changed, 52 insertions(+), 4 deletions(-) diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm index cfa824c83..52f887e24 100644 --- a/module/ice-9/sports.scm +++ b/module/ice-9/sports.scm @@ -56,14 +56,18 @@ read-char force-output close-port) - #:export (lookahead-u8 + #:export (current-read-waiter + current-write-waiter + + lookahead-u8 get-u8 get-bytevector-n + put-bytevector + %read-line read-line read-delimited - current-read-waiter - current-write-waiter + install-sports! uninstall-sports!)) @@ -99,6 +103,15 @@ (wait-for-writable port) (write-bytes port src start count)))) +(define (flush-input port) + (let* ((buf (port-read-buffer port)) + (cur (port-buffer-cur buf)) + (end (port-buffer-end buf))) + (when (< cur end) + (set-port-buffer-cur! buf 0) + (set-port-buffer-end! buf 0) + (seek port (- cur end) SEEK_CUR)))) + (define (flush-output port) (let* ((buf (port-write-buffer port)) (cur (port-buffer-cur buf)) @@ -294,6 +307,41 @@ ((< (- count pos) (port-read-buffering port)) (buffer-and-fill pos)) (else (fill-directly pos)))))) +(define* (put-bytevector port src #:optional (start 0) + (count (- (bytevector-length src) start))) + (unless (<= 0 start (+ start count) (bytevector-length src)) + (error "invalid start/count" start count)) + (when (port-random-access? port) + (flush-input port)) + (let* ((buf (port-write-buffer port)) + (bv (port-buffer-bytevector buf)) + (size (bytevector-length bv)) + (cur (port-buffer-cur buf)) + (end (port-buffer-end buf)) + (buffered (- end cur))) + (cond + ((<= size count) + ;; The write won't fit in the buffer at all; write directly. + ;; Write directly. Flush write buffer first if needed. + (when (< cur end) (flush-output port)) + (write-bytes port src start count)) + ((< (- size buffered) count) + ;; The write won't fit into the buffer along with what's already + ;; buffered. Flush and fill. + (flush-output port) + (set-port-buffer-end! buf count) + (bytevector-copy! src start bv 0 count)) + (else + ;; The write will fit in the buffer, but we need to shuffle the + ;; already-buffered bytes (if any) down. + (set-port-buffer-cur! buf 0) + (set-port-buffer-end! buf (+ buffered count)) + (bytevector-copy! bv cur bv 0 buffered) + (bytevector-copy! src start bv buffered count) + ;; If the buffer completely fills, we flush. + (when (= (+ buffered count) size) + (flush-output port)))))) + (define (decoding-error subr port) ;; GNU definition; fixme? (define EILSEQ 84) @@ -595,7 +643,7 @@ (define saved-port-bindings #f) (define port-bindings '(((guile) read-char peek-char force-output close-port) - ((ice-9 binary-ports) get-u8 lookahead-u8 get-bytevector-n) + ((ice-9 binary-ports) get-u8 lookahead-u8 get-bytevector-n put-bytevector) ((ice-9 rdelim) %read-line read-line read-delimited))) (define (install-sports!) (unless saved-port-bindings From 7c8b80e076dd7d7219c985bcd8097dd1f115b92a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 24 May 2016 08:24:38 +0200 Subject: [PATCH 349/865] Add put-u8 implementation in Scheme * module/ice-9/sports.scm (put-u8): Add implementation. (port-bindings): Add put-u8. --- module/ice-9/sports.scm | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm index 52f887e24..37ea09221 100644 --- a/module/ice-9/sports.scm +++ b/module/ice-9/sports.scm @@ -62,6 +62,7 @@ lookahead-u8 get-u8 get-bytevector-n + put-u8 put-bytevector %read-line @@ -307,6 +308,18 @@ ((< (- count pos) (port-read-buffering port)) (buffer-and-fill pos)) (else (fill-directly pos)))))) +(define (put-u8 port byte) + (when (port-random-access? port) + (flush-input port)) + (let* ((buf (port-write-buffer port)) + (bv (port-buffer-bytevector buf)) + (end (port-buffer-end buf))) + (unless (<= 0 end (bytevector-length bv)) + (error "not an output port" port)) + (bytevector-u8-set! bv end byte) + (set-port-buffer-end! buf (1+ end)) + (when (= (1+ end) (bytevector-length bv)) (flush-output port)))) + (define* (put-bytevector port src #:optional (start 0) (count (- (bytevector-length src) start))) (unless (<= 0 start (+ start count) (bytevector-length src)) @@ -643,7 +656,9 @@ (define saved-port-bindings #f) (define port-bindings '(((guile) read-char peek-char force-output close-port) - ((ice-9 binary-ports) get-u8 lookahead-u8 get-bytevector-n put-bytevector) + ((ice-9 binary-ports) + get-u8 lookahead-u8 get-bytevector-n + put-u8 put-bytevector) ((ice-9 rdelim) %read-line read-line read-delimited))) (define (install-sports!) (unless saved-port-bindings From 48dbadd8e60ca6335593e4a93179da3e8de8b34e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 24 May 2016 08:37:57 +0200 Subject: [PATCH 350/865] Speed golf on Scheme put-u8, put-bytevector * module/ice-9/sports.scm (put-u8, put-bytevector): Speed hack. --- module/ice-9/sports.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm index 37ea09221..86d9a5b06 100644 --- a/module/ice-9/sports.scm +++ b/module/ice-9/sports.scm @@ -309,13 +309,13 @@ (else (fill-directly pos)))))) (define (put-u8 port byte) - (when (port-random-access? port) - (flush-input port)) (let* ((buf (port-write-buffer port)) (bv (port-buffer-bytevector buf)) (end (port-buffer-end buf))) (unless (<= 0 end (bytevector-length bv)) (error "not an output port" port)) + (when (and (eq? (port-buffer-cur buf) end) (port-random-access? port)) + (flush-input port)) (bytevector-u8-set! bv end byte) (set-port-buffer-end! buf (1+ end)) (when (= (1+ end) (bytevector-length bv)) (flush-output port)))) @@ -324,14 +324,14 @@ (count (- (bytevector-length src) start))) (unless (<= 0 start (+ start count) (bytevector-length src)) (error "invalid start/count" start count)) - (when (port-random-access? port) - (flush-input port)) (let* ((buf (port-write-buffer port)) (bv (port-buffer-bytevector buf)) (size (bytevector-length bv)) (cur (port-buffer-cur buf)) (end (port-buffer-end buf)) (buffered (- end cur))) + (when (and (eq? cur end) (port-random-access? port)) + (flush-input port)) (cond ((<= size count) ;; The write won't fit in the buffer at all; write directly. From 47918f38d9da5fe8e7e3dd0e7cf133b14c5cf04f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 24 May 2016 22:42:51 +0200 Subject: [PATCH 351/865] Speed up scm_c_write / scm_lfwrite * libguile/ports-internal.h (scm_t_port): Add write_buf_aux field. * libguile/ports.h (scm_port_auxiliary_write_buffer): New internal decl. * libguile/ports.c (AUXILIARY_WRITE_BUFFER_SIZE): New constant. (initialize_port_buffers): Init aux write buf. (scm_port_auxiliary_write_buffer): Lazily allocate an aux write buffer. (scm_c_write): Arrange to write through an aux buffer if the port is unbuffered. --- libguile/ports-internal.h | 1 + libguile/ports.c | 50 ++++++++++++++++++++++++++++++++++++--- libguile/ports.h | 1 + 3 files changed, 49 insertions(+), 3 deletions(-) diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index 7aabee769..d01441562 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -312,6 +312,7 @@ struct scm_t_port /* Port buffers. */ SCM read_buf; SCM write_buf; + SCM write_buf_aux; /* All ports have read and write buffers; an unbuffered port simply has a one-byte buffer. However unreading bytes can expand the read diff --git a/libguile/ports.c b/libguile/ports.c index f58da4be9..3dd729db3 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -56,7 +56,7 @@ #include "libguile/strings.h" #include "libguile/mallocs.h" #include "libguile/validate.h" -//#include "libguile/ports.h" +#include "libguile/ports.h" #include "libguile/ports-internal.h" #include "libguile/vectors.h" #include "libguile/weak-set.h" @@ -109,6 +109,9 @@ static SCM sym_error; static SCM sym_substitute; static SCM sym_escape; +/* See scm_port_auxiliary_write_buffer and scm_c_write. */ +static const size_t AUXILIARY_WRITE_BUFFER_SIZE = 256; + @@ -660,6 +663,7 @@ initialize_port_buffers (SCM port) pt->read_buffering = read_buf_size; pt->read_buf = make_port_buffer (port, read_buf_size); pt->write_buf = make_port_buffer (port, write_buf_size); + pt->write_buf_aux = SCM_BOOL_F; } SCM @@ -2647,6 +2651,23 @@ SCM_DEFINE (scm_port_write_buffer, "port-write-buffer", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_port_auxiliary_write_buffer, "port-auxiliary-write-buffer", + 1, 0, 0, (SCM port), + "Return the auxiliary write buffer for a port.") +#define FUNC_NAME s_scm_port_auxiliary_write_buffer +{ + scm_t_port *pt; + + SCM_VALIDATE_OPPORT (1, port); + + pt = SCM_PORT (port); + if (scm_is_false (pt->write_buf_aux)) + pt->write_buf_aux = make_port_buffer (port, AUXILIARY_WRITE_BUFFER_SIZE); + + return pt->write_buf_aux; +} +#undef FUNC_NAME + @@ -2774,22 +2795,45 @@ scm_c_write (SCM port, const void *ptr, size_t size) scm_t_port *pt; SCM write_buf; size_t written = 0; + int using_aux_buffer = 0; const scm_t_uint8 *src = ptr; SCM_VALIDATE_OPOUTPORT (1, port); pt = SCM_PORT (port); - write_buf = pt->write_buf; if (pt->rw_random) scm_end_input (port); + /* Imagine we are writing 40 bytes on an unbuffered port. If we were + writing from a bytevector we could pass that write directly to the + port. But since we aren't, we need to go through a bytevector, and + if we went through the port buffer we'd have to make 40 individual + calls to the write function. That would be terrible. Really we + need an intermediate bytevector. But, we shouldn't use a trick + analogous to what we do with expand-port-read-buffer!, because the + way we use the cur and end cursors doesn't seem to facilitate that. + So instead we buffer through an auxiliary write buffer if needed. + To avoid re-allocating this buffer all the time, we store it on the + port. It should never be left with buffered data. + + Use of an auxiliary write buffer is triggered if the buffer is + smaller than the size we would make for an auxiliary write buffer, + and the write is bigger than the buffer. */ + write_buf = pt->write_buf; + if (scm_port_buffer_size (write_buf) < size && + scm_port_buffer_size (write_buf) < AUXILIARY_WRITE_BUFFER_SIZE) + { + using_aux_buffer = 1; + write_buf = scm_port_auxiliary_write_buffer (port); + } + while (written < size) { size_t did_put = scm_port_buffer_put (write_buf, src, size - written); written += did_put; src += did_put; - if (scm_port_buffer_can_put (write_buf) == 0) + if (using_aux_buffer || scm_port_buffer_can_put (write_buf) == 0) scm_i_write (port, write_buf); } } diff --git a/libguile/ports.h b/libguile/ports.h index 2ebcf0632..13661e008 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -208,6 +208,7 @@ SCM_INTERNAL SCM scm_port_read (SCM port); SCM_INTERNAL SCM scm_port_write (SCM port); SCM_INTERNAL SCM scm_port_read_buffer (SCM port); SCM_INTERNAL SCM scm_port_write_buffer (SCM port); +SCM_INTERNAL SCM scm_port_auxiliary_write_buffer (SCM port); /* Output. */ SCM_API void scm_putc (char c, SCM port); From 2f836e2384623dabcadd18799c13965ddf3b6004 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 25 May 2016 21:46:48 +0200 Subject: [PATCH 352/865] port_clear_stream_start_for_bom_write refactor * libguile/ports.c (port_clear_stream_start_for_bom_write): Rework to be friendly to Scheme write implementations. --- libguile/ports.c | 61 +++++++++++++++++++++++++++++++++++++----------- 1 file changed, 48 insertions(+), 13 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 3dd729db3..5660984b5 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -2452,42 +2452,77 @@ SCM_DEFINE (scm_port_clear_stream_start_for_bom_read, } #undef FUNC_NAME -static void -port_clear_stream_start_for_bom_write (SCM port, enum bom_io_mode io_mode) +SCM_INTERNAL SCM scm_port_clear_stream_start_for_bom_write (SCM port); +SCM_DEFINE (scm_port_clear_stream_start_for_bom_write, + "port-clear-stream-start-for-bom-write", 1, 0, 0, + (SCM port), + "") +#define FUNC_NAME s_scm_port_clear_stream_start_for_bom_write { - scm_t_port *pt = SCM_PORT (port); + scm_t_port *pt; + SCM_VALIDATE_PORT (1, port); + + pt = SCM_PORT (port); if (!pt->at_stream_start_for_bom_write) - return; + return SCM_BOOL_F; + + pt->at_stream_start_for_bom_write = 0; + if (pt->rw_random) + pt->at_stream_start_for_bom_read = 0; /* Record that we're no longer at stream start. */ pt->at_stream_start_for_bom_write = 0; if (pt->rw_random) pt->at_stream_start_for_bom_read = 0; - /* Write a BOM if appropriate. */ + /* Return a BOM if appropriate. */ if (scm_is_eq (pt->encoding, sym_UTF_16)) { SCM precise_encoding; + SCM bom = scm_c_make_bytevector (sizeof (scm_utf16be_bom)); scm_port_acquire_iconv_descriptors (port, NULL, NULL); precise_encoding = pt->precise_encoding; scm_port_release_iconv_descriptors (port); - if (scm_is_eq (precise_encoding, sym_UTF_16LE)) - scm_c_write (port, scm_utf16le_bom, sizeof (scm_utf16le_bom)); - else - scm_c_write (port, scm_utf16be_bom, sizeof (scm_utf16be_bom)); + memcpy (SCM_BYTEVECTOR_CONTENTS (bom), + scm_is_eq (precise_encoding, sym_UTF_16LE) + ? scm_utf16le_bom : scm_utf16be_bom, + SCM_BYTEVECTOR_LENGTH (bom)); + return bom; } else if (scm_is_eq (pt->encoding, sym_UTF_32)) { SCM precise_encoding; + SCM bom = scm_c_make_bytevector (sizeof (scm_utf32be_bom)); scm_port_acquire_iconv_descriptors (port, NULL, NULL); precise_encoding = pt->precise_encoding; scm_port_release_iconv_descriptors (port); - if (scm_is_eq (precise_encoding, sym_UTF_32LE)) - scm_c_write (port, scm_utf32le_bom, sizeof (scm_utf32le_bom)); - else - scm_c_write (port, scm_utf32be_bom, sizeof (scm_utf32be_bom)); + memcpy (SCM_BYTEVECTOR_CONTENTS (bom), + scm_is_eq (precise_encoding, sym_UTF_32LE) + ? scm_utf32le_bom : scm_utf32be_bom, + SCM_BYTEVECTOR_LENGTH (bom)); + return bom; } + + return SCM_BOOL_F; +} +#undef FUNC_NAME + +static void +port_clear_stream_start_for_bom_write (SCM port, enum bom_io_mode io_mode) +{ + scm_t_port *pt = SCM_PORT (port); + SCM bom; + + /* Fast path. */ + if (!pt->at_stream_start_for_bom_write) + return; + + bom = scm_port_clear_stream_start_for_bom_write (port); + + if (// io_mode == BOM_IO_TEXT && + scm_is_true (bom)) + scm_c_write_bytes (port, bom, 0, SCM_BYTEVECTOR_LENGTH (bom)); } SCM From 1123002a9e66f0fc9c329cc445fedfd077bfd770 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 25 May 2016 21:48:56 +0200 Subject: [PATCH 353/865] Add port-line-buffered? * libguile/ports.c (scm_port_line_buffered_p): New function. * module/ice-9/ports.scm: Plump port-line-buffered? and port-auxiliary-write-buffer through to the internals module --- libguile/ports.c | 11 +++++++++++ module/ice-9/ports.scm | 4 ++++ 2 files changed, 15 insertions(+) diff --git a/libguile/ports.c b/libguile/ports.c index 5660984b5..d04adc676 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -2703,6 +2703,17 @@ SCM_DEFINE (scm_port_auxiliary_write_buffer, "port-auxiliary-write-buffer", } #undef FUNC_NAME +SCM_INTERNAL SCM scm_port_line_buffered_p (SCM); +SCM_DEFINE (scm_port_line_buffered_p, "port-line-buffered?", 1, 0, 0, + (SCM port), + "Return true if the port is line buffered.") +#define FUNC_NAME s_scm_port_line_buffered_p +{ + SCM_VALIDATE_OPPORT (1, port); + return scm_from_bool (SCM_CELL_WORD_0 (port) & SCM_BUFLINE); +} +#undef FUNC_NAME + diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 4b7462585..3fc2f6465 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -164,6 +164,8 @@ interpret its input and output." #:use-module (ice-9 ports) #:export (port-read-buffer port-write-buffer + port-auxiliary-write-buffer + port-line-buffered? expand-port-read-buffer! port-buffer-bytevector port-buffer-cur @@ -219,6 +221,8 @@ interpret its input and output." (private-port-bindings port-read-buffer port-write-buffer + port-auxiliary-write-buffer + port-line-buffered? expand-port-read-buffer! port-read port-write From 43b6feeb1adafe54170304e7cc3c29a15c1d3808 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 26 May 2016 23:06:32 +0200 Subject: [PATCH 354/865] Beginnings of supporting encoding text in ports.c * libguile/ports.h (scm_c_put_latin1_chars, scm_c_put_utf32_chars) (scm_c_put_char, scm_c_put_string, scm_print_string): New public functions. The plan is to move encoding to ports.c and out of print.c. * libguile/ports.c (UTF8_BUFFER_SIZE, ESCAPE_BUFFER_SIZE): New internal defines. (update_port_position): Take a position instead of a port. Update callers. (utf8_to_codepoint): Allow lengths that are larger than necessary. (port_clear_stream_start_for_bom_write): Require that io_mode be BOM_IO_TEXT to write a BOM. (scm_fill_input): Add a related comment about BOM handling. (scm_i_write): use BOM_IO_TEXT, at least for now. (encode_escape_sequence, codepoint_to_utf8, utf8_to_codepoint) (put_utf8_chars_to_iconv_port, put_latin1_chars_to_utf8_port) (put_latin1_chars_to_iconv_port, put_utf32_chars_to_latin1_port) (put_utf32_chars_to_utf8_port, put_utf32_chars_to_iconv_port): New helpers. (scm_putc, scm_puts): Use scm_c_put_char and scm_put_latin1_chars. --- libguile/ports.c | 500 ++++++++++++++++++++++++++++++++++++++++++++--- libguile/ports.h | 11 +- 2 files changed, 480 insertions(+), 31 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index d04adc676..95f3337be 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -112,6 +112,12 @@ static SCM sym_escape; /* See scm_port_auxiliary_write_buffer and scm_c_write. */ static const size_t AUXILIARY_WRITE_BUFFER_SIZE = 256; +/* Maximum number of bytes in a UTF-8 sequence. */ +static const size_t UTF8_BUFFER_SIZE = 4; + +/* Maximum number of codepoints to write an escape sequence. */ +static const size_t ESCAPE_BUFFER_SIZE = 9; + @@ -1600,9 +1606,8 @@ scm_c_read (SCM port, void *buffer, size_t size) /* Update the line and column number of PORT after consumption of C. */ static inline void -update_port_position (SCM port, scm_t_wchar c) +update_port_position (SCM position, scm_t_wchar c) { - SCM position = SCM_PORT (port)->position; long line = scm_to_long (scm_port_position_line (position)); int column = scm_to_int (scm_port_position_column (position)); @@ -1632,8 +1637,6 @@ update_port_position (SCM port, scm_t_wchar c) } } -#define SCM_MBCHAR_BUF_SIZE (4) - /* Convert the SIZE-byte UTF-8 sequence in UTF8_BUF to a codepoint. UTF8_BUF is assumed to contain a valid UTF-8 sequence. */ static scm_t_wchar @@ -1643,25 +1646,25 @@ utf8_to_codepoint (const scm_t_uint8 *utf8_buf, size_t size) if (utf8_buf[0] <= 0x7f) { - assert (size == 1); + assert (size >= 1); codepoint = utf8_buf[0]; } else if ((utf8_buf[0] & 0xe0) == 0xc0) { - assert (size == 2); + assert (size >= 2); codepoint = ((scm_t_wchar) utf8_buf[0] & 0x1f) << 6UL | (utf8_buf[1] & 0x3f); } else if ((utf8_buf[0] & 0xf0) == 0xe0) { - assert (size == 3); + assert (size >= 3); codepoint = ((scm_t_wchar) utf8_buf[0] & 0x0f) << 12UL | ((scm_t_wchar) utf8_buf[1] & 0x3f) << 6UL | (utf8_buf[2] & 0x3f); } else { - assert (size == 4); + assert (size >= 4); codepoint = ((scm_t_wchar) utf8_buf[0] & 0x07) << 18UL | ((scm_t_wchar) utf8_buf[1] & 0x3f) << 12UL | ((scm_t_wchar) utf8_buf[2] & 0x3f) << 6UL @@ -1779,7 +1782,7 @@ SCM_DEFINE (scm_port_decode_char, "port-decode-char", 4, 0, 0, #define FUNC_NAME s_scm_port_decode_char { char *input, *output; - scm_t_uint8 utf8_buf[SCM_MBCHAR_BUF_SIZE]; + scm_t_uint8 utf8_buf[UTF8_BUFFER_SIZE]; iconv_t input_cd; size_t c_start, c_count; size_t input_left, output_left, done; @@ -1909,7 +1912,7 @@ scm_getc (SCM port) scm_port_buffer_did_take (SCM_PORT (port)->read_buf, len); if (codepoint == EOF) scm_i_clear_pending_eof (port); - update_port_position (port, codepoint); + update_port_position (SCM_PORT (port)->position, codepoint); return codepoint; } @@ -2035,7 +2038,7 @@ scm_ungetc (scm_t_wchar c, SCM port) if (SCM_UNLIKELY (result == NULL || len == 0)) scm_encoding_error (FUNC_NAME, errno, "conversion to port encoding failed", - SCM_BOOL_F, SCM_MAKE_CHAR (c)); + port, SCM_MAKE_CHAR (c)); scm_unget_bytes ((unsigned char *) result, len, port); @@ -2520,8 +2523,7 @@ port_clear_stream_start_for_bom_write (SCM port, enum bom_io_mode io_mode) bom = scm_port_clear_stream_start_for_bom_write (port); - if (// io_mode == BOM_IO_TEXT && - scm_is_true (bom)) + if (io_mode == BOM_IO_TEXT && scm_is_true (bom)) scm_c_write_bytes (port, bom, 0, SCM_BYTEVECTOR_LENGTH (bom)); } @@ -2535,6 +2537,9 @@ scm_fill_input (SCM port, size_t minimum_size) if (minimum_size == 0) minimum_size = 1; + /* The default is BOM_IO_TEXT. Binary input procedures should + port_clear_stream_start_for_bom_read with BOM_IO_BINARY before + filling the input buffers. */ port_clear_stream_start_for_bom_read (port, BOM_IO_TEXT); read_buf = pt->read_buf; buffered = scm_port_buffer_can_take (read_buf); @@ -2719,20 +2724,6 @@ SCM_DEFINE (scm_port_line_buffered_p, "port-line-buffered?", 1, 0, 0, /* Output. */ -void -scm_putc (char c, SCM port) -{ - SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port"); - scm_lfwrite (&c, 1, port); -} - -void -scm_puts (const char *s, SCM port) -{ - SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port"); - scm_lfwrite (s, strlen (s), port); -} - static void scm_i_write_bytes (SCM port, SCM src, size_t start, size_t count) { @@ -2761,7 +2752,10 @@ scm_i_write (SCM port, SCM buf) { size_t start, count; - port_clear_stream_start_for_bom_write (port, BOM_IO_BINARY); + /* The default is BOM_IO_TEXT. Binary output procedures should + port_clear_stream_start_for_bom_write with BOM_IO_BINARY before + filling the input buffers. */ + port_clear_stream_start_for_bom_write (port, BOM_IO_TEXT); /* Update cursors before attempting to write, assuming that I/O errors are sticky. That way if the write throws an error, causing the @@ -2885,6 +2879,454 @@ scm_c_write (SCM port, const void *ptr, size_t size) } #undef FUNC_NAME +/* The encoded escape sequence will be written to BUF, and will be valid + ASCII (so also valid ISO-8859-1 and UTF-8). Return the number of + bytes written. */ +static size_t +encode_escape_sequence (scm_t_wchar ch, scm_t_uint8 buf[ESCAPE_BUFFER_SIZE]) +{ + /* Represent CH using the in-string escape syntax. */ + static const char hex[] = "0123456789abcdef"; + static const char escapes[7] = "abtnvfr"; + size_t i = 0; + + buf[i++] = '\\'; + + if (ch >= 0x07 && ch <= 0x0D && ch != 0x0A) + /* Use special escapes for some C0 controls. */ + buf[i++] = escapes[ch - 0x07]; + else if (!SCM_R6RS_ESCAPES_P) + { + if (ch <= 0xFF) + { + buf[i++] = 'x'; + buf[i++] = hex[ch / 16]; + buf[i++] = hex[ch % 16]; + } + else if (ch <= 0xFFFF) + { + buf[i++] = 'u'; + buf[i++] = hex[(ch & 0xF000) >> 12]; + buf[i++] = hex[(ch & 0xF00) >> 8]; + buf[i++] = hex[(ch & 0xF0) >> 4]; + buf[i++] = hex[(ch & 0xF)]; + } + else if (ch > 0xFFFF) + { + buf[i++] = 'U'; + buf[i++] = hex[(ch & 0xF00000) >> 20]; + buf[i++] = hex[(ch & 0xF0000) >> 16]; + buf[i++] = hex[(ch & 0xF000) >> 12]; + buf[i++] = hex[(ch & 0xF00) >> 8]; + buf[i++] = hex[(ch & 0xF0) >> 4]; + buf[i++] = hex[(ch & 0xF)]; + } + } + else + { + buf[i++] = 'x'; + if (ch > 0xfffff) buf[i++] = hex[(ch >> 20) & 0xf]; + if (ch > 0x0ffff) buf[i++] = hex[(ch >> 16) & 0xf]; + if (ch > 0x00fff) buf[i++] = hex[(ch >> 12) & 0xf]; + if (ch > 0x000ff) buf[i++] = hex[(ch >> 8) & 0xf]; + if (ch > 0x0000f) buf[i++] = hex[(ch >> 4) & 0xf]; + buf[i++] = hex[ch & 0xf]; + buf[i++] = ';'; + } + + return i; +} + +/* Convert CODEPOINT to UTF-8 and store the result in UTF8. Return the + number of bytes of the UTF-8-encoded string. */ +static size_t +codepoint_to_utf8 (scm_t_uint32 codepoint, scm_t_uint8 utf8[UTF8_BUFFER_SIZE]) +{ + size_t len; + + if (codepoint <= 0x7f) + { + len = 1; + utf8[0] = codepoint; + } + else if (codepoint <= 0x7ffUL) + { + len = 2; + utf8[0] = 0xc0 | (codepoint >> 6); + utf8[1] = 0x80 | (codepoint & 0x3f); + } + else if (codepoint <= 0xffffUL) + { + len = 3; + utf8[0] = 0xe0 | (codepoint >> 12); + utf8[1] = 0x80 | ((codepoint >> 6) & 0x3f); + utf8[2] = 0x80 | (codepoint & 0x3f); + } + else + { + len = 4; + utf8[0] = 0xf0 | (codepoint >> 18); + utf8[1] = 0x80 | ((codepoint >> 12) & 0x3f); + utf8[2] = 0x80 | ((codepoint >> 6) & 0x3f); + utf8[3] = 0x80 | (codepoint & 0x3f); + } + + return len; +} + +/* We writing, we always iconv from UTF-8. Also in this function we + only see complete codepoints. */ +static void +put_utf8_chars_to_iconv_port (SCM port, const scm_t_uint8 *buf, size_t len) +{ + SCM bv = scm_port_buffer_bytevector (scm_port_auxiliary_write_buffer (port)); + scm_t_uint8 *aux = (scm_t_uint8*) SCM_BYTEVECTOR_CONTENTS (bv); + size_t aux_len = SCM_BYTEVECTOR_LENGTH (bv); + iconv_t output_cd; + scm_t_wchar bad_codepoint; + int saved_errno; + + while (len) + { + char *input, *output; + size_t done, input_left, output_left; + + input = (char *) buf; + input_left = len; + output = (char *) aux; + output_left = aux_len; + + scm_port_acquire_iconv_descriptors (port, NULL, &output_cd); + done = iconv (output_cd, &input, &input_left, &output, &output_left); + saved_errno = errno; + /* Emit bytes needed to get back to initial state, if needed. */ + if (done != (size_t) -1) + iconv (output_cd, NULL, NULL, &output, &output_left); + scm_port_release_iconv_descriptors (port); + + buf += (len - input_left); + len -= (len - input_left); + scm_c_write_bytes (port, bv, 0, aux_len - output_left); + + if (done == (size_t) -1) + { + scm_t_port *pt = SCM_PORT (port); + + /* The source buffer is valid UTF-8, so we shouldn't get + EILSEQ because of the input encoding; if we get EILSEQ, + that means the codepoint is not accessible in the target + encoding. We have whole codepoints in the source buffer, + so we shouldn't get EINVAL. We can get E2BIG, meaning we + just need to process the next chunk. The descriptor should + be valid so we shouldn't get EBADF. In summary, we should + only do E2BIG and EILSEQ. */ + + if (saved_errno == E2BIG) + continue; + + bad_codepoint = utf8_to_codepoint (buf, len); + + if (saved_errno != EILSEQ) + goto error; + + /* Advance the input past the utf8 sequence. */ + { + size_t advance = codepoint_to_utf8 (bad_codepoint, aux); + buf += advance; + len -= advance; + } + + /* Convert substitutes or escapes into the aux buf. */ + output = (char *) aux; + output_left = aux_len; + + /* Substitute or escape. Note that this re-sets "done", + "saved_errno", "output", and "output_left". */ + if (scm_is_eq (pt->conversion_strategy, sym_escape)) + { + scm_t_uint8 escape[ESCAPE_BUFFER_SIZE]; + input = (char *) escape; + input_left = encode_escape_sequence (bad_codepoint, escape); + scm_port_acquire_iconv_descriptors (port, NULL, &output_cd); + done = iconv (output_cd, &input, &input_left, &output, &output_left); + saved_errno = errno; + scm_port_release_iconv_descriptors (port); + } + else if (scm_is_eq (pt->conversion_strategy, sym_substitute)) + { + scm_t_uint8 substitute[2] = "?"; + input = (char *) substitute; + input_left = 1; + scm_port_acquire_iconv_descriptors (port, NULL, &output_cd); + done = iconv (output_cd, &input, &input_left, &output, &output_left); + saved_errno = errno; + scm_port_release_iconv_descriptors (port); + } + + /* This catches both the "error" conversion strategy case, and + any error while substituting or escaping the character. */ + if (done == (size_t) -1) + goto error; + + /* The substitution or escape succeeded; print it. */ + scm_c_write_bytes (port, bv, 0, aux_len - output_left); + } + } + + return; + + error: + scm_encoding_error ("put-char", saved_errno, + "conversion to port encoding failed", + port, SCM_MAKE_CHAR (bad_codepoint)); +} + +static void +put_latin1_chars_to_utf8_port (SCM port, const scm_t_uint8 *buf, size_t len) +{ + SCM bv = scm_port_buffer_bytevector (scm_port_auxiliary_write_buffer (port)); + scm_t_uint8 *utf8 = (scm_t_uint8*) SCM_BYTEVECTOR_CONTENTS (bv); + size_t utf8_len = SCM_BYTEVECTOR_LENGTH (bv); + + while (len) + { + size_t read, written; + for (read = 0, written = 0; + read < len && written + UTF8_BUFFER_SIZE < utf8_len; + read++) + written += codepoint_to_utf8 (buf[read], utf8 + written); + + buf += read; + len -= read; + scm_c_write_bytes (port, bv, 0, written); + } +} + +static void +put_latin1_chars_to_iconv_port (SCM port, const scm_t_uint8 *buf, size_t len) +{ + scm_t_uint8 utf8[AUXILIARY_WRITE_BUFFER_SIZE]; + size_t utf8_len = AUXILIARY_WRITE_BUFFER_SIZE; + + /* Convert through UTF-8, as most non-GNU iconvs can only convert + between a limited number of encodings. */ + while (len) + { + size_t read, written; + for (read = 0, written = 0; + read < len && written + UTF8_BUFFER_SIZE < utf8_len; + read++) + written += codepoint_to_utf8 (buf[read], utf8 + written); + + buf += read; + len -= read; + put_utf8_chars_to_iconv_port (port, utf8, written); + } +} + +static void +put_utf32_chars_to_latin1_port (SCM port, const scm_t_uint32 *buf, size_t len) +{ + SCM bv = scm_port_buffer_bytevector (scm_port_auxiliary_write_buffer (port)); + scm_t_uint8 *latin1 = (scm_t_uint8*) SCM_BYTEVECTOR_CONTENTS (bv); + size_t latin1_len = SCM_BYTEVECTOR_LENGTH (bv); + + while (len) + { + size_t read = 0, written = 0; + while (read < len && written + ESCAPE_BUFFER_SIZE <= latin1_len) + { + scm_t_port *pt = SCM_PORT (port); + scm_t_uint32 ch = buf[read++]; + if (ch <= 0xff) + latin1[written++] = ch; + else if (scm_is_eq (pt->conversion_strategy, sym_substitute)) + latin1[written++] = '?'; + else if (scm_is_eq (pt->conversion_strategy, sym_escape)) + written += encode_escape_sequence (ch, latin1 + written); + else + { + scm_c_write_bytes (port, bv, 0, written); + scm_encoding_error ("put-char", EILSEQ, + "conversion to port encoding failed", + port, SCM_MAKE_CHAR (ch)); + } + } + + buf += read; + len -= read; + scm_c_write_bytes (port, bv, 0, written); + } +} + +static void +put_utf32_chars_to_utf8_port (SCM port, const scm_t_uint32 *buf, size_t len) +{ + SCM bv = scm_port_buffer_bytevector (scm_port_auxiliary_write_buffer (port)); + scm_t_uint8 *utf8 = (scm_t_uint8*) SCM_BYTEVECTOR_CONTENTS (bv); + size_t utf8_len = SCM_BYTEVECTOR_LENGTH (bv); + + while (len) + { + size_t read, written; + for (read = 0, written = 0; + read < len && written + UTF8_BUFFER_SIZE < utf8_len; + read++) + written += codepoint_to_utf8 (buf[read], utf8 + written); + + buf += read; + len -= read; + scm_c_write_bytes (port, bv, 0, written); + } +} + +static void +put_utf32_chars_to_iconv_port (SCM port, const scm_t_uint32 *buf, size_t len) +{ + scm_t_uint8 utf8[AUXILIARY_WRITE_BUFFER_SIZE]; + size_t utf8_len = AUXILIARY_WRITE_BUFFER_SIZE; + + /* Convert through UTF-8, as most non-GNU iconvs can only convert + between a limited number of encodings. */ + while (len) + { + size_t read, written; + for (read = 0, written = 0; + read < len && written + UTF8_BUFFER_SIZE < utf8_len; + read++) + written += codepoint_to_utf8 (buf[read], utf8 + written); + + buf += read; + len -= read; + put_utf8_chars_to_iconv_port (port, utf8, written); + } +} + +void +scm_c_put_latin1_chars (SCM port, const scm_t_uint8 *buf, size_t len) +{ + scm_t_port *pt = SCM_PORT (port); + SCM position, saved_line; + size_t i; + + if (len == 0) + return; + + port_clear_stream_start_for_bom_write (port, BOM_IO_TEXT); + + if (scm_is_eq (pt->encoding, sym_ISO_8859_1)) + scm_c_write (port, buf, len); + else if (scm_is_eq (pt->encoding, sym_UTF_8)) + put_latin1_chars_to_utf8_port (port, buf, len); + else + put_latin1_chars_to_iconv_port (port, buf, len); + + position = pt->position; + saved_line = scm_port_position_line (position); + for (i = 0; i < len; i++) + update_port_position (position, buf[i]); + + /* Handle line buffering. */ + if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && + !scm_is_eq (saved_line, scm_port_position_line (position))) + scm_flush (port); +} + +void +scm_c_put_utf32_chars (SCM port, const scm_t_uint32 *buf, size_t len) +{ + scm_t_port *pt = SCM_PORT (port); + SCM position, saved_line; + size_t i; + + if (len == 0) + return; + + port_clear_stream_start_for_bom_write (port, BOM_IO_TEXT); + + if (scm_is_eq (pt->encoding, sym_ISO_8859_1)) + put_utf32_chars_to_latin1_port (port, buf, len); + else if (scm_is_eq (pt->encoding, sym_UTF_8)) + put_utf32_chars_to_utf8_port (port, buf, len); + else + put_utf32_chars_to_iconv_port (port, buf, len); + + position = pt->position; + saved_line = scm_port_position_line (position); + for (i = 0; i < len; i++) + update_port_position (position, buf[i]); + + /* Handle line buffering. */ + if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && + !scm_is_eq (saved_line, scm_port_position_line (position))) + scm_flush (port); +} + +void +scm_c_put_char (SCM port, scm_t_wchar ch) +{ + if (ch <= 0xff) + { + scm_t_uint8 narrow_ch = ch; + scm_c_put_latin1_chars (port, &narrow_ch, 1); + } + else + { + scm_t_uint32 wide_ch = ch; + scm_c_put_utf32_chars (port, &wide_ch, 1); + } +} + +void +scm_c_put_string (SCM port, SCM string, size_t start, size_t count) +{ + if (scm_i_is_narrow_string (string)) + { + const char *ptr = scm_i_string_chars (string); + scm_c_put_latin1_chars (port, ((const scm_t_uint8 *) ptr) + start, count); + } + else + { + const scm_t_wchar *ptr = scm_i_string_wide_chars (string); + scm_c_put_utf32_chars (port, ((const scm_t_uint32 *) ptr) + start, count); + } +} + +SCM_DEFINE (scm_put_string, "put-string", 2, 2, 0, + (SCM port, SCM string, SCM start, SCM count), + "") +#define FUNC_NAME s_scm_put_string +{ + size_t c_start, c_count, c_len; + + SCM_VALIDATE_OPINPORT (1, port); + SCM_VALIDATE_STRING (2, string); + c_len = scm_i_string_length (string); + c_start = SCM_UNBNDP (start) ? 0 : scm_to_size_t (start); + SCM_ASSERT_RANGE (3, start, c_start <= c_len); + c_count = SCM_UNBNDP (count) ? c_len - c_start : scm_to_size_t (count); + SCM_ASSERT_RANGE (4, count, c_count <= c_len - c_start); + + scm_c_put_string (port, string, c_start, c_count); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +void +scm_putc (char c, SCM port) +{ + SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port"); + scm_c_put_char (port, (scm_t_uint8) c); +} + +void +scm_puts (const char *s, SCM port) +{ + SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port"); + scm_c_put_latin1_chars (port, (const scm_t_uint8 *) s, strlen (s)); +} + /* scm_lfwrite * * This function differs from scm_c_write; it updates port line and @@ -2904,7 +3346,7 @@ scm_lfwrite (const char *ptr, size_t size, SCM port) position = SCM_PORT (port)->position; saved_line = scm_port_position_line (position); for (; size; ptr++, size--) - update_port_position (port, (scm_t_wchar) (unsigned char) *ptr); + update_port_position (position, (scm_t_wchar) (unsigned char) *ptr); /* Handle line buffering. */ if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && diff --git a/libguile/ports.h b/libguile/ports.h index 13661e008..7e0a4f325 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -211,10 +211,17 @@ SCM_INTERNAL SCM scm_port_write_buffer (SCM port); SCM_INTERNAL SCM scm_port_auxiliary_write_buffer (SCM port); /* Output. */ -SCM_API void scm_putc (char c, SCM port); -SCM_API void scm_puts (const char *str_data, SCM port); SCM_API void scm_c_write (SCM port, const void *buffer, size_t size); SCM_API void scm_c_write_bytes (SCM port, SCM src, size_t start, size_t count); +SCM_API void scm_c_put_latin1_chars (SCM port, const scm_t_uint8 *buf, + size_t len); +SCM_API void scm_c_put_utf32_chars (SCM port, const scm_t_uint32 *buf, + size_t len); +SCM_API void scm_c_put_string (SCM port, SCM str, size_t start, size_t count); +SCM_API SCM scm_put_string (SCM port, SCM str, SCM start, SCM count); +SCM_API void scm_c_put_char (SCM port, scm_t_wchar ch); +SCM_API void scm_putc (char c, SCM port); +SCM_API void scm_puts (const char *str_data, SCM port); SCM_API void scm_lfwrite (const char *ptr, size_t size, SCM port); SCM_INTERNAL void scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port); From 8f615cde4574d012d5724d921588d241a5729281 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 30 May 2016 11:59:58 +0200 Subject: [PATCH 355/865] print_normal_symbol uses new port functions * libguile/print.c (print_normal_symbol): Use new port functions. --- libguile/print.c | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/libguile/print.c b/libguile/print.c index 84c9455b3..4b6470e1c 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -436,16 +436,18 @@ symbol_has_extended_read_syntax (SCM sym) static void print_normal_symbol (SCM sym, SCM port) { - size_t len; - scm_t_string_failed_conversion_handler strategy; - - len = scm_i_symbol_length (sym); - strategy = PORT_CONVERSION_HANDLER (port); + size_t len = scm_i_symbol_length (sym); if (scm_i_is_narrow_symbol (sym)) - display_string (scm_i_symbol_chars (sym), 1, len, port, strategy); + { + const char *ptr = scm_i_symbol_chars (sym); + scm_c_put_latin1_chars (port, (const scm_t_uint8 *) ptr, len); + } else - display_string (scm_i_symbol_wide_chars (sym), 0, len, port, strategy); + { + const scm_t_wchar *ptr = scm_i_symbol_wide_chars (sym); + scm_c_put_utf32_chars (port, (const scm_t_uint32 *) ptr, len); + } } static void From 934b6dc398ad1875768e503c9e779d5c1f1db774 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 30 May 2016 15:05:40 +0200 Subject: [PATCH 356/865] iprin1 uses scm_c_put_string * libguile/print.c (iprin1): Use scm_c_put_string for strings. * test-suite/test-suite/lib.scm (exception:encoding-error): Add an additional expected error string for `encoding-error'. --- libguile/print.c | 7 ++----- test-suite/test-suite/lib.scm | 2 +- 2 files changed, 3 insertions(+), 6 deletions(-) diff --git a/libguile/print.c b/libguile/print.c index 4b6470e1c..519393c95 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -717,7 +717,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) { size_t len, printed; - len = scm_i_string_length (exp); + printed = len = scm_i_string_length (exp); if (SCM_WRITINGP (pstate)) { printed = write_string (scm_i_string_data (exp), @@ -727,10 +727,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) len += 2; /* account for the quotes */ } else - printed = display_string (scm_i_string_data (exp), - scm_i_is_narrow_string (exp), - len, port, - PORT_CONVERSION_HANDLER (port)); + scm_c_put_string (port, exp, 0, len); if (SCM_UNLIKELY (printed < len)) scm_encoding_error (__func__, errno, diff --git a/test-suite/test-suite/lib.scm b/test-suite/test-suite/lib.scm index 27620a7b7..5b73bdab3 100644 --- a/test-suite/test-suite/lib.scm +++ b/test-suite/test-suite/lib.scm @@ -287,7 +287,7 @@ (define exception:system-error (cons 'system-error ".*")) (define exception:encoding-error - (cons 'encoding-error "(cannot convert.* to output locale|input (locale conversion|decoding) error)")) + (cons 'encoding-error "(cannot convert.* to output locale|input (locale conversion|decoding) error|conversion to port encoding failed)")) (define exception:miscellaneous-error (cons 'misc-error "^.*")) (define exception:read-error From 2affb9accf4efae67de915c11300a742cede2d58 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 30 May 2016 18:48:09 +0200 Subject: [PATCH 357/865] Add scm_c_put_escaped_char, scm_c_can_put_char * libguile/ports.h: * libguile/ports.c (scm_c_put_escaped_char, scm_c_can_put_char): New helpers. --- libguile/ports.c | 49 +++++++++++++++++++++++++++++++++++++++++++++++- libguile/ports.h | 2 ++ 2 files changed, 50 insertions(+), 1 deletion(-) diff --git a/libguile/ports.c b/libguile/ports.c index 95f3337be..5d518e868 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -2937,6 +2937,14 @@ encode_escape_sequence (scm_t_wchar ch, scm_t_uint8 buf[ESCAPE_BUFFER_SIZE]) return i; } +void +scm_c_put_escaped_char (SCM port, scm_t_wchar ch) +{ + scm_t_uint8 escape[ESCAPE_BUFFER_SIZE]; + size_t len = encode_escape_sequence (ch, escape); + scm_c_put_latin1_chars (port, escape, len); +} + /* Convert CODEPOINT to UTF-8 and store the result in UTF8. Return the number of bytes of the UTF-8-encoded string. */ static size_t @@ -3277,6 +3285,45 @@ scm_c_put_char (SCM port, scm_t_wchar ch) } } +/* Return 0 unless the port can be written out to the port's encoding + without errors, substitutions, or escapes. */ +int +scm_c_can_put_char (SCM port, scm_t_wchar ch) +{ + SCM encoding = SCM_PORT (port)->encoding; + + if (scm_is_eq (encoding, sym_UTF_8) + || (scm_is_eq (encoding, sym_ISO_8859_1) && ch <= 0xff) + || scm_is_eq (encoding, sym_UTF_16) + || scm_is_eq (encoding, sym_UTF_16LE) + || scm_is_eq (encoding, sym_UTF_16BE) + || scm_is_eq (encoding, sym_UTF_32) + || scm_is_eq (encoding, sym_UTF_32LE) + || scm_is_eq (encoding, sym_UTF_32BE)) + return 1; + + { + SCM bv = scm_port_buffer_bytevector (scm_port_auxiliary_write_buffer (port)); + scm_t_uint8 buf[UTF8_BUFFER_SIZE]; + char *input = (char *) buf; + size_t input_len; + char *output = (char *) SCM_BYTEVECTOR_CONTENTS (bv); + size_t output_len = SCM_BYTEVECTOR_LENGTH (bv); + size_t result; + iconv_t output_cd; + + input_len = codepoint_to_utf8 (ch, buf); + + scm_port_acquire_iconv_descriptors (port, NULL, &output_cd); + iconv (output_cd, NULL, NULL, &output, &output_len); + result = iconv (output_cd, &input, &input_len, &output, &output_len); + iconv (output_cd, NULL, NULL, &output, &output_len); + scm_port_release_iconv_descriptors (port); + + return result != (size_t) -1; + } +} + void scm_c_put_string (SCM port, SCM string, size_t start, size_t count) { @@ -3361,7 +3408,7 @@ scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port) if (end == (size_t) -1) end = scm_i_string_length (str); - scm_i_display_substring (str, start, end, port); + scm_c_put_string (port, str, start, end - start); } diff --git a/libguile/ports.h b/libguile/ports.h index 7e0a4f325..f8d62c119 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -220,6 +220,8 @@ SCM_API void scm_c_put_utf32_chars (SCM port, const scm_t_uint32 *buf, SCM_API void scm_c_put_string (SCM port, SCM str, size_t start, size_t count); SCM_API SCM scm_put_string (SCM port, SCM str, SCM start, SCM count); SCM_API void scm_c_put_char (SCM port, scm_t_wchar ch); +SCM_INTERNAL void scm_c_put_escaped_char (SCM port, scm_t_wchar ch); +SCM_INTERNAL int scm_c_can_put_char (SCM port, scm_t_wchar ch); SCM_API void scm_putc (char c, SCM port); SCM_API void scm_puts (const char *str_data, SCM port); SCM_API void scm_lfwrite (const char *ptr, size_t size, SCM port); From 0e888cd00b3a02fe73b2f678f992d3957d74d875 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 30 May 2016 18:49:25 +0200 Subject: [PATCH 358/865] Simplify string, symbol, char display/write impls * libguile/print.h: * libguile/print.c: Use the new routines from ports.[ch]. --- libguile/print.c | 611 +++++++---------------------------------------- libguile/print.h | 2 - 2 files changed, 80 insertions(+), 533 deletions(-) diff --git a/libguile/print.c b/libguile/print.c index 519393c95..2485d9716 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -60,26 +60,8 @@ /* Character printers. */ -#define PORT_CONVERSION_HANDLER(port) \ - scm_i_string_failed_conversion_handler (scm_port_conversion_strategy (port)) - -SCM_SYMBOL (sym_UTF_8, "UTF-8"); -SCM_SYMBOL (sym_ISO_8859_1, "ISO-8859-1"); -SCM_SYMBOL (sym_UTF_16, "UTF-16"); -SCM_SYMBOL (sym_UTF_32, "UTF-32"); - -static size_t display_string (const void *, int, size_t, SCM, - scm_t_string_failed_conversion_handler); - -static size_t write_string (const void *, int, size_t, SCM, - scm_t_string_failed_conversion_handler); - -static int display_character (scm_t_wchar, SCM, - scm_t_string_failed_conversion_handler); - -static void write_character (scm_t_wchar, SCM, int); - -static void write_character_escaped (scm_t_wchar, int, SCM); +static void write_string (const void *, int, size_t, SCM); +static void write_character (scm_t_wchar, SCM); @@ -454,11 +436,8 @@ static void print_extended_symbol (SCM sym, SCM port) { size_t pos, len; - scm_t_string_failed_conversion_handler strategy; len = scm_i_symbol_length (sym); - strategy = PORT_CONVERSION_HANDLER (port); - scm_lfwrite ("#{", 2, port); for (pos = 0; pos < len; pos++) @@ -468,13 +447,7 @@ print_extended_symbol (SCM sym, SCM port) if (uc_is_general_category_withtable (c, SUBSEQUENT_IDENTIFIER_MASK | UC_CATEGORY_MASK_Zs)) - { - if (!display_character (c, port, strategy) - || (c == '\\' && !display_character (c, port, strategy))) - scm_encoding_error ("print_extended_symbol", errno, - "cannot convert to output locale", - port, SCM_MAKE_CHAR (c)); - } + scm_c_put_char (port, c); else { scm_lfwrite ("\\x", 2, port); @@ -490,10 +463,8 @@ static void print_r7rs_extended_symbol (SCM sym, SCM port) { size_t pos, len; - scm_t_string_failed_conversion_handler strategy; len = scm_i_symbol_length (sym); - strategy = PORT_CONVERSION_HANDLER (port); scm_putc ('|', port); @@ -518,12 +489,7 @@ print_r7rs_extended_symbol (SCM sym, SCM port) | UC_CATEGORY_MASK_P | UC_CATEGORY_MASK_S) || (c == ' ')) - { - if (!display_character (c, port, strategy)) - scm_encoding_error ("print_r7rs_extended_symbol", errno, - "cannot convert to output locale", - port, SCM_MAKE_CHAR (c)); - } + scm_c_put_char (port, c); else { scm_lfwrite ("\\x", 2, port); @@ -564,21 +530,6 @@ SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display); static void iprin1 (SCM exp, SCM port, scm_print_state *pstate); -/* Print a character as an octal or hex escape. */ -#define PRINT_CHAR_ESCAPE(i, port) \ - do \ - { \ - if (!SCM_R6RS_ESCAPES_P) \ - scm_intprint (i, 8, port); \ - else \ - { \ - scm_puts ("x", port); \ - scm_intprint (i, 16, port); \ - } \ - } \ - while (0) - - void scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) { @@ -641,15 +592,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) if (SCM_CHARP (exp)) { if (SCM_WRITINGP (pstate)) - write_character (SCM_CHAR (exp), port, 0); + write_character (SCM_CHAR (exp), port); else - { - if (!display_character (SCM_CHAR (exp), port, - PORT_CONVERSION_HANDLER (port))) - scm_encoding_error (__func__, errno, - "cannot convert to output locale", - port, exp); - } + scm_c_put_char (port, SCM_CHAR (exp)); } else if (SCM_IFLAGP (exp) && ((size_t) SCM_IFLAGNUM (exp) < (sizeof iflagnames / sizeof (char *)))) @@ -715,26 +660,15 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) break; case scm_tc7_string: { - size_t len, printed; + size_t len = scm_i_string_length (exp); - printed = len = scm_i_string_length (exp); if (SCM_WRITINGP (pstate)) - { - printed = write_string (scm_i_string_data (exp), - scm_i_is_narrow_string (exp), - len, port, - PORT_CONVERSION_HANDLER (port)); - len += 2; /* account for the quotes */ - } + write_string (scm_i_string_data (exp), + scm_i_is_narrow_string (exp), + len, port); else scm_c_put_string (port, exp, 0, len); - - if (SCM_UNLIKELY (printed < len)) - scm_encoding_error (__func__, errno, - "cannot convert to output locale", - port, scm_c_string_ref (exp, printed)); } - scm_remember_upto_here_1 (exp); break; case scm_tc7_symbol: @@ -889,471 +823,89 @@ scm_prin1 (SCM exp, SCM port, int writingp) } } -/* Convert codepoint CH to UTF-8 and store the result in UTF8. Return - the number of bytes of the UTF-8-encoded string. */ -static size_t -codepoint_to_utf8 (scm_t_wchar ch, scm_t_uint8 utf8[4]) -{ - size_t len; - scm_t_uint32 codepoint; - - codepoint = (scm_t_uint32) ch; - - if (codepoint <= 0x7f) - { - len = 1; - utf8[0] = (scm_t_uint8) codepoint; - } - else if (codepoint <= 0x7ffUL) - { - len = 2; - utf8[0] = 0xc0 | (codepoint >> 6); - utf8[1] = 0x80 | (codepoint & 0x3f); - } - else if (codepoint <= 0xffffUL) - { - len = 3; - utf8[0] = 0xe0 | (codepoint >> 12); - utf8[1] = 0x80 | ((codepoint >> 6) & 0x3f); - utf8[2] = 0x80 | (codepoint & 0x3f); - } - else - { - len = 4; - utf8[0] = 0xf0 | (codepoint >> 18); - utf8[1] = 0x80 | ((codepoint >> 12) & 0x3f); - utf8[2] = 0x80 | ((codepoint >> 6) & 0x3f); - utf8[3] = 0x80 | (codepoint & 0x3f); - } - - return len; -} - -#define STR_REF(s, x) \ - (narrow_p \ - ? (scm_t_wchar) ((unsigned char *) (s))[x] \ - : ((scm_t_wchar *) (s))[x]) - -/* Write STR to PORT as UTF-8. STR is a LEN-codepoint string; it is - narrow if NARROW_P is true, wide otherwise. Return LEN. */ -static size_t -display_string_as_utf8 (const void *str, int narrow_p, size_t len, - SCM port) -{ - size_t printed = 0; - - while (len > printed) - { - size_t utf8_len, i; - char *input, utf8_buf[256]; - - /* Convert STR to UTF-8. */ - for (i = printed, utf8_len = 0, input = utf8_buf; - i < len && utf8_len + 4 < sizeof (utf8_buf); - i++) - { - utf8_len += codepoint_to_utf8 (STR_REF (str, i), - (scm_t_uint8 *) input); - input = utf8_buf + utf8_len; - } - - /* INPUT was successfully converted, entirely; print the - result. */ - scm_lfwrite (utf8_buf, utf8_len, port); - printed += i - printed; - } - - assert (printed == len); - - return len; -} - -/* Write STR to PORT as ISO-8859-1. STR is a LEN-codepoint string; it - is narrow if NARROW_P is true, wide otherwise. Return LEN. */ -static size_t -display_string_as_latin1 (const void *str, int narrow_p, size_t len, - SCM port, - scm_t_string_failed_conversion_handler strategy) -{ - size_t printed = 0; - - if (narrow_p) - { - scm_lfwrite (str, len, port); - return len; - } - - while (printed < len) - { - char buf[256]; - size_t i; - - for (i = 0; i < sizeof(buf) && printed < len; i++, printed++) - { - scm_t_wchar c = STR_REF (str, printed); - - if (c < 256) - buf[i] = c; - else - break; - } - - scm_lfwrite (buf, i, port); - - if (i < sizeof(buf) && printed < len) - { - if (strategy == SCM_FAILED_CONVERSION_ERROR) - break; - else if (strategy == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE) - write_character_escaped (STR_REF (str, printed), 1, port); - else - /* STRATEGY is `SCM_FAILED_CONVERSION_QUESTION_MARK'. */ - display_string ("?", 1, 1, port, strategy); - printed++; - } - } - - return printed; -} - -/* Convert STR through PORT's output conversion descriptor and write the - output to PORT. Return the number of codepoints written. */ -static size_t -display_string_using_iconv (const void *str, int narrow_p, size_t len, - SCM port, - scm_t_string_failed_conversion_handler strategy) -{ - size_t printed; - iconv_t output_cd; - - printed = 0; - - while (len > printed) - { - size_t done, utf8_len, input_left, output_left, i; - size_t codepoints_read, output_len; - char *input, *output; - char utf8_buf[256], encoded_output[256]; - size_t offsets[256]; - - /* Convert STR to UTF-8. */ - for (i = printed, utf8_len = 0, input = utf8_buf; - i < len && utf8_len + 4 < sizeof (utf8_buf); - i++) - { - offsets[utf8_len] = i; - utf8_len += codepoint_to_utf8 (STR_REF (str, i), - (scm_t_uint8 *) input); - input = utf8_buf + utf8_len; - } - - input = utf8_buf; - input_left = utf8_len; - - output = encoded_output; - output_left = sizeof (encoded_output); - - scm_port_acquire_iconv_descriptors (port, NULL, &output_cd); - done = iconv (output_cd, &input, &input_left, &output, &output_left); - scm_port_release_iconv_descriptors (port); - - output_len = sizeof (encoded_output) - output_left; - - if (SCM_UNLIKELY (done == (size_t) -1)) - { - int errno_save = errno; - - /* Reset the `iconv' state. */ - scm_port_acquire_iconv_descriptors (port, NULL, &output_cd); - iconv (output_cd, NULL, NULL, NULL, NULL); - scm_port_release_iconv_descriptors (port); - - /* Print the OUTPUT_LEN bytes successfully converted. */ - scm_lfwrite (encoded_output, output_len, port); - - /* See how many input codepoints these OUTPUT_LEN bytes - corresponds to. */ - codepoints_read = offsets[input - utf8_buf] - printed; - printed += codepoints_read; - - if (errno_save == EILSEQ && - strategy != SCM_FAILED_CONVERSION_ERROR) - { - /* Conversion failed somewhere in INPUT and we want to - escape or substitute the offending input character. */ - - if (strategy == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE) - { - scm_t_wchar ch; - - /* Find CH, the offending codepoint, and escape it. */ - ch = STR_REF (str, offsets[input - utf8_buf]); - write_character_escaped (ch, 1, port); - } - else - /* STRATEGY is `SCM_FAILED_CONVERSION_QUESTION_MARK'. */ - display_string ("?", 1, 1, port, strategy); - - printed++; - } - else - /* Something bad happened that we can't handle: bail out. */ - break; - } - else - { - /* INPUT was successfully converted, entirely; print the - result. */ - scm_lfwrite (encoded_output, output_len, port); - codepoints_read = i - printed; - printed += codepoints_read; - } - } - - return printed; -} - -/* Display the LEN codepoints in STR to PORT according to STRATEGY; - return the number of codepoints successfully displayed. If NARROW_P, - then STR is interpreted as a sequence of `char', denoting a Latin-1 - string; otherwise it's interpreted as a sequence of - `scm_t_wchar'. */ -static size_t -display_string (const void *str, int narrow_p, - size_t len, SCM port, - scm_t_string_failed_conversion_handler strategy) -{ - scm_t_port *pt; - - pt = SCM_PORT (port); - - if (scm_is_eq (pt->encoding, sym_UTF_8)) - return display_string_as_utf8 (str, narrow_p, len, port); - else if (scm_is_eq (pt->encoding, sym_ISO_8859_1)) - return display_string_as_latin1 (str, narrow_p, len, port, strategy); - else - return display_string_using_iconv (str, narrow_p, len, port, strategy); -} - -/* Attempt to display CH to PORT according to STRATEGY. Return one if - CH was successfully displayed, zero otherwise (e.g., if it was not - representable in PORT's encoding.) */ -static int -display_character (scm_t_wchar ch, SCM port, - scm_t_string_failed_conversion_handler strategy) -{ - return display_string (&ch, 0, 1, port, strategy) == 1; -} - -/* Same as 'display_string', but using the 'write' syntax. */ -static size_t -write_string (const void *str, int narrow_p, - size_t len, SCM port, - scm_t_string_failed_conversion_handler strategy) -{ - size_t printed; - - printed = display_character ('"', port, strategy); - - if (printed > 0) - { - size_t i; - - for (i = 0; i < len; ++i) - { - write_character (STR_REF (str, i), port, 1); - printed++; - } - - printed += display_character ('"', port, strategy); - } - - return printed; -} - -#undef STR_REF - -/* Attempt to pretty-print CH, a combining character, to PORT. Return - zero upon failure, non-zero otherwise. The idea is to print CH above - a dotted circle to make it more visible. */ -static int -write_combining_character (scm_t_wchar ch, SCM port) -{ - scm_t_wchar str[2]; - - str[0] = SCM_CODEPOINT_DOTTED_CIRCLE; - str[1] = ch; - - return display_string (str, 0, 2, port, iconveh_error) == 2; -} - -/* Write CH to PORT in its escaped form, using the string escape syntax - if STRING_ESCAPES_P is non-zero. */ static void -write_character_escaped (scm_t_wchar ch, int string_escapes_p, SCM port) +write_string (const void *str, int narrow_p, size_t len, SCM port) { - if (string_escapes_p) + size_t i; + + scm_c_put_char (port, (scm_t_uint8) '"'); + + for (i = 0; i < len; ++i) { - /* Represent CH using the in-string escape syntax. */ - - static const char hex[] = "0123456789abcdef"; - static const char escapes[7] = "abtnvfr"; - char buf[9]; - - if (ch >= 0x07 && ch <= 0x0D && ch != 0x0A) - { - /* Use special escapes for some C0 controls. */ - buf[0] = '\\'; - buf[1] = escapes[ch - 0x07]; - scm_lfwrite (buf, 2, port); - } - else if (!SCM_R6RS_ESCAPES_P) - { - if (ch <= 0xFF) - { - buf[0] = '\\'; - buf[1] = 'x'; - buf[2] = hex[ch / 16]; - buf[3] = hex[ch % 16]; - scm_lfwrite (buf, 4, port); - } - else if (ch <= 0xFFFF) - { - buf[0] = '\\'; - buf[1] = 'u'; - buf[2] = hex[(ch & 0xF000) >> 12]; - buf[3] = hex[(ch & 0xF00) >> 8]; - buf[4] = hex[(ch & 0xF0) >> 4]; - buf[5] = hex[(ch & 0xF)]; - scm_lfwrite (buf, 6, port); - } - else if (ch > 0xFFFF) - { - buf[0] = '\\'; - buf[1] = 'U'; - buf[2] = hex[(ch & 0xF00000) >> 20]; - buf[3] = hex[(ch & 0xF0000) >> 16]; - buf[4] = hex[(ch & 0xF000) >> 12]; - buf[5] = hex[(ch & 0xF00) >> 8]; - buf[6] = hex[(ch & 0xF0) >> 4]; - buf[7] = hex[(ch & 0xF)]; - scm_lfwrite (buf, 8, port); - } - } + scm_t_wchar ch; + if (narrow_p) + ch = (scm_t_wchar) ((unsigned char *) (str))[i]; else - { - /* Print an R6RS variable-length hex escape: "\xNNNN;". */ - scm_t_wchar ch2 = ch; + ch = ((scm_t_wchar *) (str))[i]; - int i = 8; - buf[i] = ';'; - i --; - if (ch == 0) - buf[i--] = '0'; - else - while (ch2 > 0) - { - buf[i] = hex[ch2 & 0xF]; - ch2 >>= 4; - i --; - } - buf[i] = 'x'; - i --; - buf[i] = '\\'; - scm_lfwrite (buf + i, 9 - i, port); - } + /* Write CH to PORT, escaping it if it's non-graphic or not + representable in PORT's encoding. If CH needs to be escaped, + it is escaped using the in-string escape syntax. */ + if (ch == '"') + scm_c_put_latin1_chars (port, (const scm_t_uint8 *) "\\\"", 2); + else if (ch == '\\') + scm_c_put_latin1_chars (port, (const scm_t_uint8 *) "\\\\", 2); + else if (ch == '\n' && SCM_PRINT_ESCAPE_NEWLINES_P) + scm_c_put_latin1_chars (port, (const scm_t_uint8 *) "\\n", 2); + else if (ch == ' ' || ch == '\n' + || (uc_is_general_category_withtable (ch, + UC_CATEGORY_MASK_L | + UC_CATEGORY_MASK_M | + UC_CATEGORY_MASK_N | + UC_CATEGORY_MASK_P | + UC_CATEGORY_MASK_S) + && scm_c_can_put_char (port, ch))) + scm_c_put_char (port, ch); + else + scm_c_put_escaped_char (port, ch); } + + scm_c_put_char (port, (scm_t_uint8) '"'); +} + +/* Write CH to PORT, escaping it if it's non-graphic or not + representable in PORT's encoding. The character escape syntax is + used. */ +static void +write_character (scm_t_wchar ch, SCM port) +{ + scm_puts ("#\\", port); + + /* Pretty-print a combining characters over dotted circles, if + possible, to make them more visible. */ + if (uc_combining_class (ch) != UC_CCC_NR + && scm_c_can_put_char (port, SCM_CODEPOINT_DOTTED_CIRCLE) + && scm_c_can_put_char (port, ch)) + { + scm_c_put_char (port, SCM_CODEPOINT_DOTTED_CIRCLE); + scm_c_put_char (port, ch); + } + else if (uc_is_general_category_withtable (ch, + UC_CATEGORY_MASK_L | + UC_CATEGORY_MASK_M | + UC_CATEGORY_MASK_N | + UC_CATEGORY_MASK_P | + UC_CATEGORY_MASK_S) + && scm_c_can_put_char (port, ch)) + /* CH is graphic and encodeable; display it. */ + scm_c_put_char (port, ch); else + /* CH isn't graphic or cannot be represented in PORT's encoding. */ { /* Represent CH using the character escape syntax. */ const char *name; name = scm_i_charname (SCM_MAKE_CHAR (ch)); if (name != NULL) - scm_puts (name, port); + scm_puts (name, port); + else if (!SCM_R6RS_ESCAPES_P) + scm_intprint (ch, 8, port); else - PRINT_CHAR_ESCAPE (ch, port); - } -} - -/* Write CH to PORT, escaping it if it's non-graphic or not - representable in PORT's encoding. If STRING_ESCAPES_P is true and CH - needs to be escaped, it is escaped using the in-string escape syntax; - otherwise the character escape syntax is used. */ -static void -write_character (scm_t_wchar ch, SCM port, int string_escapes_p) -{ - int printed = 0; - scm_t_string_failed_conversion_handler strategy; - - strategy = PORT_CONVERSION_HANDLER (port); - - if (string_escapes_p) - { - /* Check if CH deserves special treatment. */ - if (ch == '"' || ch == '\\') - { - display_character ('\\', port, iconveh_question_mark); - display_character (ch, port, strategy); - printed = 1; - } - else if (ch == '\n' && SCM_PRINT_ESCAPE_NEWLINES_P) { - display_character ('\\', port, iconveh_question_mark); - display_character ('n', port, strategy); - printed = 1; + scm_puts ("x", port); + scm_intprint (ch, 16, port); } - else if (ch == ' ' || ch == '\n') - { - display_character (ch, port, strategy); - printed = 1; - } } - else - { - display_string ("#\\", 1, 2, port, iconveh_question_mark); - - if (uc_combining_class (ch) != UC_CCC_NR) - /* Character is a combining character, so attempt to - pretty-print it. */ - printed = write_combining_character (ch, port); - } - - if (!printed - && uc_is_general_category_withtable (ch, - UC_CATEGORY_MASK_L | - UC_CATEGORY_MASK_M | - UC_CATEGORY_MASK_N | - UC_CATEGORY_MASK_P | - UC_CATEGORY_MASK_S)) - /* CH is graphic; attempt to display it. */ - printed = display_character (ch, port, iconveh_error); - - if (!printed) - /* CH isn't graphic or cannot be represented in PORT's encoding. */ - write_character_escaped (ch, string_escapes_p, port); -} - -/* Display STR to PORT from START inclusive to END exclusive. */ -void -scm_i_display_substring (SCM str, size_t start, size_t end, SCM port) -{ - int narrow_p; - const char *buf; - size_t len, printed; - - buf = scm_i_string_data (str); - len = end - start; - narrow_p = scm_i_is_narrow_string (str); - buf += start * (narrow_p ? sizeof (char) : sizeof (scm_t_wchar)); - - printed = display_string (buf, narrow_p, end - start, port, - PORT_CONVERSION_HANDLER (port)); - - if (SCM_UNLIKELY (printed < len)) - scm_encoding_error (__func__, errno, - "cannot convert to output locale", - port, scm_c_string_ref (str, printed + start)); } @@ -1655,16 +1207,13 @@ SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0, { if (SCM_UNBNDP (port)) port = scm_current_output_port (); + else + port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_CHAR (1, chr); - SCM_VALIDATE_OPORT_VALUE (2, port); + SCM_VALIDATE_OPOUTPORT (2, port); - port = SCM_COERCE_OUTPORT (port); - if (!display_character (SCM_CHAR (chr), port, - PORT_CONVERSION_HANDLER (port))) - scm_encoding_error (__func__, errno, - "cannot convert to output locale", - port, chr); + scm_c_put_char (port, SCM_CHAR (chr)); return SCM_UNSPECIFIED; } diff --git a/libguile/print.h b/libguile/print.h index 80a9922f2..14318c031 100644 --- a/libguile/print.h +++ b/libguile/print.h @@ -79,8 +79,6 @@ SCM_API SCM scm_print_options (SCM setting); SCM_API SCM scm_make_print_state (void); SCM_API void scm_free_print_state (SCM print_state); SCM_INTERNAL SCM scm_i_port_with_print_state (SCM port, SCM print_state); -SCM_INTERNAL void scm_i_display_substring (SCM str, size_t start, size_t end, - SCM port); SCM_API void scm_intprint (scm_t_intmax n, int radix, SCM port); SCM_API void scm_uintprint (scm_t_uintmax n, int radix, SCM port); SCM_API void scm_ipruk (char *hdr, SCM ptr, SCM port); From 5bec3261b469a4fb735e096025e8953ea8c72c8c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Jun 2016 11:44:34 +0200 Subject: [PATCH 359/865] Rework text encoding to be more Scheme-friendly * libguile/ports.c (scm_port_clear_stream_start_for_bom_write): Instead of returning the BOM, take an optional buffer in which to write the BOM. Return number of bytes written. (port_clear_stream_start_for_bom_write): Remove. (scm_i_write): Adapt scm_port_clear_stream_start_for_bom_write call. (try_encode_char_to_iconv_buf, encode_latin1_chars_to_latin1_buf): (encode_latin1_chars_to_utf8_buf, encode_latin1_chars_to_iconv_buf): (encode_latin1_chars, encode_utf32_chars_to_latin1_buf): (encode_utf32_chars_to_utf8_buf, encode_utf32_chars_to_iconv_buf): (encode_utf32_chars, port_encode_chars): New helpers. (scm_port_encode_chars): New procedure. (scm_c_put_latin1_chars, scm_c_put_utf32_chars): Rework to use new encoding helpers. (scm_lfwrite): Use scm_c_put_latin1_chars. --- libguile/ports.c | 599 ++++++++++++++++++++++++----------------------- 1 file changed, 302 insertions(+), 297 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 5d518e868..0020bf6f4 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1497,7 +1497,6 @@ scm_i_read_bytes (SCM port, SCM dst, size_t start, size_t count) caller. */ enum bom_io_mode { BOM_IO_TEXT, BOM_IO_BINARY }; static size_t port_clear_stream_start_for_bom_read (SCM, enum bom_io_mode); -static void port_clear_stream_start_for_bom_write (SCM, enum bom_io_mode); /* Used by an application to read arbitrary number of bytes from an SCM port. Same semantics as libc read, except that scm_c_read_bytes only @@ -2455,10 +2454,10 @@ SCM_DEFINE (scm_port_clear_stream_start_for_bom_read, } #undef FUNC_NAME -SCM_INTERNAL SCM scm_port_clear_stream_start_for_bom_write (SCM port); +SCM_INTERNAL SCM scm_port_clear_stream_start_for_bom_write (SCM, SCM); SCM_DEFINE (scm_port_clear_stream_start_for_bom_write, - "port-clear-stream-start-for-bom-write", 1, 0, 0, - (SCM port), + "port-clear-stream-start-for-bom-write", 1, 1, 0, + (SCM port, SCM buf), "") #define FUNC_NAME s_scm_port_clear_stream_start_for_bom_write { @@ -2468,65 +2467,57 @@ SCM_DEFINE (scm_port_clear_stream_start_for_bom_write, pt = SCM_PORT (port); if (!pt->at_stream_start_for_bom_write) - return SCM_BOOL_F; + return SCM_INUM0; pt->at_stream_start_for_bom_write = 0; if (pt->rw_random) pt->at_stream_start_for_bom_read = 0; - /* Record that we're no longer at stream start. */ - pt->at_stream_start_for_bom_write = 0; - if (pt->rw_random) - pt->at_stream_start_for_bom_read = 0; + if (SCM_UNBNDP (buf)) + return SCM_INUM0; - /* Return a BOM if appropriate. */ + /* Write a BOM if appropriate. */ if (scm_is_eq (pt->encoding, sym_UTF_16)) { SCM precise_encoding; - SCM bom = scm_c_make_bytevector (sizeof (scm_utf16be_bom)); + size_t ret; + scm_port_acquire_iconv_descriptors (port, NULL, NULL); precise_encoding = pt->precise_encoding; scm_port_release_iconv_descriptors (port); - memcpy (SCM_BYTEVECTOR_CONTENTS (bom), - scm_is_eq (precise_encoding, sym_UTF_16LE) - ? scm_utf16le_bom : scm_utf16be_bom, - SCM_BYTEVECTOR_LENGTH (bom)); - return bom; + + if (scm_is_eq (precise_encoding, sym_UTF_16LE)) + ret = scm_port_buffer_put (buf, scm_utf16le_bom, + sizeof (scm_utf16le_bom)); + else + ret = scm_port_buffer_put (buf, scm_utf16be_bom, + sizeof (scm_utf16be_bom)); + + return scm_from_size_t (ret); } else if (scm_is_eq (pt->encoding, sym_UTF_32)) { SCM precise_encoding; - SCM bom = scm_c_make_bytevector (sizeof (scm_utf32be_bom)); + size_t ret; + scm_port_acquire_iconv_descriptors (port, NULL, NULL); precise_encoding = pt->precise_encoding; scm_port_release_iconv_descriptors (port); - memcpy (SCM_BYTEVECTOR_CONTENTS (bom), - scm_is_eq (precise_encoding, sym_UTF_32LE) - ? scm_utf32le_bom : scm_utf32be_bom, - SCM_BYTEVECTOR_LENGTH (bom)); - return bom; + + if (scm_is_eq (precise_encoding, sym_UTF_32LE)) + ret = scm_port_buffer_put (buf, scm_utf32le_bom, + sizeof (scm_utf32le_bom)); + else + ret = scm_port_buffer_put (buf, scm_utf32be_bom, + sizeof (scm_utf32be_bom)); + + return scm_from_size_t (ret); } - return SCM_BOOL_F; + return SCM_INUM0; } #undef FUNC_NAME -static void -port_clear_stream_start_for_bom_write (SCM port, enum bom_io_mode io_mode) -{ - scm_t_port *pt = SCM_PORT (port); - SCM bom; - - /* Fast path. */ - if (!pt->at_stream_start_for_bom_write) - return; - - bom = scm_port_clear_stream_start_for_bom_write (port); - - if (io_mode == BOM_IO_TEXT && scm_is_true (bom)) - scm_c_write_bytes (port, bom, 0, SCM_BYTEVECTOR_LENGTH (bom)); -} - SCM scm_fill_input (SCM port, size_t minimum_size) { @@ -2752,10 +2743,7 @@ scm_i_write (SCM port, SCM buf) { size_t start, count; - /* The default is BOM_IO_TEXT. Binary output procedures should - port_clear_stream_start_for_bom_write with BOM_IO_BINARY before - filling the input buffers. */ - port_clear_stream_start_for_bom_write (port, BOM_IO_TEXT); + scm_port_clear_stream_start_for_bom_write (port, SCM_UNDEFINED); /* Update cursors before attempting to write, assuming that I/O errors are sticky. That way if the write throws an error, causing the @@ -2982,257 +2970,294 @@ codepoint_to_utf8 (scm_t_uint32 codepoint, scm_t_uint8 utf8[UTF8_BUFFER_SIZE]) return len; } -/* We writing, we always iconv from UTF-8. Also in this function we - only see complete codepoints. */ -static void -put_utf8_chars_to_iconv_port (SCM port, const scm_t_uint8 *buf, size_t len) +static size_t +try_encode_char_to_iconv_buf (SCM port, SCM buf, scm_t_uint32 ch) { - SCM bv = scm_port_buffer_bytevector (scm_port_auxiliary_write_buffer (port)); - scm_t_uint8 *aux = (scm_t_uint8*) SCM_BYTEVECTOR_CONTENTS (bv); - size_t aux_len = SCM_BYTEVECTOR_LENGTH (bv); + scm_t_uint8 utf8[UTF8_BUFFER_SIZE]; + size_t utf8_len = codepoint_to_utf8 (ch, utf8); + scm_t_uint8 *aux = scm_port_buffer_put_pointer (buf); + size_t can_put = scm_port_buffer_can_put (buf); iconv_t output_cd; - scm_t_wchar bad_codepoint; int saved_errno; - while (len) + char *input = (char *) utf8; + size_t input_left = utf8_len; + char *output = (char *) aux; + size_t output_left = can_put; + size_t res; + + scm_port_acquire_iconv_descriptors (port, NULL, &output_cd); + res = iconv (output_cd, &input, &input_left, &output, &output_left); + saved_errno = errno; + /* Emit bytes needed to get back to initial state, if needed. */ + iconv (output_cd, NULL, NULL, &output, &output_left); + scm_port_release_iconv_descriptors (port); + + if (res != (size_t) -1) { - char *input, *output; - size_t done, input_left, output_left; + /* Success. */ + scm_port_buffer_did_put (buf, can_put - output_left); + return 1; + } - input = (char *) buf; - input_left = len; - output = (char *) aux; - output_left = aux_len; + if (saved_errno == E2BIG) + /* No space to encode the character; try again next time. */ + return 0; + /* Otherwise, re-set the output buffer and try to escape or substitute + the character, as appropriate. */ + output = (char *) aux; + output_left = can_put; + + /* The source buffer is valid UTF-8, so we shouldn't get EILSEQ + because of the input encoding; if we get EILSEQ, that means the + codepoint is not accessible in the target encoding. We have whole + codepoints in the source buffer, so we shouldn't get EINVAL. We + already handled E2BIG. The descriptor should be valid so we + shouldn't get EBADF. In summary, we only need to handle EILSEQ. */ + + if (scm_is_eq (SCM_PORT (port)->conversion_strategy, sym_escape)) + { + scm_t_uint8 escape[ESCAPE_BUFFER_SIZE]; + input = (char *) escape; + input_left = encode_escape_sequence (ch, escape); scm_port_acquire_iconv_descriptors (port, NULL, &output_cd); - done = iconv (output_cd, &input, &input_left, &output, &output_left); + res = iconv (output_cd, &input, &input_left, &output, &output_left); saved_errno = errno; - /* Emit bytes needed to get back to initial state, if needed. */ - if (done != (size_t) -1) - iconv (output_cd, NULL, NULL, &output, &output_left); + iconv (output_cd, NULL, NULL, &output, &output_left); scm_port_release_iconv_descriptors (port); - - buf += (len - input_left); - len -= (len - input_left); - scm_c_write_bytes (port, bv, 0, aux_len - output_left); - - if (done == (size_t) -1) - { - scm_t_port *pt = SCM_PORT (port); - - /* The source buffer is valid UTF-8, so we shouldn't get - EILSEQ because of the input encoding; if we get EILSEQ, - that means the codepoint is not accessible in the target - encoding. We have whole codepoints in the source buffer, - so we shouldn't get EINVAL. We can get E2BIG, meaning we - just need to process the next chunk. The descriptor should - be valid so we shouldn't get EBADF. In summary, we should - only do E2BIG and EILSEQ. */ - - if (saved_errno == E2BIG) - continue; - - bad_codepoint = utf8_to_codepoint (buf, len); - - if (saved_errno != EILSEQ) - goto error; - - /* Advance the input past the utf8 sequence. */ - { - size_t advance = codepoint_to_utf8 (bad_codepoint, aux); - buf += advance; - len -= advance; - } - - /* Convert substitutes or escapes into the aux buf. */ - output = (char *) aux; - output_left = aux_len; - - /* Substitute or escape. Note that this re-sets "done", - "saved_errno", "output", and "output_left". */ - if (scm_is_eq (pt->conversion_strategy, sym_escape)) - { - scm_t_uint8 escape[ESCAPE_BUFFER_SIZE]; - input = (char *) escape; - input_left = encode_escape_sequence (bad_codepoint, escape); - scm_port_acquire_iconv_descriptors (port, NULL, &output_cd); - done = iconv (output_cd, &input, &input_left, &output, &output_left); - saved_errno = errno; - scm_port_release_iconv_descriptors (port); - } - else if (scm_is_eq (pt->conversion_strategy, sym_substitute)) - { - scm_t_uint8 substitute[2] = "?"; - input = (char *) substitute; - input_left = 1; - scm_port_acquire_iconv_descriptors (port, NULL, &output_cd); - done = iconv (output_cd, &input, &input_left, &output, &output_left); - saved_errno = errno; - scm_port_release_iconv_descriptors (port); - } - - /* This catches both the "error" conversion strategy case, and - any error while substituting or escaping the character. */ - if (done == (size_t) -1) - goto error; - - /* The substitution or escape succeeded; print it. */ - scm_c_write_bytes (port, bv, 0, aux_len - output_left); - } } - - return; - - error: - scm_encoding_error ("put-char", saved_errno, - "conversion to port encoding failed", - port, SCM_MAKE_CHAR (bad_codepoint)); -} - -static void -put_latin1_chars_to_utf8_port (SCM port, const scm_t_uint8 *buf, size_t len) -{ - SCM bv = scm_port_buffer_bytevector (scm_port_auxiliary_write_buffer (port)); - scm_t_uint8 *utf8 = (scm_t_uint8*) SCM_BYTEVECTOR_CONTENTS (bv); - size_t utf8_len = SCM_BYTEVECTOR_LENGTH (bv); - - while (len) + else if (scm_is_eq (SCM_PORT (port)->conversion_strategy, sym_substitute)) { - size_t read, written; - for (read = 0, written = 0; - read < len && written + UTF8_BUFFER_SIZE < utf8_len; - read++) - written += codepoint_to_utf8 (buf[read], utf8 + written); - - buf += read; - len -= read; - scm_c_write_bytes (port, bv, 0, written); + scm_t_uint8 substitute[2] = "?"; + input = (char *) substitute; + input_left = 1; + scm_port_acquire_iconv_descriptors (port, NULL, &output_cd); + res = iconv (output_cd, &input, &input_left, &output, &output_left); + saved_errno = errno; + iconv (output_cd, NULL, NULL, &output, &output_left); + scm_port_release_iconv_descriptors (port); } -} -static void -put_latin1_chars_to_iconv_port (SCM port, const scm_t_uint8 *buf, size_t len) -{ - scm_t_uint8 utf8[AUXILIARY_WRITE_BUFFER_SIZE]; - size_t utf8_len = AUXILIARY_WRITE_BUFFER_SIZE; - - /* Convert through UTF-8, as most non-GNU iconvs can only convert - between a limited number of encodings. */ - while (len) + if (res != (size_t) -1) { - size_t read, written; - for (read = 0, written = 0; - read < len && written + UTF8_BUFFER_SIZE < utf8_len; - read++) - written += codepoint_to_utf8 (buf[read], utf8 + written); - - buf += read; - len -= read; - put_utf8_chars_to_iconv_port (port, utf8, written); + scm_port_buffer_did_put (buf, can_put - output_left); + return 1; } + + /* No space to write the substitution or escape, or maybe there was an + error. If there are buffered bytes, the caller should flush and + try again; otherwise the caller should raise an error. */ + return 0; } -static void -put_utf32_chars_to_latin1_port (SCM port, const scm_t_uint32 *buf, size_t len) +static size_t +encode_latin1_chars_to_latin1_buf (SCM port, SCM buf, + const scm_t_uint8 *chars, size_t count) { - SCM bv = scm_port_buffer_bytevector (scm_port_auxiliary_write_buffer (port)); - scm_t_uint8 *latin1 = (scm_t_uint8*) SCM_BYTEVECTOR_CONTENTS (bv); - size_t latin1_len = SCM_BYTEVECTOR_LENGTH (bv); - - while (len) - { - size_t read = 0, written = 0; - while (read < len && written + ESCAPE_BUFFER_SIZE <= latin1_len) - { - scm_t_port *pt = SCM_PORT (port); - scm_t_uint32 ch = buf[read++]; - if (ch <= 0xff) - latin1[written++] = ch; - else if (scm_is_eq (pt->conversion_strategy, sym_substitute)) - latin1[written++] = '?'; - else if (scm_is_eq (pt->conversion_strategy, sym_escape)) - written += encode_escape_sequence (ch, latin1 + written); - else - { - scm_c_write_bytes (port, bv, 0, written); - scm_encoding_error ("put-char", EILSEQ, - "conversion to port encoding failed", - port, SCM_MAKE_CHAR (ch)); - } - } - - buf += read; - len -= read; - scm_c_write_bytes (port, bv, 0, written); - } + return scm_port_buffer_put (buf, chars, count); } -static void -put_utf32_chars_to_utf8_port (SCM port, const scm_t_uint32 *buf, size_t len) +static size_t +encode_latin1_chars_to_utf8_buf (SCM port, SCM buf, const scm_t_uint8 *chars, + size_t count) { - SCM bv = scm_port_buffer_bytevector (scm_port_auxiliary_write_buffer (port)); - scm_t_uint8 *utf8 = (scm_t_uint8*) SCM_BYTEVECTOR_CONTENTS (bv); - size_t utf8_len = SCM_BYTEVECTOR_LENGTH (bv); - - while (len) - { - size_t read, written; - for (read = 0, written = 0; - read < len && written + UTF8_BUFFER_SIZE < utf8_len; - read++) - written += codepoint_to_utf8 (buf[read], utf8 + written); - - buf += read; - len -= read; - scm_c_write_bytes (port, bv, 0, written); - } + scm_t_uint8 *dst = scm_port_buffer_put_pointer (buf); + size_t buf_size = scm_port_buffer_can_put (buf); + size_t read, written; + for (read = 0, written = 0; + read < count && written + UTF8_BUFFER_SIZE < buf_size; + read++) + written += codepoint_to_utf8 (chars[read], dst + written); + scm_port_buffer_did_put (buf, written); + return read; } -static void -put_utf32_chars_to_iconv_port (SCM port, const scm_t_uint32 *buf, size_t len) +static size_t +encode_latin1_chars_to_iconv_buf (SCM port, SCM buf, const scm_t_uint8 *chars, + size_t count) { - scm_t_uint8 utf8[AUXILIARY_WRITE_BUFFER_SIZE]; - size_t utf8_len = AUXILIARY_WRITE_BUFFER_SIZE; - - /* Convert through UTF-8, as most non-GNU iconvs can only convert - between a limited number of encodings. */ - while (len) - { - size_t read, written; - for (read = 0, written = 0; - read < len && written + UTF8_BUFFER_SIZE < utf8_len; - read++) - written += codepoint_to_utf8 (buf[read], utf8 + written); - - buf += read; - len -= read; - put_utf8_chars_to_iconv_port (port, utf8, written); - } + size_t read; + for (read = 0; read < count; read++) + if (!try_encode_char_to_iconv_buf (port, buf, chars[read])) + break; + return read; } -void -scm_c_put_latin1_chars (SCM port, const scm_t_uint8 *buf, size_t len) +static size_t +encode_latin1_chars (SCM port, SCM buf, const scm_t_uint8 *chars, size_t count) { scm_t_port *pt = SCM_PORT (port); - SCM position, saved_line; - size_t i; - - if (len == 0) - return; - - port_clear_stream_start_for_bom_write (port, BOM_IO_TEXT); + SCM position; + size_t ret, i; if (scm_is_eq (pt->encoding, sym_ISO_8859_1)) - scm_c_write (port, buf, len); + ret = encode_latin1_chars_to_latin1_buf (port, buf, chars, count); else if (scm_is_eq (pt->encoding, sym_UTF_8)) - put_latin1_chars_to_utf8_port (port, buf, len); + ret = encode_latin1_chars_to_utf8_buf (port, buf, chars, count); else - put_latin1_chars_to_iconv_port (port, buf, len); + ret = encode_latin1_chars_to_iconv_buf (port, buf, chars, count); + + if (ret == 0 && count > 0) + scm_encoding_error ("put-char", EILSEQ, + "conversion to port encoding failed", + port, SCM_MAKE_CHAR (chars[0])); position = pt->position; - saved_line = scm_port_position_line (position); - for (i = 0; i < len; i++) - update_port_position (position, buf[i]); + for (i = 0; i < ret; i++) + update_port_position (position, chars[i]); + + return ret; +} + +static size_t +encode_utf32_chars_to_latin1_buf (SCM port, SCM buf, + const scm_t_uint32 *chars, size_t count) +{ + scm_t_port *pt = SCM_PORT (port); + scm_t_uint8 *dst = scm_port_buffer_put_pointer (buf); + size_t buf_size = scm_port_buffer_can_put (buf); + size_t read, written; + for (read = 0, written = 0; read < count && written < buf_size; read++) + { + scm_t_uint32 ch = chars[read]; + if (ch <= 0xff) + dst[written++] = ch; + else if (scm_is_eq (pt->conversion_strategy, sym_substitute)) + dst[written++] = '?'; + else if (scm_is_eq (pt->conversion_strategy, sym_escape)) + { + scm_t_uint8 escape[ESCAPE_BUFFER_SIZE]; + size_t escape_len = encode_escape_sequence (ch, escape); + if (escape_len > buf_size - written) + break; + memcpy (dst + written, escape, escape_len); + written += escape_len; + } + else + break; + } + scm_port_buffer_did_put (buf, written); + return read; +} + +static size_t +encode_utf32_chars_to_utf8_buf (SCM port, SCM buf, const scm_t_uint32 *chars, + size_t count) +{ + scm_t_uint8 *dst = scm_port_buffer_put_pointer (buf); + size_t buf_size = scm_port_buffer_can_put (buf); + size_t read, written; + for (read = 0, written = 0; + read < count && written + UTF8_BUFFER_SIZE < buf_size; + read++) + written += codepoint_to_utf8 (chars[read], dst + written); + scm_port_buffer_did_put (buf, written); + return read; +} + +static size_t +encode_utf32_chars_to_iconv_buf (SCM port, SCM buf, const scm_t_uint32 *chars, + size_t count) +{ + size_t read; + for (read = 0; read < count; read++) + if (!try_encode_char_to_iconv_buf (port, buf, chars[read])) + break; + return read; +} + +static size_t +encode_utf32_chars (SCM port, SCM buf, const scm_t_uint32 *chars, size_t count) +{ + scm_t_port *pt = SCM_PORT (port); + SCM position; + size_t ret, i; + + if (scm_is_eq (pt->encoding, sym_ISO_8859_1)) + ret = encode_utf32_chars_to_latin1_buf (port, buf, chars, count); + else if (scm_is_eq (pt->encoding, sym_UTF_8)) + ret = encode_utf32_chars_to_utf8_buf (port, buf, chars, count); + else + ret = encode_utf32_chars_to_iconv_buf (port, buf, chars, count); + + if (ret == 0 && count > 0) + scm_encoding_error ("put-char", EILSEQ, + "conversion to port encoding failed", + port, SCM_MAKE_CHAR (chars[0])); + + position = pt->position; + for (i = 0; i < ret; i++) + update_port_position (position, chars[i]); + + return ret; +} + +static size_t +port_encode_chars (SCM port, SCM buf, SCM str, size_t start, size_t count) +{ + if (count == 0) + return 0; + + if (scm_i_is_narrow_string (str)) + { + const char *chars = scm_i_string_chars (str); + return encode_latin1_chars (port, buf, + ((const scm_t_uint8 *) chars) + start, + count); + } + else + { + const scm_t_wchar *chars = scm_i_string_wide_chars (str); + return encode_utf32_chars (port, buf, + ((const scm_t_uint32 *) chars) + start, + count); + } +} + +SCM scm_port_encode_chars (SCM, SCM, SCM, SCM, SCM); +SCM_DEFINE (scm_port_encode_chars, "port-encode-chars", 5, 0, 0, + (SCM port, SCM buf, SCM str, SCM start, SCM count), + "") +#define FUNC_NAME s_scm_port_encode_chars +{ + size_t c_start, c_count, c_len, encoded; + + SCM_VALIDATE_OPOUTPORT (1, port); + SCM_VALIDATE_VECTOR (2, buf); + SCM_VALIDATE_STRING (3, str); + c_len = scm_i_string_length (str); + SCM_VALIDATE_SIZE_COPY (4, start, c_start); + SCM_ASSERT_RANGE (4, start, c_start <= c_len); + SCM_VALIDATE_SIZE_COPY (5, count, c_count); + SCM_ASSERT_RANGE (5, count, c_count <= c_len - c_start); + + encoded = port_encode_chars (port, buf, str, c_start, c_count); + + return scm_from_size_t (encoded); +} +#undef FUNC_NAME + +void +scm_c_put_latin1_chars (SCM port, const scm_t_uint8 *chars, size_t len) +{ + SCM aux_buf = scm_port_auxiliary_write_buffer (port); + SCM aux_bv = scm_port_buffer_bytevector (aux_buf); + SCM position = SCM_PORT (port)->position; + SCM saved_line = scm_port_position_line (position); + + scm_port_clear_stream_start_for_bom_write (port, aux_buf); + + while (len) + { + size_t encoded = encode_latin1_chars (port, aux_buf, chars, len); + assert(encoded <= len); + scm_c_write_bytes (port, aux_bv, 0, + scm_to_size_t (scm_port_buffer_end (aux_buf))); + scm_port_buffer_reset (aux_buf); + chars += encoded; + len -= encoded; + } /* Handle line buffering. */ if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && @@ -3241,28 +3266,25 @@ scm_c_put_latin1_chars (SCM port, const scm_t_uint8 *buf, size_t len) } void -scm_c_put_utf32_chars (SCM port, const scm_t_uint32 *buf, size_t len) +scm_c_put_utf32_chars (SCM port, const scm_t_uint32 *chars, size_t len) { - scm_t_port *pt = SCM_PORT (port); - SCM position, saved_line; - size_t i; + SCM aux_buf = scm_port_auxiliary_write_buffer (port); + SCM aux_bv = scm_port_buffer_bytevector (aux_buf); + SCM position = SCM_PORT (port)->position; + SCM saved_line = scm_port_position_line (position); - if (len == 0) - return; + scm_port_clear_stream_start_for_bom_write (port, aux_buf); - port_clear_stream_start_for_bom_write (port, BOM_IO_TEXT); - - if (scm_is_eq (pt->encoding, sym_ISO_8859_1)) - put_utf32_chars_to_latin1_port (port, buf, len); - else if (scm_is_eq (pt->encoding, sym_UTF_8)) - put_utf32_chars_to_utf8_port (port, buf, len); - else - put_utf32_chars_to_iconv_port (port, buf, len); - - position = pt->position; - saved_line = scm_port_position_line (position); - for (i = 0; i < len; i++) - update_port_position (position, buf[i]); + while (len) + { + size_t encoded = encode_utf32_chars (port, aux_buf, chars, len); + assert(encoded <= len); + scm_c_write_bytes (port, aux_bv, 0, + scm_to_size_t (scm_port_buffer_end (aux_buf))); + scm_port_buffer_reset (aux_buf); + chars += encoded; + len -= encoded; + } /* Handle line buffering. */ if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && @@ -3346,7 +3368,7 @@ SCM_DEFINE (scm_put_string, "put-string", 2, 2, 0, { size_t c_start, c_count, c_len; - SCM_VALIDATE_OPINPORT (1, port); + SCM_VALIDATE_OPOUTPORT (1, port); SCM_VALIDATE_STRING (2, string); c_len = scm_i_string_length (string); c_start = SCM_UNBNDP (start) ? 0 : scm_to_size_t (start); @@ -3381,24 +3403,7 @@ scm_puts (const char *s, SCM port) void scm_lfwrite (const char *ptr, size_t size, SCM port) { - SCM position, saved_line; - - if (size == 0) - return; - - port_clear_stream_start_for_bom_write (port, BOM_IO_TEXT); - - scm_c_write (port, ptr, size); - - position = SCM_PORT (port)->position; - saved_line = scm_port_position_line (position); - for (; size; ptr++, size--) - update_port_position (position, (scm_t_wchar) (unsigned char) *ptr); - - /* Handle line buffering. */ - if ((SCM_CELL_WORD_0 (port) & SCM_BUFLINE) && - !scm_is_eq (saved_line, scm_port_position_line (position))) - scm_flush (port); + scm_c_put_latin1_chars (port, (const scm_t_uint8 *) ptr, size); } /* Write STR to PORT from START inclusive to END exclusive. */ From 9454068a54a4e9e84db61dc42d9a5d7a544a7ece Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Jun 2016 12:01:16 +0200 Subject: [PATCH 360/865] put-string in Scheme * module/ice-9/ports.scm: Export port-encode-chars and port-clear-stream-start-for-bom-write via the internals module. * module/ice-9/sports.scm (put-string): New function. --- module/ice-9/ports.scm | 4 ++++ module/ice-9/sports.scm | 22 ++++++++++++++++++++++ 2 files changed, 26 insertions(+) diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 3fc2f6465..68afed1d4 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -182,10 +182,12 @@ interpret its input and output." port-read port-write port-clear-stream-start-for-bom-read + port-clear-stream-start-for-bom-write %port-encoding specialize-port-encoding! port-random-access? port-decode-char + port-encode-chars port-read-buffering port-poll port-read-wait-fd @@ -227,9 +229,11 @@ interpret its input and output." port-read port-write port-clear-stream-start-for-bom-read + port-clear-stream-start-for-bom-write %port-encoding specialize-port-encoding! port-decode-char + port-encode-chars port-random-access? port-read-buffering port-poll diff --git a/module/ice-9/sports.scm b/module/ice-9/sports.scm index 86d9a5b06..d145d071a 100644 --- a/module/ice-9/sports.scm +++ b/module/ice-9/sports.scm @@ -64,6 +64,7 @@ get-bytevector-n put-u8 put-bytevector + put-string %read-line read-line @@ -653,6 +654,27 @@ (define* (%read-line port) (read-line port 'split)) +(define* (put-string port str #:optional (start 0) + (count (- (string-length str) start))) + (let* ((aux (port-auxiliary-write-buffer port)) + (pos (port-buffer-position aux)) + (line (port-position-line pos))) + (set-port-buffer-cur! aux 0) + (port-clear-stream-start-for-bom-write port aux) + (let lp ((encoded 0)) + (when (< encoded count) + (let ((encoded (+ encoded + (port-encode-chars port aux str + (+ start encoded) + (- count encoded))))) + (let ((end (port-buffer-end aux))) + (set-port-buffer-end! aux 0) + (put-bytevector port (port-buffer-bytevector aux) 0 end) + (lp encoded))))) + (when (and (not (eqv? line (port-position-line pos))) + (port-line-buffered? port)) + (flush-output port)))) + (define saved-port-bindings #f) (define port-bindings '(((guile) read-char peek-char force-output close-port) From d7f39a36b1fb02bd7900eaad0c2f951d6f20b2ff Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 26 Mar 2012 00:25:03 +0200 Subject: [PATCH 361/865] socket: TCP_CORK, TCP_NODELAY * libguile/socket.c (scm_init_socket): Define TCP_NODELAY and TCP_CORK if they are available. * doc/ref/posix.texi (Network Sockets and Communication): Add documentation. * NEWS: Add entry. --- NEWS | 3 +++ doc/ref/posix.texi | 9 +++++++++ libguile/socket.c | 9 +++++++++ 3 files changed, 21 insertions(+) diff --git a/NEWS b/NEWS index 8d2ec86fb..ff18b39ad 100644 --- a/NEWS +++ b/NEWS @@ -54,6 +54,9 @@ avoid the crashes that led to the introduction of locking, but without locks. For that reason we have removed port locks, and removed the "_unlocked" port API variants that were introduced in 2.1.0. +* New interfaces +** `TCP_NODELAY' and `TCP_CORK' socket options, if provided by the system + * New deprecations ** `_IONBF', `_IOLBF', and `_IOFBF' diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 53a71c138..8a8ab388e 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -3178,6 +3178,15 @@ supporting that. @end defvar @end deffn +For @code{IPPROTO_TCP} level the following @var{optname}s are defined +(when provided by the system). For their meaning see @command{man 7 +tcp}. + +@defvar TCP_NODELAY +@defvarx TCP_CORK +The @var{value} taken or returned is an integer. +@end defvar + @deffn {Scheme Procedure} shutdown sock how @deffnx {C Function} scm_shutdown (sock, how) Sockets can be closed simply by using @code{close-port}. The diff --git a/libguile/socket.c b/libguile/socket.c index a6f1e5fca..1c4f2ae36 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -40,6 +40,7 @@ #include #endif #include +#include #include #include @@ -1713,6 +1714,14 @@ scm_init_socket () scm_c_define ("MSG_DONTROUTE", scm_from_int (MSG_DONTROUTE)); #endif + /* TCP options. */ +#ifdef TCP_NODELAY + scm_c_define ("TCP_NODELAY", scm_from_int (TCP_NODELAY)); +#endif +#ifdef TCP_CORK + scm_c_define ("TCP_CORK", scm_from_int (TCP_CORK)); +#endif + #ifdef IP_ADD_MEMBERSHIP scm_c_define ("IP_ADD_MEMBERSHIP", scm_from_int (IP_ADD_MEMBERSHIP)); scm_c_define ("IP_DROP_MEMBERSHIP", scm_from_int (IP_DROP_MEMBERSHIP)); From 4bceba876ba10029cff0c6903418b1bdcc9067c0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 8 Jun 2016 07:42:29 +0200 Subject: [PATCH 362/865] put-char, put-string in (ice-9 ports internals) * libguile/ports.h (scm_put_char): * libguile/ports.c (scm_put_char): New function. (scm_put_string): Add docstrings, and expose to the internal ports module. * module/ice-9/ports.scm (put-char, put-string): Expose these bindings only through the internals module. --- libguile/ports.c | 22 +++++++++++++++++++++- libguile/ports.h | 1 + module/ice-9/ports.scm | 8 ++++++-- 3 files changed, 28 insertions(+), 3 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 0020bf6f4..a464aaf56 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -3361,9 +3361,29 @@ scm_c_put_string (SCM port, SCM string, size_t start, size_t count) } } +SCM_DEFINE (scm_put_char, "put-char", 2, 0, 0, (SCM port, SCM ch), + "Encode @var{ch} to bytes, and send those bytes to @var{port}.") +#define FUNC_NAME s_scm_put_char +{ + SCM_VALIDATE_OPOUTPORT (1, port); + SCM_VALIDATE_CHAR (2, ch); + + scm_c_put_char (port, SCM_CHAR (ch)); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + SCM_DEFINE (scm_put_string, "put-string", 2, 2, 0, (SCM port, SCM string, SCM start, SCM count), - "") + "Display the @var{count} characters from @var{string} to\n" + "@var{port}, starting with the character at index @var{start}.\n" + "@var{start} defaults to 0, and @var{count} defaults to\n" + "displaying all characters until the end of the string.\n\n" + "Calling @code{put-string} is equivalent in all respects to\n" + "calling @code{put-char} on the relevant sequence of characters,\n" + "except that it will attempt to write multiple characters to\n" + "the port at a time, even if the port is unbuffered.") #define FUNC_NAME s_scm_put_string { size_t c_start, c_count, c_len; diff --git a/libguile/ports.h b/libguile/ports.h index f8d62c119..66b24715d 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -220,6 +220,7 @@ SCM_API void scm_c_put_utf32_chars (SCM port, const scm_t_uint32 *buf, SCM_API void scm_c_put_string (SCM port, SCM str, size_t start, size_t count); SCM_API SCM scm_put_string (SCM port, SCM str, SCM start, SCM count); SCM_API void scm_c_put_char (SCM port, scm_t_wchar ch); +SCM_API SCM scm_put_char (SCM port, SCM ch); SCM_INTERNAL void scm_c_put_escaped_char (SCM port, scm_t_wchar ch); SCM_INTERNAL int scm_c_can_put_char (SCM port, scm_t_wchar ch); SCM_API void scm_putc (char c, SCM port); diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 68afed1d4..43a029b49 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -191,7 +191,9 @@ interpret its input and output." port-read-buffering port-poll port-read-wait-fd - port-write-wait-fd)) + port-write-wait-fd + put-char + put-string)) (define-syntax-rule (port-buffer-bytevector buf) (vector-ref buf 0)) (define-syntax-rule (port-buffer-cur buf) (vector-ref buf 1)) @@ -238,7 +240,9 @@ interpret its input and output." port-read-buffering port-poll port-read-wait-fd - port-write-wait-fd) + port-write-wait-fd + put-char + put-string) ;; And we're back. (define-module (ice-9 ports)) From 4ed9f6c29cc84763f6dc9b212e6c20ae247d3c48 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 8 Jun 2016 07:40:57 +0200 Subject: [PATCH 363/865] Add (ice-9 textual-ports) * module/ice-9/textual-ports.scm: New module. * module/Makefile.am: Add new module. --- module/Makefile.am | 1 + module/ice-9/textual-ports.scm | 57 ++++++++++++++++++++++++++++++++++ 2 files changed, 58 insertions(+) create mode 100644 module/ice-9/textual-ports.scm diff --git a/module/Makefile.am b/module/Makefile.am index 7f8284e18..06def3851 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -111,6 +111,7 @@ SOURCES = \ ice-9/streams.scm \ ice-9/string-fun.scm \ ice-9/syncase.scm \ + ice-9/textual-ports.scm \ ice-9/threads.scm \ ice-9/time.scm \ ice-9/top-repl.scm \ diff --git a/module/ice-9/textual-ports.scm b/module/ice-9/textual-ports.scm new file mode 100644 index 000000000..620d20e5a --- /dev/null +++ b/module/ice-9/textual-ports.scm @@ -0,0 +1,57 @@ +;;;; textual-ports.scm --- Textual I/O on ports + +;;;; Copyright (C) 2016 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Code: + +(define-module (ice-9 textual-ports) + #:use-module (ice-9 ports internal) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 rdelim) + #:re-export (get-string-n! + put-char + put-string) + #:export (get-char + lookahead-char + get-string-n + get-string-all + get-line)) + +(define (get-char port) + (read-char port)) + +(define (lookahead-char port) + (peek-char port)) + +(define (get-line port) + (read-line port 'trim)) + +(define (get-string-all port) + (read-string port)) + +(define (get-string-n port count) + "Read up to @var{count} characters from @var{port}. +If no characters could be read before encountering the end of file, +return the end-of-file object, otherwise return a string containing +the characters read." + (let* ((s (make-string count)) + (rv (get-string-n! port s 0 count))) + (cond ((eof-object? rv) rv) + ((= rv count) s) + (else (substring/shared s 0 rv))))) From 6eee08874bce2b650f79932e30195369670a2fdd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 8 Jun 2016 08:38:49 +0200 Subject: [PATCH 364/865] Undocument (ice-9 rw) * doc/ref/api-io.texi (Block Reading and Writing): Undocument (ice-9 rw). The R6RS routines do the same job and are not so clunky. --- doc/ref/api-io.texi | 101 -------------------------------------------- 1 file changed, 101 deletions(-) diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 313204593..5c6c213fa 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -15,7 +15,6 @@ * Buffering:: Controlling when data is written to ports. * Random Access:: Moving around a random access port. * Line/Delimited:: Read and write lines or delimited text. -* Block Reading and Writing:: Reading and writing blocks of text. * Default Ports:: Defaults for input, output and errors. * Port Types:: Types of port and how to make them. * R6RS I/O Ports:: The R6RS port API. @@ -744,106 +743,6 @@ delimiter may be either a newline or the @var{eof-object}; if @code{(# . #)}. @end deffn -@node Block Reading and Writing -@subsection Block reading and writing -@cindex Block read/write -@cindex Port, block read/write - -The Block-string-I/O module can be accessed with: - -@lisp -(use-modules (ice-9 rw)) -@end lisp - -It currently contains procedures that help to implement the -@code{(scsh rw)} module in guile-scsh. - -@deffn {Scheme Procedure} read-string!/partial str [port_or_fdes [start [end]]] -@deffnx {C Function} scm_read_string_x_partial (str, port_or_fdes, start, end) -Read characters from a port or file descriptor into a -string @var{str}. A port must have an underlying file -descriptor --- a so-called fport. This procedure is -scsh-compatible and can efficiently read large strings. -It will: - -@itemize -@item -attempt to fill the entire string, unless the @var{start} -and/or @var{end} arguments are supplied. i.e., @var{start} -defaults to 0 and @var{end} defaults to -@code{(string-length str)} -@item -use the current input port if @var{port_or_fdes} is not -supplied. -@item -return fewer than the requested number of characters in some -cases, e.g., on end of file, if interrupted by a signal, or if -not all the characters are immediately available. -@item -wait indefinitely for some input if no characters are -currently available, -unless the port is in non-blocking mode. -@item -read characters from the port's input buffers if available, -instead from the underlying file descriptor. -@item -return @code{#f} if end-of-file is encountered before reading -any characters, otherwise return the number of characters -read. -@item -return 0 if the port is in non-blocking mode and no characters -are immediately available. -@item -return 0 if the request is for 0 bytes, with no -end-of-file check. -@end itemize -@end deffn - -@deffn {Scheme Procedure} write-string/partial str [port_or_fdes [start [end]]] -@deffnx {C Function} scm_write_string_partial (str, port_or_fdes, start, end) -Write characters from a string @var{str} to a port or file -descriptor. A port must have an underlying file descriptor ---- a so-called fport. This procedure is -scsh-compatible and can efficiently write large strings. -It will: - -@itemize -@item -attempt to write the entire string, unless the @var{start} -and/or @var{end} arguments are supplied. i.e., @var{start} -defaults to 0 and @var{end} defaults to -@code{(string-length str)} -@item -use the current output port if @var{port_of_fdes} is not -supplied. -@item -in the case of a buffered port, store the characters in the -port's output buffer, if all will fit. If they will not fit -then any existing buffered characters will be flushed -before attempting -to write the new characters directly to the underlying file -descriptor. If the port is in non-blocking mode and -buffered characters can not be flushed immediately, then an -@code{EAGAIN} system-error exception will be raised (Note: -scsh does not support the use of non-blocking buffered ports.) -@item -write fewer than the requested number of -characters in some cases, e.g., if interrupted by a signal or -if not all of the output can be accepted immediately. -@item -wait indefinitely for at least one character -from @var{str} to be accepted by the port, unless the port is -in non-blocking mode. -@item -return the number of characters accepted by the port. -@item -return 0 if the port is in non-blocking mode and can not accept -at least one character from @var{str} immediately -@item -return 0 immediately if the request size is 0 bytes. -@end itemize -@end deffn - @node Default Ports @subsection Default Ports for Input, Output and Errors @cindex Default ports From a21f6467acdbd80de811574c8e7959c215adea2a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 8 Jun 2016 10:19:27 +0200 Subject: [PATCH 365/865] Big ports documentation update * doc/ref/api-io.texi: Update to document ports more thoroughly. Still some work needed. * doc/ref/r6rs.texi: Move ports documentation back to r6rs.texi, now that Guile has a more thorough binary/textual I/O story, heavily based on R6RS. * doc/ref/api-control.texi: * doc/ref/api-data.texi: * doc/ref/api-options.texi: * doc/ref/misc-modules.texi: * doc/ref/posix.texi: * doc/ref/srfi-modules.texi: Update references. --- doc/ref/api-control.texi | 4 +- doc/ref/api-data.texi | 4 +- doc/ref/api-io.texi | 1980 +++++++++++++------------------------ doc/ref/api-options.texi | 2 +- doc/ref/misc-modules.texi | 35 +- doc/ref/posix.texi | 6 +- doc/ref/r6rs.texi | 566 ++++++++++- doc/ref/srfi-modules.texi | 4 +- 8 files changed, 1286 insertions(+), 1315 deletions(-) diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index 4253a206a..a1eacd6c8 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.texi @@ -1801,8 +1801,8 @@ In @code{scm_wrong_type_arg_msg}, @var{expected} is a C string describing the type of argument that was expected. In @code{scm_misc_error}, @var{message} is the error message string, -possibly containing @code{simple-format} escapes (@pxref{Writing}), and -the corresponding arguments in the @var{args} list. +possibly containing @code{simple-format} escapes (@pxref{Simple +Output}), and the corresponding arguments in the @var{args} list. @end deftypefn diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 3a3a8e4ac..aee0bb6ce 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -4611,8 +4611,8 @@ they do not need to be quoted: @result{} #vu8(1 53 204) @end lisp -Bytevectors can be used with the binary input/output primitives of the -R6RS (@pxref{R6RS I/O Ports}). +Bytevectors can be used with the binary input/output primitives +(@pxref{Binary I/O}). @menu * Bytevector Endianness:: Dealing with byte order. diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 5c6c213fa..c0518d71a 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -8,16 +8,18 @@ @section Input and Output @menu -* Ports:: The idea of the port abstraction. -* Reading:: Procedures for reading from a port. -* Writing:: Procedures for writing to a port. -* Closing:: Procedures to close a port. +* Ports:: What's a port? +* Binary I/O:: Reading and writing bytes. +* Encoding:: Characters as bytes. +* Textual I/O:: Reading and writing characters. +* Simple Output:: Simple syntactic sugar solution. * Buffering:: Controlling when data is written to ports. * Random Access:: Moving around a random access port. * Line/Delimited:: Read and write lines or delimited text. * Default Ports:: Defaults for input, output and errors. * Port Types:: Types of port and how to make them. -* R6RS I/O Ports:: The R6RS port API. +* Venerable Port Interfaces:: Procedures from the last millenium. +* Using Ports from C:: Nice interfaces for C. * I/O Extensions:: Implementing new port types in C. * Non-Blocking I/O:: How Guile deals with EWOULDBLOCK. * BOM Handling:: Handling of Unicode byte order marks. @@ -28,49 +30,248 @@ @subsection Ports @cindex Port -Sequential input/output in Scheme is represented by operations on a -@dfn{port}. This chapter explains the operations that Guile provides -for working with ports. +Ports are the way that Guile performs input and output. Guile can read +in characters or bytes from an @dfn{input port}, or write them out to an +@dfn{output port}. Some ports support both interfaces. -Ports are created by opening, for instance @code{open-file} for a file -(@pxref{File Ports}). Other kinds of ports include @dfn{soft ports} and -@dfn{string ports} (@pxref{Soft Ports}, and @ref{String Ports}). -Characters or bytes can be read from an input port and written to an -output port, or both on an input/output port. A port can be closed -(@pxref{Closing}) when no longer required, after which any attempt to -read or write is an error. +There are a number of different port types implemented in Guile. File +ports provide input and output over files, as you might imagine. For +example, we might display a string to a file like this: -Ports are garbage collected in the usual way (@pxref{Memory -Management}), and will be closed at that time if not already closed. In -this case any errors occurring in the close will not be reported. -Usually a program will want to explicitly close so as to be sure all its -operations have been successful, including any buffered writes -(@pxref{Buffering}). Of course if a program has abandoned something due -to an error or other condition then closing problems are probably not of -interest. +@example +(let ((port (open-output-file "foo.txt"))) + (display "Hello, world!\n" port) + (close-port port)) +@end example -It is strongly recommended that file ports be closed explicitly when -no longer required. Most systems have limits on how many files can be -open, both on a per-process and a system-wide basis. A program that -uses many files should take care not to hit those limits. The same -applies to similar system resources such as pipes and sockets. +There are also string ports, for taking input from a string, or +collecting output to a string; bytevector ports, for doing the same but +using a bytevector as a source or sink of data; and soft ports, for +arranging to call Scheme functions to provide input or handle output. +@xref{Port Types}. -Note that automatic garbage collection is triggered only by memory -consumption, not by file or other resource usage, so a program cannot -rely on that to keep it away from system limits. An explicit call to -@code{gc} can of course be relied on to pick up unreferenced ports. -If program flow makes it hard to be certain when to close then this -may be an acceptable way to control resource usage. +Ports should be @dfn{closed} when they are not needed by calling +@code{close-port} on them, as in the example above. This will make sure +that any pending output is successfully written out to disk, in the case +of a file port, or otherwise to whatever mutable store is backed by the +port. Any error that occurs while writing out that buffered data would +also be raised promptly at the @code{close-port}, and not later when the +port is closed by the garbage collector. @xref{Buffering}, for more on +buffered output. -All file access uses the ``LFS'' large file support functions when -available, so files bigger than 2 Gbytes (@math{2^31} bytes) can be -read and written on a 32-bit system. +Closing a port also releases any precious resource the file might have. +Usually in Scheme a programmer doesn't have to clean up after their data +structures (@pxref{Memory Management}), but most systems have strict +limits on how many files can be open, both on a per-process and a +system-wide basis. A program that uses many files should take care not +to hit those limits. The same applies to similar system resources such +as pipes and sockets. -Each port has an associated character encoding that controls how bytes -read from the port are converted to characters and controls how -characters written to the port are converted to bytes. When ports are -created, they inherit their character encoding from the current locale, -but, that can be modified after the port is created. +Indeed for these reasons the above example is not the most idiomatic way +to use ports. It is more common to acquire ports via procedures like +@code{call-with-output-file}, which handle the @code{close-port} +automatically: + +@example +(call-with-output-file "foo.txt" + (lambda (port) + (display "Hello, world!\n" port))) +@end example + +Finally, all ports have associated input and output buffers, as +appropriate. Buffering is a common strategy to limit the overhead of +small reads and writes: without buffering, each character fetched from a +file would involve at least one call into the kernel, and maybe more +depending on the character and the encoding. Instead, Guile will batch +reads and writes into internal buffers. However, sometimes you want to +make output on a port show up immediately. @xref{Buffering}, for more +on interfaces to control port buffering. + +@deffn {Scheme Procedure} port? x +@deffnx {C Function} scm_port_p (x) +Return a boolean indicating whether @var{x} is a port. +@end deffn + +@rnindex input-port? +@deffn {Scheme Procedure} input-port? x +@deffnx {C Function} scm_input_port_p (x) +Return @code{#t} if @var{x} is an input port, otherwise return +@code{#f}. Any object satisfying this predicate also satisfies +@code{port?}. +@end deffn + +@rnindex output-port? +@deffn {Scheme Procedure} output-port? x +@deffnx {C Function} scm_output_port_p (x) +Return @code{#t} if @var{x} is an output port, otherwise return +@code{#f}. Any object satisfying this predicate also satisfies +@code{port?}. +@end deffn + +@cindex Closing ports +@cindex Port, close +@deffn {Scheme Procedure} close-port port +@deffnx {C Function} scm_close_port (port) +Close the specified port object. Return @code{#t} if it successfully +closes a port or @code{#f} if it was already closed. An exception may +be raised if an error occurs, for example when flushing buffered output. +@xref{Buffering}, for more on buffered output. See also @ref{Ports and +File Descriptors, close}, for a procedure which can close file +descriptors. +@end deffn + +@deffn {Scheme Procedure} port-closed? port +@deffnx {C Function} scm_port_closed_p (port) +Return @code{#t} if @var{port} is closed or @code{#f} if it is +open. +@end deffn + + +@node Binary I/O +@subsection Binary I/O + +Guile's ports are fundamentally binary in nature: at the lowest level, +they work on bytes. This section describes Guile's core binary I/O +operations. @xref{Textual I/O}, for input and output of strings and +characters. + +To use these routines, first include the binary I/O module: + +@example +(use-modules (ice-9 binary-ports)) +@end example + +Note that although this module's name suggests that binary ports are +some different kind of port, that's not the case: all ports in Guile are +both binary and textual ports. + +@cindex binary input +@deffn {Scheme Procedure} get-u8 port +@deffnx {C Function} scm_get_u8 (port) +Return an octet read from @var{port}, an input port, blocking as +necessary, or the end-of-file object. +@end deffn + +@deffn {Scheme Procedure} lookahead-u8 port +@deffnx {C Function} scm_lookahead_u8 (port) +Like @code{get-u8} but does not update @var{port}'s position to point +past the octet. +@end deffn + +The end-of-file object is unlike any other kind of object: it's not a +pair, a symbol, or anything else. To check if a value is the +end-of-file object, use the @code{eof-object?} predicate. + +@rnindex eof-object? +@cindex End of file object +@deffn {Scheme Procedure} eof-object? x +@deffnx {C Function} scm_eof_object_p (x) +Return @code{#t} if @var{x} is an end-of-file object, or @code{#f} +otherwise. +@end deffn + +Note that unlike other procedures in this module, @code{eof-object?} is +defined in the default environment. + +@deffn {Scheme Procedure} get-bytevector-n port count +@deffnx {C Function} scm_get_bytevector_n (port, count) +Read @var{count} octets from @var{port}, blocking as necessary and +return a bytevector containing the octets read. If fewer bytes are +available, a bytevector smaller than @var{count} is returned. +@end deffn + +@deffn {Scheme Procedure} get-bytevector-n! port bv start count +@deffnx {C Function} scm_get_bytevector_n_x (port, bv, start, count) +Read @var{count} bytes from @var{port} and store them in @var{bv} +starting at index @var{start}. Return either the number of bytes +actually read or the end-of-file object. +@end deffn + +@deffn {Scheme Procedure} get-bytevector-some port +@deffnx {C Function} scm_get_bytevector_some (port) +Read from @var{port}, blocking as necessary, until bytes are available +or an end-of-file is reached. Return either the end-of-file object or a +new bytevector containing some of the available bytes (at least one), +and update the port position to point just past these bytes. +@end deffn + +@deffn {Scheme Procedure} get-bytevector-all port +@deffnx {C Function} scm_get_bytevector_all (port) +Read from @var{port}, blocking as necessary, until the end-of-file is +reached. Return either a new bytevector containing the data read or the +end-of-file object (if no data were available). +@end deffn + +@deffn {Scheme Procedure} unget-bytevector port bv [start [count]] +@deffnx {C Function} scm_unget_bytevector (port, bv, start, count) +Place the contents of @var{bv} in @var{port}, optionally starting at +index @var{start} and limiting to @var{count} octets, so that its bytes +will be read from left-to-right as the next bytes from @var{port} during +subsequent read operations. If called multiple times, the unread bytes +will be read again in last-in first-out order. +@end deffn + +@cindex binary output +To perform binary output on a port, use @code{put-u8} or +@code{put-bytevector}. + +@deffn {Scheme Procedure} put-u8 port octet +@deffnx {C Function} scm_put_u8 (port, octet) +Write @var{octet}, an integer in the 0--255 range, to @var{port}, a +binary output port. +@end deffn + +@deffn {Scheme Procedure} put-bytevector port bv [start [count]] +@deffnx {C Function} scm_put_bytevector (port, bv, start, count) +Write the contents of @var{bv} to @var{port}, optionally starting at +index @var{start} and limiting to @var{count} octets. +@end deffn + +@node Encoding +@subsection Encoding + +Textual input and output on Guile ports is layered on top of binary +operations. To this end, each port has an associated character encoding +that controls how bytes read from the port are converted to characters, +and how characters written to the port are converted to bytes. + +@deffn {Scheme Procedure} port-encoding port +@deffnx {C Function} scm_port_encoding (port) +Returns, as a string, the character encoding that @var{port} uses to +interpret its input and output. +@end deffn + +@deffn {Scheme Procedure} set-port-encoding! port enc +@deffnx {C Function} scm_set_port_encoding_x (port, enc) +Sets the character encoding that will be used to interpret I/O to +@var{port}. @var{enc} is a string containing the name of an encoding. +Valid encoding names are those +@url{http://www.iana.org/assignments/character-sets, defined by IANA}, +for example @code{"UTF-8"} or @code{"ISO-8859-1"}. +@end deffn + +When ports are created, they are assigned an encoding. The usual +process to determine the initial encoding for a port is to take the +value of the @code{%default-port-encoding} fluid. + +@defvr {Scheme Variable} %default-port-encoding +A fluid containing name of the encoding to be used by default for newly +created ports (@pxref{Fluids and Dynamic States}). As a special case, +the value @code{#f} is equivalent to @code{"ISO-8859-1"}. +@end defvr + +The @code{%default-port-encoding} itself defaults to the encoding +appropriate for the current locale, if @code{setlocale} has been called. +@xref{Locales}, for more on locales and when you might need to call +@code{setlocale} explicitly. + +Some port types have other ways of determining their initial locales. +String ports, for example, default to the UTF-8 encoding, in order to be +able to represent all characters regardless of the current locale. File +ports can optionally sniff their file for a @code{coding:} declaration; +@xref{File Ports}. Binary ports might be initialized to the ISO-8859-1 +encoding in which each codepoint between 0 and 255 corresponds to a byte +with that value. Currently, the ports only work with @emph{non-modal} encodings. Most encodings are non-modal, meaning that the conversion of bytes to a @@ -90,92 +291,6 @@ escape, or to replace the character with a substitute character. Port conversion strategies are also used when decoding characters from an input port. -Finally, all ports have associated input and output buffers, as -appropriate. Buffering is a common strategy to limit the overhead of -small reads and writes: without buffering, each character fetched from a -file would involve at least one call into the kernel, and maybe more -depending on the character and the encoding. Instead, Guile will batch -reads and writes into internal buffers. However, sometimes you want to -make output on a port show up immediately. @xref{Buffering}, for more -on interfaces to control port buffering. - -@rnindex input-port? -@deffn {Scheme Procedure} input-port? x -@deffnx {C Function} scm_input_port_p (x) -Return @code{#t} if @var{x} is an input port, otherwise return -@code{#f}. Any object satisfying this predicate also satisfies -@code{port?}. -@end deffn - -@rnindex output-port? -@deffn {Scheme Procedure} output-port? x -@deffnx {C Function} scm_output_port_p (x) -Return @code{#t} if @var{x} is an output port, otherwise return -@code{#f}. Any object satisfying this predicate also satisfies -@code{port?}. -@end deffn - -@deffn {Scheme Procedure} port? x -@deffnx {C Function} scm_port_p (x) -Return a boolean indicating whether @var{x} is a port. -Equivalent to @code{(or (input-port? @var{x}) (output-port? -@var{x}))}. -@end deffn - -@deffn {Scheme Procedure} set-port-encoding! port enc -@deffnx {C Function} scm_set_port_encoding_x (port, enc) -Sets the character encoding that will be used to interpret all port I/O. -@var{enc} is a string containing the name of an encoding. Valid -encoding names are those -@url{http://www.iana.org/assignments/character-sets, defined by IANA}. -@end deffn - -@defvr {Scheme Variable} %default-port-encoding -A fluid containing @code{#f} or the name of the encoding to -be used by default for newly created ports (@pxref{Fluids and Dynamic -States}). The value @code{#f} is equivalent to @code{"ISO-8859-1"}. - -New ports are created with the encoding appropriate for the current -locale if @code{setlocale} has been called or the value specified by -this fluid otherwise. -@end defvr - -@deffn {Scheme Procedure} port-encoding port -@deffnx {C Function} scm_port_encoding (port) -Returns, as a string, the character encoding that @var{port} uses to interpret -its input and output. The value @code{#f} is equivalent to @code{"ISO-8859-1"}. -@end deffn - -@deffn {Scheme Procedure} set-port-conversion-strategy! port sym -@deffnx {C Function} scm_set_port_conversion_strategy_x (port, sym) -Sets the behavior of Guile when outputting a character that is not -representable in the port's current encoding, or when Guile encounters a -decoding error when trying to read a character. @var{sym} can be either -@code{error}, @code{substitute}, or @code{escape}. - -If @var{port} is an open port, the conversion error behavior -is set for that port. If it is @code{#f}, it is set as the -default behavior for any future ports that get created in -this thread. -@end deffn - -For an output port, a there are three possible port conversion -strategies. The @code{error} strategy will throw an error when a -nonconvertible character is encountered. The @code{substitute} strategy -will replace nonconvertible characters with a question mark (@samp{?}). -Finally the @code{escape} strategy will print nonconvertible characters -as a hex escape, using the escaping that is recognized by Guile's string -syntax. Note that if the port's encoding is a Unicode encoding, like -@code{UTF-8}, then encoding errors are impossible. - -For an input port, the @code{error} strategy will cause Guile to throw -an error if it encounters an invalid encoding, such as might happen if -you tried to read @code{ISO-8859-1} as @code{UTF-8}. The error is -thrown before advancing the read position. The @code{substitute} -strategy will replace the bad bytes with a U+FFFD replacement character, -in accordance with Unicode recommendations. When reading from an input -port, the @code{escape} strategy is treated as if it were @code{error}. - @deffn {Scheme Procedure} port-conversion-strategy port @deffnx {C Function} scm_port_conversion_strategy (port) Returns the behavior of the port when outputting a character that is not @@ -186,9 +301,24 @@ returned. New ports will have this default behavior when they are created. @end deffn +@deffn {Scheme Procedure} set-port-conversion-strategy! port sym +@deffnx {C Function} scm_set_port_conversion_strategy_x (port, sym) +Sets the behavior of Guile when outputting a character that is not +representable in the port's current encoding, or when Guile encounters a +decoding error when trying to read a character. @var{sym} can be either +@code{error}, @code{substitute}, or @code{escape}. + +If @var{port} is an open port, the conversion error behavior is set for +that port. If it is @code{#f}, it is set as the default behavior for +any future ports that get created in this thread. +@end deffn + +As with port encodings, there is a fluid which determines the initial +conversion strategy for a port. + @deffn {Scheme Variable} %default-port-conversion-strategy The fluid that defines the conversion strategy for newly created ports, -and for other conversion routines such as @code{scm_to_stringn}, +and also for other conversion routines such as @code{scm_to_stringn}, @code{scm_from_stringn}, @code{string->pointer}, and @code{pointer->string}. @@ -202,114 +332,161 @@ equivalent to @code{(fluid-set! %default-port-conversion-strategy @var{sym})}. @end deffn +As mentioned above, for an output port there are three possible port +conversion strategies. The @code{error} strategy will throw an error +when a nonconvertible character is encountered. The @code{substitute} +strategy will replace nonconvertible characters with a question mark +(@samp{?}). Finally the @code{escape} strategy will print +nonconvertible characters as a hex escape, using the escaping that is +recognized by Guile's string syntax. Note that if the port's encoding +is a Unicode encoding, like @code{UTF-8}, then encoding errors are +impossible. -@node Reading -@subsection Reading -@cindex Reading +For an input port, the @code{error} strategy will cause Guile to throw +an error if it encounters an invalid encoding, such as might happen if +you tried to read @code{ISO-8859-1} as @code{UTF-8}. The error is +thrown before advancing the read position. The @code{substitute} +strategy will replace the bad bytes with a U+FFFD replacement character, +in accordance with Unicode recommendations. When reading from an input +port, the @code{escape} strategy is treated as if it were @code{error}. -These procedures pertain to reading characters and strings from -ports. To read general S-expressions from ports, @xref{Scheme Read}. -@rnindex eof-object? -@cindex End of file object -@deffn {Scheme Procedure} eof-object? x -@deffnx {C Function} scm_eof_object_p (x) -Return @code{#t} if @var{x} is an end-of-file object; otherwise -return @code{#f}. +@node Textual I/O +@subsection Textual I/O +@cindex textual input +@cindex textual output + +This section describes Guile's core textual I/O operations on characters +and strings. @xref{Binary I/O}, for input and output of bytes and +bytevectors. @xref{Encoding}, for more on how characters relate to +bytes. To read general S-expressions from ports, @xref{Scheme Read}. +@xref{Scheme Write}, for interfaces that write generic Scheme datums. + +To use these routines, first include the textual I/O module: + +@example +(use-modules (ice-9 textual-ports)) +@end example + +Note that although this module's name suggests that textual ports are +some different kind of port, that's not the case: all ports in Guile are +both binary and textual ports. + +@deffn {Scheme Procedure} get-char input-port +Reads from @var{input-port}, blocking as necessary, until a +complete character is available from @var{input-port}, +or until an end of file is reached. + +If a complete character is available before the next end of file, +@code{get-char} returns that character and updates the input port to +point past the character. If an end of file is reached before any +character is read, @code{get-char} returns the end-of-file object. @end deffn -@rnindex char-ready? -@deffn {Scheme Procedure} char-ready? [port] -@deffnx {C Function} scm_char_ready_p (port) -Return @code{#t} if a character is ready on input @var{port} -and return @code{#f} otherwise. If @code{char-ready?} returns -@code{#t} then the next @code{read-char} operation on -@var{port} is guaranteed not to hang. If @var{port} is a file -port at end of file then @code{char-ready?} returns @code{#t}. - -@code{char-ready?} exists to make it possible for a -program to accept characters from interactive ports without -getting stuck waiting for input. Any input editors associated -with such ports must make sure that characters whose existence -has been asserted by @code{char-ready?} cannot be rubbed out. -If @code{char-ready?} were to return @code{#f} at end of file, -a port at end of file would be indistinguishable from an -interactive port that has no ready characters. +@deffn {Scheme Procedure} lookahead-char input-port +The @code{lookahead-char} procedure is like @code{get-char}, but it does +not update @var{input-port} to point past the character. @end deffn -@rnindex read-char -@deffn {Scheme Procedure} read-char [port] -@deffnx {C Function} scm_read_char (port) -Return the next character available from @var{port}, updating @var{port} -to point to the following character. If no more characters are -available, the end-of-file object is returned. A decoding error, if -any, is handled in accordance with the port's conversion strategy. -@end deffn +In the same way that it's possible to "unget" a byte or bytes, it's +possible to "unget" the bytes corresponding to an encoded character. -@deftypefn {C Function} size_t scm_c_read (SCM port, void *buffer, size_t size) -Read up to @var{size} bytes from @var{port} and store them in -@var{buffer}. The return value is the number of bytes actually read, -which can be less than @var{size} if end-of-file has been reached. - -Note that this function does not update @code{port-line} and -@code{port-column} below. -@end deftypefn - -@rnindex peek-char -@deffn {Scheme Procedure} peek-char [port] -@deffnx {C Function} scm_peek_char (port) -Return the next character available from @var{port}, -@emph{without} updating @var{port} to point to the following -character. If no more characters are available, the -end-of-file object is returned. - -The value returned by -a call to @code{peek-char} is the same as the value that would -have been returned by a call to @code{read-char} on the same -port. The only difference is that the very next call to -@code{read-char} or @code{peek-char} on that @var{port} will -return the value returned by the preceding call to -@code{peek-char}. In particular, a call to @code{peek-char} on -an interactive port will hang waiting for input whenever a call -to @code{read-char} would have hung. - -As for @code{read-char}, decoding errors are handled in accordance with -the port's conversion strategy. -@end deffn - -@deffn {Scheme Procedure} unread-char cobj [port] -@deffnx {C Function} scm_unread_char (cobj, port) -Place character @var{cobj} in @var{port} so that it will be read by the +@deffn {Scheme Procedure} unget-char port char +Place character @var{char} in @var{port} so that it will be read by the next read operation. If called multiple times, the unread characters -will be read again in last-in first-out order. If @var{port} is -not supplied, the current input port is used. +will be read again in last-in first-out order. @end deffn -@deffn {Scheme Procedure} unread-string str port -@deffnx {C Function} scm_unread_string (str, port) +@deffn {Scheme Procedure} unget-string port str Place the string @var{str} in @var{port} so that its characters will be read from left-to-right as the next characters from @var{port} during subsequent read operations. If called multiple times, the -unread characters will be read again in last-in first-out order. If -@var{port} is not supplied, the @code{current-input-port} is used. +unread characters will be read again in last-in first-out order. @end deffn -@deffn {Scheme Procedure} drain-input port -@deffnx {C Function} scm_drain_input (port) -This procedure clears a port's input buffers, similar -to the way that force-output clears the output buffer. The -contents of the buffers are returned as a single string, e.g., +Reading in a character at a time can be inefficient. If it's possible +to perform I/O over multiple characters at a time, via strings, that +might be faster. -@lisp -(define p (open-input-file ...)) -(drain-input p) => empty string, nothing buffered yet. -(unread-char (read-char p) p) -(drain-input p) => initial chars from p, up to the buffer size. -@end lisp +@deffn {Scheme Procedure} get-string-n input-port count +The @code{get-string-n} procedure reads from @var{input-port}, blocking +as necessary, until @var{count} characters are available, or until an +end of file is reached. @var{count} must be an exact, non-negative +integer, representing the number of characters to be read. -Draining the buffers may be useful for cleanly finishing -buffered I/O so that the file descriptor can be used directly -for further input. +If @var{count} characters are available before end of file, +@code{get-string-n} returns a string consisting of those @var{count} +characters. If fewer characters are available before an end of file, but +one or more characters can be read, @code{get-string-n} returns a string +containing those characters. In either case, the input port is updated +to point just past the characters read. If no characters can be read +before an end of file, the end-of-file object is returned. +@end deffn + +@deffn {Scheme Procedure} get-string-n! input-port string start count +The @code{get-string-n!} procedure reads from @var{input-port} in the +same manner as @code{get-string-n}. @var{start} and @var{count} must be +exact, non-negative integer objects, with @var{count} representing the +number of characters to be read. @var{string} must be a string with at +least $@var{start} + @var{count}$ characters. + +If @var{count} characters are available before an end of file, they are +written into @var{string} starting at index @var{start}, and @var{count} +is returned. If fewer characters are available before an end of file, +but one or more can be read, those characters are written into +@var{string} starting at index @var{start} and the number of characters +actually read is returned as an exact integer object. If no characters +can be read before an end of file, the end-of-file object is returned. +@end deffn + +@deffn {Scheme Procedure} get-string-all input-port +Reads from @var{input-port} until an end of file, decoding characters in +the same manner as @code{get-string-n} and @code{get-string-n!}. + +If characters are available before the end of file, a string containing +all the characters decoded from that data are returned. If no character +precedes the end of file, the end-of-file object is returned. +@end deffn + +@deffn {Scheme Procedure} get-line input-port +Reads from @var{input-port} up to and including the linefeed +character or end of file, decoding characters in the same manner as +@code{get-string-n} and @code{get-string-n!}. + +If a linefeed character is read, a string containing all of the text up +to (but not including) the linefeed character is returned, and the port +is updated to point just past the linefeed character. If an end of file +is encountered before any linefeed character is read, but some +characters have been read and decoded as characters, a string containing +those characters is returned. If an end of file is encountered before +any characters are read, the end-of-file object is returned. +@end deffn + +Finally, there are just two core procedures to write characters to a +port. + +@deffn {Scheme Procedure} put-char port char +Writes @var{char} to the port. The @code{put-char} procedure returns +an unspecified value. +@end deffn + +@deffn {Scheme Procedure} put-string port string +@deffnx {Scheme Procedure} put-string port string start +@deffnx {Scheme Procedure} put-string port string start count +Write the @var{count} characters of @var{string} starting at index +@var{start} to the port. + +@var{start} and @var{count} must be non-negative exact integer objects. +@var{string} must have a length of at least @math{@var{start} + +@var{count}}. @var{start} defaults to 0. @var{count} defaults to +@math{@code{(string-length @var{string})} - @var{start}}$. + +Calling @code{put-string} is equivalent in all respects to calling +@code{put-char} on the relevant sequence of characters, except that it +will attempt to write multiple characters to the port at a time, even if +the port is unbuffered. + +The @code{put-string} procedure returns an unspecified value. @end deffn @deffn {Scheme Procedure} port-column port @@ -333,34 +510,8 @@ what non-programmers will find most natural.) Set the current column or line number of @var{port}. @end deffn -@node Writing -@subsection Writing -@cindex Writing - -These procedures are for writing characters and strings to -ports. For more information on writing arbitrary Scheme objects to -ports, @xref{Scheme Write}. - -@deffn {Scheme Procedure} get-print-state port -@deffnx {C Function} scm_get_print_state (port) -Return the print state of the port @var{port}. If @var{port} -has no associated print state, @code{#f} is returned. -@end deffn - -@rnindex newline -@deffn {Scheme Procedure} newline [port] -@deffnx {C Function} scm_newline (port) -Send a newline to @var{port}. -If @var{port} is omitted, send to the current output port. -@end deffn - -@deffn {Scheme Procedure} port-with-print-state port [pstate] -@deffnx {C Function} scm_port_with_print_state (port, pstate) -Create a new port which behaves like @var{port}, but with an -included print state @var{pstate}. @var{pstate} is optional. -If @var{pstate} isn't supplied and @var{port} already has -a print state, the old print state is reused. -@end deffn +@node Simple Output +@subsection Simple Textual Output @deffn {Scheme Procedure} simple-format destination message . args @deffnx {C Function} scm_simple_format (destination, message, args) @@ -373,81 +524,7 @@ current output port, if @var{destination} is @code{#f}, then return a string containing the formatted text. Does not add a trailing newline. @end deffn -@rnindex write-char -@deffn {Scheme Procedure} write-char chr [port] -@deffnx {C Function} scm_write_char (chr, port) -Send character @var{chr} to @var{port}. -@end deffn - -@deftypefn {C Function} void scm_c_write (SCM port, const void *buffer, size_t size) -Write @var{size} bytes at @var{buffer} to @var{port}. - -Note that this function does not update @code{port-line} and -@code{port-column} (@pxref{Reading}). -@end deftypefn - -@deftypefn {C Function} void scm_lfwrite (const char *buffer, size_t size, SCM port) -Write @var{size} bytes at @var{buffer} to @var{port}. The @code{lf} -indicates that unlike @code{scm_c_write}, this function updates the -port's @code{port-line} and @code{port-column}, and also flushes the -port if the data contains a newline (@code{\n}) and the port is -line-buffered. -@end deftypefn - -@findex fflush -@deffn {Scheme Procedure} force-output [port] -@deffnx {C Function} scm_force_output (port) -Flush the specified output port, or the current output port if @var{port} -is omitted. The current output buffer contents are passed to the -underlying port implementation (e.g., in the case of fports, the -data will be written to the file and the output buffer will be cleared.) -It has no effect on an unbuffered port. - -The return value is unspecified. -@end deffn - -@deffn {Scheme Procedure} flush-all-ports -@deffnx {C Function} scm_flush_all_ports () -Equivalent to calling @code{force-output} on -all open output ports. The return value is unspecified. -@end deffn - - -@node Closing -@subsection Closing -@cindex Closing ports -@cindex Port, close - -@deffn {Scheme Procedure} close-port port -@deffnx {C Function} scm_close_port (port) -Close the specified port object. Return @code{#t} if it successfully -closes a port or @code{#f} if it was already closed. An exception may -be raised if an error occurs, for example when flushing buffered output. -@xref{Buffering}, for more on buffered output. See also @ref{Ports and -File Descriptors, close}, for a procedure which can close file -descriptors. -@end deffn - -@deffn {Scheme Procedure} close-input-port port -@deffnx {Scheme Procedure} close-output-port port -@deffnx {C Function} scm_close_input_port (port) -@deffnx {C Function} scm_close_output_port (port) -@rnindex close-input-port -@rnindex close-output-port -Close the specified input or output @var{port}. An exception may be -raised if an error occurs while closing. If @var{port} is already -closed, nothing is done. The return value is unspecified. - -See also @ref{Ports and File Descriptors, close}, for a procedure -which can close file descriptors. -@end deffn - -@deffn {Scheme Procedure} port-closed? port -@deffnx {C Function} scm_port_closed_p (port) -Return @code{#t} if @var{port} is closed or @code{#f} if it is -open. -@end deffn - +pk / peek @node Buffering @subsection Buffering @@ -463,7 +540,7 @@ that intermediate buffer. Similarly, small writes like @code{write-char} first go to a buffer, and are sent to the store when the buffer is full (or when port is flushed). Buffered ports speed up your program by reducing the number of round-trips to the mutable store, -and the do so in a way that is mostly transparent to the user. +and they do so in a way that is mostly transparent to the user. There are two major ways, however, in which buffering affects program semantics. Building correct, performant programs requires understanding @@ -483,7 +560,7 @@ mutable store, and are not seekable. Note also that sockets are unbuffered by default. @xref{Network Sockets and Communication}. The second case is the more pernicious one. If you write data to a -buffered port, it probably hasn't gone out to the mutable store yet. +buffered port, it probably doesn't go out to the mutable store directly. (This ``probably'' introduces some indeterminism in your program: what goes to the store, and when, depends on how full the buffer is. It is something that the user needs to explicitly be aware of.) The data is @@ -532,6 +609,44 @@ Another way to set the buffering, for file ports, is to open the file with @code{0} or @code{l} as part of the mode string, for unbuffered or line-buffered ports, respectively. @xref{File Ports}, for more. +Any buffered output data will be written out when the port is closed. +To make sure to flush it at specific points in your program, use +@code{force-otput}. + +@findex fflush +@deffn {Scheme Procedure} force-output [port] +@deffnx {C Function} scm_force_output (port) +Flush the specified output port, or the current output port if +@var{port} is omitted. The current output buffer contents, if any, are +passed to the underlying port implementation. + +The return value is unspecified. +@end deffn + +@deffn {Scheme Procedure} flush-all-ports +@deffnx {C Function} scm_flush_all_ports () +Equivalent to calling @code{force-output} on all open output ports. The +return value is unspecified. +@end deffn + +Similarly, sometimes you might want to switch from using Guile's ports +to working directly on file descriptors. In that case, for input ports +use @code{drain-input} to get any buffered input from that port. + +@deffn {Scheme Procedure} drain-input port +@deffnx {C Function} scm_drain_input (port) +This procedure clears a port's input buffers, similar +to the way that force-output clears the output buffer. The +contents of the buffers are returned as a single string, e.g., + +@lisp +(define p (open-input-file ...)) +(drain-input p) => empty string, nothing buffered yet. +(unread-char (read-char p) p) +(drain-input p) => initial chars from p, up to the buffer size. +@end lisp +@end deffn + All of these considerations are very similar to those of streams in the C library, although Guile's ports are not built on top of C streams. Still, it is useful to read what other systems do. @@ -783,7 +898,7 @@ Unbuffered output to a tty is good for ensuring progress output or a prompt is seen. But an application which always prints whole lines could change to line buffered, or an application with a lot of output could go fully buffered and perhaps make explicit @code{force-output} -calls (@pxref{Writing}) at selected points. +calls (@pxref{Buffering}) at selected points. @end deffn @deffn {Scheme Procedure} current-error-port @@ -827,8 +942,10 @@ initialized with the @var{port} argument. @menu * File Ports:: Ports on an operating system file. +* Bytevector Ports:: Ports on a bytevector. * String Ports:: Ports on a Scheme string. -* Soft Ports:: Ports on arbitrary Scheme procedures. +* Custom Ports:: Ports whose implementation you control. +* Soft Ports:: An older version of custom ports. * Void Ports:: Ports on nothing at all. @end menu @@ -842,6 +959,10 @@ The following procedures are used to open file ports. See also @ref{Ports and File Descriptors, open}, for an interface to the Unix @code{open} system call. +All file access uses the ``LFS'' large file support functions when +available, so files bigger than 2 Gbytes (@math{2^31} bytes) can be +read and written on a 32-bit system. + Most systems have limits on how many files can be open, so it's strongly recommended that file ports be closed explicitly when no longer required (@pxref{Ports}). @@ -895,8 +1016,7 @@ character encoding "ISO-8859-1", ignoring the default port encoding. Note that while it is possible to read and write binary data as characters or strings, it is usually better to treat bytes as octets, -and byte sequences as bytevectors. @xref{R6RS Binary Input}, and -@ref{R6RS Binary Output}, for more. +and byte sequences as bytevectors. @xref{Binary I/O}, for more. This option had another historical meaning, for DOS compatibility: in the default (textual) mode, DOS reads a CR-LF sequence as one LF byte. @@ -1029,6 +1149,98 @@ Determine whether @var{obj} is a port that is related to a file. @end deffn +@node Bytevector Ports +@subsubsection Bytevector Ports + +@deffn {Scheme Procedure} open-bytevector-input-port bv [transcoder] +@deffnx {C Function} scm_open_bytevector_input_port (bv, transcoder) +Return an input port whose contents are drawn from bytevector @var{bv} +(@pxref{Bytevectors}). + +@c FIXME: Update description when implemented. +The @var{transcoder} argument is currently not supported. +@end deffn + +@cindex custom binary input ports + +@deffn {Scheme Procedure} make-custom-binary-input-port id read! get-position set-position! close +@deffnx {C Function} scm_make_custom_binary_input_port (id, read!, get-position, set-position!, close) +Return a new custom binary input port@footnote{This is similar in spirit +to Guile's @dfn{soft ports} (@pxref{Soft Ports}).} named @var{id} (a +string) whose input is drained by invoking @var{read!} and passing it a +bytevector, an index where bytes should be written, and the number of +bytes to read. The @code{read!} procedure must return an integer +indicating the number of bytes read, or @code{0} to indicate the +end-of-file. + +Optionally, if @var{get-position} is not @code{#f}, it must be a thunk +that will be called when @code{port-position} is invoked on the custom +binary port and should return an integer indicating the position within +the underlying data stream; if @var{get-position} was not supplied, the +returned port does not support @code{port-position}. + +Likewise, if @var{set-position!} is not @code{#f}, it should be a +one-argument procedure. When @code{set-port-position!} is invoked on the +custom binary input port, @var{set-position!} is passed an integer +indicating the position of the next byte is to read. + +Finally, if @var{close} is not @code{#f}, it must be a thunk. It is +invoked when the custom binary input port is closed. + +The returned port is fully buffered by default, but its buffering mode +can be changed using @code{setvbuf} (@pxref{Buffering}). + +Using a custom binary input port, the @code{open-bytevector-input-port} +procedure could be implemented as follows: + +@lisp +(define (open-bytevector-input-port source) + (define position 0) + (define length (bytevector-length source)) + + (define (read! bv start count) + (let ((count (min count (- length position)))) + (bytevector-copy! source position + bv start count) + (set! position (+ position count)) + count)) + + (define (get-position) position) + + (define (set-position! new-position) + (set! position new-position)) + + (make-custom-binary-input-port "the port" read! + get-position + set-position!)) + +(read (open-bytevector-input-port (string->utf8 "hello"))) +@result{} hello +@end lisp +@end deffn + +@deffn {Scheme Procedure} open-bytevector-output-port [transcoder] +@deffnx {C Function} scm_open_bytevector_output_port (transcoder) +Return two values: a binary output port and a procedure. The latter +should be called with zero arguments to obtain a bytevector containing +the data accumulated by the port, as illustrated below. + +@lisp +(call-with-values + (lambda () + (open-bytevector-output-port)) + (lambda (port get-bytevector) + (display "hello" port) + (get-bytevector))) + +@result{} #vu8(104 101 108 108 111) +@end lisp + +@c FIXME: Update description when implemented. +The @var{transcoder} argument is currently not supported. +@end deffn + + @node String Ports @subsubsection String Ports @cindex String port @@ -1103,6 +1315,83 @@ E.g., seeking and truncating will work on a string port, but trying to extract the file descriptor number will fail. +@node Custom Ports +@subsubsection Custom Ports + +(ice-9 binary-ports), binary and text... + +@cindex custom binary input ports +@deffn {Scheme Procedure} make-custom-binary-input-port id read! get-position set-position! close +@deffnx {C Function} scm_make_custom_binary_input_port (id, read!, get-position, set-position!, close) +Return a new custom binary input port@footnote{This is similar in spirit +to Guile's @dfn{soft ports} (@pxref{Soft Ports}).} named @var{id} (a +string) whose input is drained by invoking @var{read!} and passing it a +bytevector, an index where bytes should be written, and the number of +bytes to read. The @code{read!} procedure must return an integer +indicating the number of bytes read, or @code{0} to indicate the +end-of-file. + +Optionally, if @var{get-position} is not @code{#f}, it must be a thunk +that will be called when @code{port-position} is invoked on the custom +binary port and should return an integer indicating the position within +the underlying data stream; if @var{get-position} was not supplied, the +returned port does not support @code{port-position}. + +Likewise, if @var{set-position!} is not @code{#f}, it should be a +one-argument procedure. When @code{set-port-position!} is invoked on the +custom binary input port, @var{set-position!} is passed an integer +indicating the position of the next byte is to read. + +Finally, if @var{close} is not @code{#f}, it must be a thunk. It is +invoked when the custom binary input port is closed. + +The returned port is fully buffered by default, but its buffering mode +can be changed using @code{setvbuf} (@pxref{Buffering}). + +Using a custom binary input port, the @code{open-bytevector-input-port} +procedure (@pxref{Bytevector Ports}) could be implemented as follows: + +@lisp +(define (open-bytevector-input-port source) + (define position 0) + (define length (bytevector-length source)) + + (define (read! bv start count) + (let ((count (min count (- length position)))) + (bytevector-copy! source position + bv start count) + (set! position (+ position count)) + count)) + + (define (get-position) position) + + (define (set-position! new-position) + (set! position new-position)) + + (make-custom-binary-input-port "the port" read! + get-position + set-position!)) + +(read (open-bytevector-input-port (string->utf8 "hello"))) +@result{} hello +@end lisp +@end deffn + +@cindex custom binary output ports +@deffn {Scheme Procedure} make-custom-binary-output-port id write! get-position set-position! close +@deffnx {C Function} scm_make_custom_binary_output_port (id, write!, get-position, set-position!, close) +Return a new custom binary output port named @var{id} (a string) whose +output is sunk by invoking @var{write!} and passing it a bytevector, an +index where bytes should be read from this bytevector, and the number of +bytes to be ``written''. The @code{write!} procedure must return an +integer indicating the number of bytes actually written; when it is +passed @code{0} as the number of bytes to write, it should behave as +though an end-of-file was sent to the byte sink. + +The other arguments are as for @code{make-custom-binary-input-port}. +@end deffn + + @node Soft Ports @subsubsection Soft Ports @cindex Soft port @@ -1177,962 +1466,115 @@ documentation for @code{open-file} in @ref{File Ports}. @end deffn -@node R6RS I/O Ports -@subsection R6RS I/O Ports +@node Venerable Port Interfaces +@subsection Venerable Port Interfaces -@cindex R6RS -@cindex R6RS ports +@rnindex char-ready? +@deffn {Scheme Procedure} char-ready? [port] +@deffnx {C Function} scm_char_ready_p (port) +Return @code{#t} if a character is ready on input @var{port} +and return @code{#f} otherwise. If @code{char-ready?} returns +@code{#t} then the next @code{read-char} operation on +@var{port} is guaranteed not to hang. If @var{port} is a file +port at end of file then @code{char-ready?} returns @code{#t}. -The I/O port API of the @uref{http://www.r6rs.org/, Revised Report^6 on -the Algorithmic Language Scheme (R6RS)} is provided by the @code{(rnrs -io ports)} module. It provides features, such as binary I/O and Unicode -string I/O, that complement or refine Guile's historical port API -presented above (@pxref{Input and Output}). Note that R6RS ports are not -disjoint from Guile's native ports, so Guile-specific procedures will -work on ports created using the R6RS API, and vice versa. - -The text in this section is taken from the R6RS standard libraries -document, with only minor adaptions for inclusion in this manual. The -Guile developers offer their thanks to the R6RS editors for having -provided the report's text under permissive conditions making this -possible. - -@c FIXME: Update description when implemented. -@emph{Note}: The implementation of this R6RS API is not complete yet. - -@menu -* R6RS File Names:: File names. -* R6RS File Options:: Options for opening files. -* R6RS Buffer Modes:: Influencing buffering behavior. -* R6RS Transcoders:: Influencing port encoding. -* R6RS End-of-File:: The end-of-file object. -* R6RS Port Manipulation:: Manipulating R6RS ports. -* R6RS Input Ports:: Input Ports. -* R6RS Binary Input:: Binary input. -* R6RS Textual Input:: Textual input. -* R6RS Output Ports:: Output Ports. -* R6RS Binary Output:: Binary output. -* R6RS Textual Output:: Textual output. -@end menu - -A subset of the @code{(rnrs io ports)} module, plus one non-standard -procedure @code{unget-bytevector} (@pxref{R6RS Binary Input}), is -provided by the @code{(ice-9 binary-ports)} module. It contains binary -input/output procedures and does not rely on R6RS support. - -@node R6RS File Names -@subsubsection File Names - -Some of the procedures described in this chapter accept a file name as an -argument. Valid values for such a file name include strings that name a file -using the native notation of file system paths on an implementation's -underlying operating system, and may include implementation-dependent -values as well. - -A @var{filename} parameter name means that the -corresponding argument must be a file name. - -@node R6RS File Options -@subsubsection File Options -@cindex file options - -When opening a file, the various procedures in this library accept a -@code{file-options} object that encapsulates flags to specify how the -file is to be opened. A @code{file-options} object is an enum-set -(@pxref{rnrs enums}) over the symbols constituting valid file options. - -A @var{file-options} parameter name means that the corresponding -argument must be a file-options object. - -@deffn {Scheme Syntax} file-options @var{file-options-symbol} ... - -Each @var{file-options-symbol} must be a symbol. - -The @code{file-options} syntax returns a file-options object that -encapsulates the specified options. - -When supplied to an operation that opens a file for output, the -file-options object returned by @code{(file-options)} specifies that the -file is created if it does not exist and an exception with condition -type @code{&i/o-file-already-exists} is raised if it does exist. The -following standard options can be included to modify the default -behavior. - -@table @code -@item no-create - If the file does not already exist, it is not created; - instead, an exception with condition type @code{&i/o-file-does-not-exist} - is raised. - If the file already exists, the exception with condition type - @code{&i/o-file-already-exists} is not raised - and the file is truncated to zero length. -@item no-fail - If the file already exists, the exception with condition type - @code{&i/o-file-already-exists} is not raised, - even if @code{no-create} is not included, - and the file is truncated to zero length. -@item no-truncate - If the file already exists and the exception with condition type - @code{&i/o-file-already-exists} has been inhibited by inclusion of - @code{no-create} or @code{no-fail}, the file is not truncated, but - the port's current position is still set to the beginning of the - file. -@end table - -These options have no effect when a file is opened only for input. -Symbols other than those listed above may be used as -@var{file-options-symbol}s; they have implementation-specific meaning, -if any. - -@quotation Note - Only the name of @var{file-options-symbol} is significant. -@end quotation +@code{char-ready?} exists to make it possible for a +program to accept characters from interactive ports without +getting stuck waiting for input. Any input editors associated +with such ports must make sure that characters whose existence +has been asserted by @code{char-ready?} cannot be rubbed out. +If @code{char-ready?} were to return @code{#f} at end of file, +a port at end of file would be indistinguishable from an +interactive port that has no ready characters. @end deffn -@node R6RS Buffer Modes -@subsubsection Buffer Modes - -Each port has an associated buffer mode. For an output port, the -buffer mode defines when an output operation flushes the buffer -associated with the output port. For an input port, the buffer mode -defines how much data will be read to satisfy read operations. The -possible buffer modes are the symbols @code{none} for no buffering, -@code{line} for flushing upon line endings and reading up to line -endings, or other implementation-dependent behavior, -and @code{block} for arbitrary buffering. This section uses -the parameter name @var{buffer-mode} for arguments that must be -buffer-mode symbols. - -If two ports are connected to the same mutable source, both ports -are unbuffered, and reading a byte or character from that shared -source via one of the two ports would change the bytes or characters -seen via the other port, a lookahead operation on one port will -render the peeked byte or character inaccessible via the other port, -while a subsequent read operation on the peeked port will see the -peeked byte or character even though the port is otherwise unbuffered. - -In other words, the semantics of buffering is defined in terms of side -effects on shared mutable sources, and a lookahead operation has the -same side effect on the shared source as a read operation. - -@deffn {Scheme Syntax} buffer-mode @var{buffer-mode-symbol} - -@var{buffer-mode-symbol} must be a symbol whose name is one of -@code{none}, @code{line}, and @code{block}. The result is the -corresponding symbol, and specifies the associated buffer mode. - -@quotation Note - Only the name of @var{buffer-mode-symbol} is significant. -@end quotation +@rnindex read-char +@deffn {Scheme Procedure} read-char [port] +@deffnx {C Function} scm_read_char (port) +Return the next character available from @var{port}, updating @var{port} +to point to the following character. If no more characters are +available, the end-of-file object is returned. A decoding error, if +any, is handled in accordance with the port's conversion strategy. @end deffn -@deffn {Scheme Procedure} buffer-mode? obj -Returns @code{#t} if the argument is a valid buffer-mode symbol, and -returns @code{#f} otherwise. +@rnindex peek-char +@deffn {Scheme Procedure} peek-char [port] +@deffnx {C Function} scm_peek_char (port) +Return the next character available from @var{port}, +@emph{without} updating @var{port} to point to the following +character. If no more characters are available, the +end-of-file object is returned. + +The value returned by +a call to @code{peek-char} is the same as the value that would +have been returned by a call to @code{read-char} on the same +port. The only difference is that the very next call to +@code{read-char} or @code{peek-char} on that @var{port} will +return the value returned by the preceding call to +@code{peek-char}. In particular, a call to @code{peek-char} on +an interactive port will hang waiting for input whenever a call +to @code{read-char} would have hung. + +As for @code{read-char}, decoding errors are handled in accordance with +the port's conversion strategy. @end deffn -@node R6RS Transcoders -@subsubsection Transcoders -@cindex codec -@cindex end-of-line style -@cindex transcoder -@cindex binary port -@cindex textual port - -Several different Unicode encoding schemes describe standard ways to -encode characters and strings as byte sequences and to decode those -sequences. Within this document, a @dfn{codec} is an immutable Scheme -object that represents a Unicode or similar encoding scheme. - -An @dfn{end-of-line style} is a symbol that, if it is not @code{none}, -describes how a textual port transcodes representations of line endings. - -A @dfn{transcoder} is an immutable Scheme object that combines a codec -with an end-of-line style and a method for handling decoding errors. -Each transcoder represents some specific bidirectional (but not -necessarily lossless), possibly stateful translation between byte -sequences and Unicode characters and strings. Every transcoder can -operate in the input direction (bytes to characters) or in the output -direction (characters to bytes). A @var{transcoder} parameter name -means that the corresponding argument must be a transcoder. - -A @dfn{binary port} is a port that supports binary I/O, does not have an -associated transcoder and does not support textual I/O. A @dfn{textual -port} is a port that supports textual I/O, and does not support binary -I/O. A textual port may or may not have an associated transcoder. - -@deffn {Scheme Procedure} latin-1-codec -@deffnx {Scheme Procedure} utf-8-codec -@deffnx {Scheme Procedure} utf-16-codec - -These are predefined codecs for the ISO 8859-1, UTF-8, and UTF-16 -encoding schemes. - -A call to any of these procedures returns a value that is equal in the -sense of @code{eqv?} to the result of any other call to the same -procedure. +@deffn {Scheme Procedure} unread-char cobj [port] +@deffnx {C Function} scm_unread_char (cobj, port) +Place character @var{cobj} in @var{port} so that it will be read by the +next read operation. If called multiple times, the unread characters +will be read again in last-in first-out order. If @var{port} is +not supplied, the current input port is used. @end deffn -@deffn {Scheme Syntax} eol-style @var{eol-style-symbol} - -@var{eol-style-symbol} should be a symbol whose name is one of -@code{lf}, @code{cr}, @code{crlf}, @code{nel}, @code{crnel}, @code{ls}, -and @code{none}. - -The form evaluates to the corresponding symbol. If the name of -@var{eol-style-symbol} is not one of these symbols, the effect and -result are implementation-dependent; in particular, the result may be an -eol-style symbol acceptable as an @var{eol-style} argument to -@code{make-transcoder}. Otherwise, an exception is raised. - -All eol-style symbols except @code{none} describe a specific -line-ending encoding: - -@table @code -@item lf -linefeed -@item cr -carriage return -@item crlf -carriage return, linefeed -@item nel -next line -@item crnel -carriage return, next line -@item ls -line separator -@end table - -For a textual port with a transcoder, and whose transcoder has an -eol-style symbol @code{none}, no conversion occurs. For a textual input -port, any eol-style symbol other than @code{none} means that all of the -above line-ending encodings are recognized and are translated into a -single linefeed. For a textual output port, @code{none} and @code{lf} -are equivalent. Linefeed characters are encoded according to the -specified eol-style symbol, and all other characters that participate in -possible line endings are encoded as is. - -@quotation Note - Only the name of @var{eol-style-symbol} is significant. -@end quotation +@deffn {Scheme Procedure} unread-string str port +@deffnx {C Function} scm_unread_string (str, port) +Place the string @var{str} in @var{port} so that its characters will +be read from left-to-right as the next characters from @var{port} +during subsequent read operations. If called multiple times, the +unread characters will be read again in last-in first-out order. If +@var{port} is not supplied, the @code{current-input-port} is used. @end deffn -@deffn {Scheme Procedure} native-eol-style -Returns the default end-of-line style of the underlying platform, e.g., -@code{lf} on Unix and @code{crlf} on Windows. +@rnindex newline +@deffn {Scheme Procedure} newline [port] +@deffnx {C Function} scm_newline (port) +Send a newline to @var{port}. +If @var{port} is omitted, send to the current output port. @end deffn -@deffn {Condition Type} &i/o-decoding -@deffnx {Scheme Procedure} make-i/o-decoding-error port -@deffnx {Scheme Procedure} i/o-decoding-error? obj - -This condition type could be defined by - -@lisp -(define-condition-type &i/o-decoding &i/o-port - make-i/o-decoding-error i/o-decoding-error?) -@end lisp - -An exception with this type is raised when one of the operations for -textual input from a port encounters a sequence of bytes that cannot be -translated into a character or string by the input direction of the -port's transcoder. - -When such an exception is raised, the port's position is past the -invalid encoding. +@rnindex write-char +@deffn {Scheme Procedure} write-char chr [port] +@deffnx {C Function} scm_write_char (chr, port) +Send character @var{chr} to @var{port}. @end deffn -@deffn {Condition Type} &i/o-encoding -@deffnx {Scheme Procedure} make-i/o-encoding-error port char -@deffnx {Scheme Procedure} i/o-encoding-error? obj -@deffnx {Scheme Procedure} i/o-encoding-error-char condition - -This condition type could be defined by - -@lisp -(define-condition-type &i/o-encoding &i/o-port - make-i/o-encoding-error i/o-encoding-error? - (char i/o-encoding-error-char)) -@end lisp - -An exception with this type is raised when one of the operations for -textual output to a port encounters a character that cannot be -translated into bytes by the output direction of the port's transcoder. -@var{char} is the character that could not be encoded. -@end deffn - -@deffn {Scheme Syntax} error-handling-mode @var{error-handling-mode-symbol} - -@var{error-handling-mode-symbol} should be a symbol whose name is one of -@code{ignore}, @code{raise}, and @code{replace}. The form evaluates to -the corresponding symbol. If @var{error-handling-mode-symbol} is not -one of these identifiers, effect and result are -implementation-dependent: The result may be an error-handling-mode -symbol acceptable as a @var{handling-mode} argument to -@code{make-transcoder}. If it is not acceptable as a -@var{handling-mode} argument to @code{make-transcoder}, an exception is -raised. - -@quotation Note - Only the name of @var{error-handling-mode-symbol} is significant. -@end quotation - -The error-handling mode of a transcoder specifies the behavior -of textual I/O operations in the presence of encoding or decoding -errors. - -If a textual input operation encounters an invalid or incomplete -character encoding, and the error-handling mode is @code{ignore}, an -appropriate number of bytes of the invalid encoding are ignored and -decoding continues with the following bytes. - -If the error-handling mode is @code{replace}, the replacement -character U+FFFD is injected into the data stream, an appropriate -number of bytes are ignored, and decoding -continues with the following bytes. - -If the error-handling mode is @code{raise}, an exception with condition -type @code{&i/o-decoding} is raised. - -If a textual output operation encounters a character it cannot encode, -and the error-handling mode is @code{ignore}, the character is ignored -and encoding continues with the next character. If the error-handling -mode is @code{replace}, a codec-specific replacement character is -emitted by the transcoder, and encoding continues with the next -character. The replacement character is U+FFFD for transcoders whose -codec is one of the Unicode encodings, but is the @code{?} character -for the Latin-1 encoding. If the error-handling mode is @code{raise}, -an exception with condition type @code{&i/o-encoding} is raised. -@end deffn - -@deffn {Scheme Procedure} make-transcoder codec -@deffnx {Scheme Procedure} make-transcoder codec eol-style -@deffnx {Scheme Procedure} make-transcoder codec eol-style handling-mode - -@var{codec} must be a codec; @var{eol-style}, if present, an eol-style -symbol; and @var{handling-mode}, if present, an error-handling-mode -symbol. - -@var{eol-style} may be omitted, in which case it defaults to the native -end-of-line style of the underlying platform. @var{handling-mode} may -be omitted, in which case it defaults to @code{replace}. The result is -a transcoder with the behavior specified by its arguments. -@end deffn - -@deffn {Scheme procedure} native-transcoder -Returns an implementation-dependent transcoder that represents a -possibly locale-dependent ``native'' transcoding. -@end deffn - -@deffn {Scheme Procedure} transcoder-codec transcoder -@deffnx {Scheme Procedure} transcoder-eol-style transcoder -@deffnx {Scheme Procedure} transcoder-error-handling-mode transcoder - -These are accessors for transcoder objects; when applied to a -transcoder returned by @code{make-transcoder}, they return the -@var{codec}, @var{eol-style}, and @var{handling-mode} arguments, -respectively. -@end deffn - -@deffn {Scheme Procedure} bytevector->string bytevector transcoder - -Returns the string that results from transcoding the -@var{bytevector} according to the input direction of the transcoder. -@end deffn - -@deffn {Scheme Procedure} string->bytevector string transcoder - -Returns the bytevector that results from transcoding the -@var{string} according to the output direction of the transcoder. -@end deffn - -@node R6RS End-of-File -@subsubsection The End-of-File Object - -@cindex EOF -@cindex end-of-file - -R5RS' @code{eof-object?} procedure is provided by the @code{(rnrs io -ports)} module: - -@deffn {Scheme Procedure} eof-object? obj -@deffnx {C Function} scm_eof_object_p (obj) -Return true if @var{obj} is the end-of-file (EOF) object. -@end deffn - -In addition, the following procedure is provided: - -@deffn {Scheme Procedure} eof-object -@deffnx {C Function} scm_eof_object () -Return the end-of-file (EOF) object. - -@lisp -(eof-object? (eof-object)) -@result{} #t -@end lisp -@end deffn - - -@node R6RS Port Manipulation -@subsubsection Port Manipulation - -The procedures listed below operate on any kind of R6RS I/O port. - -@deffn {Scheme Procedure} port? obj -Returns @code{#t} if the argument is a port, and returns @code{#f} -otherwise. -@end deffn - -@deffn {Scheme Procedure} port-transcoder port -Returns the transcoder associated with @var{port} if @var{port} is -textual and has an associated transcoder, and returns @code{#f} if -@var{port} is binary or does not have an associated transcoder. -@end deffn - -@deffn {Scheme Procedure} binary-port? port -Return @code{#t} if @var{port} is a @dfn{binary port}, suitable for -binary data input/output. - -Note that internally Guile does not differentiate between binary and -textual ports, unlike the R6RS. Thus, this procedure returns true when -@var{port} does not have an associated encoding---i.e., when -@code{(port-encoding @var{port})} is @code{#f} (@pxref{Ports, -port-encoding}). This is the case for ports returned by R6RS procedures -such as @code{open-bytevector-input-port} and -@code{make-custom-binary-output-port}. - -However, Guile currently does not prevent use of textual I/O procedures -such as @code{display} or @code{read-char} with binary ports. Doing so -``upgrades'' the port from binary to textual, under the ISO-8859-1 -encoding. Likewise, Guile does not prevent use of -@code{set-port-encoding!} on a binary port, which also turns it into a -``textual'' port. -@end deffn - -@deffn {Scheme Procedure} textual-port? port -Always return @code{#t}, as all ports can be used for textual I/O in -Guile. -@end deffn - -@deffn {Scheme Procedure} transcoded-port binary-port transcoder -The @code{transcoded-port} procedure -returns a new textual port with the specified @var{transcoder}. -Otherwise the new textual port's state is largely the same as -that of @var{binary-port}. -If @var{binary-port} is an input port, the new textual -port will be an input port and -will transcode the bytes that have not yet been read from -@var{binary-port}. -If @var{binary-port} is an output port, the new textual -port will be an output port and -will transcode output characters into bytes that are -written to the byte sink represented by @var{binary-port}. - -As a side effect, however, @code{transcoded-port} -closes @var{binary-port} in -a special way that allows the new textual port to continue to -use the byte source or sink represented by @var{binary-port}, -even though @var{binary-port} itself is closed and cannot -be used by the input and output operations described in this -chapter. -@end deffn - -@deffn {Scheme Procedure} port-position port -If @var{port} supports it (see below), return the offset (an integer) -indicating where the next octet will be read from/written to in -@var{port}. If @var{port} does not support this operation, an error -condition is raised. - -This is similar to Guile's @code{seek} procedure with the -@code{SEEK_CUR} argument (@pxref{Random Access}). -@end deffn - -@deffn {Scheme Procedure} port-has-port-position? port -Return @code{#t} is @var{port} supports @code{port-position}. -@end deffn - -@deffn {Scheme Procedure} set-port-position! port offset -If @var{port} supports it (see below), set the position where the next -octet will be read from/written to @var{port} to @var{offset} (an -integer). If @var{port} does not support this operation, an error -condition is raised. - -This is similar to Guile's @code{seek} procedure with the -@code{SEEK_SET} argument (@pxref{Random Access}). -@end deffn - -@deffn {Scheme Procedure} port-has-set-port-position!? port -Return @code{#t} is @var{port} supports @code{set-port-position!}. -@end deffn - -@deffn {Scheme Procedure} call-with-port port proc -Call @var{proc}, passing it @var{port} and closing @var{port} upon exit -of @var{proc}. Return the return values of @var{proc}. -@end deffn - -@node R6RS Input Ports -@subsubsection Input Ports - -@deffn {Scheme Procedure} input-port? obj -Returns @code{#t} if the argument is an input port (or a combined input -and output port), and returns @code{#f} otherwise. -@end deffn - -@deffn {Scheme Procedure} port-eof? input-port -Returns @code{#t} -if the @code{lookahead-u8} procedure (if @var{input-port} is a binary port) -or the @code{lookahead-char} procedure (if @var{input-port} is a textual port) -would return -the end-of-file object, and @code{#f} otherwise. -The operation may block indefinitely if no data is available -but the port cannot be determined to be at end of file. -@end deffn - -@deffn {Scheme Procedure} open-file-input-port filename -@deffnx {Scheme Procedure} open-file-input-port filename file-options -@deffnx {Scheme Procedure} open-file-input-port filename file-options buffer-mode -@deffnx {Scheme Procedure} open-file-input-port filename file-options buffer-mode maybe-transcoder -@var{maybe-transcoder} must be either a transcoder or @code{#f}. - -The @code{open-file-input-port} procedure returns an -input port for the named file. The @var{file-options} and -@var{maybe-transcoder} arguments are optional. - -The @var{file-options} argument, which may determine -various aspects of the returned port (@pxref{R6RS File Options}), -defaults to the value of @code{(file-options)}. - -The @var{buffer-mode} argument, if supplied, -must be one of the symbols that name a buffer mode. -The @var{buffer-mode} argument defaults to @code{block}. - -If @var{maybe-transcoder} is a transcoder, it becomes the transcoder associated -with the returned port. - -If @var{maybe-transcoder} is @code{#f} or absent, -the port will be a binary port and will support the -@code{port-position} and @code{set-port-position!} operations. -Otherwise the port will be a textual port, and whether it supports -the @code{port-position} and @code{set-port-position!} operations -is implementation-dependent (and possibly transcoder-dependent). -@end deffn - -@deffn {Scheme Procedure} standard-input-port -Returns a fresh binary input port connected to standard input. Whether -the port supports the @code{port-position} and @code{set-port-position!} -operations is implementation-dependent. -@end deffn - -@deffn {Scheme Procedure} current-input-port -This returns a default textual port for input. Normally, this default -port is associated with standard input, but can be dynamically -re-assigned using the @code{with-input-from-file} procedure from the -@code{io simple (6)} library (@pxref{rnrs io simple}). The port may or -may not have an associated transcoder; if it does, the transcoder is -implementation-dependent. -@end deffn - -@node R6RS Binary Input -@subsubsection Binary Input - -@cindex binary input - -R6RS binary input ports can be created with the procedures described -below. - -@deffn {Scheme Procedure} open-bytevector-input-port bv [transcoder] -@deffnx {C Function} scm_open_bytevector_input_port (bv, transcoder) -Return an input port whose contents are drawn from bytevector @var{bv} -(@pxref{Bytevectors}). - -@c FIXME: Update description when implemented. -The @var{transcoder} argument is currently not supported. -@end deffn - -@cindex custom binary input ports - -@deffn {Scheme Procedure} make-custom-binary-input-port id read! get-position set-position! close -@deffnx {C Function} scm_make_custom_binary_input_port (id, read!, get-position, set-position!, close) -Return a new custom binary input port@footnote{This is similar in spirit -to Guile's @dfn{soft ports} (@pxref{Soft Ports}).} named @var{id} (a -string) whose input is drained by invoking @var{read!} and passing it a -bytevector, an index where bytes should be written, and the number of -bytes to read. The @code{read!} procedure must return an integer -indicating the number of bytes read, or @code{0} to indicate the -end-of-file. - -Optionally, if @var{get-position} is not @code{#f}, it must be a thunk -that will be called when @code{port-position} is invoked on the custom -binary port and should return an integer indicating the position within -the underlying data stream; if @var{get-position} was not supplied, the -returned port does not support @code{port-position}. - -Likewise, if @var{set-position!} is not @code{#f}, it should be a -one-argument procedure. When @code{set-port-position!} is invoked on the -custom binary input port, @var{set-position!} is passed an integer -indicating the position of the next byte is to read. - -Finally, if @var{close} is not @code{#f}, it must be a thunk. It is -invoked when the custom binary input port is closed. - -The returned port is fully buffered by default, but its buffering mode -can be changed using @code{setvbuf} (@pxref{Buffering}). - -Using a custom binary input port, the @code{open-bytevector-input-port} -procedure could be implemented as follows: - -@lisp -(define (open-bytevector-input-port source) - (define position 0) - (define length (bytevector-length source)) - - (define (read! bv start count) - (let ((count (min count (- length position)))) - (bytevector-copy! source position - bv start count) - (set! position (+ position count)) - count)) - - (define (get-position) position) - - (define (set-position! new-position) - (set! position new-position)) - - (make-custom-binary-input-port "the port" read! - get-position - set-position!)) - -(read (open-bytevector-input-port (string->utf8 "hello"))) -@result{} hello -@end lisp -@end deffn - -@cindex binary input -Binary input is achieved using the procedures below: - -@deffn {Scheme Procedure} get-u8 port -@deffnx {C Function} scm_get_u8 (port) -Return an octet read from @var{port}, a binary input port, blocking as -necessary, or the end-of-file object. -@end deffn - -@deffn {Scheme Procedure} lookahead-u8 port -@deffnx {C Function} scm_lookahead_u8 (port) -Like @code{get-u8} but does not update @var{port}'s position to point -past the octet. -@end deffn - -@deffn {Scheme Procedure} get-bytevector-n port count -@deffnx {C Function} scm_get_bytevector_n (port, count) -Read @var{count} octets from @var{port}, blocking as necessary and -return a bytevector containing the octets read. If fewer bytes are -available, a bytevector smaller than @var{count} is returned. -@end deffn - -@deffn {Scheme Procedure} get-bytevector-n! port bv start count -@deffnx {C Function} scm_get_bytevector_n_x (port, bv, start, count) -Read @var{count} bytes from @var{port} and store them in @var{bv} -starting at index @var{start}. Return either the number of bytes -actually read or the end-of-file object. -@end deffn - -@deffn {Scheme Procedure} get-bytevector-some port -@deffnx {C Function} scm_get_bytevector_some (port) -Read from @var{port}, blocking as necessary, until bytes are available -or an end-of-file is reached. Return either the end-of-file object or a -new bytevector containing some of the available bytes (at least one), -and update the port position to point just past these bytes. -@end deffn - -@deffn {Scheme Procedure} get-bytevector-all port -@deffnx {C Function} scm_get_bytevector_all (port) -Read from @var{port}, blocking as necessary, until the end-of-file is -reached. Return either a new bytevector containing the data read or the -end-of-file object (if no data were available). -@end deffn - -The @code{(ice-9 binary-ports)} module provides the following procedure -as an extension to @code{(rnrs io ports)}: - -@deffn {Scheme Procedure} unget-bytevector port bv [start [count]] -@deffnx {C Function} scm_unget_bytevector (port, bv, start, count) -Place the contents of @var{bv} in @var{port}, optionally starting at -index @var{start} and limiting to @var{count} octets, so that its bytes -will be read from left-to-right as the next bytes from @var{port} during -subsequent read operations. If called multiple times, the unread bytes -will be read again in last-in first-out order. -@end deffn - -@node R6RS Textual Input -@subsubsection Textual Input - -@deffn {Scheme Procedure} get-char textual-input-port -Reads from @var{textual-input-port}, blocking as necessary, until a -complete character is available from @var{textual-input-port}, -or until an end of file is reached. - -If a complete character is available before the next end of file, -@code{get-char} returns that character and updates the input port to -point past the character. If an end of file is reached before any -character is read, @code{get-char} returns the end-of-file object. -@end deffn - -@deffn {Scheme Procedure} lookahead-char textual-input-port -The @code{lookahead-char} procedure is like @code{get-char}, but it does -not update @var{textual-input-port} to point past the character. -@end deffn - -@deffn {Scheme Procedure} get-string-n textual-input-port count - -@var{count} must be an exact, non-negative integer object, representing -the number of characters to be read. - -The @code{get-string-n} procedure reads from @var{textual-input-port}, -blocking as necessary, until @var{count} characters are available, or -until an end of file is reached. - -If @var{count} characters are available before end of file, -@code{get-string-n} returns a string consisting of those @var{count} -characters. If fewer characters are available before an end of file, but -one or more characters can be read, @code{get-string-n} returns a string -containing those characters. In either case, the input port is updated -to point just past the characters read. If no characters can be read -before an end of file, the end-of-file object is returned. -@end deffn - -@deffn {Scheme Procedure} get-string-n! textual-input-port string start count - -@var{start} and @var{count} must be exact, non-negative integer objects, -with @var{count} representing the number of characters to be read. -@var{string} must be a string with at least $@var{start} + @var{count}$ -characters. - -The @code{get-string-n!} procedure reads from @var{textual-input-port} -in the same manner as @code{get-string-n}. If @var{count} characters -are available before an end of file, they are written into @var{string} -starting at index @var{start}, and @var{count} is returned. If fewer -characters are available before an end of file, but one or more can be -read, those characters are written into @var{string} starting at index -@var{start} and the number of characters actually read is returned as an -exact integer object. If no characters can be read before an end of -file, the end-of-file object is returned. -@end deffn - -@deffn {Scheme Procedure} get-string-all textual-input-port -Reads from @var{textual-input-port} until an end of file, decoding -characters in the same manner as @code{get-string-n} and -@code{get-string-n!}. - -If characters are available before the end of file, a string containing -all the characters decoded from that data are returned. If no character -precedes the end of file, the end-of-file object is returned. -@end deffn - -@deffn {Scheme Procedure} get-line textual-input-port -Reads from @var{textual-input-port} up to and including the linefeed -character or end of file, decoding characters in the same manner as -@code{get-string-n} and @code{get-string-n!}. - -If a linefeed character is read, a string containing all of the text up -to (but not including) the linefeed character is returned, and the port -is updated to point just past the linefeed character. If an end of file -is encountered before any linefeed character is read, but some -characters have been read and decoded as characters, a string containing -those characters is returned. If an end of file is encountered before -any characters are read, the end-of-file object is returned. - -@quotation Note - The end-of-line style, if not @code{none}, will cause all line endings - to be read as linefeed characters. @xref{R6RS Transcoders}. -@end quotation -@end deffn - -@deffn {Scheme Procedure} get-datum textual-input-port count -Reads an external representation from @var{textual-input-port} and returns the -datum it represents. The @code{get-datum} procedure returns the next -datum that can be parsed from the given @var{textual-input-port}, updating -@var{textual-input-port} to point exactly past the end of the external -representation of the object. - -Any @emph{interlexeme space} (comment or whitespace, @pxref{Scheme -Syntax}) in the input is first skipped. If an end of file occurs after -the interlexeme space, the end-of-file object (@pxref{R6RS End-of-File}) -is returned. - -If a character inconsistent with an external representation is -encountered in the input, an exception with condition types -@code{&lexical} and @code{&i/o-read} is raised. Also, if the end of -file is encountered after the beginning of an external representation, -but the external representation is incomplete and therefore cannot be -parsed, an exception with condition types @code{&lexical} and -@code{&i/o-read} is raised. -@end deffn - -@node R6RS Output Ports -@subsubsection Output Ports - -@deffn {Scheme Procedure} output-port? obj -Returns @code{#t} if the argument is an output port (or a -combined input and output port), @code{#f} otherwise. -@end deffn - -@deffn {Scheme Procedure} flush-output-port port -Flushes any buffered output from the buffer of @var{output-port} to the -underlying file, device, or object. The @code{flush-output-port} -procedure returns an unspecified values. -@end deffn - -@deffn {Scheme Procedure} open-file-output-port filename -@deffnx {Scheme Procedure} open-file-output-port filename file-options -@deffnx {Scheme Procedure} open-file-output-port filename file-options buffer-mode -@deffnx {Scheme Procedure} open-file-output-port filename file-options buffer-mode maybe-transcoder - -@var{maybe-transcoder} must be either a transcoder or @code{#f}. - -The @code{open-file-output-port} procedure returns an output port for the named file. - -The @var{file-options} argument, which may determine various aspects of -the returned port (@pxref{R6RS File Options}), defaults to the value of -@code{(file-options)}. - -The @var{buffer-mode} argument, if supplied, -must be one of the symbols that name a buffer mode. -The @var{buffer-mode} argument defaults to @code{block}. - -If @var{maybe-transcoder} is a transcoder, it becomes the transcoder -associated with the port. - -If @var{maybe-transcoder} is @code{#f} or absent, -the port will be a binary port and will support the -@code{port-position} and @code{set-port-position!} operations. -Otherwise the port will be a textual port, and whether it supports -the @code{port-position} and @code{set-port-position!} operations -is implementation-dependent (and possibly transcoder-dependent). -@end deffn - -@deffn {Scheme Procedure} standard-output-port -@deffnx {Scheme Procedure} standard-error-port -Returns a fresh binary output port connected to the standard output or -standard error respectively. Whether the port supports the -@code{port-position} and @code{set-port-position!} operations is -implementation-dependent. -@end deffn - -@deffn {Scheme Procedure} current-output-port -@deffnx {Scheme Procedure} current-error-port -These return default textual ports for regular output and error output. -Normally, these default ports are associated with standard output, and -standard error, respectively. The return value of -@code{current-output-port} can be dynamically re-assigned using the -@code{with-output-to-file} procedure from the @code{io simple (6)} -library (@pxref{rnrs io simple}). A port returned by one of these -procedures may or may not have an associated transcoder; if it does, the -transcoder is implementation-dependent. -@end deffn - -@node R6RS Binary Output -@subsubsection Binary Output - -Binary output ports can be created with the procedures below. - -@deffn {Scheme Procedure} open-bytevector-output-port [transcoder] -@deffnx {C Function} scm_open_bytevector_output_port (transcoder) -Return two values: a binary output port and a procedure. The latter -should be called with zero arguments to obtain a bytevector containing -the data accumulated by the port, as illustrated below. - -@lisp -(call-with-values - (lambda () - (open-bytevector-output-port)) - (lambda (port get-bytevector) - (display "hello" port) - (get-bytevector))) - -@result{} #vu8(104 101 108 108 111) -@end lisp - -@c FIXME: Update description when implemented. -The @var{transcoder} argument is currently not supported. -@end deffn - -@cindex custom binary output ports - -@deffn {Scheme Procedure} make-custom-binary-output-port id write! get-position set-position! close -@deffnx {C Function} scm_make_custom_binary_output_port (id, write!, get-position, set-position!, close) -Return a new custom binary output port named @var{id} (a string) whose -output is sunk by invoking @var{write!} and passing it a bytevector, an -index where bytes should be read from this bytevector, and the number of -bytes to be ``written''. The @code{write!} procedure must return an -integer indicating the number of bytes actually written; when it is -passed @code{0} as the number of bytes to write, it should behave as -though an end-of-file was sent to the byte sink. - -The other arguments are as for @code{make-custom-binary-input-port} -(@pxref{R6RS Binary Input, @code{make-custom-binary-input-port}}). -@end deffn - -@cindex binary output -Writing to a binary output port can be done using the following -procedures: - -@deffn {Scheme Procedure} put-u8 port octet -@deffnx {C Function} scm_put_u8 (port, octet) -Write @var{octet}, an integer in the 0--255 range, to @var{port}, a -binary output port. -@end deffn - -@deffn {Scheme Procedure} put-bytevector port bv [start [count]] -@deffnx {C Function} scm_put_bytevector (port, bv, start, count) -Write the contents of @var{bv} to @var{port}, optionally starting at -index @var{start} and limiting to @var{count} octets. -@end deffn - -@node R6RS Textual Output -@subsubsection Textual Output - -@deffn {Scheme Procedure} put-char port char -Writes @var{char} to the port. The @code{put-char} procedure returns -an unspecified value. -@end deffn - -@deffn {Scheme Procedure} put-string port string -@deffnx {Scheme Procedure} put-string port string start -@deffnx {Scheme Procedure} put-string port string start count - -@var{start} and @var{count} must be non-negative exact integer objects. -@var{string} must have a length of at least @math{@var{start} + -@var{count}}. @var{start} defaults to 0. @var{count} defaults to -@math{@code{(string-length @var{string})} - @var{start}}$. The -@code{put-string} procedure writes the @var{count} characters of -@var{string} starting at index @var{start} to the port. The -@code{put-string} procedure returns an unspecified value. -@end deffn - -@deffn {Scheme Procedure} put-datum textual-output-port datum -@var{datum} should be a datum value. The @code{put-datum} procedure -writes an external representation of @var{datum} to -@var{textual-output-port}. The specific external representation is -implementation-dependent. However, whenever possible, an implementation -should produce a representation for which @code{get-datum}, when reading -the representation, will return an object equal (in the sense of -@code{equal?}) to @var{datum}. - -@quotation Note - Not all datums may allow producing an external representation for which - @code{get-datum} will produce an object that is equal to the - original. Specifically, NaNs contained in @var{datum} may make - this impossible. -@end quotation - -@quotation Note - The @code{put-datum} procedure merely writes the external - representation, but no trailing delimiter. If @code{put-datum} is - used to write several subsequent external representations to an - output port, care should be taken to delimit them properly so they can - be read back in by subsequent calls to @code{get-datum}. -@end quotation -@end deffn +@node Using Ports from C +@subsection Using Ports from C + +@deftypefn {C Function} size_t scm_c_read (SCM port, void *buffer, size_t size) +Read up to @var{size} bytes from @var{port} and store them in +@var{buffer}. The return value is the number of bytes actually read, +which can be less than @var{size} if end-of-file has been reached. + +Note that this function does not update @code{port-line} and +@code{port-column} below. +@end deftypefn + +@deftypefn {C Function} void scm_c_write (SCM port, const void *buffer, size_t size) +Write @var{size} bytes at @var{buffer} to @var{port}. + +Note that this function does not update @code{port-line} and +@code{port-column} (@pxref{Textual I/O}). +@end deftypefn + +@deftypefn {C Function} void scm_lfwrite (const char *buffer, size_t size, SCM port) +Write @var{size} bytes at @var{buffer} to @var{port}. The @code{lf} +indicates that unlike @code{scm_c_write}, this function updates the +port's @code{port-line} and @code{port-column}, and also flushes the +port if the data contains a newline (@code{\n}) and the port is +line-buffered. +@end deftypefn @node I/O Extensions @subsection Implementing New Port Types in C @@ -2371,7 +1813,7 @@ for a prototype of an asynchronous I/O and concurrency facility. @node BOM Handling -@subsection Handling of Unicode byte order marks. +@subsection Handling of Unicode Byte Order Marks @cindex BOM @cindex byte order mark diff --git a/doc/ref/api-options.texi b/doc/ref/api-options.texi index b09ae8952..152bf4693 100644 --- a/doc/ref/api-options.texi +++ b/doc/ref/api-options.texi @@ -241,7 +241,7 @@ procedures (@pxref{Arrays}). @item char-ready? Indicates that the @code{char-ready?} function is available -(@pxref{Reading}). +(@pxref{Venerable Port Interfaces}). @item complex Indicates support for complex numbers. diff --git a/doc/ref/misc-modules.texi b/doc/ref/misc-modules.texi index c1e65d7e3..c3978c8f0 100644 --- a/doc/ref/misc-modules.texi +++ b/doc/ref/misc-modules.texi @@ -47,7 +47,7 @@ follows, @table @asis @item @nicode{#:display?} @var{flag} If @var{flag} is true then print using @code{display}. The default is -@code{#f} which means use @code{write} style. (@pxref{Writing}) +@code{#f} which means use @code{write} style. @xref{Scheme Write}. @item @nicode{#:per-line-prefix} @var{string} Print the given @var{string} as a prefix on each line. The default is @@ -106,7 +106,7 @@ follows, @table @asis @item @nicode{#:display?} @var{flag} If @var{flag} is true then print using @code{display}. The default is -@code{#f} which means use @code{write} style. (@pxref{Writing}) +@code{#f} which means use @code{write} style. @pxref{Scheme Write}. @item @nicode{#:width} @var{columns} Print within the given @var{columns}. The default is 79. @@ -204,7 +204,7 @@ Object output. Parameters: @var{minwidth}, @var{padinc}, @var{minpad}, @var{padchar}. @nicode{~a} outputs an argument like @code{display}, @nicode{~s} -outputs an argument like @code{write} (@pxref{Writing}). +outputs an argument like @code{write} (@pxref{Scheme Write}). @example (format #t "~a" "foo") @print{} foo @@ -242,9 +242,9 @@ no minimum or multiple). Character. Parameter: @var{charnum}. Output a character. The default is to simply output, as per -@code{write-char} (@pxref{Writing}). @nicode{~@@c} prints in -@code{write} style. @nicode{~:c} prints control characters (ASCII 0 -to 31) in @nicode{^X} form. +@code{write-char} (@pxref{Venerable Port Interfaces}). @nicode{~@@c} +prints in @code{write} style. @nicode{~:c} prints control characters +(ASCII 0 to 31) in @nicode{^X} form. @example (format #t "~c" #\z) @print{} z @@ -760,8 +760,9 @@ already so. (format #f "a~3,5'*@@tx") @result{} "a****x" @end example -@nicode{~t} is implemented using @code{port-column} (@pxref{Reading}), -so it works even there has been other output before @code{format}. +@nicode{~t} is implemented using @code{port-column} (@pxref{Textual +I/O}), so it works even there has been other output before +@code{format}. @item @nicode{~~} Tilde character. Parameter: @var{n}. @@ -815,7 +816,7 @@ Output a formfeed character, or @var{n} many if a parameter is given. Force output. No parameters. At the end of output, call @code{force-output} to flush any buffers on -the destination (@pxref{Writing}). @nicode{~!} can occur anywhere in +the destination (@pxref{Buffering}). @nicode{~!} can occur anywhere in the format string, but the force is done at the end of output. When output is to a string (destination @code{#f}), @nicode{~!} does @@ -1112,10 +1113,10 @@ originating format, or similar. @sp 1 Guile contains a @code{format} procedure even when the module @code{(ice-9 format)} is not loaded. The default @code{format} is -@code{simple-format} (@pxref{Writing}), it doesn't support all escape -sequences documented in this section, and will signal an error if you -try to use one of them. The reason for two versions is that the full -@code{format} is fairly large and requires some time to load. +@code{simple-format} (@pxref{Simple Output}), it doesn't support all +escape sequences documented in this section, and will signal an error if +you try to use one of them. The reason for two versions is that the +full @code{format} is fairly large and requires some time to load. @code{simple-format} is often adequate too. @@ -1661,10 +1662,10 @@ returned. @end deffn @deffn {Scheme Procedure} port->stream port readproc -Return a stream which is the values obtained by reading from -@var{port} using @var{readproc}. Each read call is -@code{(@var{readproc} @var{port})}, and it should return an EOF object -(@pxref{Reading}) at the end of input. +Return a stream which is the values obtained by reading from @var{port} +using @var{readproc}. Each read call is @code{(@var{readproc} +@var{port})}, and it should return an EOF object (@pxref{Binary I/O}) at +the end of input. For example a stream of characters from a file, diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 8a8ab388e..edcff9dc2 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -303,7 +303,7 @@ a port. @deffn {Scheme Procedure} close fd_or_port @deffnx {C Function} scm_close (fd_or_port) -Similar to @code{close-port} (@pxref{Closing, close-port}), +Similar to @code{close-port} (@pxref{Ports, close-port}), but also works on file descriptors. A side effect of closing a file descriptor is that any ports using that file descriptor are moved to a different file descriptor and have @@ -2320,8 +2320,8 @@ terminate, and return the wait status code. The status is as per it can reap a pipe's child process, causing an error from a subsequent @code{close-pipe}. -@code{close-port} (@pxref{Closing}) can close a pipe, but it doesn't -reap the child process. +@code{close-port} (@pxref{Ports}) can close a pipe, but it doesn't reap +the child process. The garbage collector will close a pipe no longer in use, and reap the child process with @code{waitpid}. If the child hasn't yet terminated diff --git a/doc/ref/r6rs.texi b/doc/ref/r6rs.texi index e5ffb78e4..a12964ed2 100644 --- a/doc/ref/r6rs.texi +++ b/doc/ref/r6rs.texi @@ -97,9 +97,9 @@ The @code{(rnrs io ports)} module is incomplete. Work is ongoing to fix this. @item -Guile does not prevent use of textual I/O procedures on binary ports. -More generally, it does not make a sharp distinction between binary and -textual ports (@pxref{R6RS Port Manipulation, binary-port?}). +Guile does not prevent use of textual I/O procedures on binary ports, or +vice versa. All ports in Guile support both binary and textual I/O. +@xref{Encoding}, for full details. @item Guile's implementation of @code{equal?} may fail to terminate when @@ -147,8 +147,10 @@ Language Scheme}). * rnrs exceptions:: Handling exceptional situations. * rnrs conditions:: Data structures for exceptions. -* I/O Conditions:: Predefined I/O error types. +* R6RS I/O Conditions:: Predefined I/O error types. +* R6RS Transcoders:: Characters and bytes. * rnrs io ports:: Support for port-based I/O. +* R6RS File Ports:: Working with files. * rnrs io simple:: High-level I/O API. * rnrs files:: Functions for working with files. @@ -1343,7 +1345,7 @@ A subtype of @code{&violation} that indicates a reference to an unbound identifier. @end deffn -@node I/O Conditions +@node R6RS I/O Conditions @subsubsection I/O Conditions These condition types are exported by both the @@ -1420,21 +1422,547 @@ A subtype of @code{&i/o}; represents an error related to an operation on the port @var{port}. @end deffn +@node R6RS Transcoders +@subsubsection Transcoders +@cindex codec +@cindex end-of-line style +@cindex transcoder +@cindex binary port +@cindex textual port + +The transcoder facilities are exported by @code{(rnrs io ports)}. + +Several different Unicode encoding schemes describe standard ways to +encode characters and strings as byte sequences and to decode those +sequences. Within this document, a @dfn{codec} is an immutable Scheme +object that represents a Unicode or similar encoding scheme. + +An @dfn{end-of-line style} is a symbol that, if it is not @code{none}, +describes how a textual port transcodes representations of line endings. + +A @dfn{transcoder} is an immutable Scheme object that combines a codec +with an end-of-line style and a method for handling decoding errors. +Each transcoder represents some specific bidirectional (but not +necessarily lossless), possibly stateful translation between byte +sequences and Unicode characters and strings. Every transcoder can +operate in the input direction (bytes to characters) or in the output +direction (characters to bytes). A @var{transcoder} parameter name +means that the corresponding argument must be a transcoder. + +A @dfn{binary port} is a port that supports binary I/O, does not have an +associated transcoder and does not support textual I/O. A @dfn{textual +port} is a port that supports textual I/O, and does not support binary +I/O. A textual port may or may not have an associated transcoder. + +@deffn {Scheme Procedure} latin-1-codec +@deffnx {Scheme Procedure} utf-8-codec +@deffnx {Scheme Procedure} utf-16-codec + +These are predefined codecs for the ISO 8859-1, UTF-8, and UTF-16 +encoding schemes. + +A call to any of these procedures returns a value that is equal in the +sense of @code{eqv?} to the result of any other call to the same +procedure. +@end deffn + +@deffn {Scheme Syntax} eol-style @var{eol-style-symbol} + +@var{eol-style-symbol} should be a symbol whose name is one of +@code{lf}, @code{cr}, @code{crlf}, @code{nel}, @code{crnel}, @code{ls}, +and @code{none}. + +The form evaluates to the corresponding symbol. If the name of +@var{eol-style-symbol} is not one of these symbols, the effect and +result are implementation-dependent; in particular, the result may be an +eol-style symbol acceptable as an @var{eol-style} argument to +@code{make-transcoder}. Otherwise, an exception is raised. + +All eol-style symbols except @code{none} describe a specific +line-ending encoding: + +@table @code +@item lf +linefeed +@item cr +carriage return +@item crlf +carriage return, linefeed +@item nel +next line +@item crnel +carriage return, next line +@item ls +line separator +@end table + +For a textual port with a transcoder, and whose transcoder has an +eol-style symbol @code{none}, no conversion occurs. For a textual input +port, any eol-style symbol other than @code{none} means that all of the +above line-ending encodings are recognized and are translated into a +single linefeed. For a textual output port, @code{none} and @code{lf} +are equivalent. Linefeed characters are encoded according to the +specified eol-style symbol, and all other characters that participate in +possible line endings are encoded as is. + +@quotation Note + Only the name of @var{eol-style-symbol} is significant. +@end quotation +@end deffn + +@deffn {Scheme Procedure} native-eol-style +Returns the default end-of-line style of the underlying platform, e.g., +@code{lf} on Unix and @code{crlf} on Windows. +@end deffn + +@deffn {Condition Type} &i/o-decoding +@deffnx {Scheme Procedure} make-i/o-decoding-error port +@deffnx {Scheme Procedure} i/o-decoding-error? obj +This condition type could be defined by + +@lisp +(define-condition-type &i/o-decoding &i/o-port + make-i/o-decoding-error i/o-decoding-error?) +@end lisp + +An exception with this type is raised when one of the operations for +textual input from a port encounters a sequence of bytes that cannot be +translated into a character or string by the input direction of the +port's transcoder. + +When such an exception is raised, the port's position is past the +invalid encoding. +@end deffn + +@deffn {Condition Type} &i/o-encoding +@deffnx {Scheme Procedure} make-i/o-encoding-error port char +@deffnx {Scheme Procedure} i/o-encoding-error? obj +@deffnx {Scheme Procedure} i/o-encoding-error-char condition +This condition type could be defined by + +@lisp +(define-condition-type &i/o-encoding &i/o-port + make-i/o-encoding-error i/o-encoding-error? + (char i/o-encoding-error-char)) +@end lisp + +An exception with this type is raised when one of the operations for +textual output to a port encounters a character that cannot be +translated into bytes by the output direction of the port's transcoder. +@var{char} is the character that could not be encoded. +@end deffn + +@deffn {Scheme Syntax} error-handling-mode @var{error-handling-mode-symbol} +@var{error-handling-mode-symbol} should be a symbol whose name is one of +@code{ignore}, @code{raise}, and @code{replace}. The form evaluates to +the corresponding symbol. If @var{error-handling-mode-symbol} is not +one of these identifiers, effect and result are +implementation-dependent: The result may be an error-handling-mode +symbol acceptable as a @var{handling-mode} argument to +@code{make-transcoder}. If it is not acceptable as a +@var{handling-mode} argument to @code{make-transcoder}, an exception is +raised. + +@quotation Note + Only the name of @var{error-handling-mode-symbol} is significant. +@end quotation + +The error-handling mode of a transcoder specifies the behavior +of textual I/O operations in the presence of encoding or decoding +errors. + +If a textual input operation encounters an invalid or incomplete +character encoding, and the error-handling mode is @code{ignore}, an +appropriate number of bytes of the invalid encoding are ignored and +decoding continues with the following bytes. + +If the error-handling mode is @code{replace}, the replacement +character U+FFFD is injected into the data stream, an appropriate +number of bytes are ignored, and decoding +continues with the following bytes. + +If the error-handling mode is @code{raise}, an exception with condition +type @code{&i/o-decoding} is raised. + +If a textual output operation encounters a character it cannot encode, +and the error-handling mode is @code{ignore}, the character is ignored +and encoding continues with the next character. If the error-handling +mode is @code{replace}, a codec-specific replacement character is +emitted by the transcoder, and encoding continues with the next +character. The replacement character is U+FFFD for transcoders whose +codec is one of the Unicode encodings, but is the @code{?} character +for the Latin-1 encoding. If the error-handling mode is @code{raise}, +an exception with condition type @code{&i/o-encoding} is raised. +@end deffn + +@deffn {Scheme Procedure} make-transcoder codec +@deffnx {Scheme Procedure} make-transcoder codec eol-style +@deffnx {Scheme Procedure} make-transcoder codec eol-style handling-mode +@var{codec} must be a codec; @var{eol-style}, if present, an eol-style +symbol; and @var{handling-mode}, if present, an error-handling-mode +symbol. + +@var{eol-style} may be omitted, in which case it defaults to the native +end-of-line style of the underlying platform. @var{handling-mode} may +be omitted, in which case it defaults to @code{replace}. The result is +a transcoder with the behavior specified by its arguments. +@end deffn + +@deffn {Scheme procedure} native-transcoder +Returns an implementation-dependent transcoder that represents a +possibly locale-dependent ``native'' transcoding. +@end deffn + +@deffn {Scheme Procedure} transcoder-codec transcoder +@deffnx {Scheme Procedure} transcoder-eol-style transcoder +@deffnx {Scheme Procedure} transcoder-error-handling-mode transcoder +These are accessors for transcoder objects; when applied to a +transcoder returned by @code{make-transcoder}, they return the +@var{codec}, @var{eol-style}, and @var{handling-mode} arguments, +respectively. +@end deffn + +@deffn {Scheme Procedure} bytevector->string bytevector transcoder +Returns the string that results from transcoding the +@var{bytevector} according to the input direction of the transcoder. +@end deffn + +@deffn {Scheme Procedure} string->bytevector string transcoder +Returns the bytevector that results from transcoding the +@var{string} according to the output direction of the transcoder. +@end deffn + @node rnrs io ports @subsubsection rnrs io ports -The @code{(rnrs io ports (6))} library provides various procedures and -syntactic forms for use in writing to and reading from ports. This -functionality is documented in its own section of the manual; -(@pxref{R6RS I/O Ports}). +@cindex R6RS +@cindex R6RS ports +Guile's binary and textual port interface was heavily inspired by R6RS, +so many R6RS port interfaces are documented elsewhere. Note that R6RS +ports are not disjoint from Guile's native ports, so Guile-specific +procedures will work on ports created using the R6RS API, and vice +versa. Also note that in Guile, all ports are both textual and binary. +@xref{Input and Output}, for more on Guile's core port API. The R6RS +ports module wraps Guile's I/O routines in a helper that will translate +native Guile exceptions to R6RS conditions; @xref{R6RS I/O Conditions}, +for more. @xref{R6RS File Ports}, for documentation on the R6RS file +port interface. + +@c FIXME: Update description when implemented. +@emph{Note}: The implementation of this R6RS API is not complete yet. + +@deffn {Scheme Procedure} eof-object? obj +@xref{Binary I/O}, for documentation. +@end deffn + +@deffn {Scheme Procedure} eof-object +Return the end-of-file (EOF) object. + +@lisp +(eof-object? (eof-object)) +@result{} #t +@end lisp +@end deffn + +@deffn {Scheme Procedure} port? obj +@deffnx {Scheme Procedure} input-port? obj +@deffnx {Scheme Procedure} output-port? obj +@xref{Ports}, for documentation. +@end deffn + +@deffn {Scheme Procedure} port-transcoder port +Return a transcoder associated with the encoding of @var{port}. +@xref{Encoding}, and @xref{R6RS Transcoders}. +@end deffn + +@deffn {Scheme Procedure} binary-port? port +@deffnx {Scheme Procedure} textual-port? port +Return @code{#t}, as all ports in Guile are suitable for binary and +textual I/O. @xref{Encoding}, for more details. +@end deffn + +@deffn {Scheme Procedure} transcoded-port binary-port transcoder +The @code{transcoded-port} procedure +returns a new textual port with the specified @var{transcoder}. +Otherwise the new textual port's state is largely the same as +that of @var{binary-port}. +If @var{binary-port} is an input port, the new textual +port will be an input port and +will transcode the bytes that have not yet been read from +@var{binary-port}. +If @var{binary-port} is an output port, the new textual +port will be an output port and +will transcode output characters into bytes that are +written to the byte sink represented by @var{binary-port}. + +As a side effect, however, @code{transcoded-port} +closes @var{binary-port} in +a special way that allows the new textual port to continue to +use the byte source or sink represented by @var{binary-port}, +even though @var{binary-port} itself is closed and cannot +be used by the input and output operations described in this +chapter. +@end deffn + +@deffn {Scheme Procedure} port-position port +Equivalent to @code{(seek @var{port} SEEK_CUR 0)}. @xref{Random +Access}. +@end deffn + +@deffn {Scheme Procedure} port-has-port-position? port +Return @code{#t} is @var{port} supports @code{port-position}. +@end deffn + +@deffn {Scheme Procedure} set-port-position! port offset +Equivalent to @code{(seek @var{port} SEEK_SET @var{offset})}. +@xref{Random Access}. +@end deffn + +@deffn {Scheme Procedure} port-has-set-port-position!? port +Return @code{#t} is @var{port} supports @code{set-port-position!}. +@end deffn + +@deffn {Scheme Procedure} call-with-port port proc +Call @var{proc}, passing it @var{port} and closing @var{port} upon exit +of @var{proc}. Return the return values of @var{proc}. +@end deffn + +@deffn {Scheme Procedure} port-eof? input-port +Equivalent to @code{(eof-object? (lookahead-u8 @var{input-port}))}. +@end deffn + +@deffn {Scheme Procedure} standard-input-port +@deffnx {Scheme Procedure} standard-output-port +@deffnx {Scheme Procedure} standard-error-port +Returns a fresh binary input port connected to standard input, or a +binary output port connected to the standard output or standard error, +respectively. Whether the port supports the @code{port-position} and +@code{set-port-position!} operations is implementation-dependent. +@end deffn + +@deffn {Scheme Procedure} current-input-port +@deffnx {Scheme Procedure} current-output-port +@deffnx {Scheme Procedure} current-error-port +@xref{Default Ports}. +@end deffn + +@deffn {Scheme Procedure} open-bytevector-input-port bv [transcoder] +@deffnx {Scheme Procedure} open-bytevector-output-port [transcoder] +@xref{Bytevector Ports}. +@end deffn + +@deffn {Scheme Procedure} make-custom-binary-input-port id read! get-position set-position! close +@deffnx {Scheme Procedure} make-custom-binary-output-port id write! get-position set-position! close +@xref{Custom Ports}. +@end deffn + +@deffn {Scheme Procedure} get-u8 port +@deffnx {Scheme Procedure} lookahead-u8 port +@deffnx {Scheme Procedure} get-bytevector-n port count +@deffnx {Scheme Procedure} get-bytevector-n! port bv start count +@deffnx {Scheme Procedure} get-bytevector-some port +@deffnx {Scheme Procedure} get-bytevector-all port +@deffnx {Scheme Procedure} put-u8 port octet +@deffnx {Scheme Procedure} put-bytevector port bv [start [count]] +@xref{Binary I/O}. +@end deffn + +@deffn {Scheme Procedure} get-char textual-input-port +@deffnx {Scheme Procedure} lookahead-char textual-input-port +@deffnx {Scheme Procedure} get-string-n textual-input-port count +@deffnx {Scheme Procedure} get-string-n! textual-input-port string start count +@deffnx {Scheme Procedure} get-string-all textual-input-port +@deffnx {Scheme Procedure} get-line textual-input-port +@deffnx {Scheme Procedure} put-char port char +@deffnx {Scheme Procedure} put-string port string [start [count]] +@xref{Textual I/O}. +@end deffn + +@deffn {Scheme Procedure} get-datum textual-input-port count +Reads an external representation from @var{textual-input-port} and returns the +datum it represents. The @code{get-datum} procedure returns the next +datum that can be parsed from the given @var{textual-input-port}, updating +@var{textual-input-port} to point exactly past the end of the external +representation of the object. + +Any @emph{interlexeme space} (comment or whitespace, @pxref{Scheme +Syntax}) in the input is first skipped. If an end of file occurs after +the interlexeme space, the end-of-file object is returned. + +If a character inconsistent with an external representation is +encountered in the input, an exception with condition types +@code{&lexical} and @code{&i/o-read} is raised. Also, if the end of +file is encountered after the beginning of an external representation, +but the external representation is incomplete and therefore cannot be +parsed, an exception with condition types @code{&lexical} and +@code{&i/o-read} is raised. +@end deffn + +@deffn {Scheme Procedure} put-datum textual-output-port datum +@var{datum} should be a datum value. The @code{put-datum} procedure +writes an external representation of @var{datum} to +@var{textual-output-port}. The specific external representation is +implementation-dependent. However, whenever possible, an implementation +should produce a representation for which @code{get-datum}, when reading +the representation, will return an object equal (in the sense of +@code{equal?}) to @var{datum}. + +@quotation Note + Not all datums may allow producing an external representation for which + @code{get-datum} will produce an object that is equal to the + original. Specifically, NaNs contained in @var{datum} may make + this impossible. +@end quotation + +@quotation Note + The @code{put-datum} procedure merely writes the external + representation, but no trailing delimiter. If @code{put-datum} is + used to write several subsequent external representations to an + output port, care should be taken to delimit them properly so they can + be read back in by subsequent calls to @code{get-datum}. +@end quotation +@end deffn + +@deffn {Scheme Procedure} flush-output-port port +@xref{Buffering}, for documentation on @code{force-output}. +@end deffn + +@node R6RS File Ports +@subsubsection R6RS File Ports + +The facilities described in this section are exported by the @code{(rnrs +io ports)} module. + +@deffn {Scheme Syntax} buffer-mode @var{buffer-mode-symbol} +@var{buffer-mode-symbol} must be a symbol whose name is one of +@code{none}, @code{line}, and @code{block}. The result is the +corresponding symbol, and specifies the associated buffer mode. +@xref{Buffering}, for a discussion of these different buffer modes. To +control the amount of buffering, use @code{setvbuf} instead. Note that +only the name of @var{buffer-mode-symbol} is significant. + +@xref{Buffering}, for a discussion of port buffering. +@end deffn + +@deffn {Scheme Procedure} buffer-mode? obj +Returns @code{#t} if the argument is a valid buffer-mode symbol, and +returns @code{#f} otherwise. +@end deffn + +When opening a file, the various procedures accept a @code{file-options} +object that encapsulates flags to specify how the file is to be +opened. A @code{file-options} object is an enum-set (@pxref{rnrs enums}) +over the symbols constituting valid file options. + +A @var{file-options} parameter name means that the corresponding +argument must be a file-options object. + +@deffn {Scheme Syntax} file-options @var{file-options-symbol} ... + +Each @var{file-options-symbol} must be a symbol. + +The @code{file-options} syntax returns a file-options object that +encapsulates the specified options. + +When supplied to an operation that opens a file for output, the +file-options object returned by @code{(file-options)} specifies that the +file is created if it does not exist and an exception with condition +type @code{&i/o-file-already-exists} is raised if it does exist. The +following standard options can be included to modify the default +behavior. + +@table @code +@item no-create + If the file does not already exist, it is not created; + instead, an exception with condition type @code{&i/o-file-does-not-exist} + is raised. + If the file already exists, the exception with condition type + @code{&i/o-file-already-exists} is not raised + and the file is truncated to zero length. +@item no-fail + If the file already exists, the exception with condition type + @code{&i/o-file-already-exists} is not raised, + even if @code{no-create} is not included, + and the file is truncated to zero length. +@item no-truncate + If the file already exists and the exception with condition type + @code{&i/o-file-already-exists} has been inhibited by inclusion of + @code{no-create} or @code{no-fail}, the file is not truncated, but + the port's current position is still set to the beginning of the + file. +@end table + +These options have no effect when a file is opened only for input. +Symbols other than those listed above may be used as +@var{file-options-symbol}s; they have implementation-specific meaning, +if any. + +@quotation Note + Only the name of @var{file-options-symbol} is significant. +@end quotation +@end deffn + +@deffn {Scheme Procedure} open-file-input-port filename +@deffnx {Scheme Procedure} open-file-input-port filename file-options +@deffnx {Scheme Procedure} open-file-input-port filename file-options buffer-mode +@deffnx {Scheme Procedure} open-file-input-port filename file-options buffer-mode maybe-transcoder +@var{maybe-transcoder} must be either a transcoder or @code{#f}. + +The @code{open-file-input-port} procedure returns an +input port for the named file. The @var{file-options} and +@var{maybe-transcoder} arguments are optional. + +The @var{file-options} argument, which may determine various aspects of +the returned port, defaults to the value of @code{(file-options)}. + +The @var{buffer-mode} argument, if supplied, +must be one of the symbols that name a buffer mode. +The @var{buffer-mode} argument defaults to @code{block}. + +If @var{maybe-transcoder} is a transcoder, it becomes the transcoder associated +with the returned port. + +If @var{maybe-transcoder} is @code{#f} or absent, +the port will be a binary port and will support the +@code{port-position} and @code{set-port-position!} operations. +Otherwise the port will be a textual port, and whether it supports +the @code{port-position} and @code{set-port-position!} operations +is implementation-dependent (and possibly transcoder-dependent). +@end deffn + +@deffn {Scheme Procedure} open-file-output-port filename +@deffnx {Scheme Procedure} open-file-output-port filename file-options +@deffnx {Scheme Procedure} open-file-output-port filename file-options buffer-mode +@deffnx {Scheme Procedure} open-file-output-port filename file-options buffer-mode maybe-transcoder +@var{maybe-transcoder} must be either a transcoder or @code{#f}. + +The @code{open-file-output-port} procedure returns an output port for the named file. + +The @var{file-options} argument, which may determine various aspects of +the returned port, defaults to the value of @code{(file-options)}. + +The @var{buffer-mode} argument, if supplied, +must be one of the symbols that name a buffer mode. +The @var{buffer-mode} argument defaults to @code{block}. + +If @var{maybe-transcoder} is a transcoder, it becomes the transcoder +associated with the port. + +If @var{maybe-transcoder} is @code{#f} or absent, +the port will be a binary port and will support the +@code{port-position} and @code{set-port-position!} operations. +Otherwise the port will be a textual port, and whether it supports +the @code{port-position} and @code{set-port-position!} operations +is implementation-dependent (and possibly transcoder-dependent). +@end deffn @node rnrs io simple @subsubsection rnrs io simple The @code{(rnrs io simple (6))} library provides convenience functions for performing textual I/O on ports. This library also exports all of -the condition types and associated procedures described in (@pxref{I/O -Conditions}). In the context of this section, when stating that a +the condition types and associated procedures described in (@pxref{R6RS +I/O Conditions}). In the context of this section, when stating that a procedure behaves ``identically'' to the corresponding procedure in Guile's core library, this is modulo the behavior wrt. conditions: such procedures raise the appropriate R6RS conditions in case of error, but @@ -1451,9 +1979,8 @@ appropriate R6RS conditions. @deffn {Scheme Procedure} eof-object @deffnx {Scheme Procedure} eof-object? obj -These procedures are identical to the ones provided by the -@code{(rnrs io ports (6))} library. @xref{R6RS I/O Ports}, for -documentation. +These procedures are identical to the ones provided by the @code{(rnrs +io ports (6))} library. @xref{rnrs io ports}, for documentation. @end deffn @deffn {Scheme Procedure} input-port? obj @@ -1474,8 +2001,8 @@ library. @xref{File Ports}, for documentation. @deffn {Scheme Procedure} close-input-port input-port @deffnx {Scheme Procedure} close-output-port output-port -These procedures are identical to the ones provided by Guile's core -library. @xref{Closing}, for documentation. +Closes the given @var{input-port} or @var{output-port}. These are +legacy interfaces; just use @code{close-port}. @end deffn @deffn {Scheme Procedure} peek-char @@ -1483,7 +2010,7 @@ library. @xref{Closing}, for documentation. @deffnx {Scheme Procedure} read-char @deffnx {Scheme Procedure} read-char textual-input-port These procedures are identical to the ones provided by Guile's core -library. @xref{Reading}, for documentation. +library. @xref{Venerable Port Interfaces}, for documentation. @end deffn @deffn {Scheme Procedure} read @@ -1500,8 +2027,9 @@ This procedure is identical to the one provided by Guile's core library. @deffnx {Scheme Procedure} write obj textual-output-port @deffnx {Scheme Procedure} write-char char @deffnx {Scheme Procedure} write-char char textual-output-port -These procedures are identical to the ones provided by Guile's core -library. @xref{Writing}, for documentation. +These procedures are identical to the ones provided by Guile's core +library. @xref{Venerable Port Interfaces}, and @xref{Scheme Write}, for +documentation. @end deffn @node rnrs files diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index c890d7dd1..463592e82 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -3302,8 +3302,8 @@ Insert a newline. Insert a tilde. @end table -This procedure is the same as calling @code{simple-format} (@pxref{Writing}) -with @code{#f} as the destination. +This procedure is the same as calling @code{simple-format} +(@pxref{Simple Output}) with @code{#f} as the destination. @end deffn @node SRFI-30 From c7c11f3af9774a07d885dad1eb0c653ab4b45ef7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 9 Jun 2016 10:45:54 +0200 Subject: [PATCH 366/865] Update port documentation, rename sports to suspendable ports * module/ice-9/suspendable-ports.scm: Rename from ice-9/sports.scm, and adapt module names. Remove exports that are not related to the suspendable ports facility; we want people to continue using the port operations from their original locations. Add put-string to the replacement list. * module/Makefile.am: Adapt to rename. * test-suite/tests/suspendable-ports.test: Rename from sports.test. * test-suite/Makefile.am: Adapt to rename. * module/ice-9/textual-ports.scm (unget-char, unget-string): New functions. * doc/ref/api-io.texi (Textual I/O, Simple Output): Flesh out documentation. (Line/Delimited): Undocument write-line, read-string, and read-string!. This is handled by (ice-9 textual-ports). (Bytevector Ports): Fix duplicated section. (String Ports): Move the note about encodings down to the end. (Custom Ports): Add explanatory text. Remove mention of C functions; they should use the C port interface. (Venerable Port Interfaces): Add text, and make documentation refer to recommended interfaces. (Using Ports from C): Add documentation. (Non-Blocking I/O): Document more fully and adapt to suspendable-ports name change. --- doc/ref/api-io.texi | 404 ++++++++---------- module/Makefile.am | 2 +- .../{sports.scm => suspendable-ports.scm} | 32 +- module/ice-9/textual-ports.scm | 13 + test-suite/Makefile.am | 2 +- .../{sports.test => suspendable-ports.test} | 6 +- 6 files changed, 214 insertions(+), 245 deletions(-) rename module/ice-9/{sports.scm => suspendable-ports.scm} (97%) rename test-suite/tests/{sports.test => suspendable-ports.test} (94%) diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index c0518d71a..9b32c8728 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -489,20 +489,24 @@ the port is unbuffered. The @code{put-string} procedure returns an unspecified value. @end deffn +Textual ports have a textual position associated with them: a line and a +column. Reading in characters or writing them out advances the line and +the column appropriately. + @deffn {Scheme Procedure} port-column port @deffnx {Scheme Procedure} port-line port @deffnx {C Function} scm_port_column (port) @deffnx {C Function} scm_port_line (port) Return the current column number or line number of @var{port}. -If the number is -unknown, the result is #f. Otherwise, the result is a 0-origin integer -- i.e.@: the first character of the first line is line 0, column 0. -(However, when you display a file position, for example in an error -message, we recommend you add 1 to get 1-origin integers. This is -because lines and column numbers traditionally start with 1, and that is -what non-programmers will find most natural.) @end deffn +Port lines and positions are represented as 0-origin integers, which is +to say that the the first character of the first line is line 0, column +0. However, when you display a line number, for example in an error +message, we recommend you add 1 to get 1-origin integers. This is +because lines numbers traditionally start with 1, and that is what +non-programmers will find most natural. + @deffn {Scheme Procedure} set-port-column! port column @deffnx {Scheme Procedure} set-port-line! port line @deffnx {C Function} scm_set_port_column_x (port, column) @@ -513,6 +517,9 @@ Set the current column or line number of @var{port}. @node Simple Output @subsection Simple Textual Output +Guile exports a simple formatted output function, @code{simple-format}. +For a more capable formatted output facility, @xref{Formatted Output}. + @deffn {Scheme Procedure} simple-format destination message . args @deffnx {C Function} scm_simple_format (destination, message, args) Write @var{message} to @var{destination}, defaulting to the current @@ -524,7 +531,11 @@ current output port, if @var{destination} is @code{#f}, then return a string containing the formatted text. Does not add a trailing newline. @end deffn -pk / peek +Somewhat confusingly, Guile binds the @code{format} identifier to +@code{simple-format} at startup. Once @code{(ice-9 format)} loads, it +actually replaces the core @code{format} binding, so depending on +whether you or a module you use has loaded @code{(ice-9 format)}, you +may be using the simple or the more capable version. @node Buffering @subsection Buffering @@ -728,11 +739,8 @@ The delimited-I/O module can be accessed with: @end lisp It can be used to read or write lines of text, or read text delimited by -a specified set of characters. It's similar to the @code{(scsh rdelim)} -module from guile-scsh, but does not use multiple values or character -sets and has an extra procedure @code{write-line}. +a specified set of characters. -@c begin (scm-doc-string "rdelim.scm" "read-line") @deffn {Scheme Procedure} read-line [port] [handle-delim] Return a line of text from @var{port} if specified, otherwise from the value returned by @code{(current-input-port)}. Under Unix, a line of text @@ -755,21 +763,19 @@ terminating delimiter or end-of-file object. @end table @end deffn -@c begin (scm-doc-string "rdelim.scm" "read-line!") @deffn {Scheme Procedure} read-line! buf [port] Read a line of text into the supplied string @var{buf} and return the number of characters added to @var{buf}. If @var{buf} is filled, then -@code{#f} is returned. -Read from @var{port} if -specified, otherwise from the value returned by @code{(current-input-port)}. +@code{#f} is returned. Read from @var{port} if specified, otherwise +from the value returned by @code{(current-input-port)}. @end deffn -@c begin (scm-doc-string "rdelim.scm" "read-delimited") @deffn {Scheme Procedure} read-delimited delims [port] [handle-delim] -Read text until one of the characters in the string @var{delims} is found -or end-of-file is reached. Read from @var{port} if supplied, otherwise -from the value returned by @code{(current-input-port)}. -@var{handle-delim} takes the same values as described for @code{read-line}. +Read text until one of the characters in the string @var{delims} is +found or end-of-file is reached. Read from @var{port} if supplied, +otherwise from the value returned by @code{(current-input-port)}. +@var{handle-delim} takes the same values as described for +@code{read-line}. @end deffn @c begin (scm-doc-string "rdelim.scm" "read-delimited!") @@ -787,48 +793,6 @@ buffer was full, @code{#f} is returned. It's something of a wacky interface, to be honest. @end deffn -@deffn {Scheme Procedure} write-line obj [port] -@deffnx {C Function} scm_write_line (obj, port) -Display @var{obj} and a newline character to @var{port}. If -@var{port} is not specified, @code{(current-output-port)} is -used. This function is equivalent to: -@lisp -(display obj [port]) -(newline [port]) -@end lisp -@end deffn - -In the past, Guile did not have a procedure that would just read out all -of the characters from a port. As a workaround, many people just called -@code{read-delimited} with no delimiters, knowing that would produce the -behavior they wanted. This prompted Guile developers to add some -routines that would read all characters from a port. So it is that -@code{(ice-9 rdelim)} is also the home for procedures that can reading -undelimited text: - -@deffn {Scheme Procedure} read-string [port] [count] -Read all of the characters out of @var{port} and return them as a -string. If the @var{count} is present, treat it as a limit to the -number of characters to read. - -By default, read from the current input port, with no size limit on the -result. This procedure always returns a string, even if no characters -were read. -@end deffn - -@deffn {Scheme Procedure} read-string! buf [port] [start] [end] -Fill @var{buf} with characters read from @var{port}, defaulting to the -current input port. Return the number of characters read. - -If @var{start} or @var{end} are specified, store data only into the -substring of @var{str} bounded by @var{start} and @var{end} (which -default to the beginning and end of the string, respectively). -@end deffn - -Some of the aforementioned I/O functions rely on the following C -primitives. These will mainly be of interest to people hacking Guile -internals. - @deffn {Scheme Procedure} %read-delimited! delims str gobble [port [start [end]]] @deffnx {C Function} scm_read_delimited_x (delims, str, gobble, port, start, end) Read characters from @var{port} into @var{str} until one of the @@ -1131,7 +1095,7 @@ used only during port creation are not retained. Return the filename associated with @var{port}, or @code{#f} if no filename is associated with the port. -@var{port} must be open, @code{port-filename} cannot be used once the +@var{port} must be open; @code{port-filename} cannot be used once the port is closed. @end deffn @@ -1161,64 +1125,6 @@ Return an input port whose contents are drawn from bytevector @var{bv} The @var{transcoder} argument is currently not supported. @end deffn -@cindex custom binary input ports - -@deffn {Scheme Procedure} make-custom-binary-input-port id read! get-position set-position! close -@deffnx {C Function} scm_make_custom_binary_input_port (id, read!, get-position, set-position!, close) -Return a new custom binary input port@footnote{This is similar in spirit -to Guile's @dfn{soft ports} (@pxref{Soft Ports}).} named @var{id} (a -string) whose input is drained by invoking @var{read!} and passing it a -bytevector, an index where bytes should be written, and the number of -bytes to read. The @code{read!} procedure must return an integer -indicating the number of bytes read, or @code{0} to indicate the -end-of-file. - -Optionally, if @var{get-position} is not @code{#f}, it must be a thunk -that will be called when @code{port-position} is invoked on the custom -binary port and should return an integer indicating the position within -the underlying data stream; if @var{get-position} was not supplied, the -returned port does not support @code{port-position}. - -Likewise, if @var{set-position!} is not @code{#f}, it should be a -one-argument procedure. When @code{set-port-position!} is invoked on the -custom binary input port, @var{set-position!} is passed an integer -indicating the position of the next byte is to read. - -Finally, if @var{close} is not @code{#f}, it must be a thunk. It is -invoked when the custom binary input port is closed. - -The returned port is fully buffered by default, but its buffering mode -can be changed using @code{setvbuf} (@pxref{Buffering}). - -Using a custom binary input port, the @code{open-bytevector-input-port} -procedure could be implemented as follows: - -@lisp -(define (open-bytevector-input-port source) - (define position 0) - (define length (bytevector-length source)) - - (define (read! bv start count) - (let ((count (min count (- length position)))) - (bytevector-copy! source position - bv start count) - (set! position (+ position count)) - count)) - - (define (get-position) position) - - (define (set-position! new-position) - (set! position new-position)) - - (make-custom-binary-input-port "the port" read! - get-position - set-position!)) - -(read (open-bytevector-input-port (string->utf8 "hello"))) -@result{} hello -@end lisp -@end deffn - @deffn {Scheme Procedure} open-bytevector-output-port [transcoder] @deffnx {C Function} scm_open_bytevector_output_port (transcoder) Return two values: a binary output port and a procedure. The latter @@ -1246,16 +1152,6 @@ The @var{transcoder} argument is currently not supported. @cindex String port @cindex Port, string -The following allow string ports to be opened by analogy to R4RS -file port facilities: - -With string ports, the port-encoding is treated differently than other -types of ports. When string ports are created, they do not inherit a -character encoding from the current locale. They are given a -default locale that allows them to handle all valid string characters. -Typically one should not modify a string port's character encoding -away from its default. - @deffn {Scheme Procedure} call-with-output-string proc @deffnx {C Function} scm_call_with_output_string (proc) Calls the one-argument procedure @var{proc} with a newly created output @@ -1309,20 +1205,25 @@ output to the port so far. closed the string cannot be obtained. @end deffn -A string port can be used in many procedures which accept a port -but which are not dependent on implementation details of fports. -E.g., seeking and truncating will work on a string port, -but trying to extract the file descriptor number will fail. +With string ports, the port-encoding is treated differently than other +types of ports. When string ports are created, they do not inherit a +character encoding from the current locale. They are given a +default locale that allows them to handle all valid string characters. +Typically one should not modify a string port's character encoding +away from its default. @xref{Encoding}. @node Custom Ports @subsubsection Custom Ports -(ice-9 binary-ports), binary and text... +Custom ports allow the user to provide input and handle output via +user-supplied procedures. Guile currently only provides custom binary +ports, not textual ports; for custom textual ports, @xref{Soft Ports}. +We should add the R6RS custom textual port interfaces though. +Contributions are appreciated. @cindex custom binary input ports @deffn {Scheme Procedure} make-custom-binary-input-port id read! get-position set-position! close -@deffnx {C Function} scm_make_custom_binary_input_port (id, read!, get-position, set-position!, close) Return a new custom binary input port@footnote{This is similar in spirit to Guile's @dfn{soft ports} (@pxref{Soft Ports}).} named @var{id} (a string) whose input is drained by invoking @var{read!} and passing it a @@ -1379,7 +1280,6 @@ procedure (@pxref{Bytevector Ports}) could be implemented as follows: @cindex custom binary output ports @deffn {Scheme Procedure} make-custom-binary-output-port id write! get-position set-position! close -@deffnx {C Function} scm_make_custom_binary_output_port (id, write!, get-position, set-position!, close) Return a new custom binary output port named @var{id} (a string) whose output is sunk by invoking @var{write!} and passing it a bytevector, an index where bytes should be read from this bytevector, and the number of @@ -1397,11 +1297,10 @@ The other arguments are as for @code{make-custom-binary-input-port}. @cindex Soft port @cindex Port, soft -A @dfn{soft-port} is a port based on a vector of procedures capable of +A @dfn{soft port} is a port based on a vector of procedures capable of accepting or delivering characters. It allows emulation of I/O ports. @deffn {Scheme Procedure} make-soft-port pv modes -@deffnx {C Function} scm_make_soft_port (pv, modes) Return a port capable of receiving or delivering characters as specified by the @var{modes} string (@pxref{File Ports, open-file}). @var{pv} must be a vector of length 5 or 6. Its @@ -1469,9 +1368,34 @@ documentation for @code{open-file} in @ref{File Ports}. @node Venerable Port Interfaces @subsection Venerable Port Interfaces +Over the 25 years or so that Guile has been around, its port system has +evolved, adding many useful features. At the same time there have been +four major Scheme standards released in those 25 years, which also +evolve the common Scheme understanding of what a port interface should +be. Alas, it would be too much to ask for all of these evolutionary +branches to be consistent. Some of Guile's original interfaces don't +mesh with the later Scheme standards, and yet Guile can't just drop old +interfaces. Sadly as well, the R6RS and R7RS standards both part from a +base of R5RS, but end up in different and somewhat incompatible designs. + +Guile's approach is to pick a set of port primitives that make sense +together. We document that set of primitives, design our internal +interfaces around them, and recommend them to users. As the R6RS I/O +system is the most capable standard that Scheme has yet produced in this +domain, we mostly recommend that; @code{(ice-9 binary-ports)} and +@code{(ice-9 textual-ports)} are wholly modelled on @code{(rnrs io +ports)}. Guile does not wholly copy R6RS, however; @xref{R6RS +Incompatibilities}. + +At the same time, we have many venerable port interfaces, lore handed +down to us from our hacker ancestors. Most of these interfaces even +predate the expectation that Scheme should have modules, so they are +present in the default environment. In Guile we support them as well +and we have no plans to remove them, but again we don't recommend them +for new users. + @rnindex char-ready? @deffn {Scheme Procedure} char-ready? [port] -@deffnx {C Function} scm_char_ready_p (port) Return @code{#t} if a character is ready on input @var{port} and return @code{#f} otherwise. If @code{char-ready?} returns @code{#t} then the next @code{read-char} operation on @@ -1490,90 +1414,82 @@ interactive port that has no ready characters. @rnindex read-char @deffn {Scheme Procedure} read-char [port] -@deffnx {C Function} scm_read_char (port) -Return the next character available from @var{port}, updating @var{port} -to point to the following character. If no more characters are -available, the end-of-file object is returned. A decoding error, if -any, is handled in accordance with the port's conversion strategy. +The same as @code{get-char}, except that @var{port} defaults to the +current input port. @xref{Textual I/O}. @end deffn @rnindex peek-char @deffn {Scheme Procedure} peek-char [port] -@deffnx {C Function} scm_peek_char (port) -Return the next character available from @var{port}, -@emph{without} updating @var{port} to point to the following -character. If no more characters are available, the -end-of-file object is returned. - -The value returned by -a call to @code{peek-char} is the same as the value that would -have been returned by a call to @code{read-char} on the same -port. The only difference is that the very next call to -@code{read-char} or @code{peek-char} on that @var{port} will -return the value returned by the preceding call to -@code{peek-char}. In particular, a call to @code{peek-char} on -an interactive port will hang waiting for input whenever a call -to @code{read-char} would have hung. - -As for @code{read-char}, decoding errors are handled in accordance with -the port's conversion strategy. +The same as @code{lookahead-char}, except that @var{port} defaults to +the current input port. @xref{Textual I/O}. @end deffn @deffn {Scheme Procedure} unread-char cobj [port] -@deffnx {C Function} scm_unread_char (cobj, port) -Place character @var{cobj} in @var{port} so that it will be read by the -next read operation. If called multiple times, the unread characters -will be read again in last-in first-out order. If @var{port} is -not supplied, the current input port is used. +The same as @code{unget-char}, except that @var{port} defaults to the +current input port, and the arguments are swapped. @xref{Textual I/O}. @end deffn @deffn {Scheme Procedure} unread-string str port @deffnx {C Function} scm_unread_string (str, port) -Place the string @var{str} in @var{port} so that its characters will -be read from left-to-right as the next characters from @var{port} -during subsequent read operations. If called multiple times, the -unread characters will be read again in last-in first-out order. If -@var{port} is not supplied, the @code{current-input-port} is used. +The same as @code{unget-string}, except that @var{port} defaults to the +current input port, and the arguments are swapped. @xref{Textual I/O}. @end deffn @rnindex newline @deffn {Scheme Procedure} newline [port] -@deffnx {C Function} scm_newline (port) -Send a newline to @var{port}. -If @var{port} is omitted, send to the current output port. +Send a newline to @var{port}. If @var{port} is omitted, send to the +current output port. Equivalent to @code{(put-char port #\newline)}. @end deffn @rnindex write-char @deffn {Scheme Procedure} write-char chr [port] -@deffnx {C Function} scm_write_char (chr, port) -Send character @var{chr} to @var{port}. +The same as @code{put-char}, except that @var{port} defaults to the +current input port, and the arguments are swapped. @xref{Textual I/O}. @end deffn @node Using Ports from C @subsection Using Ports from C +Guile's C interfaces provides some niceties for sending and receiving +bytes and characters in a way that works better with C. + @deftypefn {C Function} size_t scm_c_read (SCM port, void *buffer, size_t size) Read up to @var{size} bytes from @var{port} and store them in @var{buffer}. The return value is the number of bytes actually read, which can be less than @var{size} if end-of-file has been reached. -Note that this function does not update @code{port-line} and -@code{port-column} below. +Note that as this is a binary input procedure, this function does not +update @code{port-line} and @code{port-column} (@pxref{Textual I/O}). @end deftypefn @deftypefn {C Function} void scm_c_write (SCM port, const void *buffer, size_t size) Write @var{size} bytes at @var{buffer} to @var{port}. -Note that this function does not update @code{port-line} and -@code{port-column} (@pxref{Textual I/O}). +Note that as this is a binary output procedure, this function does not +update @code{port-line} and @code{port-column} (@pxref{Textual I/O}). @end deftypefn -@deftypefn {C Function} void scm_lfwrite (const char *buffer, size_t size, SCM port) -Write @var{size} bytes at @var{buffer} to @var{port}. The @code{lf} -indicates that unlike @code{scm_c_write}, this function updates the -port's @code{port-line} and @code{port-column}, and also flushes the -port if the data contains a newline (@code{\n}) and the port is -line-buffered. +@deftypefn {C Function} size_t scm_c_read_bytes (SCM port, SCM bv, size_t start, size_t count) +@deftypefnx {C Function} void scm_c_write_bytes (SCM port, SCM bv, size_t start, size_t count) +Like @code{scm_c_read} and @code{scm_c_write}, but reading into or +writing from the bytevector @var{bv}. @var{count} indicates the byte +index at which to start in the bytevector, and the read or write will +continue for @var{count} bytes. +@end deftypefn + +@deftypefn {C Function} void scm_unget_bytes (const unsigned char *buf, size_t len, SCM port) +@deftypefnx {C Function} void scm_unget_byte (int c, SCM port) +@deftypefnx {C Function} void scm_ungetc (scm_t_wchar c, SCM port) +Like @code{unget-bytevector}, @code{unget-byte}, and @code{unget-char}, +respectively. @xref{Textual I/O}. +@end deftypefn + +@deftypefn {C Function} void scm_c_put_latin1_chars (SCM port, const scm_t_uint8 *buf, size_t len) +@deftypefnx {C Function} void scm_c_put_utf32_chars (SCM port, const scm_t_uint32 *buf, size_t len); +Write a string to @var{port}. In the first case, the +@code{scm_t_uint8*} buffer is a string in the latin-1 encoding. In the +second, the @code{scm_t_uint32*} buffer is a string in the UTF-32 +encoding. These routines will update the port's line and column. @end deftypefn @node I/O Extensions @@ -1582,15 +1498,13 @@ line-buffered. This section describes how to implement a new port type in C. Although ports support many operations, as a data structure they present an opaque interface to the user. To the port implementor, you have two -additional pieces of information: the port type, which is an opaque -pointer allocated when defining your port type; and a port's ``stream'', -which you allocate when you create a port. - -The type code helps you identify which ports are actually yours. The -``stream'' is the private data associated with that port which you and -only you control. Get a stream from a port using the @code{SCM_STREAM} -macro. Note that your port methods are only ever called with ports of -your type. +pieces of information to work with: the port type, and the port's +``stream''. The port type is an opaque pointer allocated when defining +your port type. It is your key into the port API, and it helps you +identify which ports are actually yours. The ``stream'' is a pointer +you control, and which you set when you create a port. Get a stream +from a port using the @code{SCM_STREAM} macro. Note that your port +methods are only ever called with ports of your type. A port type is created by calling @code{scm_make_port_type}. Once you have your port type, you can create ports with @code{scm_c_make_port}, @@ -1789,27 +1703,81 @@ incantation: @end example Now the file descriptor is open in non-blocking mode. If Guile tries to -read or write from this file descriptor in C, it will block by polling -on the socket's @code{read_wait_fd}, to preserve the illusion of a -blocking read or write. @xref{I/O Extensions} for more on that internal -interface. +read or write from this file and the read or write returns a result +indicating that more data can only be had by doing a blocking read or +write, Guile will block by polling on the socket's @code{read-wait-fd} +or @code{write-wait-fd}, to preserve the illusion of a blocking read or +write. @xref{I/O Extensions} for more on those internal interfaces. -However if a user uses the new and experimental Scheme implementation of -ports in @code{(ice-9 sports)}, Guile instead calls the value of the -@code{current-read-waiter} or @code{current-write-waiter} parameters on -the port before re-trying the read or write. The default value of these -parameters does the same thing as the C port runtime: it blocks. -However it's possible to dynamically bind these parameters to handlers -that can suspend the current coroutine to a scheduler, to be later -re-animated once the port becomes readable or writable in the future. -In the mean-time the scheduler can run other code, for example servicing -other web requests. +So far we have just reproduced the status quo: the file descriptor is +non-blocking, but the operations on the port do block. To go farther, +it would be nice if we could suspend the ``thread'' using delimited +continuations, and only resume the thread once the file descriptor is +readable or writable. (@xref{Prompts}). -Guile does not currently include such a scheduler. Currently we want to -make sure that we're providing the right primitives that can be used to -build schedulers and other user-space concurrency patterns. In the -meantime, have a look at 8sync (@url{https://gnu.org/software/8sync}) -for a prototype of an asynchronous I/O and concurrency facility. +But here we run into a difficulty. The ports code is implemented in C, +which means that although we can suspend the computation to some outer +prompt, we can't resume it because Guile can't resume delimited +continuations that capture the C stack. + +To overcome this difficulty we have created a compatible but entirely +parallel implementation of port operations. To use this implementation, +do the following: + +@example +(use-module (ice-9 suspendable-ports)) +(install-suspendable-ports!) +@end example + +This will replace the core I/O primitives like @code{get-char} and +@code{put-bytevector} with new versions that are exactly the same as the +ones in the standard library, but with two differences. One is that +when a read or a write would block, the suspendable port operations call +out the value of the @code{current-read-waiter} or +@code{current-write-waiter} parameter, as appropriate. +@xref{Parameters}. The default read and write waiters do the same thing +that the C read and write waiters do, which is to poll. User code can +parameterize the waiters, though, enabling the computation to suspend +and allow the program to process other I/O operations. Because the new +suspendable ports implementation is written in Scheme, that suspended +computation can resume again later when it is able to make progress. +Success! + +The other main difference is that because the new ports implementation +is written in Scheme, it is slower than C, currently by a factor of 3 or +4, though it depends on many factors. For this reason we have to keep +the C implementations as the default ones. One day when Guile's +compiler is better, we can close this gap and have only one port +operation implementation again. + +Note that Guile does not currently include an implementation of the +facility to suspend the current thread and schedule other threads in the +meantime. Before adding such a thing, we want to make sure that we're +providing the right primitives that can be used to build schedulers and +other user-space concurrency patterns, and that the patterns that we +settle on are the right patterns. In the meantime, have a look at 8sync +(@url{https://gnu.org/software/8sync}) for a prototype of an +asynchronous I/O and concurrency facility. + +@deffn {Scheme Procedure} install-suspendable-ports! +Replace the core ports implementation with suspendable ports, as +described above. This will mutate the values of the bindings like +@code{get-char}, @code{put-u8}, and so on in place. +@end deffn + +@deffn {Scheme Procedure} uninstall-suspendable-ports! +Restore the original core ports implementation, un-doing the effect of +@code{install-suspendable-ports!}. +@end deffn + +@deffn {Scheme Parameter} current-read-waiter +@deffnx {Scheme Parameter} current-write-waiter +Parameters whose values are procedures of one argument, called when a +suspendable port operation would block on a port while reading or +writing, respectively. The default values of these parameters do a +blocking @code{poll} on the port's file descriptor. The procedures are +passed the port in question as their one argument. +@end deffn @node BOM Handling diff --git a/module/Makefile.am b/module/Makefile.am index 06def3851..3f14ed8b4 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -106,10 +106,10 @@ SOURCES = \ ice-9/serialize.scm \ ice-9/session.scm \ ice-9/slib.scm \ - ice-9/sports.scm \ ice-9/stack-catch.scm \ ice-9/streams.scm \ ice-9/string-fun.scm \ + ice-9/suspendable-ports.scm \ ice-9/syncase.scm \ ice-9/textual-ports.scm \ ice-9/threads.scm \ diff --git a/module/ice-9/sports.scm b/module/ice-9/suspendable-ports.scm similarity index 97% rename from module/ice-9/sports.scm rename to module/ice-9/suspendable-ports.scm index d145d071a..d4468be09 100644 --- a/module/ice-9/sports.scm +++ b/module/ice-9/suspendable-ports.scm @@ -48,30 +48,15 @@ ;;; Code: -(define-module (ice-9 sports) +(define-module (ice-9 suspendable-ports) #:use-module (rnrs bytevectors) #:use-module (ice-9 ports internal) #:use-module (ice-9 match) - #:replace (peek-char - read-char - force-output - close-port) #:export (current-read-waiter current-write-waiter - lookahead-u8 - get-u8 - get-bytevector-n - put-u8 - put-bytevector - put-string - - %read-line - read-line - read-delimited - - install-sports! - uninstall-sports!)) + install-suspendable-ports! + uninstall-suspendable-ports!)) (define (default-read-waiter port) (port-poll port "r")) (define (default-write-waiter port) (port-poll port "w")) @@ -681,11 +666,14 @@ ((ice-9 binary-ports) get-u8 lookahead-u8 get-bytevector-n put-u8 put-bytevector) + ((ice-9 textual-ports) + ;; FIXME: put-char + put-string) ((ice-9 rdelim) %read-line read-line read-delimited))) -(define (install-sports!) +(define (install-suspendable-ports!) (unless saved-port-bindings (set! saved-port-bindings (make-hash-table)) - (let ((sports (resolve-module '(ice-9 sports)))) + (let ((suspendable-ports (resolve-module '(ice-9 suspendable-ports)))) (for-each (match-lambda ((mod . syms) @@ -694,11 +682,11 @@ (hashq-set! saved-port-bindings sym (module-ref mod sym)) (module-set! mod sym - (module-ref sports sym))) + (module-ref suspendable-ports sym))) syms)))) port-bindings)))) -(define (uninstall-sports!) +(define (uninstall-suspendable-ports!) (when saved-port-bindings (for-each (match-lambda diff --git a/module/ice-9/textual-ports.scm b/module/ice-9/textual-ports.scm index 620d20e5a..ba30a8b1f 100644 --- a/module/ice-9/textual-ports.scm +++ b/module/ice-9/textual-ports.scm @@ -28,6 +28,8 @@ put-char put-string) #:export (get-char + unget-char + unget-string lookahead-char get-string-n get-string-all @@ -39,6 +41,17 @@ (define (lookahead-char port) (peek-char port)) +(define (unget-char port char) + (unread-char char port)) + +(define* (unget-string port string #:optional (start 0) + (count (- (string-length string) start))) + (unread-string (if (and (zero? start) + (= count (string-length string))) + string + (substring/shared string start (+ start count))) + port)) + (define (get-line port) (read-line port 'trim)) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 775a04f07..822360670 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -127,7 +127,6 @@ SCM_TESTS = tests/00-initial-env.test \ tests/session.test \ tests/signals.test \ tests/sort.test \ - tests/sports.test \ tests/srcprop.test \ tests/srfi-1.test \ tests/srfi-6.test \ @@ -164,6 +163,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/streams.test \ tests/strings.test \ tests/structs.test \ + tests/suspendable-ports.test \ tests/sxml.fold.test \ tests/sxml.match.test \ tests/sxml.simple.test \ diff --git a/test-suite/tests/sports.test b/test-suite/tests/suspendable-ports.test similarity index 94% rename from test-suite/tests/sports.test rename to test-suite/tests/suspendable-ports.test index 453e35fab..28557d5f5 100644 --- a/test-suite/tests/sports.test +++ b/test-suite/tests/suspendable-ports.test @@ -17,7 +17,7 @@ ;;;; . (define-module (test-suite test-ports) - #:use-module ((ice-9 sports) #:select (install-sports! uninstall-sports!))) + #:use-module (ice-9 suspendable-ports)) ;; Include tests from ports.test. @@ -49,10 +49,10 @@ #`((include-one #,exp) . #,(lp)))))))) #:guess-encoding #t))))) -(install-sports!) +(install-suspendable-ports!) (include-tests "tests/ports.test") (include-tests "tests/rdelim.test") (include-tests "tests/r6rs-ports.test") -(uninstall-sports!) +(uninstall-suspendable-ports!) From d8067213dc3728a37c3c60d15aa0f1113d2e8daa Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Jun 2016 23:48:08 +0200 Subject: [PATCH 367/865] put-char in Scheme * libguile/ports.c (scm_port_encode_char): New function. * module/ice-9/ports.scm (port-encode-char): Export port-encode-char to the internals module. * module/ice-9/sports.scm (put-char): New function. (port-bindings): Add put-char and put-string. --- libguile/ports.c | 19 +++++++++++++++++++ module/ice-9/ports.scm | 2 ++ module/ice-9/suspendable-ports.scm | 17 ++++++++++++++--- 3 files changed, 35 insertions(+), 3 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index a464aaf56..2694dcf5f 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -3238,6 +3238,25 @@ SCM_DEFINE (scm_port_encode_chars, "port-encode-chars", 5, 0, 0, } #undef FUNC_NAME +SCM scm_port_encode_char (SCM, SCM, SCM); +SCM_DEFINE (scm_port_encode_char, "port-encode-char", 3, 0, 0, + (SCM port, SCM buf, SCM ch), + "") +#define FUNC_NAME s_scm_port_encode_char +{ + scm_t_uint32 codepoint; + + SCM_VALIDATE_OPOUTPORT (1, port); + SCM_VALIDATE_VECTOR (2, buf); + SCM_VALIDATE_CHAR (3, ch); + + codepoint = SCM_CHAR (ch); + encode_utf32_chars (port, buf, &codepoint, 1); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + void scm_c_put_latin1_chars (SCM port, const scm_t_uint8 *chars, size_t len) { diff --git a/module/ice-9/ports.scm b/module/ice-9/ports.scm index 43a029b49..8eee22988 100644 --- a/module/ice-9/ports.scm +++ b/module/ice-9/ports.scm @@ -187,6 +187,7 @@ interpret its input and output." specialize-port-encoding! port-random-access? port-decode-char + port-encode-char port-encode-chars port-read-buffering port-poll @@ -235,6 +236,7 @@ interpret its input and output." %port-encoding specialize-port-encoding! port-decode-char + port-encode-char port-encode-chars port-random-access? port-read-buffering diff --git a/module/ice-9/suspendable-ports.scm b/module/ice-9/suspendable-ports.scm index d4468be09..6d3d40510 100644 --- a/module/ice-9/suspendable-ports.scm +++ b/module/ice-9/suspendable-ports.scm @@ -660,15 +660,26 @@ (port-line-buffered? port)) (flush-output port)))) +(define* (put-char port char) + (let ((aux (port-auxiliary-write-buffer port))) + (set-port-buffer-cur! aux 0) + (port-clear-stream-start-for-bom-write port aux) + (port-encode-char port aux char) + (let ((end (port-buffer-end aux))) + (set-port-buffer-end! aux 0) + (put-bytevector port (port-buffer-bytevector aux) 0 end)) + (when (and (eqv? char #\newline) (port-line-buffered? port)) + (flush-output port)))) + (define saved-port-bindings #f) (define port-bindings - '(((guile) read-char peek-char force-output close-port) + '(((guile) + read-char peek-char force-output close-port) ((ice-9 binary-ports) get-u8 lookahead-u8 get-bytevector-n put-u8 put-bytevector) ((ice-9 textual-ports) - ;; FIXME: put-char - put-string) + put-char put-string) ((ice-9 rdelim) %read-line read-line read-delimited))) (define (install-suspendable-ports!) (unless saved-port-bindings From e6cc051f8c3f6851be4f51ccb14109d03ae867ba Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 2 Jun 2016 22:37:34 +0200 Subject: [PATCH 368/865] `accept' on nonblocking socket can return #f * doc/ref/posix.texi (Network Sockets and Communication): * libguile/socket.c (scm_accept): Return #f if the socket is nonblocking and no connection is ready. --- doc/ref/posix.texi | 25 ++++++++++++++++++------- libguile/socket.c | 25 ++++++++++++++----------- 2 files changed, 32 insertions(+), 18 deletions(-) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index edcff9dc2..4d2a850cf 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -3260,15 +3260,26 @@ The return value is unspecified. @deffn {Scheme Procedure} accept sock @deffnx {C Function} scm_accept (sock) Accept a connection from socket port @var{sock} which has been enabled -for listening with @code{listen} above. If there are no incoming -connections in the queue, wait until one is available (unless -@code{O_NONBLOCK} has been set on the socket, @pxref{Ports and File -Descriptors,@code{fcntl}}). +for listening with @code{listen} above. + +If there are no incoming connections in the queue, there are two +possible behaviors, depending on whether @var{sock} has been configured +for non-blocking operation or not: + +@itemize +@item +If there is no connection waiting and the socket was set to non-blocking +mode with the @code{O_NONBLOCK} port option (@pxref{Ports and File +Descriptors,@code{fcntl}}), return @code{#f} directly. + +@item +Otherwise wait until a connection is available. +@end itemize The return value is a pair. The @code{car} is a new socket port, -connected and ready to communicate. The @code{cdr} is a socket -address object (@pxref{Network Socket Address}) which is where the -remote connection is from (like @code{getpeername} below). +connected and ready to communicate. The @code{cdr} is a socket address +object (@pxref{Network Socket Address}) which is where the remote +connection is from (like @code{getpeername} below). All communication takes place using the new socket returned. The given @var{sock} remains bound and listening, and @code{accept} may be diff --git a/libguile/socket.c b/libguile/socket.c index 1c4f2ae36..55b93572c 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -1236,16 +1236,15 @@ SCM_DEFINE (scm_make_socket_address, "make-socket-address", 2, 0, 1, SCM_DEFINE (scm_accept, "accept", 1, 0, 0, (SCM sock), - "Accept a connection on a bound, listening socket.\n" - "If there\n" - "are no pending connections in the queue, wait until\n" - "one is available unless the non-blocking option has been\n" - "set on the socket.\n\n" - "The return value is a\n" - "pair in which the @emph{car} is a new socket port for the\n" - "connection and\n" - "the @emph{cdr} is an object with address information about the\n" - "client which initiated the connection.\n\n" + "Accept a connection on a bound, listening socket. If there\n" + "are no pending connections in the queue, there are two\n" + "possibilities: if the socket has been configured as\n" + "non-blocking, return @code{#f} directly. Otherwise wait\n" + "until a connection is available. When a connection comes,\n" + "the return value is a pair in which the @emph{car} is a new\n" + "socket port for the connection and the @emph{cdr} is an\n" + "object with address information about the client which\n" + "initiated the connection.\n\n" "@var{sock} does not become part of the\n" "connection and will continue to accept new requests.") #define FUNC_NAME s_scm_accept @@ -1262,7 +1261,11 @@ SCM_DEFINE (scm_accept, "accept", 1, 0, 0, fd = SCM_FPORT_FDES (sock); SCM_SYSCALL (newfd = accept (fd, (struct sockaddr *) &addr, &addr_size)); if (newfd == -1) - SCM_SYSERROR; + { + if (errno == EAGAIN || errno == EWOULDBLOCK) + return SCM_BOOL_F; + SCM_SYSERROR; + } newsock = SCM_SOCK_FD_TO_PORT (newfd); address = _scm_from_sockaddr (&addr, addr_size, FUNC_NAME); From 69ea1fc45b2b06bda2e435d198e610fa9157c7ac Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 2 Jun 2016 23:12:06 +0200 Subject: [PATCH 369/865] Support `connect' on nonblocking sockets * libguile/socket.c (scm_connect): * doc/ref/posix.texi (Network Sockets and Communication): Support connect on nonblocking ports. --- doc/ref/posix.texi | 10 ++++++---- libguile/socket.c | 7 +++++-- 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 4d2a850cf..09bcd816b 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -3213,10 +3213,12 @@ The return value is unspecified. @deffnx {Scheme Procedure} connect sock AF_INET6 ipv6addr port [flowinfo [scopeid]] @deffnx {Scheme Procedure} connect sock AF_UNIX path @deffnx {C Function} scm_connect (sock, fam, address, args) -Initiate a connection on socket port @var{sock} to a given address. -The destination is either a socket address object, or arguments the -same as @code{make-socket-address} would take to make such an object -(@pxref{Network Socket Address}). The return value is unspecified. +Initiate a connection on socket port @var{sock} to a given address. The +destination is either a socket address object, or arguments the same as +@code{make-socket-address} would take to make such an object +(@pxref{Network Socket Address}). Return true unless the socket was +configured as non-blocking and the connection could not be made +immediately. @example (connect sock AF_INET INADDR_LOOPBACK 23) diff --git a/libguile/socket.c b/libguile/socket.c index 55b93572c..37e9f523f 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -834,7 +834,8 @@ SCM_DEFINE (scm_connect, "connect", 2, 1, 1, "Alternatively, the second argument can be a socket address object " "as returned by @code{make-socket-address}, in which case the " "no additional arguments should be passed.\n\n" - "The return value is unspecified.") + "Return true, unless the socket was configured to be non-blocking\n" + "and the operation has not finished yet.\n") #define FUNC_NAME s_scm_connect { int fd; @@ -859,10 +860,12 @@ SCM_DEFINE (scm_connect, "connect", 2, 1, 1, free (soka); errno = save_errno; + if (errno == EINPROGRESS) + return SCM_BOOL_F; SCM_SYSERROR; } free (soka); - return SCM_UNSPECIFIED; + return SCM_BOOL_T; } #undef FUNC_NAME From 6788faba7a36bf767fda0376025f5847222ef761 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 2 Jun 2016 23:02:21 +0200 Subject: [PATCH 370/865] Non-blocking accept/connect Scheme support * module/ice-9/sports.scm (accept, connect): New Scheme functions. --- module/ice-9/suspendable-ports.scm | 23 ++++++++++++++++++++++- 1 file changed, 22 insertions(+), 1 deletion(-) diff --git a/module/ice-9/suspendable-ports.scm b/module/ice-9/suspendable-ports.scm index 6d3d40510..bc84a4a98 100644 --- a/module/ice-9/suspendable-ports.scm +++ b/module/ice-9/suspendable-ports.scm @@ -671,10 +671,31 @@ (when (and (eqv? char #\newline) (port-line-buffered? port)) (flush-output port)))) +(define accept + (let ((%accept (@ (guile) accept))) + (lambda (port) + (let lp () + (or (%accept port) + (begin + (wait-for-readable port) + (lp))))))) + +(define connect + (let ((%connect (@ (guile) connect))) + (lambda (port sockaddr . args) + (unless (apply %connect port sockaddr args) + ;; Clownshoes semantics; see connect(2). + (wait-for-writable port) + (let ((err (getsockopt port SOL_SOCKET SO_ERROR))) + (unless (zero? err) + (scm-error 'system-error "connect" "~A" + (list (strerror err)) #f))))))) + (define saved-port-bindings #f) (define port-bindings '(((guile) - read-char peek-char force-output close-port) + read-char peek-char force-output close-port + accept connect) ((ice-9 binary-ports) get-u8 lookahead-u8 get-bytevector-n put-u8 put-bytevector) From 1a2ab83bcf9bbe330b767b906433e75e33ba3896 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 10 Jun 2016 07:46:24 +0200 Subject: [PATCH 371/865] Types refactor for unboxed char ranges * module/language/cps/types.scm (*max-codepoint*): Factor codepoint range restrictions to use this value. --- module/language/cps/types.scm | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index f5a83a143..79568bd3e 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -220,6 +220,7 @@ (define *max-size-t* (min (+ (ash most-positive-fixnum 3) #b111) (1- (ash 1 48)))) +(define *max-codepoint* #x10ffff) (define-inlinable (make-unclamped-type-entry type min max) (vector type min max)) @@ -693,8 +694,6 @@ minimum, and maximum." ;;; Strings. ;;; -(define *max-char* (1- (ash 1 24))) - (define-type-checker (string-ref s idx) (and (check-type s &string 0 *max-size-t*) (check-type idx &u64 0 *max-size-t*) @@ -702,17 +701,17 @@ minimum, and maximum." (define-type-inferrer (string-ref s idx result) (restrict! s &string (1+ (&min/0 idx)) *max-size-t*) (restrict! idx &u64 0 (1- (&max/size s))) - (define! result &char 0 *max-char*)) + (define! result &char 0 *max-codepoint*)) (define-type-checker (string-set! s idx val) (and (check-type s &string 0 *max-size-t*) (check-type idx &exact-integer 0 *max-size-t*) - (check-type val &char 0 *max-char*) + (check-type val &char 0 *max-codepoint*) (< (&max idx) (&min s)))) (define-type-inferrer (string-set! s idx val) (restrict! s &string (1+ (&min/0 idx)) *max-size-t*) (restrict! idx &exact-integer 0 (1- (&max/size s))) - (restrict! val &char 0 *max-char*)) + (restrict! val &char 0 *max-codepoint*)) (define-simple-type-checker (string-length &string)) (define-type-inferrer (string-length s result) @@ -1422,15 +1421,15 @@ minimum, and maximum." ((logior &true &false) 0 0)) (define-type-aliases char=? char>?) -(define-simple-type-checker (integer->char (&u64 0 #x10ffff))) +(define-simple-type-checker (integer->char (&u64 0 *max-codepoint*))) (define-type-inferrer (integer->char i result) - (restrict! i &u64 0 #x10ffff) - (define! result &char (&min/0 i) (min (&max i) #x10ffff))) + (restrict! i &u64 0 *max-codepoint*) + (define! result &char (&min/0 i) (min (&max i) *max-codepoint*))) (define-simple-type-checker (char->integer &char)) (define-type-inferrer (char->integer c result) - (restrict! c &char 0 #x10ffff) - (define! result &u64 (&min/0 c) (min (&max c) #x10ffff))) + (restrict! c &char 0 *max-codepoint*) + (define! result &u64 (&min/0 c) (min (&max c) *max-codepoint*))) From 58e508b5695e0a6baa09e046f9440a2b44959a3c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 10 Jun 2016 07:46:57 +0200 Subject: [PATCH 372/865] Type inference: Use &u64-max instead of #xffff... * module/language/cps/types.scm: Use &u64-max where possible. --- module/language/cps/types.scm | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 79568bd3e..633fef51b 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -742,9 +742,9 @@ minimum, and maximum." (define! result &flonum (&min f64) (&max f64))) (define-type-checker (scm->u64 scm) - (check-type scm &exact-integer 0 #xffffffffffffffff)) + (check-type scm &exact-integer 0 &u64-max)) (define-type-inferrer (scm->u64 scm result) - (restrict! scm &exact-integer 0 #xffffffffffffffff) + (restrict! scm &exact-integer 0 &u64-max) (define! result &u64 (&min/0 scm) (&max/u64 scm))) (define-type-aliases scm->u64 load-u64) @@ -1004,9 +1004,9 @@ minimum, and maximum." (define-type-inferrer (uadd a b result) ;; Handle wraparound. (let ((max (+ (&max/u64 a) (&max/u64 b)))) - (if (<= max #xffffffffffffffff) + (if (<= max &u64-max) (define! result &u64 (+ (&min/0 a) (&min/0 b)) max) - (define! result &u64 0 #xffffffffffffffff)))) + (define! result &u64 0 &u64-max)))) (define-type-aliases uadd uadd/immediate) (define-simple-type-checker (sub &number &number)) @@ -1025,7 +1025,7 @@ minimum, and maximum." ;; Handle wraparound. (let ((min (- (&min/0 a) (&max/u64 b)))) (if (< min 0) - (define! result &u64 0 #xffffffffffffffff) + (define! result &u64 0 &u64-max) (define! result &u64 min (- (&max/u64 a) (&min/0 b)))))) (define-type-aliases usub usub/immediate) @@ -1077,9 +1077,9 @@ minimum, and maximum." (define-type-inferrer (umul a b result) ;; Handle wraparound. (let ((max (* (&max/u64 a) (&max/u64 b)))) - (if (<= max #xffffffffffffffff) + (if (<= max &u64-max) (define! result &u64 (* (&min/0 a) (&min/0 b)) max) - (define! result &u64 0 #xffffffffffffffff)))) + (define! result &u64 0 &u64-max)))) (define-type-aliases umul umul/immediate) (define-type-checker (div a b) From d1b99ea2aee299643a027066a33632da0b623f26 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 10 Jun 2016 08:23:04 +0200 Subject: [PATCH 373/865] Minor VM fixes * libguile/vm-engine.c (string-ref): Unpack the index into a 64-bit integer. (br-if-u64-<-scm): Tighten up the fast path. --- libguile/vm-engine.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 018f32f04..078e0783f 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -2239,7 +2239,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, { scm_t_uint8 dst, src, idx; SCM str; - scm_t_uint32 c_idx; + scm_t_uint64 c_idx; UNPACK_8_8_8 (op, dst, src, idx); str = SP_REF (src); @@ -3700,7 +3700,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, */ VM_DEFINE_OP (171, br_if_u64_lt_scm, "br-if-u64-<-scm", OP3 (X8_S24, X8_S24, B1_X7_L24)) { - BR_U64_SCM_COMPARISON(x, y, y >= 0 && (scm_t_uint64) y > x, scm_less_p); + BR_U64_SCM_COMPARISON(x, y, y > 0 && (scm_t_uint64) y > x, scm_less_p); } /* br-if-u64-=-scm a:24 _:8 b:24 invert:1 _:7 offset:24 From 7e502d57e0ec121222abe6fd3e1bbb94067f6dfe Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 10 Jun 2016 15:30:40 +0200 Subject: [PATCH 374/865] Fix bad backtraces * libguile/vm-engine.c (BV_REF, BV_BOUNDED_SET, BV_SET, integer->char) (char->integer): Use VM_ASSERT so that we save the IP before erroring out. --- libguile/vm-engine.c | 31 +++++++++++++++---------------- 1 file changed, 15 insertions(+), 16 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 078e0783f..765858919 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -2976,9 +2976,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, \ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-ref"); \ \ - if (SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (bv) < size) \ - || SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (bv) - size < c_idx)) \ - vm_error_out_of_range_uint64 ("bv-" #stem "-ref", c_idx); \ + VM_ASSERT (SCM_BYTEVECTOR_LENGTH (bv) >= size \ + && SCM_BYTEVECTOR_LENGTH (bv) - size >= c_idx, \ + vm_error_out_of_range_uint64 ("bv-" #stem "-ref", c_idx)); \ \ memcpy (&result, SCM_BYTEVECTOR_CONTENTS (bv) + c_idx, size); \ SP_SET_ ## slot (dst, result); \ @@ -3043,13 +3043,13 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, \ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ \ - if (SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (bv) < size) \ - || SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (bv) - size < c_idx)) \ - vm_error_out_of_range_uint64 ("bv-" #stem "-set!", c_idx); \ + VM_ASSERT (SCM_BYTEVECTOR_LENGTH (bv) >= size \ + && SCM_BYTEVECTOR_LENGTH (bv) - size >= c_idx, \ + vm_error_out_of_range_uint64 ("bv-" #stem "-set!", c_idx)); \ \ - if (SCM_UNLIKELY (slot_val < min) || SCM_UNLIKELY (slot_val > max)) \ - vm_error_out_of_range_ ## slot_type ("bv-" #stem "-set!", \ - slot_val); \ + VM_ASSERT (slot_val >= min && slot_val <= max, \ + vm_error_out_of_range_ ## slot_type ("bv-" #stem "-set!", \ + slot_val)); \ \ val = slot_val; \ memcpy (SCM_BYTEVECTOR_CONTENTS (bv) + c_idx, &val, size); \ @@ -3069,9 +3069,9 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, \ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ \ - if (SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (bv) < size) \ - || SCM_UNLIKELY (SCM_BYTEVECTOR_LENGTH (bv) - size < c_idx)) \ - vm_error_out_of_range_uint64 ("bv-" #stem "-set!", c_idx); \ + VM_ASSERT (SCM_BYTEVECTOR_LENGTH (bv) >= size \ + && SCM_BYTEVECTOR_LENGTH (bv) - size >= c_idx, \ + vm_error_out_of_range_uint64 ("bv-" #stem "-set!", c_idx)); \ \ memcpy (SCM_BYTEVECTOR_CONTENTS (bv) + c_idx, &val, size); \ NEXT (1); \ @@ -3746,8 +3746,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_12_12 (op, dst, src); x = SP_REF_U64 (src); - if (SCM_UNLIKELY (x > (scm_t_uint64) SCM_CODEPOINT_MAX)) - vm_error_out_of_range_uint64 ("integer->char", x); + VM_ASSERT (x <= (scm_t_uint64) SCM_CODEPOINT_MAX, + vm_error_out_of_range_uint64 ("integer->char", x)); SP_SET (dst, SCM_MAKE_ITAG8 ((scm_t_bits) (scm_t_wchar) x, scm_tc8_char)); @@ -3766,8 +3766,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_12_12 (op, dst, src); x = SP_REF (src); - if (SCM_UNLIKELY (!SCM_CHARP (x))) - vm_error_not_a_char ("char->integer", x); + VM_ASSERT (SCM_CHARP (x), vm_error_not_a_char ("char->integer", x)); SP_SET_U64 (dst, SCM_CHAR (x)); From ddce05e81957f9150310f72e8a3b26b9fe9019d2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 11 Jun 2016 12:26:26 +0200 Subject: [PATCH 375/865] vm: Make sure IP is stored before potentially GCing. * libguile/vm-engine.c: Add a number of SYNC_IP calls that were missing before calls that could GC. --- libguile/vm-engine.c | 24 ++++++++++++++++++------ 1 file changed, 18 insertions(+), 6 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 765858919..3af66b672 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -523,6 +523,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, { scm_t_uint32 n; ret = SCM_EOL; + SYNC_IP (); for (n = nvals; n > 0; n--) ret = scm_inline_cons (thread, FP_REF (4 + n - 1), ret); ret = scm_values (ret); @@ -1304,6 +1305,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, { SCM rest = SCM_EOL; n = nkw; + SYNC_IP (); while (n--) rest = scm_inline_cons (thread, FP_REF (ntotal + n), rest); FP_SET (nreq_and_opt, rest); @@ -1335,6 +1337,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, } else { + SYNC_IP (); + while (nargs-- > dst) { rest = scm_inline_cons (thread, FP_REF (nargs), rest); @@ -1476,10 +1480,13 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, */ VM_DEFINE_OP (44, br_if_logtest, "br-if-logtest", OP3 (X8_S24, X8_S24, B1_X7_L24)) { - BR_BINARY (x, y, - ((SCM_I_INUMP (x) && SCM_I_INUMP (y)) - ? (SCM_UNPACK (x) & SCM_UNPACK (y) & ~scm_tc2_int) - : scm_is_true (scm_logtest (x, y)))); + SYNC_IP (); + { + BR_BINARY (x, y, + ((SCM_I_INUMP (x) && SCM_I_INUMP (y)) + ? (SCM_UNPACK (x) & SCM_UNPACK (y) & ~scm_tc2_int) + : scm_is_true (scm_logtest (x, y)))); + } } /* br-if-= a:12 b:12 invert:1 _:7 offset:24 @@ -1575,6 +1582,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, { scm_t_uint16 dst, src; UNPACK_12_12 (op, dst, src); + SYNC_IP (); SP_SET (dst, scm_inline_cell (thread, scm_tc7_variable, SCM_UNPACK (SP_REF (src)))); NEXT (1); @@ -2085,6 +2093,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, /* Push the prompt onto the dynamic stack. */ flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0; + SYNC_IP (); scm_dynstack_push_prompt (&thread->dynstack, flags, SP_REF (tag), vp->stack_top - vp->fp, @@ -2106,6 +2115,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, { scm_t_uint16 winder, unwinder; UNPACK_12_12 (op, winder, unwinder); + SYNC_IP (); scm_dynstack_push_dynwind (&thread->dynstack, SP_REF (winder), SP_REF (unwinder)); NEXT (1); @@ -2132,6 +2142,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_12_12 (op, fluid, value); + SYNC_IP (); scm_dynstack_push_fluid (&thread->dynstack, SP_REF (fluid), SP_REF (value), thread->dynamic_state); @@ -2311,6 +2322,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, VM_DEFINE_OP (81, cons, "cons", OP1 (X8_S8_S8_S8) | OP_DST) { ARGS2 (x, y); + SYNC_IP (); RETURN (scm_inline_cons (thread, x, y)); } @@ -2603,6 +2615,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_8_8_8 (op, dst, length, init); val = SP_REF (init); + SYNC_IP (); vector = scm_inline_words (thread, scm_tc7_vector | (length << 8), length + 1); for (n = 0; n < length; n++) @@ -2899,8 +2912,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, ARGS1 (obj); if (SCM_INSTANCEP (obj)) RETURN (SCM_CLASS_OF (obj)); - SYNC_IP (); - RETURN (scm_class_of (obj)); + RETURN_EXP (scm_class_of (obj)); } From 100b0480971239cf26779e6e9b3465db31d0a489 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 11 Jun 2016 13:01:56 +0200 Subject: [PATCH 376/865] VM type checking refactor * libguile/vm-engine.c (VM_VALIDATE): Refactor some type-related assertions to use a common macro. (vector-length, vector-set!/immediate): Fix the proc mentioned in the error message. --- libguile/vm-engine.c | 77 +++++++++++++++++++++----------------------- 1 file changed, 36 insertions(+), 41 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 3af66b672..dfdf0a199 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -423,7 +423,7 @@ ((scm_t_signed_bits) SCM_UNPACK (SCM_INUM1) \ - (scm_t_signed_bits) SCM_UNPACK (SCM_INUM0)) -#define BINARY_INTEGER_OP(CFUNC,SFUNC) \ +#define BINARY_INTEGER_OP(CFUNC,SFUNC) \ { \ ARGS2 (x, y); \ if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \ @@ -435,14 +435,26 @@ RETURN_EXP (SFUNC (x, y)); \ } -#define VM_VALIDATE_PAIR(x, proc) \ - VM_ASSERT (scm_is_pair (x), vm_error_not_a_pair (proc, x)) - -#define VM_VALIDATE_STRUCT(obj, proc) \ - VM_ASSERT (SCM_STRUCTP (obj), vm_error_not_a_pair (proc, obj)) +#define VM_VALIDATE(x, pred, proc, what) \ + VM_ASSERT (pred (x), vm_error_not_a_ ## what (proc, x)) -#define VM_VALIDATE_BYTEVECTOR(x, proc) \ - VM_ASSERT (SCM_BYTEVECTOR_P (x), vm_error_not_a_bytevector (proc, x)) +#define VM_VALIDATE_BYTEVECTOR(x, proc) \ + VM_VALIDATE (x, SCM_BYTEVECTOR_P, proc, bytevector) +#define VM_VALIDATE_CHAR(x, proc) \ + VM_VALIDATE (x, SCM_CHARP, proc, char); +#define VM_VALIDATE_PAIR(x, proc) \ + VM_VALIDATE (x, scm_is_pair, proc, pair) +#define VM_VALIDATE_STRING(obj, proc) \ + VM_VALIDATE (obj, scm_is_string, proc, string) +#define VM_VALIDATE_STRUCT(obj, proc) \ + VM_VALIDATE (obj, SCM_STRUCTP, proc, struct) +#define VM_VALIDATE_VARIABLE(obj, proc) \ + VM_VALIDATE (obj, SCM_VARIABLEP, proc, variable) +#define VM_VALIDATE_VECTOR(obj, proc) \ + VM_VALIDATE (obj, SCM_I_IS_VECTOR, proc, vector) + +#define VM_VALIDATE_INDEX(u64, size, proc) \ + VM_ASSERT (u64 < size, vm_error_out_of_range_uint64 (proc, u64)) /* Return true (non-zero) if PTR has suitable alignment for TYPE. */ #define ALIGNED_P(ptr, type) \ @@ -1599,8 +1611,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, SCM var; UNPACK_12_12 (op, dst, src); var = SP_REF (src); - VM_ASSERT (SCM_VARIABLEP (var), - vm_error_not_a_variable ("variable-ref", var)); + VM_VALIDATE_VARIABLE (var, "variable-ref"); VM_ASSERT (VARIABLE_BOUNDP (var), vm_error_unbound (var)); SP_SET (dst, VARIABLE_REF (var)); NEXT (1); @@ -1616,8 +1627,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, SCM var; UNPACK_12_12 (op, dst, src); var = SP_REF (dst); - VM_ASSERT (SCM_VARIABLEP (var), - vm_error_not_a_variable ("variable-set!", var)); + VM_VALIDATE_VARIABLE (var, "variable-set!"); VARIABLE_SET (var, SP_REF (src)); NEXT (1); } @@ -2235,8 +2245,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, VM_DEFINE_OP (76, string_length, "string-length", OP1 (X8_S12_S12) | OP_DST) { ARGS1 (str); - VM_ASSERT (scm_is_string (str), - vm_error_not_a_string ("string-length", str)); + VM_VALIDATE_STRING (str, "string-length"); SP_SET_U64 (dst, scm_i_string_length (str)); NEXT (1); } @@ -2256,10 +2265,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, str = SP_REF (src); c_idx = SP_REF_U64 (idx); - VM_ASSERT (scm_is_string (str), - vm_error_not_a_string ("string-ref", str)); - VM_ASSERT (c_idx < scm_i_string_length (str), - vm_error_out_of_range_uint64 ("string-ref", c_idx)); + VM_VALIDATE_STRING (str, "string-ref"); + VM_VALIDATE_INDEX (c_idx, scm_i_string_length (str), "string-ref"); RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str, c_idx))); } @@ -2590,8 +2597,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_8_8_8 (op, dst, length, init); length_val = SP_REF_U64 (length); - VM_ASSERT (length_val < (size_t) -1, - vm_error_out_of_range_uint64 ("make-vector", length_val)); + VM_VALIDATE_INDEX (length_val, (size_t) -1, "make-vector"); /* TODO: Inline this allocation. */ SYNC_IP (); @@ -2631,9 +2637,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, VM_DEFINE_OP (101, vector_length, "vector-length", OP1 (X8_S12_S12) | OP_DST) { ARGS1 (vect); - VM_ASSERT (SCM_I_IS_VECTOR (vect), - vm_error_not_a_vector ("vector-ref", vect)); - + VM_VALIDATE_VECTOR (vect, "vector-length"); SP_SET_U64 (dst, SCM_I_VECTOR_LENGTH (vect)); NEXT (1); } @@ -2653,10 +2657,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, vect = SP_REF (src); c_idx = SP_REF_U64 (idx); - VM_ASSERT (SCM_I_IS_VECTOR (vect), - vm_error_not_a_vector ("vector-ref", vect)); - VM_ASSERT (c_idx < SCM_I_VECTOR_LENGTH (vect), - vm_error_out_of_range_uint64 ("vector-ref", c_idx)); + VM_VALIDATE_VECTOR (vect, "vector-ref"); + VM_VALIDATE_INDEX (c_idx, SCM_I_VECTOR_LENGTH (vect), "vector-ref"); RETURN (SCM_I_VECTOR_ELTS (vect)[c_idx]); } @@ -2672,10 +2674,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_8_8_8 (op, dst, src, idx); vect = SP_REF (src); - VM_ASSERT (SCM_I_IS_VECTOR (vect), - vm_error_not_a_vector ("vector-ref", vect)); - VM_ASSERT (idx < SCM_I_VECTOR_LENGTH (vect), - vm_error_out_of_range_uint64 ("vector-ref", idx)); + VM_VALIDATE_VECTOR (vect, "vector-ref"); + VM_VALIDATE_INDEX (idx, SCM_I_VECTOR_LENGTH (vect), "vector-ref"); SP_SET (dst, SCM_I_VECTOR_ELTS (vect)[idx]); NEXT (1); } @@ -2695,10 +2695,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, c_idx = SP_REF_U64 (idx); val = SP_REF (src); - VM_ASSERT (SCM_I_IS_VECTOR (vect), - vm_error_not_a_vector ("vector-set!", vect)); - VM_ASSERT (c_idx < SCM_I_VECTOR_LENGTH (vect), - vm_error_out_of_range_uint64 ("vector-set!", c_idx)); + VM_VALIDATE_VECTOR (vect, "vector-set!"); + VM_VALIDATE_INDEX (c_idx, SCM_I_VECTOR_LENGTH (vect), "vector-set!"); SCM_I_VECTOR_WELTS (vect)[c_idx] = val; NEXT (1); } @@ -2717,10 +2715,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, vect = SP_REF (dst); val = SP_REF (src); - VM_ASSERT (SCM_I_IS_VECTOR (vect), - vm_error_not_a_vector ("vector-ref", vect)); - VM_ASSERT (idx < SCM_I_VECTOR_LENGTH (vect), - vm_error_out_of_range_uint64 ("vector-ref", idx)); + VM_VALIDATE_VECTOR (vect, "vector-set!"); + VM_VALIDATE_INDEX (idx, SCM_I_VECTOR_LENGTH (vect), "vector-set!"); SCM_I_VECTOR_WELTS (vect)[idx] = val; NEXT (1); } @@ -3778,8 +3774,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_12_12 (op, dst, src); x = SP_REF (src); - VM_ASSERT (SCM_CHARP (x), vm_error_not_a_char ("char->integer", x)); - + VM_VALIDATE_CHAR (x, "char->integer"); SP_SET_U64 (dst, SCM_CHAR (x)); NEXT (1); From be6194e32a642bbb62ad11cef02b9e34bf648ac3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 11 Jun 2016 14:44:59 +0200 Subject: [PATCH 377/865] Fix shuffling of unboxed stack elements on 32-bit systems * libguile/vm-engine.c (SP_REF_SLOT, SP_SET_SLOT): New defines. (push, pop, mov, long-mov): Move full slots. Fixes 32-bit with unboxed 64-bit stack values; before when shuffling these values around, we were only shuffling the lower 32 bits on 32-bit platforms. --- libguile/vm-engine.c | 35 +++++++++++++++++++++++++++-------- 1 file changed, 27 insertions(+), 8 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index dfdf0a199..0978636f5 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -248,6 +248,9 @@ #define FP_REF(i) SCM_FRAME_LOCAL (vp->fp, i) #define FP_SET(i,o) SCM_FRAME_LOCAL (vp->fp, i) = o +#define SP_REF_SLOT(i) (sp[i]) +#define SP_SET_SLOT(i,o) (sp[i] = o) + #define SP_REF(i) (sp[i].as_scm) #define SP_SET(i,o) (sp[i].as_scm = o) @@ -1142,12 +1145,16 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, VM_DEFINE_OP (26, push, "push", OP1 (X8_S24)) { scm_t_uint32 src; - SCM val; + union scm_vm_stack_element val; + /* FIXME: The compiler currently emits "push" for SCM, F64, U64, + and S64 variables. However SCM values are the usual case, and + on a 32-bit machine it might be cheaper to move a SCM than to + move a 64-bit number. */ UNPACK_24 (op, src); - val = SP_REF (src); + val = SP_REF_SLOT (src); ALLOC_FRAME (FRAME_LOCALS_COUNT () + 1); - SP_SET (0, val); + SP_SET_SLOT (0, val); NEXT (1); } @@ -1158,12 +1165,16 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, VM_DEFINE_OP (27, pop, "pop", OP1 (X8_S24) | OP_DST) { scm_t_uint32 dst; - SCM val; + union scm_vm_stack_element val; + /* FIXME: The compiler currently emits "pop" for SCM, F64, U64, + and S64 variables. However SCM values are the usual case, and + on a 32-bit machine it might be cheaper to move a SCM than to + move a 64-bit number. */ UNPACK_24 (op, dst); - val = SP_REF (0); + val = SP_REF_SLOT (0); vp->sp = sp = sp + 1; - SP_SET (dst, val); + SP_SET_SLOT (dst, val); NEXT (1); } @@ -1548,7 +1559,11 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, scm_t_uint16 src; UNPACK_12_12 (op, dst, src); - SP_SET (dst, SP_REF (src)); + /* FIXME: The compiler currently emits "mov" for SCM, F64, U64, + and S64 variables. However SCM values are the usual case, and + on a 32-bit machine it might be cheaper to move a SCM than to + move a 64-bit number. */ + SP_SET_SLOT (dst, SP_REF_SLOT (src)); NEXT (1); } @@ -1564,7 +1579,11 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_24 (op, dst); UNPACK_24 (ip[1], src); - SP_SET (dst, SP_REF (src)); + /* FIXME: The compiler currently emits "long-mov" for SCM, F64, + U64, and S64 variables. However SCM values are the usual case, + and on a 32-bit machine it might be cheaper to move a SCM than + to move a 64-bit number. */ + SP_SET_SLOT (dst, SP_REF_SLOT (src)); NEXT (2); } From 2cb7c4c4d7e6e6e5df9746c2582c49a8234d6103 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 11 Jun 2016 18:29:35 +0200 Subject: [PATCH 378/865] Remove unused static definitions * libguile/expand.c: * libguile/vm.c: Remove unused static definitions. --- libguile/expand.c | 9 --------- libguile/vm.c | 36 ------------------------------------ 2 files changed, 45 deletions(-) diff --git a/libguile/expand.c b/libguile/expand.c index 91097c2d5..fc7da54a8 100644 --- a/libguile/expand.c +++ b/libguile/expand.c @@ -109,27 +109,18 @@ static const char s_bad_expression[] = "Bad expression"; static const char s_expression[] = "Missing or extra expression in"; static const char s_missing_expression[] = "Missing expression in"; static const char s_extra_expression[] = "Extra expression in"; -static const char s_empty_combination[] = "Illegal empty combination"; -static const char s_missing_body_expression[] = "Missing body expression in"; -static const char s_mixed_body_forms[] = "Mixed definitions and expressions in"; static const char s_bad_define[] = "Bad define placement"; static const char s_missing_clauses[] = "Missing clauses"; static const char s_misplaced_else_clause[] = "Misplaced else clause"; -static const char s_bad_case_clause[] = "Bad case clause"; -static const char s_bad_case_labels[] = "Bad case labels"; -static const char s_duplicate_case_label[] = "Duplicate case label"; static const char s_bad_cond_clause[] = "Bad cond clause"; static const char s_missing_recipient[] = "Missing recipient in"; static const char s_bad_variable[] = "Bad variable"; static const char s_bad_bindings[] = "Bad bindings"; static const char s_bad_binding[] = "Bad binding"; static const char s_duplicate_binding[] = "Duplicate binding"; -static const char s_bad_exit_clause[] = "Bad exit clause"; static const char s_bad_formals[] = "Bad formals"; static const char s_bad_formal[] = "Bad formal"; static const char s_duplicate_formal[] = "Duplicate formal"; -static const char s_splicing[] = "Non-list result for unquote-splicing"; -static const char s_bad_slot_number[] = "Bad slot number"; static void syntax_error (const char* const, const SCM, const SCM) SCM_NORETURN; diff --git a/libguile/vm.c b/libguile/vm.c index 07d6c13ee..60469f631 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -437,25 +437,20 @@ static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN SCM_NOINLINE; static void vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) SCM_NORETURN SCM_NOINLINE; static void vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) SCM_NORETURN SCM_NOINLINE; -static void vm_error_too_many_args (int nargs) SCM_NORETURN SCM_NOINLINE; static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN SCM_NOINLINE; static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE; -static void vm_error_stack_underflow (void) SCM_NORETURN SCM_NOINLINE; -static void vm_error_improper_list (SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_char (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_string (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_vector (const char *subr, SCM v) SCM_NORETURN SCM_NOINLINE; -static void vm_error_out_of_range (const char *subr, SCM k) SCM_NORETURN SCM_NOINLINE; static void vm_error_out_of_range_uint64 (const char *subr, scm_t_uint64 idx) SCM_NORETURN SCM_NOINLINE; static void vm_error_out_of_range_int64 (const char *subr, scm_t_int64 idx) SCM_NORETURN SCM_NOINLINE; static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE; static void vm_error_wrong_number_of_values (scm_t_uint32 expected) SCM_NORETURN SCM_NOINLINE; static void vm_error_continuation_not_rewindable (SCM cont) SCM_NORETURN SCM_NOINLINE; -static void vm_error_bad_wide_string_length (size_t len) SCM_NORETURN SCM_NOINLINE; static void vm_error (const char *msg, SCM arg) @@ -526,12 +521,6 @@ vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) SCM_EOL, scm_list_1 (kw)); } -static void -vm_error_too_many_args (int nargs) -{ - vm_error ("VM: Too many arguments", scm_from_int (nargs)); -} - static void vm_error_wrong_num_args (SCM proc) { @@ -545,18 +534,6 @@ vm_error_wrong_type_apply (SCM proc) scm_list_1 (proc), scm_list_1 (proc)); } -static void -vm_error_stack_underflow (void) -{ - vm_error ("VM: Stack underflow", SCM_UNDEFINED); -} - -static void -vm_error_improper_list (SCM x) -{ - vm_error ("Expected a proper list, but got object with tail ~s", x); -} - static void vm_error_not_a_char (const char *subr, SCM x) { @@ -593,13 +570,6 @@ vm_error_not_a_vector (const char *subr, SCM x) scm_wrong_type_arg_msg (subr, 1, x, "vector"); } -static void -vm_error_out_of_range (const char *subr, SCM k) -{ - scm_to_size_t (k); - scm_out_of_range (subr, k); -} - static void vm_error_out_of_range_uint64 (const char *subr, scm_t_uint64 idx) { @@ -638,12 +608,6 @@ vm_error_continuation_not_rewindable (SCM cont) vm_error ("Unrewindable partial continuation", cont); } -static void -vm_error_bad_wide_string_length (size_t len) -{ - vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len)); -} - From 7142005a055432f0d261c294c8cef012651a1899 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 11 Jun 2016 22:43:50 +0200 Subject: [PATCH 379/865] Skip incompatible .go files * libguile/load.c (load_thunk_from_path, try_load_thunk_from_file): New functions. (search_path): Simplify. (scm_primitive_load_path, scm_init_eval_in_scheme): Use the new functions to load compiled files. * module/ice-9/boot-9.scm (load-in-vicinity): Skip invalid .go files. Inspired by a patch from Jan Nieuwenhuizen . --- libguile/load.c | 308 +++++++++++++++++++++++++++++++--------- module/ice-9/boot-9.scm | 58 +++++--- 2 files changed, 278 insertions(+), 88 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index 897541490..7ad9a754d 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -28,18 +28,19 @@ #include #include "libguile/_scm.h" -#include "libguile/libpath.h" -#include "libguile/fports.h" -#include "libguile/read.h" -#include "libguile/eval.h" -#include "libguile/throw.h" #include "libguile/alist.h" -#include "libguile/dynwind.h" -#include "libguile/root.h" -#include "libguile/strings.h" -#include "libguile/modules.h" #include "libguile/chars.h" +#include "libguile/dynwind.h" +#include "libguile/eval.h" +#include "libguile/fports.h" +#include "libguile/libpath.h" +#include "libguile/loader.h" +#include "libguile/modules.h" +#include "libguile/read.h" +#include "libguile/root.h" #include "libguile/srfi-13.h" +#include "libguile/strings.h" +#include "libguile/throw.h" #include "libguile/validate.h" #include "libguile/load.h" @@ -570,6 +571,216 @@ compiled_is_fresh (SCM full_filename, SCM compiled_filename, return compiled_is_newer; } +static SCM +do_load_thunk_from_file (void *data) +{ + return scm_load_thunk_from_file (SCM_PACK_POINTER (data)); +} + +static SCM +load_thunk_from_file_catch_handler (void *data, SCM tag, SCM throw_args) +{ + SCM filename = SCM_PACK_POINTER (data); + SCM oport, lines; + + oport = scm_open_output_string (); + scm_print_exception (oport, SCM_BOOL_F, tag, throw_args); + + scm_puts (";;; WARNING: loading compiled file ", + scm_current_warning_port ()); + scm_display (filename, scm_current_warning_port ()); + scm_puts (" failed:\n", scm_current_warning_port ()); + + lines = scm_string_split (scm_get_output_string (oport), + SCM_MAKE_CHAR ('\n')); + for (; scm_is_pair (lines); lines = scm_cdr (lines)) + if (scm_c_string_length (scm_car (lines))) + { + scm_puts (";;; ", scm_current_warning_port ()); + scm_display (scm_car (lines), scm_current_warning_port ()); + scm_newline (scm_current_warning_port ()); + } + + scm_close_port (oport); + + return SCM_BOOL_F; +} + +static SCM +try_load_thunk_from_file (SCM filename) +{ + return scm_c_catch (SCM_BOOL_T, + do_load_thunk_from_file, + SCM_UNPACK_POINTER (filename), + load_thunk_from_file_catch_handler, + SCM_UNPACK_POINTER (filename), + NULL, NULL); +} + +/* Search the %load-compiled-path for a directory containing a file + named FILENAME. The file must be readable, and not a directory. If + we don't find one, return #f. If we do fine one, treat it as a + compiled file and try to load it as a thunk. If that fails, continue + looking in the path. + + If given, EXTENSIONS is a list of strings; for each directory in + PATH, we search for FILENAME concatenated with each EXTENSION. + + If SOURCE_FILE_NAME is true, then only try to load compiled files + that are newer than SOURCE_STAT_BUF. If they are older, otherwise issuing a warning if + we see a stale file earlier in the path, setting *FOUND_STALE_FILE to + 1. + */ +static SCM +load_thunk_from_path (SCM filename, SCM source_file_name, + struct stat *source_stat_buf, + int *found_stale_file) +{ + struct stringbuf buf; + struct stat stat_buf; + char *filename_chars; + size_t filename_len; + SCM path, extensions; + SCM result = SCM_BOOL_F; + char initial_buffer[256]; + + path = *scm_loc_load_compiled_path; + if (scm_ilength (path) < 0) + scm_misc_error ("%search-path", "path is not a proper list: ~a", + scm_list_1 (path)); + + extensions = *scm_loc_load_compiled_extensions; + if (scm_ilength (extensions) < 0) + scm_misc_error ("%search-path", "bad extensions list: ~a", + scm_list_1 (extensions)); + + scm_dynwind_begin (0); + + filename_chars = scm_to_locale_string (filename); + filename_len = strlen (filename_chars); + scm_dynwind_free (filename_chars); + + /* If FILENAME is absolute and is still valid, return it unchanged. */ + if (is_absolute_file_name (filename)) + { + if (string_has_an_ext (filename, extensions) + && stat (filename_chars, &stat_buf) == 0 + && !(stat_buf.st_mode & S_IFDIR)) + result = scm_load_thunk_from_file (filename); + goto end; + } + + /* If FILENAME has an extension, don't try to add EXTENSIONS to it. */ + { + char *endp; + + for (endp = filename_chars + filename_len - 1; + endp >= filename_chars; + endp--) + { + if (*endp == '.') + { + if (!string_has_an_ext (filename, extensions)) + { + /* This filename has an extension, but not one of the right + ones... */ + goto end; + } + /* This filename already has an extension, so cancel the + list of extensions. */ + extensions = SCM_EOL; + break; + } + else if (is_file_name_separator (SCM_MAKE_CHAR (*endp))) + /* This filename has no extension, so keep the current list + of extensions. */ + break; + } + } + + /* This simplifies the loop below a bit. + */ + if (scm_is_null (extensions)) + extensions = scm_listofnullstr; + + buf.buf_len = sizeof initial_buffer; + buf.buf = initial_buffer; + + /* Try every path element. + */ + for (; scm_is_pair (path); path = SCM_CDR (path)) + { + SCM dir = SCM_CAR (path); + SCM exts; + size_t sans_ext_len; + + buf.ptr = buf.buf; + stringbuf_cat_locale_string (&buf, dir); + + /* Concatenate the path name and the filename. */ + + if (buf.ptr > buf.buf + && !is_file_name_separator (SCM_MAKE_CHAR (buf.ptr[-1]))) + stringbuf_cat (&buf, FILE_NAME_SEPARATOR_STRING); + + stringbuf_cat (&buf, filename_chars); + sans_ext_len = buf.ptr - buf.buf; + + /* Try every extension. */ + for (exts = extensions; scm_is_pair (exts); exts = SCM_CDR (exts)) + { + SCM ext = SCM_CAR (exts); + + buf.ptr = buf.buf + sans_ext_len; + stringbuf_cat_locale_string (&buf, ext); + + /* If the file exists at all, we should return it. If the + file is inaccessible, then that's an error. */ + + if (stat (buf.buf, &stat_buf) == 0 + && ! (stat_buf.st_mode & S_IFDIR)) + { + SCM found = + scm_from_locale_string (scm_i_mirror_backslashes (buf.buf)); + + if (scm_is_true (source_file_name) && + !compiled_is_fresh (source_file_name, found, + source_stat_buf, &stat_buf)) + { + if (found_stale_file) + *found_stale_file = 1; + continue; + } + + result = try_load_thunk_from_file (found); + if (scm_is_false (result)) + /* Already warned. */ + continue; + + if (found_stale_file && *found_stale_file) + { + scm_puts (";;; found fresh compiled file at ", + scm_current_warning_port ()); + scm_display (found, scm_current_warning_port ()); + scm_newline (scm_current_warning_port ()); + } + + goto end; + } + } + + if (!SCM_NULL_OR_NIL_P (exts)) + scm_wrong_type_arg_msg (NULL, 0, extensions, "proper list"); + } + + if (!SCM_NULL_OR_NIL_P (path)) + scm_wrong_type_arg_msg (NULL, 0, path, "proper list"); + + end: + scm_dynwind_end (); + return result; +} + /* Search PATH for a directory containing a file named FILENAME. The file must be readable, and not a directory. If we find one, return its full pathname; otherwise, return #f. @@ -577,17 +788,10 @@ compiled_is_fresh (SCM full_filename, SCM compiled_filename, We also fill *stat_buf corresponding to the returned pathname. If given, EXTENSIONS is a list of strings; for each directory in PATH, we search for FILENAME concatenated with each EXTENSION. - - If SOURCE_FILE_NAME is SCM_BOOL_F, then return the first matching - file name that we find in the path. Otherwise only return a file if - it is newer than SOURCE_STAT_BUF, otherwise issuing a warning if we - see a stale file earlier in the path, setting *FOUND_STALE_FILE to 1. */ static SCM search_path (SCM path, SCM filename, SCM extensions, SCM require_exts, - struct stat *stat_buf, - SCM source_file_name, struct stat *source_stat_buf, - int *found_stale_file) + struct stat *stat_buf) { struct stringbuf buf; char *filename_chars; @@ -690,27 +894,8 @@ search_path (SCM path, SCM filename, SCM extensions, SCM require_exts, if (stat (buf.buf, stat_buf) == 0 && ! (stat_buf->st_mode & S_IFDIR)) { - SCM found = + result = scm_from_locale_string (scm_i_mirror_backslashes (buf.buf)); - - if (scm_is_true (source_file_name) && - !compiled_is_fresh (source_file_name, found, - source_stat_buf, stat_buf)) - { - if (found_stale_file) - *found_stale_file = 1; - continue; - } - - if (found_stale_file && *found_stale_file) - { - scm_puts (";;; found fresh compiled file at ", - scm_current_warning_port ()); - scm_display (found, scm_current_warning_port ()); - scm_newline (scm_current_warning_port ()); - } - - result = found; goto end; } } @@ -780,8 +965,7 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 0, 1, if (SCM_UNBNDP (require_exts)) require_exts = SCM_BOOL_F; - return search_path (path, filename, extensions, require_exts, &stat_buf, - SCM_BOOL_F, NULL, NULL); + return search_path (path, filename, extensions, require_exts, &stat_buf); } #undef FUNC_NAME @@ -806,7 +990,7 @@ SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0, SCM_VALIDATE_STRING (1, filename); return search_path (*scm_loc_load_path, filename, *scm_loc_load_extensions, - SCM_BOOL_F, &stat_buf, SCM_BOOL_F, NULL, NULL); + SCM_BOOL_F, &stat_buf); } #undef FUNC_NAME @@ -973,7 +1157,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, #define FUNC_NAME s_scm_primitive_load_path { SCM filename, exception_on_not_found; - SCM full_filename, compiled_filename; + SCM full_filename, compiled_thunk; SCM hook = *scm_loc_load_hook; struct stat stat_source, stat_compiled; int found_stale_compiled_file = 0; @@ -1010,15 +1194,12 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, full_filename = search_path (*scm_loc_load_path, filename, *scm_loc_load_extensions, SCM_BOOL_F, - &stat_source, SCM_BOOL_F, NULL, NULL); + &stat_source); - compiled_filename = - search_path (*scm_loc_load_compiled_path, filename, - *scm_loc_load_compiled_extensions, SCM_BOOL_T, - &stat_compiled, full_filename, &stat_source, - &found_stale_compiled_file); + compiled_thunk = load_thunk_from_path (filename, full_filename, &stat_source, + &found_stale_compiled_file); - if (scm_is_false (compiled_filename) + if (scm_is_false (compiled_thunk) && scm_is_true (full_filename) && scm_is_true (*scm_loc_compile_fallback_path) && scm_is_false (*scm_loc_fresh_auto_compile) @@ -1045,12 +1226,12 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, scm_display (fallback, scm_current_warning_port ()); scm_newline (scm_current_warning_port ()); } - compiled_filename = fallback; + compiled_thunk = try_load_thunk_from_file (fallback); } free (fallback_chars); } - if (scm_is_false (full_filename) && scm_is_false (compiled_filename)) + if (scm_is_false (full_filename) && scm_is_false (compiled_thunk)) { if (scm_is_true (scm_procedure_p (exception_on_not_found))) return scm_call_0 (exception_on_not_found); @@ -1062,17 +1243,16 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, } if (!scm_is_false (hook)) - scm_call_1 (hook, (scm_is_true (full_filename) - ? full_filename : compiled_filename)); + scm_call_1 (hook, full_filename); - if (scm_is_true (compiled_filename)) - return scm_load_compiled_with_vm (compiled_filename); + if (scm_is_true (compiled_thunk)) + return scm_call_0 (compiled_thunk); else { SCM freshly_compiled = scm_try_auto_compile (full_filename); if (scm_is_true (freshly_compiled)) - return scm_load_compiled_with_vm (freshly_compiled); + return scm_call_0 (scm_load_thunk_from_file (freshly_compiled)); else return scm_primitive_load (full_filename); } @@ -1088,21 +1268,19 @@ scm_c_primitive_load_path (const char *filename) void scm_init_eval_in_scheme (void) { - SCM eval_scm, eval_go; - struct stat stat_source, stat_compiled; + SCM eval_scm, eval_thunk; + struct stat stat_source; int found_stale_eval_go = 0; eval_scm = search_path (*scm_loc_load_path, scm_from_locale_string ("ice-9/eval.scm"), - SCM_EOL, SCM_BOOL_F, &stat_source, - SCM_BOOL_F, NULL, NULL); - eval_go = search_path (*scm_loc_load_compiled_path, - scm_from_locale_string ("ice-9/eval.go"), - SCM_EOL, SCM_BOOL_F, &stat_compiled, - eval_scm, &stat_source, &found_stale_eval_go); + SCM_EOL, SCM_BOOL_F, &stat_source); + eval_thunk = + load_thunk_from_path (scm_from_locale_string ("ice-9/eval.go"), + eval_scm, &stat_source, &found_stale_eval_go); - if (scm_is_true (eval_go)) - scm_load_compiled_with_vm (eval_go); + if (scm_is_true (eval_thunk)) + scm_call_0 (eval_thunk); else /* If we have no eval.go, we shouldn't load any compiled code at all because we can't guarantee that tail calls will work. */ diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index ee3648027..6eae844fe 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -3728,19 +3728,23 @@ when none is available, reading FILE-NAME with READER." #:opts %auto-compilation-options #:env (current-module))) - ;; Returns the .go file corresponding to `name'. Does not search load - ;; paths, only the fallback path. If the .go file is missing or out - ;; of date, and auto-compilation is enabled, will try - ;; auto-compilation, just as primitive-load-path does internally. - ;; primitive-load is unaffected. Returns #f if auto-compilation - ;; failed or was disabled. + (define (load-thunk-from-file file) + (let ((loader (resolve-interface '(system vm loader)))) + ((module-ref loader 'load-thunk-from-file) file))) + + ;; Returns a thunk loaded from the .go file corresponding to `name'. + ;; Does not search load paths, only the fallback path. If the .go + ;; file is missing or out of date, and auto-compilation is enabled, + ;; will try auto-compilation, just as primitive-load-path does + ;; internally. primitive-load is unaffected. Returns #f if + ;; auto-compilation failed or was disabled. ;; ;; NB: Unless we need to compile the file, this function should not ;; cause (system base compile) to be loaded up. For that reason ;; compiled-file-name partially duplicates functionality from (system ;; base compile). - (define (fresh-compiled-file-name name scmstat go-file-name) + (define (fresh-compiled-thunk name scmstat go-file-name) ;; Return GO-FILE-NAME after making sure that it contains a freshly ;; compiled version of source file NAME with stat SCMSTAT; return #f ;; on failure. @@ -3748,19 +3752,19 @@ when none is available, reading FILE-NAME with READER." (let ((gostat (and (not %fresh-auto-compile) (stat go-file-name #f)))) (if (and gostat (more-recent? gostat scmstat)) - go-file-name + (load-thunk-from-file go-file-name) (begin - (if gostat - (format (current-warning-port) - ";;; note: source file ~a\n;;; newer than compiled ~a\n" - name go-file-name)) + (when gostat + (format (current-warning-port) + ";;; note: source file ~a\n;;; newer than compiled ~a\n" + name go-file-name)) (cond (%load-should-auto-compile (%warn-auto-compilation-enabled) (format (current-warning-port) ";;; compiling ~a\n" name) (let ((cfn (compile name))) (format (current-warning-port) ";;; compiled ~a\n" cfn) - cfn)) + (load-thunk-from-file cfn))) (else #f))))) #:warning "WARNING: compilation of ~a failed:\n" name)) @@ -3779,28 +3783,36 @@ when none is available, reading FILE-NAME with READER." #:warning "Stat of ~a failed:\n" abs-file-name)) (define (pre-compiled) - (and=> (search-path %load-compiled-path (sans-extension file-name) - %load-compiled-extensions #t) - (lambda (go-file-name) - (let ((gostat (stat go-file-name #f))) - (and gostat (more-recent? gostat scmstat) - go-file-name))))) + (or-map + (lambda (dir) + (or-map + (lambda (ext) + (let ((candidate (string-append (in-vicinity dir file-name) ext))) + (let ((gostat (stat candidate #f))) + (and gostat + (more-recent? gostat scmstat) + (false-if-exception + (load-thunk-from-file candidate) + #:warning "WARNING: failed to load compiled file ~a:\n" + candidate))))) + %load-compiled-extensions)) + %load-compiled-path)) (define (fallback) (and=> (false-if-exception (canonicalize-path abs-file-name)) (lambda (canon) (and=> (fallback-file-name canon) (lambda (go-file-name) - (fresh-compiled-file-name abs-file-name - scmstat - go-file-name)))))) + (fresh-compiled-thunk abs-file-name + scmstat + go-file-name)))))) (let ((compiled (and scmstat (or (pre-compiled) (fallback))))) (if compiled (begin (if %load-hook (%load-hook abs-file-name)) - (load-compiled compiled)) + (compiled)) (start-stack 'load-stack (primitive-load abs-file-name))))) From 8b875670858fdf6bdf4cee7b4e1eab575379b057 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 17 Jun 2016 15:05:39 +0200 Subject: [PATCH 380/865] Fix 64->32 bit cross-compilation of large-ish fixnums * module/system/vm/assembler.scm (immediate-bits): Fix a bug whereby compiling to a 32-bit target from a 64-bit host would treat all integers whose representation fit into 32 bits as immediates. This would result in integer constants between #x20000000 and 0x3fffffff being residualized in such a way that they would be loaded as negative numbers. --- module/system/vm/assembler.scm | 46 +++++++++++++++++----------------- 1 file changed, 23 insertions(+), 23 deletions(-) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 2ee608111..fb7f07478 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -939,32 +939,32 @@ lists. This procedure can be called many times before calling ;;; to the table. ;;; -(define tc2-int 2) (define (immediate-bits asm x) "Return the bit pattern to write into the buffer if @var{x} is immediate, and @code{#f} otherwise." - (let* ((bits (object-address x)) - (mask (case (asm-word-size asm) - ((4) #xffffffff) - ((8) #xffffffffFFFFFFFF) - (else (error "unexpected word size")))) - (fixnum-min (1- (ash mask -3))) - (fixnum-max (ash mask -3))) - (cond - ((not (zero? (logand bits 6))) - ;; Object is an immediate on the host. It's immediate if it can - ;; fit into a word on the target. - (and (= bits (logand bits mask)) - bits)) - ((and (exact-integer? x) (<= fixnum-min x fixnum-max)) - ;; Object is a bignum that would be an immediate on the target. - (let ((fixnum-bits (if (negative? x) - (+ fixnum-max 1 (logand x fixnum-max)) - x))) - (logior (ash x 2) tc2-int))) - (else - ;; Otherwise not an immediate. - #f)))) + (define tc2-int 2) + (if (exact-integer? x) + ;; Object is an immediate if it is a fixnum on the target. + (call-with-values (lambda () + (case (asm-word-size asm) + ((4) (values #x1fffffff + (- #x20000000))) + ((8) (values #x1fffffffFFFFFFFF + (- #x2000000000000000))) + (else (error "unexpected word size")))) + (lambda (fixnum-min fixnum-max) + (and (<= fixnum-min x fixnum-max) + (let ((fixnum-bits (if (negative? x) + (+ fixnum-max 1 (logand x fixnum-max)) + x))) + (logior (ash fixnum-bits 2) tc2-int))))) + ;; Otherwise, the object will be immediate on the target if and + ;; only if it is immediate on the host. Except for integers, + ;; which we handle specially above, any immediate value is an + ;; immediate on both 32-bit and 64-bit targets. + (let ((bits (object-address x))) + (and (not (zero? (logand bits 6))) + bits)))) (define-record-type (make-stringbuf string) From 0c1ee6eae63bf6ea5e516569d1c6ead4afde39f2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 18 Jun 2016 13:08:12 +0200 Subject: [PATCH 381/865] Fix ports bug when size_t is 32 bits * libguile/ports.c (scm_end_input): I am a complete idiot. I had no idea that `- (uint32_t) x' is actually still a uint32_t. --- libguile/ports.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 2694dcf5f..858dd01ab 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -2307,12 +2307,14 @@ scm_end_input (SCM port) { SCM buf; size_t discarded; + scm_t_off offset; buf = SCM_PORT (port)->read_buf; discarded = scm_port_buffer_take (buf, NULL, (size_t) -1); + offset = - (scm_t_off) discarded; - if (discarded != 0) - SCM_PORT_TYPE (port)->seek (port, -discarded, SEEK_CUR); + if (offset != 0) + SCM_PORT_TYPE (port)->seek (port, offset, SEEK_CUR); } SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0, From d88869539ddee9a5a2e1e52fea67c8a6ade6876a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 18 Jun 2016 13:16:04 +0200 Subject: [PATCH 382/865] Minor NEWS updates * NEWS: Minor updates. --- NEWS | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index ff18b39ad..a54aa1db5 100644 --- a/NEWS +++ b/NEWS @@ -28,8 +28,8 @@ performant and expressive as possible. The interface to the user has no significant change, neither on the C side nor on the Scheme side. However this refactoring has changed the -interface to the port implementor in an incompatible way. See below for -full details. +interface to the port implementor in an incompatible way. See +"Incompatible changes" below for full details. ** All ports are now buffered, can be targets of `setvbuf' @@ -57,6 +57,11 @@ locks. For that reason we have removed port locks, and removed the * New interfaces ** `TCP_NODELAY' and `TCP_CORK' socket options, if provided by the system +** `scm_c_put_latin1_chars', `scm_c_put_utf32_chars' + +Use these instead of `scm_lfwrite'. See the new "Using Ports from C" +section of the manual, for more. + * New deprecations ** `_IONBF', `_IOLBF', and `_IOFBF' From 3bea4c6970775e33a8fd2d316a6e597343e4a3c4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 18 Jun 2016 21:55:24 +0200 Subject: [PATCH 383/865] Bump version to 2.1.3 * GUILE-VERSION (GUILE_MICRO_VERSION): Bump to 2.1.3. --- GUILE-VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index 6d1025b34..919a669e4 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -3,7 +3,7 @@ # Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'. GUILE_MAJOR_VERSION=2 GUILE_MINOR_VERSION=1 -GUILE_MICRO_VERSION=2 +GUILE_MICRO_VERSION=3 GUILE_EFFECTIVE_VERSION=2.2 From ff040ee033a843f0574bd75e936ad03523443426 Mon Sep 17 00:00:00 2001 From: "Diogo F. S. Ramos" Date: Wed, 26 Mar 2014 00:27:20 -0300 Subject: [PATCH 384/865] Remove link to Emacs' regexp syntax Linking to Emacs' regexps as an example of regexp syntax gives the wrong impression that Guile supports it, which is not true. * doc/ref/api-regex.texi: Remove link to Emacs' regexp syntax --- doc/ref/api-regex.texi | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/doc/ref/api-regex.texi b/doc/ref/api-regex.texi index 082fb874d..f95eddbae 100644 --- a/doc/ref/api-regex.texi +++ b/doc/ref/api-regex.texi @@ -14,10 +14,7 @@ A @dfn{regular expression} (or @dfn{regexp}) is a pattern that describes a whole class of strings. A full description of regular -expressions and their syntax is beyond the scope of this manual; -an introduction can be found in the Emacs manual (@pxref{Regexps, -, Syntax of Regular Expressions, emacs, The GNU Emacs Manual}), or -in many general Unix reference books. +expressions and their syntax is beyond the scope of this manual. If your system does not include a POSIX regular expression library, and you have not linked Guile with a third-party regexp library such From 4cf81b7ba07f9c1d7acffcfe145478e91df365e6 Mon Sep 17 00:00:00 2001 From: "Diogo F. S. Ramos" Date: Wed, 26 Mar 2014 00:27:21 -0300 Subject: [PATCH 385/865] Add reference to the lack of "non-greedy" variants While describing special characters, remind the reader that "non-greedy" variants are not supported. They might not be familiar with POSIX extended regular expression and expect it to work. * doc/ref/api-regex.texi: Add "non-greedy" observation --- doc/ref/api-regex.texi | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/doc/ref/api-regex.texi b/doc/ref/api-regex.texi index f95eddbae..b14c2b39c 100644 --- a/doc/ref/api-regex.texi +++ b/doc/ref/api-regex.texi @@ -38,10 +38,11 @@ regex))}. @node Regexp Functions @subsection Regexp Functions -By default, Guile supports POSIX extended regular expressions. -That means that the characters @samp{(}, @samp{)}, @samp{+} and -@samp{?} are special, and must be escaped if you wish to match the -literal characters. +By default, Guile supports POSIX extended regular expressions. That +means that the characters @samp{(}, @samp{)}, @samp{+} and @samp{?} are +special, and must be escaped if you wish to match the literal characters +and there is no support for ``non-greedy'' variants of @samp{*}, +@samp{+} or @samp{?}. This regular expression interface was modeled after that implemented by SCSH, the Scheme Shell. It is intended to be From 687d393e2c9dbc57fa1d0290fbf3b2c93cbfcdf6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 20 Jun 2016 14:34:19 +0200 Subject: [PATCH 386/865] Fix uri-decode behavior for "+" * module/web/uri.scm (uri-decode): Add #:decode-plus-to-space? keyword argument. (split-and-decode-uri-path): Don't decode plus to space. * doc/ref/web.texi (URIs): Update documentation. * test-suite/tests/web-uri.test ("decode"): Add tests. * NEWS: Add entry. Based on a patch by Brent . --- NEWS | 7 +++++++ doc/ref/web.texi | 7 ++++++- module/web/uri.scm | 11 ++++++++--- test-suite/tests/web-uri.test | 5 ++++- 4 files changed, 25 insertions(+), 5 deletions(-) diff --git a/NEWS b/NEWS index a54aa1db5..651d0d76a 100644 --- a/NEWS +++ b/NEWS @@ -6,6 +6,13 @@ Please send Guile bug reports to bug-guile@gnu.org. +Changes in 2.1.4 (changes since the 2.1.3 alpha release): + +* Bug fixes +** Don't replace + with space when splitting and decoding URI paths + + +[TODO: Fold into generic 2.2 release notes.] Changes in 2.1.3 (changes since the 2.1.2 alpha release): * Notable changes diff --git a/doc/ref/web.texi b/doc/ref/web.texi index b078929e4..becdc28db 100644 --- a/doc/ref/web.texi +++ b/doc/ref/web.texi @@ -269,7 +269,7 @@ serialization. Declare a default port for the given URI scheme. @end deffn -@deffn {Scheme Procedure} uri-decode str [#:encoding=@code{"utf-8"}] +@deffn {Scheme Procedure} uri-decode str [#:encoding=@code{"utf-8"}] [#:decode-plus-to-space? #t] Percent-decode the given @var{str}, according to @var{encoding}, which should be the name of a character encoding. @@ -286,6 +286,11 @@ decoded bytes are not valid for the given encoding. Pass @code{#f} for @xref{Ports, @code{set-port-encoding!}}, for more information on character encodings. +If @var{decode-plus-to-space?} is true, which is the default, also +replace instances of the plus character @samp{+} with a space character. +This is needed when parsing @code{application/x-www-form-urlencoded} +data. + Returns a string of the decoded characters, or a bytevector if @var{encoding} was @code{#f}. @end deffn diff --git a/module/web/uri.scm b/module/web/uri.scm index e1c8b3998..848d5009b 100644 --- a/module/web/uri.scm +++ b/module/web/uri.scm @@ -322,7 +322,7 @@ serialization." (define hex-chars (string->char-set "0123456789abcdefABCDEF")) -(define* (uri-decode str #:key (encoding "utf-8")) +(define* (uri-decode str #:key (encoding "utf-8") (decode-plus-to-space? #t)) "Percent-decode the given STR, according to ENCODING, which should be the name of a character encoding. @@ -338,6 +338,10 @@ bytes are not valid for the given encoding. Pass ‘#f’ for ENCODING if you want decoded bytes as a bytevector directly. ‘set-port-encoding!’, for more information on character encodings. +If DECODE-PLUS-TO-SPACE? is true, which is the default, also replace +instances of the plus character (+) with a space character. This is +needed when parsing application/x-www-form-urlencoded data. + Returns a string of the decoded characters, or a bytevector if ENCODING was ‘#f’." (let* ((len (string-length str)) @@ -348,7 +352,7 @@ ENCODING was ‘#f’." (if (< i len) (let ((ch (string-ref str i))) (cond - ((eqv? ch #\+) + ((and (eqv? ch #\+) decode-plus-to-space?) (put-u8 port (char->integer #\space)) (lp (1+ i))) ((and (< (+ i 2) len) (eqv? ch #\%) @@ -431,7 +435,8 @@ removing empty components. For example, ‘\"/foo/bar%20baz/\"’ decodes to the two-element list, ‘(\"foo\" \"bar baz\")’." (filter (lambda (x) (not (string-null? x))) - (map uri-decode (string-split path #\/)))) + (map (lambda (s) (uri-decode s #:decode-plus-to-space? #f)) + (string-split path #\/)))) (define (encode-and-join-uri-path parts) "URI-encode each element of PARTS, which should be a list of diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test index 4873d7f71..ad56f6f2d 100644 --- a/test-suite/tests/web-uri.test +++ b/test-suite/tests/web-uri.test @@ -594,7 +594,10 @@ (equal? "foo bar" (uri-decode "foo%20bar"))) (pass-if "foo+bar" - (equal? "foo bar" (uri-decode "foo+bar")))) + (equal? "foo bar" (uri-decode "foo+bar"))) + + (pass-if "foo+bar" + (equal? '("foo+bar") (split-and-decode-uri-path "foo+bar")))) (with-test-prefix "encode" (pass-if (equal? "foo%20bar" (uri-encode "foo bar"))) From dc7bc06f69162517407606920b37bde7054fbf49 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 20 Jun 2016 17:11:59 +0200 Subject: [PATCH 387/865] Fix size measurement in bytevector_large_set * libguile/bytevectors.c (bytevector_large_set): Fix computation of value size in words. * test-suite/tests/bytevectors.test: Add test. Thanks to Ben Rocer for the bug report and fix. --- libguile/bytevectors.c | 7 ++++--- test-suite/tests/bytevectors.test | 6 +++++- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index 54eef8b8e..e426ae3a7 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -875,10 +875,11 @@ bytevector_large_set (char *c_bv, size_t c_size, int signed_p, memset (c_bv, 0, c_size); else { - size_t word_count, value_size; + size_t word_count, value_words; - value_size = (mpz_sizeinbase (c_mpz, 2) + (8 * c_size)) / (8 * c_size); - if (SCM_UNLIKELY (value_size > c_size)) + value_words = ((mpz_sizeinbase (c_mpz, 2) + (8 * c_size) - 1) / + (8 * c_size)); + if (SCM_UNLIKELY (value_words > 1)) { err = -2; goto finish; diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test index f8f020a30..f0d9f1983 100644 --- a/test-suite/tests/bytevectors.test +++ b/test-suite/tests/bytevectors.test @@ -343,7 +343,11 @@ (let ((b (make-bytevector 8))) (bytevector-s64-set! b 0 -1 (endianness big)) (bytevector-u64-set! b 0 0 (endianness big)) - (= 0 (bytevector-u64-ref b 0 (endianness big)))))) + (= 0 (bytevector-u64-ref b 0 (endianness big))))) + + (pass-if-exception "bignum out of range" + exception:out-of-range + (bytevector-u64-set! (make-bytevector 8) 0 (expt 2 64) (endianness big)))) (with-test-prefix/c&e "2.8 Operations on IEEE-754 Representations" From 5b6eaa91d23199f9266a3c338b8be8dcad5ecc38 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 20 Jun 2016 21:21:20 +0200 Subject: [PATCH 388/865] Document char-ready? limitations. * doc/ref/api-io.texi (Venerable Port Interfaces): Document limitations of char-ready?. See http://debbugs.gnu.org/10627. --- doc/ref/api-io.texi | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 9b32c8728..48ff1779c 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -1410,6 +1410,22 @@ has been asserted by @code{char-ready?} cannot be rubbed out. If @code{char-ready?} were to return @code{#f} at end of file, a port at end of file would be indistinguishable from an interactive port that has no ready characters. + +Note that @code{char-ready?} only works reliably for terminals and +sockets with one-byte encodings. Under the hood it will return +@code{#t} if the port has any input buffered, or if the file descriptor +that backs the port polls as readable, indicating that Guile can fetch +more bytes from the kernel. However being able to fetch one byte +doesn't mean that a full character is available; @xref{Encoding}. Also, +on many systems it's possible for a file descriptor to poll as readable, +but then block when it comes time to read bytes. Note also that on +Linux kernels, all file ports backed by files always poll as readable. +For non-file ports, this procedure always returns @code{#t}, except for +soft ports, which have a @code{char-ready?} handler. @xref{Soft Ports}. + +In short, this is a legacy procedure whose semantics are hard to +provide. However it is a useful check to see if any input is buffered. +@xref{Non-Blocking I/O}. @end deffn @rnindex read-char From fff013215fb1a5d211df5037dcf52c92063050a8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 20 Jun 2016 22:04:45 +0200 Subject: [PATCH 389/865] Fix peval on (call-with-values foo (lambda (x) x)) * module/language/tree-il/peval.scm (peval): Don't inline (call-with-values foo (lambda (x) exp)) to (let ((x (foo))) exp). The idea is that call-with-values sets up an explicit context in which we are requesting an explicit return arity, and that dropping extra values when there's not a rest argument is the wrong thing. Fixes #13966. * test-suite/tests/peval.test ("partial evaluation"): Update test. --- module/language/tree-il/peval.scm | 4 ---- test-suite/tests/peval.test | 6 ++++-- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 1cf2cb1a8..8e1069d38 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -1014,10 +1014,6 @@ 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 - (($ src (req-name) #f #f #f () (req-sym) body #f) - (for-tail - (make-let src (list req-name) (list req-sym) (list producer) - body))) ((and ($ src () #f rest #f () (rest-sym) body #f) (? (lambda _ (singly-valued-expression? producer)))) (let ((tmp (gensym "tmp "))) diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test index 547510311..340780873 100644 --- a/test-suite/tests/peval.test +++ b/test-suite/tests/peval.test @@ -1354,8 +1354,10 @@ (pass-if-peval (call-with-values foo (lambda (x) (bar x))) - (let (x) (_) ((call (toplevel foo))) - (call (toplevel bar) (lexical x _)))) + (let-values (call (toplevel foo)) + (lambda-case + (((x) #f #f #f () (_)) + (call (toplevel bar) (lexical x _)))))) (pass-if-peval ((lambda (foo) From e877e1bccb8b288bf9742c97a3035e36cba5a70b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 21 Jun 2016 08:35:59 +0200 Subject: [PATCH 390/865] Document sigaction + SA_RESTART * doc/ref/posix.texi (Signals): Document interaction between Guile's signal handling and SA_RESTART. Fixes #14640. --- doc/ref/posix.texi | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 09bcd816b..118843d79 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -2075,6 +2075,22 @@ restart the system call (as opposed to returning an @code{EINTR} error from that call). @end defvar +Guile handles signals asynchronously. When it receives a signal, the +synchronous signal handler just records the fact that a signal was +received and sets a flag to tell the relevant Guile thread that it has a +pending signal. When the Guile thread checks the pending-interrupt +flag, it will arrange to run the asynchronous part of the signal +handler, which is the handler attached by @code{sigaction}. + +This strategy has some perhaps-unexpected interactions with the +@code{SA_RESTART} flag, though: because the synchronous handler doesn't +do very much, and notably it doesn't run the Guile handler, it's +impossible to interrupt a thread stuck in a long-running system call via +a signal handler that is installed with @code{SA_RESTART}: the +synchronous handler just records the pending interrupt, but then the +system call resumes and Guile doesn't have a chance to actually check +the flag and run the asynchronous handler. That's just how it is. + The return value is a pair with information about the old handler as described above. From 845c873acf8cb57766dfbd565640a84d5d05ddb0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 21 Jun 2016 09:07:26 +0200 Subject: [PATCH 391/865] Add another code coverage test * test-suite/tests/coverage.test ("line-execution-counts"): Add a test from Taylan Ulrich B, from bug #14849. --- test-suite/tests/coverage.test | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/coverage.test b/test-suite/tests/coverage.test index 0fa1c1091..c1b417f03 100644 --- a/test-suite/tests/coverage.test +++ b/test-suite/tests/coverage.test @@ -196,7 +196,25 @@ (with-code-coverage (lambda () (proc 451 1884))))) (let ((counts (line-execution-counts data "one-liner.scm"))) - (equal? counts '((0 . 1)))))))) + (equal? counts '((0 . 1))))))) + + (pass-if "tail calls" + (let ((proc (code "tail-calls.scm" + "(begin + (define (tail-call-test) + (display \"foo\\n\") + (tail-call-target)) + + (define (tail-call-target) + (display \"bar\\n\")) + + tail-call-test)"))) + (let-values (((data result) + (with-code-coverage + (lambda () (with-output-to-string proc))))) + (let ((counts (line-execution-counts data "tail-calls.scm"))) + (lset= equal? '((1 . 1) (2 . 1) (3 . 1) (5 . 1) (6 . 1)) + counts)))))) (with-test-prefix "procedure-execution-count" From beea6302e06e7e41b1b835b2327febc97177010e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 21 Jun 2016 09:32:30 +0200 Subject: [PATCH 392/865] Fix fixnum-range changes in R6RS fixnum bitops * module/rnrs/arithmetic/fixnums.scm (fxcopy-bit, fxbit-field) (fxcopy-bit-field, fxarithmetic-shift) (fxarithmetic-shift-left, fx-arithmetic-shift-right) (fxrotate-bit-field, fxreverse-bit-field): Enforce range on amount by which to shift. Fixes #14917. * test-suite/tests/r6rs-arithmetic-fixnums.test ("fxarithmetic-shift-left"): Update test to not shift left by a negative amount. --- module/rnrs/arithmetic/fixnums.scm | 28 +++++++++++++++++-- test-suite/tests/r6rs-arithmetic-fixnums.test | 2 +- 2 files changed, 26 insertions(+), 4 deletions(-) diff --git a/module/rnrs/arithmetic/fixnums.scm b/module/rnrs/arithmetic/fixnums.scm index 7a5a6215e..4ec1cae0c 100644 --- a/module/rnrs/arithmetic/fixnums.scm +++ b/module/rnrs/arithmetic/fixnums.scm @@ -242,28 +242,50 @@ (define (fxcopy-bit fx1 fx2 fx3) (assert-fixnum fx1 fx2 fx3) + (unless (and (<= 0 fx2) (< fx2 (fixnum-width))) + (raise (make-assertion-violation))) (bitwise-copy-bit fx1 fx2 fx3)) (define (fxbit-field fx1 fx2 fx3) (assert-fixnum fx1 fx2 fx3) + (unless (and (<= 0 fx2 fx3) (< fx3 (fixnum-width))) + (raise (make-assertion-violation))) (bitwise-bit-field fx1 fx2 fx3)) (define (fxcopy-bit-field fx1 fx2 fx3 fx4) (assert-fixnum fx1 fx2 fx3 fx4) + (unless (and (<= 0 fx2 fx3) (< fx3 (fixnum-width))) + (raise (make-assertion-violation))) (bitwise-copy-bit-field fx1 fx2 fx3 fx4)) - (define (fxarithmetic-shift fx1 fx2) (assert-fixnum fx1 fx2) (ash fx1 fx2)) - (define fxarithmetic-shift-left fxarithmetic-shift) + (define (fxarithmetic-shift fx1 fx2) + (assert-fixnum fx1 fx2) + (unless (< (abs fx2) (fixnum-width)) + (raise (make-assertion-violation))) + (ash fx1 fx2)) + + (define (fxarithmetic-shift-left fx1 fx2) + (assert-fixnum fx1 fx2) + (unless (and (<= 0 fx2) (< fx2 (fixnum-width))) + (raise (make-assertion-violation))) + (ash fx1 fx2)) (define (fxarithmetic-shift-right fx1 fx2) - (assert-fixnum fx1 fx2) (ash fx1 (- fx2))) + (assert-fixnum fx1 fx2) + (unless (and (<= 0 fx2) (< fx2 (fixnum-width))) + (raise (make-assertion-violation))) + (ash fx1 (- fx2))) (define (fxrotate-bit-field fx1 fx2 fx3 fx4) (assert-fixnum fx1 fx2 fx3 fx4) + (unless (and (<= 0 fx2 fx3) (< fx3 (fixnum-width)) (< fx4 (- fx3 fx2))) + (raise (make-assertion-violation))) (bitwise-rotate-bit-field fx1 fx2 fx3 fx4)) (define (fxreverse-bit-field fx1 fx2 fx3) (assert-fixnum fx1 fx2 fx3) + (unless (and (<= 0 fx2 fx3) (< fx3 (fixnum-width))) + (raise (make-assertion-violation))) (bitwise-reverse-bit-field fx1 fx2 fx3)) ) diff --git a/test-suite/tests/r6rs-arithmetic-fixnums.test b/test-suite/tests/r6rs-arithmetic-fixnums.test index 2d9b177f7..9f244722f 100644 --- a/test-suite/tests/r6rs-arithmetic-fixnums.test +++ b/test-suite/tests/r6rs-arithmetic-fixnums.test @@ -202,7 +202,7 @@ (fx=? (fxarithmetic-shift -1 -1) -1)))) (with-test-prefix "fxarithmetic-shift-left" - (pass-if "simple" (fx=? (fxarithmetic-shift-left -6 -1) -3))) + (pass-if "simple" (fx=? (fxarithmetic-shift-left -6 1) -12))) (with-test-prefix "fxarithmetic-shift-right" (pass-if "simple" (fx=? (fxarithmetic-shift-right -6 1) -3))) From c1abe68dbc8580f677388e762760348ea24cbd89 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?= Date: Tue, 21 Jun 2016 00:33:50 +0200 Subject: [PATCH 393/865] (rnrs hashtables): Mutation of immutable hashtable ignored Pinging this thread with a (very slightly) updated patch. :-) [2. text/x-diff; 0001-Hashtable-set-errors-on-immutable-hashtable.patch] From 7f35d515d711e255bba5a89a013d9d92034edf41 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?= Date: Tue, 21 Jun 2016 00:25:19 +0200 Subject: [PATCH] Hashtable-set! errors on immutable hashtable. * module/rnrs/hashtables.scm (hashtable-set!): Raise an assertion violation error when the hashtable is immutable. * test-suite/tests/r6rs-hashtables.test: Fix accordingly. --- module/rnrs/hashtables.scm | 5 +++-- test-suite/tests/r6rs-hashtables.test | 6 ++++-- 2 files changed, 7 insertions(+), 4 deletions(-) diff --git a/module/rnrs/hashtables.scm b/module/rnrs/hashtables.scm index 98d2d7616..5773eb1a8 100644 --- a/module/rnrs/hashtables.scm +++ b/module/rnrs/hashtables.scm @@ -122,8 +122,9 @@ (define (hashtable-set! hashtable key obj) (if (r6rs:hashtable-mutable? hashtable) - (hash-table-set! (r6rs:hashtable-wrapped-table hashtable) key obj)) - *unspecified*) + (hash-table-set! (r6rs:hashtable-wrapped-table hashtable) key obj) + (assertion-violation + 'hashtable-set! "Hashtable is immutable." hashtable))) (define (hashtable-delete! hashtable key) (if (r6rs:hashtable-mutable? hashtable) diff --git a/test-suite/tests/r6rs-hashtables.test b/test-suite/tests/r6rs-hashtables.test index c7812c5b3..dbf685995 100644 --- a/test-suite/tests/r6rs-hashtables.test +++ b/test-suite/tests/r6rs-hashtables.test @@ -20,6 +20,7 @@ (define-module (test-suite test-rnrs-hashtable) :use-module (ice-9 receive) :use-module ((rnrs hashtables) :version (6)) + :use-module ((rnrs exceptions) :version (6)) :use-module (srfi srfi-1) :use-module (test-suite lib)) @@ -130,8 +131,9 @@ (pass-if "hashtable-copy with mutability #f produces immutable copy" (let ((copied-table (hashtable-copy (make-eq-hashtable) #f))) - (hashtable-set! copied-table 'foo 1) - (not (hashtable-ref copied-table 'foo #f))))) + (guard (exc (else #t)) + (hashtable-set! copied-table 'foo 1) + #f)))) (with-test-prefix "hashtable-clear!" (pass-if "hashtable-clear! removes all values from hashtable" From d545e4551dbc1c41babf5b9fd972fdeff62378a3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?= Date: Tue, 21 Jun 2016 00:34:45 +0200 Subject: [PATCH 394/865] (rnrs hashtables): Hash functions of eq? and eqv? hashtables Also pinging this thread with a (very slightly) updated patch. :-) [2. text/x-diff; 0001-Hashtable-hash-function-returns-f-on-eq-and-eqv-tabl.patch] From 17599f6ce7ba0beb100e80455ff99af07333d871 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?= Date: Tue, 21 Jun 2016 00:23:29 +0200 Subject: [PATCH] Hashtable-hash-function returns #f on eq and eqv tables. * module/rnrs/hashtables.scm (r6rs:hashtable)[type]: New field. (r6rs:hashtable-type): New procedure. * test-suite/tests/r6rs-hashtables.test: Add related tests. --- module/rnrs/hashtables.scm | 22 +++++++++++++++------- test-suite/tests/r6rs-hashtables.test | 6 +++++- 2 files changed, 20 insertions(+), 8 deletions(-) diff --git a/module/rnrs/hashtables.scm b/module/rnrs/hashtables.scm index 5773eb1a8..22bae7f09 100644 --- a/module/rnrs/hashtables.scm +++ b/module/rnrs/hashtables.scm @@ -74,8 +74,9 @@ (make-record-type-descriptor 'r6rs:hashtable #f #f #t #t '#((mutable wrapped-table) - (immutable orig-hash-function) - (immutable mutable)))) + (immutable orig-hash-function) + (immutable mutable) + (immutable type)))) (define hashtable? (record-predicate r6rs:hashtable)) (define make-r6rs-hashtable @@ -85,6 +86,7 @@ (define r6rs:hashtable-set-wrapped-table! (record-mutator r6rs:hashtable 0)) (define r6rs:hashtable-orig-hash-function (record-accessor r6rs:hashtable 1)) (define r6rs:hashtable-mutable? (record-accessor r6rs:hashtable 2)) + (define r6rs:hashtable-type (record-accessor r6rs:hashtable 3)) (define hashtable-mutable? r6rs:hashtable-mutable?) @@ -96,13 +98,15 @@ (make-r6rs-hashtable (if k (make-hash-table eq? hashq k) (make-hash-table eq? symbol-hash)) symbol-hash - #t)) + #t + 'eq)) (define* (make-eqv-hashtable #:optional k) (make-r6rs-hashtable (if k (make-hash-table eqv? hashv k) (make-hash-table eqv? hash-by-value)) hash-by-value - #t)) + #t + 'eqv)) (define* (make-hashtable hash-function equiv #:optional k) (let ((wrapped-hash-function (wrap-hash-function hash-function))) @@ -111,7 +115,8 @@ (make-hash-table equiv wrapped-hash-function k) (make-hash-table equiv wrapped-hash-function)) hash-function - #t))) + #t + 'custom))) (define (hashtable-size hashtable) (hash-table-size (r6rs:hashtable-wrapped-table hashtable))) @@ -144,7 +149,8 @@ (make-r6rs-hashtable (hash-table-copy (r6rs:hashtable-wrapped-table hashtable)) (r6rs:hashtable-orig-hash-function hashtable) - (and mutable #t))) + (and mutable #t) + (r6rs:hashtable-type hashtable))) (define* (hashtable-clear! hashtable #:optional k) (if (r6rs:hashtable-mutable? hashtable) @@ -179,4 +185,6 @@ (hash-table-equivalence-function (r6rs:hashtable-wrapped-table hashtable))) (define (hashtable-hash-function hashtable) - (r6rs:hashtable-orig-hash-function hashtable))) + (case (r6rs:hashtable-type hashtable) + ((eq eqv) #f) + (else (r6rs:hashtable-orig-hash-function hashtable))))) diff --git a/test-suite/tests/r6rs-hashtables.test b/test-suite/tests/r6rs-hashtables.test index dbf685995..e2cbc2afc 100644 --- a/test-suite/tests/r6rs-hashtables.test +++ b/test-suite/tests/r6rs-hashtables.test @@ -176,7 +176,11 @@ (with-test-prefix "hashtable-hash-function" (pass-if "hashtable-hash-function returns hash function" (let ((abs-hashtable (make-hashtable abs eqv?))) - (eq? (hashtable-hash-function abs-hashtable) abs)))) + (eq? (hashtable-hash-function abs-hashtable) abs))) + (pass-if "hashtable-hash-function returns #f on eq table" + (eq? #f (hashtable-hash-function (make-eq-hashtable)))) + (pass-if "hashtable-hash-function returns #f on eqv table" + (eq? #f (hashtable-hash-function (make-eqv-hashtable))))) (with-test-prefix "hashtable-mutable?" (pass-if "hashtable-mutable? is #t on mutable hashtables" From 5d9516637b68ddce3c5246a9a883e73cdcbc9097 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 21 Jun 2016 11:06:25 +0200 Subject: [PATCH 395/865] Implement R6RS output-port-buffer-mode * module/rnrs/io/ports.scm (r6rs-open): Set buffer-mode on new port. (output-port-buffer-mode): Implement and export. * module/rnrs.scm (rnrs): Export output-port-buffer-mode * test-suite/tests/r6rs-ports.test (test-output-file-opener): Add tests. --- module/rnrs.scm | 2 +- module/rnrs/io/ports.scm | 19 +++++++++++++++++-- test-suite/tests/r6rs-ports.test | 18 ++++++++++++++++++ 3 files changed, 36 insertions(+), 3 deletions(-) diff --git a/module/rnrs.scm b/module/rnrs.scm index a132c5364..e4a06faf5 100644 --- a/module/rnrs.scm +++ b/module/rnrs.scm @@ -183,7 +183,7 @@ open-file-input-port open-file-output-port open-file-input/output-port make-custom-textual-output-port call-with-string-output-port - flush-output-port put-string + output-port-buffer-mode flush-output-port put-string get-char get-datum get-line get-string-all get-string-n get-string-n! lookahead-char put-char put-datum put-string diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm index 2968dbd9f..0cceb0672 100644 --- a/module/rnrs/io/ports.scm +++ b/module/rnrs/io/ports.scm @@ -63,6 +63,7 @@ call-with-bytevector-output-port call-with-string-output-port make-custom-textual-output-port + output-port-buffer-mode flush-output-port ;; input/output ports @@ -106,6 +107,9 @@ make-i/o-encoding-error i/o-encoding-error-char) (import (ice-9 binary-ports) (only (rnrs base) assertion-violation) + (only (ice-9 ports internal) + port-write-buffer port-buffer-bytevector port-line-buffered?) + (only (rnrs bytevectors) bytevector-length) (rnrs enums) (rnrs records syntactic) (rnrs exceptions) @@ -310,8 +314,9 @@ read from/written to in @var{port}." (lambda () (with-fluids ((%default-port-encoding #f)) (open filename mode)))))) - (cond (transcoder - (set-port-encoding! port (transcoder-codec transcoder)))) + (setvbuf port buffer-mode) + (when transcoder + (set-port-encoding! port (transcoder-codec transcoder))) port)) (define (file-options->mode file-options base-mode) @@ -382,6 +387,16 @@ return the characters accumulated in that port." close) "w")) +(define (output-port-buffer-mode port) + "Return @code{none} if @var{port} is unbuffered, @code{line} if it is +line buffered, or @code{block} otherwise." + (let ((buffering (bytevector-length + (port-buffer-bytevector (port-write-buffer port))))) + (cond + ((= buffering 1) 'none) + ((port-line-buffered? port) 'line) + (else 'block)))) + (define (flush-output-port port) (force-output port)) diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index 4941dd718..8c4ef57e1 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -716,6 +716,24 @@ not `set-port-position!'" binary-port?) (= 0 (stat:size (stat filename))))) + (pass-if "buffer-mode none" + (call-with-port (open filename (file-options no-fail) + (buffer-mode none)) + (lambda (port) + (eq? (output-port-buffer-mode port) 'none)))) + + (pass-if "buffer-mode line" + (call-with-port (open filename (file-options no-fail) + (buffer-mode line)) + (lambda (port) + (eq? (output-port-buffer-mode port) 'line)))) + + (pass-if "buffer-mode block" + (call-with-port (open filename (file-options no-fail) + (buffer-mode block)) + (lambda (port) + (eq? (output-port-buffer-mode port) 'block)))) + (delete-file filename) (pass-if-condition "exception: does-not-exist" From 59f062ec78bca8ac08284771cc09fdb272888f07 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 21 Jun 2016 11:07:34 +0200 Subject: [PATCH 396/865] Export &i/o-decoding, &i/o-encoding from (rnrs) * module/rnrs/io/ports.scm (&i/o-decoding, &i/o-encoding): Rename from &i/o-decoding-error and &i/o-encoding-error, to conform to R6RS. * module/rnrs.scm (rnrs): Export &i/o-decoding, &i/o-encoding, their accessors and constructors. --- module/rnrs.scm | 7 ++++++- module/rnrs/io/ports.scm | 8 ++++---- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/module/rnrs.scm b/module/rnrs.scm index e4a06faf5..436821642 100644 --- a/module/rnrs.scm +++ b/module/rnrs.scm @@ -160,7 +160,12 @@ ;; (rnrs io ports) - file-options buffer-mode buffer-mode? + &i/o-decoding i/o-decoding-error? + make-i/o-decoding-error + &i/o-encoding i/o-encoding-error-char i/o-encoding-error? + make-i/o-encoding-error + + file-options buffer-mode buffer-mode? eol-style native-eol-style error-handling-mode make-transcoder transcoder-codec transcoder-eol-style transcoder-error-handling-mode native-transcoder diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm index 0cceb0672..8ff674894 100644 --- a/module/rnrs/io/ports.scm +++ b/module/rnrs/io/ports.scm @@ -101,9 +101,9 @@ make-i/o-file-does-not-exist-error &i/o-port i/o-port-error? make-i/o-port-error i/o-error-port - &i/o-decoding-error i/o-decoding-error? + &i/o-decoding i/o-decoding-error? make-i/o-decoding-error - &i/o-encoding-error i/o-encoding-error? + &i/o-encoding i/o-encoding-error? make-i/o-encoding-error i/o-encoding-error-char) (import (ice-9 binary-ports) (only (rnrs base) assertion-violation) @@ -411,7 +411,7 @@ line buffered, or @code{block} otherwise." (define-syntax with-i/o-encoding-error (syntax-rules () - "Convert Guile throws to `encoding-error' to `&i/o-encoding-error'." + "Convert Guile throws to `encoding-error' to `&i/o-encoding'." ((_ body ...) ;; XXX: This is heavyweight for small functions like `put-char'. (with-throw-handler 'encoding-error @@ -452,7 +452,7 @@ line buffered, or @code{block} otherwise." (define-syntax with-i/o-decoding-error (syntax-rules () - "Convert Guile throws to `decoding-error' to `&i/o-decoding-error'." + "Convert Guile throws to `decoding-error' to `&i/o-decoding'." ((_ body ...) ;; XXX: This is heavyweight for small functions like `get-char' and ;; `lookahead-char'. From 4e27e3c054442189f05355f631176d94b4f5019f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 21 Jun 2016 11:27:21 +0200 Subject: [PATCH 397/865] Add R6RS bytevector->string, string->bytevector * module/rnrs/io/ports.scm (string->bytevector): (bytevector->string): New procedures. * module/rnrs.scm: Export new procedures. * test-suite/tests/r6rs-ports.test: Add string->bytevector and bytevector->string tests. --- module/rnrs.scm | 1 + module/rnrs/io/ports.scm | 31 +++++++ test-suite/tests/r6rs-ports.test | 134 +++++++++++++++++++++++++++++++ 3 files changed, 166 insertions(+) diff --git a/module/rnrs.scm b/module/rnrs.scm index 436821642..d2b4cb3f6 100644 --- a/module/rnrs.scm +++ b/module/rnrs.scm @@ -170,6 +170,7 @@ make-transcoder transcoder-codec transcoder-eol-style transcoder-error-handling-mode native-transcoder latin-1-codec utf-8-codec utf-16-codec + string->bytevector bytevector->string eof-object? port? input-port? output-port? eof-object port-eof? port-transcoder diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm index 8ff674894..5ddc3d58d 100644 --- a/module/rnrs/io/ports.scm +++ b/module/rnrs/io/ports.scm @@ -36,6 +36,9 @@ transcoder-error-handling-mode native-transcoder latin-1-codec utf-8-codec utf-16-codec + ;; transcoding bytevectors + bytevector->string string->bytevector + ;; input & output ports port? input-port? output-port? port-eof? @@ -110,6 +113,7 @@ (only (ice-9 ports internal) port-write-buffer port-buffer-bytevector port-line-buffered?) (only (rnrs bytevectors) bytevector-length) + (prefix (ice-9 iconv) iconv:) (rnrs enums) (rnrs records syntactic) (rnrs exceptions) @@ -171,6 +175,33 @@ (define (utf-16-codec) "UTF-16") + +;;; +;;; Transcoding bytevectors +;;; + +(define (string->bytevector str transcoder) + "Encode @var{str} using @var{transcoder}, returning a bytevector." + (iconv:string->bytevector + str + (transcoder-codec transcoder) + (case (transcoder-error-handling-mode transcoder) + ((raise) 'error) + ((replace) 'substitute) + (else (error "unsupported error handling mode" + (transcoder-error-handling-mode transcoder)))))) + +(define (bytevector->string bv transcoder) + "Decode @var{bv} using @var{transcoder}, returning a string." + (iconv:bytevector->string + bv + (transcoder-codec transcoder) + (case (transcoder-error-handling-mode transcoder) + ((raise) 'error) + ((replace) 'substitute) + (else (error "unsupported error handling mode" + (transcoder-error-handling-mode transcoder)))))) + ;;; ;;; Internal helpers diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index 8c4ef57e1..b3f11bb20 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -1065,6 +1065,140 @@ not `set-port-position!'" (with-test-prefix "open-file-input/output-port [input]" (test-input-file-opener open-file-input/output-port (test-file)))) +(define exception:encoding-error + '(encoding-error . "")) + +(define exception:decoding-error + '(decoding-error . "")) + + +(with-test-prefix "ascii string" + (let ((s "Hello, World!")) + ;; For ASCII, all of these encodings should be the same. + + (pass-if "to ascii bytevector" + (equal? (string->bytevector s (make-transcoder "ASCII")) + #vu8(72 101 108 108 111 44 32 87 111 114 108 100 33))) + + (pass-if "to ascii bytevector (length check)" + (equal? (string-length s) + (bytevector-length + (string->bytevector s (make-transcoder "ascii"))))) + + (pass-if "from ascii bytevector" + (equal? s + (bytevector->string + (string->bytevector s (make-transcoder "ascii")) + (make-transcoder "ascii")))) + + (pass-if "to utf-8 bytevector" + (equal? (string->bytevector s (make-transcoder "ASCII")) + (string->bytevector s (make-transcoder "utf-8")))) + + (pass-if "to UTF-8 bytevector (testing encoding case sensitivity)" + (equal? (string->bytevector s (make-transcoder "ascii")) + (string->bytevector s (make-transcoder "UTF-8")))) + + (pass-if "from utf-8 bytevector" + (equal? s + (bytevector->string + (string->bytevector s (make-transcoder "utf-8")) + (make-transcoder "utf-8")))) + + (pass-if "to latin1 bytevector" + (equal? (string->bytevector s (make-transcoder "ASCII")) + (string->bytevector s (make-transcoder "latin1")))) + + (pass-if "from latin1 bytevector" + (equal? s + (bytevector->string + (string->bytevector s (make-transcoder "utf-8")) + (make-transcoder "utf-8")))))) + +(with-test-prefix "narrow non-ascii string" + (let ((s "été")) + (pass-if "to latin1 bytevector" + (equal? (string->bytevector s (make-transcoder "latin1")) + #vu8(233 116 233))) + + (pass-if "to latin1 bytevector (length check)" + (equal? (string-length s) + (bytevector-length + (string->bytevector s (make-transcoder "latin1"))))) + + (pass-if "from latin1 bytevector" + (equal? s + (bytevector->string + (string->bytevector s (make-transcoder "latin1")) + (make-transcoder "latin1")))) + + (pass-if "to utf-8 bytevector" + (equal? (string->bytevector s (make-transcoder "utf-8")) + #vu8(195 169 116 195 169))) + + (pass-if "from utf-8 bytevector" + (equal? s + (bytevector->string + (string->bytevector s (make-transcoder "utf-8")) + (make-transcoder "utf-8")))) + + (pass-if-exception "encode latin1 as ascii" exception:encoding-error + (string->bytevector s (make-transcoder "ascii" + (native-eol-style) + (error-handling-mode raise)))) + + (pass-if-exception "misparse latin1 as utf8" exception:decoding-error + (bytevector->string + (string->bytevector s (make-transcoder "latin1")) + (make-transcoder "utf-8" + (native-eol-style) + (error-handling-mode raise)))) + + (pass-if "misparse latin1 as utf8 with substitutions" + (equal? (bytevector->string + (string->bytevector s (make-transcoder "latin1")) + (make-transcoder "utf-8" (native-eol-style) + (error-handling-mode replace))) + "\uFFFDt\uFFFD")) + + (pass-if-exception "misparse latin1 as ascii" exception:decoding-error + (bytevector->string (string->bytevector s (make-transcoder "latin1")) + (make-transcoder "ascii" + (native-eol-style) + (error-handling-mode raise)))))) + + +(with-test-prefix "wide non-ascii string" + (let ((s "ΧΑΟΣ")) + (pass-if "to utf-8 bytevector" + (equal? (string->bytevector s (make-transcoder "utf-8")) + #vu8(206 167 206 145 206 159 206 163) )) + + (pass-if "from utf-8 bytevector" + (equal? s + (bytevector->string + (string->bytevector s (make-transcoder "utf-8")) + (make-transcoder "utf-8")))) + + (pass-if-exception "encode as ascii" exception:encoding-error + (string->bytevector s (make-transcoder "ascii" + (native-eol-style) + (error-handling-mode raise)))) + + (pass-if-exception "encode as latin1" exception:encoding-error + (string->bytevector s (make-transcoder "latin1" + (native-eol-style) + (error-handling-mode raise)))) + + (pass-if "encode as ascii with substitutions" + (equal? (make-string (string-length s) #\?) + (bytevector->string + (string->bytevector s (make-transcoder + "ascii" + (native-eol-style) + (error-handling-mode replace))) + (make-transcoder "ascii")))))) + ;;; Local Variables: ;;; mode: scheme ;;; eval: (put 'guard 'scheme-indent-function 1) From 8ffcd28fde2fab42f1497a33be047f6141bf9b0b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?= Date: Fri, 2 Oct 2015 22:56:04 +0200 Subject: [PATCH 398/865] Fix SRFI-2 (and-let*) implementation. * module/ice-9/and-let-star.scm (%and-let*): Re-implemented this in a more verbose but accurate way. --- module/ice-9/and-let-star.scm | 52 ++++++++++++++++++++++++++--------- 1 file changed, 39 insertions(+), 13 deletions(-) diff --git a/module/ice-9/and-let-star.scm b/module/ice-9/and-let-star.scm index ff15a7a1e..2d53ff384 100644 --- a/module/ice-9/and-let-star.scm +++ b/module/ice-9/and-let-star.scm @@ -1,6 +1,7 @@ ;;;; and-let-star.scm --- and-let* syntactic form (SRFI-2) for Guile ;;;; -;;;; Copyright (C) 1999, 2001, 2004, 2006, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001, 2004, 2006, 2013, +;;;; 2015 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 @@ -22,20 +23,45 @@ (define-syntax %and-let* (lambda (form) (syntax-case form () - ((_ orig-form ()) - #'#t) - ((_ orig-form () body bodies ...) - #'(begin body bodies ...)) - ((_ orig-form ((var exp) c ...) body ...) + + ;; Handle zero-clauses special-case. + ((_ orig-form () . body) + #'(begin #t . body)) + + ;; Reduce clauses down to one regardless of body. + ((_ orig-form ((var expr) rest . rest*) . body) (identifier? #'var) - #'(let ((var exp)) - (and var (%and-let* orig-form (c ...) body ...)))) - ((_ orig-form ((exp) c ...) body ...) - #'(and exp (%and-let* orig-form (c ...) body ...))) - ((_ orig-form (var c ...) body ...) + #'(let ((var expr)) + (and var (%and-let* orig-form (rest . rest*) . body)))) + ((_ orig-form ((expr) rest . rest*) . body) + #'(and expr (%and-let* orig-form (rest . rest*) . body))) + ((_ orig-form (var rest . rest*) . body) (identifier? #'var) - #'(and var (%and-let* orig-form (c ...) body ...))) - ((_ orig-form (bad-clause c ...) body ...) + #'(and var (%and-let* orig-form (rest . rest*) . body))) + + ;; Handle 1-clause cases without a body. + ((_ orig-form ((var expr))) + (identifier? #'var) + #'expr) + ((_ orig-form ((expr))) + #'expr) + ((_ orig-form (var)) + (identifier? #'var) + #'var) + + ;; Handle 1-clause cases with a body. + ((_ orig-form ((var expr)) . body) + (identifier? #'var) + #'(let ((var expr)) + (and var (begin . body)))) + ((_ orig-form ((expr)) . body) + #'(and expr (begin . body))) + ((_ orig-form (var) . body) + (identifier? #'var) + #'(and var (begin . body))) + + ;; Handle bad clauses. + ((_ orig-form (bad-clause . rest) . body) (syntax-violation 'and-let* "Bad clause" #'orig-form #'bad-clause))))) (define-syntax and-let* From daf8d330367dc1f588da117ed0ee5fad0e3731f0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?= Date: Sat, 3 Oct 2015 11:39:27 +0200 Subject: [PATCH 399/865] Add SRFI-2 (and-let*) test suite. * test-suite/tests/srfi-2.test: New file. * test-suite/Makefile.am (SCM_TESTS): Add it. --- test-suite/Makefile.am | 1 + test-suite/tests/srfi-2.test | 77 ++++++++++++++++++++++++++++++++++++ 2 files changed, 78 insertions(+) create mode 100644 test-suite/tests/srfi-2.test diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 822360670..5b498608f 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -129,6 +129,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/sort.test \ tests/srcprop.test \ tests/srfi-1.test \ + tests/srfi-2.test \ tests/srfi-6.test \ tests/srfi-10.test \ tests/srfi-11.test \ diff --git a/test-suite/tests/srfi-2.test b/test-suite/tests/srfi-2.test new file mode 100644 index 000000000..b8de21d71 --- /dev/null +++ b/test-suite/tests/srfi-2.test @@ -0,0 +1,77 @@ +;;;; srfi-2.test --- Test suite for Guile's and-let* macro. -*- scheme -*- +;;;; +;;;; Copyright (C) 2015 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-srfi-2) + #:use-module (test-suite lib) + #:use-module (srfi srfi-2)) + +(pass-if-equal 1 (and-let* () 1)) +(pass-if-equal 2 (and-let* () 1 2)) +(pass-if-equal #t (and-let* ())) + +(pass-if-equal #f (let ((x #f)) (and-let* (x)))) +(pass-if-equal 1 (let ((x 1)) (and-let* (x)))) +(pass-if-equal #f (and-let* ((x #f)))) +(pass-if-equal 1 (and-let* ((x 1)))) +(pass-if-exception "bad clause" '(syntax-error . "Bad clause") + (eval '(and-let* (#f (x 1))) (current-module))) +(pass-if-equal #f (and-let* ((#f) (x 1)))) +(pass-if-exception "bad clause" '(syntax-error . "Bad clause") + (eval '(and-let* (2 (x 1))) (current-module))) +(pass-if-equal 1 (and-let* ((2) (x 1)))) +(pass-if-equal 2 (and-let* ((x 1) (2)))) +(pass-if-equal #f (let ((x #f)) (and-let* (x) x))) +(pass-if-equal "" (let ((x "")) (and-let* (x) x))) +(pass-if-equal "" (let ((x "")) (and-let* (x)))) +(pass-if-equal 2 (let ((x 1)) (and-let* (x) (+ x 1)))) +(pass-if-equal #f (let ((x #f)) (and-let* (x) (+ x 1)))) +(pass-if-equal 2 (let ((x 1)) (and-let* (((positive? x))) (+ x 1)))) +(pass-if-equal #t (let ((x 1)) (and-let* (((positive? x)))))) +(pass-if-equal #f (let ((x 0)) (and-let* (((positive? x))) (+ x 1)))) +(pass-if-equal 3 + (let ((x 1)) (and-let* (((positive? x)) (x (+ x 1))) (+ x 1)))) + +;; This is marked as must-be-error in the original test suite, but +;; that's a mistake of the SRFI author who thinks that rebinding +;; variables in let* is an error; in fact it's allowed in let* +;; (explicitly since R6RS), so it should be allowed by and-let* too. +(pass-if-equal 4 + (let ((x 1)) + (and-let* (((positive? x)) (x (+ x 1)) (x (+ x 1))) (+ x 1)))) + +(pass-if-equal 2 + (let ((x 1)) (and-let* (x ((positive? x))) (+ x 1)))) +(pass-if-equal 2 + (let ((x 1)) (and-let* (((begin x)) ((positive? x))) (+ x 1)))) +(pass-if-equal #f + (let ((x 0)) (and-let* (x ((positive? x))) (+ x 1)))) +(pass-if-equal #f + (let ((x #f)) (and-let* (x ((positive? x))) (+ x 1)))) +(pass-if-equal #f + (let ((x #f)) (and-let* (((begin x)) ((positive? x))) (+ x 1)))) + +(pass-if-equal #f + (let ((x 1)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y)))) +(pass-if-equal #f + (let ((x 0)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y)))) +(pass-if-equal #f + (let ((x #f)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y)))) +(pass-if-equal 3/2 + (let ((x 3)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y)))) + +;;; srfi-2.test ends here From b8f5cdce15ffa529eb9befac2d237058ef20ae7e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 21 Jun 2016 13:39:37 +0200 Subject: [PATCH 400/865] Update and-let-star.test * test-suite/tests/and-let-star.test ("and-let*"): Update test expectations. --- test-suite/tests/and-let-star.test | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/test-suite/tests/and-let-star.test b/test-suite/tests/and-let-star.test index 150600c34..12bf4d300 100644 --- a/test-suite/tests/and-let-star.test +++ b/test-suite/tests/and-let-star.test @@ -46,8 +46,8 @@ (with-test-prefix "one binding" - (pass-if "no result expression (gives #t)" - (and-let* ((x 123)))) + (pass-if "no result expression (gives binding value)" + (equal? (and-let* ((x 123))) 123)) (pass-if "result expression" (and-let* ((x 123)) @@ -64,8 +64,8 @@ (with-test-prefix "one test" - (pass-if "no result expression (gives #t)" - (and-let* (( 123)))) + (pass-if "no result expression (gives test value)" + (equal? (and-let* (( 123))) 123)) (pass-if "result expression" (and-let* (( 123)) From bcc3c6b61b3d1ff411578182c0d5c2604223ab61 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 21 Jun 2016 15:38:00 +0200 Subject: [PATCH 401/865] Detect too-old libunistring at configure-time. * configure.ac: Detect too-old libunistring at configure-time. Fixes #17399. --- configure.ac | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/configure.ac b/configure.ac index b1bd7f1a8..c9c1795c2 100644 --- a/configure.ac +++ b/configure.ac @@ -891,6 +891,13 @@ if test "x$LTLIBUNISTRING" = "x"; then AC_MSG_ERROR([GNU libunistring is required, please install it.]) fi +dnl Sloppy check to make sure people aren't trying to use too-old libunistring. +case "$LIBUNISTRING_VERSION" in + 0.9.0 | 0.9.1 | 0.9.2 ) + AC_MSG_ERROR([libunistring too old. Please install a recent libunistring (>= 0.9.3).]) + ;; +esac + GUILE_LIBUNISTRING_WITH_ICONV_SUPPORT if test "x$ac_cv_libunistring_with_iconv_support" != "xyes"; then AC_MSG_ERROR([No iconv support. Please recompile libunistring with iconv enabled.]) From d0d14f410dd7d64c3852c764f2eb6aabc89ef211 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 21 Jun 2016 16:01:50 +0200 Subject: [PATCH 402/865] Importing modules with #:select no longer grovels private bindings * module/ice-9/boot-9.scm (resolve-interface): Don't look in private interface for #:select bindings. Fixes #17418. * module/system/repl/coop-server.scm: Don't rely on bad #:select behavior. * NEWS: Add entry. --- NEWS | 5 +++++ module/ice-9/boot-9.scm | 1 - module/system/repl/coop-server.scm | 14 +++++++++----- 3 files changed, 14 insertions(+), 6 deletions(-) diff --git a/NEWS b/NEWS index 651d0d76a..4915b94f5 100644 --- a/NEWS +++ b/NEWS @@ -10,6 +10,11 @@ Changes in 2.1.4 (changes since the 2.1.3 alpha release): * Bug fixes ** Don't replace + with space when splitting and decoding URI paths +** Fix bug importing specific bindings with #:select + +It used to be that if #:select didn't find a binding in the public +interface of a module, it would actually grovel in the module's +unexported private bindings. This was not intended and is now fixed. [TODO: Fold into generic 2.2 release notes.] diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 6eae844fe..00899812e 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2798,7 +2798,6 @@ written into the port is returned." (orig (if direct? bspec (car bspec))) (seen (if direct? bspec (cdr bspec))) (var (or (module-local-variable public-i orig) - (module-local-variable module orig) (error ;; fixme: format manually for now (simple-format diff --git a/module/system/repl/coop-server.scm b/module/system/repl/coop-server.scm index c19dda191..f3f5116a9 100644 --- a/module/system/repl/coop-server.scm +++ b/module/system/repl/coop-server.scm @@ -25,14 +25,18 @@ #:use-module (ice-9 threads) #:use-module (ice-9 q) #:use-module (srfi srfi-9) - #:use-module ((system repl repl) - #:select (start-repl* prompting-meta-read)) - #:use-module ((system repl server) - #:select (run-server* make-tcp-server-socket - add-open-socket! close-socket!)) + #:use-module ((system repl server) #:select (make-tcp-server-socket)) #:export (spawn-coop-repl-server poll-coop-repl-server)) +;; Hack to import private bindings from (system repl repl). +(define-syntax-rule (import-private module sym ...) + (begin + (define sym (@@ module sym)) + ...)) +(import-private (system repl repl) start-repl* prompting-meta-read) +(import-private (system repl server) run-server* add-open-socket! close-socket!) + (define-record-type (%make-coop-repl-server mutex queue) coop-repl-server? From 7e88ca6f8a54437842738b8117b63401dae1ee4c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 21 Jun 2016 16:45:37 +0200 Subject: [PATCH 403/865] Document pretty-print #:max-expr-width * doc/ref/misc-modules.texi (Pretty Printing): Document #:max-expr-width keyword argument. Fixes #17657. --- doc/ref/misc-modules.texi | 3 +++ 1 file changed, 3 insertions(+) diff --git a/doc/ref/misc-modules.texi b/doc/ref/misc-modules.texi index c3978c8f0..6c899a905 100644 --- a/doc/ref/misc-modules.texi +++ b/doc/ref/misc-modules.texi @@ -55,6 +55,9 @@ no prefix. @item @nicode{#:width} @var{columns} Print within the given @var{columns}. The default is 79. + +@item @nicode{#:max-expr-width} @var{columns} +The maximum width of an expression. The default is 50. @end table @end deffn From 1f6a8f2a6e35b1cce564b756ac2c2a3f77e98639 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 21 Jun 2016 17:51:07 +0200 Subject: [PATCH 404/865] Use source file permissions for compiled files * module/system/base/compile.scm (call-with-output-file/atomic): Use the permissions of the source file, if available, as the permissions of the compiled file. Fixes #18477. --- module/system/base/compile.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index d6a53d6b3..dfe03fde7 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -59,7 +59,9 @@ (proc tmp) ;; Chmodding by name instead of by port allows this chmod to ;; work on systems without fchmod, like MinGW. - (chmod template (logand #o0666 (lognot (umask)))) + (let ((perms (or (false-if-exception (stat:perms (stat reference))) + (lognot (umask))))) + (chmod template (logand #o0666 perms))) (close-port tmp) (rename-file template filename)) (lambda args From f1c043440312b5504ba03debeaba25c9ac1a3873 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 21 Jun 2016 22:29:55 +0200 Subject: [PATCH 405/865] `define!' instruction returns the variable * doc/ref/vm.texi (Top-Level Environment Instructions): Update documentation. * libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): Bump, sadly. * module/system/vm/assembler.scm (*bytecode-minor-version*): Bump. * libguile/vm-engine.c (define!): Change to store variable in dst slot. * module/language/tree-il/compile-cps.scm (convert): * module/language/cps/compile-bytecode.scm (compile-function): Adapt to define! change. * module/language/cps/effects-analysis.scm (current-module): Fix define! effects. Incidentally here was the bug: in Guile 2.2 you can't have effects on different object kinds in one instruction, without reverting to &unknown-memory-kinds. * test-suite/tests/compiler.test ("regression tests"): Add a test. --- doc/ref/vm.texi | 4 ++-- libguile/_scm.h | 2 +- libguile/vm-engine.c | 13 ++++++++----- module/language/cps/compile-bytecode.scm | 4 ++-- module/language/cps/effects-analysis.scm | 2 +- module/language/tree-il/compile-cps.scm | 5 ++++- module/system/vm/assembler.scm | 2 +- test-suite/tests/compiler.test | 8 ++++++++ 8 files changed, 27 insertions(+), 13 deletions(-) diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 70aa364d9..4505a019c 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -674,9 +674,9 @@ found. If @var{bound?} is true, an error will be signalled if the variable is unbound. @end deftypefn -@deftypefn Instruction {} define! s12:@var{sym} s12:@var{val} +@deftypefn Instruction {} define! s12:@var{dst} s12:@var{sym} Look up a binding for @var{sym} in the current module, creating it if -necessary. Set its value to @var{val}. +necessary. Store that variable to @var{dst}. @end deftypefn @deftypefn Instruction {} toplevel-box s24:@var{dst} r32:@var{var-offset} r32:@var{mod-offset} n32:@var{sym-offset} b1:@var{bound?} x31:@var{_} diff --git a/libguile/_scm.h b/libguile/_scm.h index 2792fd29e..60ad08295 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -268,7 +268,7 @@ void scm_ia64_longjmp (scm_i_jmp_buf *, int); /* Major and minor versions must be single characters. */ #define SCM_OBJCODE_MAJOR_VERSION 3 -#define SCM_OBJCODE_MINOR_VERSION 8 +#define SCM_OBJCODE_MINOR_VERSION 9 #define SCM_OBJCODE_MAJOR_VERSION_STRING \ SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION) #define SCM_OBJCODE_MINOR_VERSION_STRING \ diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 0978636f5..4b5b70bd2 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -1950,18 +1950,21 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (2); } - /* define! sym:12 val:12 + /* define! dst:12 sym:12 * * Look up a binding for SYM in the current module, creating it if * necessary. Set its value to VAL. */ - VM_DEFINE_OP (66, define, "define!", OP1 (X8_S12_S12)) + VM_DEFINE_OP (66, define, "define!", OP1 (X8_S12_S12) | OP_DST) { - scm_t_uint16 sym, val; - UNPACK_12_12 (op, sym, val); + scm_t_uint16 dst, sym; + SCM var; + UNPACK_12_12 (op, dst, sym); SYNC_IP (); - scm_define (SP_REF (sym), SP_REF (val)); + var = scm_module_ensure_local_variable (scm_current_module (), + SP_REF (sym)); CACHE_SP (); + SP_SET (dst, var); NEXT (1); } diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index ea5b59f38..7c69fa6fb 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -150,6 +150,8 @@ (emit-cached-module-box asm (from-sp dst) (constant mod) (constant name) (constant public?) (constant bound?))) + (($ $primcall 'define! (sym)) + (emit-define! asm (from-sp dst) (from-sp (slot sym)))) (($ $primcall 'resolve (name bound?)) (emit-resolve asm (from-sp dst) (constant bound?) (from-sp (slot name)))) @@ -312,8 +314,6 @@ (emit-set-car! asm (from-sp (slot pair)) (from-sp (slot value)))) (($ $primcall 'set-cdr! (pair value)) (emit-set-cdr! asm (from-sp (slot pair)) (from-sp (slot value)))) - (($ $primcall 'define! (sym value)) - (emit-define! asm (from-sp (slot sym)) (from-sp (slot value)))) (($ $primcall 'push-fluid (fluid val)) (emit-push-fluid asm (from-sp (slot fluid)) (from-sp (slot val)))) (($ $primcall 'pop-fluid ()) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 70344a286..5698fcd57 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -418,7 +418,7 @@ is or might be a read or a write to the same location as A." ((resolve name bound?) (&read-object &module) &type-check) ((cached-toplevel-box scope name bound?) &type-check) ((cached-module-box mod name public? bound?) &type-check) - ((define! name val) (&read-object &module) (&write-object &box))) + ((define! name) (&read-object &module))) ;; Numbers. (define-primitive-effects diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 0b9c834c4..3443d761e 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -493,9 +493,12 @@ (lambda (cps val) (with-cps cps (let$ k (adapt-arity k src 0)) + (letv box) + (letk kset ($kargs ('box) (box) + ($continue k src ($primcall 'box-set! (box val))))) ($ (with-cps-constants ((name name)) (build-term - ($continue k src ($primcall 'define! (name val)))))))))) + ($continue kset src ($primcall 'define! (name)))))))))) (($ src proc args) (convert-args cps (cons proc args) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index fb7f07478..9fc5349b7 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -1754,7 +1754,7 @@ needed." ;; FIXME: Define these somewhere central, shared with C. (define *bytecode-major-version* #x0202) -(define *bytecode-minor-version* 8) +(define *bytecode-minor-version* 9) (define (link-dynamic-section asm text rw rw-init frame-maps) "Link the dynamic section for an ELF image with bytecode @var{text}, diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test index 02f2a54c7..b29491296 100644 --- a/test-suite/tests/compiler.test +++ b/test-suite/tests/compiler.test @@ -202,3 +202,11 @@ (vector ,@(map (lambda (n) `(identity ,n)) (iota 300)))))) (list->vector (iota 300))))) + +(with-test-prefix "regression tests" + (pass-if-equal "#18583" 1 + (compile + '(begin + (define x (list 1)) + (define x (car x)) + x)))) From 25468496425360edbf2cd7cb9d92648f61dd7d16 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 21 Jun 2016 22:46:03 +0200 Subject: [PATCH 406/865] Fix srfi-64.test for #:select borkage. The irony... * test-suite/tests/srfi-64.test: Fix for recent #:select borkage. --- test-suite/tests/srfi-64.test | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/srfi-64.test b/test-suite/tests/srfi-64.test index 190d6b23a..1ceeccd08 100644 --- a/test-suite/tests/srfi-64.test +++ b/test-suite/tests/srfi-64.test @@ -17,9 +17,10 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-srfi-64) - #:use-module ((test-suite lib) #:select (report)) #:use-module (srfi srfi-64)) +(define report (@@ (test-suite lib) report)) + (define (guile-test-runner) (let ((runner (test-runner-null))) (test-runner-on-test-end! runner From 0472af4c580f378d75862cb30978bd13e101a89d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 21 Jun 2016 23:17:25 +0200 Subject: [PATCH 407/865] Fix (< 'foo) compilation * module/language/tree-il/primitives.scm (expand-chained-comparisons): Fix (< 'foo) compilation. * test-suite/tests/compiler.test ("regression tests"): Add test case. --- module/language/tree-il/primitives.scm | 7 ++++++- test-suite/tests/compiler.test | 6 +++++- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 724f38416..0a88f1476 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -579,7 +579,12 @@ (define (expand-chained-comparisons prim) (case-lambda ((src) (make-const src #t)) - ((src a) (make-const src #t)) + ((src a) + ;; (< x) -> (begin (< x 0) #t). Residualizes side-effects from x + ;; and, for numeric comparisons, checks that x is a number. + (make-seq src + (make-primcall src prim (list a (make-const src 0))) + (make-const src #t))) ((src a b) #f) ((src a b . rest) (make-conditional src (make-primcall src prim (list a b)) diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test index b29491296..bdae9a75d 100644 --- a/test-suite/tests/compiler.test +++ b/test-suite/tests/compiler.test @@ -209,4 +209,8 @@ '(begin (define x (list 1)) (define x (car x)) - x)))) + x))) + + (pass-if "Chained comparisons" + (not (compile + '(false-if-exception (< 'not-a-number)))))) From 3abd8e1ac1608c54439c99241e6c1f2ffafe9bc1 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 22 Jun 2016 12:50:16 +0200 Subject: [PATCH 408/865] Fix SCM_DEBUG_TYPING_STRICTNESS bug * libguile/ports.c (scm_setvbuf): Fix bad use of SCM as a test value. Actually all ports have read buffers, so we can remove the condition entirely. Thanks Hydra for building in this way :) --- libguile/ports.c | 18 +++++++----------- 1 file changed, 7 insertions(+), 11 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 858dd01ab..c214717c4 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1,6 +1,5 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2004, 2006, - * 2007, 2008, 2009, 2010, 2011, 2012, 2013, - * 2014, 2015 Free Software Foundation, Inc. +/* Copyright (C) 1995-2001, 2003-2004, 2006-2016 + * 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 License @@ -2241,14 +2240,11 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, pt->read_buf = make_port_buffer (port, read_buf_size); pt->write_buf = make_port_buffer (port, write_buf_size); - if (saved_read_buf) - scm_unget_bytes (scm_port_buffer_take_pointer (saved_read_buf), - scm_port_buffer_can_take (saved_read_buf), - port); - - if (saved_read_buf) - scm_port_buffer_set_has_eof_p (pt->read_buf, - scm_port_buffer_has_eof_p (saved_read_buf)); + scm_unget_bytes (scm_port_buffer_take_pointer (saved_read_buf), + scm_port_buffer_can_take (saved_read_buf), + port); + scm_port_buffer_set_has_eof_p (pt->read_buf, + scm_port_buffer_has_eof_p (saved_read_buf)); return SCM_UNSPECIFIED; } From 0ef4b76221cda14dd77ed58ac3484c5ec5a12539 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 22 Jun 2016 16:45:36 +0200 Subject: [PATCH 409/865] Remove a stale variable use in libguile/Makefile.am * libguile/Makefile.am (BUILT_SOURCES): Remove a use of a variable that doesn't exist in 2.2. --- libguile/Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index bb3dc7ed7..909101c51 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -445,7 +445,7 @@ vm-operations.h: vm-engine.c BUILT_SOURCES = cpp-E.c cpp-SIG.c libpath.h \ scmconfig.h \ - $(DOT_I_FILES) vm-operations.h $(DOT_X_FILES) $(EXTRA_DOT_X_FILES) + vm-operations.h $(DOT_X_FILES) $(EXTRA_DOT_X_FILES) # Force the generation of `guile-procedures.texi' because the top-level # Makefile expects it to be built. From d84f25c2713f8b4bf5fba7d17e0284849d82c4ca Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 22 Jun 2016 16:46:08 +0200 Subject: [PATCH 410/865] Remove unused internal i18n functions * libguile/i18n.c (str_upcase, str_downcase, str_upcase_l) (str_downcase_l): Remove unused inline functions. Based on a patch by Pedro Aguilar . Fixes #19172. --- libguile/i18n.c | 38 -------------------------------------- 1 file changed, 38 deletions(-) diff --git a/libguile/i18n.c b/libguile/i18n.c index 17e9eca61..84c6bfc58 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -834,44 +834,6 @@ compare_u32_strings_ci (SCM s1, SCM s2, SCM locale, const char *func_name) } #undef FUNC_NAME -/* Store into DST an upper-case version of SRC. */ -static inline void -str_upcase (register char *dst, register const char *src) -{ - for (; *src != '\0'; src++, dst++) - *dst = toupper ((int) *src); - *dst = '\0'; -} - -static inline void -str_downcase (register char *dst, register const char *src) -{ - for (; *src != '\0'; src++, dst++) - *dst = tolower ((int) *src); - *dst = '\0'; -} - -#ifdef USE_GNU_LOCALE_API -static inline void -str_upcase_l (register char *dst, register const char *src, - scm_t_locale locale) -{ - for (; *src != '\0'; src++, dst++) - *dst = toupper_l (*src, locale); - *dst = '\0'; -} - -static inline void -str_downcase_l (register char *dst, register const char *src, - scm_t_locale locale) -{ - for (; *src != '\0'; src++, dst++) - *dst = tolower_l (*src, locale); - *dst = '\0'; -} -#endif - - SCM_DEFINE (scm_string_locale_lt, "string-locale Date: Thu, 23 Jun 2016 10:03:10 +0200 Subject: [PATCH 411/865] Fix relative file name canonicalization on paths with "." * libguile/filesys.c (scm_i_relativize_path): Canonicalize the file names elements that we will be using as prefixes. Fixes the case where a load path contains a relative file name: #19540. * test-suite/tests/ports.test ("%file-port-name-canonicalization"): Add tests that elements of the load path are canonicalized. --- libguile/filesys.c | 38 +++++++++++++++++++++++++++---------- test-suite/tests/ports.test | 15 ++++++++------- 2 files changed, 36 insertions(+), 17 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index 7674498a4..25501ef76 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1614,22 +1614,40 @@ SCM_DEFINE (scm_canonicalize_path, "canonicalize-path", 1, 0, 0, SCM scm_i_relativize_path (SCM path, SCM in_path) { - char *str, *canon; SCM scanon; - str = scm_to_locale_string (path); - canon = canonicalize_file_name (str); - free (str); + { + char *str, *canon; + + str = scm_to_locale_string (path); + canon = canonicalize_file_name (str); + free (str); + + if (!canon) + return SCM_BOOL_F; + + scanon = scm_take_locale_string (canon); + } - if (!canon) - return SCM_BOOL_F; - - scanon = scm_take_locale_string (canon); - for (; scm_is_pair (in_path); in_path = scm_cdr (in_path)) { SCM dir = scm_car (in_path); - size_t len = scm_c_string_length (dir); + size_t len; + + /* Try to canonicalize DIR, since we have canonicalized PATH. */ + { + char *str, *canon; + + str = scm_to_locale_string (dir); + canon = canonicalize_file_name (str); + free (str); + + if (canon) + dir = scm_from_locale_string (canon); + free (canon); + } + + len = scm_c_string_length (dir); /* When DIR is empty, it means "current working directory". We could set DIR to (getcwd) in that case, but then the diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index dfa430e5a..ea8eaa796 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -1865,14 +1865,15 @@ (with-fluids ((%file-port-name-canonicalization 'relative)) (port-filename (open-input-file "/dev/null"))))) + (pass-if-equal "relative canonicalization with /dev/.." "dev/null" + (with-load-path (cons "/dev/.." %load-path) + (with-fluids ((%file-port-name-canonicalization 'relative)) + (port-filename (open-input-file "/dev/null"))))) + (pass-if-equal "relative canonicalization from ice-9" "ice-9/q.scm" - ;; If an entry in %LOAD-PATH is not canonical, then - ;; `scm_i_relativize_path' is unable to do its job. - (if (equal? (map canonicalize-path %load-path) %load-path) - (with-fluids ((%file-port-name-canonicalization 'relative)) - (port-filename - (open-input-file (%search-load-path "ice-9/q.scm")))) - (throw 'unresolved))) + (with-fluids ((%file-port-name-canonicalization 'relative)) + (port-filename + (open-input-file (%search-load-path "ice-9/q.scm"))))) (pass-if-equal "absolute canonicalization from ice-9" (canonicalize-path From c01a2a757e3c59727bdfa8d77568bf42525fbe05 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 23 Jun 2016 11:47:42 +0200 Subject: [PATCH 412/865] Fix race between SMOB marking and finalization * libguile/smob.c (clear_smobnum): New helper. (finalize_smob): Re-set the smobnum to the "finalized smob" type before finalizing. Fixes #19883. (scm_smob_prehistory): Pre-register a "finalized smob" type, which has no mark procedure. * test-suite/standalone/test-smob-mark-race.c: New file. * test-suite/standalone/Makefile.am: Arrange to build and run the new test. --- libguile/smob.c | 33 ++++++++++- test-suite/standalone/Makefile.am | 6 ++ test-suite/standalone/test-smob-mark-race.c | 65 +++++++++++++++++++++ 3 files changed, 101 insertions(+), 3 deletions(-) create mode 100644 test-suite/standalone/test-smob-mark-race.c diff --git a/libguile/smob.c b/libguile/smob.c index 6a97caa7c..43ea613de 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -372,20 +372,43 @@ scm_gc_mark (SCM o) } +static void* +clear_smobnum (void *ptr) +{ + SCM smob; + scm_t_bits smobnum; + + smob = SCM_PACK_POINTER (ptr); + + smobnum = SCM_SMOBNUM (smob); + /* Frob the object's type in place, re-setting it to be the "finalized + smob" type. This will prevent other routines from accessing its + internals in a way that assumes that the smob data is valid. This + is notably the case for SMOB's own "mark" procedure, if any; as the + finalizer runs without the alloc lock, it's possible for a GC to + occur while it's running, in which case the object is alive and yet + its data is invalid. */ + SCM_SET_SMOB_DATA_0 (smob, SCM_SMOB_DATA_0 (smob) & ~(scm_t_bits) 0xff00); + + return (void *) smobnum; +} + /* Finalize SMOB by calling its SMOB type's free function, if any. */ static void finalize_smob (void *ptr, void *data) { SCM smob; + scm_t_bits smobnum; size_t (* free_smob) (SCM); smob = SCM_PACK_POINTER (ptr); + smobnum = (scm_t_bits) GC_call_with_alloc_lock (clear_smobnum, ptr); + #if 0 - printf ("finalizing SMOB %p (smobnum: %u)\n", - ptr, SCM_SMOBNUM (smob)); + printf ("finalizing SMOB %p (smobnum: %u)\n", ptr, smobnum); #endif - free_smob = scm_smobs[SCM_SMOBNUM (smob)].free; + free_smob = scm_smobs[smobnum].free; if (free_smob) free_smob (smob); } @@ -460,6 +483,7 @@ void scm_smob_prehistory () { long i; + scm_t_bits finalized_smob_tc16; scm_i_pthread_key_create (¤t_mark_stack_pointer, NULL); scm_i_pthread_key_create (¤t_mark_stack_limit, NULL); @@ -483,6 +507,9 @@ scm_smob_prehistory () scm_smobs[i].apply = 0; scm_smobs[i].apply_trampoline = SCM_BOOL_F; } + + finalized_smob_tc16 = scm_make_smob_type ("finalized smob", 0); + if (SCM_TC2SMOBNUM (finalized_smob_tc16) != 0) abort (); } /* diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index 5138b1549..524a1445e 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -286,6 +286,12 @@ test_smob_mark_LDADD = $(LIBGUILE_LDADD) check_PROGRAMS += test-smob-mark TESTS += test-smob-mark +test_smob_mark_race_SOURCES = test-smob-mark-race.c +test_smob_mark_race_CFLAGS = ${test_cflags} +test_smob_mark_race_LDADD = $(LIBGUILE_LDADD) +check_PROGRAMS += test-smob-mark-race +TESTS += test-smob-mark-race + check_SCRIPTS += test-stack-overflow TESTS += test-stack-overflow diff --git a/test-suite/standalone/test-smob-mark-race.c b/test-suite/standalone/test-smob-mark-race.c new file mode 100644 index 000000000..eca0325d2 --- /dev/null +++ b/test-suite/standalone/test-smob-mark-race.c @@ -0,0 +1,65 @@ +/* Copyright (C) 2016 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 License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + +#if HAVE_CONFIG_H +#include +#endif + +#undef NDEBUG + +#include +#include + +static SCM +mark_smob (SCM smob) +{ + assert (SCM_SMOB_DATA (smob) == 1); + return SCM_BOOL_F; +} + +static size_t +finalize_smob (SCM smob) +{ + assert (SCM_SMOB_DATA (smob) == 1); + SCM_SET_SMOB_DATA (smob, 0); + /* Allocate a bit in the hopes of triggering a new GC, making the + marker race with the finalizer. */ + scm_cons (SCM_BOOL_F, SCM_BOOL_F); + return 0; +} + +static void +tests (void *data, int argc, char **argv) +{ + scm_t_bits tc16; + int i; + + tc16 = scm_make_smob_type ("smob with finalizer", 0); + scm_set_smob_mark (tc16, mark_smob); + scm_set_smob_free (tc16, finalize_smob); + + for (i = 0; i < 1000 * 1000; i++) + scm_new_smob (tc16, 1); +} + +int +main (int argc, char *argv[]) +{ + scm_boot_guile (argc, argv, tests, NULL); + return 0; +} From e7f1038aca62f7318b9a3c93d50293f800462110 Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Thu, 23 Jun 2016 13:21:32 +0200 Subject: [PATCH 413/865] Remove unused doc/maint --- doc/maint/ChangeLog-2008 | 75 - doc/maint/README | 35 - doc/maint/docstring.el | 622 --- doc/maint/guile.texi | 11091 ------------------------------------- 4 files changed, 11823 deletions(-) delete mode 100644 doc/maint/ChangeLog-2008 delete mode 100644 doc/maint/README delete mode 100644 doc/maint/docstring.el delete mode 100644 doc/maint/guile.texi diff --git a/doc/maint/ChangeLog-2008 b/doc/maint/ChangeLog-2008 deleted file mode 100644 index 0c6e618d6..000000000 --- a/doc/maint/ChangeLog-2008 +++ /dev/null @@ -1,75 +0,0 @@ -2004-08-25 Marius Vollmer - - * docstring.el (docstring-process-alist): Consider entries in - reverse order. That puts them in new-docstrings.texi in the same - order as in the C source. - -2004-08-23 Marius Vollmer - - * docstring.el: Replaced all "@c module" markers with "@c - module-for-docstring", making it less likely to collide with a - real commentary. - -2002-10-19 Neil Jerram - - * guile.texi: Replaced by regenerated libguile version. - -2002-07-10 Gary Houston - - * docstring.el: optional 2nd environment variable to locate - built files. - -2002-07-09 Gary Houston - - * docstring.el: defined caddr, used in several places but missing - for some reason. - -2002-04-02 Thien-Thi Nguyen - - * doctring.el: List commands in commentary; nfc. - -2002-03-15 Neil Jerram - - * guile.texi: Replaced by regenerated libguile version. - -2002-03-12 Neil Jerram - - * guile.texi: Replaced by regenerated libguile version. - -2002-03-08 Neil Jerram - - * docstring.el (docstring-libguile-directory, - docstring-display-location, docstring-show-source): New. - -2001-11-16 Neil Jerram - - * guile.texi: Replaced by regenerated libguile version. - - * docstring.el (make-module-description-list): Exclude @deffn's - with category {C Function}. - (docstring-process-alist): Bind key "d" to - docstring-ediff-this-line in the docstring output buffer. - -2001-11-13 Neil Jerram - - * guile.texi: Replaced by libguile version (after automatically - updating docstrings in the reference manual). - -2001-11-07 Neil Jerram - - * guile.texi: Replaced by libguile version (after automatically - updating docstrings in the reference manual). - - * docstring.el (docstring-manual-directory): Added "/ref" to end. - (docstring-manual-files): Now calculated automatically, since by - definition all the .texi files in doc/ref are reference manual - files. - -2001-04-03 Martin Grabmueller - - * guile.texi: Automated docstring merging. - -2001-03-23 Neil Jerram - - * ChangeLog, README, docstring.el, guile.texi: New files. - diff --git a/doc/maint/README b/doc/maint/README deleted file mode 100644 index adfa13f82..000000000 --- a/doc/maint/README +++ /dev/null @@ -1,35 +0,0 @@ -README for guile-core/doc/maint -*- text -*- - -The files in this directory are used by the maintainers to automate -the process of updating the Guile reference manual when the docstrings -in the libguile C source change. - -- ChangeLog is the change log for files in this directory. - -- README is this file. - -- docstring.el is a helpful Emacs Lisp library (see source for - customization). The two key entry points are: - `docstring-process-module' and - `docstring-ediff-this-line'. - -- guile.texi is a snapshot of the built file libguile/guile.texi, - copied last time the reference manual was determined to be in sync - with the libguile source. - -docstring.el requires the setting of an environment variable, e.g., - -export GUILE_MAINTAINER_GUILE_CORE_DIR=$HOME/guile/guile-core - -If the build directory differs from the source directory, an additional -variable is required: - -export GUILE_MAINTAINER_BUILD_CORE_DIR=$HOME/guile/guile-core-build - -If you've just fixed a docstring in, say, ../libguile/strop.c, do in emacs: - - M-x load-file RET .../doc/maint/docstring.el RET - M-x docstring-process-module RET (guile) RET - -Save all modified .texi files and copy the current ../libguile/guile.texi -to ./guile.texi, then commit. See elisp var `docstring-snarfed-roots'. diff --git a/doc/maint/docstring.el b/doc/maint/docstring.el deleted file mode 100644 index ef271930f..000000000 --- a/doc/maint/docstring.el +++ /dev/null @@ -1,622 +0,0 @@ -;;; docstring.el --- utilities for Guile docstring maintenance -;;; -;;; Copyright (C) 2001, 2004 Neil Jerram -;;; -;;; This file is not part of GUILE, but the same permissions apply. -;;; -;;; GUILE is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU Lesser General Public License as -;;; published by the Free Software Foundation; either version 3, or -;;; (at your option) any later version. -;;; -;;; GUILE is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; Lesser General Public License for more details. -;;; -;;; You should have received a copy of the GNU Lesser General Public -;;; License along with GUILE; see the file COPYING.LESSER. If not, -;;; write to the Free Software Foundation, Inc., 51 Franklin Street, -;;; Fifth Floor, Boston, MA 02110-1301, USA. - -;;; Commentary: - -;; The basic premise of these utilities is that - at least in the -;; short term - we can get a lot of reference manual mileage by -;; co-opting the docstrings that are snarfed automatically from -;; Guile's C and Scheme source code. But this leads to problems of -;; synchronization... How do you track when a docstring has been -;; updated in the source and so needs updating in the reference -;; manual. What if a procedure is removed from the Guile source? And -;; so on. To complicate matters, the exact snarfed docstring text -;; will probably need to be modified so that it fits into the flow of -;; the manual section in which it appears. Can we design solutions to -;; synchronization problems that continue to work even when the manual -;; text has been enhanced in this way? -;; -;; This file implements an approach to this problem that I have found -;; useful. It involves keeping track of three copies of each -;; docstring: -;; -;; "MANUAL" = the docstring as it appears in the reference manual. -;; -;; "SNARFED" = the docstring as snarfed from the current C or Scheme -;; source. -;; -;; "TRACKING" = the docstring as it appears in a tracking file whose -;; purpose is to record the most recent snarfed docstrings -;; that are known to be in sync with the reference manual. -;; -;; The approaches are as follows. -;; -;; 1. Comparison of MANUAL-DOC, SOURCE-DOC and TRACK-DOC, to produce a -;; summary output buffer in which keystrokes are defined to bring up -;; detailed comparisons. -;; -;; 2. Comparison of MANUAL-DOC, SOURCE-DOC and TRACK-DOC using Ediff. -;; -;; Here is a brief list of commands available (via "M-x COMMAND"): -;; -;; docstring-process-current-buffer -;; docstring-process-current-region BEG END -;; docstring-process-module MODULE -;; docstring-ediff-this-line -;; docstring-show-source - - -(defvar guile-core-dir (or (getenv "GUILE_MAINTAINER_GUILE_CORE_DIR") - (error "GUILE_MAINTAINER_GUILE_CORE_DIR not set")) - "*Full path of guile-core source directory.") - -(defvar guile-build-dir (or (getenv "GUILE_MAINTAINER_BUILD_CORE_DIR") - guile-core-dir) - "*Full path of guile-core build directory. Defaults to guile-core-dir.") - -(defvar docstring-manual-directory (expand-file-name "doc/ref" guile-core-dir) - "*The directory containing the Texinfo source for the Guile reference manual.") - -(defvar docstring-tracking-root (expand-file-name "doc/maint" guile-core-dir) - "*Root directory for docstring tracking files. The tracking file -for module (a b c) is expected to be in the file -/a/b/c.texi.") - -(defvar docstring-snarfed-roots (mapcar - #'(lambda (frag) - (expand-file-name frag guile-build-dir)) - '("libguile" "ice-9" "oop")) - "*List of possible root directories for snarfed docstring files. -For each entry in this list, the snarfed docstring file for module (a -b c) is looked for in the file /a/b/c.texi.") - -(defvar docstring-manual-files - (directory-files docstring-manual-directory nil "\\.texi$" t) - "List of Texinfo source files that comprise the Guile reference manual.") - -(defvar docstring-new-docstrings-file "new-docstrings.texi" - "The name of a file in the Guile reference manual source directory -to which new docstrings should be added.") - -;; Apply FN in turn to each element in the list CANDIDATES until the -;; first application that returns non-nil. -(defun or-map (fn candidates args) - (let ((result nil)) - (while candidates - (setq result (apply fn (car candidates) args)) - (if result - (setq result (cons (car candidates) result) - candidates nil) - (setq candidates (cdr candidates)))) - result)) - -;; Return t if the current buffer position is in the scope of the -;; specified MODULE, as determined by "@c module-for-docstring ..." comments in the -;; buffer. DEFAULT-OK specifies the return value in the case that -;; there are no preceding module comments at all. -(defun docstring-in-module (module default-ok) - (save-excursion - (if (re-search-backward "^@c module-for-docstring " nil t) - (progn - (search-forward "@c module-for-docstring ") - (equal module (read (current-buffer)))) - default-ok))) - -;; Find a docstring in the specified FILE-NAME for the item in module -;; MODULE and with description DESCRIPTION. MODULE should be a list -;; of symbols, Guile-style, for example: '(ice-9 session). -;; DESCRIPTION should be the string that is expected after the @deffn, -;; for example "primitive acons" or "syntax let*". -(defun find-docstring (file-name module description) - (and (file-exists-p file-name) - (let ((buf (find-file-noselect file-name)) - (deffn-regexp (concat "^@deffnx? " - (regexp-quote description) - "[ \n\t]")) - found - result) - (save-excursion - (set-buffer buf) - (goto-char (point-min)) - (while (and (not found) - (re-search-forward deffn-regexp nil t)) - (save-excursion - (goto-char (match-beginning 0)) - (beginning-of-line) - (if (docstring-in-module module t) - (setq found t)))) - (if found - (setq result - (list (current-buffer) - (progn - (re-search-backward "^@deffn ") - (beginning-of-line) - (point)) - (progn - (re-search-forward "^@end deffn") - (forward-line 1) - (point)))))) - result))) - -;; Find the reference manual version of the specified docstring. -;; MODULE and DESCRIPTION specify the docstring as per -;; `find-docstring'. The set of files that `find-manual-docstring' -;; searches is determined by the value of the `docstring-manual-files' -;; variable. -(defun find-manual-docstring (module description) - (let* ((result - (or-map 'find-docstring - (mapcar (function (lambda (file-name) - (concat docstring-manual-directory - "/" - file-name))) - (cons docstring-new-docstrings-file - docstring-manual-files)) - (list module - description))) - (matched-file-name (and (cdr result) - (file-name-nondirectory (car result))))) - (if matched-file-name - (setq docstring-manual-files - (cons matched-file-name - (delete matched-file-name docstring-manual-files)))) - (cdr result))) - -;; Convert MODULE to a directory subpath. -(defun module-to-path (module) - (mapconcat (function (lambda (component) - (symbol-name component))) - module - "/")) - -;; Find the current snarfed version of the specified docstring. -;; MODULE and DESCRIPTION specify the docstring as per -;; `find-docstring'. The file that `find-snarfed-docstring' looks in -;; is automatically generated from MODULE. -(defun find-snarfed-docstring (module description) - (let ((modpath (module-to-path module))) - (cdr (or-map (function (lambda (root) - (find-docstring (concat root - "/" - modpath - ".texi") - module - description))) - docstring-snarfed-roots - nil)))) - -;; Find the tracking version of the specified docstring. MODULE and -;; DESCRIPTION specify the docstring as per `find-docstring'. The -;; file that `find-tracking-docstring' looks in is automatically -;; generated from MODULE. -(defun find-tracking-docstring (module description) - (find-docstring (concat docstring-tracking-root - "/" - (module-to-path module) - ".texi") - module - description)) - -;; Extract an alist of modules and descriptions from the current -;; buffer. -(defun make-module-description-list () - (let ((alist nil) - (module '(guile))) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "^\\(@c module-for-docstring \\|@deffnx? \\({[^}]+}\\|[^ ]+\\) \\([^ \n]+\\)\\)" - nil - t) - (let ((matched (buffer-substring (match-beginning 1) - (match-end 1)))) - (if (string-equal matched "@c module-for-docstring ") - (setq module (read (current-buffer))) - (let ((type (buffer-substring (match-beginning 2) - (match-end 2)))) - (if (string-equal type "{C Function}") - nil - (setq matched - (concat type - " " - (buffer-substring (match-beginning 3) - (match-end 3)))) - (message "Found docstring: %S: %s" module matched) - (let ((descriptions (assoc module alist))) - (setq alist - (cons (cons module (cons matched (cdr-safe descriptions))) - (if descriptions - (delete descriptions alist) - alist)))))))))) - alist)) - -;; missing in some environments? -(defun caddr (list) - (nth 2 list)) - -;; Return the docstring from the specified LOCATION. LOCATION is a -;; list of three elements: buffer, start position and end position. -(defun location-to-docstring (location) - (and location - (save-excursion - (set-buffer (car location)) - (buffer-substring (cadr location) (caddr location))))) - -;; Perform a comparison of the specified docstring. MODULE and -;; DESCRIPTION are as per usual. -(defun docstring-compare (module description) - (let* ((manual-location (find-manual-docstring module description)) - (snarf-location (find-snarfed-docstring module description)) - (track-location (find-tracking-docstring module description)) - - (manual-docstring (location-to-docstring manual-location)) - (snarf-docstring (location-to-docstring snarf-location)) - (track-docstring (location-to-docstring track-location)) - - action - issue) - - ;; Decide what to do. - (cond ((null snarf-location) - (setq action nil - issue (if manual-location - 'consider-removal - nil))) - - ((null manual-location) - (setq action 'add-to-manual issue nil)) - - ((null track-location) - (setq action nil - issue (if (string-equal manual-docstring snarf-docstring) - nil - 'check-needed))) - - ((string-equal track-docstring snarf-docstring) - (setq action nil issue nil)) - - ((string-equal track-docstring manual-docstring) - (setq action 'auto-update-manual issue nil)) - - (t - (setq action nil issue 'update-needed))) - - ;; Return a pair indicating any automatic action that can be - ;; taken, and any issue for resolution. - (cons action issue))) - -;; Add the specified docstring to the manual. -(defun docstring-add-to-manual (module description) - (let ((buf (find-file-noselect (concat docstring-manual-directory - "/" - docstring-new-docstrings-file)))) - (save-excursion - (set-buffer buf) - (goto-char (point-max)) - (or (docstring-in-module module nil) - (insert "\n@c module-for-docstring " (prin1-to-string module) "\n")) - (insert "\n" (location-to-docstring (find-snarfed-docstring module - description)))))) - -;; Auto-update the specified docstring in the manual. -(defun docstring-auto-update-manual (module description) - (let ((manual-location (find-manual-docstring module description)) - (track-location (find-tracking-docstring module description))) - (save-excursion - (set-buffer (car manual-location)) - (goto-char (cadr manual-location)) - (delete-region (cadr manual-location) (caddr manual-location)) - (insert (location-to-docstring (find-snarfed-docstring module - description)))))) - -;; Process an alist of modules and descriptions, and produce a summary -;; buffer describing actions taken and issues to be resolved. -(defun docstring-process-alist (alist) - (let (check-needed-list - update-needed-list - consider-removal-list - added-to-manual-list - auto-updated-manual-list) - - (mapcar - (function (lambda (module-list) - (let ((module (car module-list))) - (message "Module: %S" module) - (mapcar - (function (lambda (description) - (message "Comparing docstring: %S: %s" module description) - (let* ((ai (docstring-compare module description)) - (action (car ai)) - (issue (cdr ai))) - - (cond ((eq action 'add-to-manual) - (docstring-add-to-manual module description) - (setq added-to-manual-list - (cons (cons module description) - added-to-manual-list))) - - ((eq action 'auto-update-manual) - (docstring-auto-update-manual module description) - (setq auto-updated-manual-list - (cons (cons module description) - auto-updated-manual-list)))) - - (cond ((eq issue 'check-needed) - (setq check-needed-list - (cons (cons module description) - check-needed-list))) - - ((eq issue 'update-needed) - (setq update-needed-list - (cons (cons module description) - update-needed-list))) - - ((eq issue 'consider-removal) - (setq consider-removal-list - (cons (cons module description) - consider-removal-list))))))) - (reverse (cdr module-list)))))) - alist) - - ;; Prepare a buffer describing the results. - (set-buffer (get-buffer-create "*Docstring Results*")) - (erase-buffer) - - (insert " -The following items have been automatically added to the manual in -file `" docstring-manual-directory "/" docstring-new-docstrings-file "'.\n\n") - (if added-to-manual-list - (mapcar (function (lambda (moddesc) - (insert (prin1-to-string (car moddesc)) - ": " - (cdr moddesc) - "\n"))) - added-to-manual-list) - (insert "(none)\n")) - - (insert " -The following items have been automatically updated in the manual.\n\n") - (if auto-updated-manual-list - (mapcar (function (lambda (moddesc) - (insert (prin1-to-string (car moddesc)) - ": " - (cdr moddesc) - "\n"))) - auto-updated-manual-list) - (insert "(none)\n")) - - (insert " -The following items are already documented in the manual but are not -mentioned in the reference copy of the snarfed docstrings file. -You should check that the manual documentation matches the docstring -in the current snarfed docstrings file.\n\n") - (if check-needed-list - (mapcar (function (lambda (moddesc) - (insert (prin1-to-string (car moddesc)) - ": " - (cdr moddesc) - "\n"))) - check-needed-list) - (insert "(none)\n")) - - (insert " -The following items have manual documentation that is different from -the docstring in the reference copy of the snarfed docstrings file, -and the snarfed docstring has changed. You need to update the manual -documentation by hand with reference to the snarfed docstring changes.\n\n") - (if update-needed-list - (mapcar (function (lambda (moddesc) - (insert (prin1-to-string (car moddesc)) - ": " - (cdr moddesc) - "\n"))) - update-needed-list) - (insert "(none)\n")) - - (insert " -The following items are documented in the manual but are no longer -present in the snarfed docstrings file. You should consider whether -the existing manual documentation is still pertinent. If it is, its -docstring module comment may need updating, to connect it with a -new snarfed docstring file.\n\n") - (if consider-removal-list - (mapcar (function (lambda (moddesc) - (insert (prin1-to-string (car moddesc)) - ": " - (cdr moddesc) - "\n"))) - consider-removal-list) - (insert "(none)\n")) - (insert "\n") - - (goto-char (point-min)) - (local-set-key "d" 'docstring-ediff-this-line) - - ;; Popup the issues buffer. - (let ((pop-up-frames t)) - (set-window-point (display-buffer (current-buffer)) - (point-min))))) - -(defun docstring-process-current-buffer () - (interactive) - (docstring-process-alist (make-module-description-list))) - -(defun docstring-process-current-region (beg end) - (interactive "r") - (narrow-to-region beg end) - (unwind-protect - (save-excursion - (docstring-process-alist (make-module-description-list))) - (widen))) - -(defun docstring-process-module (module) - (interactive "xModule: ") - (let ((modpath (module-to-path module)) - (mdlist nil)) - (mapcar (function (lambda (root) - (let ((fn (concat root - "/" - modpath - ".texi"))) - (if (file-exists-p fn) - (save-excursion - (find-file fn) - (message "Getting docstring list from %s" fn) - (setq mdlist - (append mdlist - (make-module-description-list)))))))) - docstring-snarfed-roots) - (docstring-process-alist mdlist))) - -(defun docstring-ediff-this-line () - (interactive) - (let (module - description) - (save-excursion - (beginning-of-line) - (setq module (read (current-buffer))) - (forward-char 2) - (setq description (buffer-substring (point) - (progn - (end-of-line) - (point))))) - - (message "Ediff docstring: %S: %s" module description) - - (let ((track-location (or (find-tracking-docstring module description) - (docstring-temp-location "No docstring in tracking file"))) - (snarf-location (or (find-snarfed-docstring module description) - (docstring-temp-location "No docstring in snarfed file"))) - (manual-location (or (find-manual-docstring module description) - (docstring-temp-location "No docstring in manual")))) - - (setq docstring-ediff-buffers - (list (car track-location) - (car snarf-location) - (car manual-location))) - - (docstring-narrow-to-location track-location) - (docstring-narrow-to-location snarf-location) - (docstring-narrow-to-location manual-location) - - (add-hook 'ediff-quit-hook 'docstring-widen-ediff-buffers) - - (ediff-buffers3 (nth 0 docstring-ediff-buffers) - (nth 1 docstring-ediff-buffers) - (nth 2 docstring-ediff-buffers))))) - -(defun docstring-narrow-to-location (location) - (save-excursion - (set-buffer (car location)) - (narrow-to-region (cadr location) (caddr location)))) - -(defun docstring-temp-location (str) - (let ((buf (generate-new-buffer "*Docstring Temp*"))) - (save-excursion - (set-buffer buf) - (erase-buffer) - (insert str "\n") - (list buf (point-min) (point-max))))) - -(require 'ediff) - -(defvar docstring-ediff-buffers '()) - -(defun docstring-widen-ediff-buffers () - (remove-hook 'ediff-quit-hook 'docstring-widen-ediff-buffers) - (save-excursion - (mapcar (function (lambda (buffer) - (set-buffer buffer) - (widen))) - docstring-ediff-buffers))) - - -;;; Tests: - -;(find-docstring "/home/neil/Guile/cvs/guile-core/doc/maint/guile.texi" nil "primitive sloppy-assq") -;(find-manual-docstring '(guile) "primitive sloppy-assq") -;(find-tracking-docstring '(guile) "primitive sloppy-assq") -;(find-snarfed-docstring '(guile) "primitive sloppy-assq") - -(defvar docstring-libguile-directory (expand-file-name "libguile" - guile-core-dir) - "*The directory containing the C source for libguile.") - -(defvar docstring-libguile-build-directory (expand-file-name "libguile" - guile-build-dir) - "*The directory containing the libguile build directory.") - -(defun docstring-display-location (file line) - (let ((buffer (find-file-noselect - (expand-file-name file docstring-libguile-directory)))) - (if buffer - (let* ((window (or (get-buffer-window buffer) - (display-buffer buffer))) - (pos (save-excursion - (set-buffer buffer) - (goto-line line) - (point)))) - (set-window-point window pos))))) - -(defun docstring-show-source () - "Given that point is sitting in a docstring in one of the Texinfo -source files for the Guile manual, and that that docstring may be -snarfed automatically from a libguile C file, determine whether the -docstring is from libguile and, if it is, display the relevant C file -at the line from which the docstring was snarfed. - -Why? When updating snarfed docstrings, you should usually edit the C -source rather than the Texinfo source, so that your updates benefit -Guile's online help as well. This function locates the C source for a -docstring so that it is easy for you to do this." - (interactive) - (let* ((deffn-line - (save-excursion - (end-of-line) - (or (re-search-backward "^@deffn " nil t) - (error "No docstring here!")) - (buffer-substring (point) - (progn - (end-of-line) - (point))))) - (guile-texi-file - (expand-file-name "guile.texi" docstring-libguile-build-directory)) - (source-location - (save-excursion - (set-buffer (find-file-noselect guile-texi-file)) - (save-excursion - (goto-char (point-min)) - (or (re-search-forward (concat "^" - (regexp-quote deffn-line) - "$") - nil t) - (error "Docstring not from libguile")) - (forward-line -1) - (if (looking-at "^@c snarfed from \\([^:]+\\):\\([0-9]+\\)$") - (cons (match-string 1) - (string-to-int (match-string 2))) - (error "Corrupt docstring entry in guile.texi")))))) - (docstring-display-location (car source-location) - (cdr source-location)))) - - -(provide 'docstring) - -;;; docstring.el ends here diff --git a/doc/maint/guile.texi b/doc/maint/guile.texi deleted file mode 100644 index c0570f24b..000000000 --- a/doc/maint/guile.texi +++ /dev/null @@ -1,11091 +0,0 @@ - - acons -@c snarfed from alist.c:36 -@deffn {Scheme Procedure} acons key value alist -@deffnx {C Function} scm_acons (key, value, alist) -Add a new key-value pair to @var{alist}. A new pair is -created whose car is @var{key} and whose cdr is @var{value}, and the -pair is consed onto @var{alist}, and the new list is returned. This -function is @emph{not} destructive; @var{alist} is not modified. -@end deffn - - sloppy-assq -@c snarfed from alist.c:50 -@deffn {Scheme Procedure} sloppy-assq key alist -@deffnx {C Function} scm_sloppy_assq (key, alist) -Behaves like @code{assq} but does not do any error checking. -Recommended only for use in Guile internals. -@end deffn - - sloppy-assv -@c snarfed from alist.c:68 -@deffn {Scheme Procedure} sloppy-assv key alist -@deffnx {C Function} scm_sloppy_assv (key, alist) -Behaves like @code{assv} but does not do any error checking. -Recommended only for use in Guile internals. -@end deffn - - sloppy-assoc -@c snarfed from alist.c:86 -@deffn {Scheme Procedure} sloppy-assoc key alist -@deffnx {C Function} scm_sloppy_assoc (key, alist) -Behaves like @code{assoc} but does not do any error checking. -Recommended only for use in Guile internals. -@end deffn - - assq -@c snarfed from alist.c:113 -@deffn {Scheme Procedure} assq key alist -@deffnx {Scheme Procedure} assv key alist -@deffnx {Scheme Procedure} assoc key alist -@deffnx {C Function} scm_assq (key, alist) -Fetch the entry in @var{alist} that is associated with @var{key}. To -decide whether the argument @var{key} matches a particular entry in -@var{alist}, @code{assq} compares keys with @code{eq?}, @code{assv} -uses @code{eqv?} and @code{assoc} uses @code{equal?}. If @var{key} -cannot be found in @var{alist} (according to whichever equality -predicate is in use), then return @code{#f}. These functions -return the entire alist entry found (i.e. both the key and the value). -@end deffn - - assv -@c snarfed from alist.c:134 -@deffn {Scheme Procedure} assv key alist -@deffnx {C Function} scm_assv (key, alist) -Behaves like @code{assq} but uses @code{eqv?} for key comparison. -@end deffn - - assoc -@c snarfed from alist.c:155 -@deffn {Scheme Procedure} assoc key alist -@deffnx {C Function} scm_assoc (key, alist) -Behaves like @code{assq} but uses @code{equal?} for key comparison. -@end deffn - - assq-ref -@c snarfed from alist.c:199 -@deffn {Scheme Procedure} assq-ref alist key -@deffnx {Scheme Procedure} assv-ref alist key -@deffnx {Scheme Procedure} assoc-ref alist key -@deffnx {C Function} scm_assq_ref (alist, key) -Like @code{assq}, @code{assv} and @code{assoc}, except that only the -value associated with @var{key} in @var{alist} is returned. These -functions are equivalent to - -@lisp -(let ((ent (@var{associator} @var{key} @var{alist}))) - (and ent (cdr ent))) -@end lisp - -where @var{associator} is one of @code{assq}, @code{assv} or @code{assoc}. -@end deffn - - assv-ref -@c snarfed from alist.c:216 -@deffn {Scheme Procedure} assv-ref alist key -@deffnx {C Function} scm_assv_ref (alist, key) -Behaves like @code{assq-ref} but uses @code{eqv?} for key comparison. -@end deffn - - assoc-ref -@c snarfed from alist.c:233 -@deffn {Scheme Procedure} assoc-ref alist key -@deffnx {C Function} scm_assoc_ref (alist, key) -Behaves like @code{assq-ref} but uses @code{equal?} for key comparison. -@end deffn - - assq-set! -@c snarfed from alist.c:262 -@deffn {Scheme Procedure} assq-set! alist key val -@deffnx {Scheme Procedure} assv-set! alist key value -@deffnx {Scheme Procedure} assoc-set! alist key value -@deffnx {C Function} scm_assq_set_x (alist, key, val) -Reassociate @var{key} in @var{alist} with @var{value}: find any existing -@var{alist} entry for @var{key} and associate it with the new -@var{value}. If @var{alist} does not contain an entry for @var{key}, -add a new one. Return the (possibly new) alist. - -These functions do not attempt to verify the structure of @var{alist}, -and so may cause unusual results if passed an object that is not an -association list. -@end deffn - - assv-set! -@c snarfed from alist.c:280 -@deffn {Scheme Procedure} assv-set! alist key val -@deffnx {C Function} scm_assv_set_x (alist, key, val) -Behaves like @code{assq-set!} but uses @code{eqv?} for key comparison. -@end deffn - - assoc-set! -@c snarfed from alist.c:298 -@deffn {Scheme Procedure} assoc-set! alist key val -@deffnx {C Function} scm_assoc_set_x (alist, key, val) -Behaves like @code{assq-set!} but uses @code{equal?} for key comparison. -@end deffn - - assq-remove! -@c snarfed from alist.c:322 -@deffn {Scheme Procedure} assq-remove! alist key -@deffnx {Scheme Procedure} assv-remove! alist key -@deffnx {Scheme Procedure} assoc-remove! alist key -@deffnx {C Function} scm_assq_remove_x (alist, key) -Delete the first entry in @var{alist} associated with @var{key}, and return -the resulting alist. -@end deffn - - assv-remove! -@c snarfed from alist.c:338 -@deffn {Scheme Procedure} assv-remove! alist key -@deffnx {C Function} scm_assv_remove_x (alist, key) -Behaves like @code{assq-remove!} but uses @code{eqv?} for key comparison. -@end deffn - - assoc-remove! -@c snarfed from alist.c:354 -@deffn {Scheme Procedure} assoc-remove! alist key -@deffnx {C Function} scm_assoc_remove_x (alist, key) -Behaves like @code{assq-remove!} but uses @code{equal?} for key comparison. -@end deffn - - make-arbiter -@c snarfed from arbiters.c:99 -@deffn {Scheme Procedure} make-arbiter name -@deffnx {C Function} scm_make_arbiter (name) -Return an arbiter object, initially unlocked. Currently -@var{name} is only used for diagnostic output. -@end deffn - - try-arbiter -@c snarfed from arbiters.c:116 -@deffn {Scheme Procedure} try-arbiter arb -@deffnx {C Function} scm_try_arbiter (arb) -If @var{arb} is unlocked, then lock it and return @code{#t}. -If @var{arb} is already locked, then do nothing and return -@code{#f}. -@end deffn - - release-arbiter -@c snarfed from arbiters.c:142 -@deffn {Scheme Procedure} release-arbiter arb -@deffnx {C Function} scm_release_arbiter (arb) -If @var{arb} is locked, then unlock it and return @code{#t}. -If @var{arb} is already unlocked, then do nothing and return -@code{#f}. - -Typical usage is for the thread which locked an arbiter to -later release it, but that's not required, any thread can -release it. -@end deffn - - async -@c snarfed from async.c:97 -@deffn {Scheme Procedure} async thunk -@deffnx {C Function} scm_async (thunk) -Create a new async for the procedure @var{thunk}. -@end deffn - - async-mark -@c snarfed from async.c:106 -@deffn {Scheme Procedure} async-mark a -@deffnx {C Function} scm_async_mark (a) -Mark the async @var{a} for future execution. -@end deffn - - run-asyncs -@c snarfed from async.c:117 -@deffn {Scheme Procedure} run-asyncs list_of_a -@deffnx {C Function} scm_run_asyncs (list_of_a) -Execute all thunks from the asyncs of the list @var{list_of_a}. -@end deffn - - system-async -@c snarfed from async.c:180 -@deffn {Scheme Procedure} system-async thunk -@deffnx {C Function} scm_system_async (thunk) -This function is deprecated. You can use @var{thunk} directly -instead of explicitly creating an async object. - -@end deffn - - system-async-mark -@c snarfed from async.c:296 -@deffn {Scheme Procedure} system-async-mark proc [thread] -@deffnx {C Function} scm_system_async_mark_for_thread (proc, thread) -Mark @var{proc} (a procedure with zero arguments) for future execution -in @var{thread}. If @var{proc} has already been marked for -@var{thread} but has not been executed yet, this call has no effect. -If @var{thread} is omitted, the thread that called -@code{system-async-mark} is used. - -This procedure is not safe to be called from C signal handlers. Use -@code{scm_sigaction} or @code{scm_sigaction_for_thread} to install -signal handlers. -@end deffn - - noop -@c snarfed from async.c:335 -@deffn {Scheme Procedure} noop . args -@deffnx {C Function} scm_noop (args) -Do nothing. When called without arguments, return @code{#f}, -otherwise return the first argument. -@end deffn - - unmask-signals -@c snarfed from async.c:350 -@deffn {Scheme Procedure} unmask-signals -@deffnx {C Function} scm_unmask_signals () -Unmask signals. The returned value is not specified. -@end deffn - - mask-signals -@c snarfed from async.c:370 -@deffn {Scheme Procedure} mask-signals -@deffnx {C Function} scm_mask_signals () -Mask signals. The returned value is not specified. -@end deffn - - call-with-blocked-asyncs -@c snarfed from async.c:404 -@deffn {Scheme Procedure} call-with-blocked-asyncs proc -@deffnx {C Function} scm_call_with_blocked_asyncs (proc) -Call @var{proc} with no arguments and block the execution -of system asyncs by one level for the current thread while -it is running. Return the value returned by @var{proc}. - -@end deffn - - call-with-unblocked-asyncs -@c snarfed from async.c:430 -@deffn {Scheme Procedure} call-with-unblocked-asyncs proc -@deffnx {C Function} scm_call_with_unblocked_asyncs (proc) -Call @var{proc} with no arguments and unblock the execution -of system asyncs by one level for the current thread while -it is running. Return the value returned by @var{proc}. - -@end deffn - - display-error -@c snarfed from backtrace.c:303 -@deffn {Scheme Procedure} display-error stack port subr message args rest -@deffnx {C Function} scm_display_error (stack, port, subr, message, args, rest) -Display an error message to the output port @var{port}. -@var{stack} is the saved stack for the error, @var{subr} is -the name of the procedure in which the error occurred and -@var{message} is the actual error message, which may contain -formatting instructions. These will format the arguments in -the list @var{args} accordingly. @var{rest} is currently -ignored. -@end deffn - - display-application -@c snarfed from backtrace.c:425 -@deffn {Scheme Procedure} display-application frame [port [indent]] -@deffnx {C Function} scm_display_application (frame, port, indent) -Display a procedure application @var{frame} to the output port -@var{port}. @var{indent} specifies the indentation of the -output. -@end deffn - - display-backtrace -@c snarfed from backtrace.c:740 -@deffn {Scheme Procedure} display-backtrace stack port [first [depth [highlights]]] -@deffnx {C Function} scm_display_backtrace_with_highlights (stack, port, first, depth, highlights) -Display a backtrace to the output port @var{port}. @var{stack} -is the stack to take the backtrace from, @var{first} specifies -where in the stack to start and @var{depth} how much frames -to display. Both @var{first} and @var{depth} can be @code{#f}, -which means that default values will be used. -When @var{highlights} is given, -it should be a list and all members of it are highligthed in -the backtrace. -@end deffn - - backtrace -@c snarfed from backtrace.c:776 -@deffn {Scheme Procedure} backtrace [highlights] -@deffnx {C Function} scm_backtrace_with_highlights (highlights) -Display a backtrace of the stack saved by the last error -to the current output port. When @var{highlights} is given, -it should be a list and all members of it are highligthed in -the backtrace. -@end deffn - - not -@c snarfed from boolean.c:33 -@deffn {Scheme Procedure} not x -@deffnx {C Function} scm_not (x) -Return @code{#t} iff @var{x} is @code{#f}, else return @code{#f}. -@end deffn - - boolean? -@c snarfed from boolean.c:43 -@deffn {Scheme Procedure} boolean? obj -@deffnx {C Function} scm_boolean_p (obj) -Return @code{#t} iff @var{obj} is either @code{#t} or @code{#f}. -@end deffn - - char? -@c snarfed from chars.c:33 -@deffn {Scheme Procedure} char? x -@deffnx {C Function} scm_char_p (x) -Return @code{#t} iff @var{x} is a character, else @code{#f}. -@end deffn - - char=? -@c snarfed from chars.c:42 -@deffn {Scheme Procedure} char=? x y -Return @code{#t} iff @var{x} is the same character as @var{y}, else @code{#f}. -@end deffn - - char? -@c snarfed from chars.c:79 -@deffn {Scheme Procedure} char>? x y -Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII -sequence, else @code{#f}. -@end deffn - - char>=? -@c snarfed from chars.c:91 -@deffn {Scheme Procedure} char>=? x y -Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the -ASCII sequence, else @code{#f}. -@end deffn - - char-ci=? -@c snarfed from chars.c:103 -@deffn {Scheme Procedure} char-ci=? x y -Return @code{#t} iff @var{x} is the same character as @var{y} ignoring -case, else @code{#f}. -@end deffn - - char-ci? -@c snarfed from chars.c:139 -@deffn {Scheme Procedure} char-ci>? x y -Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII -sequence ignoring case, else @code{#f}. -@end deffn - - char-ci>=? -@c snarfed from chars.c:151 -@deffn {Scheme Procedure} char-ci>=? x y -Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the -ASCII sequence ignoring case, else @code{#f}. -@end deffn - - char-alphabetic? -@c snarfed from chars.c:163 -@deffn {Scheme Procedure} char-alphabetic? chr -@deffnx {C Function} scm_char_alphabetic_p (chr) -Return @code{#t} iff @var{chr} is alphabetic, else @code{#f}. - -@end deffn - - char-numeric? -@c snarfed from chars.c:172 -@deffn {Scheme Procedure} char-numeric? chr -@deffnx {C Function} scm_char_numeric_p (chr) -Return @code{#t} iff @var{chr} is numeric, else @code{#f}. - -@end deffn - - char-whitespace? -@c snarfed from chars.c:181 -@deffn {Scheme Procedure} char-whitespace? chr -@deffnx {C Function} scm_char_whitespace_p (chr) -Return @code{#t} iff @var{chr} is whitespace, else @code{#f}. - -@end deffn - - char-upper-case? -@c snarfed from chars.c:192 -@deffn {Scheme Procedure} char-upper-case? chr -@deffnx {C Function} scm_char_upper_case_p (chr) -Return @code{#t} iff @var{chr} is uppercase, else @code{#f}. - -@end deffn - - char-lower-case? -@c snarfed from chars.c:202 -@deffn {Scheme Procedure} char-lower-case? chr -@deffnx {C Function} scm_char_lower_case_p (chr) -Return @code{#t} iff @var{chr} is lowercase, else @code{#f}. - -@end deffn - - char-is-both? -@c snarfed from chars.c:213 -@deffn {Scheme Procedure} char-is-both? chr -@deffnx {C Function} scm_char_is_both_p (chr) -Return @code{#t} iff @var{chr} is either uppercase or lowercase, else @code{#f}. - -@end deffn - - char->integer -@c snarfed from chars.c:228 -@deffn {Scheme Procedure} char->integer chr -@deffnx {C Function} scm_char_to_integer (chr) -Return the number corresponding to ordinal position of @var{chr} in the -ASCII sequence. -@end deffn - - integer->char -@c snarfed from chars.c:240 -@deffn {Scheme Procedure} integer->char n -@deffnx {C Function} scm_integer_to_char (n) -Return the character at position @var{n} in the ASCII sequence. -@end deffn - - char-upcase -@c snarfed from chars.c:250 -@deffn {Scheme Procedure} char-upcase chr -@deffnx {C Function} scm_char_upcase (chr) -Return the uppercase character version of @var{chr}. -@end deffn - - char-downcase -@c snarfed from chars.c:261 -@deffn {Scheme Procedure} char-downcase chr -@deffnx {C Function} scm_char_downcase (chr) -Return the lowercase character version of @var{chr}. -@end deffn - - with-continuation-barrier -@c snarfed from continuations.c:412 -@deffn {Scheme Procedure} with-continuation-barrier proc -@deffnx {C Function} scm_with_continuation_barrier (proc) -Call @var{proc} and return its result. Do not allow the invocation of -continuations that would leave or enter the dynamic extent of the call -to @code{with-continuation-barrier}. Such an attempt causes an error -to be signaled. - -Throws (such as errors) that are not caught from within @var{proc} are -caught by @code{with-continuation-barrier}. In that case, a short -message is printed to the current error port and @code{#f} is returned. - -Thus, @code{with-continuation-barrier} returns exactly once. - -@end deffn - - debug-options-interface -@c snarfed from debug.c:54 -@deffn {Scheme Procedure} debug-options-interface [setting] -@deffnx {C Function} scm_debug_options (setting) -Option interface for the debug options. Instead of using -this procedure directly, use the procedures @code{debug-enable}, -@code{debug-disable}, @code{debug-set!} and @code{debug-options}. -@end deffn - - with-traps -@c snarfed from debug.c:101 -@deffn {Scheme Procedure} with-traps thunk -@deffnx {C Function} scm_with_traps (thunk) -Call @var{thunk} with traps enabled. -@end deffn - - memoized? -@c snarfed from debug.c:139 -@deffn {Scheme Procedure} memoized? obj -@deffnx {C Function} scm_memoized_p (obj) -Return @code{#t} if @var{obj} is memoized. -@end deffn - - unmemoize-expr -@c snarfed from debug.c:271 -@deffn {Scheme Procedure} unmemoize-expr m -@deffnx {C Function} scm_i_unmemoize_expr (m) -Unmemoize the memoized expression @var{m}, -@end deffn - - memoized-environment -@c snarfed from debug.c:281 -@deffn {Scheme Procedure} memoized-environment m -@deffnx {C Function} scm_memoized_environment (m) -Return the environment of the memoized expression @var{m}. -@end deffn - - procedure-name -@c snarfed from debug.c:291 -@deffn {Scheme Procedure} procedure-name proc -@deffnx {C Function} scm_procedure_name (proc) -Return the name of the procedure @var{proc} -@end deffn - - procedure-source -@c snarfed from debug.c:317 -@deffn {Scheme Procedure} procedure-source proc -@deffnx {C Function} scm_procedure_source (proc) -Return the source of the procedure @var{proc}. -@end deffn - - procedure-environment -@c snarfed from debug.c:374 -@deffn {Scheme Procedure} procedure-environment proc -@deffnx {C Function} scm_procedure_environment (proc) -Return the environment of the procedure @var{proc}. -@end deffn - - local-eval -@c snarfed from debug.c:406 -@deffn {Scheme Procedure} local-eval exp [env] -@deffnx {C Function} scm_local_eval (exp, env) -Evaluate @var{exp} in its environment. If @var{env} is supplied, -it is the environment in which to evaluate @var{exp}. Otherwise, -@var{exp} must be a memoized code object (in which case, its environment -is implicit). -@end deffn - - debug-object? -@c snarfed from debug.c:493 -@deffn {Scheme Procedure} debug-object? obj -@deffnx {C Function} scm_debug_object_p (obj) -Return @code{#t} if @var{obj} is a debug object. -@end deffn - - issue-deprecation-warning -@c snarfed from deprecation.c:99 -@deffn {Scheme Procedure} issue-deprecation-warning . msgs -@deffnx {C Function} scm_issue_deprecation_warning (msgs) -Output @var{msgs} to @code{(current-error-port)} when this is the first call to @code{issue-deprecation-warning} with this specific @var{msgs}. Do nothing otherwise. The argument @var{msgs} should be a list of strings; they are printed in turn, each one followed by a newline. -@end deffn - - include-deprecated-features -@c snarfed from deprecation.c:144 -@deffn {Scheme Procedure} include-deprecated-features -@deffnx {C Function} scm_include_deprecated_features () -Return @code{#t} iff deprecated features should be included in public interfaces. -@end deffn - - substring-move-left! -@c snarfed from deprecated.c:73 -@deffn {Scheme Procedure} substring-move-left! -implemented by the C function "scm_substring_move_x" -@end deffn - - substring-move-right! -@c snarfed from deprecated.c:75 -@deffn {Scheme Procedure} substring-move-right! -implemented by the C function "scm_substring_move_x" -@end deffn - - c-registered-modules -@c snarfed from deprecated.c:178 -@deffn {Scheme Procedure} c-registered-modules -@deffnx {C Function} scm_registered_modules () -Return a list of the object code modules that have been imported into -the current Guile process. Each element of the list is a pair whose -car is the name of the module, and whose cdr is the function handle -for that module's initializer function. The name is the string that -has been passed to scm_register_module_xxx. -@end deffn - - c-clear-registered-modules -@c snarfed from deprecated.c:199 -@deffn {Scheme Procedure} c-clear-registered-modules -@deffnx {C Function} scm_clear_registered_modules () -Destroy the list of modules registered with the current Guile process. -The return value is unspecified. @strong{Warning:} this function does -not actually unlink or deallocate these modules, but only destroys the -records of which modules have been loaded. It should therefore be used -only by module bookkeeping operations. -@end deffn - - close-all-ports-except -@c snarfed from deprecated.c:342 -@deffn {Scheme Procedure} close-all-ports-except . ports -@deffnx {C Function} scm_close_all_ports_except (ports) -[DEPRECATED] Close all open file ports used by the interpreter -except for those supplied as arguments. This procedure -was intended to be used before an exec call to close file descriptors -which are not needed in the new process. However it has the -undesirable side effect of flushing buffers, so it's deprecated. -Use port-for-each instead. -@end deffn - - variable-set-name-hint! -@c snarfed from deprecated.c:359 -@deffn {Scheme Procedure} variable-set-name-hint! var hint -@deffnx {C Function} scm_variable_set_name_hint (var, hint) -Do not use this function. -@end deffn - - builtin-variable -@c snarfed from deprecated.c:372 -@deffn {Scheme Procedure} builtin-variable name -@deffnx {C Function} scm_builtin_variable (name) -Do not use this function. -@end deffn - - sloppy-memq -@c snarfed from deprecated.c:446 -@deffn {Scheme Procedure} sloppy-memq x lst -@deffnx {C Function} scm_sloppy_memq (x, lst) -This procedure behaves like @code{memq}, but does no type or error checking. -Its use is recommended only in writing Guile internals, -not for high-level Scheme programs. -@end deffn - - sloppy-memv -@c snarfed from deprecated.c:466 -@deffn {Scheme Procedure} sloppy-memv x lst -@deffnx {C Function} scm_sloppy_memv (x, lst) -This procedure behaves like @code{memv}, but does no type or error checking. -Its use is recommended only in writing Guile internals, -not for high-level Scheme programs. -@end deffn - - sloppy-member -@c snarfed from deprecated.c:486 -@deffn {Scheme Procedure} sloppy-member x lst -@deffnx {C Function} scm_sloppy_member (x, lst) -This procedure behaves like @code{member}, but does no type or error checking. -Its use is recommended only in writing Guile internals, -not for high-level Scheme programs. -@end deffn - - read-and-eval! -@c snarfed from deprecated.c:508 -@deffn {Scheme Procedure} read-and-eval! [port] -@deffnx {C Function} scm_read_and_eval_x (port) -Read a form from @var{port} (standard input by default), and evaluate it -(memoizing it in the process) in the top-level environment. If no data -is left to be read from @var{port}, an @code{end-of-file} error is -signalled. -@end deffn - - string->obarray-symbol -@c snarfed from deprecated.c:825 -@deffn {Scheme Procedure} string->obarray-symbol o s [softp] -@deffnx {C Function} scm_string_to_obarray_symbol (o, s, softp) -Intern a new symbol in @var{obarray}, a symbol table, with name -@var{string}. - -If @var{obarray} is @code{#f}, use the default system symbol table. If -@var{obarray} is @code{#t}, the symbol should not be interned in any -symbol table; merely return the pair (@var{symbol} -. @var{#}). - -The @var{soft?} argument determines whether new symbol table entries -should be created when the specified symbol is not already present in -@var{obarray}. If @var{soft?} is specified and is a true value, then -new entries should not be added for symbols not already present in the -table; instead, simply return @code{#f}. -@end deffn - - intern-symbol -@c snarfed from deprecated.c:863 -@deffn {Scheme Procedure} intern-symbol o s -@deffnx {C Function} scm_intern_symbol (o, s) -Add a new symbol to @var{obarray} with name @var{string}, bound to an -unspecified initial value. The symbol table is not modified if a symbol -with this name is already present. -@end deffn - - unintern-symbol -@c snarfed from deprecated.c:905 -@deffn {Scheme Procedure} unintern-symbol o s -@deffnx {C Function} scm_unintern_symbol (o, s) -Remove the symbol with name @var{string} from @var{obarray}. This -function returns @code{#t} if the symbol was present and @code{#f} -otherwise. -@end deffn - - symbol-binding -@c snarfed from deprecated.c:950 -@deffn {Scheme Procedure} symbol-binding o s -@deffnx {C Function} scm_symbol_binding (o, s) -Look up in @var{obarray} the symbol whose name is @var{string}, and -return the value to which it is bound. If @var{obarray} is @code{#f}, -use the global symbol table. If @var{string} is not interned in -@var{obarray}, an error is signalled. -@end deffn - - symbol-bound? -@c snarfed from deprecated.c:1003 -@deffn {Scheme Procedure} symbol-bound? o s -@deffnx {C Function} scm_symbol_bound_p (o, s) -Return @code{#t} if @var{obarray} contains a symbol with name -@var{string} bound to a defined value. This differs from -@var{symbol-interned?} in that the mere mention of a symbol -usually causes it to be interned; @code{symbol-bound?} -determines whether a symbol has been given any meaningful -value. -@end deffn - - symbol-set! -@c snarfed from deprecated.c:1030 -@deffn {Scheme Procedure} symbol-set! o s v -@deffnx {C Function} scm_symbol_set_x (o, s, v) -Find the symbol in @var{obarray} whose name is @var{string}, and rebind -it to @var{value}. An error is signalled if @var{string} is not present -in @var{obarray}. -@end deffn - - gentemp -@c snarfed from deprecated.c:1063 -@deffn {Scheme Procedure} gentemp [prefix [obarray]] -@deffnx {C Function} scm_gentemp (prefix, obarray) -Create a new symbol with a name unique in an obarray. -The name is constructed from an optional string @var{prefix} -and a counter value. The default prefix is @code{t}. The -@var{obarray} is specified as a second optional argument. -Default is the system obarray where all normal symbols are -interned. The counter is increased by 1 at each -call. There is no provision for resetting the counter. -@end deffn - - make-keyword-from-dash-symbol -@c snarfed from discouraged.c:161 -@deffn {Scheme Procedure} make-keyword-from-dash-symbol symbol -@deffnx {C Function} scm_make_keyword_from_dash_symbol (symbol) -Make a keyword object from a @var{symbol} that starts with a dash. -@end deffn - - keyword-dash-symbol -@c snarfed from discouraged.c:183 -@deffn {Scheme Procedure} keyword-dash-symbol keyword -@deffnx {C Function} scm_keyword_dash_symbol (keyword) -Return the dash symbol for @var{keyword}. -This is the inverse of @code{make-keyword-from-dash-symbol}. -@end deffn - - dynamic-link -@c snarfed from dynl.c:149 -@deffn {Scheme Procedure} dynamic-link filename -@deffnx {C Function} scm_dynamic_link (filename) -Find the shared object (shared library) denoted by -@var{filename} and link it into the running Guile -application. The returned -scheme object is a ``handle'' for the library which can -be passed to @code{dynamic-func}, @code{dynamic-call} etc. - -Searching for object files is system dependent. Normally, -if @var{filename} does have an explicit directory it will -be searched for in locations -such as @file{/usr/lib} and @file{/usr/local/lib}. -@end deffn - - dynamic-object? -@c snarfed from dynl.c:168 -@deffn {Scheme Procedure} dynamic-object? obj -@deffnx {C Function} scm_dynamic_object_p (obj) -Return @code{#t} if @var{obj} is a dynamic object handle, -or @code{#f} otherwise. -@end deffn - - dynamic-unlink -@c snarfed from dynl.c:182 -@deffn {Scheme Procedure} dynamic-unlink dobj -@deffnx {C Function} scm_dynamic_unlink (dobj) -Unlink a dynamic object from the application, if possible. The -object must have been linked by @code{dynamic-link}, with -@var{dobj} the corresponding handle. After this procedure -is called, the handle can no longer be used to access the -object. -@end deffn - - dynamic-func -@c snarfed from dynl.c:207 -@deffn {Scheme Procedure} dynamic-func name dobj -@deffnx {C Function} scm_dynamic_func (name, dobj) -Return a ``handle'' for the function @var{name} in the -shared object referred to by @var{dobj}. The handle -can be passed to @code{dynamic-call} to actually -call the function. - -Regardless whether your C compiler prepends an underscore -@samp{_} to the global names in a program, you should -@strong{not} include this underscore in @var{name} -since it will be added automatically when necessary. -@end deffn - - dynamic-call -@c snarfed from dynl.c:253 -@deffn {Scheme Procedure} dynamic-call func dobj -@deffnx {C Function} scm_dynamic_call (func, dobj) -Call a C function in a dynamic object. Two styles of -invocation are supported: - -@itemize @bullet -@item @var{func} can be a function handle returned by -@code{dynamic-func}. In this case @var{dobj} is -ignored -@item @var{func} can be a string with the name of the -function to call, with @var{dobj} the handle of the -dynamic object in which to find the function. -This is equivalent to -@smallexample - -(dynamic-call (dynamic-func @var{func} @var{dobj}) #f) -@end smallexample -@end itemize - -In either case, the function is passed no arguments -and its return value is ignored. -@end deffn - - dynamic-args-call -@c snarfed from dynl.c:285 -@deffn {Scheme Procedure} dynamic-args-call func dobj args -@deffnx {C Function} scm_dynamic_args_call (func, dobj, args) -Call the C function indicated by @var{func} and @var{dobj}, -just like @code{dynamic-call}, but pass it some arguments and -return its return value. The C function is expected to take -two arguments and return an @code{int}, just like @code{main}: -@smallexample -int c_func (int argc, char **argv); -@end smallexample - -The parameter @var{args} must be a list of strings and is -converted into an array of @code{char *}. The array is passed -in @var{argv} and its size in @var{argc}. The return value is -converted to a Scheme number and returned from the call to -@code{dynamic-args-call}. -@end deffn - - dynamic-wind -@c snarfed from dynwind.c:97 -@deffn {Scheme Procedure} dynamic-wind in_guard thunk out_guard -@deffnx {C Function} scm_dynamic_wind (in_guard, thunk, out_guard) -All three arguments must be 0-argument procedures. -@var{in_guard} is called, then @var{thunk}, then -@var{out_guard}. - -If, any time during the execution of @var{thunk}, the -continuation of the @code{dynamic_wind} expression is escaped -non-locally, @var{out_guard} is called. If the continuation of -the dynamic-wind is re-entered, @var{in_guard} is called. Thus -@var{in_guard} and @var{out_guard} may be called any number of -times. -@lisp -(define x 'normal-binding) -@result{} x -(define a-cont (call-with-current-continuation - (lambda (escape) - (let ((old-x x)) - (dynamic-wind - ;; in-guard: - ;; - (lambda () (set! x 'special-binding)) - - ;; thunk - ;; - (lambda () (display x) (newline) - (call-with-current-continuation escape) - (display x) (newline) - x) - - ;; out-guard: - ;; - (lambda () (set! x old-x))))))) - -;; Prints: -special-binding -;; Evaluates to: -@result{} a-cont -x -@result{} normal-binding -(a-cont #f) -;; Prints: -special-binding -;; Evaluates to: -@result{} a-cont ;; the value of the (define a-cont...) -x -@result{} normal-binding -a-cont -@result{} special-binding -@end lisp -@end deffn - - environment? -@c snarfed from environments.c:106 -@deffn {Scheme Procedure} environment? obj -@deffnx {C Function} scm_environment_p (obj) -Return @code{#t} if @var{obj} is an environment, or @code{#f} -otherwise. -@end deffn - - environment-bound? -@c snarfed from environments.c:117 -@deffn {Scheme Procedure} environment-bound? env sym -@deffnx {C Function} scm_environment_bound_p (env, sym) -Return @code{#t} if @var{sym} is bound in @var{env}, or -@code{#f} otherwise. -@end deffn - - environment-ref -@c snarfed from environments.c:132 -@deffn {Scheme Procedure} environment-ref env sym -@deffnx {C Function} scm_environment_ref (env, sym) -Return the value of the location bound to @var{sym} in -@var{env}. If @var{sym} is unbound in @var{env}, signal an -@code{environment:unbound} error. -@end deffn - - environment-fold -@c snarfed from environments.c:202 -@deffn {Scheme Procedure} environment-fold env proc init -@deffnx {C Function} scm_environment_fold (env, proc, init) -Iterate over all the bindings in @var{env}, accumulating some -value. -For each binding in @var{env}, apply @var{proc} to the symbol -bound, its value, and the result from the previous application -of @var{proc}. -Use @var{init} as @var{proc}'s third argument the first time -@var{proc} is applied. -If @var{env} contains no bindings, this function simply returns -@var{init}. -If @var{env} binds the symbol sym1 to the value val1, sym2 to -val2, and so on, then this procedure computes: -@lisp - (proc sym1 val1 - (proc sym2 val2 - ... - (proc symn valn - init))) -@end lisp -Each binding in @var{env} will be processed exactly once. -@code{environment-fold} makes no guarantees about the order in -which the bindings are processed. -Here is a function which, given an environment, constructs an -association list representing that environment's bindings, -using environment-fold: -@lisp - (define (environment->alist env) - (environment-fold env - (lambda (sym val tail) - (cons (cons sym val) tail)) - '())) -@end lisp -@end deffn - - environment-define -@c snarfed from environments.c:237 -@deffn {Scheme Procedure} environment-define env sym val -@deffnx {C Function} scm_environment_define (env, sym, val) -Bind @var{sym} to a new location containing @var{val} in -@var{env}. If @var{sym} is already bound to another location -in @var{env} and the binding is mutable, that binding is -replaced. The new binding and location are both mutable. The -return value is unspecified. -If @var{sym} is already bound in @var{env}, and the binding is -immutable, signal an @code{environment:immutable-binding} error. -@end deffn - - environment-undefine -@c snarfed from environments.c:263 -@deffn {Scheme Procedure} environment-undefine env sym -@deffnx {C Function} scm_environment_undefine (env, sym) -Remove any binding for @var{sym} from @var{env}. If @var{sym} -is unbound in @var{env}, do nothing. The return value is -unspecified. -If @var{sym} is already bound in @var{env}, and the binding is -immutable, signal an @code{environment:immutable-binding} error. -@end deffn - - environment-set! -@c snarfed from environments.c:291 -@deffn {Scheme Procedure} environment-set! env sym val -@deffnx {C Function} scm_environment_set_x (env, sym, val) -If @var{env} binds @var{sym} to some location, change that -location's value to @var{val}. The return value is -unspecified. -If @var{sym} is not bound in @var{env}, signal an -@code{environment:unbound} error. If @var{env} binds @var{sym} -to an immutable location, signal an -@code{environment:immutable-location} error. -@end deffn - - environment-cell -@c snarfed from environments.c:326 -@deffn {Scheme Procedure} environment-cell env sym for_write -@deffnx {C Function} scm_environment_cell (env, sym, for_write) -Return the value cell which @var{env} binds to @var{sym}, or -@code{#f} if the binding does not live in a value cell. -The argument @var{for-write} indicates whether the caller -intends to modify the variable's value by mutating the value -cell. If the variable is immutable, then -@code{environment-cell} signals an -@code{environment:immutable-location} error. -If @var{sym} is unbound in @var{env}, signal an -@code{environment:unbound} error. -If you use this function, you should consider using -@code{environment-observe}, to be notified when @var{sym} gets -re-bound to a new value cell, or becomes undefined. -@end deffn - - environment-observe -@c snarfed from environments.c:378 -@deffn {Scheme Procedure} environment-observe env proc -@deffnx {C Function} scm_environment_observe (env, proc) -Whenever @var{env}'s bindings change, apply @var{proc} to -@var{env}. -This function returns an object, token, which you can pass to -@code{environment-unobserve} to remove @var{proc} from the set -of procedures observing @var{env}. The type and value of -token is unspecified. -@end deffn - - environment-observe-weak -@c snarfed from environments.c:395 -@deffn {Scheme Procedure} environment-observe-weak env proc -@deffnx {C Function} scm_environment_observe_weak (env, proc) -This function is the same as environment-observe, except that -the reference @var{env} retains to @var{proc} is a weak -reference. This means that, if there are no other live, -non-weak references to @var{proc}, it will be -garbage-collected, and dropped from @var{env}'s -list of observing procedures. -@end deffn - - environment-unobserve -@c snarfed from environments.c:431 -@deffn {Scheme Procedure} environment-unobserve token -@deffnx {C Function} scm_environment_unobserve (token) -Cancel the observation request which returned the value -@var{token}. The return value is unspecified. -If a call @code{(environment-observe env proc)} returns -@var{token}, then the call @code{(environment-unobserve token)} -will cause @var{proc} to no longer be called when @var{env}'s -bindings change. -@end deffn - - make-leaf-environment -@c snarfed from environments.c:1017 -@deffn {Scheme Procedure} make-leaf-environment -@deffnx {C Function} scm_make_leaf_environment () -Create a new leaf environment, containing no bindings. -All bindings and locations created in the new environment -will be mutable. -@end deffn - - leaf-environment? -@c snarfed from environments.c:1040 -@deffn {Scheme Procedure} leaf-environment? object -@deffnx {C Function} scm_leaf_environment_p (object) -Return @code{#t} if object is a leaf environment, or @code{#f} -otherwise. -@end deffn - - make-eval-environment -@c snarfed from environments.c:1405 -@deffn {Scheme Procedure} make-eval-environment local imported -@deffnx {C Function} scm_make_eval_environment (local, imported) -Return a new environment object eval whose bindings are the -union of the bindings in the environments @var{local} and -@var{imported}, with bindings from @var{local} taking -precedence. Definitions made in eval are placed in @var{local}. -Applying @code{environment-define} or -@code{environment-undefine} to eval has the same effect as -applying the procedure to @var{local}. -Note that eval incorporates @var{local} and @var{imported} by -reference: -If, after creating eval, the program changes the bindings of -@var{local} or @var{imported}, those changes will be visible -in eval. -Since most Scheme evaluation takes place in eval environments, -they transparently cache the bindings received from @var{local} -and @var{imported}. Thus, the first time the program looks up -a symbol in eval, eval may make calls to @var{local} or -@var{imported} to find their bindings, but subsequent -references to that symbol will be as fast as references to -bindings in finite environments. -In typical use, @var{local} will be a finite environment, and -@var{imported} will be an import environment -@end deffn - - eval-environment? -@c snarfed from environments.c:1442 -@deffn {Scheme Procedure} eval-environment? object -@deffnx {C Function} scm_eval_environment_p (object) -Return @code{#t} if object is an eval environment, or @code{#f} -otherwise. -@end deffn - - eval-environment-local -@c snarfed from environments.c:1452 -@deffn {Scheme Procedure} eval-environment-local env -@deffnx {C Function} scm_eval_environment_local (env) -Return the local environment of eval environment @var{env}. -@end deffn - - eval-environment-set-local! -@c snarfed from environments.c:1464 -@deffn {Scheme Procedure} eval-environment-set-local! env local -@deffnx {C Function} scm_eval_environment_set_local_x (env, local) -Change @var{env}'s local environment to @var{local}. -@end deffn - - eval-environment-imported -@c snarfed from environments.c:1490 -@deffn {Scheme Procedure} eval-environment-imported env -@deffnx {C Function} scm_eval_environment_imported (env) -Return the imported environment of eval environment @var{env}. -@end deffn - - eval-environment-set-imported! -@c snarfed from environments.c:1502 -@deffn {Scheme Procedure} eval-environment-set-imported! env imported -@deffnx {C Function} scm_eval_environment_set_imported_x (env, imported) -Change @var{env}'s imported environment to @var{imported}. -@end deffn - - make-import-environment -@c snarfed from environments.c:1825 -@deffn {Scheme Procedure} make-import-environment imports conflict_proc -@deffnx {C Function} scm_make_import_environment (imports, conflict_proc) -Return a new environment @var{imp} whose bindings are the union -of the bindings from the environments in @var{imports}; -@var{imports} must be a list of environments. That is, -@var{imp} binds a symbol to a location when some element of -@var{imports} does. -If two different elements of @var{imports} have a binding for -the same symbol, the @var{conflict-proc} is called with the -following parameters: the import environment, the symbol and -the list of the imported environments that bind the symbol. -If the @var{conflict-proc} returns an environment @var{env}, -the conflict is considered as resolved and the binding from -@var{env} is used. If the @var{conflict-proc} returns some -non-environment object, the conflict is considered unresolved -and the symbol is treated as unspecified in the import -environment. -The checking for conflicts may be performed lazily, i. e. at -the moment when a value or binding for a certain symbol is -requested instead of the moment when the environment is -created or the bindings of the imports change. -All bindings in @var{imp} are immutable. If you apply -@code{environment-define} or @code{environment-undefine} to -@var{imp}, Guile will signal an - @code{environment:immutable-binding} error. However, -notice that the set of bindings in @var{imp} may still change, -if one of its imported environments changes. -@end deffn - - import-environment? -@c snarfed from environments.c:1854 -@deffn {Scheme Procedure} import-environment? object -@deffnx {C Function} scm_import_environment_p (object) -Return @code{#t} if object is an import environment, or -@code{#f} otherwise. -@end deffn - - import-environment-imports -@c snarfed from environments.c:1865 -@deffn {Scheme Procedure} import-environment-imports env -@deffnx {C Function} scm_import_environment_imports (env) -Return the list of environments imported by the import -environment @var{env}. -@end deffn - - import-environment-set-imports! -@c snarfed from environments.c:1878 -@deffn {Scheme Procedure} import-environment-set-imports! env imports -@deffnx {C Function} scm_import_environment_set_imports_x (env, imports) -Change @var{env}'s list of imported environments to -@var{imports}, and check for conflicts. -@end deffn - - make-export-environment -@c snarfed from environments.c:2145 -@deffn {Scheme Procedure} make-export-environment private signature -@deffnx {C Function} scm_make_export_environment (private, signature) -Return a new environment @var{exp} containing only those -bindings in private whose symbols are present in -@var{signature}. The @var{private} argument must be an -environment. - -The environment @var{exp} binds symbol to location when -@var{env} does, and symbol is exported by @var{signature}. - -@var{signature} is a list specifying which of the bindings in -@var{private} should be visible in @var{exp}. Each element of -@var{signature} should be a list of the form: - (symbol attribute ...) -where each attribute is one of the following: -@table @asis -@item the symbol @code{mutable-location} - @var{exp} should treat the - location bound to symbol as mutable. That is, @var{exp} - will pass calls to @code{environment-set!} or - @code{environment-cell} directly through to private. -@item the symbol @code{immutable-location} - @var{exp} should treat - the location bound to symbol as immutable. If the program - applies @code{environment-set!} to @var{exp} and symbol, or - calls @code{environment-cell} to obtain a writable value - cell, @code{environment-set!} will signal an - @code{environment:immutable-location} error. Note that, even - if an export environment treats a location as immutable, the - underlying environment may treat it as mutable, so its - value may change. -@end table -It is an error for an element of signature to specify both -@code{mutable-location} and @code{immutable-location}. If -neither is specified, @code{immutable-location} is assumed. - -As a special case, if an element of signature is a lone -symbol @var{sym}, it is equivalent to an element of the form -@code{(sym)}. - -All bindings in @var{exp} are immutable. If you apply -@code{environment-define} or @code{environment-undefine} to -@var{exp}, Guile will signal an -@code{environment:immutable-binding} error. However, -notice that the set of bindings in @var{exp} may still change, -if the bindings in private change. -@end deffn - - export-environment? -@c snarfed from environments.c:2180 -@deffn {Scheme Procedure} export-environment? object -@deffnx {C Function} scm_export_environment_p (object) -Return @code{#t} if object is an export environment, or -@code{#f} otherwise. -@end deffn - - export-environment-private -@c snarfed from environments.c:2190 -@deffn {Scheme Procedure} export-environment-private env -@deffnx {C Function} scm_export_environment_private (env) -Return the private environment of export environment @var{env}. -@end deffn - - export-environment-set-private! -@c snarfed from environments.c:2202 -@deffn {Scheme Procedure} export-environment-set-private! env private -@deffnx {C Function} scm_export_environment_set_private_x (env, private) -Change the private environment of export environment @var{env}. -@end deffn - - export-environment-signature -@c snarfed from environments.c:2224 -@deffn {Scheme Procedure} export-environment-signature env -@deffnx {C Function} scm_export_environment_signature (env) -Return the signature of export environment @var{env}. -@end deffn - - export-environment-set-signature! -@c snarfed from environments.c:2298 -@deffn {Scheme Procedure} export-environment-set-signature! env signature -@deffnx {C Function} scm_export_environment_set_signature_x (env, signature) -Change the signature of export environment @var{env}. -@end deffn - - eq? -@c snarfed from eq.c:81 -@deffn {Scheme Procedure} eq? x y -Return @code{#t} if @var{x} and @var{y} are the same object, -except for numbers and characters. For example, - -@example -(define x (vector 1 2 3)) -(define y (vector 1 2 3)) - -(eq? x x) @result{} #t -(eq? x y) @result{} #f -@end example - -Numbers and characters are not equal to any other object, but -the problem is they're not necessarily @code{eq?} to themselves -either. This is even so when the number comes directly from a -variable, - -@example -(let ((n (+ 2 3))) - (eq? n n)) @result{} *unspecified* -@end example - -Generally @code{eqv?} should be used when comparing numbers or -characters. @code{=} or @code{char=?} can be used too. - -It's worth noting that end-of-list @code{()}, @code{#t}, -@code{#f}, a symbol of a given name, and a keyword of a given -name, are unique objects. There's just one of each, so for -instance no matter how @code{()} arises in a program, it's the -same object and can be compared with @code{eq?}, - -@example -(define x (cdr '(123))) -(define y (cdr '(456))) -(eq? x y) @result{} #t - -(define x (string->symbol "foo")) -(eq? x 'foo) @result{} #t -@end example -@end deffn - - eqv? -@c snarfed from eq.c:116 -@deffn {Scheme Procedure} eqv? x y -Return @code{#t} if @var{x} and @var{y} are the same object, or -for characters and numbers the same value. - -On objects except characters and numbers, @code{eqv?} is the -same as @code{eq?}, it's true if @var{x} and @var{y} are the -same object. - -If @var{x} and @var{y} are numbers or characters, @code{eqv?} -compares their type and value. An exact number is not -@code{eqv?} to an inexact number (even if their value is the -same). - -@example -(eqv? 3 (+ 1 2)) @result{} #t -(eqv? 1 1.0) @result{} #f -@end example -@end deffn - - equal? -@c snarfed from eq.c:212 -@deffn {Scheme Procedure} equal? x y -Return @code{#t} if @var{x} and @var{y} are the same type, and -their contents or value are equal. - -For a pair, string, vector or array, @code{equal?} compares the -contents, and does so using using the same @code{equal?} -recursively, so a deep structure can be traversed. - -@example -(equal? (list 1 2 3) (list 1 2 3)) @result{} #t -(equal? (list 1 2 3) (vector 1 2 3)) @result{} #f -@end example - -For other objects, @code{equal?} compares as per @code{eqv?}, -which means characters and numbers are compared by type and -value (and like @code{eqv?}, exact and inexact numbers are not -@code{equal?}, even if their value is the same). - -@example -(equal? 3 (+ 1 2)) @result{} #t -(equal? 1 1.0) @result{} #f -@end example - -Hash tables are currently only compared as per @code{eq?}, so -two different tables are not @code{equal?}, even if their -contents are the same. - -@code{equal?} does not support circular data structures, it may -go into an infinite loop if asked to compare two circular lists -or similar. - -New application-defined object types (Smobs) have an -@code{equalp} handler which is called by @code{equal?}. This -lets an application traverse the contents or control what is -considered @code{equal?} for two such objects. If there's no -handler, the default is to just compare as per @code{eq?}. -@end deffn - - scm-error -@c snarfed from error.c:82 -@deffn {Scheme Procedure} scm-error key subr message args data -@deffnx {C Function} scm_error_scm (key, subr, message, args, data) -Raise an error with key @var{key}. @var{subr} can be a string -naming the procedure associated with the error, or @code{#f}. -@var{message} is the error message string, possibly containing -@code{~S} and @code{~A} escapes. When an error is reported, -these are replaced by formatting the corresponding members of -@var{args}: @code{~A} (was @code{%s} in older versions of -Guile) formats using @code{display} and @code{~S} (was -@code{%S}) formats using @code{write}. @var{data} is a list or -@code{#f} depending on @var{key}: if @var{key} is -@code{system-error} then it should be a list containing the -Unix @code{errno} value; If @var{key} is @code{signal} then it -should be a list containing the Unix signal number; If -@var{key} is @code{out-of-range} or @code{wrong-type-arg}, -it is a list containing the bad value; otherwise -it will usually be @code{#f}. -@end deffn - - strerror -@c snarfed from error.c:129 -@deffn {Scheme Procedure} strerror err -@deffnx {C Function} scm_strerror (err) -Return the Unix error message corresponding to @var{err}, which -must be an integer value. -@end deffn - - apply:nconc2last -@c snarfed from eval.c:4686 -@deffn {Scheme Procedure} apply:nconc2last lst -@deffnx {C Function} scm_nconc2last (lst) -Given a list (@var{arg1} @dots{} @var{args}), this function -conses the @var{arg1} @dots{} arguments onto the front of -@var{args}, and returns the resulting list. Note that -@var{args} is a list; thus, the argument to this function is -a list whose last element is a list. -Note: Rather than do new consing, @code{apply:nconc2last} -destroys its argument, so use with care. -@end deffn - - force -@c snarfed from eval.c:5598 -@deffn {Scheme Procedure} force promise -@deffnx {C Function} scm_force (promise) -If the promise @var{x} has not been computed yet, compute and -return @var{x}, otherwise just return the previously computed -value. -@end deffn - - promise? -@c snarfed from eval.c:5621 -@deffn {Scheme Procedure} promise? obj -@deffnx {C Function} scm_promise_p (obj) -Return true if @var{obj} is a promise, i.e. a delayed computation -(@pxref{Delayed evaluation,,,r5rs.info,The Revised^5 Report on Scheme}). -@end deffn - - cons-source -@c snarfed from eval.c:5633 -@deffn {Scheme Procedure} cons-source xorig x y -@deffnx {C Function} scm_cons_source (xorig, x, y) -Create and return a new pair whose car and cdr are @var{x} and @var{y}. -Any source properties associated with @var{xorig} are also associated -with the new pair. -@end deffn - - copy-tree -@c snarfed from eval.c:5790 -@deffn {Scheme Procedure} copy-tree obj -@deffnx {C Function} scm_copy_tree (obj) -Recursively copy the data tree that is bound to @var{obj}, and return a -the new data structure. @code{copy-tree} recurses down the -contents of both pairs and vectors (since both cons cells and vector -cells may point to arbitrary objects), and stops recursing when it hits -any other object. -@end deffn - - primitive-eval -@c snarfed from eval.c:5878 -@deffn {Scheme Procedure} primitive-eval exp -@deffnx {C Function} scm_primitive_eval (exp) -Evaluate @var{exp} in the top-level environment specified by -the current module. -@end deffn - - eval -@c snarfed from eval.c:5922 -@deffn {Scheme Procedure} eval exp module_or_state -@deffnx {C Function} scm_eval (exp, module_or_state) -Evaluate @var{exp}, a list representing a Scheme expression, -in the top-level environment specified by -@var{module_or_state}. -While @var{exp} is evaluated (using @code{primitive-eval}), -@var{module_or_state} is made the current module when -it is a module, or the current dynamic state when it is -a dynamic state.Example: (eval '(+ 1 2) (interaction-environment)) -@end deffn - - eval-options-interface -@c snarfed from eval.c:3086 -@deffn {Scheme Procedure} eval-options-interface [setting] -@deffnx {C Function} scm_eval_options_interface (setting) -Option interface for the evaluation options. Instead of using -this procedure directly, use the procedures @code{eval-enable}, -@code{eval-disable}, @code{eval-set!} and @code{eval-options}. -@end deffn - - evaluator-traps-interface -@c snarfed from eval.c:3104 -@deffn {Scheme Procedure} evaluator-traps-interface [setting] -@deffnx {C Function} scm_evaluator_traps (setting) -Option interface for the evaluator trap options. -@end deffn - - defined? -@c snarfed from evalext.c:34 -@deffn {Scheme Procedure} defined? sym [env] -@deffnx {C Function} scm_defined_p (sym, env) -Return @code{#t} if @var{sym} is defined in the lexical environment @var{env}. When @var{env} is not specified, look in the top-level environment as defined by the current module. -@end deffn - - map-in-order -@c snarfed from evalext.c:80 -@deffn {Scheme Procedure} map-in-order -implemented by the C function "scm_map" -@end deffn - - self-evaluating? -@c snarfed from evalext.c:85 -@deffn {Scheme Procedure} self-evaluating? obj -@deffnx {C Function} scm_self_evaluating_p (obj) -Return #t for objects which Guile considers self-evaluating -@end deffn - - load-extension -@c snarfed from extensions.c:143 -@deffn {Scheme Procedure} load-extension lib init -@deffnx {C Function} scm_load_extension (lib, init) -Load and initialize the extension designated by LIB and INIT. -When there is no pre-registered function for LIB/INIT, this is -equivalent to - -@lisp -(dynamic-call INIT (dynamic-link LIB)) -@end lisp - -When there is a pre-registered function, that function is called -instead. - -Normally, there is no pre-registered function. This option exists -only for situations where dynamic linking is unavailable or unwanted. -In that case, you would statically link your program with the desired -library, and register its init function right after Guile has been -initialized. - -LIB should be a string denoting a shared library without any file type -suffix such as ".so". The suffix is provided automatically. It -should also not contain any directory components. Libraries that -implement Guile Extensions should be put into the normal locations for -shared libraries. We recommend to use the naming convention -libguile-bla-blum for a extension related to a module `(bla blum)'. - -The normal way for a extension to be used is to write a small Scheme -file that defines a module, and to load the extension into this -module. When the module is auto-loaded, the extension is loaded as -well. For example, - -@lisp -(define-module (bla blum)) - -(load-extension "libguile-bla-blum" "bla_init_blum") -@end lisp -@end deffn - - program-arguments -@c snarfed from feature.c:57 -@deffn {Scheme Procedure} program-arguments -@deffnx {Scheme Procedure} command-line -@deffnx {C Function} scm_program_arguments () -Return the list of command line arguments passed to Guile, as a list of -strings. The list includes the invoked program name, which is usually -@code{"guile"}, but excludes switches and parameters for command line -options like @code{-e} and @code{-l}. -@end deffn - - make-fluid -@c snarfed from fluids.c:260 -@deffn {Scheme Procedure} make-fluid -@deffnx {C Function} scm_make_fluid () -Return a newly created fluid. -Fluids are objects that can hold one -value per dynamic state. That is, modifications to this value are -only visible to code that executes with the same dynamic state as -the modifying code. When a new dynamic state is constructed, it -inherits the values from its parent. Because each thread normally executes -with its own dynamic state, you can use fluids for thread local storage. -@end deffn - - fluid? -@c snarfed from fluids.c:283 -@deffn {Scheme Procedure} fluid? obj -@deffnx {C Function} scm_fluid_p (obj) -Return @code{#t} iff @var{obj} is a fluid; otherwise, return -@code{#f}. -@end deffn - - fluid-ref -@c snarfed from fluids.c:306 -@deffn {Scheme Procedure} fluid-ref fluid -@deffnx {C Function} scm_fluid_ref (fluid) -Return the value associated with @var{fluid} in the current -dynamic root. If @var{fluid} has not been set, then return -@code{#f}. -@end deffn - - fluid-set! -@c snarfed from fluids.c:325 -@deffn {Scheme Procedure} fluid-set! fluid value -@deffnx {C Function} scm_fluid_set_x (fluid, value) -Set the value associated with @var{fluid} in the current dynamic root. -@end deffn - - with-fluids* -@c snarfed from fluids.c:395 -@deffn {Scheme Procedure} with-fluids* fluids values thunk -@deffnx {C Function} scm_with_fluids (fluids, values, thunk) -Set @var{fluids} to @var{values} temporary, and call @var{thunk}. -@var{fluids} must be a list of fluids and @var{values} must be the same -number of their values to be applied. Each substitution is done -one after another. @var{thunk} must be a procedure with no argument. -@end deffn - - with-fluid* -@c snarfed from fluids.c:434 -@deffn {Scheme Procedure} with-fluid* fluid value thunk -@deffnx {C Function} scm_with_fluid (fluid, value, thunk) -Set @var{fluid} to @var{value} temporarily, and call @var{thunk}. -@var{thunk} must be a procedure with no argument. -@end deffn - - make-dynamic-state -@c snarfed from fluids.c:487 -@deffn {Scheme Procedure} make-dynamic-state [parent] -@deffnx {C Function} scm_make_dynamic_state (parent) -Return a copy of the dynamic state object @var{parent} -or of the current dynamic state when @var{parent} is omitted. -@end deffn - - dynamic-state? -@c snarfed from fluids.c:515 -@deffn {Scheme Procedure} dynamic-state? obj -@deffnx {C Function} scm_dynamic_state_p (obj) -Return @code{#t} if @var{obj} is a dynamic state object; -return @code{#f} otherwise -@end deffn - - current-dynamic-state -@c snarfed from fluids.c:530 -@deffn {Scheme Procedure} current-dynamic-state -@deffnx {C Function} scm_current_dynamic_state () -Return the current dynamic state object. -@end deffn - - set-current-dynamic-state -@c snarfed from fluids.c:540 -@deffn {Scheme Procedure} set-current-dynamic-state state -@deffnx {C Function} scm_set_current_dynamic_state (state) -Set the current dynamic state object to @var{state} -and return the previous current dynamic state object. -@end deffn - - with-dynamic-state -@c snarfed from fluids.c:582 -@deffn {Scheme Procedure} with-dynamic-state state proc -@deffnx {C Function} scm_with_dynamic_state (state, proc) -Call @var{proc} while @var{state} is the current dynamic -state object. -@end deffn - - setvbuf -@c snarfed from fports.c:137 -@deffn {Scheme Procedure} setvbuf port mode [size] -@deffnx {C Function} scm_setvbuf (port, mode, size) -Set the buffering mode for @var{port}. @var{mode} can be: -@table @code -@item _IONBF -non-buffered -@item _IOLBF -line buffered -@item _IOFBF -block buffered, using a newly allocated buffer of @var{size} bytes. -If @var{size} is omitted, a default size will be used. -@end table -@end deffn - - file-port? -@c snarfed from fports.c:230 -@deffn {Scheme Procedure} file-port? obj -@deffnx {C Function} scm_file_port_p (obj) -Determine whether @var{obj} is a port that is related to a file. -@end deffn - - open-file -@c snarfed from fports.c:284 -@deffn {Scheme Procedure} open-file filename mode -@deffnx {C Function} scm_open_file (filename, mode) -Open the file whose name is @var{filename}, and return a port -representing that file. The attributes of the port are -determined by the @var{mode} string. The way in which this is -interpreted is similar to C stdio. The first character must be -one of the following: -@table @samp -@item r -Open an existing file for input. -@item w -Open a file for output, creating it if it doesn't already exist -or removing its contents if it does. -@item a -Open a file for output, creating it if it doesn't already -exist. All writes to the port will go to the end of the file. -The "append mode" can be turned off while the port is in use -@pxref{Ports and File Descriptors, fcntl} -@end table -The following additional characters can be appended: -@table @samp -@item + -Open the port for both input and output. E.g., @code{r+}: open -an existing file for both input and output. -@item 0 -Create an "unbuffered" port. In this case input and output -operations are passed directly to the underlying port -implementation without additional buffering. This is likely to -slow down I/O operations. The buffering mode can be changed -while a port is in use @pxref{Ports and File Descriptors, -setvbuf} -@item l -Add line-buffering to the port. The port output buffer will be -automatically flushed whenever a newline character is written. -@end table -In theory we could create read/write ports which were buffered -in one direction only. However this isn't included in the -current interfaces. If a file cannot be opened with the access -requested, @code{open-file} throws an exception. -@end deffn - - gc-live-object-stats -@c snarfed from gc.c:276 -@deffn {Scheme Procedure} gc-live-object-stats -@deffnx {C Function} scm_gc_live_object_stats () -Return an alist of statistics of the current live objects. -@end deffn - - gc-stats -@c snarfed from gc.c:293 -@deffn {Scheme Procedure} gc-stats -@deffnx {C Function} scm_gc_stats () -Return an association list of statistics about Guile's current -use of storage. - -@end deffn - - object-address -@c snarfed from gc.c:429 -@deffn {Scheme Procedure} object-address obj -@deffnx {C Function} scm_object_address (obj) -Return an integer that for the lifetime of @var{obj} is uniquely -returned by this function for @var{obj} -@end deffn - - gc -@c snarfed from gc.c:440 -@deffn {Scheme Procedure} gc -@deffnx {C Function} scm_gc () -Scans all of SCM objects and reclaims for further use those that are -no longer accessible. -@end deffn - - class-of -@c snarfed from goops.c:166 -@deffn {Scheme Procedure} class-of x -@deffnx {C Function} scm_class_of (x) -Return the class of @var{x}. -@end deffn - - %compute-slots -@c snarfed from goops.c:407 -@deffn {Scheme Procedure} %compute-slots class -@deffnx {C Function} scm_sys_compute_slots (class) -Return a list consisting of the names of all slots belonging to -class @var{class}, i. e. the slots of @var{class} and of all of -its superclasses. -@end deffn - - get-keyword -@c snarfed from goops.c:498 -@deffn {Scheme Procedure} get-keyword key l default_value -@deffnx {C Function} scm_get_keyword (key, l, default_value) -Determine an associated value for the keyword @var{key} from -the list @var{l}. The list @var{l} has to consist of an even -number of elements, where, starting with the first, every -second element is a keyword, followed by its associated value. -If @var{l} does not hold a value for @var{key}, the value -@var{default_value} is returned. -@end deffn - - %initialize-object -@c snarfed from goops.c:521 -@deffn {Scheme Procedure} %initialize-object obj initargs -@deffnx {C Function} scm_sys_initialize_object (obj, initargs) -Initialize the object @var{obj} with the given arguments -@var{initargs}. -@end deffn - - %prep-layout! -@c snarfed from goops.c:619 -@deffn {Scheme Procedure} %prep-layout! class -@deffnx {C Function} scm_sys_prep_layout_x (class) - -@end deffn - - %inherit-magic! -@c snarfed from goops.c:718 -@deffn {Scheme Procedure} %inherit-magic! class dsupers -@deffnx {C Function} scm_sys_inherit_magic_x (class, dsupers) - -@end deffn - - instance? -@c snarfed from goops.c:958 -@deffn {Scheme Procedure} instance? obj -@deffnx {C Function} scm_instance_p (obj) -Return @code{#t} if @var{obj} is an instance. -@end deffn - - class-name -@c snarfed from goops.c:973 -@deffn {Scheme Procedure} class-name obj -@deffnx {C Function} scm_class_name (obj) -Return the class name of @var{obj}. -@end deffn - - class-direct-supers -@c snarfed from goops.c:983 -@deffn {Scheme Procedure} class-direct-supers obj -@deffnx {C Function} scm_class_direct_supers (obj) -Return the direct superclasses of the class @var{obj}. -@end deffn - - class-direct-slots -@c snarfed from goops.c:993 -@deffn {Scheme Procedure} class-direct-slots obj -@deffnx {C Function} scm_class_direct_slots (obj) -Return the direct slots of the class @var{obj}. -@end deffn - - class-direct-subclasses -@c snarfed from goops.c:1003 -@deffn {Scheme Procedure} class-direct-subclasses obj -@deffnx {C Function} scm_class_direct_subclasses (obj) -Return the direct subclasses of the class @var{obj}. -@end deffn - - class-direct-methods -@c snarfed from goops.c:1013 -@deffn {Scheme Procedure} class-direct-methods obj -@deffnx {C Function} scm_class_direct_methods (obj) -Return the direct methods of the class @var{obj} -@end deffn - - class-precedence-list -@c snarfed from goops.c:1023 -@deffn {Scheme Procedure} class-precedence-list obj -@deffnx {C Function} scm_class_precedence_list (obj) -Return the class precedence list of the class @var{obj}. -@end deffn - - class-slots -@c snarfed from goops.c:1033 -@deffn {Scheme Procedure} class-slots obj -@deffnx {C Function} scm_class_slots (obj) -Return the slot list of the class @var{obj}. -@end deffn - - class-environment -@c snarfed from goops.c:1043 -@deffn {Scheme Procedure} class-environment obj -@deffnx {C Function} scm_class_environment (obj) -Return the environment of the class @var{obj}. -@end deffn - - generic-function-name -@c snarfed from goops.c:1054 -@deffn {Scheme Procedure} generic-function-name obj -@deffnx {C Function} scm_generic_function_name (obj) -Return the name of the generic function @var{obj}. -@end deffn - - generic-function-methods -@c snarfed from goops.c:1099 -@deffn {Scheme Procedure} generic-function-methods obj -@deffnx {C Function} scm_generic_function_methods (obj) -Return the methods of the generic function @var{obj}. -@end deffn - - method-generic-function -@c snarfed from goops.c:1112 -@deffn {Scheme Procedure} method-generic-function obj -@deffnx {C Function} scm_method_generic_function (obj) -Return the generic function for the method @var{obj}. -@end deffn - - method-specializers -@c snarfed from goops.c:1122 -@deffn {Scheme Procedure} method-specializers obj -@deffnx {C Function} scm_method_specializers (obj) -Return specializers of the method @var{obj}. -@end deffn - - method-procedure -@c snarfed from goops.c:1132 -@deffn {Scheme Procedure} method-procedure obj -@deffnx {C Function} scm_method_procedure (obj) -Return the procedure of the method @var{obj}. -@end deffn - - accessor-method-slot-definition -@c snarfed from goops.c:1142 -@deffn {Scheme Procedure} accessor-method-slot-definition obj -@deffnx {C Function} scm_accessor_method_slot_definition (obj) -Return the slot definition of the accessor @var{obj}. -@end deffn - - %tag-body -@c snarfed from goops.c:1152 -@deffn {Scheme Procedure} %tag-body body -@deffnx {C Function} scm_sys_tag_body (body) -Internal GOOPS magic---don't use this function! -@end deffn - - make-unbound -@c snarfed from goops.c:1167 -@deffn {Scheme Procedure} make-unbound -@deffnx {C Function} scm_make_unbound () -Return the unbound value. -@end deffn - - unbound? -@c snarfed from goops.c:1176 -@deffn {Scheme Procedure} unbound? obj -@deffnx {C Function} scm_unbound_p (obj) -Return @code{#t} if @var{obj} is unbound. -@end deffn - - assert-bound -@c snarfed from goops.c:1186 -@deffn {Scheme Procedure} assert-bound value obj -@deffnx {C Function} scm_assert_bound (value, obj) -Return @var{value} if it is bound, and invoke the -@var{slot-unbound} method of @var{obj} if it is not. -@end deffn - - @@assert-bound-ref -@c snarfed from goops.c:1198 -@deffn {Scheme Procedure} @@assert-bound-ref obj index -@deffnx {C Function} scm_at_assert_bound_ref (obj, index) -Like @code{assert-bound}, but use @var{index} for accessing -the value from @var{obj}. -@end deffn - - %fast-slot-ref -@c snarfed from goops.c:1210 -@deffn {Scheme Procedure} %fast-slot-ref obj index -@deffnx {C Function} scm_sys_fast_slot_ref (obj, index) -Return the slot value with index @var{index} from @var{obj}. -@end deffn - - %fast-slot-set! -@c snarfed from goops.c:1224 -@deffn {Scheme Procedure} %fast-slot-set! obj index value -@deffnx {C Function} scm_sys_fast_slot_set_x (obj, index, value) -Set the slot with index @var{index} in @var{obj} to -@var{value}. -@end deffn - - slot-ref-using-class -@c snarfed from goops.c:1361 -@deffn {Scheme Procedure} slot-ref-using-class class obj slot_name -@deffnx {C Function} scm_slot_ref_using_class (class, obj, slot_name) - -@end deffn - - slot-set-using-class! -@c snarfed from goops.c:1380 -@deffn {Scheme Procedure} slot-set-using-class! class obj slot_name value -@deffnx {C Function} scm_slot_set_using_class_x (class, obj, slot_name, value) - -@end deffn - - slot-bound-using-class? -@c snarfed from goops.c:1394 -@deffn {Scheme Procedure} slot-bound-using-class? class obj slot_name -@deffnx {C Function} scm_slot_bound_using_class_p (class, obj, slot_name) - -@end deffn - - slot-exists-using-class? -@c snarfed from goops.c:1409 -@deffn {Scheme Procedure} slot-exists-using-class? class obj slot_name -@deffnx {C Function} scm_slot_exists_using_class_p (class, obj, slot_name) - -@end deffn - - slot-ref -@c snarfed from goops.c:1425 -@deffn {Scheme Procedure} slot-ref obj slot_name -@deffnx {C Function} scm_slot_ref (obj, slot_name) -Return the value from @var{obj}'s slot with the name -@var{slot_name}. -@end deffn - - slot-set! -@c snarfed from goops.c:1442 -@deffn {Scheme Procedure} slot-set! obj slot_name value -@deffnx {C Function} scm_slot_set_x (obj, slot_name, value) -Set the slot named @var{slot_name} of @var{obj} to @var{value}. -@end deffn - - slot-bound? -@c snarfed from goops.c:1459 -@deffn {Scheme Procedure} slot-bound? obj slot_name -@deffnx {C Function} scm_slot_bound_p (obj, slot_name) -Return @code{#t} if the slot named @var{slot_name} of @var{obj} -is bound. -@end deffn - - slot-exists? -@c snarfed from goops.c:1477 -@deffn {Scheme Procedure} slot-exists? obj slot_name -@deffnx {C Function} scm_slot_exists_p (obj, slot_name) -Return @code{#t} if @var{obj} has a slot named @var{slot_name}. -@end deffn - - %allocate-instance -@c snarfed from goops.c:1516 -@deffn {Scheme Procedure} %allocate-instance class initargs -@deffnx {C Function} scm_sys_allocate_instance (class, initargs) -Create a new instance of class @var{class} and initialize it -from the arguments @var{initargs}. -@end deffn - - %set-object-setter! -@c snarfed from goops.c:1586 -@deffn {Scheme Procedure} %set-object-setter! obj setter -@deffnx {C Function} scm_sys_set_object_setter_x (obj, setter) - -@end deffn - - %modify-instance -@c snarfed from goops.c:1611 -@deffn {Scheme Procedure} %modify-instance old new -@deffnx {C Function} scm_sys_modify_instance (old, new) - -@end deffn - - %modify-class -@c snarfed from goops.c:1637 -@deffn {Scheme Procedure} %modify-class old new -@deffnx {C Function} scm_sys_modify_class (old, new) - -@end deffn - - %invalidate-class -@c snarfed from goops.c:1661 -@deffn {Scheme Procedure} %invalidate-class class -@deffnx {C Function} scm_sys_invalidate_class (class) - -@end deffn - - %invalidate-method-cache! -@c snarfed from goops.c:1783 -@deffn {Scheme Procedure} %invalidate-method-cache! gf -@deffnx {C Function} scm_sys_invalidate_method_cache_x (gf) - -@end deffn - - generic-capability? -@c snarfed from goops.c:1809 -@deffn {Scheme Procedure} generic-capability? proc -@deffnx {C Function} scm_generic_capability_p (proc) - -@end deffn - - enable-primitive-generic! -@c snarfed from goops.c:1822 -@deffn {Scheme Procedure} enable-primitive-generic! . subrs -@deffnx {C Function} scm_enable_primitive_generic_x (subrs) - -@end deffn - - primitive-generic-generic -@c snarfed from goops.c:1843 -@deffn {Scheme Procedure} primitive-generic-generic subr -@deffnx {C Function} scm_primitive_generic_generic (subr) - -@end deffn - - make -@c snarfed from goops.c:2209 -@deffn {Scheme Procedure} make . args -@deffnx {C Function} scm_make (args) -Make a new object. @var{args} must contain the class and -all necessary initialization information. -@end deffn - - find-method -@c snarfed from goops.c:2298 -@deffn {Scheme Procedure} find-method . l -@deffnx {C Function} scm_find_method (l) - -@end deffn - - %method-more-specific? -@c snarfed from goops.c:2318 -@deffn {Scheme Procedure} %method-more-specific? m1 m2 targs -@deffnx {C Function} scm_sys_method_more_specific_p (m1, m2, targs) -Return true if method @var{m1} is more specific than @var{m2} given the argument types (classes) listed in @var{targs}. -@end deffn - - %goops-loaded -@c snarfed from goops.c:2944 -@deffn {Scheme Procedure} %goops-loaded -@deffnx {C Function} scm_sys_goops_loaded () -Announce that GOOPS is loaded and perform initialization -on the C level which depends on the loaded GOOPS modules. -@end deffn - - make-guardian -@c snarfed from guardians.c:307 -@deffn {Scheme Procedure} make-guardian [greedy_p] -@deffnx {C Function} scm_make_guardian (greedy_p) -Create a new guardian. -A guardian protects a set of objects from garbage collection, -allowing a program to apply cleanup or other actions. - -@code{make-guardian} returns a procedure representing the guardian. -Calling the guardian procedure with an argument adds the -argument to the guardian's set of protected objects. -Calling the guardian procedure without an argument returns -one of the protected objects which are ready for garbage -collection, or @code{#f} if no such object is available. -Objects which are returned in this way are removed from -the guardian. - -@code{make-guardian} takes one optional argument that says whether the -new guardian should be greedy or sharing. If there is any chance -that any object protected by the guardian may be resurrected, -then you should make the guardian greedy (this is the default). - -See R. Kent Dybvig, Carl Bruggeman, and David Eby (1993) -"Guardians in a Generation-Based Garbage Collector". -ACM SIGPLAN Conference on Programming Language Design -and Implementation, June 1993. - -(the semantics are slightly different at this point, but the -paper still (mostly) accurately describes the interface). -@end deffn - - guardian-destroyed? -@c snarfed from guardians.c:335 -@deffn {Scheme Procedure} guardian-destroyed? guardian -@deffnx {C Function} scm_guardian_destroyed_p (guardian) -Return @code{#t} if @var{guardian} has been destroyed, otherwise @code{#f}. -@end deffn - - guardian-greedy? -@c snarfed from guardians.c:353 -@deffn {Scheme Procedure} guardian-greedy? guardian -@deffnx {C Function} scm_guardian_greedy_p (guardian) -Return @code{#t} if @var{guardian} is a greedy guardian, otherwise @code{#f}. -@end deffn - - destroy-guardian! -@c snarfed from guardians.c:364 -@deffn {Scheme Procedure} destroy-guardian! guardian -@deffnx {C Function} scm_destroy_guardian_x (guardian) -Destroys @var{guardian}, by making it impossible to put any more -objects in it or get any objects from it. It also unguards any -objects guarded by @var{guardian}. -@end deffn - - hashq -@c snarfed from hash.c:183 -@deffn {Scheme Procedure} hashq key size -@deffnx {C Function} scm_hashq (key, size) -Determine a hash value for @var{key} that is suitable for -lookups in a hashtable of size @var{size}, where @code{eq?} is -used as the equality predicate. The function returns an -integer in the range 0 to @var{size} - 1. Note that -@code{hashq} may use internal addresses. Thus two calls to -hashq where the keys are @code{eq?} are not guaranteed to -deliver the same value if the key object gets garbage collected -in between. This can happen, for example with symbols: -@code{(hashq 'foo n) (gc) (hashq 'foo n)} may produce two -different values, since @code{foo} will be garbage collected. -@end deffn - - hashv -@c snarfed from hash.c:219 -@deffn {Scheme Procedure} hashv key size -@deffnx {C Function} scm_hashv (key, size) -Determine a hash value for @var{key} that is suitable for -lookups in a hashtable of size @var{size}, where @code{eqv?} is -used as the equality predicate. The function returns an -integer in the range 0 to @var{size} - 1. Note that -@code{(hashv key)} may use internal addresses. Thus two calls -to hashv where the keys are @code{eqv?} are not guaranteed to -deliver the same value if the key object gets garbage collected -in between. This can happen, for example with symbols: -@code{(hashv 'foo n) (gc) (hashv 'foo n)} may produce two -different values, since @code{foo} will be garbage collected. -@end deffn - - hash -@c snarfed from hash.c:242 -@deffn {Scheme Procedure} hash key size -@deffnx {C Function} scm_hash (key, size) -Determine a hash value for @var{key} that is suitable for -lookups in a hashtable of size @var{size}, where @code{equal?} -is used as the equality predicate. The function returns an -integer in the range 0 to @var{size} - 1. -@end deffn - - make-hash-table -@c snarfed from hashtab.c:332 -@deffn {Scheme Procedure} make-hash-table [n] -@deffnx {C Function} scm_make_hash_table (n) -Make a new abstract hash table object with minimum number of buckets @var{n} - -@end deffn - - make-weak-key-hash-table -@c snarfed from hashtab.c:349 -@deffn {Scheme Procedure} make-weak-key-hash-table [n] -@deffnx {Scheme Procedure} make-weak-value-hash-table size -@deffnx {Scheme Procedure} make-doubly-weak-hash-table size -@deffnx {C Function} scm_make_weak_key_hash_table (n) -Return a weak hash table with @var{size} buckets. - -You can modify weak hash tables in exactly the same way you -would modify regular hash tables. (@pxref{Hash Tables}) -@end deffn - - make-weak-value-hash-table -@c snarfed from hashtab.c:364 -@deffn {Scheme Procedure} make-weak-value-hash-table [n] -@deffnx {C Function} scm_make_weak_value_hash_table (n) -Return a hash table with weak values with @var{size} buckets. -(@pxref{Hash Tables}) -@end deffn - - make-doubly-weak-hash-table -@c snarfed from hashtab.c:381 -@deffn {Scheme Procedure} make-doubly-weak-hash-table n -@deffnx {C Function} scm_make_doubly_weak_hash_table (n) -Return a hash table with weak keys and values with @var{size} -buckets. (@pxref{Hash Tables}) -@end deffn - - hash-table? -@c snarfed from hashtab.c:400 -@deffn {Scheme Procedure} hash-table? obj -@deffnx {C Function} scm_hash_table_p (obj) -Return @code{#t} if @var{obj} is an abstract hash table object. -@end deffn - - weak-key-hash-table? -@c snarfed from hashtab.c:414 -@deffn {Scheme Procedure} weak-key-hash-table? obj -@deffnx {Scheme Procedure} weak-value-hash-table? obj -@deffnx {Scheme Procedure} doubly-weak-hash-table? obj -@deffnx {C Function} scm_weak_key_hash_table_p (obj) -Return @code{#t} if @var{obj} is the specified weak hash -table. Note that a doubly weak hash table is neither a weak key -nor a weak value hash table. -@end deffn - - weak-value-hash-table? -@c snarfed from hashtab.c:424 -@deffn {Scheme Procedure} weak-value-hash-table? obj -@deffnx {C Function} scm_weak_value_hash_table_p (obj) -Return @code{#t} if @var{obj} is a weak value hash table. -@end deffn - - doubly-weak-hash-table? -@c snarfed from hashtab.c:434 -@deffn {Scheme Procedure} doubly-weak-hash-table? obj -@deffnx {C Function} scm_doubly_weak_hash_table_p (obj) -Return @code{#t} if @var{obj} is a doubly weak hash table. -@end deffn - - hash-clear! -@c snarfed from hashtab.c:586 -@deffn {Scheme Procedure} hash-clear! table -@deffnx {C Function} scm_hash_clear_x (table) -Remove all items from @var{table} (without triggering a resize). -@end deffn - - hashq-get-handle -@c snarfed from hashtab.c:607 -@deffn {Scheme Procedure} hashq-get-handle table key -@deffnx {C Function} scm_hashq_get_handle (table, key) -This procedure returns the @code{(key . value)} pair from the -hash table @var{table}. If @var{table} does not hold an -associated value for @var{key}, @code{#f} is returned. -Uses @code{eq?} for equality testing. -@end deffn - - hashq-create-handle! -@c snarfed from hashtab.c:619 -@deffn {Scheme Procedure} hashq-create-handle! table key init -@deffnx {C Function} scm_hashq_create_handle_x (table, key, init) -This function looks up @var{key} in @var{table} and returns its handle. -If @var{key} is not already present, a new handle is created which -associates @var{key} with @var{init}. -@end deffn - - hashq-ref -@c snarfed from hashtab.c:632 -@deffn {Scheme Procedure} hashq-ref table key [dflt] -@deffnx {C Function} scm_hashq_ref (table, key, dflt) -Look up @var{key} in the hash table @var{table}, and return the -value (if any) associated with it. If @var{key} is not found, -return @var{default} (or @code{#f} if no @var{default} argument -is supplied). Uses @code{eq?} for equality testing. -@end deffn - - hashq-set! -@c snarfed from hashtab.c:646 -@deffn {Scheme Procedure} hashq-set! table key val -@deffnx {C Function} scm_hashq_set_x (table, key, val) -Find the entry in @var{table} associated with @var{key}, and -store @var{value} there. Uses @code{eq?} for equality testing. -@end deffn - - hashq-remove! -@c snarfed from hashtab.c:658 -@deffn {Scheme Procedure} hashq-remove! table key -@deffnx {C Function} scm_hashq_remove_x (table, key) -Remove @var{key} (and any value associated with it) from -@var{table}. Uses @code{eq?} for equality tests. -@end deffn - - hashv-get-handle -@c snarfed from hashtab.c:673 -@deffn {Scheme Procedure} hashv-get-handle table key -@deffnx {C Function} scm_hashv_get_handle (table, key) -This procedure returns the @code{(key . value)} pair from the -hash table @var{table}. If @var{table} does not hold an -associated value for @var{key}, @code{#f} is returned. -Uses @code{eqv?} for equality testing. -@end deffn - - hashv-create-handle! -@c snarfed from hashtab.c:685 -@deffn {Scheme Procedure} hashv-create-handle! table key init -@deffnx {C Function} scm_hashv_create_handle_x (table, key, init) -This function looks up @var{key} in @var{table} and returns its handle. -If @var{key} is not already present, a new handle is created which -associates @var{key} with @var{init}. -@end deffn - - hashv-ref -@c snarfed from hashtab.c:699 -@deffn {Scheme Procedure} hashv-ref table key [dflt] -@deffnx {C Function} scm_hashv_ref (table, key, dflt) -Look up @var{key} in the hash table @var{table}, and return the -value (if any) associated with it. If @var{key} is not found, -return @var{default} (or @code{#f} if no @var{default} argument -is supplied). Uses @code{eqv?} for equality testing. -@end deffn - - hashv-set! -@c snarfed from hashtab.c:713 -@deffn {Scheme Procedure} hashv-set! table key val -@deffnx {C Function} scm_hashv_set_x (table, key, val) -Find the entry in @var{table} associated with @var{key}, and -store @var{value} there. Uses @code{eqv?} for equality testing. -@end deffn - - hashv-remove! -@c snarfed from hashtab.c:724 -@deffn {Scheme Procedure} hashv-remove! table key -@deffnx {C Function} scm_hashv_remove_x (table, key) -Remove @var{key} (and any value associated with it) from -@var{table}. Uses @code{eqv?} for equality tests. -@end deffn - - hash-get-handle -@c snarfed from hashtab.c:738 -@deffn {Scheme Procedure} hash-get-handle table key -@deffnx {C Function} scm_hash_get_handle (table, key) -This procedure returns the @code{(key . value)} pair from the -hash table @var{table}. If @var{table} does not hold an -associated value for @var{key}, @code{#f} is returned. -Uses @code{equal?} for equality testing. -@end deffn - - hash-create-handle! -@c snarfed from hashtab.c:750 -@deffn {Scheme Procedure} hash-create-handle! table key init -@deffnx {C Function} scm_hash_create_handle_x (table, key, init) -This function looks up @var{key} in @var{table} and returns its handle. -If @var{key} is not already present, a new handle is created which -associates @var{key} with @var{init}. -@end deffn - - hash-ref -@c snarfed from hashtab.c:763 -@deffn {Scheme Procedure} hash-ref table key [dflt] -@deffnx {C Function} scm_hash_ref (table, key, dflt) -Look up @var{key} in the hash table @var{table}, and return the -value (if any) associated with it. If @var{key} is not found, -return @var{default} (or @code{#f} if no @var{default} argument -is supplied). Uses @code{equal?} for equality testing. -@end deffn - - hash-set! -@c snarfed from hashtab.c:778 -@deffn {Scheme Procedure} hash-set! table key val -@deffnx {C Function} scm_hash_set_x (table, key, val) -Find the entry in @var{table} associated with @var{key}, and -store @var{value} there. Uses @code{equal?} for equality -testing. -@end deffn - - hash-remove! -@c snarfed from hashtab.c:790 -@deffn {Scheme Procedure} hash-remove! table key -@deffnx {C Function} scm_hash_remove_x (table, key) -Remove @var{key} (and any value associated with it) from -@var{table}. Uses @code{equal?} for equality tests. -@end deffn - - hashx-get-handle -@c snarfed from hashtab.c:831 -@deffn {Scheme Procedure} hashx-get-handle hash assoc table key -@deffnx {C Function} scm_hashx_get_handle (hash, assoc, table, key) -This behaves the same way as the corresponding -@code{-get-handle} function, but uses @var{hash} as a hash -function and @var{assoc} to compare keys. @code{hash} must be -a function that takes two arguments, a key to be hashed and a -table size. @code{assoc} must be an associator function, like -@code{assoc}, @code{assq} or @code{assv}. -@end deffn - - hashx-create-handle! -@c snarfed from hashtab.c:850 -@deffn {Scheme Procedure} hashx-create-handle! hash assoc table key init -@deffnx {C Function} scm_hashx_create_handle_x (hash, assoc, table, key, init) -This behaves the same way as the corresponding -@code{-create-handle} function, but uses @var{hash} as a hash -function and @var{assoc} to compare keys. @code{hash} must be -a function that takes two arguments, a key to be hashed and a -table size. @code{assoc} must be an associator function, like -@code{assoc}, @code{assq} or @code{assv}. -@end deffn - - hashx-ref -@c snarfed from hashtab.c:873 -@deffn {Scheme Procedure} hashx-ref hash assoc table key [dflt] -@deffnx {C Function} scm_hashx_ref (hash, assoc, table, key, dflt) -This behaves the same way as the corresponding @code{ref} -function, but uses @var{hash} as a hash function and -@var{assoc} to compare keys. @code{hash} must be a function -that takes two arguments, a key to be hashed and a table size. -@code{assoc} must be an associator function, like @code{assoc}, -@code{assq} or @code{assv}. - -By way of illustration, @code{hashq-ref table key} is -equivalent to @code{hashx-ref hashq assq table key}. -@end deffn - - hashx-set! -@c snarfed from hashtab.c:899 -@deffn {Scheme Procedure} hashx-set! hash assoc table key val -@deffnx {C Function} scm_hashx_set_x (hash, assoc, table, key, val) -This behaves the same way as the corresponding @code{set!} -function, but uses @var{hash} as a hash function and -@var{assoc} to compare keys. @code{hash} must be a function -that takes two arguments, a key to be hashed and a table size. -@code{assoc} must be an associator function, like @code{assoc}, -@code{assq} or @code{assv}. - - By way of illustration, @code{hashq-set! table key} is -equivalent to @code{hashx-set! hashq assq table key}. -@end deffn - - hashx-remove! -@c snarfed from hashtab.c:920 -@deffn {Scheme Procedure} hashx-remove! hash assoc table obj -@deffnx {C Function} scm_hashx_remove_x (hash, assoc, table, obj) -This behaves the same way as the corresponding @code{remove!} -function, but uses @var{hash} as a hash function and -@var{assoc} to compare keys. @code{hash} must be a function -that takes two arguments, a key to be hashed and a table size. -@code{assoc} must be an associator function, like @code{assoc}, -@code{assq} or @code{assv}. - - By way of illustration, @code{hashq-remove! table key} is -equivalent to @code{hashx-remove! hashq assq #f table key}. -@end deffn - - hash-fold -@c snarfed from hashtab.c:1009 -@deffn {Scheme Procedure} hash-fold proc init table -@deffnx {C Function} scm_hash_fold (proc, init, table) -An iterator over hash-table elements. -Accumulates and returns a result by applying PROC successively. -The arguments to PROC are "(key value prior-result)" where key -and value are successive pairs from the hash table TABLE, and -prior-result is either INIT (for the first application of PROC) -or the return value of the previous application of PROC. -For example, @code{(hash-fold acons '() tab)} will convert a hash -table into an a-list of key-value pairs. -@end deffn - - hash-for-each -@c snarfed from hashtab.c:1030 -@deffn {Scheme Procedure} hash-for-each proc table -@deffnx {C Function} scm_hash_for_each (proc, table) -An iterator over hash-table elements. -Applies PROC successively on all hash table items. -The arguments to PROC are "(key value)" where key -and value are successive pairs from the hash table TABLE. -@end deffn - - hash-for-each-handle -@c snarfed from hashtab.c:1047 -@deffn {Scheme Procedure} hash-for-each-handle proc table -@deffnx {C Function} scm_hash_for_each_handle (proc, table) -An iterator over hash-table elements. -Applies PROC successively on all hash table handles. -@end deffn - - hash-map->list -@c snarfed from hashtab.c:1073 -@deffn {Scheme Procedure} hash-map->list proc table -@deffnx {C Function} scm_hash_map_to_list (proc, table) -An iterator over hash-table elements. -Accumulates and returns as a list the results of applying PROC successively. -The arguments to PROC are "(key value)" where key -and value are successive pairs from the hash table TABLE. -@end deffn - - make-hook -@c snarfed from hooks.c:154 -@deffn {Scheme Procedure} make-hook [n_args] -@deffnx {C Function} scm_make_hook (n_args) -Create a hook for storing procedure of arity @var{n_args}. -@var{n_args} defaults to zero. The returned value is a hook -object to be used with the other hook procedures. -@end deffn - - hook? -@c snarfed from hooks.c:171 -@deffn {Scheme Procedure} hook? x -@deffnx {C Function} scm_hook_p (x) -Return @code{#t} if @var{x} is a hook, @code{#f} otherwise. -@end deffn - - hook-empty? -@c snarfed from hooks.c:182 -@deffn {Scheme Procedure} hook-empty? hook -@deffnx {C Function} scm_hook_empty_p (hook) -Return @code{#t} if @var{hook} is an empty hook, @code{#f} -otherwise. -@end deffn - - add-hook! -@c snarfed from hooks.c:196 -@deffn {Scheme Procedure} add-hook! hook proc [append_p] -@deffnx {C Function} scm_add_hook_x (hook, proc, append_p) -Add the procedure @var{proc} to the hook @var{hook}. The -procedure is added to the end if @var{append_p} is true, -otherwise it is added to the front. The return value of this -procedure is not specified. -@end deffn - - remove-hook! -@c snarfed from hooks.c:223 -@deffn {Scheme Procedure} remove-hook! hook proc -@deffnx {C Function} scm_remove_hook_x (hook, proc) -Remove the procedure @var{proc} from the hook @var{hook}. The -return value of this procedure is not specified. -@end deffn - - reset-hook! -@c snarfed from hooks.c:237 -@deffn {Scheme Procedure} reset-hook! hook -@deffnx {C Function} scm_reset_hook_x (hook) -Remove all procedures from the hook @var{hook}. The return -value of this procedure is not specified. -@end deffn - - run-hook -@c snarfed from hooks.c:251 -@deffn {Scheme Procedure} run-hook hook . args -@deffnx {C Function} scm_run_hook (hook, args) -Apply all procedures from the hook @var{hook} to the arguments -@var{args}. The order of the procedure application is first to -last. The return value of this procedure is not specified. -@end deffn - - hook->list -@c snarfed from hooks.c:278 -@deffn {Scheme Procedure} hook->list hook -@deffnx {C Function} scm_hook_to_list (hook) -Convert the procedure list of @var{hook} to a list. -@end deffn - - gettext -@c snarfed from i18n.c:90 -@deffn {Scheme Procedure} gettext msgid [domain [category]] -@deffnx {C Function} scm_gettext (msgid, domain, category) -Return the translation of @var{msgid} in the message domain @var{domain}. @var{domain} is optional and defaults to the domain set through (textdomain). @var{category} is optional and defaults to LC_MESSAGES. -@end deffn - - ngettext -@c snarfed from i18n.c:146 -@deffn {Scheme Procedure} ngettext msgid msgid_plural n [domain [category]] -@deffnx {C Function} scm_ngettext (msgid, msgid_plural, n, domain, category) -Return the translation of @var{msgid}/@var{msgid_plural} in the message domain @var{domain}, with the plural form being chosen appropriately for the number @var{n}. @var{domain} is optional and defaults to the domain set through (textdomain). @var{category} is optional and defaults to LC_MESSAGES. -@end deffn - - textdomain -@c snarfed from i18n.c:209 -@deffn {Scheme Procedure} textdomain [domainname] -@deffnx {C Function} scm_textdomain (domainname) -If optional parameter @var{domainname} is supplied, set the textdomain. Return the textdomain. -@end deffn - - bindtextdomain -@c snarfed from i18n.c:241 -@deffn {Scheme Procedure} bindtextdomain domainname [directory] -@deffnx {C Function} scm_bindtextdomain (domainname, directory) -If optional parameter @var{directory} is supplied, set message catalogs to directory @var{directory}. Return the directory bound to @var{domainname}. -@end deffn - - bind-textdomain-codeset -@c snarfed from i18n.c:280 -@deffn {Scheme Procedure} bind-textdomain-codeset domainname [encoding] -@deffnx {C Function} scm_bind_textdomain_codeset (domainname, encoding) -If optional parameter @var{encoding} is supplied, set encoding for message catalogs of @var{domainname}. Return the encoding of @var{domainname}. -@end deffn - - ftell -@c snarfed from ioext.c:54 -@deffn {Scheme Procedure} ftell fd_port -@deffnx {C Function} scm_ftell (fd_port) -Return an integer representing the current position of -@var{fd/port}, measured from the beginning. Equivalent to: - -@lisp -(seek port 0 SEEK_CUR) -@end lisp -@end deffn - - redirect-port -@c snarfed from ioext.c:72 -@deffn {Scheme Procedure} redirect-port old new -@deffnx {C Function} scm_redirect_port (old, new) -This procedure takes two ports and duplicates the underlying file -descriptor from @var{old-port} into @var{new-port}. The -current file descriptor in @var{new-port} will be closed. -After the redirection the two ports will share a file position -and file status flags. - -The return value is unspecified. - -Unexpected behaviour can result if both ports are subsequently used -and the original and/or duplicate ports are buffered. - -This procedure does not have any side effects on other ports or -revealed counts. -@end deffn - - dup->fdes -@c snarfed from ioext.c:111 -@deffn {Scheme Procedure} dup->fdes fd_or_port [fd] -@deffnx {C Function} scm_dup_to_fdes (fd_or_port, fd) -Return a new integer file descriptor referring to the open file -designated by @var{fd_or_port}, which must be either an open -file port or a file descriptor. -@end deffn - - dup2 -@c snarfed from ioext.c:158 -@deffn {Scheme Procedure} dup2 oldfd newfd -@deffnx {C Function} scm_dup2 (oldfd, newfd) -A simple wrapper for the @code{dup2} system call. -Copies the file descriptor @var{oldfd} to descriptor -number @var{newfd}, replacing the previous meaning -of @var{newfd}. Both @var{oldfd} and @var{newfd} must -be integers. -Unlike for dup->fdes or primitive-move->fdes, no attempt -is made to move away ports which are using @var{newfd}. -The return value is unspecified. -@end deffn - - fileno -@c snarfed from ioext.c:177 -@deffn {Scheme Procedure} fileno port -@deffnx {C Function} scm_fileno (port) -Return the integer file descriptor underlying @var{port}. Does -not change its revealed count. -@end deffn - - isatty? -@c snarfed from ioext.c:197 -@deffn {Scheme Procedure} isatty? port -@deffnx {C Function} scm_isatty_p (port) -Return @code{#t} if @var{port} is using a serial non--file -device, otherwise @code{#f}. -@end deffn - - fdopen -@c snarfed from ioext.c:219 -@deffn {Scheme Procedure} fdopen fdes modes -@deffnx {C Function} scm_fdopen (fdes, modes) -Return a new port based on the file descriptor @var{fdes}. -Modes are given by the string @var{modes}. The revealed count -of the port is initialized to zero. The modes string is the -same as that accepted by @ref{File Ports, open-file}. -@end deffn - - primitive-move->fdes -@c snarfed from ioext.c:241 -@deffn {Scheme Procedure} primitive-move->fdes port fd -@deffnx {C Function} scm_primitive_move_to_fdes (port, fd) -Moves the underlying file descriptor for @var{port} to the integer -value @var{fdes} without changing the revealed count of @var{port}. -Any other ports already using this descriptor will be automatically -shifted to new descriptors and their revealed counts reset to zero. -The return value is @code{#f} if the file descriptor already had the -required value or @code{#t} if it was moved. -@end deffn - - fdes->ports -@c snarfed from ioext.c:274 -@deffn {Scheme Procedure} fdes->ports fd -@deffnx {C Function} scm_fdes_to_ports (fd) -Return a list of existing ports which have @var{fdes} as an -underlying file descriptor, without changing their revealed -counts. -@end deffn - - keyword? -@c snarfed from keywords.c:52 -@deffn {Scheme Procedure} keyword? obj -@deffnx {C Function} scm_keyword_p (obj) -Return @code{#t} if the argument @var{obj} is a keyword, else -@code{#f}. -@end deffn - - symbol->keyword -@c snarfed from keywords.c:61 -@deffn {Scheme Procedure} symbol->keyword symbol -@deffnx {C Function} scm_symbol_to_keyword (symbol) -Return the keyword with the same name as @var{symbol}. -@end deffn - - keyword->symbol -@c snarfed from keywords.c:82 -@deffn {Scheme Procedure} keyword->symbol keyword -@deffnx {C Function} scm_keyword_to_symbol (keyword) -Return the symbol with the same name as @var{keyword}. -@end deffn - - list -@c snarfed from list.c:104 -@deffn {Scheme Procedure} list . objs -@deffnx {C Function} scm_list (objs) -Return a list containing @var{objs}, the arguments to -@code{list}. -@end deffn - - cons* -@c snarfed from list.c:119 -@deffn {Scheme Procedure} cons* arg . rest -@deffnx {C Function} scm_cons_star (arg, rest) -Like @code{list}, but the last arg provides the tail of the -constructed list, returning @code{(cons @var{arg1} (cons -@var{arg2} (cons @dots{} @var{argn})))}. Requires at least one -argument. If given one argument, that argument is returned as -result. This function is called @code{list*} in some other -Schemes and in Common LISP. -@end deffn - - null? -@c snarfed from list.c:143 -@deffn {Scheme Procedure} null? x -@deffnx {C Function} scm_null_p (x) -Return @code{#t} iff @var{x} is the empty list, else @code{#f}. -@end deffn - - list? -@c snarfed from list.c:153 -@deffn {Scheme Procedure} list? x -@deffnx {C Function} scm_list_p (x) -Return @code{#t} iff @var{x} is a proper list, else @code{#f}. -@end deffn - - length -@c snarfed from list.c:194 -@deffn {Scheme Procedure} length lst -@deffnx {C Function} scm_length (lst) -Return the number of elements in list @var{lst}. -@end deffn - - append -@c snarfed from list.c:223 -@deffn {Scheme Procedure} append . args -@deffnx {C Function} scm_append (args) -Return a list consisting of the elements the lists passed as -arguments. -@lisp -(append '(x) '(y)) @result{} (x y) -(append '(a) '(b c d)) @result{} (a b c d) -(append '(a (b)) '((c))) @result{} (a (b) (c)) -@end lisp -The resulting list is always newly allocated, except that it -shares structure with the last list argument. The last -argument may actually be any object; an improper list results -if the last argument is not a proper list. -@lisp -(append '(a b) '(c . d)) @result{} (a b c . d) -(append '() 'a) @result{} a -@end lisp -@end deffn - - append! -@c snarfed from list.c:259 -@deffn {Scheme Procedure} append! . lists -@deffnx {C Function} scm_append_x (lists) -A destructive version of @code{append} (@pxref{Pairs and -Lists,,,r5rs, The Revised^5 Report on Scheme}). The cdr field -of each list's final pair is changed to point to the head of -the next list, so no consing is performed. Return -the mutated list. -@end deffn - - last-pair -@c snarfed from list.c:291 -@deffn {Scheme Procedure} last-pair lst -@deffnx {C Function} scm_last_pair (lst) -Return the last pair in @var{lst}, signalling an error if -@var{lst} is circular. -@end deffn - - reverse -@c snarfed from list.c:321 -@deffn {Scheme Procedure} reverse lst -@deffnx {C Function} scm_reverse (lst) -Return a new list that contains the elements of @var{lst} but -in reverse order. -@end deffn - - reverse! -@c snarfed from list.c:355 -@deffn {Scheme Procedure} reverse! lst [new_tail] -@deffnx {C Function} scm_reverse_x (lst, new_tail) -A destructive version of @code{reverse} (@pxref{Pairs and Lists,,,r5rs, -The Revised^5 Report on Scheme}). The cdr of each cell in @var{lst} is -modified to point to the previous list element. Return the -reversed list. - -Caveat: because the list is modified in place, the tail of the original -list now becomes its head, and the head of the original list now becomes -the tail. Therefore, the @var{lst} symbol to which the head of the -original list was bound now points to the tail. To ensure that the head -of the modified list is not lost, it is wise to save the return value of -@code{reverse!} -@end deffn - - list-ref -@c snarfed from list.c:381 -@deffn {Scheme Procedure} list-ref list k -@deffnx {C Function} scm_list_ref (list, k) -Return the @var{k}th element from @var{list}. -@end deffn - - list-set! -@c snarfed from list.c:405 -@deffn {Scheme Procedure} list-set! list k val -@deffnx {C Function} scm_list_set_x (list, k, val) -Set the @var{k}th element of @var{list} to @var{val}. -@end deffn - - list-cdr-ref -@c snarfed from list.c:427 -@deffn {Scheme Procedure} list-cdr-ref -implemented by the C function "scm_list_tail" -@end deffn - - list-tail -@c snarfed from list.c:436 -@deffn {Scheme Procedure} list-tail lst k -@deffnx {Scheme Procedure} list-cdr-ref lst k -@deffnx {C Function} scm_list_tail (lst, k) -Return the "tail" of @var{lst} beginning with its @var{k}th element. -The first element of the list is considered to be element 0. - -@code{list-tail} and @code{list-cdr-ref} are identical. It may help to -think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list, -or returning the results of cdring @var{k} times down @var{lst}. -@end deffn - - list-cdr-set! -@c snarfed from list.c:451 -@deffn {Scheme Procedure} list-cdr-set! list k val -@deffnx {C Function} scm_list_cdr_set_x (list, k, val) -Set the @var{k}th cdr of @var{list} to @var{val}. -@end deffn - - list-head -@c snarfed from list.c:479 -@deffn {Scheme Procedure} list-head lst k -@deffnx {C Function} scm_list_head (lst, k) -Copy the first @var{k} elements from @var{lst} into a new list, and -return it. -@end deffn - - list-copy -@c snarfed from list.c:530 -@deffn {Scheme Procedure} list-copy lst -@deffnx {C Function} scm_list_copy (lst) -Return a (newly-created) copy of @var{lst}. -@end deffn - - memq -@c snarfed from list.c:584 -@deffn {Scheme Procedure} memq x lst -@deffnx {C Function} scm_memq (x, lst) -Return the first sublist of @var{lst} whose car is @code{eq?} -to @var{x} where the sublists of @var{lst} are the non-empty -lists returned by @code{(list-tail @var{lst} @var{k})} for -@var{k} less than the length of @var{lst}. If @var{x} does not -occur in @var{lst}, then @code{#f} (not the empty list) is -returned. -@end deffn - - memv -@c snarfed from list.c:600 -@deffn {Scheme Procedure} memv x lst -@deffnx {C Function} scm_memv (x, lst) -Return the first sublist of @var{lst} whose car is @code{eqv?} -to @var{x} where the sublists of @var{lst} are the non-empty -lists returned by @code{(list-tail @var{lst} @var{k})} for -@var{k} less than the length of @var{lst}. If @var{x} does not -occur in @var{lst}, then @code{#f} (not the empty list) is -returned. -@end deffn - - member -@c snarfed from list.c:621 -@deffn {Scheme Procedure} member x lst -@deffnx {C Function} scm_member (x, lst) -Return the first sublist of @var{lst} whose car is -@code{equal?} to @var{x} where the sublists of @var{lst} are -the non-empty lists returned by @code{(list-tail @var{lst} -@var{k})} for @var{k} less than the length of @var{lst}. If -@var{x} does not occur in @var{lst}, then @code{#f} (not the -empty list) is returned. -@end deffn - - delq! -@c snarfed from list.c:646 -@deffn {Scheme Procedure} delq! item lst -@deffnx {Scheme Procedure} delv! item lst -@deffnx {Scheme Procedure} delete! item lst -@deffnx {C Function} scm_delq_x (item, lst) -These procedures are destructive versions of @code{delq}, @code{delv} -and @code{delete}: they modify the existing @var{lst} -rather than creating a new list. Caveat evaluator: Like other -destructive list functions, these functions cannot modify the binding of -@var{lst}, and so cannot be used to delete the first element of -@var{lst} destructively. -@end deffn - - delv! -@c snarfed from list.c:670 -@deffn {Scheme Procedure} delv! item lst -@deffnx {C Function} scm_delv_x (item, lst) -Destructively remove all elements from @var{lst} that are -@code{eqv?} to @var{item}. -@end deffn - - delete! -@c snarfed from list.c:695 -@deffn {Scheme Procedure} delete! item lst -@deffnx {C Function} scm_delete_x (item, lst) -Destructively remove all elements from @var{lst} that are -@code{equal?} to @var{item}. -@end deffn - - delq -@c snarfed from list.c:724 -@deffn {Scheme Procedure} delq item lst -@deffnx {C Function} scm_delq (item, lst) -Return a newly-created copy of @var{lst} with elements -@code{eq?} to @var{item} removed. This procedure mirrors -@code{memq}: @code{delq} compares elements of @var{lst} against -@var{item} with @code{eq?}. -@end deffn - - delv -@c snarfed from list.c:737 -@deffn {Scheme Procedure} delv item lst -@deffnx {C Function} scm_delv (item, lst) -Return a newly-created copy of @var{lst} with elements -@code{eqv?} to @var{item} removed. This procedure mirrors -@code{memv}: @code{delv} compares elements of @var{lst} against -@var{item} with @code{eqv?}. -@end deffn - - delete -@c snarfed from list.c:750 -@deffn {Scheme Procedure} delete item lst -@deffnx {C Function} scm_delete (item, lst) -Return a newly-created copy of @var{lst} with elements -@code{equal?} to @var{item} removed. This procedure mirrors -@code{member}: @code{delete} compares elements of @var{lst} -against @var{item} with @code{equal?}. -@end deffn - - delq1! -@c snarfed from list.c:763 -@deffn {Scheme Procedure} delq1! item lst -@deffnx {C Function} scm_delq1_x (item, lst) -Like @code{delq!}, but only deletes the first occurrence of -@var{item} from @var{lst}. Tests for equality using -@code{eq?}. See also @code{delv1!} and @code{delete1!}. -@end deffn - - delv1! -@c snarfed from list.c:791 -@deffn {Scheme Procedure} delv1! item lst -@deffnx {C Function} scm_delv1_x (item, lst) -Like @code{delv!}, but only deletes the first occurrence of -@var{item} from @var{lst}. Tests for equality using -@code{eqv?}. See also @code{delq1!} and @code{delete1!}. -@end deffn - - delete1! -@c snarfed from list.c:819 -@deffn {Scheme Procedure} delete1! item lst -@deffnx {C Function} scm_delete1_x (item, lst) -Like @code{delete!}, but only deletes the first occurrence of -@var{item} from @var{lst}. Tests for equality using -@code{equal?}. See also @code{delq1!} and @code{delv1!}. -@end deffn - - filter -@c snarfed from list.c:851 -@deffn {Scheme Procedure} filter pred list -@deffnx {C Function} scm_filter (pred, list) -Return all the elements of 2nd arg @var{list} that satisfy predicate @var{pred}. -The list is not disordered -- elements that appear in the result list occur -in the same order as they occur in the argument list. The returned list may -share a common tail with the argument list. The dynamic order in which the -various applications of pred are made is not specified. - -@lisp -(filter even? '(0 7 8 8 43 -4)) => (0 8 8 -4) -@end lisp -@end deffn - - filter! -@c snarfed from list.c:878 -@deffn {Scheme Procedure} filter! pred list -@deffnx {C Function} scm_filter_x (pred, list) -Linear-update variant of @code{filter}. -@end deffn - - primitive-load -@c snarfed from load.c:72 -@deffn {Scheme Procedure} primitive-load filename -@deffnx {C Function} scm_primitive_load (filename) -Load the file named @var{filename} and evaluate its contents in -the top-level environment. The load paths are not searched; -@var{filename} must either be a full pathname or be a pathname -relative to the current directory. If the variable -@code{%load-hook} is defined, it should be bound to a procedure -that will be called before any code is loaded. See the -documentation for @code{%load-hook} later in this section. -@end deffn - - %package-data-dir -@c snarfed from load.c:117 -@deffn {Scheme Procedure} %package-data-dir -@deffnx {C Function} scm_sys_package_data_dir () -Return the name of the directory where Scheme packages, modules and -libraries are kept. On most Unix systems, this will be -@samp{/usr/local/share/guile}. -@end deffn - - %library-dir -@c snarfed from load.c:129 -@deffn {Scheme Procedure} %library-dir -@deffnx {C Function} scm_sys_library_dir () -Return the directory where the Guile Scheme library files are installed. -E.g., may return "/usr/share/guile/1.3.5". -@end deffn - - %site-dir -@c snarfed from load.c:141 -@deffn {Scheme Procedure} %site-dir -@deffnx {C Function} scm_sys_site_dir () -Return the directory where the Guile site files are installed. -E.g., may return "/usr/share/guile/site". -@end deffn - - parse-path -@c snarfed from load.c:166 -@deffn {Scheme Procedure} parse-path path [tail] -@deffnx {C Function} scm_parse_path (path, tail) -Parse @var{path}, which is expected to be a colon-separated -string, into a list and return the resulting list with -@var{tail} appended. If @var{path} is @code{#f}, @var{tail} -is returned. -@end deffn - - search-path -@c snarfed from load.c:293 -@deffn {Scheme Procedure} search-path path filename [extensions] -@deffnx {C Function} scm_search_path (path, filename, extensions) -Search @var{path} for a directory containing a file named -@var{filename}. The file must be readable, and not a directory. -If we find one, return its full filename; otherwise, return -@code{#f}. If @var{filename} is absolute, return it unchanged. -If given, @var{extensions} is a list of strings; for each -directory in @var{path}, we search for @var{filename} -concatenated with each @var{extension}. -@end deffn - - %search-load-path -@c snarfed from load.c:430 -@deffn {Scheme Procedure} %search-load-path filename -@deffnx {C Function} scm_sys_search_load_path (filename) -Search @var{%load-path} for the file named @var{filename}, -which must be readable by the current user. If @var{filename} -is found in the list of paths to search or is an absolute -pathname, return its full pathname. Otherwise, return -@code{#f}. Filenames may have any of the optional extensions -in the @code{%load-extensions} list; @code{%search-load-path} -will try each extension automatically. -@end deffn - - primitive-load-path -@c snarfed from load.c:451 -@deffn {Scheme Procedure} primitive-load-path filename -@deffnx {C Function} scm_primitive_load_path (filename) -Search @var{%load-path} for the file named @var{filename} and -load it into the top-level environment. If @var{filename} is a -relative pathname and is not found in the list of search paths, -an error is signalled. -@end deffn - - procedure->memoizing-macro -@c snarfed from macros.c:109 -@deffn {Scheme Procedure} procedure->memoizing-macro code -@deffnx {C Function} scm_makmmacro (code) -Return a @dfn{macro} which, when a symbol defined to this value -appears as the first symbol in an expression, evaluates the -result of applying @var{code} to the expression and the -environment. - -@code{procedure->memoizing-macro} is the same as -@code{procedure->macro}, except that the expression returned by -@var{code} replaces the original macro expression in the memoized -form of the containing code. -@end deffn - - procedure->syntax -@c snarfed from macros.c:123 -@deffn {Scheme Procedure} procedure->syntax code -@deffnx {C Function} scm_makacro (code) -Return a @dfn{macro} which, when a symbol defined to this value -appears as the first symbol in an expression, returns the -result of applying @var{code} to the expression and the -environment. -@end deffn - - procedure->macro -@c snarfed from macros.c:146 -@deffn {Scheme Procedure} procedure->macro code -@deffnx {C Function} scm_makmacro (code) -Return a @dfn{macro} which, when a symbol defined to this value -appears as the first symbol in an expression, evaluates the -result of applying @var{code} to the expression and the -environment. For example: - -@lisp -(define trace - (procedure->macro - (lambda (x env) `(set! ,(cadr x) (tracef ,(cadr x) ',(cadr x)))))) - -(trace @i{foo}) @equiv{} (set! @i{foo} (tracef @i{foo} '@i{foo})). -@end lisp -@end deffn - - macro? -@c snarfed from macros.c:165 -@deffn {Scheme Procedure} macro? obj -@deffnx {C Function} scm_macro_p (obj) -Return @code{#t} if @var{obj} is a regular macro, a memoizing macro, a -syntax transformer, or a syntax-case macro. -@end deffn - - macro-type -@c snarfed from macros.c:186 -@deffn {Scheme Procedure} macro-type m -@deffnx {C Function} scm_macro_type (m) -Return one of the symbols @code{syntax}, @code{macro}, -@code{macro!}, or @code{syntax-case}, depending on whether -@var{m} is a syntax transformer, a regular macro, a memoizing -macro, or a syntax-case macro, respectively. If @var{m} is -not a macro, @code{#f} is returned. -@end deffn - - macro-name -@c snarfed from macros.c:207 -@deffn {Scheme Procedure} macro-name m -@deffnx {C Function} scm_macro_name (m) -Return the name of the macro @var{m}. -@end deffn - - macro-transformer -@c snarfed from macros.c:218 -@deffn {Scheme Procedure} macro-transformer m -@deffnx {C Function} scm_macro_transformer (m) -Return the transformer of the macro @var{m}. -@end deffn - - current-module -@c snarfed from modules.c:45 -@deffn {Scheme Procedure} current-module -@deffnx {C Function} scm_current_module () -Return the current module. -@end deffn - - set-current-module -@c snarfed from modules.c:57 -@deffn {Scheme Procedure} set-current-module module -@deffnx {C Function} scm_set_current_module (module) -Set the current module to @var{module} and return -the previous current module. -@end deffn - - interaction-environment -@c snarfed from modules.c:80 -@deffn {Scheme Procedure} interaction-environment -@deffnx {C Function} scm_interaction_environment () -Return a specifier for the environment that contains -implementation--defined bindings, typically a superset of those -listed in the report. The intent is that this procedure will -return the environment in which the implementation would -evaluate expressions dynamically typed by the user. -@end deffn - - env-module -@c snarfed from modules.c:266 -@deffn {Scheme Procedure} env-module env -@deffnx {C Function} scm_env_module (env) -Return the module of @var{ENV}, a lexical environment. -@end deffn - - standard-eval-closure -@c snarfed from modules.c:342 -@deffn {Scheme Procedure} standard-eval-closure module -@deffnx {C Function} scm_standard_eval_closure (module) -Return an eval closure for the module @var{module}. -@end deffn - - standard-interface-eval-closure -@c snarfed from modules.c:353 -@deffn {Scheme Procedure} standard-interface-eval-closure module -@deffnx {C Function} scm_standard_interface_eval_closure (module) -Return a interface eval closure for the module @var{module}. Such a closure does not allow new bindings to be added. -@end deffn - - module-import-interface -@c snarfed from modules.c:399 -@deffn {Scheme Procedure} module-import-interface module sym -@deffnx {C Function} scm_module_import_interface (module, sym) -Return the module or interface from which @var{sym} is imported in @var{module}. If @var{sym} is not imported (i.e., it is not defined in @var{module} or it is a module-local binding instead of an imported one), then @code{#f} is returned. -@end deffn - - %get-pre-modules-obarray -@c snarfed from modules.c:616 -@deffn {Scheme Procedure} %get-pre-modules-obarray -@deffnx {C Function} scm_get_pre_modules_obarray () -Return the obarray that is used for all new bindings before the module system is booted. The first call to @code{set-current-module} will boot the module system. -@end deffn - - exact? -@c snarfed from numbers.c:460 -@deffn {Scheme Procedure} exact? x -@deffnx {C Function} scm_exact_p (x) -Return @code{#t} if @var{x} is an exact number, @code{#f} -otherwise. -@end deffn - - odd? -@c snarfed from numbers.c:479 -@deffn {Scheme Procedure} odd? n -@deffnx {C Function} scm_odd_p (n) -Return @code{#t} if @var{n} is an odd number, @code{#f} -otherwise. -@end deffn - - even? -@c snarfed from numbers.c:514 -@deffn {Scheme Procedure} even? n -@deffnx {C Function} scm_even_p (n) -Return @code{#t} if @var{n} is an even number, @code{#f} -otherwise. -@end deffn - - inf? -@c snarfed from numbers.c:548 -@deffn {Scheme Procedure} inf? x -@deffnx {C Function} scm_inf_p (x) -Return @code{#t} if @var{x} is either @samp{+inf.0} -or @samp{-inf.0}, @code{#f} otherwise. -@end deffn - - nan? -@c snarfed from numbers.c:564 -@deffn {Scheme Procedure} nan? n -@deffnx {C Function} scm_nan_p (n) -Return @code{#t} if @var{n} is a NaN, @code{#f} -otherwise. -@end deffn - - inf -@c snarfed from numbers.c:634 -@deffn {Scheme Procedure} inf -@deffnx {C Function} scm_inf () -Return Inf. -@end deffn - - nan -@c snarfed from numbers.c:649 -@deffn {Scheme Procedure} nan -@deffnx {C Function} scm_nan () -Return NaN. -@end deffn - - abs -@c snarfed from numbers.c:665 -@deffn {Scheme Procedure} abs x -@deffnx {C Function} scm_abs (x) -Return the absolute value of @var{x}. -@end deffn - - logand -@c snarfed from numbers.c:1201 -@deffn {Scheme Procedure} logand n1 n2 -Return the bitwise AND of the integer arguments. - -@lisp -(logand) @result{} -1 -(logand 7) @result{} 7 -(logand #b111 #b011 #b001) @result{} 1 -@end lisp -@end deffn - - logior -@c snarfed from numbers.c:1277 -@deffn {Scheme Procedure} logior n1 n2 -Return the bitwise OR of the integer arguments. - -@lisp -(logior) @result{} 0 -(logior 7) @result{} 7 -(logior #b000 #b001 #b011) @result{} 3 -@end lisp -@end deffn - - logxor -@c snarfed from numbers.c:1353 -@deffn {Scheme Procedure} logxor n1 n2 -Return the bitwise XOR of the integer arguments. A bit is -set in the result if it is set in an odd number of arguments. -@lisp -(logxor) @result{} 0 -(logxor 7) @result{} 7 -(logxor #b000 #b001 #b011) @result{} 2 -(logxor #b000 #b001 #b011 #b011) @result{} 1 -@end lisp -@end deffn - - logtest -@c snarfed from numbers.c:1428 -@deffn {Scheme Procedure} logtest j k -@deffnx {C Function} scm_logtest (j, k) -Test whether @var{j} and @var{k} have any 1 bits in common. -This is equivalent to @code{(not (zero? (logand j k)))}, but -without actually calculating the @code{logand}, just testing -for non-zero. - -@lisp -(logtest #b0100 #b1011) @result{} #f -(logtest #b0100 #b0111) @result{} #t -@end lisp -@end deffn - - logbit? -@c snarfed from numbers.c:1501 -@deffn {Scheme Procedure} logbit? index j -@deffnx {C Function} scm_logbit_p (index, j) -Test whether bit number @var{index} in @var{j} is set. -@var{index} starts from 0 for the least significant bit. - -@lisp -(logbit? 0 #b1101) @result{} #t -(logbit? 1 #b1101) @result{} #f -(logbit? 2 #b1101) @result{} #t -(logbit? 3 #b1101) @result{} #t -(logbit? 4 #b1101) @result{} #f -@end lisp -@end deffn - - lognot -@c snarfed from numbers.c:1535 -@deffn {Scheme Procedure} lognot n -@deffnx {C Function} scm_lognot (n) -Return the integer which is the ones-complement of the integer -argument. - -@lisp -(number->string (lognot #b10000000) 2) - @result{} "-10000001" -(number->string (lognot #b0) 2) - @result{} "-1" -@end lisp -@end deffn - - modulo-expt -@c snarfed from numbers.c:1580 -@deffn {Scheme Procedure} modulo-expt n k m -@deffnx {C Function} scm_modulo_expt (n, k, m) -Return @var{n} raised to the integer exponent -@var{k}, modulo @var{m}. - -@lisp -(modulo-expt 2 3 5) - @result{} 3 -@end lisp -@end deffn - - integer-expt -@c snarfed from numbers.c:1689 -@deffn {Scheme Procedure} integer-expt n k -@deffnx {C Function} scm_integer_expt (n, k) -Return @var{n} raised to the power @var{k}. @var{k} must be an -exact integer, @var{n} can be any number. - -Negative @var{k} is supported, and results in @math{1/n^abs(k)} -in the usual way. @math{@var{n}^0} is 1, as usual, and that -includes @math{0^0} is 1. - -@lisp -(integer-expt 2 5) @result{} 32 -(integer-expt -3 3) @result{} -27 -(integer-expt 5 -3) @result{} 1/125 -(integer-expt 0 0) @result{} 1 -@end lisp -@end deffn - - ash -@c snarfed from numbers.c:1779 -@deffn {Scheme Procedure} ash n cnt -@deffnx {C Function} scm_ash (n, cnt) -Return @var{n} shifted left by @var{cnt} bits, or shifted right -if @var{cnt} is negative. This is an ``arithmetic'' shift. - -This is effectively a multiplication by 2^@var{cnt}, and when -@var{cnt} is negative it's a division, rounded towards negative -infinity. (Note that this is not the same rounding as -@code{quotient} does.) - -With @var{n} viewed as an infinite precision twos complement, -@code{ash} means a left shift introducing zero bits, or a right -shift dropping bits. - -@lisp -(number->string (ash #b1 3) 2) @result{} "1000" -(number->string (ash #b1010 -1) 2) @result{} "101" - -;; -23 is bits ...11101001, -6 is bits ...111010 -(ash -23 -2) @result{} -6 -@end lisp -@end deffn - - bit-extract -@c snarfed from numbers.c:1870 -@deffn {Scheme Procedure} bit-extract n start end -@deffnx {C Function} scm_bit_extract (n, start, end) -Return the integer composed of the @var{start} (inclusive) -through @var{end} (exclusive) bits of @var{n}. The -@var{start}th bit becomes the 0-th bit in the result. - -@lisp -(number->string (bit-extract #b1101101010 0 4) 2) - @result{} "1010" -(number->string (bit-extract #b1101101010 4 9) 2) - @result{} "10110" -@end lisp -@end deffn - - logcount -@c snarfed from numbers.c:1949 -@deffn {Scheme Procedure} logcount n -@deffnx {C Function} scm_logcount (n) -Return the number of bits in integer @var{n}. If integer is -positive, the 1-bits in its binary representation are counted. -If negative, the 0-bits in its two's-complement binary -representation are counted. If 0, 0 is returned. - -@lisp -(logcount #b10101010) - @result{} 4 -(logcount 0) - @result{} 0 -(logcount -2) - @result{} 1 -@end lisp -@end deffn - - integer-length -@c snarfed from numbers.c:1997 -@deffn {Scheme Procedure} integer-length n -@deffnx {C Function} scm_integer_length (n) -Return the number of bits necessary to represent @var{n}. - -@lisp -(integer-length #b10101010) - @result{} 8 -(integer-length 0) - @result{} 0 -(integer-length #b1111) - @result{} 4 -@end lisp -@end deffn - - number->string -@c snarfed from numbers.c:2337 -@deffn {Scheme Procedure} number->string n [radix] -@deffnx {C Function} scm_number_to_string (n, radix) -Return a string holding the external representation of the -number @var{n} in the given @var{radix}. If @var{n} is -inexact, a radix of 10 will be used. -@end deffn - - string->number -@c snarfed from numbers.c:3034 -@deffn {Scheme Procedure} string->number string [radix] -@deffnx {C Function} scm_string_to_number (string, radix) -Return a number of the maximally precise representation -expressed by the given @var{string}. @var{radix} must be an -exact integer, either 2, 8, 10, or 16. If supplied, @var{radix} -is a default radix that may be overridden by an explicit radix -prefix in @var{string} (e.g. "#o177"). If @var{radix} is not -supplied, then the default radix is 10. If string is not a -syntactically valid notation for a number, then -@code{string->number} returns @code{#f}. -@end deffn - - number? -@c snarfed from numbers.c:3097 -@deffn {Scheme Procedure} number? x -@deffnx {C Function} scm_number_p (x) -Return @code{#t} if @var{x} is a number, @code{#f} -otherwise. -@end deffn - - complex? -@c snarfed from numbers.c:3110 -@deffn {Scheme Procedure} complex? x -@deffnx {C Function} scm_complex_p (x) -Return @code{#t} if @var{x} is a complex number, @code{#f} -otherwise. Note that the sets of real, rational and integer -values form subsets of the set of complex numbers, i. e. the -predicate will also be fulfilled if @var{x} is a real, -rational or integer number. -@end deffn - - real? -@c snarfed from numbers.c:3123 -@deffn {Scheme Procedure} real? x -@deffnx {C Function} scm_real_p (x) -Return @code{#t} if @var{x} is a real number, @code{#f} -otherwise. Note that the set of integer values forms a subset of -the set of real numbers, i. e. the predicate will also be -fulfilled if @var{x} is an integer number. -@end deffn - - rational? -@c snarfed from numbers.c:3136 -@deffn {Scheme Procedure} rational? x -@deffnx {C Function} scm_rational_p (x) -Return @code{#t} if @var{x} is a rational number, @code{#f} -otherwise. Note that the set of integer values forms a subset of -the set of rational numbers, i. e. the predicate will also be -fulfilled if @var{x} is an integer number. -@end deffn - - integer? -@c snarfed from numbers.c:3159 -@deffn {Scheme Procedure} integer? x -@deffnx {C Function} scm_integer_p (x) -Return @code{#t} if @var{x} is an integer number, @code{#f} -else. -@end deffn - - inexact? -@c snarfed from numbers.c:3185 -@deffn {Scheme Procedure} inexact? x -@deffnx {C Function} scm_inexact_p (x) -Return @code{#t} if @var{x} is an inexact number, @code{#f} -else. -@end deffn - - truncate -@c snarfed from numbers.c:5060 -@deffn {Scheme Procedure} truncate x -@deffnx {C Function} scm_truncate_number (x) -Round the number @var{x} towards zero. -@end deffn - - round -@c snarfed from numbers.c:5076 -@deffn {Scheme Procedure} round x -@deffnx {C Function} scm_round_number (x) -Round the number @var{x} towards the nearest integer. When it is exactly halfway between two integers, round towards the even one. -@end deffn - - floor -@c snarfed from numbers.c:5102 -@deffn {Scheme Procedure} floor x -@deffnx {C Function} scm_floor (x) -Round the number @var{x} towards minus infinity. -@end deffn - - ceiling -@c snarfed from numbers.c:5133 -@deffn {Scheme Procedure} ceiling x -@deffnx {C Function} scm_ceiling (x) -Round the number @var{x} towards infinity. -@end deffn - - $expt -@c snarfed from numbers.c:5242 -@deffn {Scheme Procedure} $expt x y -@deffnx {C Function} scm_sys_expt (x, y) -Return @var{x} raised to the power of @var{y}. This -procedure does not accept complex arguments. -@end deffn - - $atan2 -@c snarfed from numbers.c:5258 -@deffn {Scheme Procedure} $atan2 x y -@deffnx {C Function} scm_sys_atan2 (x, y) -Return the arc tangent of the two arguments @var{x} and -@var{y}. This is similar to calculating the arc tangent of -@var{x} / @var{y}, except that the signs of both arguments -are used to determine the quadrant of the result. This -procedure does not accept complex arguments. -@end deffn - - make-rectangular -@c snarfed from numbers.c:5286 -@deffn {Scheme Procedure} make-rectangular real_part imaginary_part -@deffnx {C Function} scm_make_rectangular (real_part, imaginary_part) -Return a complex number constructed of the given @var{real-part} and @var{imaginary-part} parts. -@end deffn - - make-polar -@c snarfed from numbers.c:5310 -@deffn {Scheme Procedure} make-polar x y -@deffnx {C Function} scm_make_polar (x, y) -Return the complex number @var{x} * e^(i * @var{y}). -@end deffn - - inexact->exact -@c snarfed from numbers.c:5513 -@deffn {Scheme Procedure} inexact->exact z -@deffnx {C Function} scm_inexact_to_exact (z) -Return an exact number that is numerically closest to @var{z}. -@end deffn - - rationalize -@c snarfed from numbers.c:5550 -@deffn {Scheme Procedure} rationalize x err -@deffnx {C Function} scm_rationalize (x, err) -Return an exact number that is within @var{err} of @var{x}. -@end deffn - - entity? -@c snarfed from objects.c:192 -@deffn {Scheme Procedure} entity? obj -@deffnx {C Function} scm_entity_p (obj) -Return @code{#t} if @var{obj} is an entity. -@end deffn - - operator? -@c snarfed from objects.c:201 -@deffn {Scheme Procedure} operator? obj -@deffnx {C Function} scm_operator_p (obj) -Return @code{#t} if @var{obj} is an operator. -@end deffn - - valid-object-procedure? -@c snarfed from objects.c:217 -@deffn {Scheme Procedure} valid-object-procedure? proc -@deffnx {C Function} scm_valid_object_procedure_p (proc) -Return @code{#t} iff @var{proc} is a procedure that can be used with @code{set-object-procedure}. It is always valid to use a closure constructed by @code{lambda}. -@end deffn - - set-object-procedure! -@c snarfed from objects.c:239 -@deffn {Scheme Procedure} set-object-procedure! obj proc -@deffnx {C Function} scm_set_object_procedure_x (obj, proc) -Set the object procedure of @var{obj} to @var{proc}. -@var{obj} must be either an entity or an operator. -@end deffn - - make-class-object -@c snarfed from objects.c:299 -@deffn {Scheme Procedure} make-class-object metaclass layout -@deffnx {C Function} scm_make_class_object (metaclass, layout) -Create a new class object of class @var{metaclass}, with the -slot layout specified by @var{layout}. -@end deffn - - make-subclass-object -@c snarfed from objects.c:314 -@deffn {Scheme Procedure} make-subclass-object class layout -@deffnx {C Function} scm_make_subclass_object (class, layout) -Create a subclass object of @var{class}, with the slot layout -specified by @var{layout}. -@end deffn - - object-properties -@c snarfed from objprop.c:36 -@deffn {Scheme Procedure} object-properties obj -@deffnx {C Function} scm_object_properties (obj) -Return @var{obj}'s property list. -@end deffn - - set-object-properties! -@c snarfed from objprop.c:46 -@deffn {Scheme Procedure} set-object-properties! obj alist -@deffnx {C Function} scm_set_object_properties_x (obj, alist) -Set @var{obj}'s property list to @var{alist}. -@end deffn - - object-property -@c snarfed from objprop.c:57 -@deffn {Scheme Procedure} object-property obj key -@deffnx {C Function} scm_object_property (obj, key) -Return the property of @var{obj} with name @var{key}. -@end deffn - - set-object-property! -@c snarfed from objprop.c:69 -@deffn {Scheme Procedure} set-object-property! obj key value -@deffnx {C Function} scm_set_object_property_x (obj, key, value) -In @var{obj}'s property list, set the property named @var{key} -to @var{value}. -@end deffn - - cons -@c snarfed from pairs.c:56 -@deffn {Scheme Procedure} cons x y -@deffnx {C Function} scm_cons (x, y) -Return a newly allocated pair whose car is @var{x} and whose -cdr is @var{y}. The pair is guaranteed to be different (in the -sense of @code{eq?}) from every previously existing object. -@end deffn - - pair? -@c snarfed from pairs.c:74 -@deffn {Scheme Procedure} pair? x -@deffnx {C Function} scm_pair_p (x) -Return @code{#t} if @var{x} is a pair; otherwise return -@code{#f}. -@end deffn - - set-car! -@c snarfed from pairs.c:120 -@deffn {Scheme Procedure} set-car! pair value -@deffnx {C Function} scm_set_car_x (pair, value) -Stores @var{value} in the car field of @var{pair}. The value returned -by @code{set-car!} is unspecified. -@end deffn - - set-cdr! -@c snarfed from pairs.c:133 -@deffn {Scheme Procedure} set-cdr! pair value -@deffnx {C Function} scm_set_cdr_x (pair, value) -Stores @var{value} in the cdr field of @var{pair}. The value returned -by @code{set-cdr!} is unspecified. -@end deffn - - char-ready? -@c snarfed from ports.c:245 -@deffn {Scheme Procedure} char-ready? [port] -@deffnx {C Function} scm_char_ready_p (port) -Return @code{#t} if a character is ready on input @var{port} -and return @code{#f} otherwise. If @code{char-ready?} returns -@code{#t} then the next @code{read-char} operation on -@var{port} is guaranteed not to hang. If @var{port} is a file -port at end of file then @code{char-ready?} returns @code{#t}. - -@code{char-ready?} exists to make it possible for a -program to accept characters from interactive ports without -getting stuck waiting for input. Any input editors associated -with such ports must make sure that characters whose existence -has been asserted by @code{char-ready?} cannot be rubbed out. -If @code{char-ready?} were to return @code{#f} at end of file, -a port at end of file would be indistinguishable from an -interactive port that has no ready characters. -@end deffn - - drain-input -@c snarfed from ports.c:322 -@deffn {Scheme Procedure} drain-input port -@deffnx {C Function} scm_drain_input (port) -This procedure clears a port's input buffers, similar -to the way that force-output clears the output buffer. The -contents of the buffers are returned as a single string, e.g., - -@lisp -(define p (open-input-file ...)) -(drain-input p) => empty string, nothing buffered yet. -(unread-char (read-char p) p) -(drain-input p) => initial chars from p, up to the buffer size. -@end lisp - -Draining the buffers may be useful for cleanly finishing -buffered I/O so that the file descriptor can be used directly -for further input. -@end deffn - - current-input-port -@c snarfed from ports.c:355 -@deffn {Scheme Procedure} current-input-port -@deffnx {C Function} scm_current_input_port () -Return the current input port. This is the default port used -by many input procedures. Initially, @code{current-input-port} -returns the @dfn{standard input} in Unix and C terminology. -@end deffn - - current-output-port -@c snarfed from ports.c:367 -@deffn {Scheme Procedure} current-output-port -@deffnx {C Function} scm_current_output_port () -Return the current output port. This is the default port used -by many output procedures. Initially, -@code{current-output-port} returns the @dfn{standard output} in -Unix and C terminology. -@end deffn - - current-error-port -@c snarfed from ports.c:377 -@deffn {Scheme Procedure} current-error-port -@deffnx {C Function} scm_current_error_port () -Return the port to which errors and warnings should be sent (the -@dfn{standard error} in Unix and C terminology). -@end deffn - - current-load-port -@c snarfed from ports.c:387 -@deffn {Scheme Procedure} current-load-port -@deffnx {C Function} scm_current_load_port () -Return the current-load-port. -The load port is used internally by @code{primitive-load}. -@end deffn - - set-current-input-port -@c snarfed from ports.c:400 -@deffn {Scheme Procedure} set-current-input-port port -@deffnx {Scheme Procedure} set-current-output-port port -@deffnx {Scheme Procedure} set-current-error-port port -@deffnx {C Function} scm_set_current_input_port (port) -Change the ports returned by @code{current-input-port}, -@code{current-output-port} and @code{current-error-port}, respectively, -so that they use the supplied @var{port} for input or output. -@end deffn - - set-current-output-port -@c snarfed from ports.c:413 -@deffn {Scheme Procedure} set-current-output-port port -@deffnx {C Function} scm_set_current_output_port (port) -Set the current default output port to @var{port}. -@end deffn - - set-current-error-port -@c snarfed from ports.c:427 -@deffn {Scheme Procedure} set-current-error-port port -@deffnx {C Function} scm_set_current_error_port (port) -Set the current default error port to @var{port}. -@end deffn - - port-revealed -@c snarfed from ports.c:625 -@deffn {Scheme Procedure} port-revealed port -@deffnx {C Function} scm_port_revealed (port) -Return the revealed count for @var{port}. -@end deffn - - set-port-revealed! -@c snarfed from ports.c:638 -@deffn {Scheme Procedure} set-port-revealed! port rcount -@deffnx {C Function} scm_set_port_revealed_x (port, rcount) -Sets the revealed count for a port to a given value. -The return value is unspecified. -@end deffn - - port-mode -@c snarfed from ports.c:699 -@deffn {Scheme Procedure} port-mode port -@deffnx {C Function} scm_port_mode (port) -Return the port modes associated with the open port @var{port}. -These will not necessarily be identical to the modes used when -the port was opened, since modes such as "append" which are -used only during port creation are not retained. -@end deffn - - close-port -@c snarfed from ports.c:736 -@deffn {Scheme Procedure} close-port port -@deffnx {C Function} scm_close_port (port) -Close the specified port object. Return @code{#t} if it -successfully closes a port or @code{#f} if it was already -closed. An exception may be raised if an error occurs, for -example when flushing buffered output. See also @ref{Ports and -File Descriptors, close}, for a procedure which can close file -descriptors. -@end deffn - - close-input-port -@c snarfed from ports.c:766 -@deffn {Scheme Procedure} close-input-port port -@deffnx {C Function} scm_close_input_port (port) -Close the specified input port object. The routine has no effect if -the file has already been closed. An exception may be raised if an -error occurs. The value returned is unspecified. - -See also @ref{Ports and File Descriptors, close}, for a procedure -which can close file descriptors. -@end deffn - - close-output-port -@c snarfed from ports.c:781 -@deffn {Scheme Procedure} close-output-port port -@deffnx {C Function} scm_close_output_port (port) -Close the specified output port object. The routine has no effect if -the file has already been closed. An exception may be raised if an -error occurs. The value returned is unspecified. - -See also @ref{Ports and File Descriptors, close}, for a procedure -which can close file descriptors. -@end deffn - - port-for-each -@c snarfed from ports.c:827 -@deffn {Scheme Procedure} port-for-each proc -@deffnx {C Function} scm_port_for_each (proc) -Apply @var{proc} to each port in the Guile port table -in turn. The return value is unspecified. More specifically, -@var{proc} is applied exactly once to every port that exists -in the system at the time @var{port-for-each} is invoked. -Changes to the port table while @var{port-for-each} is running -have no effect as far as @var{port-for-each} is concerned. -@end deffn - - input-port? -@c snarfed from ports.c:845 -@deffn {Scheme Procedure} input-port? x -@deffnx {C Function} scm_input_port_p (x) -Return @code{#t} if @var{x} is an input port, otherwise return -@code{#f}. Any object satisfying this predicate also satisfies -@code{port?}. -@end deffn - - output-port? -@c snarfed from ports.c:856 -@deffn {Scheme Procedure} output-port? x -@deffnx {C Function} scm_output_port_p (x) -Return @code{#t} if @var{x} is an output port, otherwise return -@code{#f}. Any object satisfying this predicate also satisfies -@code{port?}. -@end deffn - - port? -@c snarfed from ports.c:868 -@deffn {Scheme Procedure} port? x -@deffnx {C Function} scm_port_p (x) -Return a boolean indicating whether @var{x} is a port. -Equivalent to @code{(or (input-port? @var{x}) (output-port? -@var{x}))}. -@end deffn - - port-closed? -@c snarfed from ports.c:878 -@deffn {Scheme Procedure} port-closed? port -@deffnx {C Function} scm_port_closed_p (port) -Return @code{#t} if @var{port} is closed or @code{#f} if it is -open. -@end deffn - - eof-object? -@c snarfed from ports.c:889 -@deffn {Scheme Procedure} eof-object? x -@deffnx {C Function} scm_eof_object_p (x) -Return @code{#t} if @var{x} is an end-of-file object; otherwise -return @code{#f}. -@end deffn - - force-output -@c snarfed from ports.c:903 -@deffn {Scheme Procedure} force-output [port] -@deffnx {C Function} scm_force_output (port) -Flush the specified output port, or the current output port if @var{port} -is omitted. The current output buffer contents are passed to the -underlying port implementation (e.g., in the case of fports, the -data will be written to the file and the output buffer will be cleared.) -It has no effect on an unbuffered port. - -The return value is unspecified. -@end deffn - - flush-all-ports -@c snarfed from ports.c:921 -@deffn {Scheme Procedure} flush-all-ports -@deffnx {C Function} scm_flush_all_ports () -Equivalent to calling @code{force-output} on -all open output ports. The return value is unspecified. -@end deffn - - read-char -@c snarfed from ports.c:941 -@deffn {Scheme Procedure} read-char [port] -@deffnx {C Function} scm_read_char (port) -Return the next character available from @var{port}, updating -@var{port} to point to the following character. If no more -characters are available, the end-of-file object is returned. -@end deffn - - peek-char -@c snarfed from ports.c:1283 -@deffn {Scheme Procedure} peek-char [port] -@deffnx {C Function} scm_peek_char (port) -Return the next character available from @var{port}, -@emph{without} updating @var{port} to point to the following -character. If no more characters are available, the -end-of-file object is returned. - -The value returned by -a call to @code{peek-char} is the same as the value that would -have been returned by a call to @code{read-char} on the same -port. The only difference is that the very next call to -@code{read-char} or @code{peek-char} on that @var{port} will -return the value returned by the preceding call to -@code{peek-char}. In particular, a call to @code{peek-char} on -an interactive port will hang waiting for input whenever a call -to @code{read-char} would have hung. -@end deffn - - unread-char -@c snarfed from ports.c:1306 -@deffn {Scheme Procedure} unread-char cobj [port] -@deffnx {C Function} scm_unread_char (cobj, port) -Place @var{char} in @var{port} so that it will be read by the -next read operation. If called multiple times, the unread characters -will be read again in last-in first-out order. If @var{port} is -not supplied, the current input port is used. -@end deffn - - unread-string -@c snarfed from ports.c:1329 -@deffn {Scheme Procedure} unread-string str port -@deffnx {C Function} scm_unread_string (str, port) -Place the string @var{str} in @var{port} so that its characters will be -read in subsequent read operations. If called multiple times, the -unread characters will be read again in last-in first-out order. If -@var{port} is not supplied, the current-input-port is used. -@end deffn - - seek -@c snarfed from ports.c:1368 -@deffn {Scheme Procedure} seek fd_port offset whence -@deffnx {C Function} scm_seek (fd_port, offset, whence) -Sets the current position of @var{fd/port} to the integer -@var{offset}, which is interpreted according to the value of -@var{whence}. - -One of the following variables should be supplied for -@var{whence}: -@defvar SEEK_SET -Seek from the beginning of the file. -@end defvar -@defvar SEEK_CUR -Seek from the current position. -@end defvar -@defvar SEEK_END -Seek from the end of the file. -@end defvar -If @var{fd/port} is a file descriptor, the underlying system -call is @code{lseek}. @var{port} may be a string port. - -The value returned is the new position in the file. This means -that the current position of a port can be obtained using: -@lisp -(seek port 0 SEEK_CUR) -@end lisp -@end deffn - - truncate-file -@c snarfed from ports.c:1426 -@deffn {Scheme Procedure} truncate-file object [length] -@deffnx {C Function} scm_truncate_file (object, length) -Truncates the object referred to by @var{object} to at most -@var{length} bytes. @var{object} can be a string containing a -file name or an integer file descriptor or a port. -@var{length} may be omitted if @var{object} is not a file name, -in which case the truncation occurs at the current port -position. The return value is unspecified. -@end deffn - - port-line -@c snarfed from ports.c:1486 -@deffn {Scheme Procedure} port-line port -@deffnx {C Function} scm_port_line (port) -Return the current line number for @var{port}. - -The first line of a file is 0. But you might want to add 1 -when printing line numbers, since starting from 1 is -traditional in error messages, and likely to be more natural to -non-programmers. -@end deffn - - set-port-line! -@c snarfed from ports.c:1498 -@deffn {Scheme Procedure} set-port-line! port line -@deffnx {C Function} scm_set_port_line_x (port, line) -Set the current line number for @var{port} to @var{line}. The -first line of a file is 0. -@end deffn - - port-column -@c snarfed from ports.c:1517 -@deffn {Scheme Procedure} port-column port -@deffnx {C Function} scm_port_column (port) -Return the current column number of @var{port}. -If the number is -unknown, the result is #f. Otherwise, the result is a 0-origin integer -- i.e. the first character of the first line is line 0, column 0. -(However, when you display a file position, for example in an error -message, we recommend you add 1 to get 1-origin integers. This is -because lines and column numbers traditionally start with 1, and that is -what non-programmers will find most natural.) -@end deffn - - set-port-column! -@c snarfed from ports.c:1529 -@deffn {Scheme Procedure} set-port-column! port column -@deffnx {C Function} scm_set_port_column_x (port, column) -Set the current column of @var{port}. Before reading the first -character on a line the column should be 0. -@end deffn - - port-filename -@c snarfed from ports.c:1543 -@deffn {Scheme Procedure} port-filename port -@deffnx {C Function} scm_port_filename (port) -Return the filename associated with @var{port}. This function returns -the strings "standard input", "standard output" and "standard error" -when called on the current input, output and error ports respectively. -@end deffn - - set-port-filename! -@c snarfed from ports.c:1557 -@deffn {Scheme Procedure} set-port-filename! port filename -@deffnx {C Function} scm_set_port_filename_x (port, filename) -Change the filename associated with @var{port}, using the current input -port if none is specified. Note that this does not change the port's -source of data, but only the value that is returned by -@code{port-filename} and reported in diagnostic output. -@end deffn - - %make-void-port -@c snarfed from ports.c:1651 -@deffn {Scheme Procedure} %make-void-port mode -@deffnx {C Function} scm_sys_make_void_port (mode) -Create and return a new void port. A void port acts like -@file{/dev/null}. The @var{mode} argument -specifies the input/output modes for this port: see the -documentation for @code{open-file} in @ref{File Ports}. -@end deffn - - print-options-interface -@c snarfed from print.c:87 -@deffn {Scheme Procedure} print-options-interface [setting] -@deffnx {C Function} scm_print_options (setting) -Option interface for the print options. Instead of using -this procedure directly, use the procedures -@code{print-enable}, @code{print-disable}, @code{print-set!} -and @code{print-options}. -@end deffn - - simple-format -@c snarfed from print.c:929 -@deffn {Scheme Procedure} simple-format destination message . args -@deffnx {C Function} scm_simple_format (destination, message, args) -Write @var{message} to @var{destination}, defaulting to -the current output port. -@var{message} can contain @code{~A} (was @code{%s}) and -@code{~S} (was @code{%S}) escapes. When printed, -the escapes are replaced with corresponding members of -@var{ARGS}: -@code{~A} formats using @code{display} and @code{~S} formats -using @code{write}. -If @var{destination} is @code{#t}, then use the current output -port, if @var{destination} is @code{#f}, then return a string -containing the formatted text. Does not add a trailing newline. -@end deffn - - newline -@c snarfed from print.c:1019 -@deffn {Scheme Procedure} newline [port] -@deffnx {C Function} scm_newline (port) -Send a newline to @var{port}. -If @var{port} is omitted, send to the current output port. -@end deffn - - write-char -@c snarfed from print.c:1034 -@deffn {Scheme Procedure} write-char chr [port] -@deffnx {C Function} scm_write_char (chr, port) -Send character @var{chr} to @var{port}. -@end deffn - - port-with-print-state -@c snarfed from print.c:1088 -@deffn {Scheme Procedure} port-with-print-state port [pstate] -@deffnx {C Function} scm_port_with_print_state (port, pstate) -Create a new port which behaves like @var{port}, but with an -included print state @var{pstate}. @var{pstate} is optional. -If @var{pstate} isn't supplied and @var{port} already has -a print state, the old print state is reused. -@end deffn - - get-print-state -@c snarfed from print.c:1101 -@deffn {Scheme Procedure} get-print-state port -@deffnx {C Function} scm_get_print_state (port) -Return the print state of the port @var{port}. If @var{port} -has no associated print state, @code{#f} is returned. -@end deffn - - procedure-properties -@c snarfed from procprop.c:160 -@deffn {Scheme Procedure} procedure-properties proc -@deffnx {C Function} scm_procedure_properties (proc) -Return @var{obj}'s property list. -@end deffn - - set-procedure-properties! -@c snarfed from procprop.c:173 -@deffn {Scheme Procedure} set-procedure-properties! proc new_val -@deffnx {C Function} scm_set_procedure_properties_x (proc, new_val) -Set @var{obj}'s property list to @var{alist}. -@end deffn - - procedure-property -@c snarfed from procprop.c:186 -@deffn {Scheme Procedure} procedure-property p k -@deffnx {C Function} scm_procedure_property (p, k) -Return the property of @var{obj} with name @var{key}. -@end deffn - - set-procedure-property! -@c snarfed from procprop.c:209 -@deffn {Scheme Procedure} set-procedure-property! p k v -@deffnx {C Function} scm_set_procedure_property_x (p, k, v) -In @var{obj}'s property list, set the property named @var{key} to -@var{value}. -@end deffn - - procedure? -@c snarfed from procs.c:162 -@deffn {Scheme Procedure} procedure? obj -@deffnx {C Function} scm_procedure_p (obj) -Return @code{#t} if @var{obj} is a procedure. -@end deffn - - closure? -@c snarfed from procs.c:189 -@deffn {Scheme Procedure} closure? obj -@deffnx {C Function} scm_closure_p (obj) -Return @code{#t} if @var{obj} is a closure. -@end deffn - - thunk? -@c snarfed from procs.c:198 -@deffn {Scheme Procedure} thunk? obj -@deffnx {C Function} scm_thunk_p (obj) -Return @code{#t} if @var{obj} is a thunk. -@end deffn - - procedure-documentation -@c snarfed from procs.c:248 -@deffn {Scheme Procedure} procedure-documentation proc -@deffnx {C Function} scm_procedure_documentation (proc) -Return the documentation string associated with @code{proc}. By -convention, if a procedure contains more than one expression and the -first expression is a string constant, that string is assumed to contain -documentation for that procedure. -@end deffn - - procedure-with-setter? -@c snarfed from procs.c:284 -@deffn {Scheme Procedure} procedure-with-setter? obj -@deffnx {C Function} scm_procedure_with_setter_p (obj) -Return @code{#t} if @var{obj} is a procedure with an -associated setter procedure. -@end deffn - - make-procedure-with-setter -@c snarfed from procs.c:294 -@deffn {Scheme Procedure} make-procedure-with-setter procedure setter -@deffnx {C Function} scm_make_procedure_with_setter (procedure, setter) -Create a new procedure which behaves like @var{procedure}, but -with the associated setter @var{setter}. -@end deffn - - procedure -@c snarfed from procs.c:308 -@deffn {Scheme Procedure} procedure proc -@deffnx {C Function} scm_procedure (proc) -Return the procedure of @var{proc}, which must be an -applicable struct. -@end deffn - - primitive-make-property -@c snarfed from properties.c:40 -@deffn {Scheme Procedure} primitive-make-property not_found_proc -@deffnx {C Function} scm_primitive_make_property (not_found_proc) -Create a @dfn{property token} that can be used with -@code{primitive-property-ref} and @code{primitive-property-set!}. -See @code{primitive-property-ref} for the significance of -@var{not_found_proc}. -@end deffn - - primitive-property-ref -@c snarfed from properties.c:59 -@deffn {Scheme Procedure} primitive-property-ref prop obj -@deffnx {C Function} scm_primitive_property_ref (prop, obj) -Return the property @var{prop} of @var{obj}. - -When no value has yet been associated with @var{prop} and -@var{obj}, the @var{not-found-proc} from @var{prop} is used. A -call @code{(@var{not-found-proc} @var{prop} @var{obj})} is made -and the result set as the property value. If -@var{not-found-proc} is @code{#f} then @code{#f} is the -property value. -@end deffn - - primitive-property-set! -@c snarfed from properties.c:90 -@deffn {Scheme Procedure} primitive-property-set! prop obj val -@deffnx {C Function} scm_primitive_property_set_x (prop, obj, val) -Set the property @var{prop} of @var{obj} to @var{val}. -@end deffn - - primitive-property-del! -@c snarfed from properties.c:111 -@deffn {Scheme Procedure} primitive-property-del! prop obj -@deffnx {C Function} scm_primitive_property_del_x (prop, obj) -Remove any value associated with @var{prop} and @var{obj}. -@end deffn - - random -@c snarfed from random.c:347 -@deffn {Scheme Procedure} random n [state] -@deffnx {C Function} scm_random (n, state) -Return a number in [0, N). - -Accepts a positive integer or real n and returns a -number of the same type between zero (inclusive) and -N (exclusive). The values returned have a uniform -distribution. - -The optional argument @var{state} must be of the type produced -by @code{seed->random-state}. It defaults to the value of the -variable @var{*random-state*}. This object is used to maintain -the state of the pseudo-random-number generator and is altered -as a side effect of the random operation. -@end deffn - - copy-random-state -@c snarfed from random.c:372 -@deffn {Scheme Procedure} copy-random-state [state] -@deffnx {C Function} scm_copy_random_state (state) -Return a copy of the random state @var{state}. -@end deffn - - seed->random-state -@c snarfed from random.c:384 -@deffn {Scheme Procedure} seed->random-state seed -@deffnx {C Function} scm_seed_to_random_state (seed) -Return a new random state using @var{seed}. -@end deffn - - random:uniform -@c snarfed from random.c:402 -@deffn {Scheme Procedure} random:uniform [state] -@deffnx {C Function} scm_random_uniform (state) -Return a uniformly distributed inexact real random number in -[0,1). -@end deffn - - random:normal -@c snarfed from random.c:417 -@deffn {Scheme Procedure} random:normal [state] -@deffnx {C Function} scm_random_normal (state) -Return an inexact real in a normal distribution. The -distribution used has mean 0 and standard deviation 1. For a -normal distribution with mean m and standard deviation d use -@code{(+ m (* d (random:normal)))}. -@end deffn - - random:solid-sphere! -@c snarfed from random.c:500 -@deffn {Scheme Procedure} random:solid-sphere! v [state] -@deffnx {C Function} scm_random_solid_sphere_x (v, state) -Fills @var{vect} with inexact real random numbers the sum of -whose squares is less than 1.0. Thinking of @var{vect} as -coordinates in space of dimension @var{n} @math{=} -@code{(vector-length @var{vect})}, the coordinates are -uniformly distributed within the unit @var{n}-sphere. -@end deffn - - random:hollow-sphere! -@c snarfed from random.c:522 -@deffn {Scheme Procedure} random:hollow-sphere! v [state] -@deffnx {C Function} scm_random_hollow_sphere_x (v, state) -Fills vect with inexact real random numbers -the sum of whose squares is equal to 1.0. -Thinking of vect as coordinates in space of -dimension n = (vector-length vect), the coordinates -are uniformly distributed over the surface of the -unit n-sphere. -@end deffn - - random:normal-vector! -@c snarfed from random.c:539 -@deffn {Scheme Procedure} random:normal-vector! v [state] -@deffnx {C Function} scm_random_normal_vector_x (v, state) -Fills vect with inexact real random numbers that are -independent and standard normally distributed -(i.e., with mean 0 and variance 1). -@end deffn - - random:exp -@c snarfed from random.c:577 -@deffn {Scheme Procedure} random:exp [state] -@deffnx {C Function} scm_random_exp (state) -Return an inexact real in an exponential distribution with mean -1. For an exponential distribution with mean u use (* u -(random:exp)). -@end deffn - - %read-delimited! -@c snarfed from rdelim.c:55 -@deffn {Scheme Procedure} %read-delimited! delims str gobble [port [start [end]]] -@deffnx {C Function} scm_read_delimited_x (delims, str, gobble, port, start, end) -Read characters from @var{port} into @var{str} until one of the -characters in the @var{delims} string is encountered. If -@var{gobble} is true, discard the delimiter character; -otherwise, leave it in the input stream for the next read. If -@var{port} is not specified, use the value of -@code{(current-input-port)}. If @var{start} or @var{end} are -specified, store data only into the substring of @var{str} -bounded by @var{start} and @var{end} (which default to the -beginning and end of the string, respectively). - - Return a pair consisting of the delimiter that terminated the -string and the number of characters read. If reading stopped -at the end of file, the delimiter returned is the -@var{eof-object}; if the string was filled without encountering -a delimiter, this value is @code{#f}. -@end deffn - - %read-line -@c snarfed from rdelim.c:202 -@deffn {Scheme Procedure} %read-line [port] -@deffnx {C Function} scm_read_line (port) -Read a newline-terminated line from @var{port}, allocating storage as -necessary. The newline terminator (if any) is removed from the string, -and a pair consisting of the line and its delimiter is returned. The -delimiter may be either a newline or the @var{eof-object}; if -@code{%read-line} is called at the end of file, it returns the pair -@code{(# . #)}. -@end deffn - - write-line -@c snarfed from rdelim.c:255 -@deffn {Scheme Procedure} write-line obj [port] -@deffnx {C Function} scm_write_line (obj, port) -Display @var{obj} and a newline character to @var{port}. If -@var{port} is not specified, @code{(current-output-port)} is -used. This function is equivalent to: -@lisp -(display obj [port]) -(newline [port]) -@end lisp -@end deffn - - read-options-interface -@c snarfed from read.c:110 -@deffn {Scheme Procedure} read-options-interface [setting] -@deffnx {C Function} scm_read_options (setting) -Option interface for the read options. Instead of using -this procedure directly, use the procedures @code{read-enable}, -@code{read-disable}, @code{read-set!} and @code{read-options}. -@end deffn - - read -@c snarfed from read.c:130 -@deffn {Scheme Procedure} read [port] -@deffnx {C Function} scm_read (port) -Read an s-expression from the input port @var{port}, or from -the current input port if @var{port} is not specified. -Any whitespace before the next token is discarded. -@end deffn - - read-hash-extend -@c snarfed from read.c:898 -@deffn {Scheme Procedure} read-hash-extend chr proc -@deffnx {C Function} scm_read_hash_extend (chr, proc) -Install the procedure @var{proc} for reading expressions -starting with the character sequence @code{#} and @var{chr}. -@var{proc} will be called with two arguments: the character -@var{chr} and the port to read further data from. The object -returned will be the return value of @code{read}. -Passing @code{#f} for @var{proc} will remove a previous setting. - -@end deffn - - call-with-dynamic-root -@c snarfed from root.c:160 -@deffn {Scheme Procedure} call-with-dynamic-root thunk handler -@deffnx {C Function} scm_call_with_dynamic_root (thunk, handler) -Call @var{thunk} with a new dynamic state and withina continuation barrier. The @var{handler} catches allotherwise uncaught throws and executes within the samedynamic context as @var{thunk}. -@end deffn - - dynamic-root -@c snarfed from root.c:171 -@deffn {Scheme Procedure} dynamic-root -@deffnx {C Function} scm_dynamic_root () -Return an object representing the current dynamic root. - -These objects are only useful for comparison using @code{eq?}. - -@end deffn - - read-string!/partial -@c snarfed from rw.c:101 -@deffn {Scheme Procedure} read-string!/partial str [port_or_fdes [start [end]]] -@deffnx {C Function} scm_read_string_x_partial (str, port_or_fdes, start, end) -Read characters from a port or file descriptor into a -string @var{str}. A port must have an underlying file -descriptor --- a so-called fport. This procedure is -scsh-compatible and can efficiently read large strings. -It will: - -@itemize -@item -attempt to fill the entire string, unless the @var{start} -and/or @var{end} arguments are supplied. i.e., @var{start} -defaults to 0 and @var{end} defaults to -@code{(string-length str)} -@item -use the current input port if @var{port_or_fdes} is not -supplied. -@item -return fewer than the requested number of characters in some -cases, e.g., on end of file, if interrupted by a signal, or if -not all the characters are immediately available. -@item -wait indefinitely for some input if no characters are -currently available, -unless the port is in non-blocking mode. -@item -read characters from the port's input buffers if available, -instead from the underlying file descriptor. -@item -return @code{#f} if end-of-file is encountered before reading -any characters, otherwise return the number of characters -read. -@item -return 0 if the port is in non-blocking mode and no characters -are immediately available. -@item -return 0 if the request is for 0 bytes, with no -end-of-file check. -@end itemize -@end deffn - - write-string/partial -@c snarfed from rw.c:205 -@deffn {Scheme Procedure} write-string/partial str [port_or_fdes [start [end]]] -@deffnx {C Function} scm_write_string_partial (str, port_or_fdes, start, end) -Write characters from a string @var{str} to a port or file -descriptor. A port must have an underlying file descriptor ---- a so-called fport. This procedure is -scsh-compatible and can efficiently write large strings. -It will: - -@itemize -@item -attempt to write the entire string, unless the @var{start} -and/or @var{end} arguments are supplied. i.e., @var{start} -defaults to 0 and @var{end} defaults to -@code{(string-length str)} -@item -use the current output port if @var{port_of_fdes} is not -supplied. -@item -in the case of a buffered port, store the characters in the -port's output buffer, if all will fit. If they will not fit -then any existing buffered characters will be flushed -before attempting -to write the new characters directly to the underlying file -descriptor. If the port is in non-blocking mode and -buffered characters can not be flushed immediately, then an -@code{EAGAIN} system-error exception will be raised (Note: -scsh does not support the use of non-blocking buffered ports.) -@item -write fewer than the requested number of -characters in some cases, e.g., if interrupted by a signal or -if not all of the output can be accepted immediately. -@item -wait indefinitely for at least one character -from @var{str} to be accepted by the port, unless the port is -in non-blocking mode. -@item -return the number of characters accepted by the port. -@item -return 0 if the port is in non-blocking mode and can not accept -at least one character from @var{str} immediately -@item -return 0 immediately if the request size is 0 bytes. -@end itemize -@end deffn - - sigaction -@c snarfed from scmsigs.c:253 -@deffn {Scheme Procedure} sigaction signum [handler [flags [thread]]] -@deffnx {C Function} scm_sigaction_for_thread (signum, handler, flags, thread) -Install or report the signal handler for a specified signal. - -@var{signum} is the signal number, which can be specified using the value -of variables such as @code{SIGINT}. - -If @var{handler} is omitted, @code{sigaction} returns a pair: the -CAR is the current -signal hander, which will be either an integer with the value @code{SIG_DFL} -(default action) or @code{SIG_IGN} (ignore), or the Scheme procedure which -handles the signal, or @code{#f} if a non-Scheme procedure handles the -signal. The CDR contains the current @code{sigaction} flags for the handler. - -If @var{handler} is provided, it is installed as the new handler for -@var{signum}. @var{handler} can be a Scheme procedure taking one -argument, or the value of @code{SIG_DFL} (default action) or -@code{SIG_IGN} (ignore), or @code{#f} to restore whatever signal handler -was installed before @code{sigaction} was first used. When -a scheme procedure has been specified, that procedure will run -in the given @var{thread}. When no thread has been given, the -thread that made this call to @code{sigaction} is used. -Flags can optionally be specified for the new handler (@code{SA_RESTART} will -always be added if it's available and the system is using restartable -system calls.) The return value is a pair with information about the -old handler as described above. - -This interface does not provide access to the "signal blocking" -facility. Maybe this is not needed, since the thread support may -provide solutions to the problem of consistent access to data -structures. -@end deffn - - restore-signals -@c snarfed from scmsigs.c:427 -@deffn {Scheme Procedure} restore-signals -@deffnx {C Function} scm_restore_signals () -Return all signal handlers to the values they had before any call to -@code{sigaction} was made. The return value is unspecified. -@end deffn - - alarm -@c snarfed from scmsigs.c:464 -@deffn {Scheme Procedure} alarm i -@deffnx {C Function} scm_alarm (i) -Set a timer to raise a @code{SIGALRM} signal after the specified -number of seconds (an integer). It's advisable to install a signal -handler for -@code{SIGALRM} beforehand, since the default action is to terminate -the process. - -The return value indicates the time remaining for the previous alarm, -if any. The new value replaces the previous alarm. If there was -no previous alarm, the return value is zero. -@end deffn - - setitimer -@c snarfed from scmsigs.c:491 -@deffn {Scheme Procedure} setitimer which_timer interval_seconds interval_microseconds value_seconds value_microseconds -@deffnx {C Function} scm_setitimer (which_timer, interval_seconds, interval_microseconds, value_seconds, value_microseconds) -Set the timer specified by @var{which_timer} according to the given -@var{interval_seconds}, @var{interval_microseconds}, -@var{value_seconds}, and @var{value_microseconds} values. - -Return information about the timer's previous setting. -Errors are handled as described in the guile info pages under ``POSIX -Interface Conventions''. - -The timers available are: @code{ITIMER_REAL}, @code{ITIMER_VIRTUAL}, -and @code{ITIMER_PROF}. - -The return value will be a list of two cons pairs representing the -current state of the given timer. The first pair is the seconds and -microseconds of the timer @code{it_interval}, and the second pair is -the seconds and microseconds of the timer @code{it_value}. -@end deffn - - getitimer -@c snarfed from scmsigs.c:532 -@deffn {Scheme Procedure} getitimer which_timer -@deffnx {C Function} scm_getitimer (which_timer) -Return information about the timer specified by @var{which_timer} -Errors are handled as described in the guile info pages under ``POSIX -Interface Conventions''. - -The timers available are: @code{ITIMER_REAL}, @code{ITIMER_VIRTUAL}, -and @code{ITIMER_PROF}. - -The return value will be a list of two cons pairs representing the -current state of the given timer. The first pair is the seconds and -microseconds of the timer @code{it_interval}, and the second pair is -the seconds and microseconds of the timer @code{it_value}. -@end deffn - - pause -@c snarfed from scmsigs.c:559 -@deffn {Scheme Procedure} pause -@deffnx {C Function} scm_pause () -Pause the current process (thread?) until a signal arrives whose -action is to either terminate the current process or invoke a -handler procedure. The return value is unspecified. -@end deffn - - sleep -@c snarfed from scmsigs.c:572 -@deffn {Scheme Procedure} sleep i -@deffnx {C Function} scm_sleep (i) -Wait for the given number of seconds (an integer) or until a signal -arrives. The return value is zero if the time elapses or the number -of seconds remaining otherwise. -@end deffn - - usleep -@c snarfed from scmsigs.c:581 -@deffn {Scheme Procedure} usleep i -@deffnx {C Function} scm_usleep (i) -Sleep for @var{i} microseconds. -@end deffn - - raise -@c snarfed from scmsigs.c:591 -@deffn {Scheme Procedure} raise sig -@deffnx {C Function} scm_raise (sig) -Sends a specified signal @var{sig} to the current process, where -@var{sig} is as described for the kill procedure. -@end deffn - - system -@c snarfed from simpos.c:64 -@deffn {Scheme Procedure} system [cmd] -@deffnx {C Function} scm_system (cmd) -Execute @var{cmd} using the operating system's "command -processor". Under Unix this is usually the default shell -@code{sh}. The value returned is @var{cmd}'s exit status as -returned by @code{waitpid}, which can be interpreted using -@code{status:exit-val} and friends. - -If @code{system} is called without arguments, return a boolean -indicating whether the command processor is available. -@end deffn - - system* -@c snarfed from simpos.c:114 -@deffn {Scheme Procedure} system* . args -@deffnx {C Function} scm_system_star (args) -Execute the command indicated by @var{args}. The first element must -be a string indicating the command to be executed, and the remaining -items must be strings representing each of the arguments to that -command. - -This function returns the exit status of the command as provided by -@code{waitpid}. This value can be handled with @code{status:exit-val} -and the related functions. - -@code{system*} is similar to @code{system}, but accepts only one -string per-argument, and performs no shell interpretation. The -command is executed using fork and execlp. Accordingly this function -may be safer than @code{system} in situations where shell -interpretation is not required. - -Example: (system* "echo" "foo" "bar") -@end deffn - - getenv -@c snarfed from simpos.c:184 -@deffn {Scheme Procedure} getenv nam -@deffnx {C Function} scm_getenv (nam) -Looks up the string @var{name} in the current environment. The return -value is @code{#f} unless a string of the form @code{NAME=VALUE} is -found, in which case the string @code{VALUE} is returned. -@end deffn - - primitive-exit -@c snarfed from simpos.c:200 -@deffn {Scheme Procedure} primitive-exit [status] -@deffnx {C Function} scm_primitive_exit (status) -Terminate the current process without unwinding the Scheme stack. -This is would typically be useful after a fork. The exit status -is @var{status} if supplied, otherwise zero. -@end deffn - - restricted-vector-sort! -@c snarfed from sort.c:78 -@deffn {Scheme Procedure} restricted-vector-sort! vec less startpos endpos -@deffnx {C Function} scm_restricted_vector_sort_x (vec, less, startpos, endpos) -Sort the vector @var{vec}, using @var{less} for comparing -the vector elements. @var{startpos} (inclusively) and -@var{endpos} (exclusively) delimit -the range of the vector which gets sorted. The return value -is not specified. -@end deffn - - sorted? -@c snarfed from sort.c:111 -@deffn {Scheme Procedure} sorted? items less -@deffnx {C Function} scm_sorted_p (items, less) -Return @code{#t} iff @var{items} is a list or a vector such that -for all 1 <= i <= m, the predicate @var{less} returns true when -applied to all elements i - 1 and i -@end deffn - - merge -@c snarfed from sort.c:186 -@deffn {Scheme Procedure} merge alist blist less -@deffnx {C Function} scm_merge (alist, blist, less) -Merge two already sorted lists into one. -Given two lists @var{alist} and @var{blist}, such that -@code{(sorted? alist less?)} and @code{(sorted? blist less?)}, -return a new list in which the elements of @var{alist} and -@var{blist} have been stably interleaved so that -@code{(sorted? (merge alist blist less?) less?)}. -Note: this does _not_ accept vectors. -@end deffn - - merge! -@c snarfed from sort.c:303 -@deffn {Scheme Procedure} merge! alist blist less -@deffnx {C Function} scm_merge_x (alist, blist, less) -Takes two lists @var{alist} and @var{blist} such that -@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and -returns a new list in which the elements of @var{alist} and -@var{blist} have been stably interleaved so that - @code{(sorted? (merge alist blist less?) less?)}. -This is the destructive variant of @code{merge} -Note: this does _not_ accept vectors. -@end deffn - - sort! -@c snarfed from sort.c:373 -@deffn {Scheme Procedure} sort! items less -@deffnx {C Function} scm_sort_x (items, less) -Sort the sequence @var{items}, which may be a list or a -vector. @var{less} is used for comparing the sequence -elements. The sorting is destructive, that means that the -input sequence is modified to produce the sorted result. -This is not a stable sort. -@end deffn - - sort -@c snarfed from sort.c:404 -@deffn {Scheme Procedure} sort items less -@deffnx {C Function} scm_sort (items, less) -Sort the sequence @var{items}, which may be a list or a -vector. @var{less} is used for comparing the sequence -elements. This is not a stable sort. -@end deffn - - stable-sort! -@c snarfed from sort.c:487 -@deffn {Scheme Procedure} stable-sort! items less -@deffnx {C Function} scm_stable_sort_x (items, less) -Sort the sequence @var{items}, which may be a list or a -vector. @var{less} is used for comparing the sequence elements. -The sorting is destructive, that means that the input sequence -is modified to produce the sorted result. -This is a stable sort. -@end deffn - - stable-sort -@c snarfed from sort.c:531 -@deffn {Scheme Procedure} stable-sort items less -@deffnx {C Function} scm_stable_sort (items, less) -Sort the sequence @var{items}, which may be a list or a -vector. @var{less} is used for comparing the sequence elements. -This is a stable sort. -@end deffn - - sort-list! -@c snarfed from sort.c:549 -@deffn {Scheme Procedure} sort-list! items less -@deffnx {C Function} scm_sort_list_x (items, less) -Sort the list @var{items}, using @var{less} for comparing the -list elements. The sorting is destructive, that means that the -input list is modified to produce the sorted result. -This is a stable sort. -@end deffn - - sort-list -@c snarfed from sort.c:564 -@deffn {Scheme Procedure} sort-list items less -@deffnx {C Function} scm_sort_list (items, less) -Sort the list @var{items}, using @var{less} for comparing the -list elements. This is a stable sort. -@end deffn - - source-properties -@c snarfed from srcprop.c:153 -@deffn {Scheme Procedure} source-properties obj -@deffnx {C Function} scm_source_properties (obj) -Return the source property association list of @var{obj}. -@end deffn - - set-source-properties! -@c snarfed from srcprop.c:176 -@deffn {Scheme Procedure} set-source-properties! obj plist -@deffnx {C Function} scm_set_source_properties_x (obj, plist) -Install the association list @var{plist} as the source property -list for @var{obj}. -@end deffn - - source-property -@c snarfed from srcprop.c:194 -@deffn {Scheme Procedure} source-property obj key -@deffnx {C Function} scm_source_property (obj, key) -Return the source property specified by @var{key} from -@var{obj}'s source property list. -@end deffn - - set-source-property! -@c snarfed from srcprop.c:225 -@deffn {Scheme Procedure} set-source-property! obj key datum -@deffnx {C Function} scm_set_source_property_x (obj, key, datum) -Set the source property of object @var{obj}, which is specified by -@var{key} to @var{datum}. Normally, the key will be a symbol. -@end deffn - - stack? -@c snarfed from stacks.c:391 -@deffn {Scheme Procedure} stack? obj -@deffnx {C Function} scm_stack_p (obj) -Return @code{#t} if @var{obj} is a calling stack. -@end deffn - - make-stack -@c snarfed from stacks.c:422 -@deffn {Scheme Procedure} make-stack obj . args -@deffnx {C Function} scm_make_stack (obj, args) -Create a new stack. If @var{obj} is @code{#t}, the current -evaluation stack is used for creating the stack frames, -otherwise the frames are taken from @var{obj} (which must be -either a debug object or a continuation). - -@var{args} should be a list containing any combination of -integer, procedure and @code{#t} values. - -These values specify various ways of cutting away uninteresting -stack frames from the top and bottom of the stack that -@code{make-stack} returns. They come in pairs like this: -@code{(@var{inner_cut_1} @var{outer_cut_1} @var{inner_cut_2} -@var{outer_cut_2} @dots{})}. - -Each @var{inner_cut_N} can be @code{#t}, an integer, or a -procedure. @code{#t} means to cut away all frames up to but -excluding the first user module frame. An integer means to cut -away exactly that number of frames. A procedure means to cut -away all frames up to but excluding the application frame whose -procedure matches the specified one. - -Each @var{outer_cut_N} can be an integer or a procedure. An -integer means to cut away that number of frames. A procedure -means to cut away frames down to but excluding the application -frame whose procedure matches the specified one. - -If the @var{outer_cut_N} of the last pair is missing, it is -taken as 0. -@end deffn - - stack-id -@c snarfed from stacks.c:511 -@deffn {Scheme Procedure} stack-id stack -@deffnx {C Function} scm_stack_id (stack) -Return the identifier given to @var{stack} by @code{start-stack}. -@end deffn - - stack-ref -@c snarfed from stacks.c:549 -@deffn {Scheme Procedure} stack-ref stack index -@deffnx {C Function} scm_stack_ref (stack, index) -Return the @var{index}'th frame from @var{stack}. -@end deffn - - stack-length -@c snarfed from stacks.c:562 -@deffn {Scheme Procedure} stack-length stack -@deffnx {C Function} scm_stack_length (stack) -Return the length of @var{stack}. -@end deffn - - frame? -@c snarfed from stacks.c:575 -@deffn {Scheme Procedure} frame? obj -@deffnx {C Function} scm_frame_p (obj) -Return @code{#t} if @var{obj} is a stack frame. -@end deffn - - last-stack-frame -@c snarfed from stacks.c:586 -@deffn {Scheme Procedure} last-stack-frame obj -@deffnx {C Function} scm_last_stack_frame (obj) -Return a stack which consists of a single frame, which is the -last stack frame for @var{obj}. @var{obj} must be either a -debug object or a continuation. -@end deffn - - frame-number -@c snarfed from stacks.c:625 -@deffn {Scheme Procedure} frame-number frame -@deffnx {C Function} scm_frame_number (frame) -Return the frame number of @var{frame}. -@end deffn - - frame-source -@c snarfed from stacks.c:635 -@deffn {Scheme Procedure} frame-source frame -@deffnx {C Function} scm_frame_source (frame) -Return the source of @var{frame}. -@end deffn - - frame-procedure -@c snarfed from stacks.c:646 -@deffn {Scheme Procedure} frame-procedure frame -@deffnx {C Function} scm_frame_procedure (frame) -Return the procedure for @var{frame}, or @code{#f} if no -procedure is associated with @var{frame}. -@end deffn - - frame-arguments -@c snarfed from stacks.c:658 -@deffn {Scheme Procedure} frame-arguments frame -@deffnx {C Function} scm_frame_arguments (frame) -Return the arguments of @var{frame}. -@end deffn - - frame-previous -@c snarfed from stacks.c:669 -@deffn {Scheme Procedure} frame-previous frame -@deffnx {C Function} scm_frame_previous (frame) -Return the previous frame of @var{frame}, or @code{#f} if -@var{frame} is the first frame in its stack. -@end deffn - - frame-next -@c snarfed from stacks.c:685 -@deffn {Scheme Procedure} frame-next frame -@deffnx {C Function} scm_frame_next (frame) -Return the next frame of @var{frame}, or @code{#f} if -@var{frame} is the last frame in its stack. -@end deffn - - frame-real? -@c snarfed from stacks.c:700 -@deffn {Scheme Procedure} frame-real? frame -@deffnx {C Function} scm_frame_real_p (frame) -Return @code{#t} if @var{frame} is a real frame. -@end deffn - - frame-procedure? -@c snarfed from stacks.c:710 -@deffn {Scheme Procedure} frame-procedure? frame -@deffnx {C Function} scm_frame_procedure_p (frame) -Return @code{#t} if a procedure is associated with @var{frame}. -@end deffn - - frame-evaluating-args? -@c snarfed from stacks.c:720 -@deffn {Scheme Procedure} frame-evaluating-args? frame -@deffnx {C Function} scm_frame_evaluating_args_p (frame) -Return @code{#t} if @var{frame} contains evaluated arguments. -@end deffn - - frame-overflow? -@c snarfed from stacks.c:730 -@deffn {Scheme Procedure} frame-overflow? frame -@deffnx {C Function} scm_frame_overflow_p (frame) -Return @code{#t} if @var{frame} is an overflow frame. -@end deffn - - get-internal-real-time -@c snarfed from stime.c:133 -@deffn {Scheme Procedure} get-internal-real-time -@deffnx {C Function} scm_get_internal_real_time () -Return the number of time units since the interpreter was -started. -@end deffn - - times -@c snarfed from stime.c:180 -@deffn {Scheme Procedure} times -@deffnx {C Function} scm_times () -Return an object with information about real and processor -time. The following procedures accept such an object as an -argument and return a selected component: - -@table @code -@item tms:clock -The current real time, expressed as time units relative to an -arbitrary base. -@item tms:utime -The CPU time units used by the calling process. -@item tms:stime -The CPU time units used by the system on behalf of the calling -process. -@item tms:cutime -The CPU time units used by terminated child processes of the -calling process, whose status has been collected (e.g., using -@code{waitpid}). -@item tms:cstime -Similarly, the CPU times units used by the system on behalf of -terminated child processes. -@end table -@end deffn - - get-internal-run-time -@c snarfed from stime.c:212 -@deffn {Scheme Procedure} get-internal-run-time -@deffnx {C Function} scm_get_internal_run_time () -Return the number of time units of processor time used by the -interpreter. Both @emph{system} and @emph{user} time are -included but subprocesses are not. -@end deffn - - current-time -@c snarfed from stime.c:229 -@deffn {Scheme Procedure} current-time -@deffnx {C Function} scm_current_time () -Return the number of seconds since 1970-01-01 00:00:00 UTC, -excluding leap seconds. -@end deffn - - gettimeofday -@c snarfed from stime.c:248 -@deffn {Scheme Procedure} gettimeofday -@deffnx {C Function} scm_gettimeofday () -Return a pair containing the number of seconds and microseconds -since 1970-01-01 00:00:00 UTC, excluding leap seconds. Note: -whether true microsecond resolution is available depends on the -operating system. -@end deffn - - localtime -@c snarfed from stime.c:364 -@deffn {Scheme Procedure} localtime time [zone] -@deffnx {C Function} scm_localtime (time, zone) -Return an object representing the broken down components of -@var{time}, an integer like the one returned by -@code{current-time}. The time zone for the calculation is -optionally specified by @var{zone} (a string), otherwise the -@code{TZ} environment variable or the system default is used. -@end deffn - - gmtime -@c snarfed from stime.c:449 -@deffn {Scheme Procedure} gmtime time -@deffnx {C Function} scm_gmtime (time) -Return an object representing the broken down components of -@var{time}, an integer like the one returned by -@code{current-time}. The values are calculated for UTC. -@end deffn - - mktime -@c snarfed from stime.c:517 -@deffn {Scheme Procedure} mktime sbd_time [zone] -@deffnx {C Function} scm_mktime (sbd_time, zone) -@var{bd-time} is an object representing broken down time and @code{zone} -is an optional time zone specifier (otherwise the TZ environment variable -or the system default is used). - -Returns a pair: the car is a corresponding -integer time value like that returned -by @code{current-time}; the cdr is a broken down time object, similar to -as @var{bd-time} but with normalized values. -@end deffn - - tzset -@c snarfed from stime.c:603 -@deffn {Scheme Procedure} tzset -@deffnx {C Function} scm_tzset () -Initialize the timezone from the TZ environment variable -or the system default. It's not usually necessary to call this procedure -since it's done automatically by other procedures that depend on the -timezone. -@end deffn - - strftime -@c snarfed from stime.c:620 -@deffn {Scheme Procedure} strftime format stime -@deffnx {C Function} scm_strftime (format, stime) -Formats a time specification @var{time} using @var{template}. @var{time} -is an object with time components in the form returned by @code{localtime} -or @code{gmtime}. @var{template} is a string which can include formatting -specifications introduced by a @code{%} character. The formatting of -month and day names is dependent on the current locale. The value returned -is the formatted string. -@xref{Formatting Date and Time, , , libc, The GNU C Library Reference Manual}.) -@end deffn - - strptime -@c snarfed from stime.c:721 -@deffn {Scheme Procedure} strptime format string -@deffnx {C Function} scm_strptime (format, string) -Performs the reverse action to @code{strftime}, parsing -@var{string} according to the specification supplied in -@var{template}. The interpretation of month and day names is -dependent on the current locale. The value returned is a pair. -The car has an object with time components -in the form returned by @code{localtime} or @code{gmtime}, -but the time zone components -are not usefully set. -The cdr reports the number of characters from @var{string} -which were used for the conversion. -@end deffn - - string? -@c snarfed from strings.c:526 -@deffn {Scheme Procedure} string? obj -@deffnx {C Function} scm_string_p (obj) -Return @code{#t} if @var{obj} is a string, else @code{#f}. -@end deffn - - list->string -@c snarfed from strings.c:534 -@deffn {Scheme Procedure} list->string -implemented by the C function "scm_string" -@end deffn - - string -@c snarfed from strings.c:540 -@deffn {Scheme Procedure} string . chrs -@deffnx {Scheme Procedure} list->string chrs -@deffnx {C Function} scm_string (chrs) -Return a newly allocated string composed of the arguments, -@var{chrs}. -@end deffn - - make-string -@c snarfed from strings.c:578 -@deffn {Scheme Procedure} make-string k [chr] -@deffnx {C Function} scm_make_string (k, chr) -Return a newly allocated string of -length @var{k}. If @var{chr} is given, then all elements of -the string are initialized to @var{chr}, otherwise the contents -of the @var{string} are unspecified. -@end deffn - - string-length -@c snarfed from strings.c:604 -@deffn {Scheme Procedure} string-length string -@deffnx {C Function} scm_string_length (string) -Return the number of characters in @var{string}. -@end deffn - - string-ref -@c snarfed from strings.c:623 -@deffn {Scheme Procedure} string-ref str k -@deffnx {C Function} scm_string_ref (str, k) -Return character @var{k} of @var{str} using zero-origin -indexing. @var{k} must be a valid index of @var{str}. -@end deffn - - string-set! -@c snarfed from strings.c:646 -@deffn {Scheme Procedure} string-set! str k chr -@deffnx {C Function} scm_string_set_x (str, k, chr) -Store @var{chr} in element @var{k} of @var{str} and return -an unspecified value. @var{k} must be a valid index of -@var{str}. -@end deffn - - substring -@c snarfed from strings.c:682 -@deffn {Scheme Procedure} substring str start [end] -@deffnx {C Function} scm_substring (str, start, end) -Return a newly allocated string formed from the characters -of @var{str} beginning with index @var{start} (inclusive) and -ending with index @var{end} (exclusive). -@var{str} must be a string, @var{start} and @var{end} must be -exact integers satisfying: - -0 <= @var{start} <= @var{end} <= (string-length @var{str}). -@end deffn - - substring/read-only -@c snarfed from strings.c:708 -@deffn {Scheme Procedure} substring/read-only str start [end] -@deffnx {C Function} scm_substring_read_only (str, start, end) -Return a newly allocated string formed from the characters -of @var{str} beginning with index @var{start} (inclusive) and -ending with index @var{end} (exclusive). -@var{str} must be a string, @var{start} and @var{end} must be -exact integers satisfying: - -0 <= @var{start} <= @var{end} <= (string-length @var{str}). - -The returned string is read-only. - -@end deffn - - substring/copy -@c snarfed from strings.c:731 -@deffn {Scheme Procedure} substring/copy str start [end] -@deffnx {C Function} scm_substring_copy (str, start, end) -Return a newly allocated string formed from the characters -of @var{str} beginning with index @var{start} (inclusive) and -ending with index @var{end} (exclusive). -@var{str} must be a string, @var{start} and @var{end} must be -exact integers satisfying: - -0 <= @var{start} <= @var{end} <= (string-length @var{str}). -@end deffn - - substring/shared -@c snarfed from strings.c:755 -@deffn {Scheme Procedure} substring/shared str start [end] -@deffnx {C Function} scm_substring_shared (str, start, end) -Return string that indirectly refers to the characters -of @var{str} beginning with index @var{start} (inclusive) and -ending with index @var{end} (exclusive). -@var{str} must be a string, @var{start} and @var{end} must be -exact integers satisfying: - -0 <= @var{start} <= @var{end} <= (string-length @var{str}). -@end deffn - - string-append -@c snarfed from strings.c:774 -@deffn {Scheme Procedure} string-append . args -@deffnx {C Function} scm_string_append (args) -Return a newly allocated string whose characters form the -concatenation of the given strings, @var{args}. -@end deffn - - uniform-vector? -@c snarfed from srfi-4.c:651 -@deffn {Scheme Procedure} uniform-vector? obj -@deffnx {C Function} scm_uniform_vector_p (obj) -Return @code{#t} if @var{obj} is a uniform vector. -@end deffn - - uniform-vector-ref -@c snarfed from srfi-4.c:677 -@deffn {Scheme Procedure} uniform-vector-ref v idx -@deffnx {C Function} scm_uniform_vector_ref (v, idx) -Return the element at index @var{idx} of the -homogenous numeric vector @var{v}. -@end deffn - - uniform-vector-set! -@c snarfed from srfi-4.c:714 -@deffn {Scheme Procedure} uniform-vector-set! v idx val -@deffnx {C Function} scm_uniform_vector_set_x (v, idx, val) -Set the element at index @var{idx} of the -homogenous numeric vector @var{v} to @var{val}. -@end deffn - - uniform-vector->list -@c snarfed from srfi-4.c:737 -@deffn {Scheme Procedure} uniform-vector->list uvec -@deffnx {C Function} scm_uniform_vector_to_list (uvec) -Convert the uniform numeric vector @var{uvec} to a list. -@end deffn - - uniform-vector-length -@c snarfed from srfi-4.c:820 -@deffn {Scheme Procedure} uniform-vector-length v -@deffnx {C Function} scm_uniform_vector_length (v) -Return the number of elements in the uniform vector @var{v}. -@end deffn - - uniform-vector-read! -@c snarfed from srfi-4.c:845 -@deffn {Scheme Procedure} uniform-array-read! ura [port_or_fd [start [end]]] -@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end] -@deffnx {C Function} scm_uniform_array_read_x (ura, port_or_fd, start, end) -Attempt to read all elements of @var{ura}, in lexicographic order, as -binary objects from @var{port-or-fdes}. -If an end of file is encountered, -the objects up to that point are put into @var{ura} -(starting at the beginning) and the remainder of the array is -unchanged. - -The optional arguments @var{start} and @var{end} allow -a specified region of a vector (or linearized array) to be read, -leaving the remainder of the vector unchanged. - -@code{uniform-array-read!} returns the number of objects read. -@var{port-or-fdes} may be omitted, in which case it defaults to the value -returned by @code{(current-input-port)}. -@end deffn - - uniform-vector-write -@c snarfed from srfi-4.c:958 -@deffn {Scheme Procedure} uniform-vector-write uvec [port_or_fd [start [end]]] -@deffnx {C Function} scm_uniform_vector_write (uvec, port_or_fd, start, end) -Write the elements of @var{uvec} as raw bytes to -@var{port-or-fdes}, in the host byte order. - -The optional arguments @var{start} (inclusive) -and @var{end} (exclusive) allow -a specified region to be written. - -When @var{port-or-fdes} is a port, all specified elements -of @var{uvec} are attempted to be written, potentially blocking -while waiting for more room. -When @var{port-or-fd} is an integer, a single call to -write(2) is made. - -An error is signalled when the last element has only -been partially written in the single call to write(2). - -The number of objects actually written is returned. -@var{port-or-fdes} may be -omitted, in which case it defaults to the value returned by -@code{(current-output-port)}. -@end deffn - - u8vector? -@c snarfed from ../libguile/srfi-4.i.c:41 -@deffn {Scheme Procedure} u8vector? obj -@deffnx {C Function} scm_u8vector_p (obj) -Return @code{#t} if @var{obj} is a vector of type u8, -@code{#f} otherwise. -@end deffn - - make-u8vector -@c snarfed from ../libguile/srfi-4.i.c:53 -@deffn {Scheme Procedure} make-u8vector len [fill] -@deffnx {C Function} scm_make_u8vector (len, fill) -Return a newly allocated uniform numeric vector which can -hold @var{len} elements. If @var{fill} is given, it is used to -initialize the elements, otherwise the contents of the vector -is unspecified. -@end deffn - - u8vector -@c snarfed from ../libguile/srfi-4.i.c:63 -@deffn {Scheme Procedure} u8vector . l -@deffnx {C Function} scm_u8vector (l) -Return a newly allocated uniform numeric vector containing -all argument values. -@end deffn - - u8vector-length -@c snarfed from ../libguile/srfi-4.i.c:74 -@deffn {Scheme Procedure} u8vector-length uvec -@deffnx {C Function} scm_u8vector_length (uvec) -Return the number of elements in the uniform numeric vector -@var{uvec}. -@end deffn - - u8vector-ref -@c snarfed from ../libguile/srfi-4.i.c:85 -@deffn {Scheme Procedure} u8vector-ref uvec index -@deffnx {C Function} scm_u8vector_ref (uvec, index) -Return the element at @var{index} in the uniform numeric -vector @var{uvec}. -@end deffn - - u8vector-set! -@c snarfed from ../libguile/srfi-4.i.c:97 -@deffn {Scheme Procedure} u8vector-set! uvec index value -@deffnx {C Function} scm_u8vector_set_x (uvec, index, value) -Set the element at @var{index} in the uniform numeric -vector @var{uvec} to @var{value}. The return value is not -specified. -@end deffn - - u8vector->list -@c snarfed from ../libguile/srfi-4.i.c:107 -@deffn {Scheme Procedure} u8vector->list uvec -@deffnx {C Function} scm_u8vector_to_list (uvec) -Convert the uniform numeric vector @var{uvec} to a list. -@end deffn - - list->u8vector -@c snarfed from ../libguile/srfi-4.i.c:117 -@deffn {Scheme Procedure} list->u8vector l -@deffnx {C Function} scm_list_to_u8vector (l) -Convert the list @var{l} to a numeric uniform vector. -@end deffn - - any->u8vector -@c snarfed from ../libguile/srfi-4.i.c:128 -@deffn {Scheme Procedure} any->u8vector obj -@deffnx {C Function} scm_any_to_u8vector (obj) -Convert @var{obj}, which can be a list, vector, or -uniform vector, to a numeric uniform vector of -type u8. -@end deffn - - s8vector? -@c snarfed from ../libguile/srfi-4.i.c:41 -@deffn {Scheme Procedure} s8vector? obj -@deffnx {C Function} scm_s8vector_p (obj) -Return @code{#t} if @var{obj} is a vector of type s8, -@code{#f} otherwise. -@end deffn - - make-s8vector -@c snarfed from ../libguile/srfi-4.i.c:53 -@deffn {Scheme Procedure} make-s8vector len [fill] -@deffnx {C Function} scm_make_s8vector (len, fill) -Return a newly allocated uniform numeric vector which can -hold @var{len} elements. If @var{fill} is given, it is used to -initialize the elements, otherwise the contents of the vector -is unspecified. -@end deffn - - s8vector -@c snarfed from ../libguile/srfi-4.i.c:63 -@deffn {Scheme Procedure} s8vector . l -@deffnx {C Function} scm_s8vector (l) -Return a newly allocated uniform numeric vector containing -all argument values. -@end deffn - - s8vector-length -@c snarfed from ../libguile/srfi-4.i.c:74 -@deffn {Scheme Procedure} s8vector-length uvec -@deffnx {C Function} scm_s8vector_length (uvec) -Return the number of elements in the uniform numeric vector -@var{uvec}. -@end deffn - - s8vector-ref -@c snarfed from ../libguile/srfi-4.i.c:85 -@deffn {Scheme Procedure} s8vector-ref uvec index -@deffnx {C Function} scm_s8vector_ref (uvec, index) -Return the element at @var{index} in the uniform numeric -vector @var{uvec}. -@end deffn - - s8vector-set! -@c snarfed from ../libguile/srfi-4.i.c:97 -@deffn {Scheme Procedure} s8vector-set! uvec index value -@deffnx {C Function} scm_s8vector_set_x (uvec, index, value) -Set the element at @var{index} in the uniform numeric -vector @var{uvec} to @var{value}. The return value is not -specified. -@end deffn - - s8vector->list -@c snarfed from ../libguile/srfi-4.i.c:107 -@deffn {Scheme Procedure} s8vector->list uvec -@deffnx {C Function} scm_s8vector_to_list (uvec) -Convert the uniform numeric vector @var{uvec} to a list. -@end deffn - - list->s8vector -@c snarfed from ../libguile/srfi-4.i.c:117 -@deffn {Scheme Procedure} list->s8vector l -@deffnx {C Function} scm_list_to_s8vector (l) -Convert the list @var{l} to a numeric uniform vector. -@end deffn - - any->s8vector -@c snarfed from ../libguile/srfi-4.i.c:128 -@deffn {Scheme Procedure} any->s8vector obj -@deffnx {C Function} scm_any_to_s8vector (obj) -Convert @var{obj}, which can be a list, vector, or -uniform vector, to a numeric uniform vector of -type s8. -@end deffn - - u16vector? -@c snarfed from ../libguile/srfi-4.i.c:41 -@deffn {Scheme Procedure} u16vector? obj -@deffnx {C Function} scm_u16vector_p (obj) -Return @code{#t} if @var{obj} is a vector of type u16, -@code{#f} otherwise. -@end deffn - - make-u16vector -@c snarfed from ../libguile/srfi-4.i.c:53 -@deffn {Scheme Procedure} make-u16vector len [fill] -@deffnx {C Function} scm_make_u16vector (len, fill) -Return a newly allocated uniform numeric vector which can -hold @var{len} elements. If @var{fill} is given, it is used to -initialize the elements, otherwise the contents of the vector -is unspecified. -@end deffn - - u16vector -@c snarfed from ../libguile/srfi-4.i.c:63 -@deffn {Scheme Procedure} u16vector . l -@deffnx {C Function} scm_u16vector (l) -Return a newly allocated uniform numeric vector containing -all argument values. -@end deffn - - u16vector-length -@c snarfed from ../libguile/srfi-4.i.c:74 -@deffn {Scheme Procedure} u16vector-length uvec -@deffnx {C Function} scm_u16vector_length (uvec) -Return the number of elements in the uniform numeric vector -@var{uvec}. -@end deffn - - u16vector-ref -@c snarfed from ../libguile/srfi-4.i.c:85 -@deffn {Scheme Procedure} u16vector-ref uvec index -@deffnx {C Function} scm_u16vector_ref (uvec, index) -Return the element at @var{index} in the uniform numeric -vector @var{uvec}. -@end deffn - - u16vector-set! -@c snarfed from ../libguile/srfi-4.i.c:97 -@deffn {Scheme Procedure} u16vector-set! uvec index value -@deffnx {C Function} scm_u16vector_set_x (uvec, index, value) -Set the element at @var{index} in the uniform numeric -vector @var{uvec} to @var{value}. The return value is not -specified. -@end deffn - - u16vector->list -@c snarfed from ../libguile/srfi-4.i.c:107 -@deffn {Scheme Procedure} u16vector->list uvec -@deffnx {C Function} scm_u16vector_to_list (uvec) -Convert the uniform numeric vector @var{uvec} to a list. -@end deffn - - list->u16vector -@c snarfed from ../libguile/srfi-4.i.c:117 -@deffn {Scheme Procedure} list->u16vector l -@deffnx {C Function} scm_list_to_u16vector (l) -Convert the list @var{l} to a numeric uniform vector. -@end deffn - - any->u16vector -@c snarfed from ../libguile/srfi-4.i.c:128 -@deffn {Scheme Procedure} any->u16vector obj -@deffnx {C Function} scm_any_to_u16vector (obj) -Convert @var{obj}, which can be a list, vector, or -uniform vector, to a numeric uniform vector of -type u16. -@end deffn - - s16vector? -@c snarfed from ../libguile/srfi-4.i.c:41 -@deffn {Scheme Procedure} s16vector? obj -@deffnx {C Function} scm_s16vector_p (obj) -Return @code{#t} if @var{obj} is a vector of type s16, -@code{#f} otherwise. -@end deffn - - make-s16vector -@c snarfed from ../libguile/srfi-4.i.c:53 -@deffn {Scheme Procedure} make-s16vector len [fill] -@deffnx {C Function} scm_make_s16vector (len, fill) -Return a newly allocated uniform numeric vector which can -hold @var{len} elements. If @var{fill} is given, it is used to -initialize the elements, otherwise the contents of the vector -is unspecified. -@end deffn - - s16vector -@c snarfed from ../libguile/srfi-4.i.c:63 -@deffn {Scheme Procedure} s16vector . l -@deffnx {C Function} scm_s16vector (l) -Return a newly allocated uniform numeric vector containing -all argument values. -@end deffn - - s16vector-length -@c snarfed from ../libguile/srfi-4.i.c:74 -@deffn {Scheme Procedure} s16vector-length uvec -@deffnx {C Function} scm_s16vector_length (uvec) -Return the number of elements in the uniform numeric vector -@var{uvec}. -@end deffn - - s16vector-ref -@c snarfed from ../libguile/srfi-4.i.c:85 -@deffn {Scheme Procedure} s16vector-ref uvec index -@deffnx {C Function} scm_s16vector_ref (uvec, index) -Return the element at @var{index} in the uniform numeric -vector @var{uvec}. -@end deffn - - s16vector-set! -@c snarfed from ../libguile/srfi-4.i.c:97 -@deffn {Scheme Procedure} s16vector-set! uvec index value -@deffnx {C Function} scm_s16vector_set_x (uvec, index, value) -Set the element at @var{index} in the uniform numeric -vector @var{uvec} to @var{value}. The return value is not -specified. -@end deffn - - s16vector->list -@c snarfed from ../libguile/srfi-4.i.c:107 -@deffn {Scheme Procedure} s16vector->list uvec -@deffnx {C Function} scm_s16vector_to_list (uvec) -Convert the uniform numeric vector @var{uvec} to a list. -@end deffn - - list->s16vector -@c snarfed from ../libguile/srfi-4.i.c:117 -@deffn {Scheme Procedure} list->s16vector l -@deffnx {C Function} scm_list_to_s16vector (l) -Convert the list @var{l} to a numeric uniform vector. -@end deffn - - any->s16vector -@c snarfed from ../libguile/srfi-4.i.c:128 -@deffn {Scheme Procedure} any->s16vector obj -@deffnx {C Function} scm_any_to_s16vector (obj) -Convert @var{obj}, which can be a list, vector, or -uniform vector, to a numeric uniform vector of -type s16. -@end deffn - - u32vector? -@c snarfed from ../libguile/srfi-4.i.c:41 -@deffn {Scheme Procedure} u32vector? obj -@deffnx {C Function} scm_u32vector_p (obj) -Return @code{#t} if @var{obj} is a vector of type u32, -@code{#f} otherwise. -@end deffn - - make-u32vector -@c snarfed from ../libguile/srfi-4.i.c:53 -@deffn {Scheme Procedure} make-u32vector len [fill] -@deffnx {C Function} scm_make_u32vector (len, fill) -Return a newly allocated uniform numeric vector which can -hold @var{len} elements. If @var{fill} is given, it is used to -initialize the elements, otherwise the contents of the vector -is unspecified. -@end deffn - - u32vector -@c snarfed from ../libguile/srfi-4.i.c:63 -@deffn {Scheme Procedure} u32vector . l -@deffnx {C Function} scm_u32vector (l) -Return a newly allocated uniform numeric vector containing -all argument values. -@end deffn - - u32vector-length -@c snarfed from ../libguile/srfi-4.i.c:74 -@deffn {Scheme Procedure} u32vector-length uvec -@deffnx {C Function} scm_u32vector_length (uvec) -Return the number of elements in the uniform numeric vector -@var{uvec}. -@end deffn - - u32vector-ref -@c snarfed from ../libguile/srfi-4.i.c:85 -@deffn {Scheme Procedure} u32vector-ref uvec index -@deffnx {C Function} scm_u32vector_ref (uvec, index) -Return the element at @var{index} in the uniform numeric -vector @var{uvec}. -@end deffn - - u32vector-set! -@c snarfed from ../libguile/srfi-4.i.c:97 -@deffn {Scheme Procedure} u32vector-set! uvec index value -@deffnx {C Function} scm_u32vector_set_x (uvec, index, value) -Set the element at @var{index} in the uniform numeric -vector @var{uvec} to @var{value}. The return value is not -specified. -@end deffn - - u32vector->list -@c snarfed from ../libguile/srfi-4.i.c:107 -@deffn {Scheme Procedure} u32vector->list uvec -@deffnx {C Function} scm_u32vector_to_list (uvec) -Convert the uniform numeric vector @var{uvec} to a list. -@end deffn - - list->u32vector -@c snarfed from ../libguile/srfi-4.i.c:117 -@deffn {Scheme Procedure} list->u32vector l -@deffnx {C Function} scm_list_to_u32vector (l) -Convert the list @var{l} to a numeric uniform vector. -@end deffn - - any->u32vector -@c snarfed from ../libguile/srfi-4.i.c:128 -@deffn {Scheme Procedure} any->u32vector obj -@deffnx {C Function} scm_any_to_u32vector (obj) -Convert @var{obj}, which can be a list, vector, or -uniform vector, to a numeric uniform vector of -type u32. -@end deffn - - s32vector? -@c snarfed from ../libguile/srfi-4.i.c:41 -@deffn {Scheme Procedure} s32vector? obj -@deffnx {C Function} scm_s32vector_p (obj) -Return @code{#t} if @var{obj} is a vector of type s32, -@code{#f} otherwise. -@end deffn - - make-s32vector -@c snarfed from ../libguile/srfi-4.i.c:53 -@deffn {Scheme Procedure} make-s32vector len [fill] -@deffnx {C Function} scm_make_s32vector (len, fill) -Return a newly allocated uniform numeric vector which can -hold @var{len} elements. If @var{fill} is given, it is used to -initialize the elements, otherwise the contents of the vector -is unspecified. -@end deffn - - s32vector -@c snarfed from ../libguile/srfi-4.i.c:63 -@deffn {Scheme Procedure} s32vector . l -@deffnx {C Function} scm_s32vector (l) -Return a newly allocated uniform numeric vector containing -all argument values. -@end deffn - - s32vector-length -@c snarfed from ../libguile/srfi-4.i.c:74 -@deffn {Scheme Procedure} s32vector-length uvec -@deffnx {C Function} scm_s32vector_length (uvec) -Return the number of elements in the uniform numeric vector -@var{uvec}. -@end deffn - - s32vector-ref -@c snarfed from ../libguile/srfi-4.i.c:85 -@deffn {Scheme Procedure} s32vector-ref uvec index -@deffnx {C Function} scm_s32vector_ref (uvec, index) -Return the element at @var{index} in the uniform numeric -vector @var{uvec}. -@end deffn - - s32vector-set! -@c snarfed from ../libguile/srfi-4.i.c:97 -@deffn {Scheme Procedure} s32vector-set! uvec index value -@deffnx {C Function} scm_s32vector_set_x (uvec, index, value) -Set the element at @var{index} in the uniform numeric -vector @var{uvec} to @var{value}. The return value is not -specified. -@end deffn - - s32vector->list -@c snarfed from ../libguile/srfi-4.i.c:107 -@deffn {Scheme Procedure} s32vector->list uvec -@deffnx {C Function} scm_s32vector_to_list (uvec) -Convert the uniform numeric vector @var{uvec} to a list. -@end deffn - - list->s32vector -@c snarfed from ../libguile/srfi-4.i.c:117 -@deffn {Scheme Procedure} list->s32vector l -@deffnx {C Function} scm_list_to_s32vector (l) -Convert the list @var{l} to a numeric uniform vector. -@end deffn - - any->s32vector -@c snarfed from ../libguile/srfi-4.i.c:128 -@deffn {Scheme Procedure} any->s32vector obj -@deffnx {C Function} scm_any_to_s32vector (obj) -Convert @var{obj}, which can be a list, vector, or -uniform vector, to a numeric uniform vector of -type s32. -@end deffn - - u64vector? -@c snarfed from ../libguile/srfi-4.i.c:41 -@deffn {Scheme Procedure} u64vector? obj -@deffnx {C Function} scm_u64vector_p (obj) -Return @code{#t} if @var{obj} is a vector of type u64, -@code{#f} otherwise. -@end deffn - - make-u64vector -@c snarfed from ../libguile/srfi-4.i.c:53 -@deffn {Scheme Procedure} make-u64vector len [fill] -@deffnx {C Function} scm_make_u64vector (len, fill) -Return a newly allocated uniform numeric vector which can -hold @var{len} elements. If @var{fill} is given, it is used to -initialize the elements, otherwise the contents of the vector -is unspecified. -@end deffn - - u64vector -@c snarfed from ../libguile/srfi-4.i.c:63 -@deffn {Scheme Procedure} u64vector . l -@deffnx {C Function} scm_u64vector (l) -Return a newly allocated uniform numeric vector containing -all argument values. -@end deffn - - u64vector-length -@c snarfed from ../libguile/srfi-4.i.c:74 -@deffn {Scheme Procedure} u64vector-length uvec -@deffnx {C Function} scm_u64vector_length (uvec) -Return the number of elements in the uniform numeric vector -@var{uvec}. -@end deffn - - u64vector-ref -@c snarfed from ../libguile/srfi-4.i.c:85 -@deffn {Scheme Procedure} u64vector-ref uvec index -@deffnx {C Function} scm_u64vector_ref (uvec, index) -Return the element at @var{index} in the uniform numeric -vector @var{uvec}. -@end deffn - - u64vector-set! -@c snarfed from ../libguile/srfi-4.i.c:97 -@deffn {Scheme Procedure} u64vector-set! uvec index value -@deffnx {C Function} scm_u64vector_set_x (uvec, index, value) -Set the element at @var{index} in the uniform numeric -vector @var{uvec} to @var{value}. The return value is not -specified. -@end deffn - - u64vector->list -@c snarfed from ../libguile/srfi-4.i.c:107 -@deffn {Scheme Procedure} u64vector->list uvec -@deffnx {C Function} scm_u64vector_to_list (uvec) -Convert the uniform numeric vector @var{uvec} to a list. -@end deffn - - list->u64vector -@c snarfed from ../libguile/srfi-4.i.c:117 -@deffn {Scheme Procedure} list->u64vector l -@deffnx {C Function} scm_list_to_u64vector (l) -Convert the list @var{l} to a numeric uniform vector. -@end deffn - - any->u64vector -@c snarfed from ../libguile/srfi-4.i.c:128 -@deffn {Scheme Procedure} any->u64vector obj -@deffnx {C Function} scm_any_to_u64vector (obj) -Convert @var{obj}, which can be a list, vector, or -uniform vector, to a numeric uniform vector of -type u64. -@end deffn - - s64vector? -@c snarfed from ../libguile/srfi-4.i.c:41 -@deffn {Scheme Procedure} s64vector? obj -@deffnx {C Function} scm_s64vector_p (obj) -Return @code{#t} if @var{obj} is a vector of type s64, -@code{#f} otherwise. -@end deffn - - make-s64vector -@c snarfed from ../libguile/srfi-4.i.c:53 -@deffn {Scheme Procedure} make-s64vector len [fill] -@deffnx {C Function} scm_make_s64vector (len, fill) -Return a newly allocated uniform numeric vector which can -hold @var{len} elements. If @var{fill} is given, it is used to -initialize the elements, otherwise the contents of the vector -is unspecified. -@end deffn - - s64vector -@c snarfed from ../libguile/srfi-4.i.c:63 -@deffn {Scheme Procedure} s64vector . l -@deffnx {C Function} scm_s64vector (l) -Return a newly allocated uniform numeric vector containing -all argument values. -@end deffn - - s64vector-length -@c snarfed from ../libguile/srfi-4.i.c:74 -@deffn {Scheme Procedure} s64vector-length uvec -@deffnx {C Function} scm_s64vector_length (uvec) -Return the number of elements in the uniform numeric vector -@var{uvec}. -@end deffn - - s64vector-ref -@c snarfed from ../libguile/srfi-4.i.c:85 -@deffn {Scheme Procedure} s64vector-ref uvec index -@deffnx {C Function} scm_s64vector_ref (uvec, index) -Return the element at @var{index} in the uniform numeric -vector @var{uvec}. -@end deffn - - s64vector-set! -@c snarfed from ../libguile/srfi-4.i.c:97 -@deffn {Scheme Procedure} s64vector-set! uvec index value -@deffnx {C Function} scm_s64vector_set_x (uvec, index, value) -Set the element at @var{index} in the uniform numeric -vector @var{uvec} to @var{value}. The return value is not -specified. -@end deffn - - s64vector->list -@c snarfed from ../libguile/srfi-4.i.c:107 -@deffn {Scheme Procedure} s64vector->list uvec -@deffnx {C Function} scm_s64vector_to_list (uvec) -Convert the uniform numeric vector @var{uvec} to a list. -@end deffn - - list->s64vector -@c snarfed from ../libguile/srfi-4.i.c:117 -@deffn {Scheme Procedure} list->s64vector l -@deffnx {C Function} scm_list_to_s64vector (l) -Convert the list @var{l} to a numeric uniform vector. -@end deffn - - any->s64vector -@c snarfed from ../libguile/srfi-4.i.c:128 -@deffn {Scheme Procedure} any->s64vector obj -@deffnx {C Function} scm_any_to_s64vector (obj) -Convert @var{obj}, which can be a list, vector, or -uniform vector, to a numeric uniform vector of -type s64. -@end deffn - - f32vector? -@c snarfed from ../libguile/srfi-4.i.c:41 -@deffn {Scheme Procedure} f32vector? obj -@deffnx {C Function} scm_f32vector_p (obj) -Return @code{#t} if @var{obj} is a vector of type f32, -@code{#f} otherwise. -@end deffn - - make-f32vector -@c snarfed from ../libguile/srfi-4.i.c:53 -@deffn {Scheme Procedure} make-f32vector len [fill] -@deffnx {C Function} scm_make_f32vector (len, fill) -Return a newly allocated uniform numeric vector which can -hold @var{len} elements. If @var{fill} is given, it is used to -initialize the elements, otherwise the contents of the vector -is unspecified. -@end deffn - - f32vector -@c snarfed from ../libguile/srfi-4.i.c:63 -@deffn {Scheme Procedure} f32vector . l -@deffnx {C Function} scm_f32vector (l) -Return a newly allocated uniform numeric vector containing -all argument values. -@end deffn - - f32vector-length -@c snarfed from ../libguile/srfi-4.i.c:74 -@deffn {Scheme Procedure} f32vector-length uvec -@deffnx {C Function} scm_f32vector_length (uvec) -Return the number of elements in the uniform numeric vector -@var{uvec}. -@end deffn - - f32vector-ref -@c snarfed from ../libguile/srfi-4.i.c:85 -@deffn {Scheme Procedure} f32vector-ref uvec index -@deffnx {C Function} scm_f32vector_ref (uvec, index) -Return the element at @var{index} in the uniform numeric -vector @var{uvec}. -@end deffn - - f32vector-set! -@c snarfed from ../libguile/srfi-4.i.c:97 -@deffn {Scheme Procedure} f32vector-set! uvec index value -@deffnx {C Function} scm_f32vector_set_x (uvec, index, value) -Set the element at @var{index} in the uniform numeric -vector @var{uvec} to @var{value}. The return value is not -specified. -@end deffn - - f32vector->list -@c snarfed from ../libguile/srfi-4.i.c:107 -@deffn {Scheme Procedure} f32vector->list uvec -@deffnx {C Function} scm_f32vector_to_list (uvec) -Convert the uniform numeric vector @var{uvec} to a list. -@end deffn - - list->f32vector -@c snarfed from ../libguile/srfi-4.i.c:117 -@deffn {Scheme Procedure} list->f32vector l -@deffnx {C Function} scm_list_to_f32vector (l) -Convert the list @var{l} to a numeric uniform vector. -@end deffn - - any->f32vector -@c snarfed from ../libguile/srfi-4.i.c:128 -@deffn {Scheme Procedure} any->f32vector obj -@deffnx {C Function} scm_any_to_f32vector (obj) -Convert @var{obj}, which can be a list, vector, or -uniform vector, to a numeric uniform vector of -type f32. -@end deffn - - f64vector? -@c snarfed from ../libguile/srfi-4.i.c:41 -@deffn {Scheme Procedure} f64vector? obj -@deffnx {C Function} scm_f64vector_p (obj) -Return @code{#t} if @var{obj} is a vector of type f64, -@code{#f} otherwise. -@end deffn - - make-f64vector -@c snarfed from ../libguile/srfi-4.i.c:53 -@deffn {Scheme Procedure} make-f64vector len [fill] -@deffnx {C Function} scm_make_f64vector (len, fill) -Return a newly allocated uniform numeric vector which can -hold @var{len} elements. If @var{fill} is given, it is used to -initialize the elements, otherwise the contents of the vector -is unspecified. -@end deffn - - f64vector -@c snarfed from ../libguile/srfi-4.i.c:63 -@deffn {Scheme Procedure} f64vector . l -@deffnx {C Function} scm_f64vector (l) -Return a newly allocated uniform numeric vector containing -all argument values. -@end deffn - - f64vector-length -@c snarfed from ../libguile/srfi-4.i.c:74 -@deffn {Scheme Procedure} f64vector-length uvec -@deffnx {C Function} scm_f64vector_length (uvec) -Return the number of elements in the uniform numeric vector -@var{uvec}. -@end deffn - - f64vector-ref -@c snarfed from ../libguile/srfi-4.i.c:85 -@deffn {Scheme Procedure} f64vector-ref uvec index -@deffnx {C Function} scm_f64vector_ref (uvec, index) -Return the element at @var{index} in the uniform numeric -vector @var{uvec}. -@end deffn - - f64vector-set! -@c snarfed from ../libguile/srfi-4.i.c:97 -@deffn {Scheme Procedure} f64vector-set! uvec index value -@deffnx {C Function} scm_f64vector_set_x (uvec, index, value) -Set the element at @var{index} in the uniform numeric -vector @var{uvec} to @var{value}. The return value is not -specified. -@end deffn - - f64vector->list -@c snarfed from ../libguile/srfi-4.i.c:107 -@deffn {Scheme Procedure} f64vector->list uvec -@deffnx {C Function} scm_f64vector_to_list (uvec) -Convert the uniform numeric vector @var{uvec} to a list. -@end deffn - - list->f64vector -@c snarfed from ../libguile/srfi-4.i.c:117 -@deffn {Scheme Procedure} list->f64vector l -@deffnx {C Function} scm_list_to_f64vector (l) -Convert the list @var{l} to a numeric uniform vector. -@end deffn - - any->f64vector -@c snarfed from ../libguile/srfi-4.i.c:128 -@deffn {Scheme Procedure} any->f64vector obj -@deffnx {C Function} scm_any_to_f64vector (obj) -Convert @var{obj}, which can be a list, vector, or -uniform vector, to a numeric uniform vector of -type f64. -@end deffn - - c32vector? -@c snarfed from ../libguile/srfi-4.i.c:41 -@deffn {Scheme Procedure} c32vector? obj -@deffnx {C Function} scm_c32vector_p (obj) -Return @code{#t} if @var{obj} is a vector of type c32, -@code{#f} otherwise. -@end deffn - - make-c32vector -@c snarfed from ../libguile/srfi-4.i.c:53 -@deffn {Scheme Procedure} make-c32vector len [fill] -@deffnx {C Function} scm_make_c32vector (len, fill) -Return a newly allocated uniform numeric vector which can -hold @var{len} elements. If @var{fill} is given, it is used to -initialize the elements, otherwise the contents of the vector -is unspecified. -@end deffn - - c32vector -@c snarfed from ../libguile/srfi-4.i.c:63 -@deffn {Scheme Procedure} c32vector . l -@deffnx {C Function} scm_c32vector (l) -Return a newly allocated uniform numeric vector containing -all argument values. -@end deffn - - c32vector-length -@c snarfed from ../libguile/srfi-4.i.c:74 -@deffn {Scheme Procedure} c32vector-length uvec -@deffnx {C Function} scm_c32vector_length (uvec) -Return the number of elements in the uniform numeric vector -@var{uvec}. -@end deffn - - c32vector-ref -@c snarfed from ../libguile/srfi-4.i.c:85 -@deffn {Scheme Procedure} c32vector-ref uvec index -@deffnx {C Function} scm_c32vector_ref (uvec, index) -Return the element at @var{index} in the uniform numeric -vector @var{uvec}. -@end deffn - - c32vector-set! -@c snarfed from ../libguile/srfi-4.i.c:97 -@deffn {Scheme Procedure} c32vector-set! uvec index value -@deffnx {C Function} scm_c32vector_set_x (uvec, index, value) -Set the element at @var{index} in the uniform numeric -vector @var{uvec} to @var{value}. The return value is not -specified. -@end deffn - - c32vector->list -@c snarfed from ../libguile/srfi-4.i.c:107 -@deffn {Scheme Procedure} c32vector->list uvec -@deffnx {C Function} scm_c32vector_to_list (uvec) -Convert the uniform numeric vector @var{uvec} to a list. -@end deffn - - list->c32vector -@c snarfed from ../libguile/srfi-4.i.c:117 -@deffn {Scheme Procedure} list->c32vector l -@deffnx {C Function} scm_list_to_c32vector (l) -Convert the list @var{l} to a numeric uniform vector. -@end deffn - - any->c32vector -@c snarfed from ../libguile/srfi-4.i.c:128 -@deffn {Scheme Procedure} any->c32vector obj -@deffnx {C Function} scm_any_to_c32vector (obj) -Convert @var{obj}, which can be a list, vector, or -uniform vector, to a numeric uniform vector of -type c32. -@end deffn - - c64vector? -@c snarfed from ../libguile/srfi-4.i.c:41 -@deffn {Scheme Procedure} c64vector? obj -@deffnx {C Function} scm_c64vector_p (obj) -Return @code{#t} if @var{obj} is a vector of type c64, -@code{#f} otherwise. -@end deffn - - make-c64vector -@c snarfed from ../libguile/srfi-4.i.c:53 -@deffn {Scheme Procedure} make-c64vector len [fill] -@deffnx {C Function} scm_make_c64vector (len, fill) -Return a newly allocated uniform numeric vector which can -hold @var{len} elements. If @var{fill} is given, it is used to -initialize the elements, otherwise the contents of the vector -is unspecified. -@end deffn - - c64vector -@c snarfed from ../libguile/srfi-4.i.c:63 -@deffn {Scheme Procedure} c64vector . l -@deffnx {C Function} scm_c64vector (l) -Return a newly allocated uniform numeric vector containing -all argument values. -@end deffn - - c64vector-length -@c snarfed from ../libguile/srfi-4.i.c:74 -@deffn {Scheme Procedure} c64vector-length uvec -@deffnx {C Function} scm_c64vector_length (uvec) -Return the number of elements in the uniform numeric vector -@var{uvec}. -@end deffn - - c64vector-ref -@c snarfed from ../libguile/srfi-4.i.c:85 -@deffn {Scheme Procedure} c64vector-ref uvec index -@deffnx {C Function} scm_c64vector_ref (uvec, index) -Return the element at @var{index} in the uniform numeric -vector @var{uvec}. -@end deffn - - c64vector-set! -@c snarfed from ../libguile/srfi-4.i.c:97 -@deffn {Scheme Procedure} c64vector-set! uvec index value -@deffnx {C Function} scm_c64vector_set_x (uvec, index, value) -Set the element at @var{index} in the uniform numeric -vector @var{uvec} to @var{value}. The return value is not -specified. -@end deffn - - c64vector->list -@c snarfed from ../libguile/srfi-4.i.c:107 -@deffn {Scheme Procedure} c64vector->list uvec -@deffnx {C Function} scm_c64vector_to_list (uvec) -Convert the uniform numeric vector @var{uvec} to a list. -@end deffn - - list->c64vector -@c snarfed from ../libguile/srfi-4.i.c:117 -@deffn {Scheme Procedure} list->c64vector l -@deffnx {C Function} scm_list_to_c64vector (l) -Convert the list @var{l} to a numeric uniform vector. -@end deffn - - any->c64vector -@c snarfed from ../libguile/srfi-4.i.c:128 -@deffn {Scheme Procedure} any->c64vector obj -@deffnx {C Function} scm_any_to_c64vector (obj) -Convert @var{obj}, which can be a list, vector, or -uniform vector, to a numeric uniform vector of -type c64. -@end deffn - - string-null? -@c snarfed from srfi-13.c:62 -@deffn {Scheme Procedure} string-null? str -@deffnx {C Function} scm_string_null_p (str) -Return @code{#t} if @var{str}'s length is zero, and -@code{#f} otherwise. -@lisp -(string-null? "") @result{} #t -y @result{} "foo" -(string-null? y) @result{} #f -@end lisp -@end deffn - - string-any-c-code -@c snarfed from srfi-13.c:94 -@deffn {Scheme Procedure} string-any-c-code char_pred s [start [end]] -@deffnx {C Function} scm_string_any (char_pred, s, start, end) -Check if @var{char_pred} is true for any character in string @var{s}. - -@var{char_pred} can be a character to check for any equal to that, or -a character set (@pxref{Character Sets}) to check for any in that set, -or a predicate procedure to call. - -For a procedure, calls @code{(@var{char_pred} c)} are made -successively on the characters from @var{start} to @var{end}. If -@var{char_pred} returns true (ie.@: non-@code{#f}), @code{string-any} -stops and that return value is the return from @code{string-any}. The -call on the last character (ie.@: at @math{@var{end}-1}), if that -point is reached, is a tail call. - -If there are no characters in @var{s} (ie.@: @var{start} equals -@var{end}) then the return is @code{#f}. - -@end deffn - - string-every-c-code -@c snarfed from srfi-13.c:158 -@deffn {Scheme Procedure} string-every-c-code char_pred s [start [end]] -@deffnx {C Function} scm_string_every (char_pred, s, start, end) -Check if @var{char_pred} is true for every character in string -@var{s}. - -@var{char_pred} can be a character to check for every character equal -to that, or a character set (@pxref{Character Sets}) to check for -every character being in that set, or a predicate procedure to call. - -For a procedure, calls @code{(@var{char_pred} c)} are made -successively on the characters from @var{start} to @var{end}. If -@var{char_pred} returns @code{#f}, @code{string-every} stops and -returns @code{#f}. The call on the last character (ie.@: at -@math{@var{end}-1}), if that point is reached, is a tail call and the -return from that call is the return from @code{string-every}. - -If there are no characters in @var{s} (ie.@: @var{start} equals -@var{end}) then the return is @code{#t}. - -@end deffn - - string-tabulate -@c snarfed from srfi-13.c:214 -@deffn {Scheme Procedure} string-tabulate proc len -@deffnx {C Function} scm_string_tabulate (proc, len) -@var{proc} is an integer->char procedure. Construct a string -of size @var{len} by applying @var{proc} to each index to -produce the corresponding string element. The order in which -@var{proc} is applied to the indices is not specified. -@end deffn - - string->list -@c snarfed from srfi-13.c:246 -@deffn {Scheme Procedure} string->list str [start [end]] -@deffnx {C Function} scm_substring_to_list (str, start, end) -Convert the string @var{str} into a list of characters. -@end deffn - - reverse-list->string -@c snarfed from srfi-13.c:285 -@deffn {Scheme Procedure} reverse-list->string chrs -@deffnx {C Function} scm_reverse_list_to_string (chrs) -An efficient implementation of @code{(compose string->list -reverse)}: - -@smalllisp -(reverse-list->string '(#\a #\B #\c)) @result{} "cBa" -@end smalllisp -@end deffn - - string-join -@c snarfed from srfi-13.c:352 -@deffn {Scheme Procedure} string-join ls [delimiter [grammar]] -@deffnx {C Function} scm_string_join (ls, delimiter, grammar) -Append the string in the string list @var{ls}, using the string -@var{delim} as a delimiter between the elements of @var{ls}. -@var{grammar} is a symbol which specifies how the delimiter is -placed between the strings, and defaults to the symbol -@code{infix}. - -@table @code -@item infix -Insert the separator between list elements. An empty string -will produce an empty list. -@item string-infix -Like @code{infix}, but will raise an error if given the empty -list. -@item suffix -Insert the separator after every list element. -@item prefix -Insert the separator before each list element. -@end table -@end deffn - - string-copy -@c snarfed from srfi-13.c:486 -@deffn {Scheme Procedure} string-copy str [start [end]] -@deffnx {C Function} scm_srfi13_substring_copy (str, start, end) -Return a freshly allocated copy of the string @var{str}. If -given, @var{start} and @var{end} delimit the portion of -@var{str} which is copied. -@end deffn - - string-copy! -@c snarfed from srfi-13.c:513 -@deffn {Scheme Procedure} string-copy! target tstart s [start [end]] -@deffnx {C Function} scm_string_copy_x (target, tstart, s, start, end) -Copy the sequence of characters from index range [@var{start}, -@var{end}) in string @var{s} to string @var{target}, beginning -at index @var{tstart}. The characters are copied left-to-right -or right-to-left as needed -- the copy is guaranteed to work, -even if @var{target} and @var{s} are the same string. It is an -error if the copy operation runs off the end of the target -string. -@end deffn - - substring-move! -@c snarfed from srfi-13.c:543 -@deffn {Scheme Procedure} substring-move! str1 start1 end1 str2 start2 -@deffnx {C Function} scm_substring_move_x (str1, start1, end1, str2, start2) -Copy the substring of @var{str1} bounded by @var{start1} and @var{end1} -into @var{str2} beginning at position @var{start2}. -@var{str1} and @var{str2} can be the same string. -@end deffn - - string-take -@c snarfed from srfi-13.c:552 -@deffn {Scheme Procedure} string-take s n -@deffnx {C Function} scm_string_take (s, n) -Return the @var{n} first characters of @var{s}. -@end deffn - - string-drop -@c snarfed from srfi-13.c:562 -@deffn {Scheme Procedure} string-drop s n -@deffnx {C Function} scm_string_drop (s, n) -Return all but the first @var{n} characters of @var{s}. -@end deffn - - string-take-right -@c snarfed from srfi-13.c:572 -@deffn {Scheme Procedure} string-take-right s n -@deffnx {C Function} scm_string_take_right (s, n) -Return the @var{n} last characters of @var{s}. -@end deffn - - string-drop-right -@c snarfed from srfi-13.c:584 -@deffn {Scheme Procedure} string-drop-right s n -@deffnx {C Function} scm_string_drop_right (s, n) -Return all but the last @var{n} characters of @var{s}. -@end deffn - - string-pad -@c snarfed from srfi-13.c:599 -@deffn {Scheme Procedure} string-pad s len [chr [start [end]]] -@deffnx {C Function} scm_string_pad (s, len, chr, start, end) -Take that characters from @var{start} to @var{end} from the -string @var{s} and return a new string, right-padded by the -character @var{chr} to length @var{len}. If the resulting -string is longer than @var{len}, it is truncated on the right. -@end deffn - - string-pad-right -@c snarfed from srfi-13.c:639 -@deffn {Scheme Procedure} string-pad-right s len [chr [start [end]]] -@deffnx {C Function} scm_string_pad_right (s, len, chr, start, end) -Take that characters from @var{start} to @var{end} from the -string @var{s} and return a new string, left-padded by the -character @var{chr} to length @var{len}. If the resulting -string is longer than @var{len}, it is truncated on the left. -@end deffn - - string-trim -@c snarfed from srfi-13.c:692 -@deffn {Scheme Procedure} string-trim s [char_pred [start [end]]] -@deffnx {C Function} scm_string_trim (s, char_pred, start, end) -Trim @var{s} by skipping over all characters on the left -that satisfy the parameter @var{char_pred}: - -@itemize @bullet -@item -if it is the character @var{ch}, characters equal to -@var{ch} are trimmed, - -@item -if it is a procedure @var{pred} characters that -satisfy @var{pred} are trimmed, - -@item -if it is a character set, characters in that set are trimmed. -@end itemize - -If called without a @var{char_pred} argument, all whitespace is -trimmed. -@end deffn - - string-trim-right -@c snarfed from srfi-13.c:768 -@deffn {Scheme Procedure} string-trim-right s [char_pred [start [end]]] -@deffnx {C Function} scm_string_trim_right (s, char_pred, start, end) -Trim @var{s} by skipping over all characters on the rightt -that satisfy the parameter @var{char_pred}: - -@itemize @bullet -@item -if it is the character @var{ch}, characters equal to @var{ch} -are trimmed, - -@item -if it is a procedure @var{pred} characters that satisfy -@var{pred} are trimmed, - -@item -if it is a character sets, all characters in that set are -trimmed. -@end itemize - -If called without a @var{char_pred} argument, all whitespace is -trimmed. -@end deffn - - string-trim-both -@c snarfed from srfi-13.c:844 -@deffn {Scheme Procedure} string-trim-both s [char_pred [start [end]]] -@deffnx {C Function} scm_string_trim_both (s, char_pred, start, end) -Trim @var{s} by skipping over all characters on both sides of -the string that satisfy the parameter @var{char_pred}: - -@itemize @bullet -@item -if it is the character @var{ch}, characters equal to @var{ch} -are trimmed, - -@item -if it is a procedure @var{pred} characters that satisfy -@var{pred} are trimmed, - -@item -if it is a character set, the characters in the set are -trimmed. -@end itemize - -If called without a @var{char_pred} argument, all whitespace is -trimmed. -@end deffn - - string-fill! -@c snarfed from srfi-13.c:931 -@deffn {Scheme Procedure} string-fill! str chr [start [end]] -@deffnx {C Function} scm_substring_fill_x (str, chr, start, end) -Stores @var{chr} in every element of the given @var{str} and -returns an unspecified value. -@end deffn - - string-compare -@c snarfed from srfi-13.c:983 -@deffn {Scheme Procedure} string-compare s1 s2 proc_lt proc_eq proc_gt [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_compare (s1, s2, proc_lt, proc_eq, proc_gt, start1, end1, start2, end2) -Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the -mismatch index, depending upon whether @var{s1} is less than, -equal to, or greater than @var{s2}. The mismatch index is the -largest index @var{i} such that for every 0 <= @var{j} < -@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is, -@var{i} is the first position that does not match. -@end deffn - - string-compare-ci -@c snarfed from srfi-13.c:1037 -@deffn {Scheme Procedure} string-compare-ci s1 s2 proc_lt proc_eq proc_gt [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_compare_ci (s1, s2, proc_lt, proc_eq, proc_gt, start1, end1, start2, end2) -Apply @var{proc_lt}, @var{proc_eq}, @var{proc_gt} to the -mismatch index, depending upon whether @var{s1} is less than, -equal to, or greater than @var{s2}. The mismatch index is the -largest index @var{i} such that for every 0 <= @var{j} < -@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is, -@var{i} is the first position where the lowercased letters -do not match. - -@end deffn - - string= -@c snarfed from srfi-13.c:1088 -@deffn {Scheme Procedure} string= s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_eq (s1, s2, start1, end1, start2, end2) -Return @code{#f} if @var{s1} and @var{s2} are not equal, a true -value otherwise. -@end deffn - - string<> -@c snarfed from srfi-13.c:1127 -@deffn {Scheme Procedure} string<> s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_neq (s1, s2, start1, end1, start2, end2) -Return @code{#f} if @var{s1} and @var{s2} are equal, a true -value otherwise. -@end deffn - - string< -@c snarfed from srfi-13.c:1170 -@deffn {Scheme Procedure} string< s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_lt (s1, s2, start1, end1, start2, end2) -Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a -true value otherwise. -@end deffn - - string> -@c snarfed from srfi-13.c:1213 -@deffn {Scheme Procedure} string> s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_gt (s1, s2, start1, end1, start2, end2) -Return @code{#f} if @var{s1} is less or equal to @var{s2}, a -true value otherwise. -@end deffn - - string<= -@c snarfed from srfi-13.c:1256 -@deffn {Scheme Procedure} string<= s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_le (s1, s2, start1, end1, start2, end2) -Return @code{#f} if @var{s1} is greater to @var{s2}, a true -value otherwise. -@end deffn - - string>= -@c snarfed from srfi-13.c:1299 -@deffn {Scheme Procedure} string>= s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_ge (s1, s2, start1, end1, start2, end2) -Return @code{#f} if @var{s1} is less to @var{s2}, a true value -otherwise. -@end deffn - - string-ci= -@c snarfed from srfi-13.c:1343 -@deffn {Scheme Procedure} string-ci= s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_ci_eq (s1, s2, start1, end1, start2, end2) -Return @code{#f} if @var{s1} and @var{s2} are not equal, a true -value otherwise. The character comparison is done -case-insensitively. -@end deffn - - string-ci<> -@c snarfed from srfi-13.c:1387 -@deffn {Scheme Procedure} string-ci<> s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_ci_neq (s1, s2, start1, end1, start2, end2) -Return @code{#f} if @var{s1} and @var{s2} are equal, a true -value otherwise. The character comparison is done -case-insensitively. -@end deffn - - string-ci< -@c snarfed from srfi-13.c:1431 -@deffn {Scheme Procedure} string-ci< s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_ci_lt (s1, s2, start1, end1, start2, end2) -Return @code{#f} if @var{s1} is greater or equal to @var{s2}, a -true value otherwise. The character comparison is done -case-insensitively. -@end deffn - - string-ci> -@c snarfed from srfi-13.c:1475 -@deffn {Scheme Procedure} string-ci> s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_ci_gt (s1, s2, start1, end1, start2, end2) -Return @code{#f} if @var{s1} is less or equal to @var{s2}, a -true value otherwise. The character comparison is done -case-insensitively. -@end deffn - - string-ci<= -@c snarfed from srfi-13.c:1519 -@deffn {Scheme Procedure} string-ci<= s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_ci_le (s1, s2, start1, end1, start2, end2) -Return @code{#f} if @var{s1} is greater to @var{s2}, a true -value otherwise. The character comparison is done -case-insensitively. -@end deffn - - string-ci>= -@c snarfed from srfi-13.c:1563 -@deffn {Scheme Procedure} string-ci>= s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_ci_ge (s1, s2, start1, end1, start2, end2) -Return @code{#f} if @var{s1} is less to @var{s2}, a true value -otherwise. The character comparison is done -case-insensitively. -@end deffn - - string-hash -@c snarfed from srfi-13.c:1608 -@deffn {Scheme Procedure} string-hash s [bound [start [end]]] -@deffnx {C Function} scm_substring_hash (s, bound, start, end) -Compute a hash value for @var{S}. the optional argument @var{bound} is a non-negative exact integer specifying the range of the hash function. A positive value restricts the return value to the range [0,bound). -@end deffn - - string-hash-ci -@c snarfed from srfi-13.c:1625 -@deffn {Scheme Procedure} string-hash-ci s [bound [start [end]]] -@deffnx {C Function} scm_substring_hash_ci (s, bound, start, end) -Compute a hash value for @var{S}. the optional argument @var{bound} is a non-negative exact integer specifying the range of the hash function. A positive value restricts the return value to the range [0,bound). -@end deffn - - string-prefix-length -@c snarfed from srfi-13.c:1637 -@deffn {Scheme Procedure} string-prefix-length s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_prefix_length (s1, s2, start1, end1, start2, end2) -Return the length of the longest common prefix of the two -strings. -@end deffn - - string-prefix-length-ci -@c snarfed from srfi-13.c:1669 -@deffn {Scheme Procedure} string-prefix-length-ci s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_prefix_length_ci (s1, s2, start1, end1, start2, end2) -Return the length of the longest common prefix of the two -strings, ignoring character case. -@end deffn - - string-suffix-length -@c snarfed from srfi-13.c:1701 -@deffn {Scheme Procedure} string-suffix-length s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_suffix_length (s1, s2, start1, end1, start2, end2) -Return the length of the longest common suffix of the two -strings. -@end deffn - - string-suffix-length-ci -@c snarfed from srfi-13.c:1733 -@deffn {Scheme Procedure} string-suffix-length-ci s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_suffix_length_ci (s1, s2, start1, end1, start2, end2) -Return the length of the longest common suffix of the two -strings, ignoring character case. -@end deffn - - string-prefix? -@c snarfed from srfi-13.c:1764 -@deffn {Scheme Procedure} string-prefix? s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_prefix_p (s1, s2, start1, end1, start2, end2) -Is @var{s1} a prefix of @var{s2}? -@end deffn - - string-prefix-ci? -@c snarfed from srfi-13.c:1796 -@deffn {Scheme Procedure} string-prefix-ci? s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_prefix_ci_p (s1, s2, start1, end1, start2, end2) -Is @var{s1} a prefix of @var{s2}, ignoring character case? -@end deffn - - string-suffix? -@c snarfed from srfi-13.c:1828 -@deffn {Scheme Procedure} string-suffix? s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_suffix_p (s1, s2, start1, end1, start2, end2) -Is @var{s1} a suffix of @var{s2}? -@end deffn - - string-suffix-ci? -@c snarfed from srfi-13.c:1860 -@deffn {Scheme Procedure} string-suffix-ci? s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_suffix_ci_p (s1, s2, start1, end1, start2, end2) -Is @var{s1} a suffix of @var{s2}, ignoring character case? -@end deffn - - string-index -@c snarfed from srfi-13.c:1904 -@deffn {Scheme Procedure} string-index s char_pred [start [end]] -@deffnx {C Function} scm_string_index (s, char_pred, start, end) -Search through the string @var{s} from left to right, returning -the index of the first occurence of a character which - -@itemize @bullet -@item -equals @var{char_pred}, if it is character, - -@item -satisifies the predicate @var{char_pred}, if it is a procedure, - -@item -is in the set @var{char_pred}, if it is a character set. -@end itemize -@end deffn - - string-index-right -@c snarfed from srfi-13.c:1969 -@deffn {Scheme Procedure} string-index-right s char_pred [start [end]] -@deffnx {C Function} scm_string_index_right (s, char_pred, start, end) -Search through the string @var{s} from right to left, returning -the index of the last occurence of a character which - -@itemize @bullet -@item -equals @var{char_pred}, if it is character, - -@item -satisifies the predicate @var{char_pred}, if it is a procedure, - -@item -is in the set if @var{char_pred} is a character set. -@end itemize -@end deffn - - string-rindex -@c snarfed from srfi-13.c:2034 -@deffn {Scheme Procedure} string-rindex s char_pred [start [end]] -@deffnx {C Function} scm_string_rindex (s, char_pred, start, end) -Search through the string @var{s} from right to left, returning -the index of the last occurence of a character which - -@itemize @bullet -@item -equals @var{char_pred}, if it is character, - -@item -satisifies the predicate @var{char_pred}, if it is a procedure, - -@item -is in the set if @var{char_pred} is a character set. -@end itemize -@end deffn - - string-skip -@c snarfed from srfi-13.c:2056 -@deffn {Scheme Procedure} string-skip s char_pred [start [end]] -@deffnx {C Function} scm_string_skip (s, char_pred, start, end) -Search through the string @var{s} from left to right, returning -the index of the first occurence of a character which - -@itemize @bullet -@item -does not equal @var{char_pred}, if it is character, - -@item -does not satisify the predicate @var{char_pred}, if it is a -procedure, - -@item -is not in the set if @var{char_pred} is a character set. -@end itemize -@end deffn - - string-skip-right -@c snarfed from srfi-13.c:2123 -@deffn {Scheme Procedure} string-skip-right s char_pred [start [end]] -@deffnx {C Function} scm_string_skip_right (s, char_pred, start, end) -Search through the string @var{s} from right to left, returning -the index of the last occurence of a character which - -@itemize @bullet -@item -does not equal @var{char_pred}, if it is character, - -@item -does not satisfy the predicate @var{char_pred}, if it is a -procedure, - -@item -is not in the set if @var{char_pred} is a character set. -@end itemize -@end deffn - - string-count -@c snarfed from srfi-13.c:2190 -@deffn {Scheme Procedure} string-count s char_pred [start [end]] -@deffnx {C Function} scm_string_count (s, char_pred, start, end) -Return the count of the number of characters in the string -@var{s} which - -@itemize @bullet -@item -equals @var{char_pred}, if it is character, - -@item -satisifies the predicate @var{char_pred}, if it is a procedure. - -@item -is in the set @var{char_pred}, if it is a character set. -@end itemize -@end deffn - - string-contains -@c snarfed from srfi-13.c:2247 -@deffn {Scheme Procedure} string-contains s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_contains (s1, s2, start1, end1, start2, end2) -Does string @var{s1} contain string @var{s2}? Return the index -in @var{s1} where @var{s2} occurs as a substring, or false. -The optional start/end indices restrict the operation to the -indicated substrings. -@end deffn - - string-contains-ci -@c snarfed from srfi-13.c:2294 -@deffn {Scheme Procedure} string-contains-ci s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_contains_ci (s1, s2, start1, end1, start2, end2) -Does string @var{s1} contain string @var{s2}? Return the index -in @var{s1} where @var{s2} occurs as a substring, or false. -The optional start/end indices restrict the operation to the -indicated substrings. Character comparison is done -case-insensitively. -@end deffn - - string-upcase! -@c snarfed from srfi-13.c:2359 -@deffn {Scheme Procedure} string-upcase! str [start [end]] -@deffnx {C Function} scm_substring_upcase_x (str, start, end) -Destructively upcase every character in @code{str}. - -@lisp -(string-upcase! y) -@result{} "ARRDEFG" -y -@result{} "ARRDEFG" -@end lisp -@end deffn - - string-upcase -@c snarfed from srfi-13.c:2380 -@deffn {Scheme Procedure} string-upcase str [start [end]] -@deffnx {C Function} scm_substring_upcase (str, start, end) -Upcase every character in @code{str}. -@end deffn - - string-downcase! -@c snarfed from srfi-13.c:2427 -@deffn {Scheme Procedure} string-downcase! str [start [end]] -@deffnx {C Function} scm_substring_downcase_x (str, start, end) -Destructively downcase every character in @var{str}. - -@lisp -y -@result{} "ARRDEFG" -(string-downcase! y) -@result{} "arrdefg" -y -@result{} "arrdefg" -@end lisp -@end deffn - - string-downcase -@c snarfed from srfi-13.c:2448 -@deffn {Scheme Procedure} string-downcase str [start [end]] -@deffnx {C Function} scm_substring_downcase (str, start, end) -Downcase every character in @var{str}. -@end deffn - - string-titlecase! -@c snarfed from srfi-13.c:2504 -@deffn {Scheme Procedure} string-titlecase! str [start [end]] -@deffnx {C Function} scm_string_titlecase_x (str, start, end) -Destructively titlecase every first character in a word in -@var{str}. -@end deffn - - string-titlecase -@c snarfed from srfi-13.c:2520 -@deffn {Scheme Procedure} string-titlecase str [start [end]] -@deffnx {C Function} scm_string_titlecase (str, start, end) -Titlecase every first character in a word in @var{str}. -@end deffn - - string-capitalize! -@c snarfed from srfi-13.c:2542 -@deffn {Scheme Procedure} string-capitalize! str -@deffnx {C Function} scm_string_capitalize_x (str) -Upcase the first character of every word in @var{str} -destructively and return @var{str}. - -@lisp -y @result{} "hello world" -(string-capitalize! y) @result{} "Hello World" -y @result{} "Hello World" -@end lisp -@end deffn - - string-capitalize -@c snarfed from srfi-13.c:2554 -@deffn {Scheme Procedure} string-capitalize str -@deffnx {C Function} scm_string_capitalize (str) -Return a freshly allocated string with the characters in -@var{str}, where the first character of every word is -capitalized. -@end deffn - - string-reverse -@c snarfed from srfi-13.c:2588 -@deffn {Scheme Procedure} string-reverse str [start [end]] -@deffnx {C Function} scm_string_reverse (str, start, end) -Reverse the string @var{str}. The optional arguments -@var{start} and @var{end} delimit the region of @var{str} to -operate on. -@end deffn - - string-reverse! -@c snarfed from srfi-13.c:2613 -@deffn {Scheme Procedure} string-reverse! str [start [end]] -@deffnx {C Function} scm_string_reverse_x (str, start, end) -Reverse the string @var{str} in-place. The optional arguments -@var{start} and @var{end} delimit the region of @var{str} to -operate on. The return value is unspecified. -@end deffn - - string-append/shared -@c snarfed from srfi-13.c:2635 -@deffn {Scheme Procedure} string-append/shared . rest -@deffnx {C Function} scm_string_append_shared (rest) -Like @code{string-append}, but the result may share memory -with the argument strings. -@end deffn - - string-concatenate -@c snarfed from srfi-13.c:2656 -@deffn {Scheme Procedure} string-concatenate ls -@deffnx {C Function} scm_string_concatenate (ls) -Append the elements of @var{ls} (which must be strings) -together into a single string. Guaranteed to return a freshly -allocated string. -@end deffn - - string-concatenate-reverse -@c snarfed from srfi-13.c:2678 -@deffn {Scheme Procedure} string-concatenate-reverse ls [final_string [end]] -@deffnx {C Function} scm_string_concatenate_reverse (ls, final_string, end) -Without optional arguments, this procedure is equivalent to - -@smalllisp -(string-concatenate (reverse ls)) -@end smalllisp - -If the optional argument @var{final_string} is specified, it is -consed onto the beginning to @var{ls} before performing the -list-reverse and string-concatenate operations. If @var{end} -is given, only the characters of @var{final_string} up to index -@var{end} are used. - -Guaranteed to return a freshly allocated string. -@end deffn - - string-concatenate/shared -@c snarfed from srfi-13.c:2695 -@deffn {Scheme Procedure} string-concatenate/shared ls -@deffnx {C Function} scm_string_concatenate_shared (ls) -Like @code{string-concatenate}, but the result may share memory -with the strings in the list @var{ls}. -@end deffn - - string-concatenate-reverse/shared -@c snarfed from srfi-13.c:2706 -@deffn {Scheme Procedure} string-concatenate-reverse/shared ls [final_string [end]] -@deffnx {C Function} scm_string_concatenate_reverse_shared (ls, final_string, end) -Like @code{string-concatenate-reverse}, but the result may -share memory with the strings in the @var{ls} arguments. -@end deffn - - string-map -@c snarfed from srfi-13.c:2719 -@deffn {Scheme Procedure} string-map proc s [start [end]] -@deffnx {C Function} scm_string_map (proc, s, start, end) -@var{proc} is a char->char procedure, it is mapped over -@var{s}. The order in which the procedure is applied to the -string elements is not specified. -@end deffn - - string-map! -@c snarfed from srfi-13.c:2749 -@deffn {Scheme Procedure} string-map! proc s [start [end]] -@deffnx {C Function} scm_string_map_x (proc, s, start, end) -@var{proc} is a char->char procedure, it is mapped over -@var{s}. The order in which the procedure is applied to the -string elements is not specified. The string @var{s} is -modified in-place, the return value is not specified. -@end deffn - - string-fold -@c snarfed from srfi-13.c:2776 -@deffn {Scheme Procedure} string-fold kons knil s [start [end]] -@deffnx {C Function} scm_string_fold (kons, knil, s, start, end) -Fold @var{kons} over the characters of @var{s}, with @var{knil} -as the terminating element, from left to right. @var{kons} -must expect two arguments: The actual character and the last -result of @var{kons}' application. -@end deffn - - string-fold-right -@c snarfed from srfi-13.c:2807 -@deffn {Scheme Procedure} string-fold-right kons knil s [start [end]] -@deffnx {C Function} scm_string_fold_right (kons, knil, s, start, end) -Fold @var{kons} over the characters of @var{s}, with @var{knil} -as the terminating element, from right to left. @var{kons} -must expect two arguments: The actual character and the last -result of @var{kons}' application. -@end deffn - - string-unfold -@c snarfed from srfi-13.c:2852 -@deffn {Scheme Procedure} string-unfold p f g seed [base [make_final]] -@deffnx {C Function} scm_string_unfold (p, f, g, seed, base, make_final) -@itemize @bullet -@item @var{g} is used to generate a series of @emph{seed} -values from the initial @var{seed}: @var{seed}, (@var{g} -@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), -@dots{} -@item @var{p} tells us when to stop -- when it returns true -when applied to one of these seed values. -@item @var{f} maps each seed value to the corresponding -character in the result string. These chars are assembled -into the string in a left-to-right order. -@item @var{base} is the optional initial/leftmost portion -of the constructed string; it default to the empty -string. -@item @var{make_final} is applied to the terminal seed -value (on which @var{p} returns true) to produce -the final/rightmost portion of the constructed string. -It defaults to @code{(lambda (x) )}. -@end itemize -@end deffn - - string-unfold-right -@c snarfed from srfi-13.c:2915 -@deffn {Scheme Procedure} string-unfold-right p f g seed [base [make_final]] -@deffnx {C Function} scm_string_unfold_right (p, f, g, seed, base, make_final) -@itemize @bullet -@item @var{g} is used to generate a series of @emph{seed} -values from the initial @var{seed}: @var{seed}, (@var{g} -@var{seed}), (@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), -@dots{} -@item @var{p} tells us when to stop -- when it returns true -when applied to one of these seed values. -@item @var{f} maps each seed value to the corresponding -character in the result string. These chars are assembled -into the string in a right-to-left order. -@item @var{base} is the optional initial/rightmost portion -of the constructed string; it default to the empty -string. -@item @var{make_final} is applied to the terminal seed -value (on which @var{p} returns true) to produce -the final/leftmost portion of the constructed string. -It defaults to @code{(lambda (x) )}. -@end itemize -@end deffn - - string-for-each -@c snarfed from srfi-13.c:2962 -@deffn {Scheme Procedure} string-for-each proc s [start [end]] -@deffnx {C Function} scm_string_for_each (proc, s, start, end) -@var{proc} is mapped over @var{s} in left-to-right order. The -return value is not specified. -@end deffn - - string-for-each-index -@c snarfed from srfi-13.c:2988 -@deffn {Scheme Procedure} string-for-each-index proc s [start [end]] -@deffnx {C Function} scm_string_for_each_index (proc, s, start, end) -@var{proc} is mapped over @var{s} in left-to-right order. The -return value is not specified. -@end deffn - - xsubstring -@c snarfed from srfi-13.c:3020 -@deffn {Scheme Procedure} xsubstring s from [to [start [end]]] -@deffnx {C Function} scm_xsubstring (s, from, to, start, end) -This is the @emph{extended substring} procedure that implements -replicated copying of a substring of some string. - -@var{s} is a string, @var{start} and @var{end} are optional -arguments that demarcate a substring of @var{s}, defaulting to -0 and the length of @var{s}. Replicate this substring up and -down index space, in both the positive and negative directions. -@code{xsubstring} returns the substring of this string -beginning at index @var{from}, and ending at @var{to}, which -defaults to @var{from} + (@var{end} - @var{start}). -@end deffn - - string-xcopy! -@c snarfed from srfi-13.c:3067 -@deffn {Scheme Procedure} string-xcopy! target tstart s sfrom [sto [start [end]]] -@deffnx {C Function} scm_string_xcopy_x (target, tstart, s, sfrom, sto, start, end) -Exactly the same as @code{xsubstring}, but the extracted text -is written into the string @var{target} starting at index -@var{tstart}. The operation is not defined if @code{(eq? -@var{target} @var{s})} or these arguments share storage -- you -cannot copy a string on top of itself. -@end deffn - - string-replace -@c snarfed from srfi-13.c:3117 -@deffn {Scheme Procedure} string-replace s1 s2 [start1 [end1 [start2 [end2]]]] -@deffnx {C Function} scm_string_replace (s1, s2, start1, end1, start2, end2) -Return the string @var{s1}, but with the characters -@var{start1} @dots{} @var{end1} replaced by the characters -@var{start2} @dots{} @var{end2} from @var{s2}. -@end deffn - - string-tokenize -@c snarfed from srfi-13.c:3154 -@deffn {Scheme Procedure} string-tokenize s [token_set [start [end]]] -@deffnx {C Function} scm_string_tokenize (s, token_set, start, end) -Split the string @var{s} into a list of substrings, where each -substring is a maximal non-empty contiguous sequence of -characters from the character set @var{token_set}, which -defaults to @code{char-set:graphic}. -If @var{start} or @var{end} indices are provided, they restrict -@code{string-tokenize} to operating on the indicated substring -of @var{s}. -@end deffn - - string-split -@c snarfed from srfi-13.c:3220 -@deffn {Scheme Procedure} string-split str chr -@deffnx {C Function} scm_string_split (str, chr) -Split the string @var{str} into the a list of the substrings delimited -by appearances of the character @var{chr}. Note that an empty substring -between separator characters will result in an empty string in the -result list. - -@lisp -(string-split "root:x:0:0:root:/root:/bin/bash" #\:) -@result{} -("root" "x" "0" "0" "root" "/root" "/bin/bash") - -(string-split "::" #\:) -@result{} -("" "" "") - -(string-split "" #\:) -@result{} -("") -@end lisp -@end deffn - - string-filter -@c snarfed from srfi-13.c:3258 -@deffn {Scheme Procedure} string-filter s char_pred [start [end]] -@deffnx {C Function} scm_string_filter (s, char_pred, start, end) -Filter the string @var{s}, retaining only those characters that -satisfy the @var{char_pred} argument. If the argument is a -procedure, it is applied to each character as a predicate, if -it is a character, it is tested for equality and if it is a -character set, it is tested for membership. -@end deffn - - string-delete -@c snarfed from srfi-13.c:3330 -@deffn {Scheme Procedure} string-delete s char_pred [start [end]] -@deffnx {C Function} scm_string_delete (s, char_pred, start, end) -Filter the string @var{s}, retaining only those characters that -do not satisfy the @var{char_pred} argument. If the argument -is a procedure, it is applied to each character as a predicate, -if it is a character, it is tested for equality and if it is a -character set, it is tested for membership. -@end deffn - - char-set? -@c snarfed from srfi-14.c:85 -@deffn {Scheme Procedure} char-set? obj -@deffnx {C Function} scm_char_set_p (obj) -Return @code{#t} if @var{obj} is a character set, @code{#f} -otherwise. -@end deffn - - char-set= -@c snarfed from srfi-14.c:95 -@deffn {Scheme Procedure} char-set= . char_sets -@deffnx {C Function} scm_char_set_eq (char_sets) -Return @code{#t} if all given character sets are equal. -@end deffn - - char-set<= -@c snarfed from srfi-14.c:125 -@deffn {Scheme Procedure} char-set<= . char_sets -@deffnx {C Function} scm_char_set_leq (char_sets) -Return @code{#t} if every character set @var{cs}i is a subset -of character set @var{cs}i+1. -@end deffn - - char-set-hash -@c snarfed from srfi-14.c:163 -@deffn {Scheme Procedure} char-set-hash cs [bound] -@deffnx {C Function} scm_char_set_hash (cs, bound) -Compute a hash value for the character set @var{cs}. If -@var{bound} is given and non-zero, it restricts the -returned value to the range 0 @dots{} @var{bound - 1}. -@end deffn - - char-set-cursor -@c snarfed from srfi-14.c:196 -@deffn {Scheme Procedure} char-set-cursor cs -@deffnx {C Function} scm_char_set_cursor (cs) -Return a cursor into the character set @var{cs}. -@end deffn - - char-set-ref -@c snarfed from srfi-14.c:216 -@deffn {Scheme Procedure} char-set-ref cs cursor -@deffnx {C Function} scm_char_set_ref (cs, cursor) -Return the character at the current cursor position -@var{cursor} in the character set @var{cs}. It is an error to -pass a cursor for which @code{end-of-char-set?} returns true. -@end deffn - - char-set-cursor-next -@c snarfed from srfi-14.c:233 -@deffn {Scheme Procedure} char-set-cursor-next cs cursor -@deffnx {C Function} scm_char_set_cursor_next (cs, cursor) -Advance the character set cursor @var{cursor} to the next -character in the character set @var{cs}. It is an error if the -cursor given satisfies @code{end-of-char-set?}. -@end deffn - - end-of-char-set? -@c snarfed from srfi-14.c:254 -@deffn {Scheme Procedure} end-of-char-set? cursor -@deffnx {C Function} scm_end_of_char_set_p (cursor) -Return @code{#t} if @var{cursor} has reached the end of a -character set, @code{#f} otherwise. -@end deffn - - char-set-fold -@c snarfed from srfi-14.c:266 -@deffn {Scheme Procedure} char-set-fold kons knil cs -@deffnx {C Function} scm_char_set_fold (kons, knil, cs) -Fold the procedure @var{kons} over the character set @var{cs}, -initializing it with @var{knil}. -@end deffn - - char-set-unfold -@c snarfed from srfi-14.c:296 -@deffn {Scheme Procedure} char-set-unfold p f g seed [base_cs] -@deffnx {C Function} scm_char_set_unfold (p, f, g, seed, base_cs) -This is a fundamental constructor for character sets. -@itemize @bullet -@item @var{g} is used to generate a series of ``seed'' values -from the initial seed: @var{seed}, (@var{g} @var{seed}), -(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{} -@item @var{p} tells us when to stop -- when it returns true -when applied to one of the seed values. -@item @var{f} maps each seed value to a character. These -characters are added to the base character set @var{base_cs} to -form the result; @var{base_cs} defaults to the empty set. -@end itemize -@end deffn - - char-set-unfold! -@c snarfed from srfi-14.c:340 -@deffn {Scheme Procedure} char-set-unfold! p f g seed base_cs -@deffnx {C Function} scm_char_set_unfold_x (p, f, g, seed, base_cs) -This is a fundamental constructor for character sets. -@itemize @bullet -@item @var{g} is used to generate a series of ``seed'' values -from the initial seed: @var{seed}, (@var{g} @var{seed}), -(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{} -@item @var{p} tells us when to stop -- when it returns true -when applied to one of the seed values. -@item @var{f} maps each seed value to a character. These -characters are added to the base character set @var{base_cs} to -form the result; @var{base_cs} defaults to the empty set. -@end itemize -@end deffn - - char-set-for-each -@c snarfed from srfi-14.c:369 -@deffn {Scheme Procedure} char-set-for-each proc cs -@deffnx {C Function} scm_char_set_for_each (proc, cs) -Apply @var{proc} to every character in the character set -@var{cs}. The return value is not specified. -@end deffn - - char-set-map -@c snarfed from srfi-14.c:388 -@deffn {Scheme Procedure} char-set-map proc cs -@deffnx {C Function} scm_char_set_map (proc, cs) -Map the procedure @var{proc} over every character in @var{cs}. -@var{proc} must be a character -> character procedure. -@end deffn - - char-set-copy -@c snarfed from srfi-14.c:414 -@deffn {Scheme Procedure} char-set-copy cs -@deffnx {C Function} scm_char_set_copy (cs) -Return a newly allocated character set containing all -characters in @var{cs}. -@end deffn - - char-set -@c snarfed from srfi-14.c:434 -@deffn {Scheme Procedure} char-set . rest -@deffnx {C Function} scm_char_set (rest) -Return a character set containing all given characters. -@end deffn - - list->char-set -@c snarfed from srfi-14.c:462 -@deffn {Scheme Procedure} list->char-set list [base_cs] -@deffnx {C Function} scm_list_to_char_set (list, base_cs) -Convert the character list @var{list} to a character set. If -the character set @var{base_cs} is given, the character in this -set are also included in the result. -@end deffn - - list->char-set! -@c snarfed from srfi-14.c:496 -@deffn {Scheme Procedure} list->char-set! list base_cs -@deffnx {C Function} scm_list_to_char_set_x (list, base_cs) -Convert the character list @var{list} to a character set. The -characters are added to @var{base_cs} and @var{base_cs} is -returned. -@end deffn - - string->char-set -@c snarfed from srfi-14.c:523 -@deffn {Scheme Procedure} string->char-set str [base_cs] -@deffnx {C Function} scm_string_to_char_set (str, base_cs) -Convert the string @var{str} to a character set. If the -character set @var{base_cs} is given, the characters in this -set are also included in the result. -@end deffn - - string->char-set! -@c snarfed from srfi-14.c:557 -@deffn {Scheme Procedure} string->char-set! str base_cs -@deffnx {C Function} scm_string_to_char_set_x (str, base_cs) -Convert the string @var{str} to a character set. The -characters from the string are added to @var{base_cs}, and -@var{base_cs} is returned. -@end deffn - - char-set-filter -@c snarfed from srfi-14.c:584 -@deffn {Scheme Procedure} char-set-filter pred cs [base_cs] -@deffnx {C Function} scm_char_set_filter (pred, cs, base_cs) -Return a character set containing every character from @var{cs} -so that it satisfies @var{pred}. If provided, the characters -from @var{base_cs} are added to the result. -@end deffn - - char-set-filter! -@c snarfed from srfi-14.c:620 -@deffn {Scheme Procedure} char-set-filter! pred cs base_cs -@deffnx {C Function} scm_char_set_filter_x (pred, cs, base_cs) -Return a character set containing every character from @var{cs} -so that it satisfies @var{pred}. The characters are added to -@var{base_cs} and @var{base_cs} is returned. -@end deffn - - ucs-range->char-set -@c snarfed from srfi-14.c:658 -@deffn {Scheme Procedure} ucs-range->char-set lower upper [error [base_cs]] -@deffnx {C Function} scm_ucs_range_to_char_set (lower, upper, error, base_cs) -Return a character set containing all characters whose -character codes lie in the half-open range -[@var{lower},@var{upper}). - -If @var{error} is a true value, an error is signalled if the -specified range contains characters which are not contained in -the implemented character range. If @var{error} is @code{#f}, -these characters are silently left out of the resultung -character set. - -The characters in @var{base_cs} are added to the result, if -given. -@end deffn - - ucs-range->char-set! -@c snarfed from srfi-14.c:711 -@deffn {Scheme Procedure} ucs-range->char-set! lower upper error base_cs -@deffnx {C Function} scm_ucs_range_to_char_set_x (lower, upper, error, base_cs) -Return a character set containing all characters whose -character codes lie in the half-open range -[@var{lower},@var{upper}). - -If @var{error} is a true value, an error is signalled if the -specified range contains characters which are not contained in -the implemented character range. If @var{error} is @code{#f}, -these characters are silently left out of the resultung -character set. - -The characters are added to @var{base_cs} and @var{base_cs} is -returned. -@end deffn - - ->char-set -@c snarfed from srfi-14.c:741 -@deffn {Scheme Procedure} ->char-set x -@deffnx {C Function} scm_to_char_set (x) -Coerces x into a char-set. @var{x} may be a string, character or char-set. A string is converted to the set of its constituent characters; a character is converted to a singleton set; a char-set is returned as-is. -@end deffn - - char-set-size -@c snarfed from srfi-14.c:757 -@deffn {Scheme Procedure} char-set-size cs -@deffnx {C Function} scm_char_set_size (cs) -Return the number of elements in character set @var{cs}. -@end deffn - - char-set-count -@c snarfed from srfi-14.c:774 -@deffn {Scheme Procedure} char-set-count pred cs -@deffnx {C Function} scm_char_set_count (pred, cs) -Return the number of the elements int the character set -@var{cs} which satisfy the predicate @var{pred}. -@end deffn - - char-set->list -@c snarfed from srfi-14.c:797 -@deffn {Scheme Procedure} char-set->list cs -@deffnx {C Function} scm_char_set_to_list (cs) -Return a list containing the elements of the character set -@var{cs}. -@end deffn - - char-set->string -@c snarfed from srfi-14.c:816 -@deffn {Scheme Procedure} char-set->string cs -@deffnx {C Function} scm_char_set_to_string (cs) -Return a string containing the elements of the character set -@var{cs}. The order in which the characters are placed in the -string is not defined. -@end deffn - - char-set-contains? -@c snarfed from srfi-14.c:841 -@deffn {Scheme Procedure} char-set-contains? cs ch -@deffnx {C Function} scm_char_set_contains_p (cs, ch) -Return @code{#t} iff the character @var{ch} is contained in the -character set @var{cs}. -@end deffn - - char-set-every -@c snarfed from srfi-14.c:854 -@deffn {Scheme Procedure} char-set-every pred cs -@deffnx {C Function} scm_char_set_every (pred, cs) -Return a true value if every character in the character set -@var{cs} satisfies the predicate @var{pred}. -@end deffn - - char-set-any -@c snarfed from srfi-14.c:878 -@deffn {Scheme Procedure} char-set-any pred cs -@deffnx {C Function} scm_char_set_any (pred, cs) -Return a true value if any character in the character set -@var{cs} satisfies the predicate @var{pred}. -@end deffn - - char-set-adjoin -@c snarfed from srfi-14.c:901 -@deffn {Scheme Procedure} char-set-adjoin cs . rest -@deffnx {C Function} scm_char_set_adjoin (cs, rest) -Add all character arguments to the first argument, which must -be a character set. -@end deffn - - char-set-delete -@c snarfed from srfi-14.c:929 -@deffn {Scheme Procedure} char-set-delete cs . rest -@deffnx {C Function} scm_char_set_delete (cs, rest) -Delete all character arguments from the first argument, which -must be a character set. -@end deffn - - char-set-adjoin! -@c snarfed from srfi-14.c:957 -@deffn {Scheme Procedure} char-set-adjoin! cs . rest -@deffnx {C Function} scm_char_set_adjoin_x (cs, rest) -Add all character arguments to the first argument, which must -be a character set. -@end deffn - - char-set-delete! -@c snarfed from srfi-14.c:984 -@deffn {Scheme Procedure} char-set-delete! cs . rest -@deffnx {C Function} scm_char_set_delete_x (cs, rest) -Delete all character arguments from the first argument, which -must be a character set. -@end deffn - - char-set-complement -@c snarfed from srfi-14.c:1010 -@deffn {Scheme Procedure} char-set-complement cs -@deffnx {C Function} scm_char_set_complement (cs) -Return the complement of the character set @var{cs}. -@end deffn - - char-set-union -@c snarfed from srfi-14.c:1031 -@deffn {Scheme Procedure} char-set-union . rest -@deffnx {C Function} scm_char_set_union (rest) -Return the union of all argument character sets. -@end deffn - - char-set-intersection -@c snarfed from srfi-14.c:1060 -@deffn {Scheme Procedure} char-set-intersection . rest -@deffnx {C Function} scm_char_set_intersection (rest) -Return the intersection of all argument character sets. -@end deffn - - char-set-difference -@c snarfed from srfi-14.c:1100 -@deffn {Scheme Procedure} char-set-difference cs1 . rest -@deffnx {C Function} scm_char_set_difference (cs1, rest) -Return the difference of all argument character sets. -@end deffn - - char-set-xor -@c snarfed from srfi-14.c:1130 -@deffn {Scheme Procedure} char-set-xor . rest -@deffnx {C Function} scm_char_set_xor (rest) -Return the exclusive-or of all argument character sets. -@end deffn - - char-set-diff+intersection -@c snarfed from srfi-14.c:1171 -@deffn {Scheme Procedure} char-set-diff+intersection cs1 . rest -@deffnx {C Function} scm_char_set_diff_plus_intersection (cs1, rest) -Return the difference and the intersection of all argument -character sets. -@end deffn - - char-set-complement! -@c snarfed from srfi-14.c:1209 -@deffn {Scheme Procedure} char-set-complement! cs -@deffnx {C Function} scm_char_set_complement_x (cs) -Return the complement of the character set @var{cs}. -@end deffn - - char-set-union! -@c snarfed from srfi-14.c:1226 -@deffn {Scheme Procedure} char-set-union! cs1 . rest -@deffnx {C Function} scm_char_set_union_x (cs1, rest) -Return the union of all argument character sets. -@end deffn - - char-set-intersection! -@c snarfed from srfi-14.c:1254 -@deffn {Scheme Procedure} char-set-intersection! cs1 . rest -@deffnx {C Function} scm_char_set_intersection_x (cs1, rest) -Return the intersection of all argument character sets. -@end deffn - - char-set-difference! -@c snarfed from srfi-14.c:1282 -@deffn {Scheme Procedure} char-set-difference! cs1 . rest -@deffnx {C Function} scm_char_set_difference_x (cs1, rest) -Return the difference of all argument character sets. -@end deffn - - char-set-xor! -@c snarfed from srfi-14.c:1310 -@deffn {Scheme Procedure} char-set-xor! cs1 . rest -@deffnx {C Function} scm_char_set_xor_x (cs1, rest) -Return the exclusive-or of all argument character sets. -@end deffn - - char-set-diff+intersection! -@c snarfed from srfi-14.c:1349 -@deffn {Scheme Procedure} char-set-diff+intersection! cs1 cs2 . rest -@deffnx {C Function} scm_char_set_diff_plus_intersection_x (cs1, cs2, rest) -Return the difference and the intersection of all argument -character sets. -@end deffn - - string=? -@c snarfed from strorder.c:50 -@deffn {Scheme Procedure} string=? [s1 [s2 . rest]] -@deffnx {C Function} scm_i_string_equal_p (s1, s2, rest) -Lexicographic equality predicate; return @code{#t} if the two -strings are the same length and contain the same characters in -the same positions, otherwise return @code{#f}. - -The procedure @code{string-ci=?} treats upper and lower case -letters as though they were the same character, but -@code{string=?} treats upper and lower case as distinct -characters. -@end deffn - - string-ci=? -@c snarfed from strorder.c:62 -@deffn {Scheme Procedure} string-ci=? [s1 [s2 . rest]] -@deffnx {C Function} scm_i_string_ci_equal_p (s1, s2, rest) -Case-insensitive string equality predicate; return @code{#t} if -the two strings are the same length and their component -characters match (ignoring case) at each position; otherwise -return @code{#f}. -@end deffn - - string? -@c snarfed from strorder.c:92 -@deffn {Scheme Procedure} string>? [s1 [s2 . rest]] -@deffnx {C Function} scm_i_string_gr_p (s1, s2, rest) -Lexicographic ordering predicate; return @code{#t} if @var{s1} -is lexicographically greater than @var{s2}. -@end deffn - - string>=? -@c snarfed from strorder.c:102 -@deffn {Scheme Procedure} string>=? [s1 [s2 . rest]] -@deffnx {C Function} scm_i_string_geq_p (s1, s2, rest) -Lexicographic ordering predicate; return @code{#t} if @var{s1} -is lexicographically greater than or equal to @var{s2}. -@end deffn - - string-ci? -@c snarfed from strorder.c:135 -@deffn {Scheme Procedure} string-ci>? [s1 [s2 . rest]] -@deffnx {C Function} scm_i_string_ci_gr_p (s1, s2, rest) -Case insensitive lexicographic ordering predicate; return -@code{#t} if @var{s1} is lexicographically greater than -@var{s2} regardless of case. -@end deffn - - string-ci>=? -@c snarfed from strorder.c:146 -@deffn {Scheme Procedure} string-ci>=? [s1 [s2 . rest]] -@deffnx {C Function} scm_i_string_ci_geq_p (s1, s2, rest) -Case insensitive lexicographic ordering predicate; return -@code{#t} if @var{s1} is lexicographically greater than or -equal to @var{s2} regardless of case. -@end deffn - - object->string -@c snarfed from strports.c:332 -@deffn {Scheme Procedure} object->string obj [printer] -@deffnx {C Function} scm_object_to_string (obj, printer) -Return a Scheme string obtained by printing @var{obj}. -Printing function can be specified by the optional second -argument @var{printer} (default: @code{write}). -@end deffn - - call-with-output-string -@c snarfed from strports.c:356 -@deffn {Scheme Procedure} call-with-output-string proc -@deffnx {C Function} scm_call_with_output_string (proc) -Calls the one-argument procedure @var{proc} with a newly created output -port. When the function returns, the string composed of the characters -written into the port is returned. -@end deffn - - call-with-input-string -@c snarfed from strports.c:375 -@deffn {Scheme Procedure} call-with-input-string string proc -@deffnx {C Function} scm_call_with_input_string (string, proc) -Calls the one-argument procedure @var{proc} with a newly -created input port from which @var{string}'s contents may be -read. The value yielded by the @var{proc} is returned. -@end deffn - - open-input-string -@c snarfed from strports.c:388 -@deffn {Scheme Procedure} open-input-string str -@deffnx {C Function} scm_open_input_string (str) -Take a string and return an input port that delivers characters -from the string. The port can be closed by -@code{close-input-port}, though its storage will be reclaimed -by the garbage collector if it becomes inaccessible. -@end deffn - - open-output-string -@c snarfed from strports.c:402 -@deffn {Scheme Procedure} open-output-string -@deffnx {C Function} scm_open_output_string () -Return an output port that will accumulate characters for -retrieval by @code{get-output-string}. The port can be closed -by the procedure @code{close-output-port}, though its storage -will be reclaimed by the garbage collector if it becomes -inaccessible. -@end deffn - - get-output-string -@c snarfed from strports.c:419 -@deffn {Scheme Procedure} get-output-string port -@deffnx {C Function} scm_get_output_string (port) -Given an output port created by @code{open-output-string}, -return a string consisting of the characters that have been -output to the port so far. -@end deffn - - eval-string -@c snarfed from strports.c:488 -@deffn {Scheme Procedure} eval-string string [module] -@deffnx {C Function} scm_eval_string_in_module (string, module) -Evaluate @var{string} as the text representation of a Scheme -form or forms, and return whatever value they produce. -Evaluation takes place in the given module, or the current -module when no module is given. -While the code is evaluated, the given module is made the -current one. The current module is restored when this -procedure returns. -@end deffn - - make-struct-layout -@c snarfed from struct.c:56 -@deffn {Scheme Procedure} make-struct-layout fields -@deffnx {C Function} scm_make_struct_layout (fields) -Return a new structure layout object. - -@var{fields} must be a string made up of pairs of characters -strung together. The first character of each pair describes a field -type, the second a field protection. Allowed types are 'p' for -GC-protected Scheme data, 'u' for unprotected binary data, and 's' for -a field that points to the structure itself. Allowed protections -are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque -fields. The last field protection specification may be capitalized to -indicate that the field is a tail-array. -@end deffn - - struct? -@c snarfed from struct.c:223 -@deffn {Scheme Procedure} struct? x -@deffnx {C Function} scm_struct_p (x) -Return @code{#t} iff @var{x} is a structure object, else -@code{#f}. -@end deffn - - struct-vtable? -@c snarfed from struct.c:232 -@deffn {Scheme Procedure} struct-vtable? x -@deffnx {C Function} scm_struct_vtable_p (x) -Return @code{#t} iff @var{x} is a vtable structure. -@end deffn - - make-struct -@c snarfed from struct.c:418 -@deffn {Scheme Procedure} make-struct vtable tail_array_size . init -@deffnx {C Function} scm_make_struct (vtable, tail_array_size, init) -Create a new structure. - -@var{type} must be a vtable structure (@pxref{Vtables}). - -@var{tail-elts} must be a non-negative integer. If the layout -specification indicated by @var{type} includes a tail-array, -this is the number of elements allocated to that array. - -The @var{init1}, @dots{} are optional arguments describing how -successive fields of the structure should be initialized. Only fields -with protection 'r' or 'w' can be initialized, except for fields of -type 's', which are automatically initialized to point to the new -structure itself; fields with protection 'o' can not be initialized by -Scheme programs. - -If fewer optional arguments than initializable fields are supplied, -fields of type 'p' get default value #f while fields of type 'u' are -initialized to 0. - -Structs are currently the basic representation for record-like data -structures in Guile. The plan is to eventually replace them with a -new representation which will at the same time be easier to use and -more powerful. - -For more information, see the documentation for @code{make-vtable-vtable}. -@end deffn - - make-vtable-vtable -@c snarfed from struct.c:502 -@deffn {Scheme Procedure} make-vtable-vtable user_fields tail_array_size . init -@deffnx {C Function} scm_make_vtable_vtable (user_fields, tail_array_size, init) -Return a new, self-describing vtable structure. - -@var{user-fields} is a string describing user defined fields of the -vtable beginning at index @code{vtable-offset-user} -(see @code{make-struct-layout}). - -@var{tail-size} specifies the size of the tail-array (if any) of -this vtable. - -@var{init1}, @dots{} are the optional initializers for the fields of -the vtable. - -Vtables have one initializable system field---the struct printer. -This field comes before the user fields in the initializers passed -to @code{make-vtable-vtable} and @code{make-struct}, and thus works as -a third optional argument to @code{make-vtable-vtable} and a fourth to -@code{make-struct} when creating vtables: - -If the value is a procedure, it will be called instead of the standard -printer whenever a struct described by this vtable is printed. -The procedure will be called with arguments STRUCT and PORT. - -The structure of a struct is described by a vtable, so the vtable is -in essence the type of the struct. The vtable is itself a struct with -a vtable. This could go on forever if it weren't for the -vtable-vtables which are self-describing vtables, and thus terminate -the chain. - -There are several potential ways of using structs, but the standard -one is to use three kinds of structs, together building up a type -sub-system: one vtable-vtable working as the root and one or several -"types", each with a set of "instances". (The vtable-vtable should be -compared to the class which is the class of itself.) - -@lisp -(define ball-root (make-vtable-vtable "pr" 0)) - -(define (make-ball-type ball-color) - (make-struct ball-root 0 - (make-struct-layout "pw") - (lambda (ball port) - (format port "#" - (color ball) - (owner ball))) - ball-color)) -(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user)) -(define (owner ball) (struct-ref ball 0)) - -(define red (make-ball-type 'red)) -(define green (make-ball-type 'green)) - -(define (make-ball type owner) (make-struct type 0 owner)) - -(define ball (make-ball green 'Nisse)) -ball @result{} # -@end lisp -@end deffn - - struct-ref -@c snarfed from struct.c:542 -@deffn {Scheme Procedure} struct-ref handle pos -@deffnx {Scheme Procedure} struct-set! struct n value -@deffnx {C Function} scm_struct_ref (handle, pos) -Access (or modify) the @var{n}th field of @var{struct}. - -If the field is of type 'p', then it can be set to an arbitrary value. - -If the field is of type 'u', then it can only be set to a non-negative -integer value small enough to fit in one machine word. -@end deffn - - struct-set! -@c snarfed from struct.c:621 -@deffn {Scheme Procedure} struct-set! handle pos val -@deffnx {C Function} scm_struct_set_x (handle, pos, val) -Set the slot of the structure @var{handle} with index @var{pos} -to @var{val}. Signal an error if the slot can not be written -to. -@end deffn - - struct-vtable -@c snarfed from struct.c:692 -@deffn {Scheme Procedure} struct-vtable handle -@deffnx {C Function} scm_struct_vtable (handle) -Return the vtable structure that describes the type of @var{struct}. -@end deffn - - struct-vtable-tag -@c snarfed from struct.c:703 -@deffn {Scheme Procedure} struct-vtable-tag handle -@deffnx {C Function} scm_struct_vtable_tag (handle) -Return the vtable tag of the structure @var{handle}. -@end deffn - - struct-vtable-name -@c snarfed from struct.c:742 -@deffn {Scheme Procedure} struct-vtable-name vtable -@deffnx {C Function} scm_struct_vtable_name (vtable) -Return the name of the vtable @var{vtable}. -@end deffn - - set-struct-vtable-name! -@c snarfed from struct.c:752 -@deffn {Scheme Procedure} set-struct-vtable-name! vtable name -@deffnx {C Function} scm_set_struct_vtable_name_x (vtable, name) -Set the name of the vtable @var{vtable} to @var{name}. -@end deffn - - symbol? -@c snarfed from symbols.c:156 -@deffn {Scheme Procedure} symbol? obj -@deffnx {C Function} scm_symbol_p (obj) -Return @code{#t} if @var{obj} is a symbol, otherwise return -@code{#f}. -@end deffn - - symbol-interned? -@c snarfed from symbols.c:166 -@deffn {Scheme Procedure} symbol-interned? symbol -@deffnx {C Function} scm_symbol_interned_p (symbol) -Return @code{#t} if @var{symbol} is interned, otherwise return -@code{#f}. -@end deffn - - make-symbol -@c snarfed from symbols.c:178 -@deffn {Scheme Procedure} make-symbol name -@deffnx {C Function} scm_make_symbol (name) -Return a new uninterned symbol with the name @var{name}. The returned symbol is guaranteed to be unique and future calls to @code{string->symbol} will not return it. -@end deffn - - symbol->string -@c snarfed from symbols.c:210 -@deffn {Scheme Procedure} symbol->string s -@deffnx {C Function} scm_symbol_to_string (s) -Return the name of @var{symbol} as a string. If the symbol was -part of an object returned as the value of a literal expression -(section @pxref{Literal expressions,,,r5rs, The Revised^5 -Report on Scheme}) or by a call to the @code{read} procedure, -and its name contains alphabetic characters, then the string -returned will contain characters in the implementation's -preferred standard case---some implementations will prefer -upper case, others lower case. If the symbol was returned by -@code{string->symbol}, the case of characters in the string -returned will be the same as the case in the string that was -passed to @code{string->symbol}. It is an error to apply -mutation procedures like @code{string-set!} to strings returned -by this procedure. - -The following examples assume that the implementation's -standard case is lower case: - -@lisp -(symbol->string 'flying-fish) @result{} "flying-fish" -(symbol->string 'Martin) @result{} "martin" -(symbol->string - (string->symbol "Malvina")) @result{} "Malvina" -@end lisp -@end deffn - - string->symbol -@c snarfed from symbols.c:240 -@deffn {Scheme Procedure} string->symbol string -@deffnx {C Function} scm_string_to_symbol (string) -Return the symbol whose name is @var{string}. This procedure -can create symbols with names containing special characters or -letters in the non-standard case, but it is usually a bad idea -to create such symbols because in some implementations of -Scheme they cannot be read as themselves. See -@code{symbol->string}. - -The following examples assume that the implementation's -standard case is lower case: - -@lisp -(eq? 'mISSISSIppi 'mississippi) @result{} #t -(string->symbol "mISSISSIppi") @result{} @r{the symbol with name "mISSISSIppi"} -(eq? 'bitBlt (string->symbol "bitBlt")) @result{} #f -(eq? 'JollyWog - (string->symbol (symbol->string 'JollyWog))) @result{} #t -(string=? "K. Harper, M.D." - (symbol->string - (string->symbol "K. Harper, M.D."))) @result{}#t -@end lisp -@end deffn - - string-ci->symbol -@c snarfed from symbols.c:252 -@deffn {Scheme Procedure} string-ci->symbol str -@deffnx {C Function} scm_string_ci_to_symbol (str) -Return the symbol whose name is @var{str}. @var{str} is -converted to lowercase before the conversion is done, if Guile -is currently reading symbols case-insensitively. -@end deffn - - gensym -@c snarfed from symbols.c:269 -@deffn {Scheme Procedure} gensym [prefix] -@deffnx {C Function} scm_gensym (prefix) -Create a new symbol with a name constructed from a prefix and -a counter value. The string @var{prefix} can be specified as -an optional argument. Default prefix is @code{ g}. The counter -is increased by 1 at each call. There is no provision for -resetting the counter. -@end deffn - - symbol-hash -@c snarfed from symbols.c:295 -@deffn {Scheme Procedure} symbol-hash symbol -@deffnx {C Function} scm_symbol_hash (symbol) -Return a hash value for @var{symbol}. -@end deffn - - symbol-fref -@c snarfed from symbols.c:305 -@deffn {Scheme Procedure} symbol-fref s -@deffnx {C Function} scm_symbol_fref (s) -Return the contents of @var{symbol}'s @dfn{function slot}. -@end deffn - - symbol-pref -@c snarfed from symbols.c:316 -@deffn {Scheme Procedure} symbol-pref s -@deffnx {C Function} scm_symbol_pref (s) -Return the @dfn{property list} currently associated with @var{symbol}. -@end deffn - - symbol-fset! -@c snarfed from symbols.c:327 -@deffn {Scheme Procedure} symbol-fset! s val -@deffnx {C Function} scm_symbol_fset_x (s, val) -Change the binding of @var{symbol}'s function slot. -@end deffn - - symbol-pset! -@c snarfed from symbols.c:339 -@deffn {Scheme Procedure} symbol-pset! s val -@deffnx {C Function} scm_symbol_pset_x (s, val) -Change the binding of @var{symbol}'s property slot. -@end deffn - - call-with-new-thread -@c snarfed from threads.c:611 -@deffn {Scheme Procedure} call-with-new-thread thunk [handler] -@deffnx {C Function} scm_call_with_new_thread (thunk, handler) -Call @code{thunk} in a new thread and with a new dynamic state, -returning a new thread object representing the thread. The procedure -@var{thunk} is called via @code{with-continuation-barrier}. - -When @var{handler} is specified, then @var{thunk} is called from -within a @code{catch} with tag @code{#t} that has @var{handler} as its -handler. This catch is established inside the continuation barrier. - -Once @var{thunk} or @var{handler} returns, the return value is made -the @emph{exit value} of the thread and the thread is terminated. -@end deffn - - yield -@c snarfed from threads.c:722 -@deffn {Scheme Procedure} yield -@deffnx {C Function} scm_yield () -Move the calling thread to the end of the scheduling queue. -@end deffn - - join-thread -@c snarfed from threads.c:732 -@deffn {Scheme Procedure} join-thread thread -@deffnx {C Function} scm_join_thread (thread) -Suspend execution of the calling thread until the target @var{thread} terminates, unless the target @var{thread} has already terminated. -@end deffn - - make-mutex -@c snarfed from threads.c:828 -@deffn {Scheme Procedure} make-mutex -@deffnx {C Function} scm_make_mutex () -Create a new mutex. -@end deffn - - make-recursive-mutex -@c snarfed from threads.c:837 -@deffn {Scheme Procedure} make-recursive-mutex -@deffnx {C Function} scm_make_recursive_mutex () -Create a new recursive mutex. -@end deffn - - lock-mutex -@c snarfed from threads.c:883 -@deffn {Scheme Procedure} lock-mutex mx -@deffnx {C Function} scm_lock_mutex (mx) -Lock @var{mutex}. If the mutex is already locked, the calling thread blocks until the mutex becomes available. The function returns when the calling thread owns the lock on @var{mutex}. Locking a mutex that a thread already owns will succeed right away and will not block the thread. That is, Guile's mutexes are @emph{recursive}. -@end deffn - - try-mutex -@c snarfed from threads.c:931 -@deffn {Scheme Procedure} try-mutex mutex -@deffnx {C Function} scm_try_mutex (mutex) -Try to lock @var{mutex}. If the mutex is already locked by someone else, return @code{#f}. Else lock the mutex and return @code{#t}. -@end deffn - - unlock-mutex -@c snarfed from threads.c:976 -@deffn {Scheme Procedure} unlock-mutex mx -@deffnx {C Function} scm_unlock_mutex (mx) -Unlocks @var{mutex} if the calling thread owns the lock on @var{mutex}. Calling unlock-mutex on a mutex not owned by the current thread results in undefined behaviour. Once a mutex has been unlocked, one thread blocked on @var{mutex} is awakened and grabs the mutex lock. Every call to @code{lock-mutex} by this thread must be matched with a call to @code{unlock-mutex}. Only the last call to @code{unlock-mutex} will actually unlock the mutex. -@end deffn - - make-condition-variable -@c snarfed from threads.c:1052 -@deffn {Scheme Procedure} make-condition-variable -@deffnx {C Function} scm_make_condition_variable () -Make a new condition variable. -@end deffn - - wait-condition-variable -@c snarfed from threads.c:1120 -@deffn {Scheme Procedure} wait-condition-variable cv mx [t] -@deffnx {C Function} scm_timed_wait_condition_variable (cv, mx, t) -Wait until @var{cond-var} has been signalled. While waiting, @var{mutex} is atomically unlocked (as with @code{unlock-mutex}) and is locked again when this function returns. When @var{time} is given, it specifies a point in time where the waiting should be aborted. It can be either a integer as returned by @code{current-time} or a pair as returned by @code{gettimeofday}. When the waiting is aborted the mutex is locked and @code{#f} is returned. When the condition variable is in fact signalled, the mutex is also locked and @code{#t} is returned. -@end deffn - - signal-condition-variable -@c snarfed from threads.c:1157 -@deffn {Scheme Procedure} signal-condition-variable cv -@deffnx {C Function} scm_signal_condition_variable (cv) -Wake up one thread that is waiting for @var{cv} -@end deffn - - broadcast-condition-variable -@c snarfed from threads.c:1177 -@deffn {Scheme Procedure} broadcast-condition-variable cv -@deffnx {C Function} scm_broadcast_condition_variable (cv) -Wake up all threads that are waiting for @var{cv}. -@end deffn - - current-thread -@c snarfed from threads.c:1354 -@deffn {Scheme Procedure} current-thread -@deffnx {C Function} scm_current_thread () -Return the thread that called this function. -@end deffn - - all-threads -@c snarfed from threads.c:1372 -@deffn {Scheme Procedure} all-threads -@deffnx {C Function} scm_all_threads () -Return a list of all threads. -@end deffn - - thread-exited? -@c snarfed from threads.c:1398 -@deffn {Scheme Procedure} thread-exited? thread -@deffnx {C Function} scm_thread_exited_p (thread) -Return @code{#t} iff @var{thread} has exited. - -@end deffn - - catch -@c snarfed from throw.c:512 -@deffn {Scheme Procedure} catch key thunk handler -@deffnx {C Function} scm_catch (key, thunk, handler) -Invoke @var{thunk} in the dynamic context of @var{handler} for -exceptions matching @var{key}. If thunk throws to the symbol -@var{key}, then @var{handler} is invoked this way: -@lisp -(handler key args ...) -@end lisp - -@var{key} is a symbol or @code{#t}. - -@var{thunk} takes no arguments. If @var{thunk} returns -normally, that is the return value of @code{catch}. - -Handler is invoked outside the scope of its own @code{catch}. -If @var{handler} again throws to the same key, a new handler -from further up the call chain is invoked. - -If the key is @code{#t}, then a throw to @emph{any} symbol will -match this call to @code{catch}. -@end deffn - - lazy-catch -@c snarfed from throw.c:540 -@deffn {Scheme Procedure} lazy-catch key thunk handler -@deffnx {C Function} scm_lazy_catch (key, thunk, handler) -This behaves exactly like @code{catch}, except that it does -not unwind the stack before invoking @var{handler}. -The @var{handler} procedure is not allowed to return: -it must throw to another catch, or otherwise exit non-locally. -@end deffn - - throw -@c snarfed from throw.c:573 -@deffn {Scheme Procedure} throw key . args -@deffnx {C Function} scm_throw (key, args) -Invoke the catch form matching @var{key}, passing @var{args} to the -@var{handler}. - -@var{key} is a symbol. It will match catches of the same symbol or of -@code{#t}. - -If there is no handler at all, Guile prints an error and then exits. -@end deffn - - values -@c snarfed from values.c:53 -@deffn {Scheme Procedure} values . args -@deffnx {C Function} scm_values (args) -Delivers all of its arguments to its continuation. Except for -continuations created by the @code{call-with-values} procedure, -all continuations take exactly one value. The effect of -passing no value or more than one value to continuations that -were not created by @code{call-with-values} is unspecified. -@end deffn - - make-variable -@c snarfed from variable.c:52 -@deffn {Scheme Procedure} make-variable init -@deffnx {C Function} scm_make_variable (init) -Return a variable initialized to value @var{init}. -@end deffn - - make-undefined-variable -@c snarfed from variable.c:62 -@deffn {Scheme Procedure} make-undefined-variable -@deffnx {C Function} scm_make_undefined_variable () -Return a variable that is initially unbound. -@end deffn - - variable? -@c snarfed from variable.c:73 -@deffn {Scheme Procedure} variable? obj -@deffnx {C Function} scm_variable_p (obj) -Return @code{#t} iff @var{obj} is a variable object, else -return @code{#f}. -@end deffn - - variable-ref -@c snarfed from variable.c:85 -@deffn {Scheme Procedure} variable-ref var -@deffnx {C Function} scm_variable_ref (var) -Dereference @var{var} and return its value. -@var{var} must be a variable object; see @code{make-variable} -and @code{make-undefined-variable}. -@end deffn - - variable-set! -@c snarfed from variable.c:101 -@deffn {Scheme Procedure} variable-set! var val -@deffnx {C Function} scm_variable_set_x (var, val) -Set the value of the variable @var{var} to @var{val}. -@var{var} must be a variable object, @var{val} can be any -value. Return an unspecified value. -@end deffn - - variable-bound? -@c snarfed from variable.c:113 -@deffn {Scheme Procedure} variable-bound? var -@deffnx {C Function} scm_variable_bound_p (var) -Return @code{#t} iff @var{var} is bound to a value. -Throws an error if @var{var} is not a variable object. -@end deffn - - vector? -@c snarfed from vectors.c:91 -@deffn {Scheme Procedure} vector? obj -@deffnx {C Function} scm_vector_p (obj) -Return @code{#t} if @var{obj} is a vector, otherwise return -@code{#f}. -@end deffn - - list->vector -@c snarfed from vectors.c:123 -@deffn {Scheme Procedure} list->vector -implemented by the C function "scm_vector" -@end deffn - - vector -@c snarfed from vectors.c:140 -@deffn {Scheme Procedure} vector . l -@deffnx {Scheme Procedure} list->vector l -@deffnx {C Function} scm_vector (l) -Return a newly allocated vector composed of the -given arguments. Analogous to @code{list}. - -@lisp -(vector 'a 'b 'c) @result{} #(a b c) -@end lisp -@end deffn - - make-vector -@c snarfed from vectors.c:276 -@deffn {Scheme Procedure} make-vector k [fill] -@deffnx {C Function} scm_make_vector (k, fill) -Return a newly allocated vector of @var{k} elements. If a -second argument is given, then each position is initialized to -@var{fill}. Otherwise the initial contents of each position is -unspecified. -@end deffn - - vector-copy -@c snarfed from vectors.c:318 -@deffn {Scheme Procedure} vector-copy vec -@deffnx {C Function} scm_vector_copy (vec) -Return a copy of @var{vec}. -@end deffn - - vector->list -@c snarfed from vectors.c:389 -@deffn {Scheme Procedure} vector->list v -@deffnx {C Function} scm_vector_to_list (v) -Return a newly allocated list composed of the elements of @var{v}. - -@lisp -(vector->list '#(dah dah didah)) @result{} (dah dah didah) -(list->vector '(dididit dah)) @result{} #(dididit dah) -@end lisp -@end deffn - - vector-fill! -@c snarfed from vectors.c:413 -@deffn {Scheme Procedure} vector-fill! v fill -@deffnx {C Function} scm_vector_fill_x (v, fill) -Store @var{fill} in every position of @var{vector}. The value -returned by @code{vector-fill!} is unspecified. -@end deffn - - vector-move-left! -@c snarfed from vectors.c:450 -@deffn {Scheme Procedure} vector-move-left! vec1 start1 end1 vec2 start2 -@deffnx {C Function} scm_vector_move_left_x (vec1, start1, end1, vec2, start2) -Copy elements from @var{vec1}, positions @var{start1} to @var{end1}, -to @var{vec2} starting at position @var{start2}. @var{start1} and -@var{start2} are inclusive indices; @var{end1} is exclusive. - -@code{vector-move-left!} copies elements in leftmost order. -Therefore, in the case where @var{vec1} and @var{vec2} refer to the -same vector, @code{vector-move-left!} is usually appropriate when -@var{start1} is greater than @var{start2}. -@end deffn - - vector-move-right! -@c snarfed from vectors.c:488 -@deffn {Scheme Procedure} vector-move-right! vec1 start1 end1 vec2 start2 -@deffnx {C Function} scm_vector_move_right_x (vec1, start1, end1, vec2, start2) -Copy elements from @var{vec1}, positions @var{start1} to @var{end1}, -to @var{vec2} starting at position @var{start2}. @var{start1} and -@var{start2} are inclusive indices; @var{end1} is exclusive. - -@code{vector-move-right!} copies elements in rightmost order. -Therefore, in the case where @var{vec1} and @var{vec2} refer to the -same vector, @code{vector-move-right!} is usually appropriate when -@var{start1} is less than @var{start2}. -@end deffn - - generalized-vector? -@c snarfed from vectors.c:537 -@deffn {Scheme Procedure} generalized-vector? obj -@deffnx {C Function} scm_generalized_vector_p (obj) -Return @code{#t} if @var{obj} is a vector, string, -bitvector, or uniform numeric vector. -@end deffn - - generalized-vector-length -@c snarfed from vectors.c:569 -@deffn {Scheme Procedure} generalized-vector-length v -@deffnx {C Function} scm_generalized_vector_length (v) -Return the length of the generalized vector @var{v}. -@end deffn - - generalized-vector-ref -@c snarfed from vectors.c:594 -@deffn {Scheme Procedure} generalized-vector-ref v idx -@deffnx {C Function} scm_generalized_vector_ref (v, idx) -Return the element at index @var{idx} of the -generalized vector @var{v}. -@end deffn - - generalized-vector-set! -@c snarfed from vectors.c:619 -@deffn {Scheme Procedure} generalized-vector-set! v idx val -@deffnx {C Function} scm_generalized_vector_set_x (v, idx, val) -Set the element at index @var{idx} of the -generalized vector @var{v} to @var{val}. -@end deffn - - generalized-vector->list -@c snarfed from vectors.c:630 -@deffn {Scheme Procedure} generalized-vector->list v -@deffnx {C Function} scm_generalized_vector_to_list (v) -Return a new list whose elements are the elements of the -generalized vector @var{v}. -@end deffn - - major-version -@c snarfed from version.c:35 -@deffn {Scheme Procedure} major-version -@deffnx {C Function} scm_major_version () -Return a string containing Guile's major version number. -E.g., the 1 in "1.6.5". -@end deffn - - minor-version -@c snarfed from version.c:48 -@deffn {Scheme Procedure} minor-version -@deffnx {C Function} scm_minor_version () -Return a string containing Guile's minor version number. -E.g., the 6 in "1.6.5". -@end deffn - - micro-version -@c snarfed from version.c:61 -@deffn {Scheme Procedure} micro-version -@deffnx {C Function} scm_micro_version () -Return a string containing Guile's micro version number. -E.g., the 5 in "1.6.5". -@end deffn - - version -@c snarfed from version.c:83 -@deffn {Scheme Procedure} version -@deffnx {Scheme Procedure} major-version -@deffnx {Scheme Procedure} minor-version -@deffnx {Scheme Procedure} micro-version -@deffnx {C Function} scm_version () -Return a string describing Guile's version number, or its major, minor -or micro version number, respectively. - -@lisp -(version) @result{} "1.6.0" -(major-version) @result{} "1" -(minor-version) @result{} "6" -(micro-version) @result{} "0" -@end lisp -@end deffn - - effective-version -@c snarfed from version.c:113 -@deffn {Scheme Procedure} effective-version -@deffnx {C Function} scm_effective_version () -Return a string describing Guile's effective version number. -@lisp -(version) @result{} "1.6.0" -(effective-version) @result{} "1.6" -(major-version) @result{} "1" -(minor-version) @result{} "6" -(micro-version) @result{} "0" -@end lisp -@end deffn - - make-soft-port -@c snarfed from vports.c:185 -@deffn {Scheme Procedure} make-soft-port pv modes -@deffnx {C Function} scm_make_soft_port (pv, modes) -Return a port capable of receiving or delivering characters as -specified by the @var{modes} string (@pxref{File Ports, -open-file}). @var{pv} must be a vector of length 5 or 6. Its -components are as follows: - -@enumerate 0 -@item -procedure accepting one character for output -@item -procedure accepting a string for output -@item -thunk for flushing output -@item -thunk for getting one character -@item -thunk for closing port (not by garbage collection) -@item -(if present and not @code{#f}) thunk for computing the number of -characters that can be read from the port without blocking. -@end enumerate - -For an output-only port only elements 0, 1, 2, and 4 need be -procedures. For an input-only port only elements 3 and 4 need -be procedures. Thunks 2 and 4 can instead be @code{#f} if -there is no useful operation for them to perform. - -If thunk 3 returns @code{#f} or an @code{eof-object} -(@pxref{Input, eof-object?, ,r5rs, The Revised^5 Report on -Scheme}) it indicates that the port has reached end-of-file. -For example: - -@lisp -(define stdout (current-output-port)) -(define p (make-soft-port - (vector - (lambda (c) (write c stdout)) - (lambda (s) (display s stdout)) - (lambda () (display "." stdout)) - (lambda () (char-upcase (read-char))) - (lambda () (display "@@" stdout))) - "rw")) - -(write p p) @result{} # -@end lisp -@end deffn - - make-weak-vector -@c snarfed from weaks.c:74 -@deffn {Scheme Procedure} make-weak-vector size [fill] -@deffnx {C Function} scm_make_weak_vector (size, fill) -Return a weak vector with @var{size} elements. If the optional -argument @var{fill} is given, all entries in the vector will be -set to @var{fill}. The default value for @var{fill} is the -empty list. -@end deffn - - list->weak-vector -@c snarfed from weaks.c:82 -@deffn {Scheme Procedure} list->weak-vector -implemented by the C function "scm_weak_vector" -@end deffn - - weak-vector -@c snarfed from weaks.c:90 -@deffn {Scheme Procedure} weak-vector . l -@deffnx {Scheme Procedure} list->weak-vector l -@deffnx {C Function} scm_weak_vector (l) -Construct a weak vector from a list: @code{weak-vector} uses -the list of its arguments while @code{list->weak-vector} uses -its only argument @var{l} (a list) to construct a weak vector -the same way @code{list->vector} would. -@end deffn - - weak-vector? -@c snarfed from weaks.c:120 -@deffn {Scheme Procedure} weak-vector? obj -@deffnx {C Function} scm_weak_vector_p (obj) -Return @code{#t} if @var{obj} is a weak vector. Note that all -weak hashes are also weak vectors. -@end deffn - - make-weak-key-alist-vector -@c snarfed from weaks.c:138 -@deffn {Scheme Procedure} make-weak-key-alist-vector [size] -@deffnx {Scheme Procedure} make-weak-value-alist-vector size -@deffnx {Scheme Procedure} make-doubly-weak-alist-vector size -@deffnx {C Function} scm_make_weak_key_alist_vector (size) -Return a weak hash table with @var{size} buckets. As with any -hash table, choosing a good size for the table requires some -caution. - -You can modify weak hash tables in exactly the same way you -would modify regular hash tables. (@pxref{Hash Tables}) -@end deffn - - make-weak-value-alist-vector -@c snarfed from weaks.c:150 -@deffn {Scheme Procedure} make-weak-value-alist-vector [size] -@deffnx {C Function} scm_make_weak_value_alist_vector (size) -Return a hash table with weak values with @var{size} buckets. -(@pxref{Hash Tables}) -@end deffn - - make-doubly-weak-alist-vector -@c snarfed from weaks.c:162 -@deffn {Scheme Procedure} make-doubly-weak-alist-vector size -@deffnx {C Function} scm_make_doubly_weak_alist_vector (size) -Return a hash table with weak keys and values with @var{size} -buckets. (@pxref{Hash Tables}) -@end deffn - - weak-key-alist-vector? -@c snarfed from weaks.c:177 -@deffn {Scheme Procedure} weak-key-alist-vector? obj -@deffnx {Scheme Procedure} weak-value-alist-vector? obj -@deffnx {Scheme Procedure} doubly-weak-alist-vector? obj -@deffnx {C Function} scm_weak_key_alist_vector_p (obj) -Return @code{#t} if @var{obj} is the specified weak hash -table. Note that a doubly weak hash table is neither a weak key -nor a weak value hash table. -@end deffn - - weak-value-alist-vector? -@c snarfed from weaks.c:187 -@deffn {Scheme Procedure} weak-value-alist-vector? obj -@deffnx {C Function} scm_weak_value_alist_vector_p (obj) -Return @code{#t} if @var{obj} is a weak value hash table. -@end deffn - - doubly-weak-alist-vector? -@c snarfed from weaks.c:197 -@deffn {Scheme Procedure} doubly-weak-alist-vector? obj -@deffnx {C Function} scm_doubly_weak_alist_vector_p (obj) -Return @code{#t} if @var{obj} is a doubly weak hash table. -@end deffn - - array-fill! -@c snarfed from ramap.c:352 -@deffn {Scheme Procedure} array-fill! ra fill -@deffnx {C Function} scm_array_fill_x (ra, fill) -Store @var{fill} in every element of @var{array}. The value returned -is unspecified. -@end deffn - - array-copy-in-order! -@c snarfed from ramap.c:399 -@deffn {Scheme Procedure} array-copy-in-order! -implemented by the C function "scm_array_copy_x" -@end deffn - - array-copy! -@c snarfed from ramap.c:408 -@deffn {Scheme Procedure} array-copy! src dst -@deffnx {Scheme Procedure} array-copy-in-order! src dst -@deffnx {C Function} scm_array_copy_x (src, dst) -Copy every element from vector or array @var{source} to the -corresponding element of @var{destination}. @var{destination} must have -the same rank as @var{source}, and be at least as large in each -dimension. The order is unspecified. -@end deffn - - array-map-in-order! -@c snarfed from ramap.c:798 -@deffn {Scheme Procedure} array-map-in-order! -implemented by the C function "scm_array_map_x" -@end deffn - - array-map! -@c snarfed from ramap.c:809 -@deffn {Scheme Procedure} array-map! ra0 proc . lra -@deffnx {Scheme Procedure} array-map-in-order! ra0 proc . lra -@deffnx {C Function} scm_array_map_x (ra0, proc, lra) -@var{array1}, @dots{} must have the same number of dimensions as -@var{array0} and have a range for each index which includes the range -for the corresponding index in @var{array0}. @var{proc} is applied to -each tuple of elements of @var{array1} @dots{} and the result is stored -as the corresponding element in @var{array0}. The value returned is -unspecified. The order of application is unspecified. -@end deffn - - array-for-each -@c snarfed from ramap.c:950 -@deffn {Scheme Procedure} array-for-each proc ra0 . lra -@deffnx {C Function} scm_array_for_each (proc, ra0, lra) -Apply @var{proc} to each tuple of elements of @var{array0} @dots{} -in row-major order. The value returned is unspecified. -@end deffn - - array-index-map! -@c snarfed from ramap.c:978 -@deffn {Scheme Procedure} array-index-map! ra proc -@deffnx {C Function} scm_array_index_map_x (ra, proc) -Apply @var{proc} to the indices of each element of @var{array} in -turn, storing the result in the corresponding element. The value -returned and the order of application are unspecified. - -One can implement @var{array-indexes} as -@lisp -(define (array-indexes array) - (let ((ra (apply make-array #f (array-shape array)))) - (array-index-map! ra (lambda x x)) - ra)) -@end lisp -Another example: -@lisp -(define (apl:index-generator n) - (let ((v (make-uniform-vector n 1))) - (array-index-map! v (lambda (i) i)) - v)) -@end lisp -@end deffn - - array? -@c snarfed from unif.c:501 -@deffn {Scheme Procedure} array? obj [prot] -@deffnx {C Function} scm_array_p (obj, prot) -Return @code{#t} if the @var{obj} is an array, and @code{#f} if -not. -@end deffn - - typed-array? -@c snarfed from unif.c:548 -@deffn {Scheme Procedure} typed-array? obj type -@deffnx {C Function} scm_typed_array_p (obj, type) -Return @code{#t} if the @var{obj} is an array of type -@var{type}, and @code{#f} if not. -@end deffn - - array-rank -@c snarfed from unif.c:569 -@deffn {Scheme Procedure} array-rank array -@deffnx {C Function} scm_array_rank (array) -Return the number of dimensions of the array @var{array.} - -@end deffn - - array-dimensions -@c snarfed from unif.c:583 -@deffn {Scheme Procedure} array-dimensions ra -@deffnx {C Function} scm_array_dimensions (ra) -@code{array-dimensions} is similar to @code{array-shape} but replaces -elements with a @code{0} minimum with one greater than the maximum. So: -@lisp -(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5) -@end lisp -@end deffn - - shared-array-root -@c snarfed from unif.c:611 -@deffn {Scheme Procedure} shared-array-root ra -@deffnx {C Function} scm_shared_array_root (ra) -Return the root vector of a shared array. -@end deffn - - shared-array-offset -@c snarfed from unif.c:625 -@deffn {Scheme Procedure} shared-array-offset ra -@deffnx {C Function} scm_shared_array_offset (ra) -Return the root vector index of the first element in the array. -@end deffn - - shared-array-increments -@c snarfed from unif.c:641 -@deffn {Scheme Procedure} shared-array-increments ra -@deffnx {C Function} scm_shared_array_increments (ra) -For each dimension, return the distance between elements in the root vector. -@end deffn - - make-typed-array -@c snarfed from unif.c:740 -@deffn {Scheme Procedure} make-typed-array type fill . bounds -@deffnx {C Function} scm_make_typed_array (type, fill, bounds) -Create and return an array of type @var{type}. -@end deffn - - make-array -@c snarfed from unif.c:775 -@deffn {Scheme Procedure} make-array fill . bounds -@deffnx {C Function} scm_make_array (fill, bounds) -Create and return an array. -@end deffn - - dimensions->uniform-array -@c snarfed from unif.c:790 -@deffn {Scheme Procedure} dimensions->uniform-array dims prot [fill] -@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill] -@deffnx {C Function} scm_dimensions_to_uniform_array (dims, prot, fill) -Create and return a uniform array or vector of type -corresponding to @var{prototype} with dimensions @var{dims} or -length @var{length}. If @var{fill} is supplied, it's used to -fill the array, otherwise @var{prototype} is used. -@end deffn - - make-shared-array -@c snarfed from unif.c:843 -@deffn {Scheme Procedure} make-shared-array oldra mapfunc . dims -@deffnx {C Function} scm_make_shared_array (oldra, mapfunc, dims) -@code{make-shared-array} can be used to create shared subarrays of other -arrays. The @var{mapper} is a function that translates coordinates in -the new array into coordinates in the old array. A @var{mapper} must be -linear, and its range must stay within the bounds of the old array, but -it can be otherwise arbitrary. A simple example: -@lisp -(define fred (make-array #f 8 8)) -(define freds-diagonal - (make-shared-array fred (lambda (i) (list i i)) 8)) -(array-set! freds-diagonal 'foo 3) -(array-ref fred 3 3) @result{} foo -(define freds-center - (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2)) -(array-ref freds-center 0 0) @result{} foo -@end lisp -@end deffn - - transpose-array -@c snarfed from unif.c:961 -@deffn {Scheme Procedure} transpose-array ra . args -@deffnx {C Function} scm_transpose_array (ra, args) -Return an array sharing contents with @var{array}, but with -dimensions arranged in a different order. There must be one -@var{dim} argument for each dimension of @var{array}. -@var{dim0}, @var{dim1}, @dots{} should be integers between 0 -and the rank of the array to be returned. Each integer in that -range must appear at least once in the argument list. - -The values of @var{dim0}, @var{dim1}, @dots{} correspond to -dimensions in the array to be returned, their positions in the -argument list to dimensions of @var{array}. Several @var{dim}s -may have the same value, in which case the returned array will -have smaller rank than @var{array}. - -@lisp -(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d)) -(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d) -(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{} - #2((a 4) (b 5) (c 6)) -@end lisp -@end deffn - - enclose-array -@c snarfed from unif.c:1059 -@deffn {Scheme Procedure} enclose-array ra . axes -@deffnx {C Function} scm_enclose_array (ra, axes) -@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than -the rank of @var{array}. @var{enclose-array} returns an array -resembling an array of shared arrays. The dimensions of each shared -array are the same as the @var{dim}th dimensions of the original array, -the dimensions of the outer array are the same as those of the original -array that did not match a @var{dim}. - -An enclosed array is not a general Scheme array. Its elements may not -be set using @code{array-set!}. Two references to the same element of -an enclosed array will be @code{equal?} but will not in general be -@code{eq?}. The value returned by @var{array-prototype} when given an -enclosed array is unspecified. - -examples: -@lisp -(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{} - # - -(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{} - # -@end lisp -@end deffn - - array-in-bounds? -@c snarfed from unif.c:1132 -@deffn {Scheme Procedure} array-in-bounds? v . args -@deffnx {C Function} scm_array_in_bounds_p (v, args) -Return @code{#t} if its arguments would be acceptable to -@code{array-ref}. -@end deffn - - array-ref -@c snarfed from unif.c:1209 -@deffn {Scheme Procedure} array-ref v . args -@deffnx {C Function} scm_array_ref (v, args) -Return the element at the @code{(index1, index2)} element in -@var{array}. -@end deffn - - array-set! -@c snarfed from unif.c:1226 -@deffn {Scheme Procedure} array-set! v obj . args -@deffnx {C Function} scm_array_set_x (v, obj, args) -Set the element at the @code{(index1, index2)} element in @var{array} to -@var{new-value}. The value returned by array-set! is unspecified. -@end deffn - - array-contents -@c snarfed from unif.c:1252 -@deffn {Scheme Procedure} array-contents ra [strict] -@deffnx {C Function} scm_array_contents (ra, strict) -If @var{array} may be @dfn{unrolled} into a one dimensional shared array -without changing their order (last subscript changing fastest), then -@code{array-contents} returns that shared array, otherwise it returns -@code{#f}. All arrays made by @var{make-array} and -@var{make-uniform-array} may be unrolled, some arrays made by -@var{make-shared-array} may not be. - -If the optional argument @var{strict} is provided, a shared array will -be returned only if its elements are stored internally contiguous in -memory. -@end deffn - - uniform-array-read! -@c snarfed from unif.c:1352 -@deffn {Scheme Procedure} uniform-array-read! ura [port_or_fd [start [end]]] -@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end] -@deffnx {C Function} scm_uniform_array_read_x (ura, port_or_fd, start, end) -Attempt to read all elements of @var{ura}, in lexicographic order, as -binary objects from @var{port-or-fdes}. -If an end of file is encountered, -the objects up to that point are put into @var{ura} -(starting at the beginning) and the remainder of the array is -unchanged. - -The optional arguments @var{start} and @var{end} allow -a specified region of a vector (or linearized array) to be read, -leaving the remainder of the vector unchanged. - -@code{uniform-array-read!} returns the number of objects read. -@var{port-or-fdes} may be omitted, in which case it defaults to the value -returned by @code{(current-input-port)}. -@end deffn - - uniform-array-write -@c snarfed from unif.c:1406 -@deffn {Scheme Procedure} uniform-array-write ura [port_or_fd [start [end]]] -@deffnx {C Function} scm_uniform_array_write (ura, port_or_fd, start, end) -Writes all elements of @var{ura} as binary objects to -@var{port-or-fdes}. - -The optional arguments @var{start} -and @var{end} allow -a specified region of a vector (or linearized array) to be written. - -The number of objects actually written is returned. -@var{port-or-fdes} may be -omitted, in which case it defaults to the value returned by -@code{(current-output-port)}. -@end deffn - - bitvector? -@c snarfed from unif.c:1518 -@deffn {Scheme Procedure} bitvector? obj -@deffnx {C Function} scm_bitvector_p (obj) -Return @code{#t} when @var{obj} is a bitvector, else -return @code{#f}. -@end deffn - - make-bitvector -@c snarfed from unif.c:1545 -@deffn {Scheme Procedure} make-bitvector len [fill] -@deffnx {C Function} scm_make_bitvector (len, fill) -Create a new bitvector of length @var{len} and -optionally initialize all elements to @var{fill}. -@end deffn - - bitvector -@c snarfed from unif.c:1554 -@deffn {Scheme Procedure} bitvector . bits -@deffnx {C Function} scm_bitvector (bits) -Create a new bitvector with the arguments as elements. -@end deffn - - bitvector-length -@c snarfed from unif.c:1570 -@deffn {Scheme Procedure} bitvector-length vec -@deffnx {C Function} scm_bitvector_length (vec) -Return the length of the bitvector @var{vec}. -@end deffn - - bitvector-ref -@c snarfed from unif.c:1661 -@deffn {Scheme Procedure} bitvector-ref vec idx -@deffnx {C Function} scm_bitvector_ref (vec, idx) -Return the element at index @var{idx} of the bitvector -@var{vec}. -@end deffn - - bitvector-set! -@c snarfed from unif.c:1704 -@deffn {Scheme Procedure} bitvector-set! vec idx val -@deffnx {C Function} scm_bitvector_set_x (vec, idx, val) -Set the element at index @var{idx} of the bitvector -@var{vec} when @var{val} is true, else clear it. -@end deffn - - bitvector-fill! -@c snarfed from unif.c:1715 -@deffn {Scheme Procedure} bitvector-fill! vec val -@deffnx {C Function} scm_bitvector_fill_x (vec, val) -Set all elements of the bitvector -@var{vec} when @var{val} is true, else clear them. -@end deffn - - list->bitvector -@c snarfed from unif.c:1760 -@deffn {Scheme Procedure} list->bitvector list -@deffnx {C Function} scm_list_to_bitvector (list) -Return a new bitvector initialized with the elements -of @var{list}. -@end deffn - - bitvector->list -@c snarfed from unif.c:1790 -@deffn {Scheme Procedure} bitvector->list vec -@deffnx {C Function} scm_bitvector_to_list (vec) -Return a new list initialized with the elements -of the bitvector @var{vec}. -@end deffn - - bit-count -@c snarfed from unif.c:1854 -@deffn {Scheme Procedure} bit-count b bitvector -@deffnx {C Function} scm_bit_count (b, bitvector) -Return the number of occurrences of the boolean @var{b} in -@var{bitvector}. -@end deffn - - bit-position -@c snarfed from unif.c:1923 -@deffn {Scheme Procedure} bit-position item v k -@deffnx {C Function} scm_bit_position (item, v, k) -Return the index of the first occurrance of @var{item} in bit -vector @var{v}, starting from @var{k}. If there is no -@var{item} entry between @var{k} and the end of -@var{bitvector}, then return @code{#f}. For example, - -@example -(bit-position #t #*000101 0) @result{} 3 -(bit-position #f #*0001111 3) @result{} #f -@end example -@end deffn - - bit-set*! -@c snarfed from unif.c:2006 -@deffn {Scheme Procedure} bit-set*! v kv obj -@deffnx {C Function} scm_bit_set_star_x (v, kv, obj) -Set entries of bit vector @var{v} to @var{obj}, with @var{kv} -selecting the entries to change. The return value is -unspecified. - -If @var{kv} is a bit vector, then those entries where it has -@code{#t} are the ones in @var{v} which are set to @var{obj}. -@var{kv} and @var{v} must be the same length. When @var{obj} -is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when -@var{obj} is @code{#f} it can be seen as an ANDNOT. - -@example -(define bv #*01000010) -(bit-set*! bv #*10010001 #t) -bv -@result{} #*11010011 -@end example - -If @var{kv} is a u32vector, then its elements are -indices into @var{v} which are set to @var{obj}. - -@example -(define bv #*01000010) -(bit-set*! bv #u32(5 2 7) #t) -bv -@result{} #*01100111 -@end example -@end deffn - - bit-count* -@c snarfed from unif.c:2109 -@deffn {Scheme Procedure} bit-count* v kv obj -@deffnx {C Function} scm_bit_count_star (v, kv, obj) -Return a count of how many entries in bit vector @var{v} are -equal to @var{obj}, with @var{kv} selecting the entries to -consider. - -If @var{kv} is a bit vector, then those entries where it has -@code{#t} are the ones in @var{v} which are considered. -@var{kv} and @var{v} must be the same length. - -If @var{kv} is a u32vector, then it contains -the indexes in @var{v} to consider. - -For example, - -@example -(bit-count* #*01110111 #*11001101 #t) @result{} 3 -(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2 -@end example -@end deffn - - bit-invert! -@c snarfed from unif.c:2196 -@deffn {Scheme Procedure} bit-invert! v -@deffnx {C Function} scm_bit_invert_x (v) -Modify the bit vector @var{v} by replacing each element with -its negation. -@end deffn - - array->list -@c snarfed from unif.c:2303 -@deffn {Scheme Procedure} array->list v -@deffnx {C Function} scm_array_to_list (v) -Return a list consisting of all the elements, in order, of -@var{array}. -@end deffn - - list->typed-array -@c snarfed from unif.c:2332 -@deffn {Scheme Procedure} list->typed-array type shape lst -@deffnx {C Function} scm_list_to_typed_array (type, shape, lst) -Return an array of the type @var{type} -with elements the same as those of @var{lst}. - -The argument @var{shape} determines the number of dimensions -of the array and their shape. It is either an exact integer, -giving the -number of dimensions directly, or a list whose length -specifies the number of dimensions and each element specified -the lower and optionally the upper bound of the corresponding -dimension. -When the element is list of two elements, these elements -give the lower and upper bounds. When it is an exact -integer, it gives only the lower bound. -@end deffn - - list->array -@c snarfed from unif.c:2390 -@deffn {Scheme Procedure} list->array ndim lst -@deffnx {C Function} scm_list_to_array (ndim, lst) -Return an array with elements the same as those of @var{lst}. -@end deffn - - list->uniform-array -@c snarfed from unif.c:2440 -@deffn {Scheme Procedure} list->uniform-array ndim prot lst -@deffnx {C Function} scm_list_to_uniform_array (ndim, prot, lst) -Return a uniform array of the type indicated by prototype -@var{prot} with elements the same as those of @var{lst}. -Elements must be of the appropriate type, no coercions are -done. - -The argument @var{ndim} determines the number of dimensions -of the array. It is either an exact integer, giving the -number directly, or a list of exact integers, whose length -specifies the number of dimensions and each element is the -lower index bound of its dimension. -@end deffn - - array-type -@c snarfed from unif.c:2789 -@deffn {Scheme Procedure} array-type ra -@deffnx {C Function} scm_array_type (ra) - -@end deffn - - array-prototype -@c snarfed from unif.c:2809 -@deffn {Scheme Procedure} array-prototype ra -@deffnx {C Function} scm_array_prototype (ra) -Return an object that would produce an array of the same type -as @var{array}, if used as the @var{prototype} for -@code{make-uniform-array}. -@end deffn - - dynamic-link -@c snarfed from dynl.c:149 -@deffn {Scheme Procedure} dynamic-link filename -@deffnx {C Function} scm_dynamic_link (filename) -Find the shared object (shared library) denoted by -@var{filename} and link it into the running Guile -application. The returned -scheme object is a ``handle'' for the library which can -be passed to @code{dynamic-func}, @code{dynamic-call} etc. - -Searching for object files is system dependent. Normally, -if @var{filename} does have an explicit directory it will -be searched for in locations -such as @file{/usr/lib} and @file{/usr/local/lib}. -@end deffn - - dynamic-object? -@c snarfed from dynl.c:168 -@deffn {Scheme Procedure} dynamic-object? obj -@deffnx {C Function} scm_dynamic_object_p (obj) -Return @code{#t} if @var{obj} is a dynamic object handle, -or @code{#f} otherwise. -@end deffn - - dynamic-unlink -@c snarfed from dynl.c:182 -@deffn {Scheme Procedure} dynamic-unlink dobj -@deffnx {C Function} scm_dynamic_unlink (dobj) -Unlink a dynamic object from the application, if possible. The -object must have been linked by @code{dynamic-link}, with -@var{dobj} the corresponding handle. After this procedure -is called, the handle can no longer be used to access the -object. -@end deffn - - dynamic-func -@c snarfed from dynl.c:207 -@deffn {Scheme Procedure} dynamic-func name dobj -@deffnx {C Function} scm_dynamic_func (name, dobj) -Return a ``handle'' for the function @var{name} in the -shared object referred to by @var{dobj}. The handle -can be passed to @code{dynamic-call} to actually -call the function. - -Regardless whether your C compiler prepends an underscore -@samp{_} to the global names in a program, you should -@strong{not} include this underscore in @var{name} -since it will be added automatically when necessary. -@end deffn - - dynamic-call -@c snarfed from dynl.c:253 -@deffn {Scheme Procedure} dynamic-call func dobj -@deffnx {C Function} scm_dynamic_call (func, dobj) -Call a C function in a dynamic object. Two styles of -invocation are supported: - -@itemize @bullet -@item @var{func} can be a function handle returned by -@code{dynamic-func}. In this case @var{dobj} is -ignored -@item @var{func} can be a string with the name of the -function to call, with @var{dobj} the handle of the -dynamic object in which to find the function. -This is equivalent to -@smallexample - -(dynamic-call (dynamic-func @var{func} @var{dobj}) #f) -@end smallexample -@end itemize - -In either case, the function is passed no arguments -and its return value is ignored. -@end deffn - - dynamic-args-call -@c snarfed from dynl.c:285 -@deffn {Scheme Procedure} dynamic-args-call func dobj args -@deffnx {C Function} scm_dynamic_args_call (func, dobj, args) -Call the C function indicated by @var{func} and @var{dobj}, -just like @code{dynamic-call}, but pass it some arguments and -return its return value. The C function is expected to take -two arguments and return an @code{int}, just like @code{main}: -@smallexample -int c_func (int argc, char **argv); -@end smallexample - -The parameter @var{args} must be a list of strings and is -converted into an array of @code{char *}. The array is passed -in @var{argv} and its size in @var{argc}. The return value is -converted to a Scheme number and returned from the call to -@code{dynamic-args-call}. -@end deffn - - chown -@c snarfed from filesys.c:224 -@deffn {Scheme Procedure} chown object owner group -@deffnx {C Function} scm_chown (object, owner, group) -Change the ownership and group of the file referred to by @var{object} to -the integer values @var{owner} and @var{group}. @var{object} can be -a string containing a file name or, if the platform -supports fchown, a port or integer file descriptor -which is open on the file. The return value -is unspecified. - -If @var{object} is a symbolic link, either the -ownership of the link or the ownership of the referenced file will be -changed depending on the operating system (lchown is -unsupported at present). If @var{owner} or @var{group} is specified -as @code{-1}, then that ID is not changed. -@end deffn - - chmod -@c snarfed from filesys.c:262 -@deffn {Scheme Procedure} chmod object mode -@deffnx {C Function} scm_chmod (object, mode) -Changes the permissions of the file referred to by @var{obj}. -@var{obj} can be a string containing a file name or a port or integer file -descriptor which is open on a file (in which case @code{fchmod} is used -as the underlying system call). -@var{mode} specifies -the new permissions as a decimal number, e.g., @code{(chmod "foo" #o755)}. -The return value is unspecified. -@end deffn - - umask -@c snarfed from filesys.c:294 -@deffn {Scheme Procedure} umask [mode] -@deffnx {C Function} scm_umask (mode) -If @var{mode} is omitted, returns a decimal number representing the current -file creation mask. Otherwise the file creation mask is set to -@var{mode} and the previous value is returned. - -E.g., @code{(umask #o022)} sets the mask to octal 22, decimal 18. -@end deffn - - open-fdes -@c snarfed from filesys.c:316 -@deffn {Scheme Procedure} open-fdes path flags [mode] -@deffnx {C Function} scm_open_fdes (path, flags, mode) -Similar to @code{open} but return a file descriptor instead of -a port. -@end deffn - - open -@c snarfed from filesys.c:357 -@deffn {Scheme Procedure} open path flags [mode] -@deffnx {C Function} scm_open (path, flags, mode) -Open the file named by @var{path} for reading and/or writing. -@var{flags} is an integer specifying how the file should be opened. -@var{mode} is an integer specifying the permission bits of the file, if -it needs to be created, before the umask is applied. The default is 666 -(Unix itself has no default). - -@var{flags} can be constructed by combining variables using @code{logior}. -Basic flags are: - -@defvar O_RDONLY -Open the file read-only. -@end defvar -@defvar O_WRONLY -Open the file write-only. -@end defvar -@defvar O_RDWR -Open the file read/write. -@end defvar -@defvar O_APPEND -Append to the file instead of truncating. -@end defvar -@defvar O_CREAT -Create the file if it does not already exist. -@end defvar - -See the Unix documentation of the @code{open} system call -for additional flags. -@end deffn - - close -@c snarfed from filesys.c:395 -@deffn {Scheme Procedure} close fd_or_port -@deffnx {C Function} scm_close (fd_or_port) -Similar to close-port (@pxref{Closing, close-port}), -but also works on file descriptors. A side -effect of closing a file descriptor is that any ports using that file -descriptor are moved to a different file descriptor and have -their revealed counts set to zero. -@end deffn - - close-fdes -@c snarfed from filesys.c:422 -@deffn {Scheme Procedure} close-fdes fd -@deffnx {C Function} scm_close_fdes (fd) -A simple wrapper for the @code{close} system call. -Close file descriptor @var{fd}, which must be an integer. -Unlike close (@pxref{Ports and File Descriptors, close}), -the file descriptor will be closed even if a port is using it. -The return value is unspecified. -@end deffn - - stat -@c snarfed from filesys.c:624 -@deffn {Scheme Procedure} stat object -@deffnx {C Function} scm_stat (object) -Return an object containing various information about the file -determined by @var{obj}. @var{obj} can be a string containing -a file name or a port or integer file descriptor which is open -on a file (in which case @code{fstat} is used as the underlying -system call). - -The object returned by @code{stat} can be passed as a single -parameter to the following procedures, all of which return -integers: - -@table @code -@item stat:dev -The device containing the file. -@item stat:ino -The file serial number, which distinguishes this file from all -other files on the same device. -@item stat:mode -The mode of the file. This includes file type information and -the file permission bits. See @code{stat:type} and -@code{stat:perms} below. -@item stat:nlink -The number of hard links to the file. -@item stat:uid -The user ID of the file's owner. -@item stat:gid -The group ID of the file. -@item stat:rdev -Device ID; this entry is defined only for character or block -special files. -@item stat:size -The size of a regular file in bytes. -@item stat:atime -The last access time for the file. -@item stat:mtime -The last modification time for the file. -@item stat:ctime -The last modification time for the attributes of the file. -@item stat:blksize -The optimal block size for reading or writing the file, in -bytes. -@item stat:blocks -The amount of disk space that the file occupies measured in -units of 512 byte blocks. -@end table - -In addition, the following procedures return the information -from stat:mode in a more convenient form: - -@table @code -@item stat:type -A symbol representing the type of file. Possible values are -regular, directory, symlink, block-special, char-special, fifo, -socket and unknown -@item stat:perms -An integer representing the access permission bits. -@end table -@end deffn - - link -@c snarfed from filesys.c:686 -@deffn {Scheme Procedure} link oldpath newpath -@deffnx {C Function} scm_link (oldpath, newpath) -Creates a new name @var{newpath} in the file system for the -file named by @var{oldpath}. If @var{oldpath} is a symbolic -link, the link may or may not be followed depending on the -system. -@end deffn - - rename-file -@c snarfed from filesys.c:724 -@deffn {Scheme Procedure} rename-file oldname newname -@deffnx {C Function} scm_rename (oldname, newname) -Renames the file specified by @var{oldname} to @var{newname}. -The return value is unspecified. -@end deffn - - delete-file -@c snarfed from filesys.c:741 -@deffn {Scheme Procedure} delete-file str -@deffnx {C Function} scm_delete_file (str) -Deletes (or "unlinks") the file specified by @var{path}. -@end deffn - - mkdir -@c snarfed from filesys.c:758 -@deffn {Scheme Procedure} mkdir path [mode] -@deffnx {C Function} scm_mkdir (path, mode) -Create a new directory named by @var{path}. If @var{mode} is omitted -then the permissions of the directory file are set using the current -umask. Otherwise they are set to the decimal value specified with -@var{mode}. The return value is unspecified. -@end deffn - - rmdir -@c snarfed from filesys.c:785 -@deffn {Scheme Procedure} rmdir path -@deffnx {C Function} scm_rmdir (path) -Remove the existing directory named by @var{path}. The directory must -be empty for this to succeed. The return value is unspecified. -@end deffn - - directory-stream? -@c snarfed from filesys.c:809 -@deffn {Scheme Procedure} directory-stream? obj -@deffnx {C Function} scm_directory_stream_p (obj) -Return a boolean indicating whether @var{object} is a directory -stream as returned by @code{opendir}. -@end deffn - - opendir -@c snarfed from filesys.c:820 -@deffn {Scheme Procedure} opendir dirname -@deffnx {C Function} scm_opendir (dirname) -Open the directory specified by @var{path} and return a directory -stream. -@end deffn - - readdir -@c snarfed from filesys.c:841 -@deffn {Scheme Procedure} readdir port -@deffnx {C Function} scm_readdir (port) -Return (as a string) the next directory entry from the directory stream -@var{stream}. If there is no remaining entry to be read then the -end of file object is returned. -@end deffn - - rewinddir -@c snarfed from filesys.c:880 -@deffn {Scheme Procedure} rewinddir port -@deffnx {C Function} scm_rewinddir (port) -Reset the directory port @var{stream} so that the next call to -@code{readdir} will return the first directory entry. -@end deffn - - closedir -@c snarfed from filesys.c:897 -@deffn {Scheme Procedure} closedir port -@deffnx {C Function} scm_closedir (port) -Close the directory stream @var{stream}. -The return value is unspecified. -@end deffn - - chdir -@c snarfed from filesys.c:947 -@deffn {Scheme Procedure} chdir str -@deffnx {C Function} scm_chdir (str) -Change the current working directory to @var{path}. -The return value is unspecified. -@end deffn - - getcwd -@c snarfed from filesys.c:962 -@deffn {Scheme Procedure} getcwd -@deffnx {C Function} scm_getcwd () -Return the name of the current working directory. -@end deffn - - select -@c snarfed from filesys.c:1164 -@deffn {Scheme Procedure} select reads writes excepts [secs [usecs]] -@deffnx {C Function} scm_select (reads, writes, excepts, secs, usecs) -This procedure has a variety of uses: waiting for the ability -to provide input, accept output, or the existence of -exceptional conditions on a collection of ports or file -descriptors, or waiting for a timeout to occur. -It also returns if interrupted by a signal. - -@var{reads}, @var{writes} and @var{excepts} can be lists or -vectors, with each member a port or a file descriptor. -The value returned is a list of three corresponding -lists or vectors containing only the members which meet the -specified requirement. The ability of port buffers to -provide input or accept output is taken into account. -Ordering of the input lists or vectors is not preserved. - -The optional arguments @var{secs} and @var{usecs} specify the -timeout. Either @var{secs} can be specified alone, as -either an integer or a real number, or both @var{secs} and -@var{usecs} can be specified as integers, in which case -@var{usecs} is an additional timeout expressed in -microseconds. If @var{secs} is omitted or is @code{#f} then -select will wait for as long as it takes for one of the other -conditions to be satisfied. - -The scsh version of @code{select} differs as follows: -Only vectors are accepted for the first three arguments. -The @var{usecs} argument is not supported. -Multiple values are returned instead of a list. -Duplicates in the input vectors appear only once in output. -An additional @code{select!} interface is provided. -@end deffn - - fcntl -@c snarfed from filesys.c:1302 -@deffn {Scheme Procedure} fcntl object cmd [value] -@deffnx {C Function} scm_fcntl (object, cmd, value) -Apply @var{command} to the specified file descriptor or the underlying -file descriptor of the specified port. @var{value} is an optional -integer argument. - -Values for @var{command} are: - -@table @code -@item F_DUPFD -Duplicate a file descriptor -@item F_GETFD -Get flags associated with the file descriptor. -@item F_SETFD -Set flags associated with the file descriptor to @var{value}. -@item F_GETFL -Get flags associated with the open file. -@item F_SETFL -Set flags associated with the open file to @var{value} -@item F_GETOWN -Get the process ID of a socket's owner, for @code{SIGIO} signals. -@item F_SETOWN -Set the process that owns a socket to @var{value}, for @code{SIGIO} signals. -@item FD_CLOEXEC -The value used to indicate the "close on exec" flag with @code{F_GETFL} or -@code{F_SETFL}. -@end table -@end deffn - - fsync -@c snarfed from filesys.c:1334 -@deffn {Scheme Procedure} fsync object -@deffnx {C Function} scm_fsync (object) -Copies any unwritten data for the specified output file descriptor to disk. -If @var{port/fd} is a port, its buffer is flushed before the underlying -file descriptor is fsync'd. -The return value is unspecified. -@end deffn - - symlink -@c snarfed from filesys.c:1359 -@deffn {Scheme Procedure} symlink oldpath newpath -@deffnx {C Function} scm_symlink (oldpath, newpath) -Create a symbolic link named @var{path-to} with the value (i.e., pointing to) -@var{path-from}. The return value is unspecified. -@end deffn - - readlink -@c snarfed from filesys.c:1378 -@deffn {Scheme Procedure} readlink path -@deffnx {C Function} scm_readlink (path) -Return the value of the symbolic link named by @var{path} (a -string), i.e., the file that the link points to. -@end deffn - - lstat -@c snarfed from filesys.c:1420 -@deffn {Scheme Procedure} lstat str -@deffnx {C Function} scm_lstat (str) -Similar to @code{stat}, but does not follow symbolic links, i.e., -it will return information about a symbolic link itself, not the -file it points to. @var{path} must be a string. -@end deffn - - copy-file -@c snarfed from filesys.c:1443 -@deffn {Scheme Procedure} copy-file oldfile newfile -@deffnx {C Function} scm_copy_file (oldfile, newfile) -Copy the file specified by @var{path-from} to @var{path-to}. -The return value is unspecified. -@end deffn - - dirname -@c snarfed from filesys.c:1506 -@deffn {Scheme Procedure} dirname filename -@deffnx {C Function} scm_dirname (filename) -Return the directory name component of the file name -@var{filename}. If @var{filename} does not contain a directory -component, @code{.} is returned. -@end deffn - - basename -@c snarfed from filesys.c:1549 -@deffn {Scheme Procedure} basename filename [suffix] -@deffnx {C Function} scm_basename (filename, suffix) -Return the base name of the file name @var{filename}. The -base name is the file name without any directory components. -If @var{suffix} is provided, and is equal to the end of -@var{basename}, it is removed also. -@end deffn - - pipe -@c snarfed from posix.c:233 -@deffn {Scheme Procedure} pipe -@deffnx {C Function} scm_pipe () -Return a newly created pipe: a pair of ports which are linked -together on the local machine. The @emph{car} is the input -port and the @emph{cdr} is the output port. Data written (and -flushed) to the output port can be read from the input port. -Pipes are commonly used for communication with a newly forked -child process. The need to flush the output port can be -avoided by making it unbuffered using @code{setvbuf}. - -Writes occur atomically provided the size of the data in bytes -is not greater than the value of @code{PIPE_BUF}. Note that -the output port is likely to block if too much data (typically -equal to @code{PIPE_BUF}) has been written but not yet read -from the input port. -@end deffn - - getgroups -@c snarfed from posix.c:254 -@deffn {Scheme Procedure} getgroups -@deffnx {C Function} scm_getgroups () -Return a vector of integers representing the current -supplementary group IDs. -@end deffn - - setgroups -@c snarfed from posix.c:287 -@deffn {Scheme Procedure} setgroups group_vec -@deffnx {C Function} scm_setgroups (group_vec) -Set the current set of supplementary group IDs to the integers -in the given vector @var{vec}. The return value is -unspecified. - -Generally only the superuser can set the process group IDs. -@end deffn - - getpw -@c snarfed from posix.c:336 -@deffn {Scheme Procedure} getpw [user] -@deffnx {C Function} scm_getpwuid (user) -Look up an entry in the user database. @var{obj} can be an integer, -a string, or omitted, giving the behaviour of getpwuid, getpwnam -or getpwent respectively. -@end deffn - - setpw -@c snarfed from posix.c:386 -@deffn {Scheme Procedure} setpw [arg] -@deffnx {C Function} scm_setpwent (arg) -If called with a true argument, initialize or reset the password data -stream. Otherwise, close the stream. The @code{setpwent} and -@code{endpwent} procedures are implemented on top of this. -@end deffn - - getgr -@c snarfed from posix.c:405 -@deffn {Scheme Procedure} getgr [name] -@deffnx {C Function} scm_getgrgid (name) -Look up an entry in the group database. @var{obj} can be an integer, -a string, or omitted, giving the behaviour of getgrgid, getgrnam -or getgrent respectively. -@end deffn - - setgr -@c snarfed from posix.c:441 -@deffn {Scheme Procedure} setgr [arg] -@deffnx {C Function} scm_setgrent (arg) -If called with a true argument, initialize or reset the group data -stream. Otherwise, close the stream. The @code{setgrent} and -@code{endgrent} procedures are implemented on top of this. -@end deffn - - kill -@c snarfed from posix.c:477 -@deffn {Scheme Procedure} kill pid sig -@deffnx {C Function} scm_kill (pid, sig) -Sends a signal to the specified process or group of processes. - -@var{pid} specifies the processes to which the signal is sent: - -@table @r -@item @var{pid} greater than 0 -The process whose identifier is @var{pid}. -@item @var{pid} equal to 0 -All processes in the current process group. -@item @var{pid} less than -1 -The process group whose identifier is -@var{pid} -@item @var{pid} equal to -1 -If the process is privileged, all processes except for some special -system processes. Otherwise, all processes with the current effective -user ID. -@end table - -@var{sig} should be specified using a variable corresponding to -the Unix symbolic name, e.g., - -@defvar SIGHUP -Hang-up signal. -@end defvar - -@defvar SIGINT -Interrupt signal. -@end defvar -@end deffn - - waitpid -@c snarfed from posix.c:528 -@deffn {Scheme Procedure} waitpid pid [options] -@deffnx {C Function} scm_waitpid (pid, options) -This procedure collects status information from a child process which -has terminated or (optionally) stopped. Normally it will -suspend the calling process until this can be done. If more than one -child process is eligible then one will be chosen by the operating system. - -The value of @var{pid} determines the behaviour: - -@table @r -@item @var{pid} greater than 0 -Request status information from the specified child process. -@item @var{pid} equal to -1 or WAIT_ANY -Request status information for any child process. -@item @var{pid} equal to 0 or WAIT_MYPGRP -Request status information for any child process in the current process -group. -@item @var{pid} less than -1 -Request status information for any child process whose process group ID -is -@var{PID}. -@end table - -The @var{options} argument, if supplied, should be the bitwise OR of the -values of zero or more of the following variables: - -@defvar WNOHANG -Return immediately even if there are no child processes to be collected. -@end defvar - -@defvar WUNTRACED -Report status information for stopped processes as well as terminated -processes. -@end defvar - -The return value is a pair containing: - -@enumerate -@item -The process ID of the child process, or 0 if @code{WNOHANG} was -specified and no process was collected. -@item -The integer status value. -@end enumerate -@end deffn - - status:exit-val -@c snarfed from posix.c:554 -@deffn {Scheme Procedure} status:exit-val status -@deffnx {C Function} scm_status_exit_val (status) -Return the exit status value, as would be set if a process -ended normally through a call to @code{exit} or @code{_exit}, -if any, otherwise @code{#f}. -@end deffn - - status:term-sig -@c snarfed from posix.c:572 -@deffn {Scheme Procedure} status:term-sig status -@deffnx {C Function} scm_status_term_sig (status) -Return the signal number which terminated the process, if any, -otherwise @code{#f}. -@end deffn - - status:stop-sig -@c snarfed from posix.c:588 -@deffn {Scheme Procedure} status:stop-sig status -@deffnx {C Function} scm_status_stop_sig (status) -Return the signal number which stopped the process, if any, -otherwise @code{#f}. -@end deffn - - getppid -@c snarfed from posix.c:606 -@deffn {Scheme Procedure} getppid -@deffnx {C Function} scm_getppid () -Return an integer representing the process ID of the parent -process. -@end deffn - - getuid -@c snarfed from posix.c:618 -@deffn {Scheme Procedure} getuid -@deffnx {C Function} scm_getuid () -Return an integer representing the current real user ID. -@end deffn - - getgid -@c snarfed from posix.c:629 -@deffn {Scheme Procedure} getgid -@deffnx {C Function} scm_getgid () -Return an integer representing the current real group ID. -@end deffn - - geteuid -@c snarfed from posix.c:643 -@deffn {Scheme Procedure} geteuid -@deffnx {C Function} scm_geteuid () -Return an integer representing the current effective user ID. -If the system does not support effective IDs, then the real ID -is returned. @code{(provided? 'EIDs)} reports whether the -system supports effective IDs. -@end deffn - - getegid -@c snarfed from posix.c:660 -@deffn {Scheme Procedure} getegid -@deffnx {C Function} scm_getegid () -Return an integer representing the current effective group ID. -If the system does not support effective IDs, then the real ID -is returned. @code{(provided? 'EIDs)} reports whether the -system supports effective IDs. -@end deffn - - setuid -@c snarfed from posix.c:676 -@deffn {Scheme Procedure} setuid id -@deffnx {C Function} scm_setuid (id) -Sets both the real and effective user IDs to the integer @var{id}, provided -the process has appropriate privileges. -The return value is unspecified. -@end deffn - - setgid -@c snarfed from posix.c:689 -@deffn {Scheme Procedure} setgid id -@deffnx {C Function} scm_setgid (id) -Sets both the real and effective group IDs to the integer @var{id}, provided -the process has appropriate privileges. -The return value is unspecified. -@end deffn - - seteuid -@c snarfed from posix.c:704 -@deffn {Scheme Procedure} seteuid id -@deffnx {C Function} scm_seteuid (id) -Sets the effective user ID to the integer @var{id}, provided the process -has appropriate privileges. If effective IDs are not supported, the -real ID is set instead -- @code{(provided? 'EIDs)} reports whether the -system supports effective IDs. -The return value is unspecified. -@end deffn - - setegid -@c snarfed from posix.c:729 -@deffn {Scheme Procedure} setegid id -@deffnx {C Function} scm_setegid (id) -Sets the effective group ID to the integer @var{id}, provided the process -has appropriate privileges. If effective IDs are not supported, the -real ID is set instead -- @code{(provided? 'EIDs)} reports whether the -system supports effective IDs. -The return value is unspecified. -@end deffn - - getpgrp -@c snarfed from posix.c:752 -@deffn {Scheme Procedure} getpgrp -@deffnx {C Function} scm_getpgrp () -Return an integer representing the current process group ID. -This is the POSIX definition, not BSD. -@end deffn - - setpgid -@c snarfed from posix.c:770 -@deffn {Scheme Procedure} setpgid pid pgid -@deffnx {C Function} scm_setpgid (pid, pgid) -Move the process @var{pid} into the process group @var{pgid}. @var{pid} or -@var{pgid} must be integers: they can be zero to indicate the ID of the -current process. -Fails on systems that do not support job control. -The return value is unspecified. -@end deffn - - setsid -@c snarfed from posix.c:787 -@deffn {Scheme Procedure} setsid -@deffnx {C Function} scm_setsid () -Creates a new session. The current process becomes the session leader -and is put in a new process group. The process will be detached -from its controlling terminal if it has one. -The return value is an integer representing the new process group ID. -@end deffn - - ttyname -@c snarfed from posix.c:811 -@deffn {Scheme Procedure} ttyname port -@deffnx {C Function} scm_ttyname (port) -Return a string with the name of the serial terminal device -underlying @var{port}. -@end deffn - - ctermid -@c snarfed from posix.c:850 -@deffn {Scheme Procedure} ctermid -@deffnx {C Function} scm_ctermid () -Return a string containing the file name of the controlling -terminal for the current process. -@end deffn - - tcgetpgrp -@c snarfed from posix.c:874 -@deffn {Scheme Procedure} tcgetpgrp port -@deffnx {C Function} scm_tcgetpgrp (port) -Return the process group ID of the foreground process group -associated with the terminal open on the file descriptor -underlying @var{port}. - -If there is no foreground process group, the return value is a -number greater than 1 that does not match the process group ID -of any existing process group. This can happen if all of the -processes in the job that was formerly the foreground job have -terminated, and no other job has yet been moved into the -foreground. -@end deffn - - tcsetpgrp -@c snarfed from posix.c:898 -@deffn {Scheme Procedure} tcsetpgrp port pgid -@deffnx {C Function} scm_tcsetpgrp (port, pgid) -Set the foreground process group ID for the terminal used by the file -descriptor underlying @var{port} to the integer @var{pgid}. -The calling process -must be a member of the same session as @var{pgid} and must have the same -controlling terminal. The return value is unspecified. -@end deffn - - execl -@c snarfed from posix.c:930 -@deffn {Scheme Procedure} execl filename . args -@deffnx {C Function} scm_execl (filename, args) -Executes the file named by @var{path} as a new process image. -The remaining arguments are supplied to the process; from a C program -they are accessible as the @code{argv} argument to @code{main}. -Conventionally the first @var{arg} is the same as @var{path}. -All arguments must be strings. - -If @var{arg} is missing, @var{path} is executed with a null -argument list, which may have system-dependent side-effects. - -This procedure is currently implemented using the @code{execv} system -call, but we call it @code{execl} because of its Scheme calling interface. -@end deffn - - execlp -@c snarfed from posix.c:961 -@deffn {Scheme Procedure} execlp filename . args -@deffnx {C Function} scm_execlp (filename, args) -Similar to @code{execl}, however if -@var{filename} does not contain a slash -then the file to execute will be located by searching the -directories listed in the @code{PATH} environment variable. - -This procedure is currently implemented using the @code{execvp} system -call, but we call it @code{execlp} because of its Scheme calling interface. -@end deffn - - execle -@c snarfed from posix.c:995 -@deffn {Scheme Procedure} execle filename env . args -@deffnx {C Function} scm_execle (filename, env, args) -Similar to @code{execl}, but the environment of the new process is -specified by @var{env}, which must be a list of strings as returned by the -@code{environ} procedure. - -This procedure is currently implemented using the @code{execve} system -call, but we call it @code{execle} because of its Scheme calling interface. -@end deffn - - primitive-fork -@c snarfed from posix.c:1031 -@deffn {Scheme Procedure} primitive-fork -@deffnx {C Function} scm_fork () -Creates a new "child" process by duplicating the current "parent" process. -In the child the return value is 0. In the parent the return value is -the integer process ID of the child. - -This procedure has been renamed from @code{fork} to avoid a naming conflict -with the scsh fork. -@end deffn - - uname -@c snarfed from posix.c:1051 -@deffn {Scheme Procedure} uname -@deffnx {C Function} scm_uname () -Return an object with some information about the computer -system the program is running on. -@end deffn - - environ -@c snarfed from posix.c:1080 -@deffn {Scheme Procedure} environ [env] -@deffnx {C Function} scm_environ (env) -If @var{env} is omitted, return the current environment (in the -Unix sense) as a list of strings. Otherwise set the current -environment, which is also the default environment for child -processes, to the supplied list of strings. Each member of -@var{env} should be of the form @code{NAME=VALUE} and values of -@code{NAME} should not be duplicated. If @var{env} is supplied -then the return value is unspecified. -@end deffn - - tmpnam -@c snarfed from posix.c:1113 -@deffn {Scheme Procedure} tmpnam -@deffnx {C Function} scm_tmpnam () -Return a name in the file system that does not match any -existing file. However there is no guarantee that another -process will not create the file after @code{tmpnam} is called. -Care should be taken if opening the file, e.g., use the -@code{O_EXCL} open flag or use @code{mkstemp!} instead. -@end deffn - - mkstemp! -@c snarfed from posix.c:1144 -@deffn {Scheme Procedure} mkstemp! tmpl -@deffnx {C Function} scm_mkstemp (tmpl) -Create a new unique file in the file system and returns a new -buffered port open for reading and writing to the file. - -@var{tmpl} is a string specifying where the file should be -created: it must end with @samp{XXXXXX} and will be changed in -place to return the name of the temporary file. - -The file is created with mode @code{0600}, which means read and -write for the owner only. @code{chmod} can be used to change -this. -@end deffn - - utime -@c snarfed from posix.c:1179 -@deffn {Scheme Procedure} utime pathname [actime [modtime]] -@deffnx {C Function} scm_utime (pathname, actime, modtime) -@code{utime} sets the access and modification times for the -file named by @var{path}. If @var{actime} or @var{modtime} is -not supplied, then the current time is used. @var{actime} and -@var{modtime} must be integer time values as returned by the -@code{current-time} procedure. -@lisp -(utime "foo" (- (current-time) 3600)) -@end lisp -will set the access time to one hour in the past and the -modification time to the current time. -@end deffn - - access? -@c snarfed from posix.c:1244 -@deffn {Scheme Procedure} access? path how -@deffnx {C Function} scm_access (path, how) -Test accessibility of a file under the real UID and GID of the -calling process. The return is @code{#t} if @var{path} exists -and the permissions requested by @var{how} are all allowed, or -@code{#f} if not. - -@var{how} is an integer which is one of the following values, -or a bitwise-OR (@code{logior}) of multiple values. - -@defvar R_OK -Test for read permission. -@end defvar -@defvar W_OK -Test for write permission. -@end defvar -@defvar X_OK -Test for execute permission. -@end defvar -@defvar F_OK -Test for existence of the file. This is implied by each of the -other tests, so there's no need to combine it with them. -@end defvar - -It's important to note that @code{access?} does not simply -indicate what will happen on attempting to read or write a -file. In normal circumstances it does, but in a set-UID or -set-GID program it doesn't because @code{access?} tests the -real ID, whereas an open or execute attempt uses the effective -ID. - -A program which will never run set-UID/GID can ignore the -difference between real and effective IDs, but for maximum -generality, especially in library functions, it's best not to -use @code{access?} to predict the result of an open or execute, -instead simply attempt that and catch any exception. - -The main use for @code{access?} is to let a set-UID/GID program -determine what the invoking user would have been allowed to do, -without the greater (or perhaps lesser) privileges afforded by -the effective ID. For more on this, see ``Testing File -Access'' in The GNU C Library Reference Manual. -@end deffn - - getpid -@c snarfed from posix.c:1257 -@deffn {Scheme Procedure} getpid -@deffnx {C Function} scm_getpid () -Return an integer representing the current process ID. -@end deffn - - putenv -@c snarfed from posix.c:1274 -@deffn {Scheme Procedure} putenv str -@deffnx {C Function} scm_putenv (str) -Modifies the environment of the current process, which is -also the default environment inherited by child processes. - -If @var{string} is of the form @code{NAME=VALUE} then it will be written -directly into the environment, replacing any existing environment string -with -name matching @code{NAME}. If @var{string} does not contain an equal -sign, then any existing string with name matching @var{string} will -be removed. - -The return value is unspecified. -@end deffn - - setlocale -@c snarfed from posix.c:1358 -@deffn {Scheme Procedure} setlocale category [locale] -@deffnx {C Function} scm_setlocale (category, locale) -If @var{locale} is omitted, return the current value of the -specified locale category as a system-dependent string. -@var{category} should be specified using the values -@code{LC_COLLATE}, @code{LC_ALL} etc. - -Otherwise the specified locale category is set to the string -@var{locale} and the new value is returned as a -system-dependent string. If @var{locale} is an empty string, -the locale will be set using environment variables. -@end deffn - - mknod -@c snarfed from posix.c:1407 -@deffn {Scheme Procedure} mknod path type perms dev -@deffnx {C Function} scm_mknod (path, type, perms, dev) -Creates a new special file, such as a file corresponding to a device. -@var{path} specifies the name of the file. @var{type} should -be one of the following symbols: -regular, directory, symlink, block-special, char-special, -fifo, or socket. @var{perms} (an integer) specifies the file permissions. -@var{dev} (an integer) specifies which device the special file refers -to. Its exact interpretation depends on the kind of special file -being created. - -E.g., -@lisp -(mknod "/dev/fd0" 'block-special #o660 (+ (* 2 256) 2)) -@end lisp - -The return value is unspecified. -@end deffn - - nice -@c snarfed from posix.c:1453 -@deffn {Scheme Procedure} nice incr -@deffnx {C Function} scm_nice (incr) -Increment the priority of the current process by @var{incr}. A higher -priority value means that the process runs less often. -The return value is unspecified. -@end deffn - - sync -@c snarfed from posix.c:1471 -@deffn {Scheme Procedure} sync -@deffnx {C Function} scm_sync () -Flush the operating system disk buffers. -The return value is unspecified. -@end deffn - - crypt -@c snarfed from posix.c:1502 -@deffn {Scheme Procedure} crypt key salt -@deffnx {C Function} scm_crypt (key, salt) -Encrypt @var{key} using @var{salt} as the salt value to the -crypt(3) library call. -@end deffn - - chroot -@c snarfed from posix.c:1531 -@deffn {Scheme Procedure} chroot path -@deffnx {C Function} scm_chroot (path) -Change the root directory to that specified in @var{path}. -This directory will be used for path names beginning with -@file{/}. The root directory is inherited by all children -of the current process. Only the superuser may change the -root directory. -@end deffn - - getlogin -@c snarfed from posix.c:1565 -@deffn {Scheme Procedure} getlogin -@deffnx {C Function} scm_getlogin () -Return a string containing the name of the user logged in on -the controlling terminal of the process, or @code{#f} if this -information cannot be obtained. -@end deffn - - cuserid -@c snarfed from posix.c:1583 -@deffn {Scheme Procedure} cuserid -@deffnx {C Function} scm_cuserid () -Return a string containing a user name associated with the -effective user id of the process. Return @code{#f} if this -information cannot be obtained. -@end deffn - - getpriority -@c snarfed from posix.c:1609 -@deffn {Scheme Procedure} getpriority which who -@deffnx {C Function} scm_getpriority (which, who) -Return the scheduling priority of the process, process group -or user, as indicated by @var{which} and @var{who}. @var{which} -is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP} -or @code{PRIO_USER}, and @var{who} is interpreted relative to -@var{which} (a process identifier for @code{PRIO_PROCESS}, -process group identifier for @code{PRIO_PGRP}, and a user -identifier for @code{PRIO_USER}. A zero value of @var{who} -denotes the current process, process group, or user. Return -the highest priority (lowest numerical value) of any of the -specified processes. -@end deffn - - setpriority -@c snarfed from posix.c:1643 -@deffn {Scheme Procedure} setpriority which who prio -@deffnx {C Function} scm_setpriority (which, who, prio) -Set the scheduling priority of the process, process group -or user, as indicated by @var{which} and @var{who}. @var{which} -is one of the variables @code{PRIO_PROCESS}, @code{PRIO_PGRP} -or @code{PRIO_USER}, and @var{who} is interpreted relative to -@var{which} (a process identifier for @code{PRIO_PROCESS}, -process group identifier for @code{PRIO_PGRP}, and a user -identifier for @code{PRIO_USER}. A zero value of @var{who} -denotes the current process, process group, or user. -@var{prio} is a value in the range -20 and 20, the default -priority is 0; lower priorities cause more favorable -scheduling. Sets the priority of all of the specified -processes. Only the super-user may lower priorities. -The return value is not specified. -@end deffn - - getpass -@c snarfed from posix.c:1668 -@deffn {Scheme Procedure} getpass prompt -@deffnx {C Function} scm_getpass (prompt) -Display @var{prompt} to the standard error output and read -a password from @file{/dev/tty}. If this file is not -accessible, it reads from standard input. The password may be -up to 127 characters in length. Additional characters and the -terminating newline character are discarded. While reading -the password, echoing and the generation of signals by special -characters is disabled. -@end deffn - - flock -@c snarfed from posix.c:1780 -@deffn {Scheme Procedure} flock file operation -@deffnx {C Function} scm_flock (file, operation) -Apply or remove an advisory lock on an open file. -@var{operation} specifies the action to be done: - -@defvar LOCK_SH -Shared lock. More than one process may hold a shared lock -for a given file at a given time. -@end defvar -@defvar LOCK_EX -Exclusive lock. Only one process may hold an exclusive lock -for a given file at a given time. -@end defvar -@defvar LOCK_UN -Unlock the file. -@end defvar -@defvar LOCK_NB -Don't block when locking. This is combined with one of the -other operations using @code{logior}. If @code{flock} would -block an @code{EWOULDBLOCK} error is thrown. -@end defvar - -The return value is not specified. @var{file} may be an open -file descriptor or an open file descriptor port. - -Note that @code{flock} does not lock files across NFS. -@end deffn - - sethostname -@c snarfed from posix.c:1805 -@deffn {Scheme Procedure} sethostname name -@deffnx {C Function} scm_sethostname (name) -Set the host name of the current processor to @var{name}. May -only be used by the superuser. The return value is not -specified. -@end deffn - - gethostname -@c snarfed from posix.c:1823 -@deffn {Scheme Procedure} gethostname -@deffnx {C Function} scm_gethostname () -Return the host name of the current processor. -@end deffn - - gethost -@c snarfed from net_db.c:134 -@deffn {Scheme Procedure} gethost [host] -@deffnx {Scheme Procedure} gethostbyname hostname -@deffnx {Scheme Procedure} gethostbyaddr address -@deffnx {C Function} scm_gethost (host) -Look up a host by name or address, returning a host object. The -@code{gethost} procedure will accept either a string name or an integer -address; if given no arguments, it behaves like @code{gethostent} (see -below). If a name or address is supplied but the address can not be -found, an error will be thrown to one of the keys: -@code{host-not-found}, @code{try-again}, @code{no-recovery} or -@code{no-data}, corresponding to the equivalent @code{h_error} values. -Unusual conditions may result in errors thrown to the -@code{system-error} or @code{misc_error} keys. -@end deffn - - getnet -@c snarfed from net_db.c:216 -@deffn {Scheme Procedure} getnet [net] -@deffnx {Scheme Procedure} getnetbyname net-name -@deffnx {Scheme Procedure} getnetbyaddr net-number -@deffnx {C Function} scm_getnet (net) -Look up a network by name or net number in the network database. The -@var{net-name} argument must be a string, and the @var{net-number} -argument must be an integer. @code{getnet} will accept either type of -argument, behaving like @code{getnetent} (see below) if no arguments are -given. -@end deffn - - getproto -@c snarfed from net_db.c:268 -@deffn {Scheme Procedure} getproto [protocol] -@deffnx {Scheme Procedure} getprotobyname name -@deffnx {Scheme Procedure} getprotobynumber number -@deffnx {C Function} scm_getproto (protocol) -Look up a network protocol by name or by number. @code{getprotobyname} -takes a string argument, and @code{getprotobynumber} takes an integer -argument. @code{getproto} will accept either type, behaving like -@code{getprotoent} (see below) if no arguments are supplied. -@end deffn - - getserv -@c snarfed from net_db.c:334 -@deffn {Scheme Procedure} getserv [name [protocol]] -@deffnx {Scheme Procedure} getservbyname name protocol -@deffnx {Scheme Procedure} getservbyport port protocol -@deffnx {C Function} scm_getserv (name, protocol) -Look up a network service by name or by service number, and return a -network service object. The @var{protocol} argument specifies the name -of the desired protocol; if the protocol found in the network service -database does not match this name, a system error is signalled. - -The @code{getserv} procedure will take either a service name or number -as its first argument; if given no arguments, it behaves like -@code{getservent} (see below). -@end deffn - - sethost -@c snarfed from net_db.c:385 -@deffn {Scheme Procedure} sethost [stayopen] -@deffnx {C Function} scm_sethost (stayopen) -If @var{stayopen} is omitted, this is equivalent to @code{endhostent}. -Otherwise it is equivalent to @code{sethostent stayopen}. -@end deffn - - setnet -@c snarfed from net_db.c:401 -@deffn {Scheme Procedure} setnet [stayopen] -@deffnx {C Function} scm_setnet (stayopen) -If @var{stayopen} is omitted, this is equivalent to @code{endnetent}. -Otherwise it is equivalent to @code{setnetent stayopen}. -@end deffn - - setproto -@c snarfed from net_db.c:417 -@deffn {Scheme Procedure} setproto [stayopen] -@deffnx {C Function} scm_setproto (stayopen) -If @var{stayopen} is omitted, this is equivalent to @code{endprotoent}. -Otherwise it is equivalent to @code{setprotoent stayopen}. -@end deffn - - setserv -@c snarfed from net_db.c:433 -@deffn {Scheme Procedure} setserv [stayopen] -@deffnx {C Function} scm_setserv (stayopen) -If @var{stayopen} is omitted, this is equivalent to @code{endservent}. -Otherwise it is equivalent to @code{setservent stayopen}. -@end deffn - - htons -@c snarfed from socket.c:80 -@deffn {Scheme Procedure} htons value -@deffnx {C Function} scm_htons (value) -Convert a 16 bit quantity from host to network byte ordering. -@var{value} is packed into 2 bytes, which are then converted -and returned as a new integer. -@end deffn - - ntohs -@c snarfed from socket.c:91 -@deffn {Scheme Procedure} ntohs value -@deffnx {C Function} scm_ntohs (value) -Convert a 16 bit quantity from network to host byte ordering. -@var{value} is packed into 2 bytes, which are then converted -and returned as a new integer. -@end deffn - - htonl -@c snarfed from socket.c:102 -@deffn {Scheme Procedure} htonl value -@deffnx {C Function} scm_htonl (value) -Convert a 32 bit quantity from host to network byte ordering. -@var{value} is packed into 4 bytes, which are then converted -and returned as a new integer. -@end deffn - - ntohl -@c snarfed from socket.c:115 -@deffn {Scheme Procedure} ntohl value -@deffnx {C Function} scm_ntohl (value) -Convert a 32 bit quantity from network to host byte ordering. -@var{value} is packed into 4 bytes, which are then converted -and returned as a new integer. -@end deffn - - inet-aton -@c snarfed from socket.c:135 -@deffn {Scheme Procedure} inet-aton address -@deffnx {C Function} scm_inet_aton (address) -Convert an IPv4 Internet address from printable string -(dotted decimal notation) to an integer. E.g., - -@lisp -(inet-aton "127.0.0.1") @result{} 2130706433 -@end lisp -@end deffn - - inet-ntoa -@c snarfed from socket.c:158 -@deffn {Scheme Procedure} inet-ntoa inetid -@deffnx {C Function} scm_inet_ntoa (inetid) -Convert an IPv4 Internet address to a printable -(dotted decimal notation) string. E.g., - -@lisp -(inet-ntoa 2130706433) @result{} "127.0.0.1" -@end lisp -@end deffn - - inet-netof -@c snarfed from socket.c:178 -@deffn {Scheme Procedure} inet-netof address -@deffnx {C Function} scm_inet_netof (address) -Return the network number part of the given IPv4 -Internet address. E.g., - -@lisp -(inet-netof 2130706433) @result{} 127 -@end lisp -@end deffn - - inet-lnaof -@c snarfed from socket.c:196 -@deffn {Scheme Procedure} inet-lnaof address -@deffnx {C Function} scm_lnaof (address) -Return the local-address-with-network part of the given -IPv4 Internet address, using the obsolete class A/B/C system. -E.g., - -@lisp -(inet-lnaof 2130706433) @result{} 1 -@end lisp -@end deffn - - inet-makeaddr -@c snarfed from socket.c:214 -@deffn {Scheme Procedure} inet-makeaddr net lna -@deffnx {C Function} scm_inet_makeaddr (net, lna) -Make an IPv4 Internet address by combining the network number -@var{net} with the local-address-within-network number -@var{lna}. E.g., - -@lisp -(inet-makeaddr 127 1) @result{} 2130706433 -@end lisp -@end deffn - - inet-pton -@c snarfed from socket.c:350 -@deffn {Scheme Procedure} inet-pton family address -@deffnx {C Function} scm_inet_pton (family, address) -Convert a string containing a printable network address to -an integer address. Note that unlike the C version of this -function, -the result is an integer with normal host byte ordering. -@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g., - -@lisp -(inet-pton AF_INET "127.0.0.1") @result{} 2130706433 -(inet-pton AF_INET6 "::1") @result{} 1 -@end lisp -@end deffn - - inet-ntop -@c snarfed from socket.c:388 -@deffn {Scheme Procedure} inet-ntop family address -@deffnx {C Function} scm_inet_ntop (family, address) -Convert a network address into a printable string. -Note that unlike the C version of this function, -the input is an integer with normal host byte ordering. -@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g., - -@lisp -(inet-ntop AF_INET 2130706433) @result{} "127.0.0.1" -(inet-ntop AF_INET6 (- (expt 2 128) 1)) - @result{} "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff" -@end lisp -@end deffn - - socket -@c snarfed from socket.c:430 -@deffn {Scheme Procedure} socket family style proto -@deffnx {C Function} scm_socket (family, style, proto) -Return a new socket port of the type specified by @var{family}, -@var{style} and @var{proto}. All three parameters are -integers. Supported values for @var{family} are -@code{AF_UNIX}, @code{AF_INET} and @code{AF_INET6}. -Typical values for @var{style} are @code{SOCK_STREAM}, -@code{SOCK_DGRAM} and @code{SOCK_RAW}. - -@var{proto} can be obtained from a protocol name using -@code{getprotobyname}. A value of zero specifies the default -protocol, which is usually right. - -A single socket port cannot by used for communication until it -has been connected to another socket. -@end deffn - - socketpair -@c snarfed from socket.c:451 -@deffn {Scheme Procedure} socketpair family style proto -@deffnx {C Function} scm_socketpair (family, style, proto) -Return a pair of connected (but unnamed) socket ports of the -type specified by @var{family}, @var{style} and @var{proto}. -Many systems support only socket pairs of the @code{AF_UNIX} -family. Zero is likely to be the only meaningful value for -@var{proto}. -@end deffn - - getsockopt -@c snarfed from socket.c:476 -@deffn {Scheme Procedure} getsockopt sock level optname -@deffnx {C Function} scm_getsockopt (sock, level, optname) -Return the value of a particular socket option for the socket -port @var{sock}. @var{level} is an integer code for type of -option being requested, e.g., @code{SOL_SOCKET} for -socket-level options. @var{optname} is an integer code for the -option required and should be specified using one of the -symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc. - -The returned value is typically an integer but @code{SO_LINGER} -returns a pair of integers. -@end deffn - - setsockopt -@c snarfed from socket.c:544 -@deffn {Scheme Procedure} setsockopt sock level optname value -@deffnx {C Function} scm_setsockopt (sock, level, optname, value) -Set the value of a particular socket option for the socket -port @var{sock}. @var{level} is an integer code for type of option -being set, e.g., @code{SOL_SOCKET} for socket-level options. -@var{optname} is an -integer code for the option to set and should be specified using one of -the symbols @code{SO_DEBUG}, @code{SO_REUSEADDR} etc. -@var{value} is the value to which the option should be set. For -most options this must be an integer, but for @code{SO_LINGER} it must -be a pair. - -The return value is unspecified. -@end deffn - - shutdown -@c snarfed from socket.c:646 -@deffn {Scheme Procedure} shutdown sock how -@deffnx {C Function} scm_shutdown (sock, how) -Sockets can be closed simply by using @code{close-port}. The -@code{shutdown} procedure allows reception or transmission on a -connection to be shut down individually, according to the parameter -@var{how}: - -@table @asis -@item 0 -Stop receiving data for this socket. If further data arrives, reject it. -@item 1 -Stop trying to transmit data from this socket. Discard any -data waiting to be sent. Stop looking for acknowledgement of -data already sent; don't retransmit it if it is lost. -@item 2 -Stop both reception and transmission. -@end table - -The return value is unspecified. -@end deffn - - connect -@c snarfed from socket.c:789 -@deffn {Scheme Procedure} connect sock fam address . args -@deffnx {C Function} scm_connect (sock, fam, address, args) -Initiate a connection from a socket using a specified address -family to the address -specified by @var{address} and possibly @var{args}. -The format required for @var{address} -and @var{args} depends on the family of the socket. - -For a socket of family @code{AF_UNIX}, -only @var{address} is specified and must be a string with the -filename where the socket is to be created. - -For a socket of family @code{AF_INET}, -@var{address} must be an integer IPv4 host address and -@var{args} must be a single integer port number. - -For a socket of family @code{AF_INET6}, -@var{address} must be an integer IPv6 host address and -@var{args} may be up to three integers: -port [flowinfo] [scope_id], -where flowinfo and scope_id default to zero. - -The return value is unspecified. -@end deffn - - bind -@c snarfed from socket.c:848 -@deffn {Scheme Procedure} bind sock fam address . args -@deffnx {C Function} scm_bind (sock, fam, address, args) -Assign an address to the socket port @var{sock}. -Generally this only needs to be done for server sockets, -so they know where to look for incoming connections. A socket -without an address will be assigned one automatically when it -starts communicating. - -The format of @var{address} and @var{args} depends -on the family of the socket. - -For a socket of family @code{AF_UNIX}, only @var{address} -is specified and must be a string with the filename where -the socket is to be created. - -For a socket of family @code{AF_INET}, @var{address} -must be an integer IPv4 address and @var{args} -must be a single integer port number. - -The values of the following variables can also be used for -@var{address}: - -@defvar INADDR_ANY -Allow connections from any address. -@end defvar - -@defvar INADDR_LOOPBACK -The address of the local host using the loopback device. -@end defvar - -@defvar INADDR_BROADCAST -The broadcast address on the local network. -@end defvar - -@defvar INADDR_NONE -No address. -@end defvar - -For a socket of family @code{AF_INET6}, @var{address} -must be an integer IPv6 address and @var{args} -may be up to three integers: -port [flowinfo] [scope_id], -where flowinfo and scope_id default to zero. - -The return value is unspecified. -@end deffn - - listen -@c snarfed from socket.c:881 -@deffn {Scheme Procedure} listen sock backlog -@deffnx {C Function} scm_listen (sock, backlog) -Enable @var{sock} to accept connection -requests. @var{backlog} is an integer specifying -the maximum length of the queue for pending connections. -If the queue fills, new clients will fail to connect until -the server calls @code{accept} to accept a connection from -the queue. - -The return value is unspecified. -@end deffn - - accept -@c snarfed from socket.c:993 -@deffn {Scheme Procedure} accept sock -@deffnx {C Function} scm_accept (sock) -Accept a connection on a bound, listening socket. -If there -are no pending connections in the queue, wait until -one is available unless the non-blocking option has been -set on the socket. - -The return value is a -pair in which the @emph{car} is a new socket port for the -connection and -the @emph{cdr} is an object with address information about the -client which initiated the connection. - -@var{sock} does not become part of the -connection and will continue to accept new requests. -@end deffn - - getsockname -@c snarfed from socket.c:1020 -@deffn {Scheme Procedure} getsockname sock -@deffnx {C Function} scm_getsockname (sock) -Return the address of @var{sock}, in the same form as the -object returned by @code{accept}. On many systems the address -of a socket in the @code{AF_FILE} namespace cannot be read. -@end deffn - - getpeername -@c snarfed from socket.c:1042 -@deffn {Scheme Procedure} getpeername sock -@deffnx {C Function} scm_getpeername (sock) -Return the address that @var{sock} -is connected to, in the same form as the object returned by -@code{accept}. On many systems the address of a socket in the -@code{AF_FILE} namespace cannot be read. -@end deffn - - recv! -@c snarfed from socket.c:1077 -@deffn {Scheme Procedure} recv! sock buf [flags] -@deffnx {C Function} scm_recv (sock, buf, flags) -Receive data from a socket port. -@var{sock} must already -be bound to the address from which data is to be received. -@var{buf} is a string into which -the data will be written. The size of @var{buf} limits -the amount of -data which can be received: in the case of packet -protocols, if a packet larger than this limit is encountered -then some data -will be irrevocably lost. - -The optional @var{flags} argument is a value or -bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc. - -The value returned is the number of bytes read from the -socket. - -Note that the data is read directly from the socket file -descriptor: -any unread buffered port data is ignored. -@end deffn - - send -@c snarfed from socket.c:1120 -@deffn {Scheme Procedure} send sock message [flags] -@deffnx {C Function} scm_send (sock, message, flags) -Transmit the string @var{message} on a socket port @var{sock}. -@var{sock} must already be bound to a destination address. The -value returned is the number of bytes transmitted -- -it's possible for -this to be less than the length of @var{message} -if the socket is -set to be non-blocking. The optional @var{flags} argument -is a value or -bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc. - -Note that the data is written directly to the socket -file descriptor: -any unflushed buffered port data is ignored. -@end deffn - - recvfrom! -@c snarfed from socket.c:1171 -@deffn {Scheme Procedure} recvfrom! sock str [flags [start [end]]] -@deffnx {C Function} scm_recvfrom (sock, str, flags, start, end) -Return data from the socket port @var{sock} and also -information about where the data was received from. -@var{sock} must already be bound to the address from which -data is to be received. @code{str}, is a string into which the -data will be written. The size of @var{str} limits the amount -of data which can be received: in the case of packet protocols, -if a packet larger than this limit is encountered then some -data will be irrevocably lost. - -The optional @var{flags} argument is a value or bitwise OR of -@code{MSG_OOB}, @code{MSG_PEEK}, @code{MSG_DONTROUTE} etc. - -The value returned is a pair: the @emph{car} is the number of -bytes read from the socket and the @emph{cdr} an address object -in the same form as returned by @code{accept}. The address -will given as @code{#f} if not available, as is usually the -case for stream sockets. - -The @var{start} and @var{end} arguments specify a substring of -@var{str} to which the data should be written. - -Note that the data is read directly from the socket file -descriptor: any unread buffered port data is ignored. -@end deffn - - sendto -@c snarfed from socket.c:1236 -@deffn {Scheme Procedure} sendto sock message fam address . args_and_flags -@deffnx {C Function} scm_sendto (sock, message, fam, address, args_and_flags) -Transmit the string @var{message} on the socket port -@var{sock}. The -destination address is specified using the @var{fam}, -@var{address} and -@var{args_and_flags} arguments, in a similar way to the -@code{connect} procedure. @var{args_and_flags} contains -the usual connection arguments optionally followed by -a flags argument, which is a value or -bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc. - -The value returned is the number of bytes transmitted -- -it's possible for -this to be less than the length of @var{message} if the -socket is -set to be non-blocking. -Note that the data is written directly to the socket -file descriptor: -any unflushed buffered port data is ignored. -@end deffn - - regexp? -@c snarfed from regex-posix.c:106 -@deffn {Scheme Procedure} regexp? obj -@deffnx {C Function} scm_regexp_p (obj) -Return @code{#t} if @var{obj} is a compiled regular expression, -or @code{#f} otherwise. -@end deffn - - make-regexp -@c snarfed from regex-posix.c:151 -@deffn {Scheme Procedure} make-regexp pat . flags -@deffnx {C Function} scm_make_regexp (pat, flags) -Compile the regular expression described by @var{pat}, and -return the compiled regexp structure. If @var{pat} does not -describe a legal regular expression, @code{make-regexp} throws -a @code{regular-expression-syntax} error. - -The @var{flags} arguments change the behavior of the compiled -regular expression. The following flags may be supplied: - -@table @code -@item regexp/icase -Consider uppercase and lowercase letters to be the same when -matching. -@item regexp/newline -If a newline appears in the target string, then permit the -@samp{^} and @samp{$} operators to match immediately after or -immediately before the newline, respectively. Also, the -@samp{.} and @samp{[^...]} operators will never match a newline -character. The intent of this flag is to treat the target -string as a buffer containing many lines of text, and the -regular expression as a pattern that may match a single one of -those lines. -@item regexp/basic -Compile a basic (``obsolete'') regexp instead of the extended -(``modern'') regexps that are the default. Basic regexps do -not consider @samp{|}, @samp{+} or @samp{?} to be special -characters, and require the @samp{@{...@}} and @samp{(...)} -metacharacters to be backslash-escaped (@pxref{Backslash -Escapes}). There are several other differences between basic -and extended regular expressions, but these are the most -significant. -@item regexp/extended -Compile an extended regular expression rather than a basic -regexp. This is the default behavior; this flag will not -usually be needed. If a call to @code{make-regexp} includes -both @code{regexp/basic} and @code{regexp/extended} flags, the -one which comes last will override the earlier one. -@end table -@end deffn - - regexp-exec -@c snarfed from regex-posix.c:217 -@deffn {Scheme Procedure} regexp-exec rx str [start [flags]] -@deffnx {C Function} scm_regexp_exec (rx, str, start, flags) -Match the compiled regular expression @var{rx} against -@code{str}. If the optional integer @var{start} argument is -provided, begin matching from that position in the string. -Return a match structure describing the results of the match, -or @code{#f} if no match could be found. - -The @var{flags} arguments change the matching behavior. -The following flags may be supplied: - -@table @code -@item regexp/notbol -Operator @samp{^} always fails (unless @code{regexp/newline} -is used). Use this when the beginning of the string should -not be considered the beginning of a line. -@item regexp/noteol -Operator @samp{$} always fails (unless @code{regexp/newline} -is used). Use this when the end of the string should not be -considered the end of a line. -@end table -@end deffn From 2c8ea5a008959ffba629694942d75887dc14a869 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 23 Jun 2016 14:57:50 +0200 Subject: [PATCH 414/865] Fix memory leak in scm_from_{u,}int64 on 32-bit platforms * libguile/conv-integer.i.c (SCM_FROM_TYPE_PROTO): * libguile/conv-uinteger.i.c (SCM_FROM_TYPE_PROTO): Fix a big in which scm_from_int64 and scm_from_uint64 on a 32-bit platform leaked memory if they needed to allocate a bignum. Fixes #20079. --- libguile/conv-integer.i.c | 2 +- libguile/conv-uinteger.i.c | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/conv-integer.i.c b/libguile/conv-integer.i.c index 4cf887cb6..a5362d39c 100644 --- a/libguile/conv-integer.i.c +++ b/libguile/conv-integer.i.c @@ -117,7 +117,7 @@ SCM_FROM_TYPE_PROTO (TYPE val) return scm_i_long2big (val); else { - SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); + SCM z = make_bignum (); mpz_init (SCM_I_BIG_MPZ (z)); if (val < 0) { diff --git a/libguile/conv-uinteger.i.c b/libguile/conv-uinteger.i.c index d6b969c20..f62dc41ad 100644 --- a/libguile/conv-uinteger.i.c +++ b/libguile/conv-uinteger.i.c @@ -104,7 +104,7 @@ SCM_FROM_TYPE_PROTO (TYPE val) return scm_i_ulong2big (val); else { - SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); + SCM z = make_bignum (); mpz_init (SCM_I_BIG_MPZ (z)); mpz_import (SCM_I_BIG_MPZ (z), 1, 1, sizeof (TYPE), 0, 0, &val); return z; From 1d72d469517ca858736bfc227d8382bfb1d84b21 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 23 Jun 2016 15:45:53 +0200 Subject: [PATCH 415/865] Don't serialize uninterned symbols * module/system/vm/assembler.scm (intern-constant): Don't serialize uninterned symbols. * test-suite/tests/rtl.test ("bad constants"): Add a test. --- module/system/vm/assembler.scm | 2 ++ test-suite/tests/rtl.test | 10 ++++++++++ 2 files changed, 12 insertions(+) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 9fc5349b7..20a652c66 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -1034,6 +1034,8 @@ table, its existing label is used directly." `((static-patch! ,label 1 ,(static-procedure-code obj)))) ((cache-cell? obj) '()) ((symbol? obj) + (unless (symbol-interned? obj) + (error "uninterned symbol cannot be saved to object file" obj)) `((make-non-immediate 1 ,(recur (symbol->string obj))) (string->symbol 1 1) (static-set! 1 ,label 0))) diff --git a/test-suite/tests/rtl.test b/test-suite/tests/rtl.test index 57047a2fb..316f4557c 100644 --- a/test-suite/tests/rtl.test +++ b/test-suite/tests/rtl.test @@ -77,6 +77,16 @@ a procedure." ;; FIXME: Add more tests for arrays (uniform and otherwise) )) +(define-syntax-rule (assert-bad-constants val ...) + (begin + (pass-if-exception (object->string val) exception:miscellaneous-error + (return-constant val)) + ...)) + +(with-test-prefix "bad constants" + (assert-bad-constants (make-symbol "foo") + (lambda () 100))) + (with-test-prefix "static procedure" (assert-equal 42 (((assemble-program `((begin-program foo From 04d87db927207afa844add9353e5ef40995e6485 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 23 Jun 2016 17:08:38 +0200 Subject: [PATCH 416/865] Fix default-duplicate-binding-handlers for compilation * module/ice-9/boot-9.scm (define-module*): Capture value of `default-duplicate-binding-procedures' when the module is created. Fixes #20093. --- module/ice-9/boot-9.scm | 59 +++++++++++++++++++++-------------------- 1 file changed, 30 insertions(+), 29 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 00899812e..64726542e 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2827,7 +2827,7 @@ written into the port is returned." ;; sure to update "modules.c" as well. (define* (define-module* name - #:key filename pure version (duplicates '()) + #:key filename pure version (duplicates #f) (imports '()) (exports '()) (replacements '()) (re-exports '()) (autoloads '()) transformer) (define (list-of pred l) @@ -2869,35 +2869,36 @@ written into the port is returned." (let ((imports (resolve-imports imports))) (call-with-deferred-observers (lambda () - (if (pair? imports) - (module-use-interfaces! module imports)) - (if (list-of valid-export? exports) - (if (pair? exports) - (module-export! module exports)) - (error "expected exports to be a list of symbols or symbol pairs")) - (if (list-of valid-export? replacements) - (if (pair? replacements) - (module-replace! module replacements)) - (error "expected replacements to be a list of symbols or symbol pairs")) - (if (list-of valid-export? re-exports) - (if (pair? re-exports) - (module-re-export! module re-exports)) - (error "expected re-exports to be a list of symbols or symbol pairs")) - ;; FIXME - (if (not (null? autoloads)) - (apply module-autoload! module autoloads)) - ;; Wait until modules have been loaded to resolve duplicates - ;; handlers. - (if (pair? duplicates) - (let ((handlers (lookup-duplicates-handlers duplicates))) - (set-module-duplicates-handlers! module handlers)))))) + (unless (list-of valid-export? exports) + (error "expected exports to be a list of symbols or symbol pairs")) + (unless (list-of valid-export? replacements) + (error "expected replacements to be a list of symbols or symbol pairs")) + (unless (list-of valid-export? re-exports) + (error "expected re-exports to be a list of symbols or symbol pairs")) + (unless (null? imports) + (module-use-interfaces! module imports)) + (module-export! module exports) + (module-replace! module replacements) + (module-re-export! module re-exports) + ;; FIXME: Avoid use of `apply'. + (apply module-autoload! module autoloads) + ;; Capture the value of `default-duplicate-binding-procedures' + ;; that is current when the module is defined, unless the user + ;; specfies a #:duplicates set explicitly. Otherwise if we + ;; leave it unset, we would delegate the duplicates-handling + ;; behavior to whatever default the user has set at whatever + ;; time in the future we first use an imported binding. + (let ((handlers (if duplicates + (lookup-duplicates-handlers duplicates) + (default-duplicate-binding-procedures)))) + (set-module-duplicates-handlers! module handlers))))) - (if transformer - (if (and (pair? transformer) (list-of symbol? transformer)) - (let ((iface (resolve-interface transformer)) - (sym (car (last-pair transformer)))) - (set-module-transformer! module (module-ref iface sym))) - (error "expected transformer to be a module name" transformer))) + (when transformer + (unless (and (pair? transformer) (list-of symbol? transformer)) + (error "expected transformer to be a module name" transformer)) + (let ((iface (resolve-interface transformer)) + (sym (car (last-pair transformer)))) + (set-module-transformer! module (module-ref iface sym)))) (run-hook module-defined-hook module) module)) From 3df22933b6113872e5c67456fbcdd9d8adc1a5f8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 23 Jun 2016 17:24:22 +0200 Subject: [PATCH 417/865] Static default for define-module #:duplicates * module/ice-9/boot-9.scm (define-module*): Leaving off #:duplicates defaults to installing the duplicate binding handlers specified in the manual, not the value of some other dynamic parameter. (default-duplicate-binding-procedures): (default-duplicate-binding-handler): Instead of closing over a separate fluid, close over the handlers of the current module. That way when a user does (default-duplicate-binding-handler ...) in a script, then it applies to the right module. --- module/ice-9/boot-9.scm | 67 +++++++++++++++++++++++------------------ 1 file changed, 38 insertions(+), 29 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 64726542e..5d1fcc4b3 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2827,9 +2827,9 @@ written into the port is returned." ;; sure to update "modules.c" as well. (define* (define-module* name - #:key filename pure version (duplicates #f) - (imports '()) (exports '()) (replacements '()) - (re-exports '()) (autoloads '()) transformer) + #:key filename pure version (imports '()) (exports '()) + (replacements '()) (re-exports '()) (autoloads '()) + (duplicates #f) transformer) (define (list-of pred l) (or (null? l) (and (pair? l) (pred (car l)) (list-of pred (cdr l))))) @@ -2856,16 +2856,15 @@ written into the port is returned." ;; (let ((module (resolve-module name #f))) (beautify-user-module! module) - (if filename - (set-module-filename! module filename)) - (if pure - (purify-module! module)) - (if version - (begin - (if (not (list-of integer? version)) - (error "expected list of integers for version")) - (set-module-version! module version) - (set-module-version! (module-public-interface module) version))) + (when filename + (set-module-filename! module filename)) + (when pure + (purify-module! module)) + (when version + (unless (list-of integer? version) + (error "expected list of integers for version")) + (set-module-version! module version) + (set-module-version! (module-public-interface module) version)) (let ((imports (resolve-imports imports))) (call-with-deferred-observers (lambda () @@ -2882,16 +2881,17 @@ written into the port is returned." (module-re-export! module re-exports) ;; FIXME: Avoid use of `apply'. (apply module-autoload! module autoloads) - ;; Capture the value of `default-duplicate-binding-procedures' - ;; that is current when the module is defined, unless the user - ;; specfies a #:duplicates set explicitly. Otherwise if we - ;; leave it unset, we would delegate the duplicates-handling - ;; behavior to whatever default the user has set at whatever - ;; time in the future we first use an imported binding. - (let ((handlers (if duplicates - (lookup-duplicates-handlers duplicates) - (default-duplicate-binding-procedures)))) - (set-module-duplicates-handlers! module handlers))))) + (let ((duplicates (or duplicates + ;; Avoid stompling a previously installed + ;; duplicates handlers if possible. + (and (not (module-duplicates-handlers module)) + ;; Note: If you change this default, + ;; change it also in + ;; `default-duplicate-binding-procedures'. + '(replace warn-override-core warn last))))) + (when duplicates + (let ((handlers (lookup-duplicates-handlers duplicates))) + (set-module-duplicates-handlers! module handlers))))))) (when transformer (unless (and (pair? transformer) (list-of symbol? transformer)) @@ -3632,14 +3632,23 @@ but it fails to load." (list handler-names))))) (define default-duplicate-binding-procedures - (make-mutable-parameter #f)) + (case-lambda + (() + (or (module-duplicates-handlers (current-module)) + ;; Note: If you change this default, change it also in + ;; `define-module*'. + (lookup-duplicates-handlers + '(replace warn-override-core warn last)))) + ((procs) + (set-module-duplicates-handlers! (current-module) procs)))) (define default-duplicate-binding-handler - (make-mutable-parameter '(replace warn-override-core warn last) - (lambda (handler-names) - (default-duplicate-binding-procedures - (lookup-duplicates-handlers handler-names)) - handler-names))) + (case-lambda + (() + (map procedure-name (default-duplicate-binding-procedures))) + ((handlers) + (default-duplicate-binding-procedures + (lookup-duplicates-handlers handlers))))) From 498cd58cb43e0dde024ad3c62983def16a0c7ca9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 23 Jun 2016 21:39:23 +0200 Subject: [PATCH 418/865] Fix R6RS fold-left documentation * doc/ref/r6rs.texi (rnrs lists): Fix documentation of fold-left. --- doc/ref/r6rs.texi | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/doc/ref/r6rs.texi b/doc/ref/r6rs.texi index a12964ed2..eaee82105 100644 --- a/doc/ref/r6rs.texi +++ b/doc/ref/r6rs.texi @@ -724,11 +724,15 @@ These procedures are identical to the ones provided by SRFI-1. @xref{SRFI-1 Filtering and Partitioning}, for @code{partition}. @end deffn +@deffn {Scheme Procedure} fold-right combine nil list1 list2 @dots{} +This procedure is identical the @code{fold-right} procedure provided by +SRFI-1. @xref{SRFI-1 Fold and Map}, for documentation. +@end deffn + @deffn {Scheme Procedure} fold-left combine nil list1 list2 @dots{} -@deffnx {Scheme Procedure} fold-right combine nil list1 list2 @dots{} -These procedures are identical to the @code{fold} and @code{fold-right} -procedures provided by SRFI-1. @xref{SRFI-1 Fold and Map}, for -documentation. +This procedure is like @code{fold} from SRFI-1, but @var{combine} is +called with the seed as the first argument. @xref{SRFI-1 Fold and Map}, +for documentation. @end deffn @deffn {Scheme Procedure} remp proc list From 8a072fc2d628bc85c7edadc39d50b4ff3a00d6eb Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 23 Jun 2016 22:37:23 +0200 Subject: [PATCH 419/865] Add weak hash table documentation * doc/ref/api-memory.texi (Weak hash tables): Update documentation. Fixes #20551. --- doc/ref/api-memory.texi | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/doc/ref/api-memory.texi b/doc/ref/api-memory.texi index a2a27e43b..142eb0159 100644 --- a/doc/ref/api-memory.texi +++ b/doc/ref/api-memory.texi @@ -309,10 +309,18 @@ Return a weak hash table with @var{size} buckets. As with any hash table, choosing a good size for the table requires some caution. -You can modify weak hash tables in exactly the same way you -would modify regular hash tables. (@pxref{Hash Tables}) +You can modify weak hash tables in exactly the same way you would modify +regular hash tables, with the exception of the routines that act on +handles. Weak tables have a different implementation behind the scenes +that doesn't have handles. @pxref{Hash Tables}, for more on +@code{hashq-ref} et al. @end deffn +Note that in a weak-key hash table, the reference to the value is +strong. This means that if the value references the key, even +indirectly, the key will never be collected, which can lead to a memory +leak. The reverse is true for weak value tables. + @deffn {Scheme Procedure} weak-key-hash-table? obj @deffnx {Scheme Procedure} weak-value-hash-table? obj @deffnx {Scheme Procedure} doubly-weak-hash-table? obj From f23dfc0fb582e2cd2894e9019b66bee53cecf2f9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jun 2016 07:43:58 +0200 Subject: [PATCH 420/865] Locale is default port encoding * libguile/ports.c (scm_init_ports): Use the locale as the default charset. After the switch to default GUILE_INSTALL_LOCALE=1, this harmonizes the default port encoding with the installed locale. --- libguile/ports.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/ports.c b/libguile/ports.c index c214717c4..434e48e54 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -3979,13 +3979,14 @@ scm_init_ports (void) cur_warnport_fluid = scm_make_fluid (); cur_loadport_fluid = scm_make_fluid (); - /* Use Latin-1 as the default port encoding. */ default_port_encoding_var = scm_c_define ("%default-port-encoding", scm_make_fluid_with_default (SCM_BOOL_F)); default_conversion_strategy_var = scm_c_define ("%default-port-conversion-strategy", scm_make_fluid_with_default (sym_substitute)); + /* Use the locale as the default port encoding. */ + scm_i_set_default_port_encoding (locale_charset ()); scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, "scm_init_ice_9_ports", From f84006c5644997ce9854df9070ec2f1fb8acd420 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jun 2016 08:56:21 +0200 Subject: [PATCH 421/865] Clarify use of the term "scanning" in the manual * doc/ref/api-memory.texi (Garbage Collection Functions): * doc/ref/libguile-concepts.texi (Garbage Collection): Attempt to be clear that scanning is a thing that happens in the mark phase. Fixes #20907 I think. --- doc/ref/api-memory.texi | 42 ++++++++++++++++------------- doc/ref/libguile-concepts.texi | 48 ++++++++++++++++++++++------------ 2 files changed, 56 insertions(+), 34 deletions(-) diff --git a/doc/ref/api-memory.texi b/doc/ref/api-memory.texi index 142eb0159..ce0187b14 100644 --- a/doc/ref/api-memory.texi +++ b/doc/ref/api-memory.texi @@ -27,9 +27,10 @@ collection relates to using Guile from C. @deffn {Scheme Procedure} gc @deffnx {C Function} scm_gc () -Scans all of SCM objects and reclaims for further use those that are -no longer accessible. You normally don't need to call this function -explicitly. It is called automatically when appropriate. +Finds all of the ``live'' @code{SCM} objects and reclaims for further +use those that are no longer accessible. You normally don't need to +call this function explicitly. Its functionality is invoked +automatically as needed. @end deffn @deftypefn {C Function} SCM scm_gc_protect_object (SCM @var{obj}) @@ -43,8 +44,9 @@ than it has been protected. Returns the SCM object it was passed. Note that storing @var{obj} in a C global variable has the same effect@footnote{In Guile up to version 1.8, C global variables were not -scanned by the garbage collector; hence, @code{scm_gc_protect_object} -was the only way in C to prevent a Scheme object from being freed.}. +visited by the garbage collector in the mark phase; hence, +@code{scm_gc_protect_object} was the only way in C to prevent a Scheme +object from being freed.}. @end deftypefn @deftypefn {C Function} SCM scm_gc_unprotect_object (SCM @var{obj}) @@ -123,16 +125,18 @@ live reference to it@footnote{In Guile up to version 1.8, memory allocated with @code{scm_gc_malloc} @emph{had} to be freed with @code{scm_gc_free}.}. -Memory allocated with @code{scm_gc_malloc} is scanned for live pointers. -This means that if @code{scm_gc_malloc}-allocated memory contains a -pointer to some other part of the memory, the garbage collector notices -it and prevents it from being reclaimed@footnote{In Guile up to 1.8, -memory allocated with @code{scm_gc_malloc} was @emph{not} scanned. -Consequently, the GC had to be told explicitly about pointers to live -objects contained in the memory block, e.g., @i{via} SMOB mark functions -(@pxref{Smobs, @code{scm_set_smob_mark}})}. Conversely, memory -allocated with @code{scm_gc_malloc_pointerless} is assumed to be -``pointer-less'' and is not scanned. +When garbage collection occurs, Guile will visit the words in memory +allocated with @code{scm_gc_malloc}, looking for live pointers. This +means that if @code{scm_gc_malloc}-allocated memory contains a pointer +to some other part of the memory, the garbage collector notices it and +prevents it from being reclaimed@footnote{In Guile up to 1.8, memory +allocated with @code{scm_gc_malloc} was @emph{not} visited by the +collector in the mark phase. Consequently, the GC had to be told +explicitly about pointers to live objects contained in the memory block, +e.g., @i{via} SMOB mark functions (@pxref{Smobs, +@code{scm_set_smob_mark}})}. Conversely, memory allocated with +@code{scm_gc_malloc_pointerless} is assumed to be ``pointer-less'' and +is not scanned for pointers. For memory that is not associated with a Scheme object, you can use @code{scm_malloc} instead of @code{malloc}. Like @@ -193,9 +197,11 @@ Allocate @var{size} bytes of automatically-managed memory. The memory is automatically freed when no longer referenced from any live memory block. -Memory allocated with @code{scm_gc_malloc} or @code{scm_gc_calloc} is -scanned for pointers. Memory allocated by -@code{scm_gc_malloc_pointerless} is not scanned. +When garbage collection occurs, Guile will visit the words in memory +allocated with @code{scm_gc_malloc} or @code{scm_gc_calloc}, looking for +pointers to other memory allocations that are managed by the GC. In +contrast, memory allocated by @code{scm_gc_malloc_pointerless} is not +scanned for pointers. The @code{scm_gc_realloc} call preserves the ``pointerlessness'' of the memory area pointed to by @var{mem}. Note that you need to pass the old diff --git a/doc/ref/libguile-concepts.texi b/doc/ref/libguile-concepts.texi index 9785f4d6f..e93d98711 100644 --- a/doc/ref/libguile-concepts.texi +++ b/doc/ref/libguile-concepts.texi @@ -203,22 +203,38 @@ set'' of garbage collection; any value on the heap that is referenced directly or indirectly by a member of the root set is preserved, and all other objects are eligible for reclamation. -The Scheme stack and heap are scanned precisely; that is to say, Guile -knows about all inter-object pointers on the Scheme stack and heap. -This is not the case, unfortunately, for pointers on the C stack and -static data segment. For this reason we have to scan the C stack and -static data segment @dfn{conservatively}; any value that looks like a -pointer to a GC-managed object is treated as such, whether it actually -is a reference or not. Thus, scanning the C stack and static data -segment is guaranteed to find all actual references, but it might also -find words that only accidentally look like references. These ``false -positives'' might keep @code{SCM} objects alive that would otherwise be -considered dead. While this might waste memory, keeping an object -around longer than it strictly needs to is harmless. This is why this -technique is called ``conservative garbage collection''. In practice, -the wasted memory seems to be no problem, as the static C root set is -almost always finite and small, given that the Scheme stack is separate -from the C stack. +In Guile, garbage collection has two logical phases: the @dfn{mark +phase}, in which the collector discovers the set of all live objects, +and the @dfn{sweep phase}, in which the collector reclaims the resources +associated with dead objects. The mark phase pauses the program and +traces all @code{SCM} object references, starting with the root set. +The sweep phase actually runs concurrently with the main program, +incrementally reclaiming memory as needed by allocation. + +In the mark phase, the garbage collector traces the Scheme stack and +heap @dfn{precisely}. Because the Scheme stack and heap are managed by +Guile, Guile can know precisely where in those data structures it might +find references to other heap objects. This is not the case, +unfortunately, for pointers on the C stack and static data segment. +Instead of requiring the user to inform Guile about all variables in C +that might point to heap objects, Guile traces the C stack and static +data segment @dfn{conservatively}. That is to say, Guile just treats +every word on the C stack and every C global variable as a potential +reference in to the Scheme heap@footnote{Note that Guile does not scan +the C heap for references, so a reference to a @code{SCM} object from a +memory segment allocated with @code{malloc} will have to use some other +means to keep the @code{SCM} object alive. @xref{Garbage Collection +Functions}.}. Any value that looks like a pointer to a GC-managed +object is treated as such, whether it actually is a reference or not. +Thus, scanning the C stack and static data segment is guaranteed to find +all actual references, but it might also find words that only +accidentally look like references. These ``false positives'' might keep +@code{SCM} objects alive that would otherwise be considered dead. While +this might waste memory, keeping an object around longer than it +strictly needs to is harmless. This is why this technique is called +``conservative garbage collection''. In practice, the wasted memory +seems to be no problem, as the static C root set is almost always finite +and small, given that the Scheme stack is separate from the C stack. The stack of every thread is scanned in this way and the registers of the CPU and all other memory locations where local variables or function From 20718dd94b8360e67c4df9caa5af3e079167e2a6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jun 2016 09:05:05 +0200 Subject: [PATCH 422/865] Add with-input-from-port, etc documentation * doc/ref/api-io.texi (Default Ports): Add documentation for with-input-from-port, with-output-to-port, and with-error-to-port. Fixes #20919. --- doc/ref/api-io.texi | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 48ff1779c..23620538a 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -886,6 +886,14 @@ Change the ports returned by @code{current-input-port}, so that they use the supplied @var{port} for input or output. @end deffn +@deffn {Scheme Procedure} with-input-from-port port thunk +@deffnx {Scheme Procedure} with-output-to-port port thunk +@deffnx {Scheme Procedure} with-error-to-port port thunk +Call @var{thunk} in a dynamic environment in which +@code{current-input-port}, @code{current-output-port} or +@code{current-error-port} is rebound to the given @var{port}. +@end deffn + @deftypefn {C Function} void scm_dynwind_current_input_port (SCM port) @deftypefnx {C Function} void scm_dynwind_current_output_port (SCM port) @deftypefnx {C Function} void scm_dynwind_current_error_port (SCM port) From 7d550c4ea0c78c5f4a726cae03bf812a246a6dde Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jun 2016 09:50:23 +0200 Subject: [PATCH 423/865] Fix ,profile in pure modules * libguile/scmsigs.c (close_1): Make the async closure in an environment where `lambda' has its usual meaning. Fixes #21013. --- libguile/scmsigs.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index a23f151a2..441da3ec7 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -109,8 +109,10 @@ static SIGRETTYPE (*orig_handlers[NSIG])(int); static SCM close_1 (SCM proc, SCM arg) { - return scm_primitive_eval_x (scm_list_3 (scm_sym_lambda, SCM_EOL, - scm_list_2 (proc, arg))); + /* Eval in the root module so that `lambda' has its usual meaning. */ + return scm_eval (scm_list_3 (scm_sym_lambda, SCM_EOL, + scm_list_2 (proc, arg)), + scm_the_root_module ()); } #if SCM_USE_PTHREAD_THREADS From cab7167849d3ec9eb22b3913de87c1670065475e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jun 2016 09:55:28 +0200 Subject: [PATCH 424/865] Fix typo about `keywords' read option * doc/ref/api-data.texi (Keyword Read Syntax): Fix typo. Thanks to Glenn Michaels for the report and fix. --- doc/ref/api-data.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index aee0bb6ce..c87b01eca 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -5888,7 +5888,7 @@ objects print using this syntax as well, so values containing keyword objects can be read back into Guile. When used in an expression, keywords are self-quoting objects. -If the @code{keyword} read option is set to @code{'prefix}, Guile also +If the @code{keywords} read option is set to @code{'prefix}, Guile also recognizes the alternative read syntax @code{:NAME}. Otherwise, tokens of the form @code{:NAME} are read as symbols, as required by R5RS. From 395582b218ee57358df825314acaa7e08a2ce6f9 Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Tue, 28 Jul 2015 09:42:25 +0200 Subject: [PATCH 425/865] Avoid stifling readline history when looking up options With this patch, history is never stifled unless (readline-set!) is used. * src/guile-readline/readline.c (scm_readline_options) --- guile-readline/readline.c | 56 ++++++++++++++++++++------------------- 1 file changed, 29 insertions(+), 27 deletions(-) diff --git a/guile-readline/readline.c b/guile-readline/readline.c index aac6e18c2..a3e890346 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -2,17 +2,17 @@ /* Copyright (C) 1997,1999,2000,2001, 2002, 2003, 2006, 2007, 2008, * 2009, 2010, 2013 Free Software Foundation, Inc. - * + * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 3, or (at your option) * any later version. - * + * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. - * + * * You should have received a copy of the GNU General Public License * along with this software; see the file COPYING. If not, write to * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, @@ -52,7 +52,7 @@ scm_t_option scm_readline_opts[] = { extern void stifle_history (int max); -SCM_DEFINE (scm_readline_options, "readline-options-interface", 0, 1, 0, +SCM_DEFINE (scm_readline_options, "readline-options-interface", 0, 1, 0, (SCM setting), "") #define FUNC_NAME s_scm_readline_options @@ -60,7 +60,9 @@ SCM_DEFINE (scm_readline_options, "readline-options-interface", 0, 1, 0, SCM ans = scm_options (setting, scm_readline_opts, FUNC_NAME); - stifle_history (SCM_HISTORY_LENGTH); + if (!SCM_UNBNDP (setting)) { + stifle_history (SCM_HISTORY_LENGTH); + } return ans; } #undef FUNC_NAME @@ -107,13 +109,13 @@ void rl_free_line_state () { register HIST_ENTRY *entry; - + free_undo_list (); entry = current_history (); if (entry) - entry->data = (char *)NULL; - + entry->data = (char *)NULL; + _rl_kill_kbd_macro (); rl_clear_message (); _rl_init_argument (); @@ -145,15 +147,15 @@ static void unwind_readline (void *unused); static void reentry_barrier (void); -SCM_DEFINE (scm_readline, "%readline", 0, 4, 0, +SCM_DEFINE (scm_readline, "%readline", 0, 4, 0, (SCM text, SCM inp, SCM outp, SCM read_hook), "") #define FUNC_NAME s_scm_readline { SCM ans; - + reentry_barrier (); - + before_read = SCM_BOOL_F; if (!SCM_UNBNDP (text)) @@ -164,7 +166,7 @@ SCM_DEFINE (scm_readline, "%readline", 0, 4, 0, scm_wrong_type_arg (s_scm_readline, SCM_ARG1, text); } } - + if (!((SCM_UNBNDP (inp) && SCM_OPINFPORTP (scm_current_input_port ())) || SCM_OPINFPORTP (inp))) { @@ -173,7 +175,7 @@ SCM_DEFINE (scm_readline, "%readline", 0, 4, 0, "Input port is not open or not a file port", SCM_EOL); } - + if (!((SCM_UNBNDP (outp) && SCM_OPOUTFPORTP (scm_current_output_port ())) || SCM_OPOUTFPORTP (outp))) { @@ -197,7 +199,7 @@ SCM_DEFINE (scm_readline, "%readline", 0, 4, 0, scm_dynwind_begin (0); scm_dynwind_unwind_handler (unwind_readline, NULL, 0); - + ans = internal_readline (text); scm_dynwind_end (); @@ -249,7 +251,7 @@ internal_readline (SCM text) s = readline (prompt); if (s) ret = scm_from_port_string (s, output_port); - else + else ret = SCM_EOF_VAL; if (!SCM_UNBNDP (text)) @@ -287,10 +289,10 @@ scm_readline_init_ports (SCM inp, SCM outp) { if (SCM_UNBNDP (inp)) inp = scm_current_input_port (); - + if (SCM_UNBNDP (outp)) outp = scm_current_output_port (); - + if (!SCM_OPINFPORTP (inp)) { scm_misc_error (0, "Input port is not open or not a file port", @@ -311,7 +313,7 @@ scm_readline_init_ports (SCM inp, SCM outp) -SCM_DEFINE (scm_add_history, "add-history", 1, 0, 0, +SCM_DEFINE (scm_add_history, "add-history", 1, 0, 0, (SCM text), "") #define FUNC_NAME s_scm_add_history @@ -327,7 +329,7 @@ SCM_DEFINE (scm_add_history, "add-history", 1, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_read_history, "read-history", 1, 0, 0, +SCM_DEFINE (scm_read_history, "read-history", 1, 0, 0, (SCM file), "") #define FUNC_NAME s_scm_read_history @@ -343,7 +345,7 @@ SCM_DEFINE (scm_read_history, "read-history", 1, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_write_history, "write-history", 1, 0, 0, +SCM_DEFINE (scm_write_history, "write-history", 1, 0, 0, (SCM file), "") #define FUNC_NAME s_scm_write_history @@ -358,7 +360,7 @@ SCM_DEFINE (scm_write_history, "write-history", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_clear_history, "clear-history", 0, 0, 0, +SCM_DEFINE (scm_clear_history, "clear-history", 0, 0, 0, (), "Clear the history buffer of the readline machinery.") #define FUNC_NAME s_scm_clear_history @@ -369,7 +371,7 @@ SCM_DEFINE (scm_clear_history, "clear-history", 0, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_filename_completion_function, "filename-completion-function", 2, 0, 0, +SCM_DEFINE (scm_filename_completion_function, "filename-completion-function", 2, 0, 0, (SCM text, SCM continuep), "") #define FUNC_NAME s_scm_filename_completion_function @@ -408,10 +410,10 @@ completion_function (char *text, int continuep) SCM t = scm_from_locale_string (text); SCM c = scm_from_bool (continuep); res = scm_apply (compfunc, scm_list_2 (t, c), SCM_EOL); - + if (scm_is_false (res)) return NULL; - + return scm_to_locale_string (res); } } @@ -525,7 +527,7 @@ scm_init_readline () rl_getc_function = current_input_getc; #if defined (_RL_FUNCTION_TYPEDEF) rl_completion_entry_function = (rl_compentry_func_t*) completion_function; -#else +#else rl_completion_entry_function = (Function*) completion_function; #endif rl_basic_word_break_characters = " \t\n\"'`;()"; @@ -535,12 +537,12 @@ scm_init_readline () #if defined (HAVE_DECL_RL_CATCH_SIGNALS) && HAVE_DECL_RL_CATCH_SIGNALS rl_catch_signals = 0; #endif - + /* But let readline handle SIGWINCH. */ #if defined (HAVE_DECL_RL_CATCH_SIGWINCH) && HAVE_DECL_RL_CATCH_SIGWINCH rl_catch_sigwinch = 1; #endif - + reentry_barrier_mutex = scm_make_mutex (); scm_init_opts (scm_readline_options, scm_readline_opts); From 5ca24b6ba1bc617e60a0a9b2ecad7f112e99ef9c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jun 2016 10:40:09 +0200 Subject: [PATCH 426/865] Fix include-from-path when file found in relative path * module/ice-9/psyntax.scm (include-from-path): Canonicalize result of %search-load-path. Otherwise a relative path passed to `include' would be treated as relative to the directory of the file that contains the `include-from-path'. Fixes #21347. * module/ice-9/psyntax-pp.scm: Regenerate. --- module/ice-9/psyntax-pp.scm | 17 +++++++++-------- module/ice-9/psyntax.scm | 9 +++++---- 2 files changed, 14 insertions(+), 12 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 3cd6035f7..e06ae8206 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -3285,14 +3285,15 @@ (let ((fn (syntax->datum filename))) (let ((tmp (datum->syntax filename - (let ((t (%search-load-path fn))) - (if t - t - (syntax-violation - 'include-from-path - "file not found in path" - x - filename)))))) + (canonicalize-path + (let ((t (%search-load-path fn))) + (if t + t + (syntax-violation + 'include-from-path + "file not found in path" + x + filename))))))) (let ((fn tmp)) (list '#(syntax-object include ((top)) (hygiene guile)) fn))))) tmp) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index a45353aa3..e68b4ca7d 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -3204,10 +3204,11 @@ (let ((fn (syntax->datum #'filename))) (with-syntax ((fn (datum->syntax #'filename - (or (%search-load-path fn) - (syntax-violation 'include-from-path - "file not found in path" - x #'filename))))) + (canonicalize-path + (or (%search-load-path fn) + (syntax-violation 'include-from-path + "file not found in path" + x #'filename)))))) #'(include fn))))))) (define-syntax unquote From d848af9a161b0c37964d582dfb8b52ed5112355f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jun 2016 14:15:38 +0200 Subject: [PATCH 427/865] Parse bytecode to determine minimum arity * libguile/programs.c (try_parse_arity): New helper, to parse bytecode to determine the minimum arity of a function in a cheaper way than grovelling through the debug info. Should speed up all thunk? checks and similar. (scm_i_program_arity): Simplify. * libguile/gsubr.h: * libguile/gsubr.c (scm_i_primitive_arity): * libguile/foreign.h: * libguile/foreign.c (scm_i_foreign_arity): --- libguile/foreign.c | 19 ------------ libguile/foreign.h | 2 -- libguile/gsubr.c | 31 -------------------- libguile/gsubr.h | 1 - libguile/programs.c | 71 ++++++++++++++++++++++++++++++++++++--------- 5 files changed, 58 insertions(+), 66 deletions(-) diff --git a/libguile/foreign.c b/libguile/foreign.c index 936f3419c..0992ef4d3 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -792,25 +792,6 @@ get_foreign_stub_code (unsigned int nargs) return &foreign_stub_code[nargs * 2]; } -/* Given a foreign procedure, determine its minimum arity. */ -int -scm_i_foreign_arity (SCM foreign, int *req, int *opt, int *rest) -{ - const scm_t_uint32 *code = SCM_PROGRAM_CODE (foreign); - - if (code < foreign_stub_code) - return 0; - if (code > (foreign_stub_code - + (sizeof(foreign_stub_code) / sizeof(scm_t_uint32)))) - return 0; - - *req = (code - foreign_stub_code) / 2; - *opt = 0; - *rest = 0; - - return 1; -} - static SCM cif_to_procedure (SCM cif, SCM func_ptr) { diff --git a/libguile/foreign.h b/libguile/foreign.h index 53f39d5c7..4c1a19f1f 100644 --- a/libguile/foreign.h +++ b/libguile/foreign.h @@ -101,8 +101,6 @@ SCM_API SCM scm_procedure_to_pointer (SCM return_type, SCM func_ptr, SCM arg_types); SCM_INTERNAL SCM scm_i_foreign_call (SCM foreign, const union scm_vm_stack_element *argv); -SCM_INTERNAL int scm_i_foreign_arity (SCM foreign, - int *req, int *opt, int *rest); diff --git a/libguile/gsubr.c b/libguile/gsubr.c index d80e5dd42..b456b220a 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -262,37 +262,6 @@ scm_i_primitive_code_p (const scm_t_uint32 *code) return 1; } -/* Given a program that is a primitive, determine its minimum arity. - This is possible because each primitive's code is 4 32-bit words - long, and they are laid out contiguously in an ordered pattern. */ -int -scm_i_primitive_arity (SCM prim, int *req, int *opt, int *rest) -{ - const scm_t_uint32 *code = SCM_PROGRAM_CODE (prim); - unsigned idx, nargs, base, next; - - if (!scm_i_primitive_code_p (code)) - return 0; - - idx = (code - subr_stub_code) / 4; - - nargs = -1; - next = 0; - do - { - base = next; - nargs++; - next = (nargs + 1) * (nargs + 1); - } - while (idx >= next); - - *rest = (next - idx) < (idx - base); - *req = *rest ? (next - 1) - idx : (base + nargs) - idx; - *opt = *rest ? idx - (next - nargs) : idx - base; - - return 1; -} - scm_t_uintptr scm_i_primitive_call_ip (SCM subr) { diff --git a/libguile/gsubr.h b/libguile/gsubr.h index 725de2cbd..83eebc371 100644 --- a/libguile/gsubr.h +++ b/libguile/gsubr.h @@ -55,7 +55,6 @@ SCM_INTERNAL int scm_i_primitive_code_p (const scm_t_uint32 *code); -SCM_INTERNAL int scm_i_primitive_arity (SCM subr, int *req, int *opt, int *rest); SCM_INTERNAL scm_t_uintptr scm_i_primitive_call_ip (SCM subr); union scm_vm_stack_element; diff --git a/libguile/programs.c b/libguile/programs.c index 49d4c77b1..ba8e8546b 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -22,6 +22,7 @@ #include #include "_scm.h" +#include "instructions.h" #include "modules.h" #include "programs.h" #include "procprop.h" /* scm_sym_name */ @@ -236,25 +237,69 @@ SCM_DEFINE (scm_program_free_variable_set_x, "program-free-variable-set!", 3, 0, } #undef FUNC_NAME +/* It's hacky, but it manages to cover all of the non-keyword cases. */ +static int +try_parse_arity (SCM program, int *req, int *opt, int *rest) +{ + scm_t_uint32 *code = SCM_PROGRAM_CODE (program); + scm_t_uint32 slots, min; + + switch (code[0] & 0xff) { + case scm_op_assert_nargs_ee: + slots = code[0] >> 8; + *req = slots - 1; + *opt = 0; + *rest = 0; + return 1; + case scm_op_assert_nargs_le: + slots = code[0] >> 8; + *req = 0; + *opt = slots - 1; + *rest = 0; + return 1; + case scm_op_bind_rest: + slots = code[0] >> 8; + *req = 0; + *opt = slots - 1; + *rest = 1; + return 1; + case scm_op_assert_nargs_ge: + min = code[0] >> 8; + switch (code[1] & 0xff) { + case scm_op_assert_nargs_le: + slots = code[1] >> 8; + *req = min - 1; + *opt = slots - 1 - *req; + *rest = 0; + return 1; + case scm_op_bind_rest: + slots = code[1] >> 8; + *req = min - 1; + *opt = slots - min; + *rest = 1; + return 1; + default: + return 0; + } + case scm_op_continuation_call: + case scm_op_compose_continuation: + *req = 0; + *opt = 0; + *rest = 1; + return 1; + default: + return 0; + } +} + int scm_i_program_arity (SCM program, int *req, int *opt, int *rest) { static SCM program_minimum_arity = SCM_BOOL_F; SCM l; - if (SCM_PRIMITIVE_P (program)) - return scm_i_primitive_arity (program, req, opt, rest); - - if (SCM_PROGRAM_IS_FOREIGN (program)) - return scm_i_foreign_arity (program, req, opt, rest); - - if (SCM_PROGRAM_IS_CONTINUATION (program) - || SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program)) - { - *req = *opt = 0; - *rest = 1; - return 1; - } + if (try_parse_arity (program, req, opt, rest)) + return 1; if (scm_is_false (program_minimum_arity) && scm_module_system_booted_p) program_minimum_arity = From bd65845497110b179456d4bfdf26854791f0a822 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jun 2016 17:09:39 +0200 Subject: [PATCH 428/865] Fix texinfo->html for @acronym, @itemize * module/texinfo/html.scm (itemize, acronym, tag-replacements, rules): Fix HTML serialization of @itemize and @acronym. Fixes #21772. * test-suite/tests/texinfo.html.test: New file. * test-suite/Makefile.am: Add new file. --- module/texinfo/html.scm | 24 +++++++++++++++----- test-suite/Makefile.am | 1 + test-suite/tests/texinfo.html.test | 36 ++++++++++++++++++++++++++++++ 3 files changed, 56 insertions(+), 5 deletions(-) create mode 100644 test-suite/tests/texinfo.html.test diff --git a/module/texinfo/html.scm b/module/texinfo/html.scm index 709744dc3..6a07cffce 100644 --- a/module/texinfo/html.scm +++ b/module/texinfo/html.scm @@ -37,10 +37,11 @@ ;; margin-top on dd > p) (define-module (texinfo html) - :use-module (texinfo) - :use-module (sxml transform) - :use-module (srfi srfi-13) - :export (stexi->shtml add-ref-resolver! urlify)) + #:use-module (texinfo) + #:use-module (sxml transform) + #:use-module (ice-9 match) + #:use-module (srfi srfi-13) + #:export (stexi->shtml add-ref-resolver! urlify)) ;; The caller is responsible for carring the returned list. (define (arg-ref key %-args) @@ -138,6 +139,18 @@ name, @code{#}, and the node name." (cdr elts)) elts))) +(define (itemize tag . elts) + `(ul ,@(match elts + ;; Strip `bullet' attribute. + ((('% . attrs) . elts) elts) + (elts elts)))) + +(define (acronym tag . elts) + (match elts + ;; FIXME: Need attribute matcher that doesn't depend on attribute + ;; order. + ((('% ('acronym text) . _)) `(acronym ,text)))) + (define (table tag args . body) (let ((formatter (caar (arg-req 'formatter args)))) (cons 'dl @@ -184,7 +197,6 @@ name, @code{#}, and the node name." (subheading h4) (subsubheading h5) (quotation blockquote) - (itemize ul) (item li) ;; itemx ? (para p) (*fragment* div) ;; should be ok @@ -234,6 +246,8 @@ name, @code{#}, and the node name." (node . ,node) (anchor . ,node) (table . ,table) (enumerate . ,enumerate) + (itemize . ,itemize) + (acronym . ,acronym) (entry *preorder* . ,entry) (deftp . ,def) (defcv . ,def) (defivar . ,def) (deftypeivar . ,def) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 5b498608f..473501ee2 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -176,6 +176,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/syntax.test \ tests/texinfo.test \ tests/texinfo.docbook.test \ + tests/texinfo.html.test \ tests/texinfo.serialize.test \ tests/texinfo.string-utils.test \ tests/threads.test \ diff --git a/test-suite/tests/texinfo.html.test b/test-suite/tests/texinfo.html.test new file mode 100644 index 000000000..02f4d28c3 --- /dev/null +++ b/test-suite/tests/texinfo.html.test @@ -0,0 +1,36 @@ +;;;; texinfo.html.test -*- scheme -*- +;;;; +;;;; Copyright (C) 2016 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;; +;; Unit tests for (texinfo html). +;; +;;; Code: + +(define-module (test-suite texinfo-html) + #:use-module (test-suite lib) + #:use-module (texinfo) + #:use-module (texinfo html)) + +(define (texi-fragment->shtml str) + (stexi->shtml (texi-fragment->stexi str))) + +(pass-if-equal '(div (ul (li (p "foo")))) + (texi-fragment->shtml "@itemize\n@item foo\n@end itemize\n")) +(pass-if-equal '(div (p (acronym "GNU"))) + (texi-fragment->shtml "@acronym{GNU}\n")) From 9687334ff52a2def369e7abb8563401351db9be7 Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Fri, 24 Jun 2016 16:31:45 +0200 Subject: [PATCH 429/865] On Darwin, skip tests that depend on setrlimit On Darwin, setrlimit is ignored, and these tests do not terminate. There doesn't seem to be another way to limit the memory allocated by a process. * test-suite/standalone/test-stack-overflow: Skip this test on Darwin. * test-suite/standalone/test-out-of-memory: Skip this test on Darwin. --- test-suite/standalone/test-out-of-memory | 6 ++++++ test-suite/standalone/test-stack-overflow | 7 +++++++ 2 files changed, 13 insertions(+) diff --git a/test-suite/standalone/test-out-of-memory b/test-suite/standalone/test-out-of-memory index 2ae3ee69b..bda42cb44 100755 --- a/test-suite/standalone/test-out-of-memory +++ b/test-suite/standalone/test-out-of-memory @@ -9,6 +9,12 @@ exec guile -q -s "$0" "$@" ;; should run as part of an automated test suite. (exit 0)) +(when (string-ci= "darwin" (vector-ref (uname) 0)) + ;; setrlimits are ignored in OS X (tested on 10.9 and 10.10). Proceeding + ;; with the test would fill all available memory and probably end in a crash. + ;; See also test-stack-overflow. + (exit 77)) ; unresolved + (catch #t ;; Silence GC warnings. (lambda () diff --git a/test-suite/standalone/test-stack-overflow b/test-suite/standalone/test-stack-overflow index 3b979a99e..74bc7b874 100755 --- a/test-suite/standalone/test-stack-overflow +++ b/test-suite/standalone/test-stack-overflow @@ -9,6 +9,12 @@ exec guile -q -s "$0" "$@" ;; something we should run as part of an automated test suite. (exit 0)) +(when (string-ci= "darwin" (vector-ref (uname) 0)) + ;; setrlimits are ignored in OS X (tested on 10.9 and 10.10). Proceeding + ;; with the test would fill all available memory and probably end in a crash. + ;; See also test-stack-overflow. + (exit 77)) ; uresolved + ;; 100 MB. (define *limit* (* 100 1024 1024)) @@ -28,6 +34,7 @@ exec guile -q -s "$0" "$@" ;; Run the test a few times. The stack will only be enlarged and ;; relocated on the first one. + (test) (test) (test) From ff5cafc77d34420b12a134ef2c1d5bd7ca4794cb Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jun 2016 17:22:17 +0200 Subject: [PATCH 430/865] Prevent (@ (ice-9 boot-9) x) * module/ice-9/boot-9.scm: Prevent re-loading, perhaps via (@ (ice-9 boot-9) foo). (ice-9 boot-9) isn't a module. Fixes #21801. --- module/ice-9/boot-9.scm | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 5d1fcc4b3..c2ee108f6 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -39,6 +39,11 @@ (eval-when (compile) (set-current-module (resolve-module '(guile)))) +;; Prevent this file being loaded more than once in a session. Just +;; doesn't make sense! +(if (current-module) + (error "re-loading ice-9/boot-9.scm not allowed")) + ;;; {Language primitives} From 229d062f83d7c79fa08729330406d25755b25080 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jun 2016 17:35:55 +0200 Subject: [PATCH 431/865] Constant-folding eq? and eqv? uses deduplication * test-suite/tests/peval.test ("partial evaluation"): Add tests. * module/language/tree-il/peval.scm (peval): Constant-fold eq? and eqv? using equal?, anticipating deduplication. --- module/language/tree-il/peval.scm | 10 +++++++++- test-suite/tests/peval.test | 8 ++++++++ 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 8e1069d38..7d1945873 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -511,7 +511,15 @@ top-level bindings from ENV and return the resulting expression." (lambda () (call-with-values (lambda () - (apply (module-ref the-scm-module name) args)) + (case name + ((eq? eqv?) + ;; Constants will be deduplicated later, but eq? + ;; folding can happen now. Anticipate the + ;; deduplication by using equal? instead of eq?. + ;; Same for eqv?. + (apply equal? args)) + (else + (apply (module-ref the-scm-module name) args)))) (lambda results (values #t results)))) (lambda _ diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test index 340780873..4e2ccf9c6 100644 --- a/test-suite/tests/peval.test +++ b/test-suite/tests/peval.test @@ -1359,6 +1359,14 @@ (((x) #f #f #f () (_)) (call (toplevel bar) (lexical x _)))))) + (pass-if-peval + (eq? '(a b) '(a b)) + (const #t)) + + (pass-if-peval + (eqv? '(a b) '(a b)) + (const #t)) + (pass-if-peval ((lambda (foo) (define* (bar a #:optional (b (1+ a))) From 6a5b44de683fdcea5aee7a089a294c597db55ca1 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jun 2016 17:52:30 +0200 Subject: [PATCH 432/865] Check for strtod_l before using it. Based on a patch by Andy Stormont . * configure.ac: Check for strtod_l. * libguile/i18n.c (scm_locale_string_to_integer): Fix style. (scm_locale_string_to_inexact): Check for strtod_l. --- configure.ac | 2 +- libguile/i18n.c | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/configure.ac b/configure.ac index c9c1795c2..4c78b0712 100644 --- a/configure.ac +++ b/configure.ac @@ -766,7 +766,7 @@ AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \ strdup system usleep atexit on_exit chown link fcntl ttyname getpwent \ getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp \ index bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron \ - strcoll strcoll_l strtol_l newlocale uselocale utimensat \ + strcoll strcoll_l strtod_l strtol_l newlocale uselocale utimensat \ sched_getaffinity sched_setaffinity sendfile]) # Reasons for testing: diff --git a/libguile/i18n.c b/libguile/i18n.c index 84c6bfc58..6f75966a1 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -1335,7 +1335,7 @@ SCM_DEFINE (scm_locale_string_to_integer, "locale-string->integer", if (c_locale != NULL) { -#if defined(USE_GNU_LOCALE_API) && defined(HAVE_STRTOL_L) +#if defined USE_GNU_LOCALE_API && defined HAVE_STRTOL_L c_result = strtol_l (c_str, &c_endptr, c_base, c_locale); #else RUN_IN_LOCALE_SECTION (c_locale, @@ -1379,7 +1379,7 @@ SCM_DEFINE (scm_locale_string_to_inexact, "locale-string->inexact", if (c_locale != NULL) { -#ifdef USE_GNU_LOCALE_API +#if defined USE_GNU_LOCALE_API && defined HAVE_STRTOD_L c_result = strtod_l (c_str, &c_endptr, c_locale); #else RUN_IN_LOCALE_SECTION (c_locale, From 5f9134c32d0c4d7497dfeabbcc219e35a66013d5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Jun 2016 18:18:46 +0200 Subject: [PATCH 433/865] Favor "escape continuation" over "one-shot continuation" in manual * doc/ref/api-control.texi (Prompt Primitives): Remove mention of one-shot continuations, as it's possible to invoke them multiple times if the continuation is re-entered through other means. --- doc/ref/api-control.texi | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index a1eacd6c8..10a445cb0 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.texi @@ -584,10 +584,8 @@ important efficiency consideration to keep in mind. One example where this optimization matters is @dfn{escape continuations}. Escape continuations are delimited continuations whose only use is to make a non-local exit---i.e., to escape from the current -continuation. Such continuations are invoked only once, and for this -reason they are sometimes called @dfn{one-shot continuations}. A common -use of escape continuations is when throwing an exception -(@pxref{Exceptions}). +continuation. A common use of escape continuations is when throwing an +exception (@pxref{Exceptions}). The constructs below are syntactic sugar atop prompts to simplify the use of escape continuations. From 73714b87aa920b8d29223f8de701c0713fb4e6af Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 25 Jun 2016 10:06:15 +0200 Subject: [PATCH 434/865] Add documentation pointer from getopt-long to SRFI-37. * doc/ref/mod-getopt-long.texi (getopt-long): Point to SRFI-37. --- doc/ref/mod-getopt-long.texi | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/doc/ref/mod-getopt-long.texi b/doc/ref/mod-getopt-long.texi index 07fab813b..cf043418f 100644 --- a/doc/ref/mod-getopt-long.texi +++ b/doc/ref/mod-getopt-long.texi @@ -7,6 +7,12 @@ @node getopt-long @section The (ice-9 getopt-long) Module +The @code{(ice-9 getopt-long)} facility is designed to help parse +arguments that are passed to Guile programs on the command line, and is +modelled after the C library's facility of the same name +(@pxref{Getopt,,,libc,The GNU C Library Reference Manual}). For a more +low-level interface to command-line argument parsing, @xref{SRFI-37}. + The @code{(ice-9 getopt-long)} module exports two procedures: @code{getopt-long} and @code{option-ref}. From 31c76f16c6f13cf2d55c7f4830e874ed702ad777 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 25 Jun 2016 15:34:11 +0200 Subject: [PATCH 435/865] Fix duplicate case in peval * module/language/tree-il/peval.scm (singly-valued-expression?): Fix duplicate case. Spotted by "mejja" on IRC. --- module/language/tree-il/peval.scm | 1 - 1 file changed, 1 deletion(-) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 7d1945873..07004a349 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -92,7 +92,6 @@ (define (singly-valued-expression? exp) (match exp (($ ) #t) - (($ ) #t) (($ ) #t) (($ ) #t) (($ ) #t) From 3e719e0a35cf383d4f7fa3823494f01e244135e9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 25 Jun 2016 18:08:28 +0200 Subject: [PATCH 436/865] Add -Wmacro-use-before-definition * module/ice-9/boot-9.scm (%auto-compilation-options): * am/guilec (GUILE_WARNINGS): Add -Wmacro-use-before-definition. * module/language/tree-il/analyze.scm (unbound-variable-analysis): Use match-lambda. (, macro-use-before-definition-analysis): New analysis. * module/system/base/message.scm (%warning-types): Add macro-use-before-definition warning type. * module/language/tree-il/compile-cps.scm (%warning-passes): Add support for macro-use-before-definition. --- am/guilec | 2 +- module/ice-9/boot-9.scm | 4 +- module/language/tree-il/analyze.scm | 70 +++++++++++++++++++++++-- module/language/tree-il/compile-cps.scm | 11 ++-- module/system/base/message.scm | 6 +++ 5 files changed, 81 insertions(+), 12 deletions(-) diff --git a/am/guilec b/am/guilec index 5ef07faa4..7ab9cccb7 100644 --- a/am/guilec +++ b/am/guilec @@ -1,7 +1,7 @@ # -*- makefile -*- GOBJECTS = $(SOURCES:%.scm=%.go) $(ELISP_SOURCES:%.el=%.go) -GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat +GUILE_WARNINGS = -Wunbound-variable -Wmacro-use-before-definition -Warity-mismatch -Wformat moddir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/$(modpath) nobase_mod_DATA = $(SOURCES) $(ELISP_SOURCES) $(NOCOMP_SOURCES) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index c2ee108f6..99543e7a5 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -3679,8 +3679,8 @@ but it fails to load." (define %auto-compilation-options ;; Default `compile-file' option when auto-compiling. - '(#:warnings (unbound-variable arity-mismatch format - duplicate-case-datum bad-case-datum))) + '(#:warnings (unbound-variable macro-use-before-definition arity-mismatch + format duplicate-case-datum bad-case-datum))) (define* (load-in-vicinity dir file-name #:optional reader) "Load source file FILE-NAME in vicinity of directory DIR. Use a diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 1c0612764..ff4b93d31 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -35,6 +35,7 @@ unused-variable-analysis unused-toplevel-analysis unbound-variable-analysis + macro-use-before-definition-analysis arity-analysis format-analysis)) @@ -895,14 +896,75 @@ given `tree-il' element." (lambda (toplevel env) ;; Post-process the result. - (vlist-for-each (lambda (name+loc) - (let ((name (car name+loc)) - (loc (cdr name+loc))) - (warning 'unbound-variable loc name))) + (vlist-for-each (match-lambda + ((name . loc) + (warning 'unbound-variable loc name))) (vlist-reverse (toplevel-info-refs toplevel)))) (make-toplevel-info vlist-null vlist-null))) + +;;; +;;; Macro use-before-definition analysis. +;;; + +;; records are used during tree traversal in search of +;; possibly uses of macros before they are defined. They contain a list +;; of references to top-level variables, and a list of the top-level +;; macro definitions that have been encountered. Any definition which +;; is a macro should in theory be expanded out already; if that's not +;; the case, the program likely has a bug. +(define-record-type + (make-macro-use-info uses defs) + macro-use-info? + (uses macro-use-info-uses) ;; ((VARIABLE-NAME . LOCATION) ...) + (defs macro-use-info-defs)) ;; ((VARIABLE-NAME . LOCATION) ...) + +(define macro-use-before-definition-analysis + ;; Report possibly unbound variables in the given tree. + (make-tree-analysis + (lambda (x info env locs) + ;; Going down into X. + (define (nearest-loc src) + (or src (find pair? locs))) + (define (add-use name src) + (match info + (($ uses defs) + (make-macro-use-info (vhash-consq name src uses) defs)))) + (define (add-def name src) + (match info + (($ uses defs) + (make-macro-use-info uses (vhash-consq name src defs))))) + (define (macro? x) + (match x + (($ _ 'make-syntax-transformer) #t) + (_ #f))) + (match x + (($ src name) + (add-use name (nearest-loc src))) + (($ src name) + (add-use name (nearest-loc src))) + (($ src name (? macro?)) + (add-def name (nearest-loc src))) + (_ info))) + + (lambda (x info env locs) + ;; Leaving X's scope. + info) + + (lambda (info env) + ;; Post-process the result. + (match info + (($ uses defs) + (vlist-for-each + (match-lambda + ((name . use-loc) + (when (vhash-assq name defs) + (warning 'macro-use-before-definition use-loc name)))) + (vlist-reverse (macro-use-info-uses info)))))) + + (make-macro-use-info vlist-null vlist-null))) + ;;; ;;; Arity analysis. diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 3443d761e..9e7dc72ca 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -955,11 +955,12 @@ integer." (define *comp-module* (make-fluid)) (define %warning-passes - `((unused-variable . ,unused-variable-analysis) - (unused-toplevel . ,unused-toplevel-analysis) - (unbound-variable . ,unbound-variable-analysis) - (arity-mismatch . ,arity-analysis) - (format . ,format-analysis))) + `((unused-variable . ,unused-variable-analysis) + (unused-toplevel . ,unused-toplevel-analysis) + (unbound-variable . ,unbound-variable-analysis) + (macro-use-before-definition . ,macro-use-before-definition-analysis) + (arity-mismatch . ,arity-analysis) + (format . ,format-analysis))) (define (optimize-tree-il x e opts) (define warnings diff --git a/module/system/base/message.scm b/module/system/base/message.scm index 26d1a181a..979291c1e 100644 --- a/module/system/base/message.scm +++ b/module/system/base/message.scm @@ -115,6 +115,12 @@ (emit port "~A: warning: possibly unbound variable `~A'~%" loc name))) + (macro-use-before-definition + "report possibly mis-use of macros before they are defined" + ,(lambda (port loc name) + (emit port "~A: warning: macro `~A' used before definition~%" + loc name))) + (arity-mismatch "report procedure arity mismatches (wrong number of arguments)" ,(lambda (port loc name certain?) From d5d7e303486012b3173c8df0417c69b01df9baf3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?= Date: Sat, 25 Jun 2016 16:43:36 +0200 Subject: [PATCH 437/865] Fix 'monitor' macro. * module/ice-9/threads.scm (monitor-mutex-table) (monitor-mutex-table-mutex, monitor-mutex-with-id): New variables. (monitor): Fix it. --- module/ice-9/threads.scm | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm index 9f9e1bf8e..14da11339 100644 --- a/module/ice-9/threads.scm +++ b/module/ice-9/threads.scm @@ -85,9 +85,24 @@ (lambda () (begin e0 e1 ...)) (lambda () (unlock-mutex x))))) -(define-syntax-rule (monitor first rest ...) - (with-mutex (make-mutex) - first rest ...)) +(define monitor-mutex-table (make-hash-table)) + +(define monitor-mutex-table-mutex (make-mutex)) + +(define (monitor-mutex-with-id id) + (with-mutex monitor-mutex-table-mutex + (or (hashq-ref monitor-mutex-table id) + (let ((mutex (make-mutex))) + (hashq-set! monitor-mutex-table id mutex) + mutex)))) + +(define-syntax monitor + (lambda (stx) + (syntax-case stx () + ((_ body body* ...) + (let ((id (datum->syntax #'body (gensym)))) + #`(with-mutex (monitor-mutex-with-id '#,id) + body body* ...)))))) (define (par-mapper mapper cons) (lambda (proc . lists) From cce3ea2b5979a0b156bd25ee72bae270529a4239 Mon Sep 17 00:00:00 2001 From: David Pirotte Date: Sat, 25 Jun 2016 17:42:09 -0300 Subject: [PATCH 438/865] Do not track some test-suite files * .gitignore: Adding test-smob-mark-race to the list of the test-suite files we do not track. --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 6375f2bc5..7f9d630f8 100644 --- a/.gitignore +++ b/.gitignore @@ -142,6 +142,7 @@ INSTALL /test-suite/standalone/test-scm-spawn-thread /test-suite/standalone/test-pthread-create /test-suite/standalone/test-pthread-create-secondary +/test-suite/standalone/test-smob-mark-race /lib/fcntl.h /lib/sys/uio.h /lib/stdalign.h From ed39782c2a000c1e3f49c314e2f71bd9de64a694 Mon Sep 17 00:00:00 2001 From: David Pirotte Date: Sat, 25 Jun 2016 23:07:48 -0300 Subject: [PATCH 439/865] Fixing GUILE_PROGS wrong versioning checks * meta/guile.m4: Fixing GUILE_PROGS versioning checks were wrong and incomplete, leading to false errors like: "... checking for Guile version >= 2.0.11... configure: error: Guile 2.0.11 required, but 2.1.3 found". thanks to Colomban Wendling, aka b4n, who also suggested this fix during a chat on #autotools while helping me wrt another autotool related problem I was nvestigating. --- meta/guile.m4 | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/meta/guile.m4 b/meta/guile.m4 index dd3c212e8..9fd4f1a9f 100644 --- a/meta/guile.m4 +++ b/meta/guile.m4 @@ -47,8 +47,8 @@ # for an available version of Guile. # # By default, this macro will search for the latest stable version of -# Guile (e.g. 2.0), falling back to the previous stable version -# (e.g. 1.8) if it is available. If no guile-@var{VERSION}.pc file is +# Guile (e.g. 2.2), falling back to the previous stable version +# (e.g. 2.0) if it is available. If no guile-@var{VERSION}.pc file is # found, an error is signalled. The found version is stored in # @var{GUILE_EFFECTIVE_VERSION}. # @@ -224,8 +224,12 @@ AC_DEFUN([GUILE_PROGS], _major_version=`echo $_guile_required_version | cut -d . -f 1` _minor_version=`echo $_guile_required_version | cut -d . -f 2` _micro_version=`echo $_guile_required_version | cut -d . -f 3` - if test "$_guile_major_version" -ge "$_major_version"; then - if test "$_guile_minor_version" -ge "$_minor_version"; then + if test "$_guile_major_version" -gt "$_major_version"; then + true + elif test "$_guile_major_version" -eq "$_major_version"; then + if test "$_guile_minor_version" -gt "$_minor_version"; then + true + elif test "$_guile_minor_version" -eq "$_minor_version"; then if test -n "$_micro_version"; then if test "$_guile_micro_version" -lt "$_micro_version"; then AC_MSG_ERROR([Guile $_guile_required_version required, but $_guile_prog_version found]) From e264117e1b73cfbc70f863bb964653dd9ed7a83e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 27 Jun 2016 22:47:06 +0200 Subject: [PATCH 440/865] Fix uninstalled-env bug that put prebuilt/ in front * meta/uninstalled-env.in (top_builddir): Fix bug whereby meta/uninstalled-env run within meta-uninstalled-env, as happens sometimes, would move the prebuilt dir to the front. --- meta/uninstalled-env.in | 9 ++------- 1 file changed, 2 insertions(+), 7 deletions(-) diff --git a/meta/uninstalled-env.in b/meta/uninstalled-env.in index 7197eabee..ff32902d0 100644 --- a/meta/uninstalled-env.in +++ b/meta/uninstalled-env.in @@ -80,17 +80,12 @@ then fi export GUILE_LOAD_PATH - if test "x$GUILE_LOAD_COMPILED_PATH" = "x"; then - GUILE_LOAD_COMPILED_PATH="${top_srcdir}/prebuilt/@host@" - else - GUILE_LOAD_COMPILED_PATH="${top_srcdir}/prebuilt/@host@:$GUILE_LOAD_COMPILED_PATH" - fi - - for d in "/bootstrap" "/module" "/guile-readline" + for d in "/prebuilt/@host@" "/bootstrap" "/module" "/guile-readline" do # This hair prevents double inclusion. # The ":" prevents prefix aliasing. case x"$GUILE_LOAD_COMPILED_PATH" in + x) GUILE_LOAD_COMPILED_PATH="${top_builddir}${d}" ;; x*${top_builddir}${d}:*) ;; x*${top_builddir}${d}) ;; *) GUILE_LOAD_COMPILED_PATH="${top_builddir}${d}:$GUILE_LOAD_COMPILED_PATH" ;; From a62d46ffff7b13339178f265fef9171e6b972250 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 27 Jun 2016 22:54:04 +0200 Subject: [PATCH 441/865] psyntax can trace expand-time changes to the current module * module/ice-9/psyntax.scm (expand-top-sequence): Support expand-time changes to the current module. * module/ice-9/psyntax-pp.scm: Regenerate. --- module/ice-9/psyntax-pp.scm | 219 +++++++++++++++++++----------------- module/ice-9/psyntax.scm | 11 +- 2 files changed, 124 insertions(+), 106 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index e06ae8206..d79766595 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -583,114 +583,123 @@ (lp (cdr body) (append (parse1 (car body) r w s m esew mod) exps)))))) (parse1 (lambda (x r w s m esew mod) - (call-with-values - (lambda () (syntax-type x r w (source-annotation x) ribcage mod #f)) - (lambda (type value form e w s mod) - (let ((key type)) - (cond ((memv key '(define-form)) - (let* ((id (wrap value w mod)) - (label (gen-label)) - (var (if (macro-introduced-identifier? id) - (fresh-derived-name id x) - (syntax-object-expression id)))) - (record-definition! id var) + (letrec* + ((current-module-for-expansion + (lambda (mod) + (let ((key (car mod))) + (if (memv key '(hygiene)) + (cons 'hygiene (module-name (current-module))) + mod))))) + (call-with-values + (lambda () + (let ((mod (current-module-for-expansion mod))) + (syntax-type x r w (source-annotation x) ribcage mod #f))) + (lambda (type value form e w s mod) + (let ((key type)) + (cond ((memv key '(define-form)) + (let* ((id (wrap value w mod)) + (label (gen-label)) + (var (if (macro-introduced-identifier? id) + (fresh-derived-name id x) + (syntax-object-expression id)))) + (record-definition! id var) + (list (if (eq? m 'c&e) + (let ((x (build-global-definition s var (expand e r w mod)))) + (top-level-eval-hook x mod) + (lambda () x)) + (call-with-values + (lambda () (resolve-identifier id '(()) r mod #t)) + (lambda (type* value* mod*) + (if (eq? type* 'macro) + (top-level-eval-hook + (build-global-definition s var (build-void s)) + mod)) + (lambda () (build-global-definition s var (expand e r w mod))))))))) + ((memv key '(define-syntax-form define-syntax-parameter-form)) + (let* ((id (wrap value w mod)) + (label (gen-label)) + (var (if (macro-introduced-identifier? id) + (fresh-derived-name id x) + (syntax-object-expression id)))) + (record-definition! id var) + (let ((key m)) + (cond ((memv key '(c)) + (cond ((memq 'compile esew) + (let ((e (expand-install-global var type (expand e r w mod)))) + (top-level-eval-hook e mod) + (if (memq 'load esew) (list (lambda () e)) '()))) + ((memq 'load esew) + (list (lambda () (expand-install-global var type (expand e r w mod))))) + (else '()))) + ((memv key '(c&e)) + (let ((e (expand-install-global var type (expand e r w mod)))) + (top-level-eval-hook e mod) + (list (lambda () e)))) + (else + (if (memq 'eval esew) + (top-level-eval-hook + (expand-install-global var type (expand e r w mod)) + mod)) + '()))))) + ((memv key '(begin-form)) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any)))) + (if tmp + (apply (lambda (e1) (parse e1 r w s m esew mod)) tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))) + ((memv key '(local-syntax-form)) + (expand-local-syntax + value + e + r + w + s + mod + (lambda (forms r w s mod) (parse forms r w s m esew mod)))) + ((memv key '(eval-when-form)) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any)))) + (if tmp + (apply (lambda (x e1 e2) + (let ((when-list (parse-when-list e x)) (body (cons e1 e2))) + (letrec* + ((recurse (lambda (m esew) (parse body r w s m esew mod)))) + (cond ((eq? m 'e) + (if (memq 'eval when-list) + (recurse (if (memq 'expand when-list) 'c&e 'e) '(eval)) + (begin + (if (memq 'expand when-list) + (top-level-eval-hook + (expand-top-sequence body r w s 'e '(eval) mod) + mod)) + '()))) + ((memq 'load when-list) + (cond ((or (memq 'compile when-list) + (memq 'expand when-list) + (and (eq? m 'c&e) (memq 'eval when-list))) + (recurse 'c&e '(compile load))) + ((memq m '(c c&e)) (recurse 'c '(load))) + (else '()))) + ((or (memq 'compile when-list) + (memq 'expand when-list) + (and (eq? m 'c&e) (memq 'eval when-list))) + (top-level-eval-hook + (expand-top-sequence body r w s 'e '(eval) mod) + mod) + '()) + (else '()))))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))) + (else (list (if (eq? m 'c&e) - (let ((x (build-global-definition s var (expand e r w mod)))) + (let ((x (expand-expr type value form e r w s mod))) (top-level-eval-hook x mod) (lambda () x)) - (call-with-values - (lambda () (resolve-identifier id '(()) r mod #t)) - (lambda (type* value* mod*) - (if (eq? type* 'macro) - (top-level-eval-hook - (build-global-definition s var (build-void s)) - mod)) - (lambda () (build-global-definition s var (expand e r w mod))))))))) - ((memv key '(define-syntax-form define-syntax-parameter-form)) - (let* ((id (wrap value w mod)) - (label (gen-label)) - (var (if (macro-introduced-identifier? id) - (fresh-derived-name id x) - (syntax-object-expression id)))) - (record-definition! id var) - (let ((key m)) - (cond ((memv key '(c)) - (cond ((memq 'compile esew) - (let ((e (expand-install-global var type (expand e r w mod)))) - (top-level-eval-hook e mod) - (if (memq 'load esew) (list (lambda () e)) '()))) - ((memq 'load esew) - (list (lambda () (expand-install-global var type (expand e r w mod))))) - (else '()))) - ((memv key '(c&e)) - (let ((e (expand-install-global var type (expand e r w mod)))) - (top-level-eval-hook e mod) - (list (lambda () e)))) - (else - (if (memq 'eval esew) - (top-level-eval-hook - (expand-install-global var type (expand e r w mod)) - mod)) - '()))))) - ((memv key '(begin-form)) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any)))) - (if tmp - (apply (lambda (e1) (parse e1 r w s m esew mod)) tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))) - ((memv key '(local-syntax-form)) - (expand-local-syntax - value - e - r - w - s - mod - (lambda (forms r w s mod) (parse forms r w s m esew mod)))) - ((memv key '(eval-when-form)) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any)))) - (if tmp - (apply (lambda (x e1 e2) - (let ((when-list (parse-when-list e x)) (body (cons e1 e2))) - (letrec* - ((recurse (lambda (m esew) (parse body r w s m esew mod)))) - (cond ((eq? m 'e) - (if (memq 'eval when-list) - (recurse (if (memq 'expand when-list) 'c&e 'e) '(eval)) - (begin - (if (memq 'expand when-list) - (top-level-eval-hook - (expand-top-sequence body r w s 'e '(eval) mod) - mod)) - '()))) - ((memq 'load when-list) - (cond ((or (memq 'compile when-list) - (memq 'expand when-list) - (and (eq? m 'c&e) (memq 'eval when-list))) - (recurse 'c&e '(compile load))) - ((memq m '(c c&e)) (recurse 'c '(load))) - (else '()))) - ((or (memq 'compile when-list) - (memq 'expand when-list) - (and (eq? m 'c&e) (memq 'eval when-list))) - (top-level-eval-hook - (expand-top-sequence body r w s 'e '(eval) mod) - mod) - '()) - (else '()))))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))) - (else - (list (if (eq? m 'c&e) - (let ((x (expand-expr type value form e r w s mod))) - (top-level-eval-hook x mod) - (lambda () x)) - (lambda () (expand-expr type value form e r w s mod)))))))))))) + (lambda () (expand-expr type value form e r w s mod))))))))))))) (let ((exps (map (lambda (x) (x)) (reverse (parse body r w s m esew mod))))) (if (null? exps) (build-void s) (build-sequence s exps))))))) (expand-install-global diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index e68b4ca7d..88df4c753 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -1087,9 +1087,18 @@ (append (parse1 (car body) r w s m esew mod) exps))))) (define (parse1 x r w s m esew mod) + (define (current-module-for-expansion mod) + (case (car mod) + ;; If the module was just put in place for hygiene, in a + ;; top-level `begin' always recapture the current + ;; module. If a user wants to override, then we need to + ;; use @@ or similar. + ((hygiene) (cons 'hygiene (module-name (current-module)))) + (else mod))) (call-with-values (lambda () - (syntax-type x r w (source-annotation x) ribcage mod #f)) + (let ((mod (current-module-for-expansion mod))) + (syntax-type x r w (source-annotation x) ribcage mod #f))) (lambda (type value form e w s mod) (case type ((define-form) From 516f70f9e93b2369eb3778d4800fa3bcb4033e14 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Tue, 28 Jun 2016 15:16:13 +0200 Subject: [PATCH 442/865] tests-suite: resurrect invoking check-guile --coverage. * test-suite/guile-test (main): remove (the-vm) from with-code-coverage call. --- test-suite/guile-test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/guile-test b/test-suite/guile-test index 4a264b426..da1bcda25 100755 --- a/test-suite/guile-test +++ b/test-suite/guile-test @@ -246,7 +246,7 @@ tests)))) (if (opt 'coverage #f) (let-values (((coverage-data _) - (with-code-coverage (the-vm) run-tests))) + (with-code-coverage run-tests))) (let ((out (open-output-file "guile.info"))) (coverage-data->lcov coverage-data out) (close out))) From 85faf8eccb836586b869c359413eadd4caaff883 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 29 Jun 2016 13:55:49 +0200 Subject: [PATCH 443/865] Update NEWS * NEWS: Add 2.0.12 NEWS. Fold 2.1.3 NEWS into main 2.2.0 NEWS. --- NEWS | 484 +++++++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 318 insertions(+), 166 deletions(-) diff --git a/NEWS b/NEWS index 4915b94f5..e1e924d23 100644 --- a/NEWS +++ b/NEWS @@ -8,154 +8,46 @@ Please send Guile bug reports to bug-guile@gnu.org. Changes in 2.1.4 (changes since the 2.1.3 alpha release): +* Notable changes +* New interfaces + +** Implement R6RS output-buffer-mode +** Implement R6RS bytevector->string, string->bytevector + +* New deprecations +* Incompatible changes +** Statically scoped module duplicate handlers + +It used to be that if a module did not specify a #:duplicates handler, +when a name was first referenced in that module and multiple imported +modules provide that name, the value of the +`default-duplicate-binding-handlers' parameter would be used to resolve +the duplicate bindings. We have changed so that instead a module +defaults to the set of handlers described in the manual. If the module +specifies #:duplicates, of course we use that. The +`default-duplicate-binding-handlers' parameter now simply accesses the +handlers of the current module, instead of some global value. + * Bug fixes -** Don't replace + with space when splitting and decoding URI paths ** Fix bug importing specific bindings with #:select It used to be that if #:select didn't find a binding in the public interface of a module, it would actually grovel in the module's unexported private bindings. This was not intended and is now fixed. - -[TODO: Fold into generic 2.2 release notes.] -Changes in 2.1.3 (changes since the 2.1.2 alpha release): +** Fix fixnum-range checks in R6RS fixnum bitops + (http://bugs.gnu.org/14917) -* Notable changes -** Complete overhaul of port internals +** Fix `monitor' macro -Guile's ports have been completely overhauled to allow Guile developers -and eventually Guile users to write low-level input and output routines -in Scheme. The new internals will eventually allow for user-space -tasklets or green threads that suspend to a scheduler when they would -cause blocking I/O, allowing users to write straightforward network -services that parse their input and send their output as if it were -blocking, while under the hood Guile can multiplex many active -connections at once. +** Fix bug with GUILE_INSTALL_LOCALE=1 and default port encodings -At the same time, this change makes Guile's ports implementation much -more maintainable, rationalizing the many legacy port internals and -making sure that the abstractions between the user, Guile's core ports -facility, and the port implementations result in a system that is as -performant and expressive as possible. - -The interface to the user has no significant change, neither on the C -side nor on the Scheme side. However this refactoring has changed the -interface to the port implementor in an incompatible way. See -"Incompatible changes" below for full details. - -** All ports are now buffered, can be targets of `setvbuf' - -See "Buffering" in the manual, for more. A port with a buffer size of 1 -is equivalent to an unbuffered port. Ports may set their default buffer -sizes, and some ports (for example soft ports) are unbuffered by default -for historical reasons. - -** Support for non-blocking I/O - -See "Non-Blocking I/O" in the manual, for more. - -** Removal of port locks - -As part of the 2.2 series, we introduced recursive locks on each port, -and arranged to lock them to avoid crashes but also to serialize I/O in -some ways. This turned out to be a mistake: the port lock does not -necessarily correspond to a program's desired atomic unit of I/O, so -correct programs would likely have to have their own locking. At the -same time the port buffering refactoring made it possible for us to -avoid the crashes that led to the introduction of locking, but without -locks. For that reason we have removed port locks, and removed the -"_unlocked" port API variants that were introduced in 2.1.0. - -* New interfaces -** `TCP_NODELAY' and `TCP_CORK' socket options, if provided by the system - -** `scm_c_put_latin1_chars', `scm_c_put_utf32_chars' - -Use these instead of `scm_lfwrite'. See the new "Using Ports from C" -section of the manual, for more. - -* New deprecations -** `_IONBF', `_IOLBF', and `_IOFBF' - -Instead, use the symbol values `none', `line', or `block', respectively, -as arguments to the `setvbuf' function. - -* Incompatible changes - -** Decoding errors do not advance the read pointer before erroring - -When the user sets a port's conversion strategy to "error", indicating -that Guile should throw an error if it tries to read from a port whose -incoming bytes are not valid for the port's encoding, it used to be that -Guile would advance the read pointer past the bad bytes, and then throw -an error. This would allow the following `read-char' invocation to -proceed after the bad bytes. This behavior is incompatible with the -final R6RS standard, and besides contravenes the user's intention to -raise an error on bad input. Guile now raises an error without -advancing the read pointer. To skip over a bad encoding, set the port -conversion strategy to "substitute" and read a substitute character. - -** Decoding errors with `substitute' strategy return U+FFFD - -It used to be that decoding errors with the `substitute' conversion -strategy would replace the bad bytes with a `?' character. This has -been changed to use the standard U+FFFD REPLACEMENT CHARACTER, in -accordance with the Unicode recommendations. - -** API to define new port types from C has changed - -See the newly expanded "I/O Extensions" in the manual, for full details. -Notably: - -*** Remove `scm_set_port_mark' - -Port mark functions have not been called since the switch to the BDW -garbage collector. - -*** Remove `scm_set_port_equalp' - -Likewise port equal functions weren't being called. Given that ports -have their own internal buffers, it doesn't make sense to hook them into -equal? anyway. - -*** Remove `scm_set_port_free' - -It used to be that if an open port became unreachable, a special "free" -function would be called instead of the "close" function. Now that the -BDW-GC collector allows us to run arbitrary code in finalizers, we can -simplify to just call "close" on the port and remove the separate free -functions. Note that hooking into the garbage collector has some -overhead. For that reason Guile exposes a new interface, -`scm_set_port_needs_close_on_gc', allowing port implementations to -indicate to Guile whether they need closing on GC or not. - -*** Remove `scm_set_port_end_input', `scm_set_port_flush' - -As buffering is handled by Guile itself, these functions which were to -manage an implementation-side buffer are no longer needed. - -*** Change prototype of `scm_make_port_type' - -The `read' (renamed from `fill_input') and `write' functions now operate -on bytevectors. Also the `mode_bits' argument now inplicitly includes -SCM_OPN, so you don't need to include these. - -*** Change prototype of port `close' function - -The port close function now returns void. - -*** Port and port type data structures are now opaque - -Port type implementations should now use API to access port state. -However, since the change to handle port buffering centrally, port type -implementations rarely need to access unrelated port state. - -*** Port types are now `scm_t_port_type*', not a tc16 value - -`scm_make_port_type' now returns an opaque pointer, not a tc16. -Relatedly, the limitation that there only be 256 port types has been -lifted. +If GUILE_INSTALL_LOCALE is unset in the environment or set to 1, Guile +will call setlocale() to install the locale. However it was neglecting +to set the default port encoding to the locale's encoding. This is +fixed. +** Various compiler bug fixes Previous changes in 2.1.x (changes since the 2.0.x series): @@ -173,9 +65,7 @@ better memory usage, and faster execution of user code. See the This new release series takes the ABI-break opportunity to fix some interfaces that were difficult to use correctly from multiple threads. -Notably, weak hash tables are now transparently thread-safe. Ports are -also thread-safe; see "New interfaces" below for details on the changes -to the C interface. +Notably, weak hash tables and ports are now transparently thread-safe. ** Better space-safety @@ -330,6 +220,13 @@ Thanks to work by Daniel Llorens, the generic array facility is much faster now, as it is internally better able to dispatch on the type of the underlying backing store. +** All ports are now buffered, can be targets of `setvbuf' + +See "Buffering" in the manual, for more. A port with a buffer size of 1 +is equivalent to an unbuffered port. Ports may set their default buffer +sizes, and some ports (for example soft ports) are unbuffered by default +for historical reasons. + * New interfaces ** New `cond-expand' feature: `guile-2.2' @@ -355,24 +252,9 @@ See "Integers" in the manual, for more. See the newly updated "Statprof" section of the manual, for more. -** New thread-safe port API +** Support for non-blocking I/O -For details on `scm_c_make_port', `scm_c_make_port_with_encoding', -`scm_c_lock_port', `scm_c_try_lock_port', `scm_c_unlock_port', -`scm_c_port_type_ref', `scm_c_port_type_add_x', `SCM_PORT_DESCRIPTOR', -and `scm_dynwind_lock_port', see XXX. - -There is now a routine to atomically adjust port "revealed counts". See -XXX for more on `scm_adjust_port_revealed_x' and -`adjust-port-revealed!', - -All other port API now takes the lock on the port if needed. There are -some C interfaces if you know that you don't need to take a lock; see -XXX for details on `scm_get_byte_or_eof_unlocked', -`scm_peek_byte_or_eof_unlocked' `scm_c_read_unlocked', -`scm_getc_unlocked' `scm_unget_byte_unlocked', `scm_ungetc_unlocked', -`scm_ungets_unlocked', `scm_fill_input_unlocked' `scm_putc_unlocked', -`scm_puts_unlocked', and `scm_lfwrite_unlocked'. +See "Non-Blocking I/O" in the manual, for more. ** New inline functions: `scm_new_smob', `scm_new_double_smob' @@ -389,6 +271,13 @@ For more on `SCM_HAS_TYP7', `SCM_HAS_TYP7S', `SCM_HAS_TYP16', see XXX. the old `SCM2PTR' and `PTR2SCM'. Also, `SCM_UNPACK_POINTER' yields a void*. +** `TCP_NODELAY' and `TCP_CORK' socket options, if provided by the system + +** `scm_c_put_latin1_chars', `scm_c_put_utf32_chars' + +Use these instead of `scm_lfwrite'. See the new "Using Ports from C" +section of the manual, for more. + ** , standard-vtable-fields See "Structures" in the manual for more on these @@ -429,6 +318,97 @@ ASCII as ISO-8859-1. This is likely to be a problem only if the user's locale is set to ASCII, and the user or a program writes non-ASCII codepoints to a port. +** Decoding errors do not advance the read pointer before erroring + +When the user sets a port's conversion strategy to "error", indicating +that Guile should throw an error if it tries to read from a port whose +incoming bytes are not valid for the port's encoding, it used to be that +Guile would advance the read pointer past the bad bytes, and then throw +an error. This would allow the following `read-char' invocation to +proceed after the bad bytes. This behavior is incompatible with the +final R6RS standard, and besides contravenes the user's intention to +raise an error on bad input. Guile now raises an error without +advancing the read pointer. To skip over a bad encoding, set the port +conversion strategy to "substitute" and read a substitute character. + +** Decoding errors with `substitute' strategy return U+FFFD + +It used to be that decoding errors with the `substitute' conversion +strategy would replace the bad bytes with a `?' character. This has +been changed to use the standard U+FFFD REPLACEMENT CHARACTER, in +accordance with the Unicode recommendations. + +** API to define new port types from C has changed + +Guile's ports have been completely overhauled to allow Guile developers +and eventually Guile users to write low-level input and output routines +in Scheme. The new internals will eventually allow for user-space +tasklets or green threads that suspend to a scheduler when they would +cause blocking I/O, allowing users to write straightforward network +services that parse their input and send their output as if it were +blocking, while under the hood Guile can multiplex many active +connections at once. + +At the same time, this change makes Guile's ports implementation much +more maintainable, rationalizing the many legacy port internals and +making sure that the abstractions between the user, Guile's core ports +facility, and the port implementations result in a system that is as +performant and expressive as possible. + +The interface to the user has no significant change, neither on the C +side nor on the Scheme side. However this refactoring has changed the +interface to the port implementor in an incompatible way. See the newly +expanded "I/O Extensions" in the manual, for full details. + +*** Remove `scm_set_port_mark' + +Port mark functions have not been called since the switch to the BDW +garbage collector. + +*** Remove `scm_set_port_equalp' + +Likewise port equal functions weren't being called. Given that ports +have their own internal buffers, it doesn't make sense to hook them into +equal? anyway. + +*** Remove `scm_set_port_free' + +It used to be that if an open port became unreachable, a special "free" +function would be called instead of the "close" function. Now that the +BDW-GC collector allows us to run arbitrary code in finalizers, we can +simplify to just call "close" on the port and remove the separate free +functions. Note that hooking into the garbage collector has some +overhead. For that reason Guile exposes a new interface, +`scm_set_port_needs_close_on_gc', allowing port implementations to +indicate to Guile whether they need closing on GC or not. + +*** Remove `scm_set_port_end_input', `scm_set_port_flush' + +As buffering is handled by Guile itself, these functions which were to +manage an implementation-side buffer are no longer needed. + +*** Change prototype of `scm_make_port_type' + +The `read' (renamed from `fill_input') and `write' functions now operate +on bytevectors. Also the `mode_bits' argument now inplicitly includes +SCM_OPN, so you don't need to include these. + +*** Change prototype of port `close' function + +The port close function now returns void. + +*** Port and port type data structures are now opaque + +Port type implementations should now use API to access port state. +However, since the change to handle port buffering centrally, port type +implementations rarely need to access unrelated port state. + +*** Port types are now `scm_t_port_type*', not a tc16 value + +`scm_make_port_type' now returns an opaque pointer, not a tc16. +Relatedly, the limitation that there only be 256 port types has been +lifted. + ** String ports default to UTF-8 Guile 2.0 would use the `%default-port-encoding' when creating string @@ -669,6 +649,11 @@ scm_t_debug_info', `scm_pure_generic_p', `SCM_PUREGENERICP', * New deprecations +** `_IONBF', `_IOLBF', and `_IOFBF' + +Instead, use the symbol values `none', `line', or `block', respectively, +as arguments to the `setvbuf' function. + ** `with-statprof' macro deprecated Use the `statprof' procedure instead. @@ -761,22 +746,189 @@ users, but packagers may be interested. Changes in 2.0.12 (since 2.0.11): -[Note: these changes come to 2.2 via 2.0 branch, but 2.0.12 hasn't been -released yet at the time of this writing.] - * Notable changes +** FFI: Add support for functions that set 'errno' + +When accessing POSIX functions from a system's libc via Guile's dynamic +FFI, you commonly want to access the 'errno' variable to be able to +produce useful diagnostic messages. + +This is now possible using 'pointer->procedure' or +'scm_pointer_to_procedure_with_errno'. See "Dynamic FFI" in the manual. + ** The #!r6rs directive now influences read syntax The #!r6rs directive now changes the per-port reader options to make -Guile's reader conform more closely to the R6RS syntax. In particular: +Guile's reader conform more closely to the R6RS syntax. In particular: -- It makes the reader case sensitive. -- It disables the recognition of keyword syntax in conflict with the - R6RS (and R5RS). -- It enables the `square-brackets', `hungry-eol-escapes' and - `r6rs-hex-escapes' reader options. + - It makes the reader case sensitive. + - It disables the recognition of keyword syntax in conflict with the + R6RS (and R5RS). + - It enables the `square-brackets', `hungry-eol-escapes' and + `r6rs-hex-escapes' reader options. +** 'read' now accepts "\(" as equivalent to "(" + +This is indented for use at the beginning of lines in multi-line strings +to avoid confusing Emacs' lisp modes. Previously "\(" was an error. + +** SRFI-14 character data set upgraded to Unicode 8.0.0 + +** SRFI-19 table of leap seconds updated + +** 'string-hash', 'read-string', and 'write' have been optimized + +** GOOPS bug fix for inherited accessor methods + +In the port of GOOPS to Guile 2.0, we introduced a bug related to +accessor methods. The bug resulted in GOOPS assuming that a slot S in +an object whose class is C would always be present in instances of all +subclasses C, and allocated to the same struct index. This is not the +case for multiple inheritance. This behavior has been fixed to be as it +was in 1.8. + +One aspect of this change may cause confusion among users. Previously +if you defined a class C: + + (use-modules (oop goops)) + (define-class C () + (a #:getter get-a)) + +And now you define a subclass, intending to provide an #:init-value for +the slot A: + + (define-class D () + (a #:init-value 42)) + +Really what you have done is define in D a new slot with the same name, +overriding the existing slot. The problem comes in that before fixing +this bug (but not in 1.8), the getter 'get-a' would succeed for +instances of D, even though 'get-a' should only work for the slot 'a' +that is defined on class C, not any other slot that happens to have the +same name and be in a class with C as a superclass. + +It would be possible to "merge" the slot definitions on C and D, but +that part of the meta-object protocol (`compute-slots' et al) is not +fully implemented. + +Somewhat relatedly, GOOPS also had a fix around #:init-value on +class-allocated slots. GOOPS was re-initializing the value of slots +with #:class or #:each-subclass allocation every time instances of that +class was allocated. This has been fixed. + +* New interfaces + +** New SRFI-28 string formatting implementation + +See "SRFI-28" in the manual. + +** New (ice-9 unicode) module + +See "Characters" in the manual. + +** Web server + +The (web server) module now exports 'make-server-impl', 'server-impl?', +and related procedures. Likewise, (web server http) exports 'http'. + +** New procedures: 'string-utf8-length' and 'scm_c_string_utf8_length' + +See "Bytevectors as Strings" in the manual, for more. + +** New 'EXIT_SUCCESS' and 'EXIT_FAILURE' Scheme variables + +See "Processes" in the manual. + +** New C functions to disable automatic SMOB finalization + +The new 'scm_set_automatic_finalization_enabled' C function allows you +to choose whether automatic object finalization should be enabled (as +was the case until now, and still is by default.) This is meant for +applications that are not thread-safe nor async-safe; such applications +can disable automatic finalization and call the new 'scm_run_finalizers' +function when appropriate. + +See the "Garbage Collecting Smobs" and "Smobs" sections in the manual. + +** Cross-compilation to ARM + +More ARM cross-compilation targets are supported: "arm.*eb", +"^aarch64.*be", and "aarch64". + +* New deprecation + +** The undocumented and unused C function 'scm_string_hash' is now deprecated + +* Bugs fixed + +** Compiler +*** 'call-with-prompt' does not truncate multiple-value returns + () +*** Use permissions of source file for compiled file + () +*** Fix bug when inlining some functions with optional arguments + () +*** Avoid quadratic expansion time in 'and' and 'or' macros + () +*** Fix expander bug introduced when adding support for tail patterns + () +*** Handle ~p in 'format' warnings () +*** Fix bug that exposed `list' invocations to CSE + () +*** Reduce eq? and eqv? over constants using equal? + () + +** Threads +*** Fix data races leading to corruption () + +** Memory management +*** Fix race between SMOB marking and finalization + () + +** Ports +*** Fix port position handling on binary input ports + () +*** Bytevector and custom binary ports to use ISO-8859-1 + () +*** Fix buffer overrun with unbuffered custom binary input ports + () +*** Fix memory corruption that arose when using 'get-bytevector-n' + () + +** System +*** {get,set}sockopt now expect type 'int' for SO_SNDBUF/SO_RCVBUF +*** 'system*' now available on MS-Windows +*** Better support for file names containing backslashes on Windows + +** Web +*** 'split-and-decode-uri-path' no longer decodes "+" to space +*** HTTP: Support date strings with a leading space for hours + () +*** HTTP: Accept empty reason phrases () +*** HTTP: 'Location' header can now contain URI references, not just + absolute URIs +*** HTTP: Improve chunked-mode support () +*** HTTP: 'open-socket-for-uri' now sets better OS buffering parameters + () + +** Miscellaneous +*** Fix 'atan' procedure when applied to complex numbers +*** Fix Texinfo to HTML conversion for @itemize and @acronym + () +*** 'bytevector-fill!' accepts fill arguments greater than 127 + () +*** 'bytevector-copy' correctly copies SRFI-4 homogeneous vectors + () +*** 'strerror' no longer hangs when passed a non-integer argument + () +*** 'scm_boot_guile' now gracefully handles argc == 0 + () +*** Fix 'SCM_SMOB_OBJECT_LOC' definition () +*** Fix bug where 'bit-count*' was not using its second argument +*** SRFI-1 'length+' raises an error for non-lists and dotted lists + () +*** Add documentation for SXPath () Changes in 2.0.11 (since 2.0.10): From 0d191d13948c722dfe13cceca34a07df63669d6d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 7 Jul 2016 14:02:25 +0200 Subject: [PATCH 444/865] Update git-version-gen.diff for current gnulib * gnulib-local/build-aux/git-version-gen.diff: Update. --- gnulib-local/build-aux/git-version-gen.diff | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/gnulib-local/build-aux/git-version-gen.diff b/gnulib-local/build-aux/git-version-gen.diff index f875f49d9..8451701d5 100644 --- a/gnulib-local/build-aux/git-version-gen.diff +++ b/gnulib-local/build-aux/git-version-gen.diff @@ -2,17 +2,19 @@ This patch is being discussed at . Remove when integrated in Gnulib. +diff --git a/build-aux/git-version-gen b/build-aux/git-version-gen +index bd2c4b6..4458d7d 100755 --- a/build-aux/git-version-gen +++ b/build-aux/git-version-gen @@ -86,6 +86,7 @@ Print a version string. Options: - --prefix prefix of git tags (default 'v') + --prefix PREFIX prefix of git tags (default 'v') + --match pattern for git tags to match (default: '\$prefix*') - --fallback fallback version to use if \"git --version\" fails + --fallback VERSION + fallback version to use if \"git --version\" fails - --help display this help and exit -@@ -96,11 +97,15 @@ Running without arguments will suffice in most cases." +@@ -97,11 +98,15 @@ Running without arguments will suffice in most cases." prefix=v fallback= @@ -23,12 +25,12 @@ Remove when integrated in Gnulib. case $1 in --help) echo "$usage"; exit 0;; --version) echo "$version"; exit 0;; - --prefix) shift; prefix="$1";; + --prefix) shift; prefix=${1?};; + --match) shift; match="$1";; - --fallback) shift; fallback="$1";; + --fallback) shift; fallback=${1?};; -*) echo "$0: Unknown option '$1'." >&2 -@@ -124,6 +129,7 @@ if test "x$tarball_version_file" = x; then +@@ -125,6 +130,7 @@ if test "x$tarball_version_file" = x; then exit 1 fi @@ -36,7 +38,7 @@ Remove when integrated in Gnulib. tag_sed_script="${tag_sed_script:-s/x/x/}" nl=' -@@ -154,7 +160,7 @@ then +@@ -155,7 +161,7 @@ then # directory, and "git describe" output looks sensible, use that to # derive a version string. elif test "`git log -1 --pretty=format:x . 2>&1`" = x \ From d484bfbacec75941ba643ddc600e995f2c160928 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 7 Jul 2016 14:05:53 +0200 Subject: [PATCH 445/865] Update Gnulib to 68b6ade. Also add --conditional-dependencies to the flags. See: https://lists.gnu.org/archive/html/guile-devel/2016-07/msg00012.html --- GNUmakefile | 2 +- build-aux/announce-gen | 28 +- build-aux/config.rpath | 18 +- build-aux/gendocs.sh | 139 ++-- build-aux/git-version-gen | 17 +- build-aux/gitlog-to-changelog | 185 +++-- build-aux/gnu-web-doc-update | 34 +- build-aux/gnupload | 6 +- build-aux/snippet/arg-nonnull.h | 2 +- build-aux/snippet/c++defs.h | 2 +- build-aux/snippet/unused-parameter.h | 2 +- build-aux/snippet/warn-on-use.h | 2 +- build-aux/useless-if-before-free | 8 +- build-aux/vc-list-files | 6 +- doc/gendocs_template | 20 +- doc/gendocs_template_min | 93 +++ lib/Makefile.am | 178 ++++- lib/accept.c | 2 +- lib/alignof.h | 2 +- lib/alloca.in.h | 2 +- lib/arpa_inet.in.h | 2 +- lib/asnprintf.c | 2 +- lib/assure.h | 37 + lib/basename-lgpl.c | 2 +- lib/binary-io.c | 1 + lib/binary-io.h | 4 +- lib/bind.c | 2 +- lib/btowc.c | 2 +- lib/byteswap.in.h | 2 +- lib/c-ctype.c | 394 +--------- lib/c-ctype.h | 453 +++++++----- lib/c-strcase.h | 2 +- lib/c-strcasecmp.c | 2 +- lib/c-strcaseeq.h | 5 +- lib/c-strncasecmp.c | 2 +- lib/canonicalize-lgpl.c | 2 +- lib/ceil.c | 2 +- lib/close.c | 2 +- lib/config.charset | 6 +- lib/connect.c | 2 +- lib/copysign.c | 2 +- lib/dirent.in.h | 11 +- lib/dirfd.c | 68 +- lib/dirname-lgpl.c | 2 +- lib/dirname.h | 10 +- lib/dosname.h | 2 +- lib/dup2.c | 53 +- lib/duplocale.c | 2 +- lib/errno.in.h | 2 +- lib/fcntl.in.h | 22 +- lib/fd-hook.c | 2 +- lib/fd-hook.h | 2 +- lib/float+.h | 2 +- lib/float.c | 2 +- lib/float.in.h | 2 +- lib/flock.c | 2 +- lib/floor.c | 2 +- lib/frexp.c | 2 +- lib/fstat.c | 2 +- lib/fsync.c | 2 +- lib/full-read.c | 2 +- lib/full-read.h | 3 +- lib/full-write.c | 2 +- lib/full-write.h | 2 +- lib/gai_strerror.c | 2 +- lib/getaddrinfo.c | 2 +- lib/getlogin.c | 2 +- lib/getpeername.c | 2 +- lib/getsockname.c | 2 +- lib/getsockopt.c | 2 +- lib/gettext.h | 10 +- lib/gettimeofday.c | 2 +- lib/hard-locale.c | 72 ++ lib/hard-locale.h | 25 + lib/iconv.c | 2 +- lib/iconv.in.h | 2 +- lib/iconv_close.c | 2 +- lib/iconv_open.c | 2 +- lib/iconveh.h | 2 +- lib/inet_ntop.c | 4 +- lib/inet_pton.c | 2 +- lib/intprops.h | 445 +++++++++++ lib/isfinite.c | 2 +- lib/isinf.c | 2 +- lib/isnan.c | 2 +- lib/isnand-nolibm.h | 2 +- lib/isnand.c | 2 +- lib/isnanf-nolibm.h | 2 +- lib/isnanf.c | 2 +- lib/isnanl-nolibm.h | 2 +- lib/isnanl.c | 2 +- lib/itold.c | 2 +- lib/langinfo.in.h | 20 +- lib/link.c | 2 +- lib/listen.c | 2 +- lib/localcharset.c | 81 +- lib/localcharset.h | 2 +- lib/locale.in.h | 2 +- lib/localeconv.c | 2 +- lib/log.c | 2 +- lib/log1p.c | 2 +- lib/lstat.c | 2 +- lib/malloc.c | 2 +- lib/malloca.c | 2 +- lib/malloca.h | 2 +- lib/math.c | 1 + lib/math.in.h | 5 +- lib/mbrtowc.c | 65 +- lib/mbsinit.c | 2 +- lib/mbtowc-impl.h | 2 +- lib/mbtowc.c | 2 +- lib/memchr.c | 2 +- lib/mkdir.c | 2 +- lib/mkstemp.c | 2 +- lib/mktime-internal.h | 37 + lib/mktime.c | 630 ++++++++++++++++ lib/msvc-inval.c | 2 +- lib/msvc-inval.h | 2 +- lib/msvc-nothrow.c | 2 +- lib/msvc-nothrow.h | 2 +- lib/netdb.in.h | 2 +- lib/netinet_in.in.h | 2 +- lib/nl_langinfo.c | 255 ++++--- lib/nproc.c | 2 +- lib/nproc.h | 2 +- lib/open.c | 2 +- lib/pathmax.h | 2 +- lib/pipe.c | 2 +- lib/pipe2.c | 2 +- lib/poll.c | 83 +-- lib/poll.in.h | 2 +- lib/printf-args.c | 2 +- lib/printf-args.h | 2 +- lib/printf-parse.c | 2 +- lib/printf-parse.h | 2 +- lib/putenv.c | 2 +- lib/raise.c | 2 +- lib/read.c | 2 +- lib/readlink.c | 2 +- lib/recv.c | 2 +- lib/recvfrom.c | 2 +- lib/ref-add.sin | 2 +- lib/ref-del.sin | 2 +- lib/regcomp.c | 201 ++--- lib/regex.c | 2 +- lib/regex.h | 54 +- lib/regex_internal.c | 74 +- lib/regex_internal.h | 70 +- lib/regexec.c | 179 ++--- lib/rename.c | 8 +- lib/rmdir.c | 2 +- lib/round.c | 2 +- lib/safe-read.c | 2 +- lib/safe-read.h | 2 +- lib/safe-write.c | 2 +- lib/safe-write.h | 2 +- lib/same-inode.h | 2 +- lib/secure_getenv.c | 31 +- lib/select.c | 38 +- lib/send.c | 2 +- lib/sendto.c | 2 +- lib/setenv.c | 2 +- lib/setsockopt.c | 2 +- lib/shutdown.c | 2 +- lib/signal.in.h | 10 +- lib/signbitd.c | 2 +- lib/signbitf.c | 2 +- lib/signbitl.c | 2 +- lib/size_max.h | 2 +- lib/snprintf.c | 2 +- lib/socket.c | 2 +- lib/sockets.c | 9 +- lib/sockets.h | 12 +- lib/stat-time.h | 18 +- lib/stat.c | 2 +- lib/stdalign.in.h | 23 +- lib/stdbool.in.h | 2 +- lib/stddef.in.h | 56 +- lib/stdint.in.h | 19 +- lib/stdio.in.h | 12 +- lib/stdlib.in.h | 25 +- lib/strdup.c | 2 +- lib/streq.h | 2 +- lib/strftime.c | 124 ++-- lib/strftime.h | 9 +- lib/striconveh.c | 2 +- lib/striconveh.h | 2 +- lib/string.in.h | 23 +- lib/stripslash.c | 2 +- lib/sys_file.in.h | 2 +- lib/sys_select.in.h | 36 +- lib/sys_socket.c | 1 + lib/sys_socket.in.h | 2 +- lib/sys_stat.in.h | 2 +- lib/sys_time.in.h | 2 +- lib/sys_times.in.h | 2 +- lib/sys_types.in.h | 4 +- lib/sys_uio.in.h | 2 +- lib/tempname.c | 120 +-- lib/tempname.h | 17 +- lib/time-internal.h | 49 ++ lib/time.in.h | 31 +- lib/time_r.c | 2 +- lib/time_rz.c | 321 ++++++++ lib/timegm.c | 40 + lib/times.c | 4 +- lib/trunc.c | 2 +- lib/unistd.c | 1 + lib/unistd.in.h | 39 +- lib/unistr.in.h | 2 +- lib/unistr/u8-mbtouc-aux.c | 2 +- lib/unistr/u8-mbtouc-unsafe-aux.c | 2 +- lib/unistr/u8-mbtouc-unsafe.c | 2 +- lib/unistr/u8-mbtouc.c | 2 +- lib/unistr/u8-mbtoucr.c | 2 +- lib/unistr/u8-prev.c | 2 +- lib/unistr/u8-uctomb-aux.c | 2 +- lib/unistr/u8-uctomb.c | 2 +- lib/unitypes.in.h | 2 +- lib/unsetenv.c | 127 ++++ lib/vasnprintf.c | 201 +++-- lib/vasnprintf.h | 2 +- lib/verify.h | 4 +- lib/vsnprintf.c | 2 +- lib/w32sock.h | 2 +- lib/wchar.in.h | 16 +- lib/wcrtomb.c | 2 +- lib/wctype.in.h | 2 +- lib/write.c | 2 +- lib/xsize.h | 2 +- m4/00gnulib.m4 | 2 +- m4/absolute-header.m4 | 2 +- m4/alloca.m4 | 2 +- m4/arpa_inet_h.m4 | 2 +- m4/autobuild.m4 | 2 +- m4/btowc.m4 | 2 +- m4/byteswap.m4 | 2 +- m4/canonicalize.m4 | 11 +- m4/ceil.m4 | 2 +- m4/check-math-lib.m4 | 2 +- m4/clock_time.m4 | 2 +- m4/close.m4 | 2 +- m4/codeset.m4 | 3 +- m4/configmake.m4 | 2 +- m4/copysign.m4 | 2 +- m4/dirent_h.m4 | 2 +- m4/dirfd.m4 | 18 +- m4/dirname.m4 | 2 +- m4/double-slash-root.m4 | 2 +- m4/dup2.m4 | 96 ++- m4/duplocale.m4 | 8 +- m4/eealloc.m4 | 2 +- m4/environ.m4 | 2 +- m4/errno_h.m4 | 2 +- m4/exponentd.m4 | 2 +- m4/exponentf.m4 | 2 +- m4/exponentl.m4 | 2 +- m4/extensions.m4 | 7 +- m4/extern-inline.m4 | 46 +- m4/fcntl-o.m4 | 2 +- m4/fcntl_h.m4 | 2 +- m4/flexmember.m4 | 41 ++ m4/float_h.m4 | 2 +- m4/flock.m4 | 2 +- m4/floor.m4 | 2 +- m4/fpieee.m4 | 4 +- m4/frexp.m4 | 2 +- m4/fstat.m4 | 2 +- m4/fsync.m4 | 2 +- m4/func.m4 | 2 +- m4/getaddrinfo.m4 | 2 +- m4/getlogin.m4 | 2 +- m4/gettimeofday.m4 | 2 +- m4/glibc21.m4 | 2 +- m4/gnulib-cache.m4 | 8 +- m4/gnulib-common.m4 | 105 ++- m4/gnulib-comp.m4 | 1015 ++++++++++++++++++++++---- m4/gnulib-tool.m4 | 2 +- m4/hard-locale.m4 | 11 + m4/hostent.m4 | 2 +- m4/iconv.m4 | 63 +- m4/iconv_h.m4 | 2 +- m4/iconv_open-utf.m4 | 2 +- m4/iconv_open.m4 | 2 +- m4/include_next.m4 | 2 +- m4/inet_ntop.m4 | 2 +- m4/inet_pton.m4 | 2 +- m4/inline.m4 | 2 +- m4/intmax_t.m4 | 2 +- m4/inttypes_h.m4 | 2 +- m4/isfinite.m4 | 40 +- m4/isinf.m4 | 43 +- m4/isnan.m4 | 2 +- m4/isnand.m4 | 2 +- m4/isnanf.m4 | 2 +- m4/isnanl.m4 | 43 +- m4/langinfo_h.m4 | 2 +- m4/largefile.m4 | 2 +- m4/ld-version-script.m4 | 47 +- m4/ldexp.m4 | 2 +- m4/lib-ld.m4 | 2 +- m4/lib-link.m4 | 2 +- m4/lib-prefix.m4 | 2 +- m4/libunistring-base.m4 | 2 +- m4/libunistring.m4 | 2 +- m4/link.m4 | 2 +- m4/localcharset.m4 | 2 +- m4/locale-fr.m4 | 2 +- m4/locale-ja.m4 | 2 +- m4/locale-zh.m4 | 2 +- m4/locale_h.m4 | 2 +- m4/localeconv.m4 | 2 +- m4/log.m4 | 2 +- m4/log1p.m4 | 2 +- m4/longlong.m4 | 2 +- m4/lstat.m4 | 50 +- m4/malloc.m4 | 13 +- m4/malloca.m4 | 2 +- m4/math_h.m4 | 2 +- m4/mathfunc.m4 | 2 +- m4/mbrtowc.m4 | 96 ++- m4/mbsinit.m4 | 2 +- m4/mbstate_t.m4 | 2 +- m4/mbtowc.m4 | 2 +- m4/memchr.m4 | 2 +- m4/mkdir.m4 | 2 +- m4/mkstemp.m4 | 2 +- m4/mktime.m4 | 268 +++++++ m4/mmap-anon.m4 | 2 +- m4/mode_t.m4 | 2 +- m4/msvc-inval.m4 | 2 +- m4/msvc-nothrow.m4 | 2 +- m4/multiarch.m4 | 2 +- m4/netdb_h.m4 | 2 +- m4/netinet_in_h.m4 | 2 +- m4/nl_langinfo.m4 | 2 +- m4/nocrash.m4 | 5 +- m4/nproc.m4 | 2 +- m4/off_t.m4 | 2 +- m4/open.m4 | 2 +- m4/pathmax.m4 | 2 +- m4/pipe.m4 | 2 +- m4/pipe2.m4 | 2 +- m4/poll.m4 | 2 +- m4/poll_h.m4 | 2 +- m4/printf.m4 | 67 +- m4/putenv.m4 | 2 +- m4/raise.m4 | 2 +- m4/read.m4 | 2 +- m4/readlink.m4 | 2 +- m4/regex.m4 | 6 +- m4/rename.m4 | 2 +- m4/rmdir.m4 | 2 +- m4/round.m4 | 2 +- m4/safe-read.m4 | 2 +- m4/safe-write.m4 | 2 +- m4/secure_getenv.m4 | 3 +- m4/select.m4 | 5 +- m4/servent.m4 | 2 +- m4/setenv.m4 | 2 +- m4/signal_h.m4 | 2 +- m4/signbit.m4 | 2 +- m4/size_max.m4 | 2 +- m4/snprintf.m4 | 2 +- m4/socketlib.m4 | 2 +- m4/sockets.m4 | 2 +- m4/socklen.m4 | 2 +- m4/sockpfaf.m4 | 2 +- m4/ssize_t.m4 | 2 +- m4/stat-time.m4 | 2 +- m4/stat.m4 | 2 +- m4/stdalign.m4 | 10 +- m4/stdbool.m4 | 36 +- m4/stddef_h.m4 | 10 +- m4/stdint.m4 | 31 +- m4/stdint_h.m4 | 2 +- m4/stdio_h.m4 | 31 +- m4/stdlib_h.m4 | 4 +- m4/strdup.m4 | 2 +- m4/strftime.m4 | 2 +- m4/string_h.m4 | 2 +- m4/sys_file_h.m4 | 2 +- m4/sys_select_h.m4 | 2 +- m4/sys_socket_h.m4 | 2 +- m4/sys_stat_h.m4 | 2 +- m4/sys_time_h.m4 | 3 +- m4/sys_times_h.m4 | 2 +- m4/sys_types_h.m4 | 2 +- m4/sys_uio_h.m4 | 2 +- m4/tempname.m4 | 2 +- m4/time_h.m4 | 22 +- m4/time_r.m4 | 2 +- m4/time_rz.m4 | 21 + m4/timegm.m4 | 26 + m4/times.m4 | 2 +- m4/tm_gmtoff.m4 | 2 +- m4/trunc.m4 | 2 +- m4/unistd_h.m4 | 6 +- m4/vasnprintf.m4 | 2 +- m4/visibility.m4 | 2 +- m4/vsnprintf.m4 | 2 +- m4/warn-on-use.m4 | 2 +- m4/warnings.m4 | 2 +- m4/wchar_h.m4 | 2 +- m4/wchar_t.m4 | 2 +- m4/wcrtomb.m4 | 2 +- m4/wctype_h.m4 | 2 +- m4/wint_t.m4 | 2 +- m4/write.m4 | 2 +- m4/xsize.m4 | 2 +- maint.mk | 51 +- 411 files changed, 6048 insertions(+), 2457 deletions(-) create mode 100644 doc/gendocs_template_min create mode 100644 lib/assure.h create mode 100644 lib/hard-locale.c create mode 100644 lib/hard-locale.h create mode 100644 lib/intprops.h create mode 100644 lib/mktime-internal.h create mode 100644 lib/mktime.c create mode 100644 lib/time-internal.h create mode 100644 lib/time_rz.c create mode 100644 lib/timegm.c create mode 100644 lib/unsetenv.c create mode 100644 m4/flexmember.m4 create mode 100644 m4/hard-locale.m4 create mode 100644 m4/mktime.m4 create mode 100644 m4/time_rz.m4 create mode 100644 m4/timegm.m4 diff --git a/GNUmakefile b/GNUmakefile index 4ab642943..a869da5bf 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -5,7 +5,7 @@ # It is necessary if you want to build targets usually of interest # only to the maintainer. -# Copyright (C) 2001, 2003, 2006-2014 Free Software Foundation, Inc. +# Copyright (C) 2001, 2003, 2006-2016 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/build-aux/announce-gen b/build-aux/announce-gen index db9ed50a7..b46117459 100755 --- a/build-aux/announce-gen +++ b/build-aux/announce-gen @@ -1,15 +1,15 @@ -eval '(exit $?0)' && eval 'exec perl -wS "$0" ${1+"$@"}' +eval '(exit $?0)' && eval 'exec perl -wS "$0" "$@"' & eval 'exec perl -wS "$0" $argv:q' if 0; # Generate a release announcement message. -my $VERSION = '2012-06-08 06:53'; # UTC +my $VERSION = '2016-01-12 23:09'; # UTC # The definition above must lie within the first 8 lines in order # for the Emacs time-stamp write hook (at end) to update it. # If you change this file with Emacs, please let the write hook # do its job. Otherwise, update this string manually. -# Copyright (C) 2002-2014 Free Software Foundation, Inc. +# Copyright (C) 2002-2016 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -29,15 +29,18 @@ my $VERSION = '2012-06-08 06:53'; # UTC use strict; use Getopt::Long; -use Digest::MD5; -eval { require Digest::SHA; } - or eval 'use Digest::SHA1'; use POSIX qw(strftime); (my $ME = $0) =~ s|.*/||; my %valid_release_types = map {$_ => 1} qw (alpha beta stable); my @archive_suffixes = ('tar.gz', 'tar.bz2', 'tar.lzma', 'tar.xz'); +my %digest_classes = + ( + 'md5' => (eval { require Digest::MD5; } and 'Digest::MD5'), + 'sha1' => ((eval { require Digest::SHA; } and 'Digest::SHA') + or (eval { require Digest::SHA1; } and 'Digest::SHA1')) + ); my $srcdir = '.'; sub usage ($) @@ -157,15 +160,13 @@ sub print_checksums (@) foreach my $meth (qw (md5 sha1)) { + my $class = $digest_classes{$meth} or next; foreach my $f (@file) { open IN, '<', $f or die "$ME: $f: cannot open for reading: $!\n"; binmode IN; - my $dig = - ($meth eq 'md5' - ? Digest::MD5->new->addfile(*IN)->hexdigest - : Digest::SHA1->new->addfile(*IN)->hexdigest); + my $dig = $class->new->addfile(*IN)->hexdigest; close IN; print "$dig $f\n"; } @@ -416,14 +417,15 @@ sub get_tool_versions ($$) @url_dir_list or (warn "URL directory name(s) not specified\n"), $fail = 1; - my @tool_list = split ',', $bootstrap_tools; + my @tool_list = split ',', $bootstrap_tools + if $bootstrap_tools; grep (/^gnulib$/, @tool_list) ^ defined $gnulib_version and (warn "when specifying gnulib as a tool, you must also specify\n" . "--gnulib-version=V, where V is the result of running git describe\n" . "in the gnulib source directory.\n"), $fail = 1; - exists $valid_release_types{$release_type} + !$release_type || exists $valid_release_types{$release_type} or (warn "'$release_type': invalid release type\n"), $fail = 1; @ARGV @@ -550,6 +552,6 @@ EOF ## eval: (add-hook 'write-file-hooks 'time-stamp) ## time-stamp-start: "my $VERSION = '" ## time-stamp-format: "%:y-%02m-%02d %02H:%02M" -## time-stamp-time-zone: "UTC" +## time-stamp-time-zone: "UTC0" ## time-stamp-end: "'; # UTC" ## End: diff --git a/build-aux/config.rpath b/build-aux/config.rpath index ab6fd995f..98183ff2f 100755 --- a/build-aux/config.rpath +++ b/build-aux/config.rpath @@ -2,7 +2,7 @@ # Output a system dependent set of variables, describing how to set the # run time search path of shared libraries in an executable. # -# Copyright 1996-2014 Free Software Foundation, Inc. +# Copyright 1996-2016 Free Software Foundation, Inc. # Taken from GNU libtool, 2001 # Originally by Gordon Matzigkeit , 1996 # @@ -367,11 +367,7 @@ else dgux*) hardcode_libdir_flag_spec='-L$libdir' ;; - freebsd2.2*) - hardcode_libdir_flag_spec='-R$libdir' - hardcode_direct=yes - ;; - freebsd2*) + freebsd2.[01]*) hardcode_direct=yes hardcode_minus_L=yes ;; @@ -548,13 +544,11 @@ case "$host_os" in dgux*) library_names_spec='$libname$shrext' ;; + freebsd[23].*) + library_names_spec='$libname$shrext$versuffix' + ;; freebsd* | dragonfly*) - case "$host_os" in - freebsd[123]*) - library_names_spec='$libname$shrext$versuffix' ;; - *) - library_names_spec='$libname$shrext' ;; - esac + library_names_spec='$libname$shrext' ;; gnu*) library_names_spec='$libname$shrext' diff --git a/build-aux/gendocs.sh b/build-aux/gendocs.sh index f9ec9df76..fef6280a2 100755 --- a/build-aux/gendocs.sh +++ b/build-aux/gendocs.sh @@ -2,10 +2,9 @@ # gendocs.sh -- generate a GNU manual in many formats. This script is # mentioned in maintain.texi. See the help message below for usage details. -scriptversion=2013-10-10.09 +scriptversion=2016-05-20.09 -# Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 -# Free Software Foundation, Inc. +# Copyright 2003-2016 Free Software Foundation, Inc. # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -21,17 +20,16 @@ scriptversion=2013-10-10.09 # along with this program. If not, see . # # Original author: Mohit Agarwal. -# Send bug reports and any other correspondence to bug-texinfo@gnu.org. +# Send bug reports and any other correspondence to bug-gnulib@gnu.org. # # The latest version of this script, and the companion template, is -# available from Texinfo CVS: -# http://savannah.gnu.org/cgi-bin/viewcvs/texinfo/texinfo/util/gendocs.sh -# http://savannah.gnu.org/cgi-bin/viewcvs/texinfo/texinfo/util/gendocs_template +# available from the Gnulib repository: # -# An up-to-date copy is also maintained in Gnulib (gnu.org/software/gnulib). +# http://git.savannah.gnu.org/cgit/gnulib.git/tree/build-aux/gendocs.sh +# http://git.savannah.gnu.org/cgit/gnulib.git/tree/doc/gendocs_template # TODO: -# - image importation was only implemented for HTML generated by +# - image importing was only implemented for HTML generated by # makeinfo. But it should be simple enough to adjust. # - images are not imported in the source tarball. All the needed # formats (PDF, PNG, etc.) should be included. @@ -39,12 +37,12 @@ scriptversion=2013-10-10.09 prog=`basename "$0"` srcdir=`pwd` -scripturl="http://savannah.gnu.org/cgi-bin/viewcvs/~checkout~/texinfo/texinfo/util/gendocs.sh" -templateurl="http://savannah.gnu.org/cgi-bin/viewcvs/~checkout~/texinfo/texinfo/util/gendocs_template" +scripturl="http://git.savannah.gnu.org/cgit/gnulib.git/plain/build-aux/gendocs.sh" +templateurl="http://git.savannah.gnu.org/cgit/gnulib.git/plain/doc/gendocs_template" : ${SETLANG="env LANG= LC_MESSAGES= LC_ALL= LANGUAGE="} : ${MAKEINFO="makeinfo"} -: ${TEXI2DVI="texi2dvi -t @finalout"} +: ${TEXI2DVI="texi2dvi"} : ${DOCBOOK2HTML="docbook2html"} : ${DOCBOOK2PDF="docbook2pdf"} : ${DOCBOOK2TXT="docbook2txt"} @@ -54,9 +52,27 @@ templateurl="http://savannah.gnu.org/cgi-bin/viewcvs/~checkout~/texinfo/texinfo/ unset CDPATH unset use_texi2html +MANUAL_TITLE= +PACKAGE= +EMAIL=webmasters@gnu.org # please override with --email +commonarg= # passed to all makeinfo/texi2html invcations. +dirargs= # passed to all tools (-I dir). +dirs= # -I directories. +htmlarg="--css-ref=/software/gnulib/manual.css -c TOP_NODE_UP_URL=/manual" +infoarg=--no-split +generate_ascii=true +generate_html=true +generate_info=true +generate_tex=true +outdir=manual +source_extra= +split=node +srcfile= +texarg="-t @finalout" + version="gendocs.sh $scriptversion -Copyright 2013 Free Software Foundation, Inc. +Copyright 2016 Free Software Foundation, Inc. There is NO warranty. You may redistribute this software under the terms of the GNU General Public License. For more information about these matters, see the files named COPYING." @@ -75,11 +91,16 @@ Options: -o OUTDIR write files into OUTDIR, instead of manual/. -I DIR append DIR to the Texinfo search path. --common ARG pass ARG in all invocations. - --html ARG pass ARG to makeinfo or texi2html for HTML targets. + --html ARG pass ARG to makeinfo or texi2html for HTML targets, + instead of '$htmlarg'. --info ARG pass ARG to makeinfo for Info, instead of --no-split. --no-ascii skip generating the plain text output. + --no-html skip generating the html output. + --no-info skip generating the info output. + --no-tex skip generating the dvi and pdf output. --source ARG include ARG in tar archive of sources. --split HOW make split HTML by node, section, chapter; default node. + --tex ARG pass ARG to texi2dvi for DVI and PDF, instead of -t @finalout. --texi2html use texi2html to make HTML target, with all split versions. --docbook convert through DocBook too (xml, txt, html, pdf). @@ -131,23 +152,9 @@ locale, since that's the language of most Texinfo manuals. If you happen to have a non-English manual and non-English web site, see the SETLANG setting in the source. -Email bug reports or enhancement requests to bug-texinfo@gnu.org. +Email bug reports or enhancement requests to bug-gnulib@gnu.org. " -MANUAL_TITLE= -PACKAGE= -EMAIL=webmasters@gnu.org # please override with --email -commonarg= # passed to all makeinfo/texi2html invcations. -dirargs= # passed to all tools (-I dir). -dirs= # -I's directories. -htmlarg= -infoarg=--no-split -generate_ascii=true -outdir=manual -source_extra= -split=node -srcfile= - while test $# -gt 0; do case $1 in -s) shift; srcfile=$1;; @@ -159,8 +166,12 @@ while test $# -gt 0; do --html) shift; htmlarg=$1;; --info) shift; infoarg=$1;; --no-ascii) generate_ascii=false;; + --no-html) generate_ascii=false;; + --no-info) generate_info=false;; + --no-tex) generate_tex=false;; --source) shift; source_extra=$1;; --split) shift; split=$1;; + --tex) shift; texarg=$1;; --texi2html) use_texi2html=1;; --help) echo "$usage"; exit 0;; @@ -221,8 +232,9 @@ calcsize() # copy_images OUTDIR HTML-FILE... # ------------------------------- -# Copy all the images needed by the HTML-FILEs into OUTDIR. Look -# for them in the -I directories. +# Copy all the images needed by the HTML-FILEs into OUTDIR. +# Look for them in . and the -I directories; this is simpler than what +# makeinfo supports with -I, but hopefully it will suffice. copy_images() { local odir @@ -232,7 +244,7 @@ copy_images() BEGIN { \$me = '$prog'; \$odir = '$odir'; - @dirs = qw($dirs); + @dirs = qw(. $dirs); } " -e ' /${srcdir}/$PACKAGE-db.xml" @@ -431,7 +457,8 @@ if test -n "$docbook"; then mv $PACKAGE-db.pdf "$outdir/" fi -printf "\nMaking index file...\n" +# +printf "\nMaking index.html for $PACKAGE...\n" if test -z "$use_texi2html"; then CONDS="/%%IF *HTML_SECTION%%/,/%%ENDIF *HTML_SECTION%%/d;\ /%%IF *HTML_CHAPTER%%/,/%%ENDIF *HTML_CHAPTER%%/d" diff --git a/build-aux/git-version-gen b/build-aux/git-version-gen index 1e5d556e9..9e5e4fb11 100755 --- a/build-aux/git-version-gen +++ b/build-aux/git-version-gen @@ -1,8 +1,8 @@ #!/bin/sh # Print a version string. -scriptversion=2012-12-31.23; # UTC +scriptversion=2016-05-08.18; # UTC -# Copyright (C) 2007-2014 Free Software Foundation, Inc. +# Copyright (C) 2007-2016 Free Software Foundation, Inc. # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -85,9 +85,10 @@ Print a version string. Options: - --prefix prefix of git tags (default 'v') + --prefix PREFIX prefix of git tags (default 'v') --match pattern for git tags to match (default: '\$prefix*') - --fallback fallback version to use if \"git --version\" fails + --fallback VERSION + fallback version to use if \"git --version\" fails --help display this help and exit --version output version information and exit @@ -104,9 +105,9 @@ while test $# -gt 0; do case $1 in --help) echo "$usage"; exit 0;; --version) echo "$version"; exit 0;; - --prefix) shift; prefix="$1";; + --prefix) shift; prefix=${1?};; --match) shift; match="$1";; - --fallback) shift; fallback="$1";; + --fallback) shift; fallback=${1?};; -*) echo "$0: Unknown option '$1'." >&2 echo "$0: Try '--help' for more information." >&2 @@ -220,12 +221,12 @@ if test "x$v_from_git" != x; then fi # Omit the trailing newline, so that m4_esyscmd can use the result directly. -echo "$v" | tr -d "$nl" +printf %s "$v" # Local variables: # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" -# time-stamp-time-zone: "UTC" +# time-stamp-time-zone: "UTC0" # time-stamp-end: "; # UTC" # End: diff --git a/build-aux/gitlog-to-changelog b/build-aux/gitlog-to-changelog index 78afff4e8..83bafdffa 100755 --- a/build-aux/gitlog-to-changelog +++ b/build-aux/gitlog-to-changelog @@ -1,15 +1,15 @@ -eval '(exit $?0)' && eval 'exec perl -wS "$0" ${1+"$@"}' +eval '(exit $?0)' && eval 'exec perl -wS "$0" "$@"' & eval 'exec perl -wS "$0" $argv:q' if 0; # Convert git log output to ChangeLog format. -my $VERSION = '2012-07-29 06:11'; # UTC +my $VERSION = '2016-03-22 21:49'; # UTC # The definition above must lie within the first 8 lines in order # for the Emacs time-stamp write hook (at end) to update it. # If you change this file with Emacs, please let the write hook # do its job. Otherwise, update this string manually. -# Copyright (C) 2008-2014 Free Software Foundation, Inc. +# Copyright (C) 2008-2016 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -72,6 +72,9 @@ OPTIONS: directory can be derived. --since=DATE convert only the logs since DATE; the default is to convert all log entries. + --until=DATE convert only the logs older than DATE. + --ignore-matching=PAT ignore commit messages whose first lines match PAT. + --ignore-line=PAT ignore lines of commit messages that match PAT. --format=FMT set format string for commit subject and body; see 'man git-log' for the list of format metacharacters; the default is '%s%n%b%n' @@ -220,10 +223,13 @@ sub git_dir_option($) { my $since_date; + my $until_date; my $format_string = '%s%n%b%n'; my $amend_file; my $append_dot = 0; my $cluster = 1; + my $ignore_matching; + my $ignore_line; my $strip_tab = 0; my $strip_cherry_pick = 0; my $srcdir; @@ -232,10 +238,13 @@ sub git_dir_option($) help => sub { usage 0 }, version => sub { print "$ME version $VERSION\n"; exit }, 'since=s' => \$since_date, + 'until=s' => \$until_date, 'format=s' => \$format_string, 'amend=s' => \$amend_file, 'append-dot' => \$append_dot, 'cluster!' => \$cluster, + 'ignore-matching=s' => \$ignore_matching, + 'ignore-line=s' => \$ignore_line, 'strip-tab' => \$strip_tab, 'strip-cherry-pick' => \$strip_cherry_pick, 'srcdir=s' => \$srcdir, @@ -243,6 +252,8 @@ sub git_dir_option($) defined $since_date and unshift @ARGV, "--since=$since_date"; + defined $until_date + and unshift @ARGV, "--until=$until_date"; # This is a hash that maps an SHA1 to perl code (i.e., s/old/new/) # that makes a correction in the log or attribution of that commit. @@ -259,6 +270,7 @@ sub git_dir_option($) my $prev_multi_paragraph; my $prev_date_line = ''; my @prev_coauthors = (); + my @skipshas = (); while (1) { defined (my $in = ) @@ -279,6 +291,19 @@ sub git_dir_option($) $sha =~ /^[0-9a-fA-F]{40}$/ or die "$ME:$.: invalid SHA1: $sha\n"; + my $skipflag = 0; + if (@skipshas) + { + foreach(@skipshas) + { + if ($sha =~ /^$_/) + { + $skipflag = $_; + last; + } + } + } + # If this commit's log requires any transformation, do it now. my $code = $amend_code->{$sha}; if (defined $code) @@ -306,7 +331,7 @@ sub git_dir_option($) $rest =~ s/^\s*\(cherry picked from commit [\da-f]+\)\n//m; } - my @line = split "\n", $rest; + my @line = split /[ \t]*\n/, $rest; my $author_line = shift @line; defined $author_line or die "$ME:$.: unexpected EOF\n"; @@ -316,17 +341,18 @@ sub git_dir_option($) # Format 'Copyright-paperwork-exempt: Yes' as a standard ChangeLog # `(tiny change)' annotation. - my $tiny = (grep (/^Copyright-paperwork-exempt:\s+[Yy]es$/, @line) + my $tiny = (grep (/^(?:Copyright-paperwork-exempt|Tiny-change):\s+[Yy]es$/, @line) ? ' (tiny change)' : ''); my $date_line = sprintf "%s %s$tiny\n", - strftime ("%F", localtime ($1)), $2; + strftime ("%Y-%m-%d", localtime ($1)), $2; my @coauthors = grep /^Co-authored-by:.*$/, @line; # Omit meta-data lines we've already interpreted. @line = grep !/^(?:Signed-off-by:[ ].*>$ |Co-authored-by:[ ] |Copyright-paperwork-exempt:[ ] + |Tiny-change:[ ] )/x, @line; # Remove leading and trailing blank lines. @@ -336,68 +362,109 @@ sub git_dir_option($) while ($line[$#line] =~ /^\s*$/) { pop @line; } } - # Record whether there are two or more paragraphs. - my $multi_paragraph = grep /^\s*$/, @line; + # Handle Emacs gitmerge.el "skipped" commits. + # Yes, this should be controlled by an option. So sue me. + if ( grep /^(; )?Merge from /, @line ) + { + my $found = 0; + foreach (@line) + { + if (grep /^The following commit.*skipped:$/, $_) + { + $found = 1; + ## Reset at each merge to reduce chance of false matches. + @skipshas = (); + next; + } + if ($found && $_ =~ /^([0-9a-fA-F]{7,}) [^ ]/) + { + push ( @skipshas, $1 ); + } + } + } - # Format 'Co-authored-by: A U Thor ' lines in - # standard multi-author ChangeLog format. - for (@coauthors) + # Ignore commits that match the --ignore-matching pattern, if specified. + if (defined $ignore_matching && @line && $line[0] =~ /$ignore_matching/) { - s/^Co-authored-by:\s*/\t /; - s/\s*/ - or warn "$ME: warning: missing email address for " - . substr ($_, 5) . "\n"; + $skipflag = 1; + } + elsif ($skipflag) + { + ## Perhaps only warn if a pattern matches more than once? + warn "$ME: warning: skipping $sha due to $skipflag\n"; } - # If clustering of commit messages has been disabled, if this header - # would be different from the previous date/name/email/coauthors header, - # or if this or the previous entry consists of two or more paragraphs, - # then print the header. - if ( ! $cluster - || $date_line ne $prev_date_line - || "@coauthors" ne "@prev_coauthors" - || $multi_paragraph - || $prev_multi_paragraph) + if (! $skipflag) { - $prev_date_line eq '' - or print "\n"; - print $date_line; - @coauthors - and print join ("\n", @coauthors), "\n"; - } - $prev_date_line = $date_line; - @prev_coauthors = @coauthors; - $prev_multi_paragraph = $multi_paragraph; - - # If there were any lines - if (@line == 0) - { - warn "$ME: warning: empty commit message:\n $date_line\n"; - } - else - { - if ($append_dot) + if (defined $ignore_line && @line) { - # If the first line of the message has enough room, then - if (length $line[0] < 72) - { - # append a dot if there is no other punctuation or blank - # at the end. - $line[0] =~ /[[:punct:]\s]$/ - or $line[0] .= '.'; - } + @line = grep ! /$ignore_line/, @line; + while ($line[$#line] =~ /^\s*$/) { pop @line; } } - # Remove one additional leading TAB from each line. - $strip_tab - and map { s/^\t// } @line; + # Record whether there are two or more paragraphs. + my $multi_paragraph = grep /^\s*$/, @line; - # Prefix each non-empty line with a TAB. - @line = map { length $_ ? "\t$_" : '' } @line; + # Format 'Co-authored-by: A U Thor ' lines in + # standard multi-author ChangeLog format. + for (@coauthors) + { + s/^Co-authored-by:\s*/\t /; + s/\s*/ + or warn "$ME: warning: missing email address for " + . substr ($_, 5) . "\n"; + } + + # If clustering of commit messages has been disabled, if this header + # would be different from the previous date/name/etc. header, + # or if this or the previous entry consists of two or more paragraphs, + # then print the header. + if ( ! $cluster + || $date_line ne $prev_date_line + || "@coauthors" ne "@prev_coauthors" + || $multi_paragraph + || $prev_multi_paragraph) + { + $prev_date_line eq '' + or print "\n"; + print $date_line; + @coauthors + and print join ("\n", @coauthors), "\n"; + } + $prev_date_line = $date_line; + @prev_coauthors = @coauthors; + $prev_multi_paragraph = $multi_paragraph; + + # If there were any lines + if (@line == 0) + { + warn "$ME: warning: empty commit message:\n $date_line\n"; + } + else + { + if ($append_dot) + { + # If the first line of the message has enough room, then + if (length $line[0] < 72) + { + # append a dot if there is no other punctuation or blank + # at the end. + $line[0] =~ /[[:punct:]\s]$/ + or $line[0] .= '.'; + } + } + + # Remove one additional leading TAB from each line. + $strip_tab + and map { s/^\t// } @line; + + # Prefix each non-empty line with a TAB. + @line = map { length $_ ? "\t$_" : '' } @line; + + print "\n", join ("\n", @line), "\n"; + } } defined ($in = ) @@ -427,6 +494,6 @@ sub git_dir_option($) # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "my $VERSION = '" # time-stamp-format: "%:y-%02m-%02d %02H:%02M" -# time-stamp-time-zone: "UTC" +# time-stamp-time-zone: "UTC0" # time-stamp-end: "'; # UTC" # End: diff --git a/build-aux/gnu-web-doc-update b/build-aux/gnu-web-doc-update index 7af2f185f..271e69370 100755 --- a/build-aux/gnu-web-doc-update +++ b/build-aux/gnu-web-doc-update @@ -2,9 +2,9 @@ # Run this after each non-alpha release, to update the web documentation at # http://www.gnu.org/software/$pkg/manual/ -VERSION=2012-12-16.14; # UTC +VERSION=2016-01-12.23; # UTC -# Copyright (C) 2009-2014 Free Software Foundation, Inc. +# Copyright (C) 2009-2016 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -40,6 +40,7 @@ assumes all documentation is in the doc/ sub-directory. Options: -C, --builddir=DIR location of (configured) Makefile (default: .) -n, --dry-run don't actually commit anything + -m, --mirror remove out of date files from document server --help print this help, then exit --version print version number, then exit @@ -107,6 +108,7 @@ find_tool XARGS gxargs xargs builddir=. dryrun= +rm_stale='echo' while test $# != 0 do # Handle --option=value by splitting apart and putting back on argv. @@ -115,7 +117,7 @@ do opt=$(echo "$1" | sed -e 's/=.*//') val=$(echo "$1" | sed -e 's/[^=]*=//') shift - set dummy "$opt" "$val" ${1+"$@"}; shift + set dummy "$opt" "$val" "$@"; shift ;; esac @@ -123,6 +125,7 @@ do --help|--version) ${1#--};; -C|--builddir) shift; builddir=$1; shift ;; -n|--dry-run) dryrun=echo; shift;; + -m|--mirror) rm_stale=''; shift;; --*) die "unrecognized option: $1";; *) break;; esac @@ -159,6 +162,7 @@ $GIT submodule update --recursive ./bootstrap srcdir=$(pwd) cd "$builddir" +builddir=$(pwd) ./config.status --recheck ./config.status make @@ -175,13 +179,25 @@ $RSYNC -avP "$builddir"/doc/manual/ $tmp/$pkg/manual cd $tmp/$pkg/manual # Add all the files. This is simpler than trying to add only the - # new ones because of new directories: it would require iterating on - # adding the outer directories, and then their contents. - # - # find guarantees that we add outer directories first. - find . -name CVS -prune -o -print \ + # new ones because of new directories + # First add non empty dirs individually + find . -name CVS -prune -o -type d \! -empty -print \ + | $XARGS -n1 --no-run-if-empty -- $dryrun $CVS add -ko + # Now add all files + find . -name CVS -prune -o -type f -print \ | $XARGS --no-run-if-empty -- $dryrun $CVS add -ko + # Report/Remove stale files + # excluding doc server specific files like CVS/* and .symlinks + if test -n "$rm_stale"; then + echo 'Consider the --mirror option if all of the manual is generated,' >&2 + echo 'which will run `cvs remove` to remove stale files.' >&2 + fi + { find . \( -name CVS -o -type f -name '.*' \) -prune -o -type f -print + (cd "$builddir"/doc/manual/ && find . -type f -print | sed p) + } | sort | uniq -u \ + | $XARGS --no-run-if-empty -- ${rm_stale:-$dryrun} $CVS remove -f + $dryrun $CVS ci -m $version ) @@ -189,6 +205,6 @@ $RSYNC -avP "$builddir"/doc/manual/ $tmp/$pkg/manual # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "VERSION=" # time-stamp-format: "%:y-%02m-%02d.%02H" -# time-stamp-time-zone: "UTC" +# time-stamp-time-zone: "UTC0" # time-stamp-end: "; # UTC" # End: diff --git a/build-aux/gnupload b/build-aux/gnupload index 2da97d894..8d0299d69 100755 --- a/build-aux/gnupload +++ b/build-aux/gnupload @@ -1,9 +1,9 @@ #!/bin/sh # Sign files and upload them. -scriptversion=2013-03-19.17; # UTC +scriptversion=2016-01-11.22; # UTC -# Copyright (C) 2004-2014 Free Software Foundation, Inc. +# Copyright (C) 2004-2016 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -435,6 +435,6 @@ exit 0 # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" -# time-stamp-time-zone: "UTC" +# time-stamp-time-zone: "UTC0" # time-stamp-end: "; # UTC" # End: diff --git a/build-aux/snippet/arg-nonnull.h b/build-aux/snippet/arg-nonnull.h index 9ee8b1555..584649f69 100644 --- a/build-aux/snippet/arg-nonnull.h +++ b/build-aux/snippet/arg-nonnull.h @@ -1,5 +1,5 @@ /* A C macro for declaring that specific arguments must not be NULL. - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published diff --git a/build-aux/snippet/c++defs.h b/build-aux/snippet/c++defs.h index 67b12335d..813f2e2e4 100644 --- a/build-aux/snippet/c++defs.h +++ b/build-aux/snippet/c++defs.h @@ -1,5 +1,5 @@ /* C++ compatible function declaration macros. - Copyright (C) 2010-2014 Free Software Foundation, Inc. + Copyright (C) 2010-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published diff --git a/build-aux/snippet/unused-parameter.h b/build-aux/snippet/unused-parameter.h index 41d9510ca..843db76af 100644 --- a/build-aux/snippet/unused-parameter.h +++ b/build-aux/snippet/unused-parameter.h @@ -1,5 +1,5 @@ /* A C macro for declaring that specific function parameters are not used. - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published diff --git a/build-aux/snippet/warn-on-use.h b/build-aux/snippet/warn-on-use.h index 1c4d7bd4e..2948b4788 100644 --- a/build-aux/snippet/warn-on-use.h +++ b/build-aux/snippet/warn-on-use.h @@ -1,5 +1,5 @@ /* A C macro for emitting warnings if a function is used. - Copyright (C) 2010-2014 Free Software Foundation, Inc. + Copyright (C) 2010-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published diff --git a/build-aux/useless-if-before-free b/build-aux/useless-if-before-free index 4c76c75d7..1899b1ffd 100755 --- a/build-aux/useless-if-before-free +++ b/build-aux/useless-if-before-free @@ -1,16 +1,16 @@ -eval '(exit $?0)' && eval 'exec perl -wST "$0" ${1+"$@"}' +eval '(exit $?0)' && eval 'exec perl -wST "$0" "$@"' & eval 'exec perl -wST "$0" $argv:q' if 0; # Detect instances of "if (p) free (p);". # Likewise "if (p != 0)", "if (0 != p)", or with NULL; and with braces. -my $VERSION = '2012-01-06 07:23'; # UTC +my $VERSION = '2016-01-12 23:13'; # UTC # The definition above must lie within the first 8 lines in order # for the Emacs time-stamp write hook (at end) to update it. # If you change this file with Emacs, please let the write hook # do its job. Otherwise, update this string manually. -# Copyright (C) 2008-2014 Free Software Foundation, Inc. +# Copyright (C) 2008-2016 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -202,6 +202,6 @@ EOF ## eval: (add-hook 'write-file-hooks 'time-stamp) ## time-stamp-start: "my $VERSION = '" ## time-stamp-format: "%:y-%02m-%02d %02H:%02M" -## time-stamp-time-zone: "UTC" +## time-stamp-time-zone: "UTC0" ## time-stamp-end: "'; # UTC" ## End: diff --git a/build-aux/vc-list-files b/build-aux/vc-list-files index b2bca54c9..c5c420a4b 100755 --- a/build-aux/vc-list-files +++ b/build-aux/vc-list-files @@ -2,9 +2,9 @@ # List version-controlled file names. # Print a version string. -scriptversion=2011-05-16.22; # UTC +scriptversion=2016-01-11.22; # UTC -# Copyright (C) 2006-2014 Free Software Foundation, Inc. +# Copyright (C) 2006-2016 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -108,6 +108,6 @@ done # eval: (add-hook 'write-file-hooks 'time-stamp) # time-stamp-start: "scriptversion=" # time-stamp-format: "%:y-%02m-%02d.%02H" -# time-stamp-time-zone: "UTC" +# time-stamp-time-zone: "UTC0" # time-stamp-end: "; # UTC" # End: diff --git a/doc/gendocs_template b/doc/gendocs_template index 4836df787..fea0ebc23 100644 --- a/doc/gendocs_template +++ b/doc/gendocs_template @@ -1,5 +1,6 @@ -%%TITLE%% - GNU Project - Free Software Foundation (FSF) + +%%TITLE%% - GNU Project - Free Software Foundation

%%TITLE%%

@@ -67,19 +68,22 @@ script.)

diff --git a/doc/gendocs_template_min b/doc/gendocs_template_min new file mode 100644 index 000000000..935c135b5 --- /dev/null +++ b/doc/gendocs_template_min @@ -0,0 +1,93 @@ + + + + + +%%TITLE%% - GNU Project - Free Software Foundation + + + + + + +

%%TITLE%%

+ +
Free Software Foundation
+
last updated %%DATE%%
+

+ + [image of the head of a GNU] + +

+
+ +

This manual (%%PACKAGE%%) is available in the following formats:

+ + + +

(This page generated by the %%SCRIPTNAME%% +script.)

+ + + +

Copyright © 2016 Free Software Foundation, Inc.

+ +

This page is licensed under a Creative +Commons Attribution-NoDerivs 3.0 United States License.

+ + + + + + diff --git a/lib/Makefile.am b/lib/Makefile.am index 5d9c902fc..b65c94279 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -1,6 +1,6 @@ ## DO NOT EDIT! GENERATED AUTOMATICALLY! ## Process this file with automake to produce Makefile.in. -# Copyright (C) 2002-2014 Free Software Foundation, Inc. +# Copyright (C) 2002-2016 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -21,7 +21,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkstemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar +# Reproduce by: gnulib-tool --import --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --lgpl=3 --conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkstemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar AUTOMAKE_OPTIONS = 1.9.6 gnits subdir-objects @@ -101,9 +101,11 @@ EXTRA_DIST += alignof.h ## begin gnulib module alloca +if gl_GNULIB_ENABLED_alloca libgnu_la_LIBADD += @LTALLOCA@ libgnu_la_DEPENDENCIES += @LTALLOCA@ +endif EXTRA_DIST += alloca.c EXTRA_libgnu_la_SOURCES += alloca.c @@ -176,6 +178,15 @@ EXTRA_DIST += arpa_inet.in.h ## end gnulib module arpa_inet +## begin gnulib module assure + +if gl_GNULIB_ENABLED_assure + +endif +EXTRA_DIST += assure.h + +## end gnulib module assure + ## begin gnulib module binary-io libgnu_la_SOURCES += binary-io.h binary-io.c @@ -193,7 +204,9 @@ EXTRA_libgnu_la_SOURCES += bind.c ## begin gnulib module btowc +if gl_GNULIB_ENABLED_btowc +endif EXTRA_DIST += btowc.c EXTRA_libgnu_la_SOURCES += btowc.c @@ -391,22 +404,28 @@ EXTRA_libgnu_la_SOURCES += dirfd.c ## begin gnulib module dirname-lgpl +if gl_GNULIB_ENABLED_a691da99c1d83b83238e45f41a696f5c libgnu_la_SOURCES += dirname-lgpl.c basename-lgpl.c stripslash.c +endif EXTRA_DIST += dirname.h ## end gnulib module dirname-lgpl ## begin gnulib module dosname +if gl_GNULIB_ENABLED_dosname +endif EXTRA_DIST += dosname.h ## end gnulib module dosname ## begin gnulib module dup2 +if gl_GNULIB_ENABLED_dup2 +endif EXTRA_DIST += dup2.c EXTRA_libgnu_la_SOURCES += dup2.c @@ -493,8 +512,10 @@ EXTRA_DIST += fcntl.in.h ## begin gnulib module fd-hook +if gl_GNULIB_ENABLED_43fe87a341d9b4b93c47c3ad819a5239 libgnu_la_SOURCES += fd-hook.c +endif EXTRA_DIST += fd-hook.h ## end gnulib module fd-hook @@ -645,8 +666,10 @@ EXTRA_libgnu_la_SOURCES += getsockopt.c ## begin gnulib module gettext-h +if gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36 libgnu_la_SOURCES += gettext.h +endif ## end gnulib module gettext-h ## begin gnulib module gettimeofday @@ -699,9 +722,22 @@ EXTRA_DIST += $(top_srcdir)/build-aux/gnupload ## begin gnulib module gperf GPERF = gperf +V_GPERF = $(V_GPERF_@AM_V@) +V_GPERF_ = $(V_GPERF_@AM_DEFAULT_V@) +V_GPERF_0 = @echo " GPERF " $@; ## end gnulib module gperf +## begin gnulib module hard-locale + +if gl_GNULIB_ENABLED_30838f5439487421042f2225bed3af76 +libgnu_la_SOURCES += hard-locale.c + +endif +EXTRA_DIST += hard-locale.h + +## end gnulib module hard-locale + ## begin gnulib module havelib @@ -748,19 +784,19 @@ EXTRA_DIST += iconv.in.h ## begin gnulib module iconv_open iconv_open-aix.h: iconv_open-aix.gperf - $(GPERF) -m 10 $(srcdir)/iconv_open-aix.gperf > $(srcdir)/iconv_open-aix.h-t + $(V_GPERF)$(GPERF) -m 10 $(srcdir)/iconv_open-aix.gperf > $(srcdir)/iconv_open-aix.h-t && \ mv $(srcdir)/iconv_open-aix.h-t $(srcdir)/iconv_open-aix.h iconv_open-hpux.h: iconv_open-hpux.gperf - $(GPERF) -m 10 $(srcdir)/iconv_open-hpux.gperf > $(srcdir)/iconv_open-hpux.h-t + $(V_GPERF)$(GPERF) -m 10 $(srcdir)/iconv_open-hpux.gperf > $(srcdir)/iconv_open-hpux.h-t && \ mv $(srcdir)/iconv_open-hpux.h-t $(srcdir)/iconv_open-hpux.h iconv_open-irix.h: iconv_open-irix.gperf - $(GPERF) -m 10 $(srcdir)/iconv_open-irix.gperf > $(srcdir)/iconv_open-irix.h-t + $(V_GPERF)$(GPERF) -m 10 $(srcdir)/iconv_open-irix.gperf > $(srcdir)/iconv_open-irix.h-t && \ mv $(srcdir)/iconv_open-irix.h-t $(srcdir)/iconv_open-irix.h iconv_open-osf.h: iconv_open-osf.gperf - $(GPERF) -m 10 $(srcdir)/iconv_open-osf.gperf > $(srcdir)/iconv_open-osf.h-t + $(V_GPERF)$(GPERF) -m 10 $(srcdir)/iconv_open-osf.gperf > $(srcdir)/iconv_open-osf.h-t && \ mv $(srcdir)/iconv_open-osf.h-t $(srcdir)/iconv_open-osf.h iconv_open-solaris.h: iconv_open-solaris.gperf - $(GPERF) -m 10 $(srcdir)/iconv_open-solaris.gperf > $(srcdir)/iconv_open-solaris.h-t + $(V_GPERF)$(GPERF) -m 10 $(srcdir)/iconv_open-solaris.gperf > $(srcdir)/iconv_open-solaris.h-t && \ mv $(srcdir)/iconv_open-solaris.h-t $(srcdir)/iconv_open-solaris.h BUILT_SOURCES += iconv_open-aix.h iconv_open-hpux.h iconv_open-irix.h iconv_open-osf.h iconv_open-solaris.h MOSTLYCLEANFILES += iconv_open-aix.h-t iconv_open-hpux.h-t iconv_open-irix.h-t iconv_open-osf.h-t iconv_open-solaris.h-t @@ -791,6 +827,15 @@ EXTRA_libgnu_la_SOURCES += inet_pton.c ## end gnulib module inet_pton +## begin gnulib module intprops + +if gl_GNULIB_ENABLED_intprops + +endif +EXTRA_DIST += intprops.h + +## end gnulib module intprops + ## begin gnulib module isfinite @@ -820,7 +865,9 @@ EXTRA_libgnu_la_SOURCES += isnan.c isnand.c ## begin gnulib module isnand-nolibm +if gl_GNULIB_ENABLED_b1df7117b479d2da59d76deba468ee21 +endif EXTRA_DIST += float+.h isnan.c isnand-nolibm.h isnand.c EXTRA_libgnu_la_SOURCES += isnan.c isnand.c @@ -838,7 +885,9 @@ EXTRA_libgnu_la_SOURCES += isnan.c isnanf.c ## begin gnulib module isnanf-nolibm +if gl_GNULIB_ENABLED_3f0e593033d1fc2c127581960f641b66 +endif EXTRA_DIST += float+.h isnan.c isnanf-nolibm.h isnanf.c EXTRA_libgnu_la_SOURCES += isnan.c isnanf.c @@ -856,7 +905,9 @@ EXTRA_libgnu_la_SOURCES += isnan.c isnanl.c ## begin gnulib module isnanl-nolibm +if gl_GNULIB_ENABLED_dbdf22868a5367f28bf18e0013ac6f8f +endif EXTRA_DIST += float+.h isnan.c isnanl-nolibm.h isnanl.c EXTRA_libgnu_la_SOURCES += isnan.c isnanl.c @@ -1042,7 +1093,9 @@ EXTRA_DIST += locale.in.h ## begin gnulib module localeconv +if gl_GNULIB_ENABLED_localeconv +endif EXTRA_DIST += localeconv.c EXTRA_libgnu_la_SOURCES += localeconv.c @@ -1051,7 +1104,9 @@ EXTRA_libgnu_la_SOURCES += localeconv.c ## begin gnulib module log +if gl_GNULIB_ENABLED_log +endif EXTRA_DIST += log.c EXTRA_libgnu_la_SOURCES += log.c @@ -1394,7 +1449,9 @@ EXTRA_DIST += math.in.h ## begin gnulib module mbrtowc +if gl_GNULIB_ENABLED_mbrtowc +endif EXTRA_DIST += mbrtowc.c EXTRA_libgnu_la_SOURCES += mbrtowc.c @@ -1403,7 +1460,9 @@ EXTRA_libgnu_la_SOURCES += mbrtowc.c ## begin gnulib module mbsinit +if gl_GNULIB_ENABLED_mbsinit +endif EXTRA_DIST += mbsinit.c EXTRA_libgnu_la_SOURCES += mbsinit.c @@ -1412,7 +1471,9 @@ EXTRA_libgnu_la_SOURCES += mbsinit.c ## begin gnulib module mbtowc +if gl_GNULIB_ENABLED_mbtowc +endif EXTRA_DIST += mbtowc-impl.h mbtowc.c EXTRA_libgnu_la_SOURCES += mbtowc.c @@ -1421,7 +1482,9 @@ EXTRA_libgnu_la_SOURCES += mbtowc.c ## begin gnulib module memchr +if gl_GNULIB_ENABLED_memchr +endif EXTRA_DIST += memchr.c memchr.valgrind EXTRA_libgnu_la_SOURCES += memchr.c @@ -1446,9 +1509,33 @@ EXTRA_libgnu_la_SOURCES += mkstemp.c ## end gnulib module mkstemp +## begin gnulib module mktime + +if gl_GNULIB_ENABLED_mktime + +endif +EXTRA_DIST += mktime-internal.h mktime.c + +EXTRA_libgnu_la_SOURCES += mktime.c + +## end gnulib module mktime + +## begin gnulib module mktime-internal + +if gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31 + +endif +EXTRA_DIST += mktime-internal.h mktime.c + +EXTRA_libgnu_la_SOURCES += mktime.c + +## end gnulib module mktime-internal + ## begin gnulib module msvc-inval +if gl_GNULIB_ENABLED_f691f076f650964c9f5598c3ee487616 +endif EXTRA_DIST += msvc-inval.c msvc-inval.h EXTRA_libgnu_la_SOURCES += msvc-inval.c @@ -1457,7 +1544,9 @@ EXTRA_libgnu_la_SOURCES += msvc-inval.c ## begin gnulib module msvc-nothrow +if gl_GNULIB_ENABLED_676220fa4366efa9bdbfccf11a857c07 +endif EXTRA_DIST += msvc-nothrow.c msvc-nothrow.h EXTRA_libgnu_la_SOURCES += msvc-nothrow.c @@ -1557,7 +1646,9 @@ EXTRA_libgnu_la_SOURCES += open.c ## begin gnulib module pathmax +if gl_GNULIB_ENABLED_pathmax +endif EXTRA_DIST += pathmax.h ## end gnulib module pathmax @@ -1626,7 +1717,9 @@ EXTRA_libgnu_la_SOURCES += putenv.c ## begin gnulib module raise +if gl_GNULIB_ENABLED_raise +endif EXTRA_DIST += raise.c EXTRA_libgnu_la_SOURCES += raise.c @@ -1698,7 +1791,9 @@ EXTRA_libgnu_la_SOURCES += rmdir.c ## begin gnulib module round +if gl_GNULIB_ENABLED_round +endif EXTRA_DIST += round.c EXTRA_libgnu_la_SOURCES += round.c @@ -1725,14 +1820,18 @@ EXTRA_libgnu_la_SOURCES += safe-read.c ## begin gnulib module same-inode +if gl_GNULIB_ENABLED_9bc5f216d57e231e4834049d67d0db62 +endif EXTRA_DIST += same-inode.h ## end gnulib module same-inode ## begin gnulib module secure_getenv +if gl_GNULIB_ENABLED_secure_getenv +endif EXTRA_DIST += secure_getenv.c EXTRA_libgnu_la_SOURCES += secure_getenv.c @@ -1837,7 +1936,9 @@ EXTRA_DIST += signal.in.h ## begin gnulib module signbit +if gl_GNULIB_ENABLED_signbit +endif EXTRA_DIST += float+.h signbitd.c signbitf.c signbitl.c EXTRA_libgnu_la_SOURCES += signbitd.c signbitf.c signbitl.c @@ -1846,8 +1947,10 @@ EXTRA_libgnu_la_SOURCES += signbitd.c signbitf.c signbitl.c ## begin gnulib module size_max +if gl_GNULIB_ENABLED_size_max libgnu_la_SOURCES += size_max.h +endif ## end gnulib module size_max ## begin gnulib module snippet/_Noreturn @@ -1958,7 +2061,9 @@ EXTRA_DIST += $(top_srcdir)/build-aux/snippet/warn-on-use.h ## begin gnulib module snprintf +if gl_GNULIB_ENABLED_snprintf +endif EXTRA_DIST += snprintf.c EXTRA_libgnu_la_SOURCES += snprintf.c @@ -1976,15 +2081,19 @@ EXTRA_libgnu_la_SOURCES += socket.c ## begin gnulib module sockets +if gl_GNULIB_ENABLED_sockets libgnu_la_SOURCES += sockets.h sockets.c +endif EXTRA_DIST += w32sock.h ## end gnulib module sockets ## begin gnulib module stat +if gl_GNULIB_ENABLED_stat +endif EXTRA_DIST += stat.c EXTRA_libgnu_la_SOURCES += stat.c @@ -2060,6 +2169,7 @@ stddef.h: stddef.in.h $(top_builddir)/config.status -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \ -e 's|@''PRAGMA_COLUMNS''@|@PRAGMA_COLUMNS@|g' \ -e 's|@''NEXT_STDDEF_H''@|$(NEXT_STDDEF_H)|g' \ + -e 's|@''HAVE_MAX_ALIGN_T''@|$(HAVE_MAX_ALIGN_T)|g' \ -e 's|@''HAVE_WCHAR_T''@|$(HAVE_WCHAR_T)|g' \ -e 's|@''REPLACE_NULL''@|$(REPLACE_NULL)|g' \ < $(srcdir)/stddef.in.h; \ @@ -2286,6 +2396,7 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \ -e 's/@''GNULIB_PTSNAME''@/$(GNULIB_PTSNAME)/g' \ -e 's/@''GNULIB_PTSNAME_R''@/$(GNULIB_PTSNAME_R)/g' \ -e 's/@''GNULIB_PUTENV''@/$(GNULIB_PUTENV)/g' \ + -e 's/@''GNULIB_QSORT_R''@/$(GNULIB_QSORT_R)/g' \ -e 's/@''GNULIB_RANDOM''@/$(GNULIB_RANDOM)/g' \ -e 's/@''GNULIB_RANDOM_R''@/$(GNULIB_RANDOM_R)/g' \ -e 's/@''GNULIB_REALLOC_POSIX''@/$(GNULIB_REALLOC_POSIX)/g' \ @@ -2337,6 +2448,7 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \ -e 's|@''REPLACE_PTSNAME''@|$(REPLACE_PTSNAME)|g' \ -e 's|@''REPLACE_PTSNAME_R''@|$(REPLACE_PTSNAME_R)|g' \ -e 's|@''REPLACE_PUTENV''@|$(REPLACE_PUTENV)|g' \ + -e 's|@''REPLACE_QSORT_R''@|$(REPLACE_QSORT_R)|g' \ -e 's|@''REPLACE_RANDOM_R''@|$(REPLACE_RANDOM_R)|g' \ -e 's|@''REPLACE_REALLOC''@|$(REPLACE_REALLOC)|g' \ -e 's|@''REPLACE_REALPATH''@|$(REPLACE_REALPATH)|g' \ @@ -2358,7 +2470,9 @@ EXTRA_DIST += stdlib.in.h ## begin gnulib module strdup-posix +if gl_GNULIB_ENABLED_f9850631dca91859e9cddac9359921c0 +endif EXTRA_DIST += strdup.c EXTRA_libgnu_la_SOURCES += strdup.c @@ -2367,7 +2481,9 @@ EXTRA_libgnu_la_SOURCES += strdup.c ## begin gnulib module streq +if gl_GNULIB_ENABLED_streq +endif EXTRA_DIST += streq.h ## end gnulib module streq @@ -2786,8 +2902,10 @@ EXTRA_DIST += sys_uio.in.h ## begin gnulib module tempname +if gl_GNULIB_ENABLED_tempname libgnu_la_SOURCES += tempname.c +endif EXTRA_DIST += tempname.h ## end gnulib module tempname @@ -2812,10 +2930,12 @@ time.h: time.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $( -e 's/@''GNULIB_STRPTIME''@/$(GNULIB_STRPTIME)/g' \ -e 's/@''GNULIB_TIMEGM''@/$(GNULIB_TIMEGM)/g' \ -e 's/@''GNULIB_TIME_R''@/$(GNULIB_TIME_R)/g' \ + -e 's/@''GNULIB_TIME_RZ''@/$(GNULIB_TIME_RZ)/g' \ -e 's|@''HAVE_DECL_LOCALTIME_R''@|$(HAVE_DECL_LOCALTIME_R)|g' \ -e 's|@''HAVE_NANOSLEEP''@|$(HAVE_NANOSLEEP)|g' \ -e 's|@''HAVE_STRPTIME''@|$(HAVE_STRPTIME)|g' \ -e 's|@''HAVE_TIMEGM''@|$(HAVE_TIMEGM)|g' \ + -e 's|@''HAVE_TIMEZONE_T''@|$(HAVE_TIMEZONE_T)|g' \ -e 's|@''REPLACE_GMTIME''@|$(REPLACE_GMTIME)|g' \ -e 's|@''REPLACE_LOCALTIME''@|$(REPLACE_LOCALTIME)|g' \ -e 's|@''REPLACE_LOCALTIME_R''@|$(REPLACE_LOCALTIME_R)|g' \ @@ -2825,6 +2945,7 @@ time.h: time.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $( -e 's|@''PTHREAD_H_DEFINES_STRUCT_TIMESPEC''@|$(PTHREAD_H_DEFINES_STRUCT_TIMESPEC)|g' \ -e 's|@''SYS_TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(SYS_TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \ -e 's|@''TIME_H_DEFINES_STRUCT_TIMESPEC''@|$(TIME_H_DEFINES_STRUCT_TIMESPEC)|g' \ + -e 's|@''UNISTD_H_DEFINES_STRUCT_TIMESPEC''@|$(UNISTD_H_DEFINES_STRUCT_TIMESPEC)|g' \ -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \ -e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \ -e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \ @@ -2839,13 +2960,35 @@ EXTRA_DIST += time.in.h ## begin gnulib module time_r +if gl_GNULIB_ENABLED_time_r +endif EXTRA_DIST += time_r.c EXTRA_libgnu_la_SOURCES += time_r.c ## end gnulib module time_r +## begin gnulib module time_rz + + +EXTRA_DIST += time-internal.h time_rz.c + +EXTRA_libgnu_la_SOURCES += time_rz.c + +## end gnulib module time_rz + +## begin gnulib module timegm + +if gl_GNULIB_ENABLED_timegm + +endif +EXTRA_DIST += mktime-internal.h timegm.c + +EXTRA_libgnu_la_SOURCES += timegm.c + +## end gnulib module timegm + ## begin gnulib module times @@ -2995,9 +3138,11 @@ unistd.h: unistd.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H -e 's|@''REPLACE_PWRITE''@|$(REPLACE_PWRITE)|g' \ -e 's|@''REPLACE_READ''@|$(REPLACE_READ)|g' \ -e 's|@''REPLACE_READLINK''@|$(REPLACE_READLINK)|g' \ + -e 's|@''REPLACE_READLINKAT''@|$(REPLACE_READLINKAT)|g' \ -e 's|@''REPLACE_RMDIR''@|$(REPLACE_RMDIR)|g' \ -e 's|@''REPLACE_SLEEP''@|$(REPLACE_SLEEP)|g' \ -e 's|@''REPLACE_SYMLINK''@|$(REPLACE_SYMLINK)|g' \ + -e 's|@''REPLACE_SYMLINKAT''@|$(REPLACE_SYMLINKAT)|g' \ -e 's|@''REPLACE_TTYNAME_R''@|$(REPLACE_TTYNAME_R)|g' \ -e 's|@''REPLACE_UNLINK''@|$(REPLACE_UNLINK)|g' \ -e 's|@''REPLACE_UNLINKAT''@|$(REPLACE_UNLINKAT)|g' \ @@ -3088,6 +3233,17 @@ EXTRA_DIST += unitypes.in.h ## end gnulib module unitypes +## begin gnulib module unsetenv + +if gl_GNULIB_ENABLED_unsetenv + +endif +EXTRA_DIST += unsetenv.c + +EXTRA_libgnu_la_SOURCES += unsetenv.c + +## end gnulib module unsetenv + ## begin gnulib module useless-if-before-free @@ -3097,7 +3253,9 @@ EXTRA_DIST += $(top_srcdir)/build-aux/useless-if-before-free ## begin gnulib module vasnprintf +if gl_GNULIB_ENABLED_vasnprintf +endif EXTRA_DIST += asnprintf.c float+.h printf-args.c printf-args.h printf-parse.c printf-parse.h vasnprintf.c vasnprintf.h EXTRA_libgnu_la_SOURCES += asnprintf.c printf-args.c printf-parse.c vasnprintf.c @@ -3250,7 +3408,9 @@ EXTRA_DIST += wchar.in.h ## begin gnulib module wcrtomb +if gl_GNULIB_ENABLED_wcrtomb +endif EXTRA_DIST += wcrtomb.c EXTRA_libgnu_la_SOURCES += wcrtomb.c @@ -3259,6 +3419,7 @@ EXTRA_libgnu_la_SOURCES += wcrtomb.c ## begin gnulib module wctype-h +if gl_GNULIB_ENABLED_3dcce957eadc896e63ab5f137947b410 BUILT_SOURCES += wctype.h libgnu_la_SOURCES += wctype-h.c @@ -3293,6 +3454,7 @@ wctype.h: wctype.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(WARN_ON_USE_H mv $@-t $@ MOSTLYCLEANFILES += wctype.h wctype.h-t +endif EXTRA_DIST += wctype.in.h ## end gnulib module wctype-h @@ -3308,8 +3470,10 @@ EXTRA_libgnu_la_SOURCES += write.c ## begin gnulib module xsize +if gl_GNULIB_ENABLED_xsize libgnu_la_SOURCES += xsize.h xsize.c +endif ## end gnulib module xsize diff --git a/lib/accept.c b/lib/accept.c index b216c6bd6..694d13b19 100644 --- a/lib/accept.c +++ b/lib/accept.c @@ -1,6 +1,6 @@ /* accept.c --- wrappers for Windows accept function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/alignof.h b/lib/alignof.h index 280f3e384..944e935be 100644 --- a/lib/alignof.h +++ b/lib/alignof.h @@ -1,5 +1,5 @@ /* Determine alignment of types. - Copyright (C) 2003-2004, 2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2003-2004, 2006, 2009-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/alloca.in.h b/lib/alloca.in.h index e3aa62d2d..c50e0c9f3 100644 --- a/lib/alloca.in.h +++ b/lib/alloca.in.h @@ -1,6 +1,6 @@ /* Memory allocation on the stack. - Copyright (C) 1995, 1999, 2001-2004, 2006-2014 Free Software Foundation, + Copyright (C) 1995, 1999, 2001-2004, 2006-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it diff --git a/lib/arpa_inet.in.h b/lib/arpa_inet.in.h index 3f5df4776..f9d9e6408 100644 --- a/lib/arpa_inet.in.h +++ b/lib/arpa_inet.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 2005-2006, 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2005-2006, 2008-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/asnprintf.c b/lib/asnprintf.c index 7806f6888..cd20a808e 100644 --- a/lib/asnprintf.c +++ b/lib/asnprintf.c @@ -1,5 +1,5 @@ /* Formatted output to strings. - Copyright (C) 1999, 2002, 2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 1999, 2002, 2006, 2009-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/assure.h b/lib/assure.h new file mode 100644 index 000000000..bb0cb45f4 --- /dev/null +++ b/lib/assure.h @@ -0,0 +1,37 @@ +/* Run-time assert-like macros. + + Copyright (C) 2014-2016 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +/* Written by Paul Eggert. */ + +#ifndef _GL_ASSURE_H +#define _GL_ASSURE_H + +#include + +/* Check E's value at runtime, and report an error and abort if not. + However, do nothng if NDEBUG is defined. + + Unlike standard 'assert', this macro always compiles E even when NDEBUG + is defined, so as to catch typos and avoid some GCC warnings. */ + +#ifdef NDEBUG +# define assure(E) ((void) (0 && (E))) +#else +# define assure(E) assert (E) +#endif + +#endif diff --git a/lib/basename-lgpl.c b/lib/basename-lgpl.c index fe007936f..d91fbfae5 100644 --- a/lib/basename-lgpl.c +++ b/lib/basename-lgpl.c @@ -1,6 +1,6 @@ /* basename.c -- return the last element in a file name - Copyright (C) 1990, 1998-2001, 2003-2006, 2009-2014 Free Software + Copyright (C) 1990, 1998-2001, 2003-2006, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/binary-io.c b/lib/binary-io.c index 8bbdb44d1..d828bcd01 100644 --- a/lib/binary-io.c +++ b/lib/binary-io.c @@ -1,3 +1,4 @@ #include #define BINARY_IO_INLINE _GL_EXTERN_INLINE #include "binary-io.h" +typedef int dummy; diff --git a/lib/binary-io.h b/lib/binary-io.h index c276faa88..ffdae0281 100644 --- a/lib/binary-io.h +++ b/lib/binary-io.h @@ -1,5 +1,5 @@ /* Binary mode I/O. - Copyright (C) 2001, 2003, 2005, 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2001, 2003, 2005, 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -60,7 +60,7 @@ set_binary_mode (int fd, int mode) /* SET_BINARY (fd); changes the file descriptor fd to perform binary I/O. */ -#ifdef __DJGPP__ +#if defined __DJGPP__ || defined __EMX__ # include /* declares isatty() */ /* Avoid putting stdin/stdout in binary mode if it is connected to the console, because that would make it impossible for the user diff --git a/lib/bind.c b/lib/bind.c index 36750c9a8..8111351f6 100644 --- a/lib/bind.c +++ b/lib/bind.c @@ -1,6 +1,6 @@ /* bind.c --- wrappers for Windows bind function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/btowc.c b/lib/btowc.c index aad27f593..f49bc9afa 100644 --- a/lib/btowc.c +++ b/lib/btowc.c @@ -1,5 +1,5 @@ /* Convert unibyte character to wide character. - Copyright (C) 2008, 2010-2014 Free Software Foundation, Inc. + Copyright (C) 2008, 2010-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2008. This program is free software: you can redistribute it and/or modify diff --git a/lib/byteswap.in.h b/lib/byteswap.in.h index 130c79dfb..c73e1a8d2 100644 --- a/lib/byteswap.in.h +++ b/lib/byteswap.in.h @@ -1,5 +1,5 @@ /* byteswap.h - Byte swapping - Copyright (C) 2005, 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2005, 2007, 2009-2016 Free Software Foundation, Inc. Written by Oskar Liljeblad , 2005. This program is free software: you can redistribute it and/or modify diff --git a/lib/c-ctype.c b/lib/c-ctype.c index 7fe3f7efa..5d9d4d87a 100644 --- a/lib/c-ctype.c +++ b/lib/c-ctype.c @@ -1,395 +1,3 @@ -/* Character handling in C locale. - - Copyright 2000-2003, 2006, 2009-2014 Free Software Foundation, Inc. - -This program is free software; you can redistribute it and/or modify -it under the terms of the GNU Lesser General Public License as published by -the Free Software Foundation; either version 2 of the License, or -(at your option) any later version. - -This program is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU Lesser General Public License for more details. - -You should have received a copy of the GNU Lesser General Public License -along with this program; if not, see . */ - #include - -/* Specification. */ -#define NO_C_CTYPE_MACROS +#define C_CTYPE_INLINE _GL_EXTERN_INLINE #include "c-ctype.h" - -/* The function isascii is not locale dependent. Its use in EBCDIC is - questionable. */ -bool -c_isascii (int c) -{ - return (c >= 0x00 && c <= 0x7f); -} - -bool -c_isalnum (int c) -{ -#if C_CTYPE_CONSECUTIVE_DIGITS \ - && C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE -#if C_CTYPE_ASCII - return ((c >= '0' && c <= '9') - || ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'Z')); -#else - return ((c >= '0' && c <= '9') - || (c >= 'A' && c <= 'Z') - || (c >= 'a' && c <= 'z')); -#endif -#else - switch (c) - { - case '0': case '1': case '2': case '3': case '4': case '5': - case '6': case '7': case '8': case '9': - case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': - case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': - case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': - case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': - case 'Y': case 'Z': - case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': - case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': - case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': - case 's': case 't': case 'u': case 'v': case 'w': case 'x': - case 'y': case 'z': - return 1; - default: - return 0; - } -#endif -} - -bool -c_isalpha (int c) -{ -#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE -#if C_CTYPE_ASCII - return ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'Z'); -#else - return ((c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')); -#endif -#else - switch (c) - { - case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': - case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': - case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': - case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': - case 'Y': case 'Z': - case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': - case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': - case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': - case 's': case 't': case 'u': case 'v': case 'w': case 'x': - case 'y': case 'z': - return 1; - default: - return 0; - } -#endif -} - -bool -c_isblank (int c) -{ - return (c == ' ' || c == '\t'); -} - -bool -c_iscntrl (int c) -{ -#if C_CTYPE_ASCII - return ((c & ~0x1f) == 0 || c == 0x7f); -#else - switch (c) - { - case ' ': case '!': case '"': case '#': case '$': case '%': - case '&': case '\'': case '(': case ')': case '*': case '+': - case ',': case '-': case '.': case '/': - case '0': case '1': case '2': case '3': case '4': case '5': - case '6': case '7': case '8': case '9': - case ':': case ';': case '<': case '=': case '>': case '?': - case '@': - case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': - case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': - case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': - case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': - case 'Y': case 'Z': - case '[': case '\\': case ']': case '^': case '_': case '`': - case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': - case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': - case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': - case 's': case 't': case 'u': case 'v': case 'w': case 'x': - case 'y': case 'z': - case '{': case '|': case '}': case '~': - return 0; - default: - return 1; - } -#endif -} - -bool -c_isdigit (int c) -{ -#if C_CTYPE_CONSECUTIVE_DIGITS - return (c >= '0' && c <= '9'); -#else - switch (c) - { - case '0': case '1': case '2': case '3': case '4': case '5': - case '6': case '7': case '8': case '9': - return 1; - default: - return 0; - } -#endif -} - -bool -c_islower (int c) -{ -#if C_CTYPE_CONSECUTIVE_LOWERCASE - return (c >= 'a' && c <= 'z'); -#else - switch (c) - { - case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': - case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': - case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': - case 's': case 't': case 'u': case 'v': case 'w': case 'x': - case 'y': case 'z': - return 1; - default: - return 0; - } -#endif -} - -bool -c_isgraph (int c) -{ -#if C_CTYPE_ASCII - return (c >= '!' && c <= '~'); -#else - switch (c) - { - case '!': case '"': case '#': case '$': case '%': case '&': - case '\'': case '(': case ')': case '*': case '+': case ',': - case '-': case '.': case '/': - case '0': case '1': case '2': case '3': case '4': case '5': - case '6': case '7': case '8': case '9': - case ':': case ';': case '<': case '=': case '>': case '?': - case '@': - case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': - case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': - case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': - case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': - case 'Y': case 'Z': - case '[': case '\\': case ']': case '^': case '_': case '`': - case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': - case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': - case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': - case 's': case 't': case 'u': case 'v': case 'w': case 'x': - case 'y': case 'z': - case '{': case '|': case '}': case '~': - return 1; - default: - return 0; - } -#endif -} - -bool -c_isprint (int c) -{ -#if C_CTYPE_ASCII - return (c >= ' ' && c <= '~'); -#else - switch (c) - { - case ' ': case '!': case '"': case '#': case '$': case '%': - case '&': case '\'': case '(': case ')': case '*': case '+': - case ',': case '-': case '.': case '/': - case '0': case '1': case '2': case '3': case '4': case '5': - case '6': case '7': case '8': case '9': - case ':': case ';': case '<': case '=': case '>': case '?': - case '@': - case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': - case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': - case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': - case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': - case 'Y': case 'Z': - case '[': case '\\': case ']': case '^': case '_': case '`': - case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': - case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': - case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': - case 's': case 't': case 'u': case 'v': case 'w': case 'x': - case 'y': case 'z': - case '{': case '|': case '}': case '~': - return 1; - default: - return 0; - } -#endif -} - -bool -c_ispunct (int c) -{ -#if C_CTYPE_ASCII - return ((c >= '!' && c <= '~') - && !((c >= '0' && c <= '9') - || ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'Z'))); -#else - switch (c) - { - case '!': case '"': case '#': case '$': case '%': case '&': - case '\'': case '(': case ')': case '*': case '+': case ',': - case '-': case '.': case '/': - case ':': case ';': case '<': case '=': case '>': case '?': - case '@': - case '[': case '\\': case ']': case '^': case '_': case '`': - case '{': case '|': case '}': case '~': - return 1; - default: - return 0; - } -#endif -} - -bool -c_isspace (int c) -{ - return (c == ' ' || c == '\t' - || c == '\n' || c == '\v' || c == '\f' || c == '\r'); -} - -bool -c_isupper (int c) -{ -#if C_CTYPE_CONSECUTIVE_UPPERCASE - return (c >= 'A' && c <= 'Z'); -#else - switch (c) - { - case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': - case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': - case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': - case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': - case 'Y': case 'Z': - return 1; - default: - return 0; - } -#endif -} - -bool -c_isxdigit (int c) -{ -#if C_CTYPE_CONSECUTIVE_DIGITS \ - && C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE -#if C_CTYPE_ASCII - return ((c >= '0' && c <= '9') - || ((c & ~0x20) >= 'A' && (c & ~0x20) <= 'F')); -#else - return ((c >= '0' && c <= '9') - || (c >= 'A' && c <= 'F') - || (c >= 'a' && c <= 'f')); -#endif -#else - switch (c) - { - case '0': case '1': case '2': case '3': case '4': case '5': - case '6': case '7': case '8': case '9': - case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': - case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': - return 1; - default: - return 0; - } -#endif -} - -int -c_tolower (int c) -{ -#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE - return (c >= 'A' && c <= 'Z' ? c - 'A' + 'a' : c); -#else - switch (c) - { - case 'A': return 'a'; - case 'B': return 'b'; - case 'C': return 'c'; - case 'D': return 'd'; - case 'E': return 'e'; - case 'F': return 'f'; - case 'G': return 'g'; - case 'H': return 'h'; - case 'I': return 'i'; - case 'J': return 'j'; - case 'K': return 'k'; - case 'L': return 'l'; - case 'M': return 'm'; - case 'N': return 'n'; - case 'O': return 'o'; - case 'P': return 'p'; - case 'Q': return 'q'; - case 'R': return 'r'; - case 'S': return 's'; - case 'T': return 't'; - case 'U': return 'u'; - case 'V': return 'v'; - case 'W': return 'w'; - case 'X': return 'x'; - case 'Y': return 'y'; - case 'Z': return 'z'; - default: return c; - } -#endif -} - -int -c_toupper (int c) -{ -#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE - return (c >= 'a' && c <= 'z' ? c - 'a' + 'A' : c); -#else - switch (c) - { - case 'a': return 'A'; - case 'b': return 'B'; - case 'c': return 'C'; - case 'd': return 'D'; - case 'e': return 'E'; - case 'f': return 'F'; - case 'g': return 'G'; - case 'h': return 'H'; - case 'i': return 'I'; - case 'j': return 'J'; - case 'k': return 'K'; - case 'l': return 'L'; - case 'm': return 'M'; - case 'n': return 'N'; - case 'o': return 'O'; - case 'p': return 'P'; - case 'q': return 'Q'; - case 'r': return 'R'; - case 's': return 'S'; - case 't': return 'T'; - case 'u': return 'U'; - case 'v': return 'V'; - case 'w': return 'W'; - case 'x': return 'X'; - case 'y': return 'Y'; - case 'z': return 'Z'; - default: return c; - } -#endif -} diff --git a/lib/c-ctype.h b/lib/c-ctype.h index a258019f4..177e8c26c 100644 --- a/lib/c-ctype.h +++ b/lib/c-ctype.h @@ -5,7 +5,7 @@ functions' behaviour depends on the current locale set via setlocale. - Copyright (C) 2000-2003, 2006, 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2000-2003, 2006, 2008-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -25,6 +25,13 @@ along with this program; if not, see . */ #include +#ifndef _GL_INLINE_HEADER_BEGIN + #error "Please include config.h first." +#endif +_GL_INLINE_HEADER_BEGIN +#ifndef C_CTYPE_INLINE +# define C_CTYPE_INLINE _GL_INLINE +#endif #ifdef __cplusplus extern "C" { @@ -39,38 +46,6 @@ extern "C" { characters. */ -/* Check whether the ASCII optimizations apply. */ - -/* ANSI C89 (and ISO C99 5.2.1.3 too) already guarantees that - '0', '1', ..., '9' have consecutive integer values. */ -#define C_CTYPE_CONSECUTIVE_DIGITS 1 - -#if ('A' <= 'Z') \ - && ('A' + 1 == 'B') && ('B' + 1 == 'C') && ('C' + 1 == 'D') \ - && ('D' + 1 == 'E') && ('E' + 1 == 'F') && ('F' + 1 == 'G') \ - && ('G' + 1 == 'H') && ('H' + 1 == 'I') && ('I' + 1 == 'J') \ - && ('J' + 1 == 'K') && ('K' + 1 == 'L') && ('L' + 1 == 'M') \ - && ('M' + 1 == 'N') && ('N' + 1 == 'O') && ('O' + 1 == 'P') \ - && ('P' + 1 == 'Q') && ('Q' + 1 == 'R') && ('R' + 1 == 'S') \ - && ('S' + 1 == 'T') && ('T' + 1 == 'U') && ('U' + 1 == 'V') \ - && ('V' + 1 == 'W') && ('W' + 1 == 'X') && ('X' + 1 == 'Y') \ - && ('Y' + 1 == 'Z') -#define C_CTYPE_CONSECUTIVE_UPPERCASE 1 -#endif - -#if ('a' <= 'z') \ - && ('a' + 1 == 'b') && ('b' + 1 == 'c') && ('c' + 1 == 'd') \ - && ('d' + 1 == 'e') && ('e' + 1 == 'f') && ('f' + 1 == 'g') \ - && ('g' + 1 == 'h') && ('h' + 1 == 'i') && ('i' + 1 == 'j') \ - && ('j' + 1 == 'k') && ('k' + 1 == 'l') && ('l' + 1 == 'm') \ - && ('m' + 1 == 'n') && ('n' + 1 == 'o') && ('o' + 1 == 'p') \ - && ('p' + 1 == 'q') && ('q' + 1 == 'r') && ('r' + 1 == 's') \ - && ('s' + 1 == 't') && ('t' + 1 == 'u') && ('u' + 1 == 'v') \ - && ('v' + 1 == 'w') && ('w' + 1 == 'x') && ('x' + 1 == 'y') \ - && ('y' + 1 == 'z') -#define C_CTYPE_CONSECUTIVE_LOWERCASE 1 -#endif - #if (' ' == 32) && ('!' == 33) && ('"' == 34) && ('#' == 35) \ && ('%' == 37) && ('&' == 38) && ('\'' == 39) && ('(' == 40) \ && (')' == 41) && ('*' == 42) && ('+' == 43) && (',' == 44) \ @@ -96,11 +71,84 @@ extern "C" { && ('{' == 123) && ('|' == 124) && ('}' == 125) && ('~' == 126) /* The character set is ASCII or one of its variants or extensions, not EBCDIC. Testing the value of '\n' and '\r' is not relevant. */ -#define C_CTYPE_ASCII 1 +# define C_CTYPE_ASCII 1 +#elif ! (' ' == '\x40' && '0' == '\xf0' \ + && 'A' == '\xc1' && 'J' == '\xd1' && 'S' == '\xe2' \ + && 'a' == '\x81' && 'j' == '\x91' && 's' == '\xa2') +# error "Only ASCII and EBCDIC are supported" #endif +#if 'A' < 0 +# error "EBCDIC and char is signed -- not supported" +#endif -/* Function declarations. */ +/* Cases for control characters. */ + +#define _C_CTYPE_CNTRL \ + case '\a': case '\b': case '\f': case '\n': \ + case '\r': case '\t': case '\v': \ + _C_CTYPE_OTHER_CNTRL + +/* ASCII control characters other than those with \-letter escapes. */ + +#if C_CTYPE_ASCII +# define _C_CTYPE_OTHER_CNTRL \ + case '\x00': case '\x01': case '\x02': case '\x03': \ + case '\x04': case '\x05': case '\x06': case '\x0e': \ + case '\x0f': case '\x10': case '\x11': case '\x12': \ + case '\x13': case '\x14': case '\x15': case '\x16': \ + case '\x17': case '\x18': case '\x19': case '\x1a': \ + case '\x1b': case '\x1c': case '\x1d': case '\x1e': \ + case '\x1f': case '\x7f' +#else + /* Use EBCDIC code page 1047's assignments for ASCII control chars; + assume all EBCDIC code pages agree about these assignments. */ +# define _C_CTYPE_OTHER_CNTRL \ + case '\x00': case '\x01': case '\x02': case '\x03': \ + case '\x07': case '\x0e': case '\x0f': case '\x10': \ + case '\x11': case '\x12': case '\x13': case '\x18': \ + case '\x19': case '\x1c': case '\x1d': case '\x1e': \ + case '\x1f': case '\x26': case '\x27': case '\x2d': \ + case '\x2e': case '\x32': case '\x37': case '\x3c': \ + case '\x3d': case '\x3f' +#endif + +/* Cases for lowercase hex letters, and lowercase letters, all offset by N. */ + +#define _C_CTYPE_LOWER_A_THRU_F_N(n) \ + case 'a' + (n): case 'b' + (n): case 'c' + (n): case 'd' + (n): \ + case 'e' + (n): case 'f' + (n) +#define _C_CTYPE_LOWER_N(n) \ + _C_CTYPE_LOWER_A_THRU_F_N(n): \ + case 'g' + (n): case 'h' + (n): case 'i' + (n): case 'j' + (n): \ + case 'k' + (n): case 'l' + (n): case 'm' + (n): case 'n' + (n): \ + case 'o' + (n): case 'p' + (n): case 'q' + (n): case 'r' + (n): \ + case 's' + (n): case 't' + (n): case 'u' + (n): case 'v' + (n): \ + case 'w' + (n): case 'x' + (n): case 'y' + (n): case 'z' + (n) + +/* Cases for hex letters, digits, lower, punct, and upper. */ + +#define _C_CTYPE_A_THRU_F \ + _C_CTYPE_LOWER_A_THRU_F_N (0): \ + _C_CTYPE_LOWER_A_THRU_F_N ('A' - 'a') +#define _C_CTYPE_DIGIT \ + case '0': case '1': case '2': case '3': \ + case '4': case '5': case '6': case '7': \ + case '8': case '9' +#define _C_CTYPE_LOWER _C_CTYPE_LOWER_N (0) +#define _C_CTYPE_PUNCT \ + case '!': case '"': case '#': case '$': \ + case '%': case '&': case '\'': case '(': \ + case ')': case '*': case '+': case ',': \ + case '-': case '.': case '/': case ':': \ + case ';': case '<': case '=': case '>': \ + case '?': case '@': case '[': case '\\': \ + case ']': case '^': case '_': case '`': \ + case '{': case '|': case '}': case '~' +#define _C_CTYPE_UPPER _C_CTYPE_LOWER_N ('A' - 'a') + + +/* Function definitions. */ /* Unlike the functions in , which require an argument in the range of the 'unsigned char' type, the functions here operate on values that are @@ -117,179 +165,202 @@ extern "C" { if (c_isalpha (*s)) ... */ -extern bool c_isascii (int c) _GL_ATTRIBUTE_CONST; /* not locale dependent */ +C_CTYPE_INLINE bool +c_isalnum (int c) +{ + switch (c) + { + _C_CTYPE_DIGIT: + _C_CTYPE_LOWER: + _C_CTYPE_UPPER: + return true; + default: + return false; + } +} -extern bool c_isalnum (int c) _GL_ATTRIBUTE_CONST; -extern bool c_isalpha (int c) _GL_ATTRIBUTE_CONST; -extern bool c_isblank (int c) _GL_ATTRIBUTE_CONST; -extern bool c_iscntrl (int c) _GL_ATTRIBUTE_CONST; -extern bool c_isdigit (int c) _GL_ATTRIBUTE_CONST; -extern bool c_islower (int c) _GL_ATTRIBUTE_CONST; -extern bool c_isgraph (int c) _GL_ATTRIBUTE_CONST; -extern bool c_isprint (int c) _GL_ATTRIBUTE_CONST; -extern bool c_ispunct (int c) _GL_ATTRIBUTE_CONST; -extern bool c_isspace (int c) _GL_ATTRIBUTE_CONST; -extern bool c_isupper (int c) _GL_ATTRIBUTE_CONST; -extern bool c_isxdigit (int c) _GL_ATTRIBUTE_CONST; +C_CTYPE_INLINE bool +c_isalpha (int c) +{ + switch (c) + { + _C_CTYPE_LOWER: + _C_CTYPE_UPPER: + return true; + default: + return false; + } +} -extern int c_tolower (int c) _GL_ATTRIBUTE_CONST; -extern int c_toupper (int c) _GL_ATTRIBUTE_CONST; +/* The function isascii is not locale dependent. + Its use in EBCDIC is questionable. */ +C_CTYPE_INLINE bool +c_isascii (int c) +{ + switch (c) + { + case ' ': + _C_CTYPE_CNTRL: + _C_CTYPE_DIGIT: + _C_CTYPE_LOWER: + _C_CTYPE_PUNCT: + _C_CTYPE_UPPER: + return true; + default: + return false; + } +} +C_CTYPE_INLINE bool +c_isblank (int c) +{ + return c == ' ' || c == '\t'; +} -#if (defined __GNUC__ && !defined __STRICT_ANSI__ && defined __OPTIMIZE__ \ - && !defined __OPTIMIZE_SIZE__ && !defined NO_C_CTYPE_MACROS) +C_CTYPE_INLINE bool +c_iscntrl (int c) +{ + switch (c) + { + _C_CTYPE_CNTRL: + return true; + default: + return false; + } +} -/* ASCII optimizations. */ +C_CTYPE_INLINE bool +c_isdigit (int c) +{ + switch (c) + { + _C_CTYPE_DIGIT: + return true; + default: + return false; + } +} -#undef c_isascii -#define c_isascii(c) \ - ({ int __c = (c); \ - (__c >= 0x00 && __c <= 0x7f); \ - }) +C_CTYPE_INLINE bool +c_isgraph (int c) +{ + switch (c) + { + _C_CTYPE_DIGIT: + _C_CTYPE_LOWER: + _C_CTYPE_PUNCT: + _C_CTYPE_UPPER: + return true; + default: + return false; + } +} -#if C_CTYPE_CONSECUTIVE_DIGITS \ - && C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE -#if C_CTYPE_ASCII -#undef c_isalnum -#define c_isalnum(c) \ - ({ int __c = (c); \ - ((__c >= '0' && __c <= '9') \ - || ((__c & ~0x20) >= 'A' && (__c & ~0x20) <= 'Z')); \ - }) -#else -#undef c_isalnum -#define c_isalnum(c) \ - ({ int __c = (c); \ - ((__c >= '0' && __c <= '9') \ - || (__c >= 'A' && __c <= 'Z') \ - || (__c >= 'a' && __c <= 'z')); \ - }) -#endif -#endif +C_CTYPE_INLINE bool +c_islower (int c) +{ + switch (c) + { + _C_CTYPE_LOWER: + return true; + default: + return false; + } +} -#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE -#if C_CTYPE_ASCII -#undef c_isalpha -#define c_isalpha(c) \ - ({ int __c = (c); \ - ((__c & ~0x20) >= 'A' && (__c & ~0x20) <= 'Z'); \ - }) -#else -#undef c_isalpha -#define c_isalpha(c) \ - ({ int __c = (c); \ - ((__c >= 'A' && __c <= 'Z') || (__c >= 'a' && __c <= 'z')); \ - }) -#endif -#endif +C_CTYPE_INLINE bool +c_isprint (int c) +{ + switch (c) + { + case ' ': + _C_CTYPE_DIGIT: + _C_CTYPE_LOWER: + _C_CTYPE_PUNCT: + _C_CTYPE_UPPER: + return true; + default: + return false; + } +} -#undef c_isblank -#define c_isblank(c) \ - ({ int __c = (c); \ - (__c == ' ' || __c == '\t'); \ - }) +C_CTYPE_INLINE bool +c_ispunct (int c) +{ + switch (c) + { + _C_CTYPE_PUNCT: + return true; + default: + return false; + } +} -#if C_CTYPE_ASCII -#undef c_iscntrl -#define c_iscntrl(c) \ - ({ int __c = (c); \ - ((__c & ~0x1f) == 0 || __c == 0x7f); \ - }) -#endif +C_CTYPE_INLINE bool +c_isspace (int c) +{ + switch (c) + { + case ' ': case '\t': case '\n': case '\v': case '\f': case '\r': + return true; + default: + return false; + } +} -#if C_CTYPE_CONSECUTIVE_DIGITS -#undef c_isdigit -#define c_isdigit(c) \ - ({ int __c = (c); \ - (__c >= '0' && __c <= '9'); \ - }) -#endif +C_CTYPE_INLINE bool +c_isupper (int c) +{ + switch (c) + { + _C_CTYPE_UPPER: + return true; + default: + return false; + } +} -#if C_CTYPE_CONSECUTIVE_LOWERCASE -#undef c_islower -#define c_islower(c) \ - ({ int __c = (c); \ - (__c >= 'a' && __c <= 'z'); \ - }) -#endif +C_CTYPE_INLINE bool +c_isxdigit (int c) +{ + switch (c) + { + _C_CTYPE_DIGIT: + _C_CTYPE_A_THRU_F: + return true; + default: + return false; + } +} -#if C_CTYPE_ASCII -#undef c_isgraph -#define c_isgraph(c) \ - ({ int __c = (c); \ - (__c >= '!' && __c <= '~'); \ - }) -#endif - -#if C_CTYPE_ASCII -#undef c_isprint -#define c_isprint(c) \ - ({ int __c = (c); \ - (__c >= ' ' && __c <= '~'); \ - }) -#endif - -#if C_CTYPE_ASCII -#undef c_ispunct -#define c_ispunct(c) \ - ({ int _c = (c); \ - (c_isgraph (_c) && ! c_isalnum (_c)); \ - }) -#endif - -#undef c_isspace -#define c_isspace(c) \ - ({ int __c = (c); \ - (__c == ' ' || __c == '\t' \ - || __c == '\n' || __c == '\v' || __c == '\f' || __c == '\r'); \ - }) - -#if C_CTYPE_CONSECUTIVE_UPPERCASE -#undef c_isupper -#define c_isupper(c) \ - ({ int __c = (c); \ - (__c >= 'A' && __c <= 'Z'); \ - }) -#endif - -#if C_CTYPE_CONSECUTIVE_DIGITS \ - && C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE -#if C_CTYPE_ASCII -#undef c_isxdigit -#define c_isxdigit(c) \ - ({ int __c = (c); \ - ((__c >= '0' && __c <= '9') \ - || ((__c & ~0x20) >= 'A' && (__c & ~0x20) <= 'F')); \ - }) -#else -#undef c_isxdigit -#define c_isxdigit(c) \ - ({ int __c = (c); \ - ((__c >= '0' && __c <= '9') \ - || (__c >= 'A' && __c <= 'F') \ - || (__c >= 'a' && __c <= 'f')); \ - }) -#endif -#endif - -#if C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE -#undef c_tolower -#define c_tolower(c) \ - ({ int __c = (c); \ - (__c >= 'A' && __c <= 'Z' ? __c - 'A' + 'a' : __c); \ - }) -#undef c_toupper -#define c_toupper(c) \ - ({ int __c = (c); \ - (__c >= 'a' && __c <= 'z' ? __c - 'a' + 'A' : __c); \ - }) -#endif - -#endif /* optimizing for speed */ +C_CTYPE_INLINE int +c_tolower (int c) +{ + switch (c) + { + _C_CTYPE_UPPER: + return c - 'A' + 'a'; + default: + return c; + } +} +C_CTYPE_INLINE int +c_toupper (int c) +{ + switch (c) + { + _C_CTYPE_LOWER: + return c - 'a' + 'A'; + default: + return c; + } +} #ifdef __cplusplus } #endif +_GL_INLINE_HEADER_END + #endif /* C_CTYPE_H */ diff --git a/lib/c-strcase.h b/lib/c-strcase.h index ee3bd3f72..5a5ef810d 100644 --- a/lib/c-strcase.h +++ b/lib/c-strcase.h @@ -1,5 +1,5 @@ /* Case-insensitive string comparison functions in C locale. - Copyright (C) 1995-1996, 2001, 2003, 2005, 2009-2014 Free Software + Copyright (C) 1995-1996, 2001, 2003, 2005, 2009-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/c-strcasecmp.c b/lib/c-strcasecmp.c index 5059cc659..1b3e57454 100644 --- a/lib/c-strcasecmp.c +++ b/lib/c-strcasecmp.c @@ -1,5 +1,5 @@ /* c-strcasecmp.c -- case insensitive string comparator in C locale - Copyright (C) 1998-1999, 2005-2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 1998-1999, 2005-2006, 2009-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/c-strcaseeq.h b/lib/c-strcaseeq.h index 44d375148..f9a5d861c 100644 --- a/lib/c-strcaseeq.h +++ b/lib/c-strcaseeq.h @@ -1,5 +1,5 @@ /* Optimized case-insensitive string comparison in C locale. - Copyright (C) 2001-2002, 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2001-2002, 2007, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published @@ -33,9 +33,6 @@ # if C_CTYPE_ASCII # define CASEEQ(other,upper) \ (c_isupper (upper) ? ((other) & ~0x20) == (upper) : (other) == (upper)) -# elif C_CTYPE_CONSECUTIVE_UPPERCASE && C_CTYPE_CONSECUTIVE_LOWERCASE -# define CASEEQ(other,upper) \ - (c_isupper (upper) ? (other) == (upper) || (other) == (upper) - 'A' + 'a' : (other) == (upper)) # else # define CASEEQ(other,upper) \ (c_toupper (other) == (upper)) diff --git a/lib/c-strncasecmp.c b/lib/c-strncasecmp.c index 614598156..c6436e0db 100644 --- a/lib/c-strncasecmp.c +++ b/lib/c-strncasecmp.c @@ -1,5 +1,5 @@ /* c-strncasecmp.c -- case insensitive string comparator in C locale - Copyright (C) 1998-1999, 2005-2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 1998-1999, 2005-2006, 2009-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/canonicalize-lgpl.c b/lib/canonicalize-lgpl.c index a999c9c84..23b9d6aa6 100644 --- a/lib/canonicalize-lgpl.c +++ b/lib/canonicalize-lgpl.c @@ -1,5 +1,5 @@ /* Return the canonical absolute name of a given file. - Copyright (C) 1996-2014 Free Software Foundation, Inc. + Copyright (C) 1996-2016 Free Software Foundation, Inc. This file is part of the GNU C Library. This program is free software: you can redistribute it and/or modify diff --git a/lib/ceil.c b/lib/ceil.c index 7e810357b..ac9640772 100644 --- a/lib/ceil.c +++ b/lib/ceil.c @@ -1,5 +1,5 @@ /* Round towards positive infinity. - Copyright (C) 2007, 2010-2014 Free Software Foundation, Inc. + Copyright (C) 2007, 2010-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/close.c b/lib/close.c index 9d2e0276a..730d6747c 100644 --- a/lib/close.c +++ b/lib/close.c @@ -1,5 +1,5 @@ /* close replacement. - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/config.charset b/lib/config.charset index 8fe2507d9..05773ddf3 100644 --- a/lib/config.charset +++ b/lib/config.charset @@ -1,7 +1,7 @@ #! /bin/sh # Output a system dependent table of character encoding aliases. # -# Copyright (C) 2000-2004, 2006-2014 Free Software Foundation, Inc. +# Copyright (C) 2000-2004, 2006-2016 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU Lesser General Public License as published by @@ -348,12 +348,10 @@ case "$os" in #echo "sun_eu_greek ?" # what is this? echo "UTF-8 UTF-8" ;; - freebsd* | os2*) + freebsd*) # FreeBSD 4.2 doesn't have nl_langinfo(CODESET); therefore # localcharset.c falls back to using the full locale name # from the environment variables. - # Likewise for OS/2. OS/2 has XFree86 just like FreeBSD. Just - # reuse FreeBSD's locale data for OS/2. echo "C ASCII" echo "US-ASCII ASCII" for l in la_LN lt_LN; do diff --git a/lib/connect.c b/lib/connect.c index 295fe95d8..1c7dddd94 100644 --- a/lib/connect.c +++ b/lib/connect.c @@ -1,6 +1,6 @@ /* connect.c --- wrappers for Windows connect function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/copysign.c b/lib/copysign.c index 616ea356e..5a172bf4d 100644 --- a/lib/copysign.c +++ b/lib/copysign.c @@ -1,5 +1,5 @@ /* Copy sign into another 'double' number. - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/dirent.in.h b/lib/dirent.in.h index 3418bd9dc..ab872a7a2 100644 --- a/lib/dirent.in.h +++ b/lib/dirent.in.h @@ -1,5 +1,5 @@ /* A GNU-like . - Copyright (C) 2006-2014 Free Software Foundation, Inc. + Copyright (C) 2006-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -77,6 +77,7 @@ typedef struct gl_directory DIR; # if !(defined __cplusplus && defined GNULIB_NAMESPACE) # undef opendir # define opendir rpl_opendir +# define GNULIB_defined_opendir 1 # endif _GL_FUNCDECL_RPL (opendir, DIR *, (const char *dir_name) _GL_ARG_NONNULL ((1))); _GL_CXXALIAS_RPL (opendir, DIR *, (const char *dir_name)); @@ -128,6 +129,7 @@ _GL_WARN_ON_USE (rewinddir, "rewinddir is not portable - " # if !(defined __cplusplus && defined GNULIB_NAMESPACE) # undef closedir # define closedir rpl_closedir +# define GNULIB_defined_closedir 1 # endif _GL_FUNCDECL_RPL (closedir, int, (DIR *dirp) _GL_ARG_NONNULL ((1))); _GL_CXXALIAS_RPL (closedir, int, (DIR *dirp)); @@ -156,6 +158,13 @@ _GL_WARN_ON_USE (closedir, "closedir is not portable - " # endif _GL_FUNCDECL_RPL (dirfd, int, (DIR *) _GL_ARG_NONNULL ((1))); _GL_CXXALIAS_RPL (dirfd, int, (DIR *)); + +# ifdef __KLIBC__ +/* Gnulib internal hooks needed to maintain the dirfd metadata. */ +_GL_EXTERN_C int _gl_register_dirp_fd (int fd, DIR *dirp) + _GL_ARG_NONNULL ((2)); +_GL_EXTERN_C void _gl_unregister_dirp_fd (int fd); +# endif # else # if defined __cplusplus && defined GNULIB_NAMESPACE && defined dirfd /* dirfd is defined as a macro and not as a function. diff --git a/lib/dirfd.c b/lib/dirfd.c index 86f8e0a1a..4e41830df 100644 --- a/lib/dirfd.c +++ b/lib/dirfd.c @@ -1,6 +1,6 @@ /* dirfd.c -- return the file descriptor associated with an open DIR* - Copyright (C) 2001, 2006, 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2001, 2006, 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -22,11 +22,77 @@ #include #include +#ifdef __KLIBC__ +# include +# include + +static struct dirp_fd_list +{ + DIR *dirp; + int fd; + struct dirp_fd_list *next; +} *dirp_fd_start = NULL; + +/* Register fd associated with dirp to dirp_fd_list. */ +int +_gl_register_dirp_fd (int fd, DIR *dirp) +{ + struct dirp_fd_list *new_dirp_fd = malloc (sizeof *new_dirp_fd); + if (!new_dirp_fd) + return -1; + + new_dirp_fd->dirp = dirp; + new_dirp_fd->fd = fd; + new_dirp_fd->next = dirp_fd_start; + + dirp_fd_start = new_dirp_fd; + + return 0; +} + +/* Unregister fd from dirp_fd_list with closing it */ +void +_gl_unregister_dirp_fd (int fd) +{ + struct dirp_fd_list *dirp_fd; + struct dirp_fd_list *dirp_fd_prev; + + for (dirp_fd_prev = NULL, dirp_fd = dirp_fd_start; dirp_fd; + dirp_fd_prev = dirp_fd, dirp_fd = dirp_fd->next) + { + if (dirp_fd->fd == fd) + { + if (dirp_fd_prev) + dirp_fd_prev->next = dirp_fd->next; + else /* dirp_fd == dirp_fd_start */ + dirp_fd_start = dirp_fd_start->next; + + close (fd); + free (dirp_fd); + break; + } + } +} +#endif + int dirfd (DIR *dir_p) { int fd = DIR_TO_FD (dir_p); if (fd == -1) +#ifndef __KLIBC__ errno = ENOTSUP; +#else + { + struct dirp_fd_list *dirp_fd; + + for (dirp_fd = dirp_fd_start; dirp_fd; dirp_fd = dirp_fd->next) + if (dirp_fd->dirp == dir_p) + return dirp_fd->fd; + + errno = EINVAL; + } +#endif + return fd; } diff --git a/lib/dirname-lgpl.c b/lib/dirname-lgpl.c index 121d38754..6740f2027 100644 --- a/lib/dirname-lgpl.c +++ b/lib/dirname-lgpl.c @@ -1,6 +1,6 @@ /* dirname.c -- return all but the last element in a file name - Copyright (C) 1990, 1998, 2000-2001, 2003-2006, 2009-2014 Free Software + Copyright (C) 1990, 1998, 2000-2001, 2003-2006, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/dirname.h b/lib/dirname.h index e31cb6190..d74ea71dc 100644 --- a/lib/dirname.h +++ b/lib/dirname.h @@ -1,6 +1,6 @@ /* Take file names apart into directory and base names. - Copyright (C) 1998, 2001, 2003-2006, 2009-2014 Free Software Foundation, + Copyright (C) 1998, 2001, 2003-2006, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify @@ -31,6 +31,10 @@ # define DOUBLE_SLASH_IS_DISTINCT_ROOT 0 # endif +#ifdef __cplusplus +extern "C" { +#endif + # if GNULIB_DIRNAME char *base_name (char const *file); char *dir_name (char const *file); @@ -43,4 +47,8 @@ char *last_component (char const *file) _GL_ATTRIBUTE_PURE; bool strip_trailing_slashes (char *file); +#ifdef __cplusplus +} /* extern "C" */ +#endif + #endif /* not DIRNAME_H_ */ diff --git a/lib/dosname.h b/lib/dosname.h index b81163d4b..d451076e0 100644 --- a/lib/dosname.h +++ b/lib/dosname.h @@ -1,6 +1,6 @@ /* File names on MS-DOS/Windows systems. - Copyright (C) 2000-2001, 2004-2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2000-2001, 2004-2006, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/dup2.c b/lib/dup2.c index 9709b7a64..bb33eacdf 100644 --- a/lib/dup2.c +++ b/lib/dup2.c @@ -1,6 +1,6 @@ /* Duplicate an open file descriptor to a specified file descriptor. - Copyright (C) 1999, 2004-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 1999, 2004-2007, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -85,6 +85,57 @@ ms_windows_dup2 (int fd, int desired_fd) # define dup2 ms_windows_dup2 +# elif defined __KLIBC__ + +# include + +static int +klibc_dup2dirfd (int fd, int desired_fd) +{ + int tempfd; + int dupfd; + + tempfd = open ("NUL", O_RDONLY); + if (tempfd == -1) + return -1; + + if (tempfd == desired_fd) + { + close (tempfd); + + char path[_MAX_PATH]; + if (__libc_Back_ioFHToPath (fd, path, sizeof (path))) + return -1; + + return open(path, O_RDONLY); + } + + dupfd = klibc_dup2dirfd (fd, desired_fd); + + close (tempfd); + + return dupfd; +} + +static int +klibc_dup2 (int fd, int desired_fd) +{ + int dupfd; + struct stat sbuf; + + dupfd = dup2 (fd, desired_fd); + if (dupfd == -1 && errno == ENOTSUP \ + && !fstat (fd, &sbuf) && S_ISDIR (sbuf.st_mode)) + { + close (desired_fd); + + return klibc_dup2dirfd (fd, desired_fd); + } + + return dupfd; +} + +# define dup2 klibc_dup2 # endif int diff --git a/lib/duplocale.c b/lib/duplocale.c index 86d5ce59a..c9f9e4932 100644 --- a/lib/duplocale.c +++ b/lib/duplocale.c @@ -1,5 +1,5 @@ /* Duplicate a locale object. - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/errno.in.h b/lib/errno.in.h index 8dbb5f97a..3e1b5b510 100644 --- a/lib/errno.in.h +++ b/lib/errno.in.h @@ -1,6 +1,6 @@ /* A POSIX-like . - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/fcntl.in.h b/lib/fcntl.in.h index 1cd197002..d4e34fe13 100644 --- a/lib/fcntl.in.h +++ b/lib/fcntl.in.h @@ -1,6 +1,6 @@ /* Like , but with non-working flags defined to 0. - Copyright (C) 2006-2014 Free Software Foundation, Inc. + Copyright (C) 2006-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -34,7 +34,7 @@ extern "C" { ... } block, which leads to errors in C++ mode with the overridden from gnulib. These errors are known to be gone with g++ version >= 4.3. */ -#if !(defined __GLIBC__ || defined __UCLIBC__) || (defined __cplusplus && defined GNULIB_NAMESPACE && !(__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3))) +#if !(defined __GLIBC__ || defined __UCLIBC__) || (defined __cplusplus && defined GNULIB_NAMESPACE && (defined __ICC || !(__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3)))) # include #endif #@INCLUDE_NEXT@ @NEXT_FCNTL_H@ @@ -53,7 +53,7 @@ extern "C" { ... } block, which leads to errors in C++ mode with the overridden from gnulib. These errors are known to be gone with g++ version >= 4.3. */ -#if !(defined __GLIBC__ || defined __UCLIBC__) || (defined __cplusplus && defined GNULIB_NAMESPACE && !(__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3))) +#if !(defined __GLIBC__ || defined __UCLIBC__) || (defined __cplusplus && defined GNULIB_NAMESPACE && (defined __ICC || !(__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3)))) # include #endif /* The include_next requires a split double-inclusion guard. */ @@ -186,6 +186,22 @@ _GL_WARN_ON_USE (openat, "openat is not portable - " /* Fix up the O_* macros. */ +/* AIX 7.1 with XL C 12.1 defines O_CLOEXEC, O_NOFOLLOW, and O_TTY_INIT + to values outside 'int' range, so omit these misdefinitions. + But avoid namespace pollution on non-AIX systems. */ +#ifdef _AIX +# include +# if defined O_CLOEXEC && ! (INT_MIN <= O_CLOEXEC && O_CLOEXEC <= INT_MAX) +# undef O_CLOEXEC +# endif +# if defined O_NOFOLLOW && ! (INT_MIN <= O_NOFOLLOW && O_NOFOLLOW <= INT_MAX) +# undef O_NOFOLLOW +# endif +# if defined O_TTY_INIT && ! (INT_MIN <= O_TTY_INIT && O_TTY_INIT <= INT_MAX) +# undef O_TTY_INIT +# endif +#endif + #if !defined O_DIRECT && defined O_DIRECTIO /* Tru64 spells it 'O_DIRECTIO'. */ # define O_DIRECT O_DIRECTIO diff --git a/lib/fd-hook.c b/lib/fd-hook.c index fd07578f1..7404aaa5e 100644 --- a/lib/fd-hook.c +++ b/lib/fd-hook.c @@ -1,5 +1,5 @@ /* Hook for making making file descriptor functions close(), ioctl() extensible. - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2009. This program is free software: you can redistribute it and/or modify it diff --git a/lib/fd-hook.h b/lib/fd-hook.h index 5ff0f73fc..b56f1328e 100644 --- a/lib/fd-hook.h +++ b/lib/fd-hook.h @@ -1,5 +1,5 @@ /* Hook for making making file descriptor functions close(), ioctl() extensible. - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/float+.h b/lib/float+.h index 085c379b1..14b81203a 100644 --- a/lib/float+.h +++ b/lib/float+.h @@ -1,5 +1,5 @@ /* Supplemental information about the floating-point formats. - Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2007. This program is free software; you can redistribute it and/or modify diff --git a/lib/float.c b/lib/float.c index 3faa5eede..1d1d54f18 100644 --- a/lib/float.c +++ b/lib/float.c @@ -1,5 +1,5 @@ /* Auxiliary definitions for . - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/float.in.h b/lib/float.in.h index e814eaba5..20989c089 100644 --- a/lib/float.in.h +++ b/lib/float.in.h @@ -1,6 +1,6 @@ /* A correct . - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/flock.c b/lib/flock.c index 928e151b0..53f7ae528 100644 --- a/lib/flock.c +++ b/lib/flock.c @@ -6,7 +6,7 @@ Written by Richard W.M. Jones - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 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 diff --git a/lib/floor.c b/lib/floor.c index a00f937ed..3225f40b8 100644 --- a/lib/floor.c +++ b/lib/floor.c @@ -1,5 +1,5 @@ /* Round towards negative infinity. - Copyright (C) 2007, 2010-2014 Free Software Foundation, Inc. + Copyright (C) 2007, 2010-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/frexp.c b/lib/frexp.c index 6eff94574..a1a23aa54 100644 --- a/lib/frexp.c +++ b/lib/frexp.c @@ -1,5 +1,5 @@ /* Split a double into fraction and mantissa. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/fstat.c b/lib/fstat.c index 17ccc8e29..f93f60fd2 100644 --- a/lib/fstat.c +++ b/lib/fstat.c @@ -1,5 +1,5 @@ /* fstat() replacement. - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/fsync.c b/lib/fsync.c index 99475ff65..b107dfcf9 100644 --- a/lib/fsync.c +++ b/lib/fsync.c @@ -7,7 +7,7 @@ Written by Richard W.M. Jones - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 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 diff --git a/lib/full-read.c b/lib/full-read.c index 4d67afb92..0b1a8f35c 100644 --- a/lib/full-read.c +++ b/lib/full-read.c @@ -1,5 +1,5 @@ /* An interface to read that retries after partial reads and interrupts. - Copyright (C) 2002-2003, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2002-2003, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/full-read.h b/lib/full-read.h index 954b94dce..dbf4cd679 100644 --- a/lib/full-read.h +++ b/lib/full-read.h @@ -1,6 +1,6 @@ /* An interface to read() that reads all it is asked to read. - Copyright (C) 2002, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2002, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -13,7 +13,6 @@ GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License - along with this program; if not, read to the Free Software Foundation, along with this program. If not, see . */ #include diff --git a/lib/full-write.c b/lib/full-write.c index 6a77b7b45..9419d70cb 100644 --- a/lib/full-write.c +++ b/lib/full-write.c @@ -1,6 +1,6 @@ /* An interface to read and write that retries (if necessary) until complete. - Copyright (C) 1993-1994, 1997-2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 1993-1994, 1997-2006, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/full-write.h b/lib/full-write.h index 2fab6fa02..3715bec59 100644 --- a/lib/full-write.h +++ b/lib/full-write.h @@ -1,6 +1,6 @@ /* An interface to write() that writes all it is asked to write. - Copyright (C) 2002-2003, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2002-2003, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/gai_strerror.c b/lib/gai_strerror.c index d0c589da1..6acc85973 100644 --- a/lib/gai_strerror.c +++ b/lib/gai_strerror.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1997, 2001-2002, 2004-2006, 2008-2014 Free Software +/* Copyright (C) 1997, 2001-2002, 2004-2006, 2008-2016 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Philip Blundell , 1997. diff --git a/lib/getaddrinfo.c b/lib/getaddrinfo.c index 6581dd55a..33d731f19 100644 --- a/lib/getaddrinfo.c +++ b/lib/getaddrinfo.c @@ -1,5 +1,5 @@ /* Get address information (partial implementation). - Copyright (C) 1997, 2001-2002, 2004-2014 Free Software Foundation, Inc. + Copyright (C) 1997, 2001-2002, 2004-2016 Free Software Foundation, Inc. Contributed by Simon Josefsson . This program is free software; you can redistribute it and/or modify diff --git a/lib/getlogin.c b/lib/getlogin.c index f8cfe5d78..27efb2b95 100644 --- a/lib/getlogin.c +++ b/lib/getlogin.c @@ -1,6 +1,6 @@ /* Provide a working getlogin for systems which lack it. - Copyright (C) 2010-2014 Free Software Foundation, Inc. + Copyright (C) 2010-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/getpeername.c b/lib/getpeername.c index e5b3eaea3..a1d207d5d 100644 --- a/lib/getpeername.c +++ b/lib/getpeername.c @@ -1,6 +1,6 @@ /* getpeername.c --- wrappers for Windows getpeername function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/getsockname.c b/lib/getsockname.c index d26bae592..3fc808967 100644 --- a/lib/getsockname.c +++ b/lib/getsockname.c @@ -1,6 +1,6 @@ /* getsockname.c --- wrappers for Windows getsockname function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/getsockopt.c b/lib/getsockopt.c index 0b2fb2b73..6242deef7 100644 --- a/lib/getsockopt.c +++ b/lib/getsockopt.c @@ -1,6 +1,6 @@ /* getsockopt.c --- wrappers for Windows getsockopt function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/gettext.h b/lib/gettext.h index 330d8dad4..a22c9fa8b 100644 --- a/lib/gettext.h +++ b/lib/gettext.h @@ -1,5 +1,5 @@ /* Convenience header for conditional use of GNU . - Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2009-2014 Free Software + Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2009-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify @@ -225,15 +225,17 @@ dcpgettext_expr (const char *domain, if (msg_ctxt_id != NULL) #endif { + int found_translation; memcpy (msg_ctxt_id, msgctxt, msgctxt_len - 1); msg_ctxt_id[msgctxt_len - 1] = '\004'; memcpy (msg_ctxt_id + msgctxt_len, msgid, msgid_len); translation = dcgettext (domain, msg_ctxt_id, category); + found_translation = (translation != msg_ctxt_id); #if !_LIBGETTEXT_HAVE_VARIABLE_SIZE_ARRAYS if (msg_ctxt_id != buf) free (msg_ctxt_id); #endif - if (translation != msg_ctxt_id) + if (found_translation) return translation; } return msgid; @@ -271,15 +273,17 @@ dcnpgettext_expr (const char *domain, if (msg_ctxt_id != NULL) #endif { + int found_translation; memcpy (msg_ctxt_id, msgctxt, msgctxt_len - 1); msg_ctxt_id[msgctxt_len - 1] = '\004'; memcpy (msg_ctxt_id + msgctxt_len, msgid, msgid_len); translation = dcngettext (domain, msg_ctxt_id, msgid_plural, n, category); + found_translation = !(translation == msg_ctxt_id || translation == msgid_plural); #if !_LIBGETTEXT_HAVE_VARIABLE_SIZE_ARRAYS if (msg_ctxt_id != buf) free (msg_ctxt_id); #endif - if (!(translation == msg_ctxt_id || translation == msgid_plural)) + if (found_translation) return translation; } return (n == 1 ? msgid : msgid_plural); diff --git a/lib/gettimeofday.c b/lib/gettimeofday.c index c4e40fbe9..83c72d9ce 100644 --- a/lib/gettimeofday.c +++ b/lib/gettimeofday.c @@ -1,6 +1,6 @@ /* Provide gettimeofday for systems that don't have it or for which it's broken. - Copyright (C) 2001-2003, 2005-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2001-2003, 2005-2007, 2009-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/hard-locale.c b/lib/hard-locale.c new file mode 100644 index 000000000..6addf453d --- /dev/null +++ b/lib/hard-locale.c @@ -0,0 +1,72 @@ +/* hard-locale.c -- Determine whether a locale is hard. + + Copyright (C) 1997-1999, 2002-2004, 2006-2007, 2009-2016 Free Software + Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#include + +#include "hard-locale.h" + +#include +#include +#include + +#ifdef __GLIBC__ +# define GLIBC_VERSION __GLIBC__ +#elif defined __UCLIBC__ +# define GLIBC_VERSION 2 +#else +# define GLIBC_VERSION 0 +#endif + +/* Return true if the current CATEGORY locale is hard, i.e. if you + can't get away with assuming traditional C or POSIX behavior. */ +bool +hard_locale (int category) +{ + bool hard = true; + char const *p = setlocale (category, NULL); + + if (p) + { + if (2 <= GLIBC_VERSION) + { + if (strcmp (p, "C") == 0 || strcmp (p, "POSIX") == 0) + hard = false; + } + else + { + char *locale = strdup (p); + if (locale) + { + /* Temporarily set the locale to the "C" and "POSIX" locales + to find their names, so that we can determine whether one + or the other is the caller's locale. */ + if (((p = setlocale (category, "C")) + && strcmp (p, locale) == 0) + || ((p = setlocale (category, "POSIX")) + && strcmp (p, locale) == 0)) + hard = false; + + /* Restore the caller's locale. */ + setlocale (category, locale); + free (locale); + } + } + } + + return hard; +} diff --git a/lib/hard-locale.h b/lib/hard-locale.h new file mode 100644 index 000000000..a4a4c0643 --- /dev/null +++ b/lib/hard-locale.h @@ -0,0 +1,25 @@ +/* Determine whether a locale is hard. + + Copyright (C) 1999, 2003-2004, 2009-2016 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#ifndef HARD_LOCALE_H_ +# define HARD_LOCALE_H_ 1 + +# include + +bool hard_locale (int); + +#endif /* HARD_LOCALE_H_ */ diff --git a/lib/iconv.c b/lib/iconv.c index a6dfed355..97e61bd13 100644 --- a/lib/iconv.c +++ b/lib/iconv.c @@ -1,5 +1,5 @@ /* Character set conversion. - Copyright (C) 1999-2001, 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 1999-2001, 2007, 2009-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/iconv.in.h b/lib/iconv.in.h index ed95ed719..eb55e2b5b 100644 --- a/lib/iconv.in.h +++ b/lib/iconv.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/iconv_close.c b/lib/iconv_close.c index 6e286734d..e15cde16a 100644 --- a/lib/iconv_close.c +++ b/lib/iconv_close.c @@ -1,5 +1,5 @@ /* Character set conversion. - Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/iconv_open.c b/lib/iconv_open.c index fc19d44e2..434fa9534 100644 --- a/lib/iconv_open.c +++ b/lib/iconv_open.c @@ -1,5 +1,5 @@ /* Character set conversion. - Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/iconveh.h b/lib/iconveh.h index 43b23eb39..1bac9a8ab 100644 --- a/lib/iconveh.h +++ b/lib/iconveh.h @@ -1,5 +1,5 @@ /* Character set conversion handler type. - Copyright (C) 2001-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2001-2007, 2009-2016 Free Software Foundation, Inc. Written by Bruno Haible. This program is free software: you can redistribute it and/or modify diff --git a/lib/inet_ntop.c b/lib/inet_ntop.c index 462951968..37d93f88b 100644 --- a/lib/inet_ntop.c +++ b/lib/inet_ntop.c @@ -1,6 +1,6 @@ /* inet_ntop.c -- convert IPv4 and IPv6 addresses from binary to text form - Copyright (C) 2005-2006, 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2005-2006, 2008-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -40,7 +40,7 @@ /* Use this to suppress gcc's "...may be used before initialized" warnings. Beware: The Code argument must not contain commas. */ #ifndef IF_LINT -# ifdef lint +# if defined GCC_LINT || defined lint # define IF_LINT(Code) Code # else # define IF_LINT(Code) /* empty */ diff --git a/lib/inet_pton.c b/lib/inet_pton.c index 52ae31784..fac8fd41b 100644 --- a/lib/inet_pton.c +++ b/lib/inet_pton.c @@ -1,6 +1,6 @@ /* inet_pton.c -- convert IPv4 and IPv6 addresses from text to binary form - Copyright (C) 2006, 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2006, 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/intprops.h b/lib/intprops.h new file mode 100644 index 000000000..feb02c3c6 --- /dev/null +++ b/lib/intprops.h @@ -0,0 +1,445 @@ +/* intprops.h -- properties of integer types + + Copyright (C) 2001-2016 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify it + under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation; either version 2.1 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +/* Written by Paul Eggert. */ + +#ifndef _GL_INTPROPS_H +#define _GL_INTPROPS_H + +#include +#include + +/* Return a value with the common real type of E and V and the value of V. */ +#define _GL_INT_CONVERT(e, v) (0 * (e) + (v)) + +/* Act like _GL_INT_CONVERT (E, -V) but work around a bug in IRIX 6.5 cc; see + . */ +#define _GL_INT_NEGATE_CONVERT(e, v) (0 * (e) - (v)) + +/* The extra casts in the following macros work around compiler bugs, + e.g., in Cray C 5.0.3.0. */ + +/* True if the arithmetic type T is an integer type. bool counts as + an integer. */ +#define TYPE_IS_INTEGER(t) ((t) 1.5 == 1) + +/* True if the real type T is signed. */ +#define TYPE_SIGNED(t) (! ((t) 0 < (t) -1)) + +/* Return 1 if the real expression E, after promotion, has a + signed or floating type. */ +#define EXPR_SIGNED(e) (_GL_INT_NEGATE_CONVERT (e, 1) < 0) + + +/* Minimum and maximum values for integer types and expressions. */ + +/* The maximum and minimum values for the integer type T. */ +#define TYPE_MINIMUM(t) ((t) ~ TYPE_MAXIMUM (t)) +#define TYPE_MAXIMUM(t) \ + ((t) (! TYPE_SIGNED (t) \ + ? (t) -1 \ + : ((((t) 1 << (sizeof (t) * CHAR_BIT - 2)) - 1) * 2 + 1))) + +/* The maximum and minimum values for the type of the expression E, + after integer promotion. E should not have side effects. */ +#define _GL_INT_MINIMUM(e) \ + (EXPR_SIGNED (e) \ + ? ~ _GL_SIGNED_INT_MAXIMUM (e) \ + : _GL_INT_CONVERT (e, 0)) +#define _GL_INT_MAXIMUM(e) \ + (EXPR_SIGNED (e) \ + ? _GL_SIGNED_INT_MAXIMUM (e) \ + : _GL_INT_NEGATE_CONVERT (e, 1)) +#define _GL_SIGNED_INT_MAXIMUM(e) \ + (((_GL_INT_CONVERT (e, 1) << (sizeof ((e) + 0) * CHAR_BIT - 2)) - 1) * 2 + 1) + +/* This include file assumes that signed types are two's complement without + padding bits; the above macros have undefined behavior otherwise. + If this is a problem for you, please let us know how to fix it for your host. + As a sanity check, test the assumption for some signed types that + bounds. */ +verify (TYPE_MINIMUM (signed char) == SCHAR_MIN); +verify (TYPE_MAXIMUM (signed char) == SCHAR_MAX); +verify (TYPE_MINIMUM (short int) == SHRT_MIN); +verify (TYPE_MAXIMUM (short int) == SHRT_MAX); +verify (TYPE_MINIMUM (int) == INT_MIN); +verify (TYPE_MAXIMUM (int) == INT_MAX); +verify (TYPE_MINIMUM (long int) == LONG_MIN); +verify (TYPE_MAXIMUM (long int) == LONG_MAX); +#ifdef LLONG_MAX +verify (TYPE_MINIMUM (long long int) == LLONG_MIN); +verify (TYPE_MAXIMUM (long long int) == LLONG_MAX); +#endif + +/* Does the __typeof__ keyword work? This could be done by + 'configure', but for now it's easier to do it by hand. */ +#if (2 <= __GNUC__ || defined __IBM__TYPEOF__ \ + || (0x5110 <= __SUNPRO_C && !__STDC__)) +# define _GL_HAVE___TYPEOF__ 1 +#else +# define _GL_HAVE___TYPEOF__ 0 +#endif + +/* Return 1 if the integer type or expression T might be signed. Return 0 + if it is definitely unsigned. This macro does not evaluate its argument, + and expands to an integer constant expression. */ +#if _GL_HAVE___TYPEOF__ +# define _GL_SIGNED_TYPE_OR_EXPR(t) TYPE_SIGNED (__typeof__ (t)) +#else +# define _GL_SIGNED_TYPE_OR_EXPR(t) 1 +#endif + +/* Bound on length of the string representing an unsigned integer + value representable in B bits. log10 (2.0) < 146/485. The + smallest value of B where this bound is not tight is 2621. */ +#define INT_BITS_STRLEN_BOUND(b) (((b) * 146 + 484) / 485) + +/* Bound on length of the string representing an integer type or expression T. + Subtract 1 for the sign bit if T is signed, and then add 1 more for + a minus sign if needed. + + Because _GL_SIGNED_TYPE_OR_EXPR sometimes returns 0 when its argument is + signed, this macro may overestimate the true bound by one byte when + applied to unsigned types of size 2, 4, 16, ... bytes. */ +#define INT_STRLEN_BOUND(t) \ + (INT_BITS_STRLEN_BOUND (sizeof (t) * CHAR_BIT \ + - _GL_SIGNED_TYPE_OR_EXPR (t)) \ + + _GL_SIGNED_TYPE_OR_EXPR (t)) + +/* Bound on buffer size needed to represent an integer type or expression T, + including the terminating null. */ +#define INT_BUFSIZE_BOUND(t) (INT_STRLEN_BOUND (t) + 1) + + +/* Range overflow checks. + + The INT__RANGE_OVERFLOW macros return 1 if the corresponding C + operators might not yield numerically correct answers due to + arithmetic overflow. They do not rely on undefined or + implementation-defined behavior. Their implementations are simple + and straightforward, but they are a bit harder to use than the + INT__OVERFLOW macros described below. + + Example usage: + + long int i = ...; + long int j = ...; + if (INT_MULTIPLY_RANGE_OVERFLOW (i, j, LONG_MIN, LONG_MAX)) + printf ("multiply would overflow"); + else + printf ("product is %ld", i * j); + + Restrictions on *_RANGE_OVERFLOW macros: + + These macros do not check for all possible numerical problems or + undefined or unspecified behavior: they do not check for division + by zero, for bad shift counts, or for shifting negative numbers. + + These macros may evaluate their arguments zero or multiple times, + so the arguments should not have side effects. The arithmetic + arguments (including the MIN and MAX arguments) must be of the same + integer type after the usual arithmetic conversions, and the type + must have minimum value MIN and maximum MAX. Unsigned types should + use a zero MIN of the proper type. + + These macros are tuned for constant MIN and MAX. For commutative + operations such as A + B, they are also tuned for constant B. */ + +/* Return 1 if A + B would overflow in [MIN,MAX] arithmetic. + See above for restrictions. */ +#define INT_ADD_RANGE_OVERFLOW(a, b, min, max) \ + ((b) < 0 \ + ? (a) < (min) - (b) \ + : (max) - (b) < (a)) + +/* Return 1 if A - B would overflow in [MIN,MAX] arithmetic. + See above for restrictions. */ +#define INT_SUBTRACT_RANGE_OVERFLOW(a, b, min, max) \ + ((b) < 0 \ + ? (max) + (b) < (a) \ + : (a) < (min) + (b)) + +/* Return 1 if - A would overflow in [MIN,MAX] arithmetic. + See above for restrictions. */ +#define INT_NEGATE_RANGE_OVERFLOW(a, min, max) \ + ((min) < 0 \ + ? (a) < - (max) \ + : 0 < (a)) + +/* Return 1 if A * B would overflow in [MIN,MAX] arithmetic. + See above for restrictions. Avoid && and || as they tickle + bugs in Sun C 5.11 2010/08/13 and other compilers; see + . */ +#define INT_MULTIPLY_RANGE_OVERFLOW(a, b, min, max) \ + ((b) < 0 \ + ? ((a) < 0 \ + ? (a) < (max) / (b) \ + : (b) == -1 \ + ? 0 \ + : (min) / (b) < (a)) \ + : (b) == 0 \ + ? 0 \ + : ((a) < 0 \ + ? (a) < (min) / (b) \ + : (max) / (b) < (a))) + +/* Return 1 if A / B would overflow in [MIN,MAX] arithmetic. + See above for restrictions. Do not check for division by zero. */ +#define INT_DIVIDE_RANGE_OVERFLOW(a, b, min, max) \ + ((min) < 0 && (b) == -1 && (a) < - (max)) + +/* Return 1 if A % B would overflow in [MIN,MAX] arithmetic. + See above for restrictions. Do not check for division by zero. + Mathematically, % should never overflow, but on x86-like hosts + INT_MIN % -1 traps, and the C standard permits this, so treat this + as an overflow too. */ +#define INT_REMAINDER_RANGE_OVERFLOW(a, b, min, max) \ + INT_DIVIDE_RANGE_OVERFLOW (a, b, min, max) + +/* Return 1 if A << B would overflow in [MIN,MAX] arithmetic. + See above for restrictions. Here, MIN and MAX are for A only, and B need + not be of the same type as the other arguments. The C standard says that + behavior is undefined for shifts unless 0 <= B < wordwidth, and that when + A is negative then A << B has undefined behavior and A >> B has + implementation-defined behavior, but do not check these other + restrictions. */ +#define INT_LEFT_SHIFT_RANGE_OVERFLOW(a, b, min, max) \ + ((a) < 0 \ + ? (a) < (min) >> (b) \ + : (max) >> (b) < (a)) + +/* True if __builtin_add_overflow (A, B, P) works when P is null. */ +#define _GL_HAS_BUILTIN_OVERFLOW_WITH_NULL (7 <= __GNUC__) + +/* The _GL*_OVERFLOW macros have the same restrictions as the + *_RANGE_OVERFLOW macros, except that they do not assume that operands + (e.g., A and B) have the same type as MIN and MAX. Instead, they assume + that the result (e.g., A + B) has that type. */ +#if _GL_HAS_BUILTIN_OVERFLOW_WITH_NULL +# define _GL_ADD_OVERFLOW(a, b, min, max) + __builtin_add_overflow (a, b, (__typeof__ ((a) + (b)) *) 0) +# define _GL_SUBTRACT_OVERFLOW(a, b, min, max) + __builtin_sub_overflow (a, b, (__typeof__ ((a) - (b)) *) 0) +# define _GL_MULTIPLY_OVERFLOW(a, b, min, max) + __builtin_mul_overflow (a, b, (__typeof__ ((a) * (b)) *) 0) +#else +# define _GL_ADD_OVERFLOW(a, b, min, max) \ + ((min) < 0 ? INT_ADD_RANGE_OVERFLOW (a, b, min, max) \ + : (a) < 0 ? (b) <= (a) + (b) \ + : (b) < 0 ? (a) <= (a) + (b) \ + : (a) + (b) < (b)) +# define _GL_SUBTRACT_OVERFLOW(a, b, min, max) \ + ((min) < 0 ? INT_SUBTRACT_RANGE_OVERFLOW (a, b, min, max) \ + : (a) < 0 ? 1 \ + : (b) < 0 ? (a) - (b) <= (a) \ + : (a) < (b)) +# define _GL_MULTIPLY_OVERFLOW(a, b, min, max) \ + (((min) == 0 && (((a) < 0 && 0 < (b)) || ((b) < 0 && 0 < (a)))) \ + || INT_MULTIPLY_RANGE_OVERFLOW (a, b, min, max)) +#endif +#define _GL_DIVIDE_OVERFLOW(a, b, min, max) \ + ((min) < 0 ? (b) == _GL_INT_NEGATE_CONVERT (min, 1) && (a) < - (max) \ + : (a) < 0 ? (b) <= (a) + (b) - 1 \ + : (b) < 0 && (a) + (b) <= (a)) +#define _GL_REMAINDER_OVERFLOW(a, b, min, max) \ + ((min) < 0 ? (b) == _GL_INT_NEGATE_CONVERT (min, 1) && (a) < - (max) \ + : (a) < 0 ? (a) % (b) != ((max) - (b) + 1) % (b) \ + : (b) < 0 && ! _GL_UNSIGNED_NEG_MULTIPLE (a, b, max)) + +/* Return a nonzero value if A is a mathematical multiple of B, where + A is unsigned, B is negative, and MAX is the maximum value of A's + type. A's type must be the same as (A % B)'s type. Normally (A % + -B == 0) suffices, but things get tricky if -B would overflow. */ +#define _GL_UNSIGNED_NEG_MULTIPLE(a, b, max) \ + (((b) < -_GL_SIGNED_INT_MAXIMUM (b) \ + ? (_GL_SIGNED_INT_MAXIMUM (b) == (max) \ + ? (a) \ + : (a) % (_GL_INT_CONVERT (a, _GL_SIGNED_INT_MAXIMUM (b)) + 1)) \ + : (a) % - (b)) \ + == 0) + +/* Check for integer overflow, and report low order bits of answer. + + The INT__OVERFLOW macros return 1 if the corresponding C operators + might not yield numerically correct answers due to arithmetic overflow. + The INT__WRAPV macros also store the low-order bits of the answer. + These macros work correctly on all known practical hosts, and do not rely + on undefined behavior due to signed arithmetic overflow. + + Example usage, assuming A and B are long int: + + if (INT_MULTIPLY_OVERFLOW (a, b)) + printf ("result would overflow\n"); + else + printf ("result is %ld (no overflow)\n", a * b); + + Example usage with WRAPV flavor: + + long int result; + bool overflow = INT_MULTIPLY_WRAPV (a, b, &result); + printf ("result is %ld (%s)\n", result, + overflow ? "after overflow" : "no overflow"); + + Restrictions on these macros: + + These macros do not check for all possible numerical problems or + undefined or unspecified behavior: they do not check for division + by zero, for bad shift counts, or for shifting negative numbers. + + These macros may evaluate their arguments zero or multiple times, so the + arguments should not have side effects. + + The WRAPV macros are not constant expressions. They support only + +, binary -, and *. The result type must be signed. + + These macros are tuned for their last argument being a constant. + + Return 1 if the integer expressions A * B, A - B, -A, A * B, A / B, + A % B, and A << B would overflow, respectively. */ + +#define INT_ADD_OVERFLOW(a, b) \ + _GL_BINARY_OP_OVERFLOW (a, b, _GL_ADD_OVERFLOW) +#define INT_SUBTRACT_OVERFLOW(a, b) \ + _GL_BINARY_OP_OVERFLOW (a, b, _GL_SUBTRACT_OVERFLOW) +#if _GL_HAS_BUILTIN_OVERFLOW_WITH_NULL +# define INT_NEGATE_OVERFLOW(a) INT_SUBTRACT_OVERFLOW (0, a) +#else +# define INT_NEGATE_OVERFLOW(a) \ + INT_NEGATE_RANGE_OVERFLOW (a, _GL_INT_MINIMUM (a), _GL_INT_MAXIMUM (a)) +#endif +#define INT_MULTIPLY_OVERFLOW(a, b) \ + _GL_BINARY_OP_OVERFLOW (a, b, _GL_MULTIPLY_OVERFLOW) +#define INT_DIVIDE_OVERFLOW(a, b) \ + _GL_BINARY_OP_OVERFLOW (a, b, _GL_DIVIDE_OVERFLOW) +#define INT_REMAINDER_OVERFLOW(a, b) \ + _GL_BINARY_OP_OVERFLOW (a, b, _GL_REMAINDER_OVERFLOW) +#define INT_LEFT_SHIFT_OVERFLOW(a, b) \ + INT_LEFT_SHIFT_RANGE_OVERFLOW (a, b, \ + _GL_INT_MINIMUM (a), _GL_INT_MAXIMUM (a)) + +/* Return 1 if the expression A B would overflow, + where OP_RESULT_OVERFLOW (A, B, MIN, MAX) does the actual test, + assuming MIN and MAX are the minimum and maximum for the result type. + Arguments should be free of side effects. */ +#define _GL_BINARY_OP_OVERFLOW(a, b, op_result_overflow) \ + op_result_overflow (a, b, \ + _GL_INT_MINIMUM (0 * (b) + (a)), \ + _GL_INT_MAXIMUM (0 * (b) + (a))) + +/* Store the low-order bits of A + B, A - B, A * B, respectively, into *R. + Return 1 if the result overflows. See above for restrictions. */ +#define INT_ADD_WRAPV(a, b, r) \ + _GL_INT_OP_WRAPV (a, b, r, +, __builtin_add_overflow, INT_ADD_OVERFLOW) +#define INT_SUBTRACT_WRAPV(a, b, r) \ + _GL_INT_OP_WRAPV (a, b, r, -, __builtin_sub_overflow, INT_SUBTRACT_OVERFLOW) +#define INT_MULTIPLY_WRAPV(a, b, r) \ + _GL_INT_OP_WRAPV (a, b, r, *, __builtin_mul_overflow, INT_MULTIPLY_OVERFLOW) + +#ifndef __has_builtin +# define __has_builtin(x) 0 +#endif + +/* Nonzero if this compiler has GCC bug 68193 or Clang bug 25390. See: + https://gcc.gnu.org/bugzilla/show_bug.cgi?id=68193 + https://llvm.org/bugs/show_bug.cgi?id=25390 + For now, assume all versions of GCC-like compilers generate bogus + warnings for _Generic. This matters only for older compilers that + lack __builtin_add_overflow. */ +#if __GNUC__ +# define _GL__GENERIC_BOGUS 1 +#else +# define _GL__GENERIC_BOGUS 0 +#endif + +/* Store the low-order bits of A B into *R, where OP specifies + the operation. BUILTIN is the builtin operation, and OVERFLOW the + overflow predicate. Return 1 if the result overflows. See above + for restrictions. */ +#if 5 <= __GNUC__ || __has_builtin (__builtin_add_overflow) +# define _GL_INT_OP_WRAPV(a, b, r, op, builtin, overflow) builtin (a, b, r) +#elif 201112 <= __STDC_VERSION__ && !_GL__GENERIC_BOGUS +# define _GL_INT_OP_WRAPV(a, b, r, op, builtin, overflow) \ + (_Generic \ + (*(r), \ + signed char: \ + _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned char, \ + signed char, SCHAR_MIN, SCHAR_MAX), \ + short int: \ + _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned short int, \ + short int, SHRT_MIN, SHRT_MAX), \ + int: \ + _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, \ + int, INT_MIN, INT_MAX), \ + long int: \ + _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned long int, \ + long int, LONG_MIN, LONG_MAX), \ + long long int: \ + _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned long long int, \ + long long int, LLONG_MIN, LLONG_MAX))) +#else +# define _GL_INT_OP_WRAPV(a, b, r, op, builtin, overflow) \ + (sizeof *(r) == sizeof (signed char) \ + ? _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned char, \ + signed char, SCHAR_MIN, SCHAR_MAX) \ + : sizeof *(r) == sizeof (short int) \ + ? _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned short int, \ + short int, SHRT_MIN, SHRT_MAX) \ + : sizeof *(r) == sizeof (int) \ + ? _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned int, \ + int, INT_MIN, INT_MAX) \ + : _GL_INT_OP_WRAPV_LONGISH(a, b, r, op, overflow)) +# ifdef LLONG_MAX +# define _GL_INT_OP_WRAPV_LONGISH(a, b, r, op, overflow) \ + (sizeof *(r) == sizeof (long int) \ + ? _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned long int, \ + long int, LONG_MIN, LONG_MAX) \ + : _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned long long int, \ + long long int, LLONG_MIN, LLONG_MAX)) +# else +# define _GL_INT_OP_WRAPV_LONGISH(a, b, r, op, overflow) \ + _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned long int, \ + long int, LONG_MIN, LONG_MAX)) +# endif +#endif + +/* Store the low-order bits of A B into *R, where the operation + is given by OP. Use the unsigned type UT for calculation to avoid + overflow problems. *R's type is T, with extremal values TMIN and + TMAX. T must be a signed integer type. Return 1 if the result + overflows. */ +#define _GL_INT_OP_CALC(a, b, r, op, overflow, ut, t, tmin, tmax) \ + (sizeof ((a) op (b)) < sizeof (t) \ + ? _GL_INT_OP_CALC1 ((t) (a), (t) (b), r, op, overflow, ut, t, tmin, tmax) \ + : _GL_INT_OP_CALC1 (a, b, r, op, overflow, ut, t, tmin, tmax)) +#define _GL_INT_OP_CALC1(a, b, r, op, overflow, ut, t, tmin, tmax) \ + ((overflow (a, b) \ + || (EXPR_SIGNED ((a) op (b)) && ((a) op (b)) < (tmin)) \ + || (tmax) < ((a) op (b))) \ + ? (*(r) = _GL_INT_OP_WRAPV_VIA_UNSIGNED (a, b, op, ut, t, tmin, tmax), 1) \ + : (*(r) = _GL_INT_OP_WRAPV_VIA_UNSIGNED (a, b, op, ut, t, tmin, tmax), 0)) + +/* Return A B, where the operation is given by OP. Use the + unsigned type UT for calculation to avoid overflow problems. + Convert the result to type T without overflow by subtracting TMIN + from large values before converting, and adding it afterwards. + Compilers can optimize all the operations except OP. */ +#define _GL_INT_OP_WRAPV_VIA_UNSIGNED(a, b, op, ut, t, tmin, tmax) \ + (((ut) (a) op (ut) (b)) <= (tmax) \ + ? (t) ((ut) (a) op (ut) (b)) \ + : ((t) (((ut) (a) op (ut) (b)) - (tmin)) + (tmin))) + +#endif /* _GL_INTPROPS_H */ diff --git a/lib/isfinite.c b/lib/isfinite.c index 18c1d217f..431518e98 100644 --- a/lib/isfinite.c +++ b/lib/isfinite.c @@ -1,5 +1,5 @@ /* Test for finite value (zero, subnormal, or normal, and not infinite or NaN). - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isinf.c b/lib/isinf.c index 217de79df..fa9565ae4 100644 --- a/lib/isinf.c +++ b/lib/isinf.c @@ -1,5 +1,5 @@ /* Test for positive or negative infinity. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnan.c b/lib/isnan.c index 1557733bf..e9a86149d 100644 --- a/lib/isnan.c +++ b/lib/isnan.c @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnand-nolibm.h b/lib/isnand-nolibm.h index b0498ef08..c30ae24db 100644 --- a/lib/isnand-nolibm.h +++ b/lib/isnand-nolibm.h @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnand.c b/lib/isnand.c index 11efbf8d8..2e25f353f 100644 --- a/lib/isnand.c +++ b/lib/isnand.c @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnanf-nolibm.h b/lib/isnanf-nolibm.h index 9e2aa2f54..8166b9b55 100644 --- a/lib/isnanf-nolibm.h +++ b/lib/isnanf-nolibm.h @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnanf.c b/lib/isnanf.c index c7a66ca3a..6c82c5e0c 100644 --- a/lib/isnanf.c +++ b/lib/isnanf.c @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnanl-nolibm.h b/lib/isnanl-nolibm.h index 9cf090caa..517547d1a 100644 --- a/lib/isnanl-nolibm.h +++ b/lib/isnanl-nolibm.h @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnanl.c b/lib/isnanl.c index dbf9d5dd1..77404b7f5 100644 --- a/lib/isnanl.c +++ b/lib/isnanl.c @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/itold.c b/lib/itold.c index 136742eab..57f5e9578 100644 --- a/lib/itold.c +++ b/lib/itold.c @@ -1,5 +1,5 @@ /* Replacement for 'int' to 'long double' conversion routine. - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/langinfo.in.h b/lib/langinfo.in.h index f4a281a33..42c7cefb9 100644 --- a/lib/langinfo.in.h +++ b/lib/langinfo.in.h @@ -1,5 +1,5 @@ /* Substitute for and wrapper around . - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -49,7 +49,10 @@ typedef int nl_item; # define CODESET 10000 /* nl_langinfo items of the LC_NUMERIC category */ # define RADIXCHAR 10001 +# define DECIMAL_POINT RADIXCHAR # define THOUSEP 10002 +# define THOUSANDS_SEP THOUSEP +# define GROUPING 10114 /* nl_langinfo items of the LC_TIME category */ # define D_T_FMT 10003 # define D_FMT 10004 @@ -102,6 +105,21 @@ typedef int nl_item; # define ALT_DIGITS 10051 /* nl_langinfo items of the LC_MONETARY category */ # define CRNCYSTR 10052 +# define CURRENCY_SYMBOL CRNCYSTR +# define INT_CURR_SYMBOL 10100 +# define MON_DECIMAL_POINT 10101 +# define MON_THOUSANDS_SEP 10102 +# define MON_GROUPING 10103 +# define POSITIVE_SIGN 10104 +# define NEGATIVE_SIGN 10105 +# define FRAC_DIGITS 10106 +# define INT_FRAC_DIGITS 10107 +# define P_CS_PRECEDES 10108 +# define N_CS_PRECEDES 10109 +# define P_SEP_BY_SPACE 10110 +# define N_SEP_BY_SPACE 10111 +# define P_SIGN_POSN 10112 +# define N_SIGN_POSN 10113 /* nl_langinfo items of the LC_MESSAGES category */ # define YESEXPR 10053 # define NOEXPR 10054 diff --git a/lib/link.c b/lib/link.c index 9db1f8cef..9cd840c3e 100644 --- a/lib/link.c +++ b/lib/link.c @@ -1,6 +1,6 @@ /* Emulate link on platforms that lack it, namely native Windows platforms. - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/listen.c b/lib/listen.c index 912f1b7a7..014e82f85 100644 --- a/lib/listen.c +++ b/lib/listen.c @@ -1,6 +1,6 @@ /* listen.c --- wrappers for Windows listen function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/localcharset.c b/lib/localcharset.c index 7f09567ce..7ce17e69e 100644 --- a/lib/localcharset.c +++ b/lib/localcharset.c @@ -1,6 +1,6 @@ /* Determine a canonical name for the current locale's character encoding. - Copyright (C) 2000-2006, 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2000-2006, 2008-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -34,6 +34,7 @@ #if defined _WIN32 || defined __WIN32__ # define WINDOWS_NATIVE +# include #endif #if defined __EMX__ @@ -127,7 +128,7 @@ get_charset_aliases (void) cp = charset_aliases; if (cp == NULL) { -#if !(defined DARWIN7 || defined VMS || defined WINDOWS_NATIVE || defined __CYGWIN__) +#if !(defined DARWIN7 || defined VMS || defined WINDOWS_NATIVE || defined __CYGWIN__ || defined OS2) const char *dir; const char *base = "charset.alias"; char *file_name; @@ -341,6 +342,36 @@ get_charset_aliases (void) "CP54936" "\0" "GB18030" "\0" "CP65001" "\0" "UTF-8" "\0"; # endif +# if defined OS2 + /* To avoid the troubles of installing a separate file in the same + directory as the DLL and of retrieving the DLL's directory at + runtime, simply inline the aliases here. */ + + /* The list of encodings is taken from "List of OS/2 Codepages" + by Alex Taylor: + . + See also "IBM Globalization - Code page identifiers": + . */ + cp = "CP813" "\0" "ISO-8859-7" "\0" + "CP878" "\0" "KOI8-R" "\0" + "CP819" "\0" "ISO-8859-1" "\0" + "CP912" "\0" "ISO-8859-2" "\0" + "CP913" "\0" "ISO-8859-3" "\0" + "CP914" "\0" "ISO-8859-4" "\0" + "CP915" "\0" "ISO-8859-5" "\0" + "CP916" "\0" "ISO-8859-8" "\0" + "CP920" "\0" "ISO-8859-9" "\0" + "CP921" "\0" "ISO-8859-13" "\0" + "CP923" "\0" "ISO-8859-15" "\0" + "CP954" "\0" "EUC-JP" "\0" + "CP964" "\0" "EUC-TW" "\0" + "CP970" "\0" "EUC-KR" "\0" + "CP1089" "\0" "ISO-8859-6" "\0" + "CP1208" "\0" "UTF-8" "\0" + "CP1381" "\0" "GB2312" "\0" + "CP1386" "\0" "GBK" "\0" + "CP3372" "\0" "EUC-JP" "\0"; +# endif #endif charset_aliases = cp; @@ -461,14 +492,34 @@ locale_charset (void) static char buf[2 + 10 + 1]; - /* The Windows API has a function returning the locale's codepage as a - number: GetACP(). - When the output goes to a console window, it needs to be provided in - GetOEMCP() encoding if the console is using a raster font, or in - GetConsoleOutputCP() encoding if it is using a TrueType font. - But in GUI programs and for output sent to files and pipes, GetACP() - encoding is the best bet. */ - sprintf (buf, "CP%u", GetACP ()); + /* The Windows API has a function returning the locale's codepage as + a number, but the value doesn't change according to what the + 'setlocale' call specified. So we use it as a last resort, in + case the string returned by 'setlocale' doesn't specify the + codepage. */ + char *current_locale = setlocale (LC_ALL, NULL); + char *pdot; + + /* If they set different locales for different categories, + 'setlocale' will return a semi-colon separated list of locale + values. To make sure we use the correct one, we choose LC_CTYPE. */ + if (strchr (current_locale, ';')) + current_locale = setlocale (LC_CTYPE, NULL); + + pdot = strrchr (current_locale, '.'); + if (pdot) + sprintf (buf, "CP%s", pdot + 1); + else + { + /* The Windows API has a function returning the locale's codepage as a + number: GetACP(). + When the output goes to a console window, it needs to be provided in + GetOEMCP() encoding if the console is using a raster font, or in + GetConsoleOutputCP() encoding if it is using a TrueType font. + But in GUI programs and for output sent to files and pipes, GetACP() + encoding is the best bet. */ + sprintf (buf, "CP%u", GetACP ()); + } codeset = buf; #elif defined OS2 @@ -478,6 +529,8 @@ locale_charset (void) ULONG cp[3]; ULONG cplen; + codeset = NULL; + /* Allow user to override the codeset, as set in the operating system, with standard language environment variables. */ locale = getenv ("LC_ALL"); @@ -509,10 +562,12 @@ locale_charset (void) } } - /* Resolve through the charset.alias file. */ - codeset = locale; + /* For the POSIX locale, don't use the system's codepage. */ + if (strcmp (locale, "C") == 0 || strcmp (locale, "POSIX") == 0) + codeset = ""; } - else + + if (codeset == NULL) { /* OS/2 has a function returning the locale's codepage as a number. */ if (DosQueryCp (sizeof (cp), cp, &cplen)) diff --git a/lib/localcharset.h b/lib/localcharset.h index 4b104c304..49de10a43 100644 --- a/lib/localcharset.h +++ b/lib/localcharset.h @@ -1,5 +1,5 @@ /* Determine a canonical name for the current locale's character encoding. - Copyright (C) 2000-2003, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2000-2003, 2009-2016 Free Software Foundation, Inc. This file is part of the GNU CHARSET Library. This program is free software; you can redistribute it and/or modify diff --git a/lib/locale.in.h b/lib/locale.in.h index a10b129ca..f7b19caa0 100644 --- a/lib/locale.in.h +++ b/lib/locale.in.h @@ -1,5 +1,5 @@ /* A POSIX . - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/localeconv.c b/lib/localeconv.c index ed2767be0..609dbb63a 100644 --- a/lib/localeconv.c +++ b/lib/localeconv.c @@ -1,5 +1,5 @@ /* Query locale dependent information for formatting numbers. - Copyright (C) 2012-2014 Free Software Foundation, Inc. + Copyright (C) 2012-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/log.c b/lib/log.c index ef8d332f8..547201f32 100644 --- a/lib/log.c +++ b/lib/log.c @@ -1,5 +1,5 @@ /* Logarithm. - Copyright (C) 2012-2014 Free Software Foundation, Inc. + Copyright (C) 2012-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/log1p.c b/lib/log1p.c index d1132d3e4..bc4127b80 100644 --- a/lib/log1p.c +++ b/lib/log1p.c @@ -1,5 +1,5 @@ /* Natural logarithm of 1 plus argument. - Copyright (C) 2012-2014 Free Software Foundation, Inc. + Copyright (C) 2012-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/lstat.c b/lib/lstat.c index cff1188f3..0a0141607 100644 --- a/lib/lstat.c +++ b/lib/lstat.c @@ -1,6 +1,6 @@ /* Work around a bug of lstat on some systems - Copyright (C) 1997-2006, 2008-2014 Free Software Foundation, Inc. + Copyright (C) 1997-2006, 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/malloc.c b/lib/malloc.c index c6e292a74..ea63740f3 100644 --- a/lib/malloc.c +++ b/lib/malloc.c @@ -1,6 +1,6 @@ /* malloc() function that is glibc compatible. - Copyright (C) 1997-1998, 2006-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 1997-1998, 2006-2007, 2009-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/malloca.c b/lib/malloca.c index 3e95f2333..942c60f9b 100644 --- a/lib/malloca.c +++ b/lib/malloca.c @@ -1,5 +1,5 @@ /* Safe automatic memory allocation. - Copyright (C) 2003, 2006-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2003, 2006-2007, 2009-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2003. This program is free software; you can redistribute it and/or modify diff --git a/lib/malloca.h b/lib/malloca.h index 5810afa54..90fc3a6dc 100644 --- a/lib/malloca.h +++ b/lib/malloca.h @@ -1,5 +1,5 @@ /* Safe automatic memory allocation. - Copyright (C) 2003-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2003-2007, 2009-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2003. This program is free software; you can redistribute it and/or modify diff --git a/lib/math.c b/lib/math.c index ddb2ded53..ba2a6abd6 100644 --- a/lib/math.c +++ b/lib/math.c @@ -1,3 +1,4 @@ #include #define _GL_MATH_INLINE _GL_EXTERN_INLINE #include "math.h" +typedef int dummy; diff --git a/lib/math.in.h b/lib/math.in.h index 4f2aa862b..b3832c10e 100644 --- a/lib/math.in.h +++ b/lib/math.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 2002-2003, 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2002-2003, 2007-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -2205,7 +2205,8 @@ _GL_WARN_REAL_FLOATING_DECL (isnan); #if @GNULIB_SIGNBIT@ -# if @REPLACE_SIGNBIT_USING_GCC@ +# if (@REPLACE_SIGNBIT_USING_GCC@ \ + && (!defined __cplusplus || __cplusplus < 201103)) # undef signbit /* GCC 4.0 and newer provides three built-ins for signbit. */ # define signbit(x) \ diff --git a/lib/mbrtowc.c b/lib/mbrtowc.c index dff12962d..2e5a0b6aa 100644 --- a/lib/mbrtowc.c +++ b/lib/mbrtowc.c @@ -1,5 +1,5 @@ /* Convert multibyte character to wide character. - Copyright (C) 1999-2002, 2005-2014 Free Software Foundation, Inc. + Copyright (C) 1999-2002, 2005-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2008. This program is free software: you can redistribute it and/or modify @@ -20,6 +20,11 @@ /* Specification. */ #include +#if C_LOCALE_MAYBE_EILSEQ +# include "hard-locale.h" +# include +#endif + #if GNULIB_defined_mbstate_t /* Implement mbrtowc() on top of mbtowc(). */ @@ -328,7 +333,10 @@ mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps) size_t rpl_mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps) { -# if MBRTOWC_NULL_ARG2_BUG || MBRTOWC_RETVAL_BUG + size_t ret; + wchar_t wc; + +# if MBRTOWC_NULL_ARG2_BUG || MBRTOWC_RETVAL_BUG || MBRTOWC_EMPTY_INPUT_BUG if (s == NULL) { pwc = NULL; @@ -337,6 +345,14 @@ rpl_mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps) } # endif +# if MBRTOWC_EMPTY_INPUT_BUG + if (n == 0) + return (size_t) -2; +# endif + + if (! pwc) + pwc = &wc; + # if MBRTOWC_RETVAL_BUG { static mbstate_t internal_state; @@ -352,8 +368,7 @@ rpl_mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps) size_t count = 0; for (; n > 0; s++, n--) { - wchar_t wc; - size_t ret = mbrtowc (&wc, s, 1, ps); + ret = mbrtowc (&wc, s, 1, ps); if (ret == (size_t)(-1)) return (size_t)(-1); @@ -361,8 +376,7 @@ rpl_mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps) if (ret != (size_t)(-2)) { /* The multibyte character has been completed. */ - if (pwc != NULL) - *pwc = wc; + *pwc = wc; return (wc == 0 ? 0 : count); } } @@ -371,32 +385,23 @@ rpl_mbrtowc (wchar_t *pwc, const char *s, size_t n, mbstate_t *ps) } # endif + ret = mbrtowc (pwc, s, n, ps); + # if MBRTOWC_NUL_RETVAL_BUG - { - wchar_t wc; - size_t ret = mbrtowc (&wc, s, n, ps); - - if (ret != (size_t)(-1) && ret != (size_t)(-2)) - { - if (pwc != NULL) - *pwc = wc; - if (wc == 0) - ret = 0; - } - return ret; - } -# else - { -# if MBRTOWC_NULL_ARG1_BUG - wchar_t dummy; - - if (pwc == NULL) - pwc = &dummy; -# endif - - return mbrtowc (pwc, s, n, ps); - } + if (ret < (size_t) -2 && !*pwc) + return 0; # endif + +# if C_LOCALE_MAYBE_EILSEQ + if ((size_t) -2 <= ret && n != 0 && ! hard_locale (LC_CTYPE)) + { + unsigned char uc = *s; + *pwc = uc; + return 1; + } +# endif + + return ret; } #endif diff --git a/lib/mbsinit.c b/lib/mbsinit.c index 71bae341b..54ecc9edf 100644 --- a/lib/mbsinit.c +++ b/lib/mbsinit.c @@ -1,5 +1,5 @@ /* Test for initial conversion state. - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2008. This program is free software: you can redistribute it and/or modify diff --git a/lib/mbtowc-impl.h b/lib/mbtowc-impl.h index df11ad2bf..156693409 100644 --- a/lib/mbtowc-impl.h +++ b/lib/mbtowc-impl.h @@ -1,5 +1,5 @@ /* Convert multibyte character to wide character. - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/mbtowc.c b/lib/mbtowc.c index bd9d3aa6b..253fd223b 100644 --- a/lib/mbtowc.c +++ b/lib/mbtowc.c @@ -1,5 +1,5 @@ /* Convert multibyte character to wide character. - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/memchr.c b/lib/memchr.c index c1caad3a2..f866c959e 100644 --- a/lib/memchr.c +++ b/lib/memchr.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1991, 1993, 1996-1997, 1999-2000, 2003-2004, 2006, 2008-2014 +/* Copyright (C) 1991, 1993, 1996-1997, 1999-2000, 2003-2004, 2006, 2008-2016 Free Software Foundation, Inc. Based on strlen implementation by Torbjorn Granlund (tege@sics.se), diff --git a/lib/mkdir.c b/lib/mkdir.c index f1b802b57..8a1854502 100644 --- a/lib/mkdir.c +++ b/lib/mkdir.c @@ -1,7 +1,7 @@ /* On some systems, mkdir ("foo/", 0700) fails because of the trailing slash. On those systems, this wrapper removes the trailing slash. - Copyright (C) 2001, 2003, 2006, 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2001, 2003, 2006, 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/mkstemp.c b/lib/mkstemp.c index 0af69f9c3..bbad5f9cd 100644 --- a/lib/mkstemp.c +++ b/lib/mkstemp.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998-1999, 2001, 2005-2007, 2009-2014 Free Software +/* Copyright (C) 1998-1999, 2001, 2005-2007, 2009-2016 Free Software Foundation, Inc. This file is derived from the one in the GNU C Library. diff --git a/lib/mktime-internal.h b/lib/mktime-internal.h new file mode 100644 index 000000000..0c9e20405 --- /dev/null +++ b/lib/mktime-internal.h @@ -0,0 +1,37 @@ +/* mktime variant that also uses an offset guess + + Copyright 2016 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this program; if not, see + . */ + +#include + +/* mktime_offset_t is a signed type wide enough to hold a UTC offset + in seconds, and used as part of the type of the offset-guess + argument to mktime_internal. Use time_t on platforms where time_t + is signed, to be compatible with platforms like BeOS that export + this implementation detail of mktime. On platforms where time_t is + unsigned, GNU and POSIX code can assume 'int' is at least 32 bits + which is wide enough for a UTC offset. */ + +#if TIME_T_IS_SIGNED +typedef time_t mktime_offset_t; +#else +typedef int mktime_offset_t; +#endif + +time_t mktime_internal (struct tm *, + struct tm * (*) (time_t const *, struct tm *), + mktime_offset_t *); diff --git a/lib/mktime.c b/lib/mktime.c new file mode 100644 index 000000000..9eb3e7652 --- /dev/null +++ b/lib/mktime.c @@ -0,0 +1,630 @@ +/* Convert a 'struct tm' to a time_t value. + Copyright (C) 1993-2016 Free Software Foundation, Inc. + This file is part of the GNU C Library. + Contributed by Paul Eggert . + + The GNU C Library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + The GNU C Library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with the GNU C Library; if not, see + . */ + +/* Define this to 1 to have a standalone program to test this implementation of + mktime. */ +#ifndef DEBUG_MKTIME +# define DEBUG_MKTIME 0 +#endif + +#if !defined _LIBC && !DEBUG_MKTIME +# include +#endif + +/* Assume that leap seconds are possible, unless told otherwise. + If the host has a 'zic' command with a '-L leapsecondfilename' option, + then it supports leap seconds; otherwise it probably doesn't. */ +#ifndef LEAP_SECONDS_POSSIBLE +# define LEAP_SECONDS_POSSIBLE 1 +#endif + +#include + +#include +#include + +#include +#include + +#if DEBUG_MKTIME +# include +# include +# include +/* Make it work even if the system's libc has its own mktime routine. */ +# undef mktime +# define mktime my_mktime +#endif + +/* A signed type that can represent an integer number of years + multiplied by three times the number of seconds in a year. It is + needed when converting a tm_year value times the number of seconds + in a year. The factor of three comes because these products need + to be subtracted from each other, and sometimes with an offset + added to them, without worrying about overflow. + + Much of the code uses long_int to represent time_t values, to + lessen the hassle of dealing with platforms where time_t is + unsigned, and because long_int should suffice to represent all + time_t values that mktime can generate even on platforms where + time_t is excessively wide. */ + +#if INT_MAX <= LONG_MAX / 3 / 366 / 24 / 60 / 60 +typedef long int long_int; +#else +typedef long long int long_int; +#endif +verify (INT_MAX <= TYPE_MAXIMUM (long_int) / 3 / 366 / 24 / 60 / 60); + +/* Shift A right by B bits portably, by dividing A by 2**B and + truncating towards minus infinity. B should be in the range 0 <= B + <= LONG_INT_BITS - 2, where LONG_INT_BITS is the number of useful + bits in a long_int. LONG_INT_BITS is at least 32. + + ISO C99 says that A >> B is implementation-defined if A < 0. Some + implementations (e.g., UNICOS 9.0 on a Cray Y-MP EL) don't shift + right in the usual way when A < 0, so SHR falls back on division if + ordinary A >> B doesn't seem to be the usual signed shift. */ + +static long_int +shr (long_int a, int b) +{ + long_int one = 1; + return (-one >> 1 == -1 + ? a >> b + : a / (one << b) - (a % (one << b) < 0)); +} + +/* Bounds for the intersection of time_t and long_int. */ + +static long_int const mktime_min + = ((TYPE_SIGNED (time_t) && TYPE_MINIMUM (time_t) < TYPE_MINIMUM (long_int)) + ? TYPE_MINIMUM (long_int) : TYPE_MINIMUM (time_t)); +static long_int const mktime_max + = (TYPE_MAXIMUM (long_int) < TYPE_MAXIMUM (time_t) + ? TYPE_MAXIMUM (long_int) : TYPE_MAXIMUM (time_t)); + +verify (TYPE_IS_INTEGER (time_t)); + +#define EPOCH_YEAR 1970 +#define TM_YEAR_BASE 1900 +verify (TM_YEAR_BASE % 100 == 0); + +/* Is YEAR + TM_YEAR_BASE a leap year? */ +static bool +leapyear (long_int year) +{ + /* Don't add YEAR to TM_YEAR_BASE, as that might overflow. + Also, work even if YEAR is negative. */ + return + ((year & 3) == 0 + && (year % 100 != 0 + || ((year / 100) & 3) == (- (TM_YEAR_BASE / 100) & 3))); +} + +/* How many days come before each month (0-12). */ +#ifndef _LIBC +static +#endif +const unsigned short int __mon_yday[2][13] = + { + /* Normal years. */ + { 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365 }, + /* Leap years. */ + { 0, 31, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366 } + }; + + +#ifdef _LIBC +typedef time_t mktime_offset_t; +#else +/* Portable standalone applications should supply a that + declares a POSIX-compliant localtime_r, for the benefit of older + implementations that lack localtime_r or have a nonstandard one. + See the gnulib time_r module for one way to implement this. */ +# undef __localtime_r +# define __localtime_r localtime_r +# define __mktime_internal mktime_internal +# include "mktime-internal.h" +#endif + +/* Do the values A and B differ according to the rules for tm_isdst? + A and B differ if one is zero and the other positive. */ +static bool +isdst_differ (int a, int b) +{ + return (!a != !b) && (0 <= a) && (0 <= b); +} + +/* Return an integer value measuring (YEAR1-YDAY1 HOUR1:MIN1:SEC1) - + (YEAR0-YDAY0 HOUR0:MIN0:SEC0) in seconds, assuming that the clocks + were not adjusted between the time stamps. + + The YEAR values uses the same numbering as TP->tm_year. Values + need not be in the usual range. However, YEAR1 must not overflow + when multiplied by three times the number of seconds in a year, and + likewise for YDAY1 and three times the number of seconds in a day. */ + +static long_int +ydhms_diff (long_int year1, long_int yday1, int hour1, int min1, int sec1, + int year0, int yday0, int hour0, int min0, int sec0) +{ + verify (-1 / 2 == 0); + + /* Compute intervening leap days correctly even if year is negative. + Take care to avoid integer overflow here. */ + int a4 = shr (year1, 2) + shr (TM_YEAR_BASE, 2) - ! (year1 & 3); + int b4 = shr (year0, 2) + shr (TM_YEAR_BASE, 2) - ! (year0 & 3); + int a100 = a4 / 25 - (a4 % 25 < 0); + int b100 = b4 / 25 - (b4 % 25 < 0); + int a400 = shr (a100, 2); + int b400 = shr (b100, 2); + int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400); + + /* Compute the desired time without overflowing. */ + long_int years = year1 - year0; + long_int days = 365 * years + yday1 - yday0 + intervening_leap_days; + long_int hours = 24 * days + hour1 - hour0; + long_int minutes = 60 * hours + min1 - min0; + long_int seconds = 60 * minutes + sec1 - sec0; + return seconds; +} + +/* Return the average of A and B, even if A + B would overflow. + Round toward positive infinity. */ +static long_int +long_int_avg (long_int a, long_int b) +{ + return shr (a, 1) + shr (b, 1) + ((a | b) & 1); +} + +/* Return a time_t value corresponding to (YEAR-YDAY HOUR:MIN:SEC), + assuming that T corresponds to *TP and that no clock adjustments + occurred between *TP and the desired time. + Although T and the returned value are of type long_int, + they represent time_t values and must be in time_t range. + If TP is null, return a value not equal to T; this avoids false matches. + YEAR and YDAY must not be so large that multiplying them by three times the + number of seconds in a year (or day, respectively) would overflow long_int. + If the returned value would be out of range, yield the minimal or + maximal in-range value, except do not yield a value equal to T. */ +static long_int +guess_time_tm (long_int year, long_int yday, int hour, int min, int sec, + long_int t, const struct tm *tp) +{ + if (tp) + { + long_int result; + long_int d = ydhms_diff (year, yday, hour, min, sec, + tp->tm_year, tp->tm_yday, + tp->tm_hour, tp->tm_min, tp->tm_sec); + if (! INT_ADD_WRAPV (t, d, &result)) + return result; + } + + /* Overflow occurred one way or another. Return the nearest result + that is actually in range, except don't report a zero difference + if the actual difference is nonzero, as that would cause a false + match; and don't oscillate between two values, as that would + confuse the spring-forward gap detector. */ + return (t < long_int_avg (mktime_min, mktime_max) + ? (t <= mktime_min + 1 ? t + 1 : mktime_min) + : (mktime_max - 1 <= t ? t - 1 : mktime_max)); +} + +/* Use CONVERT to convert T to a struct tm value in *TM. T must be in + range for time_t. Return TM if successful, NULL if T is out of + range for CONVERT. */ +static struct tm * +convert_time (struct tm *(*convert) (const time_t *, struct tm *), + long_int t, struct tm *tm) +{ + time_t x = t; + return convert (&x, tm); +} + +/* Use CONVERT to convert *T to a broken down time in *TP. + If *T is out of range for conversion, adjust it so that + it is the nearest in-range value and then convert that. + A value is in range if it fits in both time_t and long_int. */ +static struct tm * +ranged_convert (struct tm *(*convert) (const time_t *, struct tm *), + long_int *t, struct tm *tp) +{ + struct tm *r; + if (*t < mktime_min) + *t = mktime_min; + else if (mktime_max < *t) + *t = mktime_max; + r = convert_time (convert, *t, tp); + + if (!r && *t) + { + long_int bad = *t; + long_int ok = 0; + + /* BAD is a known unconvertible value, and OK is a known good one. + Use binary search to narrow the range between BAD and OK until + they differ by 1. */ + while (true) + { + long_int mid = long_int_avg (ok, bad); + if (mid != ok && mid != bad) + break; + r = convert_time (convert, mid, tp); + if (r) + ok = mid; + else + bad = mid; + } + + if (!r && ok) + { + /* The last conversion attempt failed; + revert to the most recent successful attempt. */ + r = convert_time (convert, ok, tp); + } + } + + return r; +} + +/* Convert *TP to a time_t value, inverting + the monotonic and mostly-unit-linear conversion function CONVERT. + Use *OFFSET to keep track of a guess at the offset of the result, + compared to what the result would be for UTC without leap seconds. + If *OFFSET's guess is correct, only one CONVERT call is needed. + This function is external because it is used also by timegm.c. */ +time_t +__mktime_internal (struct tm *tp, + struct tm *(*convert) (const time_t *, struct tm *), + mktime_offset_t *offset) +{ + long_int t, gt, t0, t1, t2, dt; + struct tm tm; + + /* The maximum number of probes (calls to CONVERT) should be enough + to handle any combinations of time zone rule changes, solar time, + leap seconds, and oscillations around a spring-forward gap. + POSIX.1 prohibits leap seconds, but some hosts have them anyway. */ + int remaining_probes = 6; + + /* Time requested. Copy it in case CONVERT modifies *TP; this can + occur if TP is localtime's returned value and CONVERT is localtime. */ + int sec = tp->tm_sec; + int min = tp->tm_min; + int hour = tp->tm_hour; + int mday = tp->tm_mday; + int mon = tp->tm_mon; + int year_requested = tp->tm_year; + int isdst = tp->tm_isdst; + + /* 1 if the previous probe was DST. */ + int dst2; + + /* Ensure that mon is in range, and set year accordingly. */ + int mon_remainder = mon % 12; + int negative_mon_remainder = mon_remainder < 0; + int mon_years = mon / 12 - negative_mon_remainder; + long_int lyear_requested = year_requested; + long_int year = lyear_requested + mon_years; + + /* The other values need not be in range: + the remaining code handles overflows correctly. */ + + /* Calculate day of year from year, month, and day of month. + The result need not be in range. */ + int mon_yday = ((__mon_yday[leapyear (year)] + [mon_remainder + 12 * negative_mon_remainder]) + - 1); + long_int lmday = mday; + long_int yday = mon_yday + lmday; + + int negative_offset_guess; + + int sec_requested = sec; + + if (LEAP_SECONDS_POSSIBLE) + { + /* Handle out-of-range seconds specially, + since ydhms_tm_diff assumes every minute has 60 seconds. */ + if (sec < 0) + sec = 0; + if (59 < sec) + sec = 59; + } + + /* Invert CONVERT by probing. First assume the same offset as last + time. */ + + INT_SUBTRACT_WRAPV (0, *offset, &negative_offset_guess); + t0 = ydhms_diff (year, yday, hour, min, sec, + EPOCH_YEAR - TM_YEAR_BASE, 0, 0, 0, negative_offset_guess); + + /* Repeatedly use the error to improve the guess. */ + + for (t = t1 = t2 = t0, dst2 = 0; + (gt = guess_time_tm (year, yday, hour, min, sec, t, + ranged_convert (convert, &t, &tm)), + t != gt); + t1 = t2, t2 = t, t = gt, dst2 = tm.tm_isdst != 0) + if (t == t1 && t != t2 + && (tm.tm_isdst < 0 + || (isdst < 0 + ? dst2 <= (tm.tm_isdst != 0) + : (isdst != 0) != (tm.tm_isdst != 0)))) + /* We can't possibly find a match, as we are oscillating + between two values. The requested time probably falls + within a spring-forward gap of size GT - T. Follow the common + practice in this case, which is to return a time that is GT - T + away from the requested time, preferring a time whose + tm_isdst differs from the requested value. (If no tm_isdst + was requested and only one of the two values has a nonzero + tm_isdst, prefer that value.) In practice, this is more + useful than returning -1. */ + goto offset_found; + else if (--remaining_probes == 0) + return -1; + + /* We have a match. Check whether tm.tm_isdst has the requested + value, if any. */ + if (isdst_differ (isdst, tm.tm_isdst)) + { + /* tm.tm_isdst has the wrong value. Look for a neighboring + time with the right value, and use its UTC offset. + + Heuristic: probe the adjacent timestamps in both directions, + looking for the desired isdst. This should work for all real + time zone histories in the tz database. */ + + /* Distance between probes when looking for a DST boundary. In + tzdata2003a, the shortest period of DST is 601200 seconds + (e.g., America/Recife starting 2000-10-08 01:00), and the + shortest period of non-DST surrounded by DST is 694800 + seconds (Africa/Tunis starting 1943-04-17 01:00). Use the + minimum of these two values, so we don't miss these short + periods when probing. */ + int stride = 601200; + + /* The longest period of DST in tzdata2003a is 536454000 seconds + (e.g., America/Jujuy starting 1946-10-01 01:00). The longest + period of non-DST is much longer, but it makes no real sense + to search for more than a year of non-DST, so use the DST + max. */ + int duration_max = 536454000; + + /* Search in both directions, so the maximum distance is half + the duration; add the stride to avoid off-by-1 problems. */ + int delta_bound = duration_max / 2 + stride; + + int delta, direction; + + for (delta = stride; delta < delta_bound; delta += stride) + for (direction = -1; direction <= 1; direction += 2) + { + long_int ot; + if (! INT_ADD_WRAPV (t, delta * direction, &ot)) + { + struct tm otm; + ranged_convert (convert, &ot, &otm); + if (! isdst_differ (isdst, otm.tm_isdst)) + { + /* We found the desired tm_isdst. + Extrapolate back to the desired time. */ + t = guess_time_tm (year, yday, hour, min, sec, ot, &otm); + ranged_convert (convert, &t, &tm); + goto offset_found; + } + } + } + } + + offset_found: + /* Set *OFFSET to the low-order bits of T - T0 - NEGATIVE_OFFSET_GUESS. + This is just a heuristic to speed up the next mktime call, and + correctness is unaffected if integer overflow occurs here. */ + INT_SUBTRACT_WRAPV (t, t0, &dt); + INT_SUBTRACT_WRAPV (dt, negative_offset_guess, offset); + + if (LEAP_SECONDS_POSSIBLE && sec_requested != tm.tm_sec) + { + /* Adjust time to reflect the tm_sec requested, not the normalized value. + Also, repair any damage from a false match due to a leap second. */ + long_int sec_adjustment = sec == 0 && tm.tm_sec == 60; + sec_adjustment -= sec; + sec_adjustment += sec_requested; + if (INT_ADD_WRAPV (t, sec_adjustment, &t) + || ! (mktime_min <= t && t <= mktime_max) + || ! convert_time (convert, t, &tm)) + return -1; + } + + *tp = tm; + return t; +} + + +static mktime_offset_t localtime_offset; + +/* Convert *TP to a time_t value. */ +time_t +mktime (struct tm *tp) +{ +#ifdef _LIBC + /* POSIX.1 8.1.1 requires that whenever mktime() is called, the + time zone names contained in the external variable 'tzname' shall + be set as if the tzset() function had been called. */ + __tzset (); +#elif HAVE_TZSET + tzset (); +#endif + + return __mktime_internal (tp, __localtime_r, &localtime_offset); +} + +#ifdef weak_alias +weak_alias (mktime, timelocal) +#endif + +#ifdef _LIBC +libc_hidden_def (mktime) +libc_hidden_weak (timelocal) +#endif + +#if DEBUG_MKTIME + +static int +not_equal_tm (const struct tm *a, const struct tm *b) +{ + return ((a->tm_sec ^ b->tm_sec) + | (a->tm_min ^ b->tm_min) + | (a->tm_hour ^ b->tm_hour) + | (a->tm_mday ^ b->tm_mday) + | (a->tm_mon ^ b->tm_mon) + | (a->tm_year ^ b->tm_year) + | (a->tm_yday ^ b->tm_yday) + | isdst_differ (a->tm_isdst, b->tm_isdst)); +} + +static void +print_tm (const struct tm *tp) +{ + if (tp) + printf ("%04d-%02d-%02d %02d:%02d:%02d yday %03d wday %d isdst %d", + tp->tm_year + TM_YEAR_BASE, tp->tm_mon + 1, tp->tm_mday, + tp->tm_hour, tp->tm_min, tp->tm_sec, + tp->tm_yday, tp->tm_wday, tp->tm_isdst); + else + printf ("0"); +} + +static int +check_result (time_t tk, struct tm tmk, time_t tl, const struct tm *lt) +{ + if (tk != tl || !lt || not_equal_tm (&tmk, lt)) + { + printf ("mktime ("); + print_tm (lt); + printf (")\nyields ("); + print_tm (&tmk); + printf (") == %ld, should be %ld\n", (long int) tk, (long int) tl); + return 1; + } + + return 0; +} + +int +main (int argc, char **argv) +{ + int status = 0; + struct tm tm, tmk, tml; + struct tm *lt; + time_t tk, tl, tl1; + char trailer; + + /* Sanity check, plus call tzset. */ + tl = 0; + if (! localtime (&tl)) + { + printf ("localtime (0) fails\n"); + status = 1; + } + + if ((argc == 3 || argc == 4) + && (sscanf (argv[1], "%d-%d-%d%c", + &tm.tm_year, &tm.tm_mon, &tm.tm_mday, &trailer) + == 3) + && (sscanf (argv[2], "%d:%d:%d%c", + &tm.tm_hour, &tm.tm_min, &tm.tm_sec, &trailer) + == 3)) + { + tm.tm_year -= TM_YEAR_BASE; + tm.tm_mon--; + tm.tm_isdst = argc == 3 ? -1 : atoi (argv[3]); + tmk = tm; + tl = mktime (&tmk); + lt = localtime_r (&tl, &tml); + printf ("mktime returns %ld == ", (long int) tl); + print_tm (&tmk); + printf ("\n"); + status = check_result (tl, tmk, tl, lt); + } + else if (argc == 4 || (argc == 5 && strcmp (argv[4], "-") == 0)) + { + time_t from = atol (argv[1]); + time_t by = atol (argv[2]); + time_t to = atol (argv[3]); + + if (argc == 4) + for (tl = from; by < 0 ? to <= tl : tl <= to; tl = tl1) + { + lt = localtime_r (&tl, &tml); + if (lt) + { + tmk = tml; + tk = mktime (&tmk); + status |= check_result (tk, tmk, tl, &tml); + } + else + { + printf ("localtime_r (%ld) yields 0\n", (long int) tl); + status = 1; + } + tl1 = tl + by; + if ((tl1 < tl) != (by < 0)) + break; + } + else + for (tl = from; by < 0 ? to <= tl : tl <= to; tl = tl1) + { + /* Null benchmark. */ + lt = localtime_r (&tl, &tml); + if (lt) + { + tmk = tml; + tk = tl; + status |= check_result (tk, tmk, tl, &tml); + } + else + { + printf ("localtime_r (%ld) yields 0\n", (long int) tl); + status = 1; + } + tl1 = tl + by; + if ((tl1 < tl) != (by < 0)) + break; + } + } + else + printf ("Usage:\ +\t%s YYYY-MM-DD HH:MM:SS [ISDST] # Test given time.\n\ +\t%s FROM BY TO # Test values FROM, FROM+BY, ..., TO.\n\ +\t%s FROM BY TO - # Do not test those values (for benchmark).\n", + argv[0], argv[0], argv[0]); + + return status; +} + +#endif /* DEBUG_MKTIME */ + +/* +Local Variables: +compile-command: "gcc -DDEBUG_MKTIME -I. -Wall -W -O2 -g mktime.c -o mktime" +End: +*/ diff --git a/lib/msvc-inval.c b/lib/msvc-inval.c index 84190d097..c649d5f99 100644 --- a/lib/msvc-inval.c +++ b/lib/msvc-inval.c @@ -1,5 +1,5 @@ /* Invalid parameter handler for MSVC runtime libraries. - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/msvc-inval.h b/lib/msvc-inval.h index c6df57e93..32a44a340 100644 --- a/lib/msvc-inval.h +++ b/lib/msvc-inval.h @@ -1,5 +1,5 @@ /* Invalid parameter handler for MSVC runtime libraries. - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/msvc-nothrow.c b/lib/msvc-nothrow.c index 9b1eb598e..1c7b5849f 100644 --- a/lib/msvc-nothrow.c +++ b/lib/msvc-nothrow.c @@ -1,6 +1,6 @@ /* Wrappers that don't throw invalid parameter notifications with MSVC runtime libraries. - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/msvc-nothrow.h b/lib/msvc-nothrow.h index 1917325b3..f76f4de84 100644 --- a/lib/msvc-nothrow.h +++ b/lib/msvc-nothrow.h @@ -1,6 +1,6 @@ /* Wrappers that don't throw invalid parameter notifications with MSVC runtime libraries. - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/netdb.in.h b/lib/netdb.in.h index 3613fb5a5..8361da811 100644 --- a/lib/netdb.in.h +++ b/lib/netdb.in.h @@ -1,5 +1,5 @@ /* Provide a netdb.h header file for systems lacking it (read: MinGW). - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. Written by Simon Josefsson. This program is free software; you can redistribute it and/or modify diff --git a/lib/netinet_in.in.h b/lib/netinet_in.in.h index 8ab66a1df..4be15ab26 100644 --- a/lib/netinet_in.in.h +++ b/lib/netinet_in.in.h @@ -1,5 +1,5 @@ /* Substitute for . - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/nl_langinfo.c b/lib/nl_langinfo.c index 83d2c77af..5c3124fab 100644 --- a/lib/nl_langinfo.c +++ b/lib/nl_langinfo.c @@ -1,6 +1,6 @@ /* nl_langinfo() replacement: query locale dependent information. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -20,13 +20,72 @@ /* Specification. */ #include +#include +#include +#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ +# define WIN32_LEAN_AND_MEAN /* avoid including junk */ +# include +# include +#endif + +/* Return the codeset of the current locale, if this is easily deducible. + Otherwise, return "". */ +static char * +ctype_codeset (void) +{ + static char buf[2 + 10 + 1]; + size_t buflen = 0; + char const *locale = setlocale (LC_CTYPE, NULL); + char *codeset = buf; + size_t codesetlen; + codeset[0] = '\0'; + + if (locale && locale[0]) + { + /* If the locale name contains an encoding after the dot, return it. */ + char *dot = strchr (locale, '.'); + + if (dot) + { + /* Look for the possible @... trailer and remove it, if any. */ + char *codeset_start = dot + 1; + char const *modifier = strchr (codeset_start, '@'); + + if (! modifier) + codeset = codeset_start; + else + { + codesetlen = modifier - codeset_start; + if (codesetlen < sizeof buf) + { + codeset = memcpy (buf, codeset_start, codesetlen); + codeset[codesetlen] = '\0'; + } + } + } + } + +#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ + /* If setlocale is successful, it returns the number of the + codepage, as a string. Otherwise, fall back on Windows API + GetACP, which returns the locale's codepage as a number (although + this doesn't change according to what the 'setlocale' call specified). + Either way, prepend "CP" to make it a valid codeset name. */ + codesetlen = strlen (codeset); + if (0 < codesetlen && codesetlen < sizeof buf - 2) + memmove (buf + 2, codeset, codesetlen + 1); + else + sprintf (buf + 2, "%u", GetACP ()); + codeset = memcpy (buf, "CP", 2); +#endif + return codeset; +} + + #if REPLACE_NL_LANGINFO /* Override nl_langinfo with support for added nl_item values. */ -# include -# include - # undef nl_langinfo char * @@ -36,36 +95,7 @@ rpl_nl_langinfo (nl_item item) { # if GNULIB_defined_CODESET case CODESET: - { - const char *locale; - static char buf[2 + 10 + 1]; - - locale = setlocale (LC_CTYPE, NULL); - if (locale != NULL && locale[0] != '\0') - { - /* If the locale name contains an encoding after the dot, return - it. */ - const char *dot = strchr (locale, '.'); - - if (dot != NULL) - { - const char *modifier; - - dot++; - /* Look for the possible @... trailer and remove it, if any. */ - modifier = strchr (dot, '@'); - if (modifier == NULL) - return dot; - if (modifier - dot < sizeof (buf)) - { - memcpy (buf, dot, modifier - dot); - buf [modifier - dot] = '\0'; - return buf; - } - } - } - return ""; - } + return ctype_codeset (); # endif # if GNULIB_defined_T_FMT_AMPM case T_FMT_AMPM: @@ -111,42 +141,28 @@ rpl_nl_langinfo (nl_item item) #else -/* Provide nl_langinfo from scratch. */ +/* Provide nl_langinfo from scratch, either for native MS-Windows, or + for old Unix platforms without locales, such as Linux libc5 or + BeOS. */ -# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ - -/* Native Windows platforms. */ - -# define WIN32_LEAN_AND_MEAN /* avoid including junk */ -# include - -# include - -# else - -/* An old Unix platform without locales, such as Linux libc5 or BeOS. */ - -# endif - -# include +# include char * nl_langinfo (nl_item item) { + static char nlbuf[100]; + struct tm tmm = { 0 }; + switch (item) { /* nl_langinfo items of the LC_CTYPE category */ case CODESET: -# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ { - static char buf[2 + 10 + 1]; - - /* The Windows API has a function returning the locale's codepage as - a number. */ - sprintf (buf, "CP%u", GetACP ()); - return buf; + char *codeset = ctype_codeset (); + if (*codeset) + return codeset; } -# elif defined __BEOS__ +# ifdef __BEOS__ return "UTF-8"; # else return "ISO-8859-1"; @@ -156,6 +172,8 @@ nl_langinfo (nl_item item) return localeconv () ->decimal_point; case THOUSEP: return localeconv () ->thousands_sep; + case GROUPING: + return localeconv () ->grouping; /* nl_langinfo items of the LC_TIME category. TODO: Really use the locale. */ case D_T_FMT: @@ -170,93 +188,126 @@ nl_langinfo (nl_item item) case T_FMT_AMPM: return "%I:%M:%S %p"; case AM_STR: - return "AM"; + if (!strftime (nlbuf, sizeof nlbuf, "%p", &tmm)) + return "AM"; + return nlbuf; case PM_STR: - return "PM"; + tmm.tm_hour = 12; + if (!strftime (nlbuf, sizeof nlbuf, "%p", &tmm)) + return "PM"; + return nlbuf; case DAY_1: - return "Sunday"; case DAY_2: - return "Monday"; case DAY_3: - return "Tuesday"; case DAY_4: - return "Wednesday"; case DAY_5: - return "Thursday"; case DAY_6: - return "Friday"; case DAY_7: - return "Saturday"; + { + static char const days[][sizeof "Wednesday"] = { + "Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", + "Friday", "Saturday" + }; + tmm.tm_wday = item - DAY_1; + if (!strftime (nlbuf, sizeof nlbuf, "%A", &tmm)) + return (char *) days[item - DAY_1]; + return nlbuf; + } case ABDAY_1: - return "Sun"; case ABDAY_2: - return "Mon"; case ABDAY_3: - return "Tue"; case ABDAY_4: - return "Wed"; case ABDAY_5: - return "Thu"; case ABDAY_6: - return "Fri"; case ABDAY_7: - return "Sat"; + { + static char const abdays[][sizeof "Sun"] = { + "Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat" + }; + tmm.tm_wday = item - ABDAY_1; + if (!strftime (nlbuf, sizeof nlbuf, "%a", &tmm)) + return (char *) abdays[item - ABDAY_1]; + return nlbuf; + } case MON_1: - return "January"; case MON_2: - return "February"; case MON_3: - return "March"; case MON_4: - return "April"; case MON_5: - return "May"; case MON_6: - return "June"; case MON_7: - return "July"; case MON_8: - return "August"; case MON_9: - return "September"; case MON_10: - return "October"; case MON_11: - return "November"; case MON_12: - return "December"; + { + static char const months[][sizeof "September"] = { + "January", "February", "March", "April", "May", "June", "July", + "September", "October", "November", "December" + }; + tmm.tm_mon = item - MON_1; + if (!strftime (nlbuf, sizeof nlbuf, "%B", &tmm)) + return (char *) months[item - MON_1]; + return nlbuf; + } case ABMON_1: - return "Jan"; case ABMON_2: - return "Feb"; case ABMON_3: - return "Mar"; case ABMON_4: - return "Apr"; case ABMON_5: - return "May"; case ABMON_6: - return "Jun"; case ABMON_7: - return "Jul"; case ABMON_8: - return "Aug"; case ABMON_9: - return "Sep"; case ABMON_10: - return "Oct"; case ABMON_11: - return "Nov"; case ABMON_12: - return "Dec"; + { + static char const abmonths[][sizeof "Jan"] = { + "Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", + "Sep", "Oct", "Nov", "Dec" + }; + tmm.tm_mon = item - ABMON_1; + if (!strftime (nlbuf, sizeof nlbuf, "%b", &tmm)) + return (char *) abmonths[item - ABMON_1]; + return nlbuf; + } case ERA: return ""; case ALT_DIGITS: return "\0\0\0\0\0\0\0\0\0\0"; - /* nl_langinfo items of the LC_MONETARY category - TODO: Really use the locale. */ + /* nl_langinfo items of the LC_MONETARY category. */ case CRNCYSTR: - return "-"; + return localeconv () ->currency_symbol; + case INT_CURR_SYMBOL: + return localeconv () ->int_curr_symbol; + case MON_DECIMAL_POINT: + return localeconv () ->mon_decimal_point; + case MON_THOUSANDS_SEP: + return localeconv () ->mon_thousands_sep; + case MON_GROUPING: + return localeconv () ->mon_grouping; + case POSITIVE_SIGN: + return localeconv () ->positive_sign; + case NEGATIVE_SIGN: + return localeconv () ->negative_sign; + case FRAC_DIGITS: + return & localeconv () ->frac_digits; + case INT_FRAC_DIGITS: + return & localeconv () ->int_frac_digits; + case P_CS_PRECEDES: + return & localeconv () ->p_cs_precedes; + case N_CS_PRECEDES: + return & localeconv () ->n_cs_precedes; + case P_SEP_BY_SPACE: + return & localeconv () ->p_sep_by_space; + case N_SEP_BY_SPACE: + return & localeconv () ->n_sep_by_space; + case P_SIGN_POSN: + return & localeconv () ->p_sign_posn; + case N_SIGN_POSN: + return & localeconv () ->n_sign_posn; /* nl_langinfo items of the LC_MESSAGES category TODO: Really use the locale. */ case YESEXPR: diff --git a/lib/nproc.c b/lib/nproc.c index 293c65169..e79094cf1 100644 --- a/lib/nproc.c +++ b/lib/nproc.c @@ -1,6 +1,6 @@ /* Detect the number of processors. - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/nproc.h b/lib/nproc.h index dbc315707..6f8b4ae7c 100644 --- a/lib/nproc.h +++ b/lib/nproc.h @@ -1,6 +1,6 @@ /* Detect the number of processors. - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/open.c b/lib/open.c index f6fd06e4c..b815fcdb5 100644 --- a/lib/open.c +++ b/lib/open.c @@ -1,5 +1,5 @@ /* Open a descriptor to a file. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/pathmax.h b/lib/pathmax.h index 15ed6c28e..e7b8c7cd8 100644 --- a/lib/pathmax.h +++ b/lib/pathmax.h @@ -1,5 +1,5 @@ /* Define PATH_MAX somehow. Requires sys/types.h. - Copyright (C) 1992, 1999, 2001, 2003, 2005, 2009-2014 Free Software + Copyright (C) 1992, 1999, 2001, 2003, 2005, 2009-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/pipe.c b/lib/pipe.c index 03aed5ef9..4eda943d2 100644 --- a/lib/pipe.c +++ b/lib/pipe.c @@ -1,5 +1,5 @@ /* Create a pipe. - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/pipe2.c b/lib/pipe2.c index 4e4e894e7..e4ec14632 100644 --- a/lib/pipe2.c +++ b/lib/pipe2.c @@ -1,5 +1,5 @@ /* Create a pipe, with specific opening flags. - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/poll.c b/lib/poll.c index 7b1e58266..bf8dd1c97 100644 --- a/lib/poll.c +++ b/lib/poll.c @@ -1,7 +1,7 @@ /* Emulation for poll(2) Contributed by Paolo Bonzini. - Copyright 2001-2003, 2006-2014 Free Software Foundation, Inc. + Copyright 2001-2003, 2006-2016 Free Software Foundation, Inc. This file is part of gnulib. @@ -33,7 +33,6 @@ #include #include -#include #if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ # define WINDOWS_NATIVE @@ -45,11 +44,12 @@ # include "msvc-nothrow.h" #else # include -# include -# include # include #endif +#include +#include + #ifdef HAVE_SYS_IOCTL_H # include #endif @@ -59,6 +59,8 @@ #include +#include "assure.h" + #ifndef INFTIM # define INFTIM (-1) #endif @@ -70,9 +72,11 @@ #ifdef WINDOWS_NATIVE -/* Optimized test whether a HANDLE refers to a console. - See . */ -#define IsConsoleHandle(h) (((intptr_t) (h) & 3) == 3) +static BOOL IsConsoleHandle (HANDLE h) +{ + DWORD mode; + return GetConsoleMode (h, &mode) != 0; +} static BOOL IsSocketHandle (HANDLE h) @@ -331,26 +335,15 @@ poll (struct pollfd *pfd, nfds_t nfd, int timeout) int maxfd, rc; nfds_t i; -# ifdef _SC_OPEN_MAX - static int sc_open_max = -1; - - if (nfd < 0 - || (nfd > sc_open_max - && (sc_open_max != -1 - || nfd > (sc_open_max = sysconf (_SC_OPEN_MAX))))) + if (nfd < 0) { errno = EINVAL; return -1; } -# else /* !_SC_OPEN_MAX */ -# ifdef OPEN_MAX - if (nfd < 0 || nfd > OPEN_MAX) - { - errno = EINVAL; - return -1; - } -# endif /* OPEN_MAX -- else, no check is needed */ -# endif /* !_SC_OPEN_MAX */ + /* Don't check directly for NFD too large. Any practical use of a + too-large NFD is caught by one of the other checks below, and + checking directly for getdtablesize is too much of a portability + and/or performance and/or correctness hassle. */ /* EFAULT is not necessary to implement, but let's do it in the simplest case. */ @@ -391,10 +384,17 @@ poll (struct pollfd *pfd, nfds_t nfd, int timeout) { if (pfd[i].fd < 0) continue; - + if (maxfd < pfd[i].fd) + { + maxfd = pfd[i].fd; + if (FD_SETSIZE <= maxfd) + { + errno = EINVAL; + return -1; + } + } if (pfd[i].events & (POLLIN | POLLRDNORM)) FD_SET (pfd[i].fd, &rfds); - /* see select(2): "the only exceptional condition detectable is out-of-band data received on a socket", hence we push POLLWRBAND events onto wfds instead of efds. */ @@ -402,18 +402,6 @@ poll (struct pollfd *pfd, nfds_t nfd, int timeout) FD_SET (pfd[i].fd, &wfds); if (pfd[i].events & (POLLPRI | POLLRDBAND)) FD_SET (pfd[i].fd, &efds); - if (pfd[i].fd >= maxfd - && (pfd[i].events & (POLLIN | POLLOUT | POLLPRI - | POLLRDNORM | POLLRDBAND - | POLLWRNORM | POLLWRBAND))) - { - maxfd = pfd[i].fd; - if (maxfd > FD_SETSIZE) - { - errno = EOVERFLOW; - return -1; - } - } } /* examine fd sets */ @@ -424,18 +412,13 @@ poll (struct pollfd *pfd, nfds_t nfd, int timeout) /* establish results */ rc = 0; for (i = 0; i < nfd; i++) - if (pfd[i].fd < 0) - pfd[i].revents = 0; - else - { - int happened = compute_revents (pfd[i].fd, pfd[i].events, - &rfds, &wfds, &efds); - if (happened) - { - pfd[i].revents = happened; - rc++; - } - } + { + pfd[i].revents = (pfd[i].fd < 0 + ? 0 + : compute_revents (pfd[i].fd, pfd[i].events, + &rfds, &wfds, &efds)); + rc += pfd[i].revents != 0; + } return rc; #else @@ -478,7 +461,7 @@ restart: continue; h = (HANDLE) _get_osfhandle (pfd[i].fd); - assert (h != NULL); + assure (h != NULL); if (IsSocketHandle (h)) { int requested = FD_CLOSE; diff --git a/lib/poll.in.h b/lib/poll.in.h index bde98064f..7066229d8 100644 --- a/lib/poll.in.h +++ b/lib/poll.in.h @@ -1,7 +1,7 @@ /* Header for poll(2) emulation Contributed by Paolo Bonzini. - Copyright 2001-2003, 2007, 2009-2014 Free Software Foundation, Inc. + Copyright 2001-2003, 2007, 2009-2016 Free Software Foundation, Inc. This file is part of gnulib. diff --git a/lib/printf-args.c b/lib/printf-args.c index 9673e6ddc..ff8662549 100644 --- a/lib/printf-args.c +++ b/lib/printf-args.c @@ -1,5 +1,5 @@ /* Decomposed printf argument list. - Copyright (C) 1999, 2002-2003, 2005-2007, 2009-2014 Free Software + Copyright (C) 1999, 2002-2003, 2005-2007, 2009-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/printf-args.h b/lib/printf-args.h index 831c14738..3b2fe7fc5 100644 --- a/lib/printf-args.h +++ b/lib/printf-args.h @@ -1,5 +1,5 @@ /* Decomposed printf argument list. - Copyright (C) 1999, 2002-2003, 2006-2007, 2011-2014 Free Software + Copyright (C) 1999, 2002-2003, 2006-2007, 2011-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/printf-parse.c b/lib/printf-parse.c index e6a09a8de..f19d17f99 100644 --- a/lib/printf-parse.c +++ b/lib/printf-parse.c @@ -1,5 +1,5 @@ /* Formatted output to strings. - Copyright (C) 1999-2000, 2002-2003, 2006-2014 Free Software Foundation, Inc. + Copyright (C) 1999-2000, 2002-2003, 2006-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/printf-parse.h b/lib/printf-parse.h index 44d6f5513..4e753bef8 100644 --- a/lib/printf-parse.h +++ b/lib/printf-parse.h @@ -1,5 +1,5 @@ /* Parse printf format string. - Copyright (C) 1999, 2002-2003, 2005, 2007, 2010-2014 Free Software + Copyright (C) 1999, 2002-2003, 2005, 2007, 2010-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/putenv.c b/lib/putenv.c index de8caa712..8db04d23a 100644 --- a/lib/putenv.c +++ b/lib/putenv.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1991, 1994, 1997-1998, 2000, 2003-2014 Free Software +/* Copyright (C) 1991, 1994, 1997-1998, 2000, 2003-2016 Free Software Foundation, Inc. NOTE: The canonical source of this file is maintained with the GNU C diff --git a/lib/raise.c b/lib/raise.c index 2f04eea9b..60a76c462 100644 --- a/lib/raise.c +++ b/lib/raise.c @@ -1,6 +1,6 @@ /* Provide a non-threads replacement for the POSIX raise function. - Copyright (C) 2002-2003, 2005-2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2002-2003, 2005-2006, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/read.c b/lib/read.c index 4efe8ce23..aea8bbc04 100644 --- a/lib/read.c +++ b/lib/read.c @@ -1,5 +1,5 @@ /* POSIX compatible read() function. - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/readlink.c b/lib/readlink.c index ef502f57b..53ee57d54 100644 --- a/lib/readlink.c +++ b/lib/readlink.c @@ -1,5 +1,5 @@ /* Stub for readlink(). - Copyright (C) 2003-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2003-2007, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/recv.c b/lib/recv.c index fc7e12406..a6e962fb1 100644 --- a/lib/recv.c +++ b/lib/recv.c @@ -1,6 +1,6 @@ /* recv.c --- wrappers for Windows recv function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/recvfrom.c b/lib/recvfrom.c index 0d4fba076..2da508e7a 100644 --- a/lib/recvfrom.c +++ b/lib/recvfrom.c @@ -1,6 +1,6 @@ /* recvfrom.c --- wrappers for Windows recvfrom function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/ref-add.sin b/lib/ref-add.sin index 9adfb0df0..313d82ee0 100644 --- a/lib/ref-add.sin +++ b/lib/ref-add.sin @@ -1,6 +1,6 @@ # Add this package to a list of references stored in a text file. # -# Copyright (C) 2000, 2009-2014 Free Software Foundation, Inc. +# Copyright (C) 2000, 2009-2016 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/ref-del.sin b/lib/ref-del.sin index 45449cbba..46532d8eb 100644 --- a/lib/ref-del.sin +++ b/lib/ref-del.sin @@ -1,6 +1,6 @@ # Remove this package from a list of references stored in a text file. # -# Copyright (C) 2000, 2009-2014 Free Software Foundation, Inc. +# Copyright (C) 2000, 2009-2016 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/regcomp.c b/lib/regcomp.c index 56faf11c4..6c4db27cf 100644 --- a/lib/regcomp.c +++ b/lib/regcomp.c @@ -1,5 +1,5 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2014 Free Software Foundation, Inc. + Copyright (C) 2002-2016 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa . @@ -17,6 +17,10 @@ License along with the GNU C Library; if not, see . */ +#ifdef _LIBC +# include +#endif + static reg_errcode_t re_compile_internal (regex_t *preg, const char * pattern, size_t length, reg_syntax_t syntax); static void re_compile_fastmap_iter (regex_t *bufp, @@ -149,9 +153,9 @@ static const char __re_error_msgid[] = gettext_noop ("Invalid back reference") /* REG_ESUBREG */ "\0" #define REG_EBRACK_IDX (REG_ESUBREG_IDX + sizeof "Invalid back reference") - gettext_noop ("Unmatched [ or [^") /* REG_EBRACK */ + gettext_noop ("Unmatched [, [^, [:, [., or [=") /* REG_EBRACK */ "\0" -#define REG_EPAREN_IDX (REG_EBRACK_IDX + sizeof "Unmatched [ or [^") +#define REG_EPAREN_IDX (REG_EBRACK_IDX + sizeof "Unmatched [, [^, [:, [., or [=") gettext_noop ("Unmatched ( or \\(") /* REG_EPAREN */ "\0" #define REG_EBRACE_IDX (REG_EPAREN_IDX + sizeof "Unmatched ( or \\(") @@ -209,17 +213,9 @@ static const size_t __re_error_msgid_idx[] = Assumes the 'allocated' (and perhaps 'buffer') and 'translate' fields are set in BUFP on entry. */ -#ifdef _LIBC -const char * -re_compile_pattern (pattern, length, bufp) - const char *pattern; - size_t length; - struct re_pattern_buffer *bufp; -#else /* size_t might promote */ const char * re_compile_pattern (const char *pattern, size_t length, struct re_pattern_buffer *bufp) -#endif { reg_errcode_t ret; @@ -257,8 +253,7 @@ reg_syntax_t re_syntax_options; defined in regex.h. We return the old syntax. */ reg_syntax_t -re_set_syntax (syntax) - reg_syntax_t syntax; +re_set_syntax (reg_syntax_t syntax) { reg_syntax_t ret = re_syntax_options; @@ -270,8 +265,7 @@ weak_alias (__re_set_syntax, re_set_syntax) #endif int -re_compile_fastmap (bufp) - struct re_pattern_buffer *bufp; +re_compile_fastmap (struct re_pattern_buffer *bufp) { re_dfa_t *dfa = bufp->buffer; char *fastmap = bufp->fastmap; @@ -335,7 +329,7 @@ re_compile_fastmap_iter (regex_t *bufp, const re_dfastate_t *init_state, memset (&state, '\0', sizeof (state)); if (__mbrtowc (&wc, (const char *) buf, p - buf, &state) == p - buf - && (__wcrtomb ((char *) buf, towlower (wc), &state) + && (__wcrtomb ((char *) buf, __towlower (wc), &state) != (size_t) -1)) re_set_fastmap (fastmap, false, buf[0]); } @@ -411,7 +405,7 @@ re_compile_fastmap_iter (regex_t *bufp, const re_dfastate_t *init_state, re_set_fastmap (fastmap, icase, *(unsigned char *) buf); if ((bufp->syntax & RE_ICASE) && dfa->mb_cur_max > 1) { - if (__wcrtomb (buf, towlower (cset->mbchars[i]), &state) + if (__wcrtomb (buf, __towlower (cset->mbchars[i]), &state) != (size_t) -1) re_set_fastmap (fastmap, false, *(unsigned char *) buf); } @@ -470,10 +464,7 @@ re_compile_fastmap_iter (regex_t *bufp, const re_dfastate_t *init_state, the return codes and their meanings.) */ int -regcomp (preg, pattern, cflags) - regex_t *_Restrict_ preg; - const char *_Restrict_ pattern; - int cflags; +regcomp (regex_t *_Restrict_ preg, const char *_Restrict_ pattern, int cflags) { reg_errcode_t ret; reg_syntax_t syntax = ((cflags & REG_EXTENDED) ? RE_SYNTAX_POSIX_EXTENDED @@ -531,18 +522,9 @@ weak_alias (__regcomp, regcomp) /* Returns a message corresponding to an error code, ERRCODE, returned from either regcomp or regexec. We don't use PREG here. */ -#ifdef _LIBC size_t -regerror (errcode, preg, errbuf, errbuf_size) - int errcode; - const regex_t *_Restrict_ preg; - char *_Restrict_ errbuf; - size_t errbuf_size; -#else /* size_t might promote */ -size_t -regerror (int errcode, const regex_t *_Restrict_ preg, - char *_Restrict_ errbuf, size_t errbuf_size) -#endif +regerror (int errcode, const regex_t *_Restrict_ preg, char *_Restrict_ errbuf, + size_t errbuf_size) { const char *msg; size_t msg_size; @@ -658,8 +640,7 @@ free_dfa_content (re_dfa_t *dfa) /* Free dynamically allocated space used by PREG. */ void -regfree (preg) - regex_t *preg; +regfree (regex_t *preg) { re_dfa_t *dfa = preg->buffer; if (BE (dfa != NULL, 1)) @@ -695,8 +676,7 @@ char * regcomp/regexec above without link errors. */ weak_function # endif -re_comp (s) - const char *s; +re_comp (const char *s) { reg_errcode_t ret; char *fastmap; @@ -1417,7 +1397,7 @@ calc_first (void *extra, bin_tree_t *node) { node->first = node; node->node_idx = re_dfa_add_node (dfa, node->token); - if (BE (node->node_idx == REG_MISSING, 0)) + if (BE (node->node_idx == -1, 0)) return REG_ESPACE; if (node->token.type == ANCHOR) dfa->nodes[node->node_idx].constraint = node->token.opr.ctx_type; @@ -1478,8 +1458,8 @@ link_nfa_nodes (void *extra, bin_tree_t *node) right = node->right->first->node_idx; else right = node->next->node_idx; - assert (REG_VALID_INDEX (left)); - assert (REG_VALID_INDEX (right)); + assert (left > -1); + assert (right > -1); err = re_node_set_init_2 (dfa->edests + idx, left, right); } break; @@ -1529,7 +1509,7 @@ duplicate_node_closure (re_dfa_t *dfa, Idx top_org_node, Idx top_clone_node, org_dest = dfa->nexts[org_node]; re_node_set_empty (dfa->edests + clone_node); clone_dest = duplicate_node (dfa, org_dest, constraint); - if (BE (clone_dest == REG_MISSING, 0)) + if (BE (clone_dest == -1, 0)) return REG_ESPACE; dfa->nexts[clone_node] = dfa->nexts[org_node]; ok = re_node_set_insert (dfa->edests + clone_node, clone_dest); @@ -1562,7 +1542,7 @@ duplicate_node_closure (re_dfa_t *dfa, Idx top_org_node, Idx top_clone_node, /* In case the node has another constraint, append it. */ constraint |= dfa->nodes[org_node].constraint; clone_dest = duplicate_node (dfa, org_dest, constraint); - if (BE (clone_dest == REG_MISSING, 0)) + if (BE (clone_dest == -1, 0)) return REG_ESPACE; ok = re_node_set_insert (dfa->edests + clone_node, clone_dest); if (BE (! ok, 0)) @@ -1576,12 +1556,12 @@ duplicate_node_closure (re_dfa_t *dfa, Idx top_org_node, Idx top_clone_node, re_node_set_empty (dfa->edests + clone_node); /* Search for a duplicated node which satisfies the constraint. */ clone_dest = search_duplicated_node (dfa, org_dest, constraint); - if (clone_dest == REG_MISSING) + if (clone_dest == -1) { /* There is no such duplicated node, create a new one. */ reg_errcode_t err; clone_dest = duplicate_node (dfa, org_dest, constraint); - if (BE (clone_dest == REG_MISSING, 0)) + if (BE (clone_dest == -1, 0)) return REG_ESPACE; ok = re_node_set_insert (dfa->edests + clone_node, clone_dest); if (BE (! ok, 0)) @@ -1602,7 +1582,7 @@ duplicate_node_closure (re_dfa_t *dfa, Idx top_org_node, Idx top_clone_node, org_dest = dfa->edests[org_node].elems[1]; clone_dest = duplicate_node (dfa, org_dest, constraint); - if (BE (clone_dest == REG_MISSING, 0)) + if (BE (clone_dest == -1, 0)) return REG_ESPACE; ok = re_node_set_insert (dfa->edests + clone_node, clone_dest); if (BE (! ok, 0)) @@ -1628,18 +1608,18 @@ search_duplicated_node (const re_dfa_t *dfa, Idx org_node, && constraint == dfa->nodes[idx].constraint) return idx; /* Found. */ } - return REG_MISSING; /* Not found. */ + return -1; /* Not found. */ } /* Duplicate the node whose index is ORG_IDX and set the constraint CONSTRAINT. - Return the index of the new node, or REG_MISSING if insufficient storage is + Return the index of the new node, or -1 if insufficient storage is available. */ static Idx duplicate_node (re_dfa_t *dfa, Idx org_idx, unsigned int constraint) { Idx dup_idx = re_dfa_add_node (dfa, dfa->nodes[org_idx]); - if (BE (dup_idx != REG_MISSING, 1)) + if (BE (dup_idx != -1, 1)) { dfa->nodes[dup_idx].constraint = constraint; dfa->nodes[dup_idx].constraint |= dfa->nodes[org_idx].constraint; @@ -1698,7 +1678,7 @@ calc_eclosure (re_dfa_t *dfa) } #ifdef DEBUG - assert (dfa->eclosures[node_idx].nelem != REG_MISSING); + assert (dfa->eclosures[node_idx].nelem != -1); #endif /* If we have already calculated, skip it. */ @@ -1734,7 +1714,7 @@ calc_eclosure_iter (re_node_set *new_set, re_dfa_t *dfa, Idx node, bool root) /* This indicates that we are calculating this node now. We reference this value to avoid infinite loop. */ - dfa->eclosures[node].nelem = REG_MISSING; + dfa->eclosures[node].nelem = -1; /* If the current node has constraints, duplicate all nodes since they must inherit the constraints. */ @@ -1756,7 +1736,7 @@ calc_eclosure_iter (re_node_set *new_set, re_dfa_t *dfa, Idx node, bool root) Idx edest = dfa->edests[node].elems[i]; /* If calculating the epsilon closure of 'edest' is in progress, return intermediate result. */ - if (dfa->eclosures[edest].nelem == REG_MISSING) + if (dfa->eclosures[edest].nelem == -1) { incomplete = true; continue; @@ -2187,6 +2167,7 @@ parse_reg_exp (re_string_t *regexp, regex_t *preg, re_token_t *token, { re_dfa_t *dfa = preg->buffer; bin_tree_t *tree, *branch = NULL; + bitset_word_t initial_bkref_map = dfa->completed_bkref_map; tree = parse_branch (regexp, preg, token, syntax, nest, err); if (BE (*err != REG_NOERROR && tree == NULL, 0)) return NULL; @@ -2197,9 +2178,16 @@ parse_reg_exp (re_string_t *regexp, regex_t *preg, re_token_t *token, if (token->type != OP_ALT && token->type != END_OF_RE && (nest == 0 || token->type != OP_CLOSE_SUBEXP)) { + bitset_word_t accumulated_bkref_map = dfa->completed_bkref_map; + dfa->completed_bkref_map = initial_bkref_map; branch = parse_branch (regexp, preg, token, syntax, nest, err); if (BE (*err != REG_NOERROR && branch == NULL, 0)) - return NULL; + { + if (tree != NULL) + postorder (tree, free_tree, NULL); + return NULL; + } + dfa->completed_bkref_map |= accumulated_bkref_map; } else branch = NULL; @@ -2460,14 +2448,22 @@ parse_expression (re_string_t *regexp, regex_t *preg, re_token_t *token, while (token->type == OP_DUP_ASTERISK || token->type == OP_DUP_PLUS || token->type == OP_DUP_QUESTION || token->type == OP_OPEN_DUP_NUM) { - tree = parse_dup_op (tree, regexp, dfa, token, syntax, err); - if (BE (*err != REG_NOERROR && tree == NULL, 0)) - return NULL; + bin_tree_t *dup_tree = parse_dup_op (tree, regexp, dfa, token, + syntax, err); + if (BE (*err != REG_NOERROR && dup_tree == NULL, 0)) + { + if (tree != NULL) + postorder (tree, free_tree, NULL); + return NULL; + } + tree = dup_tree; /* In BRE consecutive duplications are not allowed. */ if ((syntax & RE_CONTEXT_INVALID_DUP) && (token->type == OP_DUP_ASTERISK || token->type == OP_OPEN_DUP_NUM)) { + if (tree != NULL) + postorder (tree, free_tree, NULL); *err = REG_BADRPT; return NULL; } @@ -2537,7 +2533,7 @@ parse_dup_op (bin_tree_t *elem, re_string_t *regexp, re_dfa_t *dfa, { end = 0; start = fetch_number (regexp, token, syntax); - if (start == REG_MISSING) + if (start == -1) { if (token->type == CHARACTER && token->opr.c == ',') start = 0; /* We treat "{,m}" as "{0,m}". */ @@ -2547,14 +2543,14 @@ parse_dup_op (bin_tree_t *elem, re_string_t *regexp, re_dfa_t *dfa, return NULL; } } - if (BE (start != REG_ERROR, 1)) + if (BE (start != -2, 1)) { /* We treat "{n}" as "{n,n}". */ end = ((token->type == OP_CLOSE_DUP_NUM) ? start : ((token->type == CHARACTER && token->opr.c == ',') - ? fetch_number (regexp, token, syntax) : REG_ERROR)); + ? fetch_number (regexp, token, syntax) : -2)); } - if (BE (start == REG_ERROR || end == REG_ERROR, 0)) + if (BE (start == -2 || end == -2, 0)) { /* Invalid sequence. */ if (BE (!(syntax & RE_INVALID_INTERVAL_ORD), 0)) @@ -2576,7 +2572,7 @@ parse_dup_op (bin_tree_t *elem, re_string_t *regexp, re_dfa_t *dfa, return elem; } - if (BE ((end != REG_MISSING && start > end) + if (BE ((end != -1 && start > end) || token->type != OP_CLOSE_DUP_NUM, 0)) { /* First number greater than second. */ @@ -2584,7 +2580,7 @@ parse_dup_op (bin_tree_t *elem, re_string_t *regexp, re_dfa_t *dfa, return NULL; } - if (BE (RE_DUP_MAX < (end == REG_MISSING ? start : end), 0)) + if (BE (RE_DUP_MAX < (end == -1 ? start : end), 0)) { *err = REG_ESIZE; return NULL; @@ -2593,7 +2589,7 @@ parse_dup_op (bin_tree_t *elem, re_string_t *regexp, re_dfa_t *dfa, else { start = (token->type == OP_DUP_PLUS) ? 1 : 0; - end = (token->type == OP_DUP_QUESTION) ? 1 : REG_MISSING; + end = (token->type == OP_DUP_QUESTION) ? 1 : -1; } fetch_token (token, regexp, syntax); @@ -2623,6 +2619,8 @@ parse_dup_op (bin_tree_t *elem, re_string_t *regexp, re_dfa_t *dfa, /* Duplicate ELEM before it is marked optional. */ elem = duplicate_tree (elem, dfa); + if (BE (elem == NULL, 0)) + goto parse_dup_op_espace; old_tree = tree; } else @@ -2635,7 +2633,7 @@ parse_dup_op (bin_tree_t *elem, re_string_t *regexp, re_dfa_t *dfa, } tree = create_tree (dfa, elem, NULL, - (end == REG_MISSING ? OP_DUP_ASTERISK : OP_ALT)); + (end == -1 ? OP_DUP_ASTERISK : OP_ALT)); if (BE (tree == NULL, 0)) goto parse_dup_op_espace; @@ -2643,10 +2641,10 @@ parse_dup_op (bin_tree_t *elem, re_string_t *regexp, re_dfa_t *dfa, True if the arithmetic type T is signed. */ #define TYPE_SIGNED(t) (! ((t) 0 < (t) -1)) - /* This loop is actually executed only when end != REG_MISSING, + /* This loop is actually executed only when end != -1, to rewrite {0,n} as ((...?)?)?... We have already created the start+1-th copy. */ - if (TYPE_SIGNED (Idx) || end != REG_MISSING) + if (TYPE_SIGNED (Idx) || end != -1) for (i = start + 2; i <= end; ++i) { elem = duplicate_tree (elem, dfa); @@ -2674,6 +2672,19 @@ parse_dup_op (bin_tree_t *elem, re_string_t *regexp, re_dfa_t *dfa, #define BRACKET_NAME_BUF_SIZE 32 #ifndef _LIBC + +# ifdef RE_ENABLE_I18N +/* Convert the byte B to the corresponding wide character. In a + unibyte locale, treat B as itself if it is an encoding error. + In a multibyte locale, return WEOF if B is an encoding error. */ +static wint_t +parse_byte (unsigned char b, re_charset_t *mbcset) +{ + wint_t wc = __btowc (b); + return wc == WEOF && !mbcset ? b : wc; +} +#endif + /* Local function for parse_bracket_exp only used in case of NOT _LIBC. Build the range expression which starts from START_ELEM, and ends at END_ELEM. The result are written to MBCSET and SBCSET. @@ -2725,9 +2736,9 @@ build_range_exp (const reg_syntax_t syntax, : ((end_elem->type == COLL_SYM) ? end_elem->opr.name[0] : 0)); start_wc = ((start_elem->type == SB_CHAR || start_elem->type == COLL_SYM) - ? __btowc (start_ch) : start_elem->opr.wch); + ? parse_byte (start_ch, mbcset) : start_elem->opr.wch); end_wc = ((end_elem->type == SB_CHAR || end_elem->type == COLL_SYM) - ? __btowc (end_ch) : end_elem->opr.wch); + ? parse_byte (end_ch, mbcset) : end_elem->opr.wch); if (start_wc == WEOF || end_wc == WEOF) return REG_ECOLLATE; else if (BE ((syntax & RE_NO_EMPTY_RANGES) && start_wc > end_wc, 0)) @@ -2757,7 +2768,11 @@ build_range_exp (const reg_syntax_t syntax, new_nranges); if (BE (new_array_start == NULL || new_array_end == NULL, 0)) - return REG_ESPACE; + { + re_free (new_array_start); + re_free (new_array_end); + return REG_ESPACE; + } mbcset->range_starts = new_array_start; mbcset->range_ends = new_array_end; @@ -3161,6 +3176,7 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token, re_token_t token2; start_elem.opr.name = start_name_buf; + start_elem.type = COLL_SYM; ret = parse_bracket_element (&start_elem, regexp, token, token_len, dfa, syntax, first_round); if (BE (ret != REG_NOERROR, 0)) @@ -3204,6 +3220,7 @@ parse_bracket_exp (re_string_t *regexp, re_dfa_t *dfa, re_token_t *token, if (is_range_exp == true) { end_elem.opr.name = end_name_buf; + end_elem.type = COLL_SYM; ret = parse_bracket_element (&end_elem, regexp, &token2, token_len2, dfa, syntax, true); if (BE (ret != REG_NOERROR, 0)) @@ -3478,8 +3495,6 @@ build_equiv_class (bitset_t sbcset, const unsigned char *name) int32_t idx1, idx2; unsigned int ch; size_t len; - /* This #include defines a local function! */ -# include /* Calculate the index for equivalence class. */ cp = name; table = (const int32_t *) _NL_CURRENT (LC_COLLATE, _NL_COLLATE_TABLEMB); @@ -3489,7 +3504,7 @@ build_equiv_class (bitset_t sbcset, const unsigned char *name) _NL_COLLATE_EXTRAMB); indirect = (const int32_t *) _NL_CURRENT (LC_COLLATE, _NL_COLLATE_INDIRECTMB); - idx1 = findidx (&cp, -1); + idx1 = findidx (table, indirect, extra, &cp, -1); if (BE (idx1 == 0 || *cp != '\0', 0)) /* This isn't a valid character. */ return REG_ECOLLATE; @@ -3500,7 +3515,7 @@ build_equiv_class (bitset_t sbcset, const unsigned char *name) { char_buf[0] = ch; cp = char_buf; - idx2 = findidx (&cp, 1); + idx2 = findidx (table, indirect, extra, &cp, 1); /* idx2 = table[ch]; */ @@ -3654,26 +3669,21 @@ build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans, bin_tree_t *tree; sbcset = (re_bitset_ptr_t) calloc (sizeof (bitset_t), 1); -#ifdef RE_ENABLE_I18N - mbcset = (re_charset_t *) calloc (sizeof (re_charset_t), 1); -#endif /* RE_ENABLE_I18N */ - -#ifdef RE_ENABLE_I18N - if (BE (sbcset == NULL || mbcset == NULL, 0)) -#else /* not RE_ENABLE_I18N */ if (BE (sbcset == NULL, 0)) -#endif /* not RE_ENABLE_I18N */ { *err = REG_ESPACE; return NULL; } - - if (non_match) - { #ifdef RE_ENABLE_I18N - mbcset->non_match = 1; -#endif /* not RE_ENABLE_I18N */ + mbcset = (re_charset_t *) calloc (sizeof (re_charset_t), 1); + if (BE (mbcset == NULL, 0)) + { + re_free (sbcset); + *err = REG_ESPACE; + return NULL; } + mbcset->non_match = non_match; +#endif /* RE_ENABLE_I18N */ /* We don't care the syntax in this case. */ ret = build_charclass (trans, sbcset, @@ -3706,6 +3716,9 @@ build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans, #endif /* Build a tree for simple bracket. */ +#if defined GCC_LINT || defined lint + memset (&br_token, 0, sizeof br_token); +#endif br_token.type = SIMPLE_BRACKET; br_token.opr.sbcset = sbcset; tree = create_token_tree (dfa, NULL, NULL, &br_token); @@ -3748,27 +3761,26 @@ build_charclass_op (re_dfa_t *dfa, RE_TRANSLATE_TYPE trans, /* This is intended for the expressions like "a{1,3}". Fetch a number from 'input', and return the number. - Return REG_MISSING if the number field is empty like "{,1}". + Return -1 if the number field is empty like "{,1}". Return RE_DUP_MAX + 1 if the number field is too large. - Return REG_ERROR if an error occurred. */ + Return -2 if an error occurred. */ static Idx fetch_number (re_string_t *input, re_token_t *token, reg_syntax_t syntax) { - Idx num = REG_MISSING; + Idx num = -1; unsigned char c; while (1) { fetch_token (token, input, syntax); c = token->opr.c; if (BE (token->type == END_OF_RE, 0)) - return REG_ERROR; + return -2; if (token->type == OP_CLOSE_DUP_NUM || c == ',') break; - num = ((token->type != CHARACTER || c < '0' || '9' < c - || num == REG_ERROR) - ? REG_ERROR - : num == REG_MISSING + num = ((token->type != CHARACTER || c < '0' || '9' < c || num == -2) + ? -2 + : num == -1 ? c - '0' : MIN (RE_DUP_MAX + 1, num * 10 + c - '0')); } @@ -3800,6 +3812,9 @@ create_tree (re_dfa_t *dfa, bin_tree_t *left, bin_tree_t *right, re_token_type_t type) { re_token_t t; +#if defined GCC_LINT || defined lint + memset (&t, 0, sizeof t); +#endif t.type = type; return create_token_tree (dfa, left, right, &t); } @@ -3829,7 +3844,7 @@ create_token_tree (re_dfa_t *dfa, bin_tree_t *left, bin_tree_t *right, tree->token.opt_subexp = 0; tree->first = NULL; tree->next = NULL; - tree->node_idx = REG_MISSING; + tree->node_idx = -1; if (left != NULL) left->parent = tree; diff --git a/lib/regex.c b/lib/regex.c index e44f55fd1..f5b46559a 100644 --- a/lib/regex.c +++ b/lib/regex.c @@ -1,5 +1,5 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2014 Free Software Foundation, Inc. + Copyright (C) 2002-2016 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa . diff --git a/lib/regex.h b/lib/regex.h index 54327c69e..3ba64ac89 100644 --- a/lib/regex.h +++ b/lib/regex.h @@ -1,6 +1,6 @@ /* Definitions for data structures and routines for the regular expression library. - Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2014 Free Software + Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2016 Free Software Foundation, Inc. This file is part of the GNU C Library. @@ -42,11 +42,6 @@ extern "C" { supported within glibc itself, and glibc users should not define _REGEX_LARGE_OFFSETS. */ -/* The type of nonnegative object indexes. Traditionally, GNU regex - uses 'int' for these. Code that uses __re_idx_t should work - regardless of whether the type is signed. */ -typedef size_t __re_idx_t; - /* The type of object sizes. */ typedef size_t __re_size_t; @@ -58,7 +53,6 @@ typedef size_t __re_long_size_t; /* The traditional GNU regex implementation mishandles strings longer than INT_MAX. */ -typedef int __re_idx_t; typedef unsigned int __re_size_t; typedef unsigned long int __re_long_size_t; @@ -244,19 +238,16 @@ extern reg_syntax_t re_syntax_options; | RE_INVALID_INTERVAL_ORD) # define RE_SYNTAX_GREP \ - (RE_BK_PLUS_QM | RE_CHAR_CLASSES \ - | RE_HAT_LISTS_NOT_NEWLINE | RE_INTERVALS \ - | RE_NEWLINE_ALT) + ((RE_SYNTAX_POSIX_BASIC | RE_NEWLINE_ALT) \ + & ~(RE_CONTEXT_INVALID_DUP | RE_DOT_NOT_NULL)) # define RE_SYNTAX_EGREP \ - (RE_CHAR_CLASSES | RE_CONTEXT_INDEP_ANCHORS \ - | RE_CONTEXT_INDEP_OPS | RE_HAT_LISTS_NOT_NEWLINE \ - | RE_NEWLINE_ALT | RE_NO_BK_PARENS \ - | RE_NO_BK_VBAR) + ((RE_SYNTAX_POSIX_EXTENDED | RE_INVALID_INTERVAL_ORD | RE_NEWLINE_ALT) \ + & ~(RE_CONTEXT_INVALID_OPS | RE_DOT_NOT_NULL)) +/* POSIX grep -E behavior is no longer incompatible with GNU. */ # define RE_SYNTAX_POSIX_EGREP \ - (RE_SYNTAX_EGREP | RE_INTERVALS | RE_NO_BK_BRACES \ - | RE_INVALID_INTERVAL_ORD) + RE_SYNTAX_EGREP /* P1003.2/D11.2, section 4.20.7.1, lines 5078ff. */ # define RE_SYNTAX_ED RE_SYNTAX_POSIX_BASIC @@ -491,7 +482,8 @@ typedef struct re_pattern_buffer regex_t; #ifdef _REGEX_LARGE_OFFSETS /* POSIX 1003.1-2008 requires that regoff_t be at least as wide as ptrdiff_t and ssize_t. We don't know of any hosts where ptrdiff_t - is wider than ssize_t, so ssize_t is safe. */ + is wider than ssize_t, so ssize_t is safe. ptrdiff_t is not + visible here, so use ssize_t. */ typedef ssize_t regoff_t; #else /* The traditional GNU regex implementation mishandles strings longer @@ -541,7 +533,7 @@ extern reg_syntax_t re_set_syntax (reg_syntax_t __syntax); BUFFER. Return NULL if successful, and an error string if not. To free the allocated storage, you must call 'regfree' on BUFFER. - Note that the translate table must either have been initialised by + Note that the translate table must either have been initialized by 'regcomp', with a malloc'ed value, or set to NULL before calling 'regfree'. */ extern const char *re_compile_pattern (const char *__pattern, size_t __length, @@ -560,34 +552,34 @@ extern int re_compile_fastmap (struct re_pattern_buffer *__buffer); match, or -2 for an internal error. Also return register information in REGS (if REGS and BUFFER->no_sub are nonzero). */ extern regoff_t re_search (struct re_pattern_buffer *__buffer, - const char *__string, __re_idx_t __length, - __re_idx_t __start, regoff_t __range, + const char *__string, regoff_t __length, + regoff_t __start, regoff_t __range, struct re_registers *__regs); /* Like 're_search', but search in the concatenation of STRING1 and STRING2. Also, stop searching at index START + STOP. */ extern regoff_t re_search_2 (struct re_pattern_buffer *__buffer, - const char *__string1, __re_idx_t __length1, - const char *__string2, __re_idx_t __length2, - __re_idx_t __start, regoff_t __range, + const char *__string1, regoff_t __length1, + const char *__string2, regoff_t __length2, + regoff_t __start, regoff_t __range, struct re_registers *__regs, - __re_idx_t __stop); + regoff_t __stop); /* Like 're_search', but return how many characters in STRING the regexp in BUFFER matched, starting at position START. */ extern regoff_t re_match (struct re_pattern_buffer *__buffer, - const char *__string, __re_idx_t __length, - __re_idx_t __start, struct re_registers *__regs); + const char *__string, regoff_t __length, + regoff_t __start, struct re_registers *__regs); /* Relates to 're_match' as 're_search_2' relates to 're_search'. */ extern regoff_t re_match_2 (struct re_pattern_buffer *__buffer, - const char *__string1, __re_idx_t __length1, - const char *__string2, __re_idx_t __length2, - __re_idx_t __start, struct re_registers *__regs, - __re_idx_t __stop); + const char *__string1, regoff_t __length1, + const char *__string2, regoff_t __length2, + regoff_t __start, struct re_registers *__regs, + regoff_t __stop); /* Set REGS to hold NUM_REGS registers, storing them in STARTS and @@ -608,7 +600,7 @@ extern void re_set_registers (struct re_pattern_buffer *__buffer, regoff_t *__starts, regoff_t *__ends); #endif /* Use GNU */ -#if defined _REGEX_RE_COMP || (defined _LIBC && defined __USE_BSD) +#if defined _REGEX_RE_COMP || (defined _LIBC && defined __USE_MISC) # ifndef _CRAY /* 4.2 bsd compatibility. */ extern char *re_comp (const char *); diff --git a/lib/regex_internal.c b/lib/regex_internal.c index 0343ee6e3..cd78b252a 100644 --- a/lib/regex_internal.c +++ b/lib/regex_internal.c @@ -1,5 +1,5 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2014 Free Software Foundation, Inc. + Copyright (C) 2002-2016 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa . @@ -311,13 +311,12 @@ build_wcs_upper_buffer (re_string_t *pstr) + byte_idx), remain_len, &pstr->cur_state); if (BE (mbclen < (size_t) -2, 1)) { - wchar_t wcu = wc; - if (iswlower (wc)) + wchar_t wcu = __towupper (wc); + if (wcu != wc) { size_t mbcdlen; - wcu = towupper (wc); - mbcdlen = wcrtomb (buf, wcu, &prev_st); + mbcdlen = __wcrtomb (buf, wcu, &prev_st); if (BE (mbclen == mbcdlen, 1)) memcpy (pstr->mbs + byte_idx, buf, mbclen); else @@ -381,12 +380,11 @@ build_wcs_upper_buffer (re_string_t *pstr) mbclen = __mbrtowc (&wc, p, remain_len, &pstr->cur_state); if (BE (mbclen < (size_t) -2, 1)) { - wchar_t wcu = wc; - if (iswlower (wc)) + wchar_t wcu = __towupper (wc); + if (wcu != wc) { size_t mbcdlen; - wcu = towupper (wc); mbcdlen = wcrtomb ((char *) buf, wcu, &prev_st); if (BE (mbclen == mbcdlen, 1)) memcpy (pstr->mbs + byte_idx, buf, mbclen); @@ -538,10 +536,7 @@ build_upper_buffer (re_string_t *pstr) int ch = pstr->raw_mbs[pstr->raw_mbs_idx + char_idx]; if (BE (pstr->trans != NULL, 0)) ch = pstr->trans[ch]; - if (islower (ch)) - pstr->mbs[char_idx] = toupper (ch); - else - pstr->mbs[char_idx] = ch; + pstr->mbs[char_idx] = toupper (ch); } pstr->valid_len = char_idx; pstr->valid_raw_len = char_idx; @@ -682,7 +677,7 @@ re_string_reconstruct (re_string_t *pstr, Idx idx, int eflags) pstr->valid_len - offset); pstr->valid_len -= offset; pstr->valid_raw_len -= offset; -#if DEBUG +#if defined DEBUG && DEBUG assert (pstr->valid_len > 0); #endif } @@ -927,7 +922,7 @@ internal_function re_string_context_at (const re_string_t *input, Idx idx, int eflags) { int c; - if (BE (! REG_VALID_INDEX (idx), 0)) + if (BE (idx < 0, 0)) /* In this case, we use the value stored in input->tip_context, since we can't know the character in input->mbs[-1] here. */ return input->tip_context; @@ -941,12 +936,12 @@ re_string_context_at (const re_string_t *input, Idx idx, int eflags) Idx wc_idx = idx; while(input->wcs[wc_idx] == WEOF) { -#ifdef DEBUG +#if defined DEBUG && DEBUG /* It must not happen. */ - assert (REG_VALID_INDEX (wc_idx)); + assert (wc_idx >= 0); #endif --wc_idx; - if (! REG_VALID_INDEX (wc_idx)) + if (wc_idx < 0) return input->tip_context; } wc = input->wcs[wc_idx]; @@ -1082,25 +1077,25 @@ re_node_set_add_intersect (re_node_set *dest, const re_node_set *src1, if (src1->elems[i1] == src2->elems[i2]) { /* Try to find the item in DEST. Maybe we could binary search? */ - while (REG_VALID_INDEX (id) && dest->elems[id] > src1->elems[i1]) + while (id >= 0 && dest->elems[id] > src1->elems[i1]) --id; - if (! REG_VALID_INDEX (id) || dest->elems[id] != src1->elems[i1]) + if (id < 0 || dest->elems[id] != src1->elems[i1]) dest->elems[--sbase] = src1->elems[i1]; - if (! REG_VALID_INDEX (--i1) || ! REG_VALID_INDEX (--i2)) + if (--i1 < 0 || --i2 < 0) break; } /* Lower the highest of the two items. */ else if (src1->elems[i1] < src2->elems[i2]) { - if (! REG_VALID_INDEX (--i2)) + if (--i2 < 0) break; } else { - if (! REG_VALID_INDEX (--i1)) + if (--i1 < 0) break; } } @@ -1113,7 +1108,7 @@ re_node_set_add_intersect (re_node_set *dest, const re_node_set *src1, DEST elements are already in place; this is more or less the same loop that is in re_node_set_merge. */ dest->nelem += delta; - if (delta > 0 && REG_VALID_INDEX (id)) + if (delta > 0 && id >= 0) for (;;) { if (dest->elems[is] > dest->elems[id]) @@ -1127,7 +1122,7 @@ re_node_set_add_intersect (re_node_set *dest, const re_node_set *src1, { /* Slide from the bottom. */ dest->elems[id + delta] = dest->elems[id]; - if (! REG_VALID_INDEX (--id)) + if (--id < 0) break; } } @@ -1221,8 +1216,7 @@ re_node_set_merge (re_node_set *dest, const re_node_set *src) /* Copy into the top of DEST the items of SRC that are not found in DEST. Maybe we could binary search in DEST? */ for (sbase = dest->nelem + 2 * src->nelem, - is = src->nelem - 1, id = dest->nelem - 1; - REG_VALID_INDEX (is) && REG_VALID_INDEX (id); ) + is = src->nelem - 1, id = dest->nelem - 1; is >= 0 && id >= 0; ) { if (dest->elems[id] == src->elems[is]) is--, id--; @@ -1232,7 +1226,7 @@ re_node_set_merge (re_node_set *dest, const re_node_set *src) --id; } - if (REG_VALID_INDEX (is)) + if (is >= 0) { /* If DEST is exhausted, the remaining items of SRC must be unique. */ sbase -= is + 1; @@ -1261,7 +1255,7 @@ re_node_set_merge (re_node_set *dest, const re_node_set *src) { /* Slide from the bottom. */ dest->elems[id + delta] = dest->elems[id]; - if (! REG_VALID_INDEX (--id)) + if (--id < 0) { /* Copy remaining SRC elements. */ memcpy (dest->elems, dest->elems + sbase, @@ -1360,7 +1354,7 @@ re_node_set_compare (const re_node_set *set1, const re_node_set *set2) Idx i; if (set1 == NULL || set2 == NULL || set1->nelem != set2->nelem) return false; - for (i = set1->nelem ; REG_VALID_INDEX (--i) ; ) + for (i = set1->nelem ; --i >= 0 ; ) if (set1->elems[i] != set2->elems[i]) return false; return true; @@ -1373,7 +1367,7 @@ internal_function __attribute__ ((pure)) re_node_set_contains (const re_node_set *set, Idx elem) { __re_size_t idx, right, mid; - if (! REG_VALID_NONZERO_INDEX (set->nelem)) + if (set->nelem <= 0) return 0; /* Binary search the element. */ @@ -1403,7 +1397,7 @@ re_node_set_remove_at (re_node_set *set, Idx idx) /* Add the token TOKEN to dfa->nodes, and return the index of the token. - Or return REG_MISSING if an error occurred. */ + Or return -1 if an error occurred. */ static Idx internal_function @@ -1421,11 +1415,11 @@ re_dfa_add_node (re_dfa_t *dfa, re_token_t token) MAX (sizeof (re_node_set), sizeof (Idx))); if (BE (MIN (IDX_MAX, SIZE_MAX / max_object_size) < new_nodes_alloc, 0)) - return REG_MISSING; + return -1; new_nodes = re_realloc (dfa->nodes, re_token_t, new_nodes_alloc); if (BE (new_nodes == NULL, 0)) - return REG_MISSING; + return -1; dfa->nodes = new_nodes; new_nexts = re_realloc (dfa->nexts, Idx, new_nodes_alloc); new_indices = re_realloc (dfa->org_indices, Idx, new_nodes_alloc); @@ -1433,7 +1427,13 @@ re_dfa_add_node (re_dfa_t *dfa, re_token_t token) new_eclosures = re_realloc (dfa->eclosures, re_node_set, new_nodes_alloc); if (BE (new_nexts == NULL || new_indices == NULL || new_edests == NULL || new_eclosures == NULL, 0)) - return REG_MISSING; + { + re_free (new_nexts); + re_free (new_indices); + re_free (new_edests); + re_free (new_eclosures); + return -1; + } dfa->nexts = new_nexts; dfa->org_indices = new_indices; dfa->edests = new_edests; @@ -1447,7 +1447,7 @@ re_dfa_add_node (re_dfa_t *dfa, re_token_t token) ((token.type == OP_PERIOD && dfa->mb_cur_max > 1) || token.type == COMPLEX_BRACKET); #endif - dfa->nexts[dfa->nodes_len] = REG_MISSING; + dfa->nexts[dfa->nodes_len] = -1; re_node_set_init_empty (dfa->edests + dfa->nodes_len); re_node_set_init_empty (dfa->eclosures + dfa->nodes_len); return dfa->nodes_len++; @@ -1482,7 +1482,7 @@ re_acquire_state (reg_errcode_t *err, const re_dfa_t *dfa, re_dfastate_t *new_state; struct re_state_table_entry *spot; Idx i; -#ifdef lint +#if defined GCC_LINT || defined lint /* Suppress bogus uninitialized-variable warnings. */ *err = REG_NOERROR; #endif @@ -1530,7 +1530,7 @@ re_acquire_state_context (reg_errcode_t *err, const re_dfa_t *dfa, re_dfastate_t *new_state; struct re_state_table_entry *spot; Idx i; -#ifdef lint +#if defined GCC_LINT || defined lint /* Suppress bogus uninitialized-variable warnings. */ *err = REG_NOERROR; #endif diff --git a/lib/regex_internal.h b/lib/regex_internal.h index a0eae33e9..56a315a4f 100644 --- a/lib/regex_internal.h +++ b/lib/regex_internal.h @@ -1,5 +1,5 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2014 Free Software Foundation, Inc. + Copyright (C) 2002-2016 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa . @@ -34,13 +34,13 @@ #include #ifdef _LIBC -# include +# include # define lock_define(name) __libc_lock_define (, name) # define lock_init(lock) (__libc_lock_init (lock), 0) # define lock_fini(lock) 0 # define lock_lock(lock) __libc_lock_lock (lock) # define lock_unlock(lock) __libc_lock_unlock (lock) -#elif defined GNULIB_LOCK +#elif defined GNULIB_LOCK && !defined USE_UNLOCKED_IO # include "glthread/lock.h" /* Use gl_lock_define if empty macro arguments are known to work. Otherwise, fall back on less-portable substitutes. */ @@ -62,7 +62,7 @@ # define lock_fini(lock) glthread_lock_destroy (&(lock)) # define lock_lock(lock) glthread_lock_lock (&(lock)) # define lock_unlock(lock) glthread_lock_unlock (&(lock)) -#elif defined GNULIB_PTHREAD +#elif defined GNULIB_PTHREAD && !defined USE_UNLOCKED_IO # include # define lock_define(name) pthread_mutex_t name; # define lock_init(lock) pthread_mutex_init (&(lock), 0) @@ -87,7 +87,6 @@ # ifndef _RE_DEFINE_LOCALE_FUNCTIONS # define _RE_DEFINE_LOCALE_FUNCTIONS 1 # include -# include # include # endif #endif @@ -137,7 +136,10 @@ # undef __wctype # undef __iswctype # define __wctype wctype +# define __iswalnum iswalnum # define __iswctype iswctype +# define __towlower towlower +# define __towupper towupper # define __btowc btowc # define __mbrtowc mbrtowc # define __wcrtomb wcrtomb @@ -149,33 +151,24 @@ # define __attribute__(arg) #endif -typedef __re_idx_t Idx; +#ifndef SSIZE_MAX +# define SSIZE_MAX ((ssize_t) (SIZE_MAX / 2)) +#endif + +/* The type of indexes into strings. This is signed, not size_t, + since the API requires indexes to fit in regoff_t anyway, and using + signed integers makes the code a bit smaller and presumably faster. + The traditional GNU regex implementation uses int for indexes. + The POSIX-compatible implementation uses a possibly-wider type. + The name 'Idx' is three letters to minimize the hassle of + reindenting a lot of regex code that formerly used 'int'. */ +typedef regoff_t Idx; #ifdef _REGEX_LARGE_OFFSETS -# define IDX_MAX (SIZE_MAX - 2) +# define IDX_MAX SSIZE_MAX #else # define IDX_MAX INT_MAX #endif -/* Special return value for failure to match. */ -#define REG_MISSING ((Idx) -1) - -/* Special return value for internal error. */ -#define REG_ERROR ((Idx) -2) - -/* Test whether N is a valid index, and is not one of the above. */ -#ifdef _REGEX_LARGE_OFFSETS -# define REG_VALID_INDEX(n) ((Idx) (n) < REG_ERROR) -#else -# define REG_VALID_INDEX(n) (0 <= (n)) -#endif - -/* Test whether N is a valid nonzero index. */ -#ifdef _REGEX_LARGE_OFFSETS -# define REG_VALID_NONZERO_INDEX(n) ((Idx) ((n) - 1) < (Idx) (REG_ERROR - 1)) -#else -# define REG_VALID_NONZERO_INDEX(n) (0 < (n)) -#endif - /* A hash value, suitable for computing hash tables. */ typedef __re_size_t re_hashval_t; @@ -447,23 +440,23 @@ typedef struct re_dfa_t re_dfa_t; #ifndef _LIBC # define internal_function +# define IS_IN(libc) false #endif -#ifndef NOT_IN_libc static reg_errcode_t re_string_realloc_buffers (re_string_t *pstr, Idx new_buf_len) internal_function; -# ifdef RE_ENABLE_I18N +#ifdef RE_ENABLE_I18N static void build_wcs_buffer (re_string_t *pstr) internal_function; static reg_errcode_t build_wcs_upper_buffer (re_string_t *pstr) internal_function; -# endif /* RE_ENABLE_I18N */ +#endif /* RE_ENABLE_I18N */ static void build_upper_buffer (re_string_t *pstr) internal_function; static void re_string_translate_buffer (re_string_t *pstr) internal_function; static unsigned int re_string_context_at (const re_string_t *input, Idx idx, int eflags) internal_function __attribute__ ((pure)); -#endif + #define re_string_peek_byte(pstr, offset) \ ((pstr)->mbs[(pstr)->cur_idx + offset]) #define re_string_fetch_byte(pstr) \ @@ -556,7 +549,7 @@ typedef struct bin_tree_storage_t bin_tree_storage_t; #define IS_WORD_CHAR(ch) (isalnum (ch) || (ch) == '_') #define IS_NEWLINE(ch) ((ch) == NEWLINE_CHAR) -#define IS_WIDE_WORD_CHAR(ch) (iswalnum (ch) || (ch) == L'_') +#define IS_WIDE_WORD_CHAR(ch) (__iswalnum (ch) || (ch) == L'_') #define IS_WIDE_NEWLINE(ch) ((ch) == WIDE_NEWLINE_CHAR) #define NOT_SATISFY_PREV_CONSTRAINT(constraint,context) \ @@ -860,15 +853,17 @@ re_string_wchar_at (const re_string_t *pstr, Idx idx) return (wint_t) pstr->wcs[idx]; } -# ifndef NOT_IN_libc +# ifdef _LIBC +# include +# endif + static int internal_function __attribute__ ((pure, unused)) re_string_elem_size_at (const re_string_t *pstr, Idx idx) { -# ifdef _LIBC +# ifdef _LIBC const unsigned char *p, *extra; const int32_t *table, *indirect; -# include uint_fast32_t nrules = _NL_CURRENT_WORD (LC_COLLATE, _NL_COLLATE_NRULES); if (nrules != 0) @@ -879,14 +874,13 @@ re_string_elem_size_at (const re_string_t *pstr, Idx idx) indirect = (const int32_t *) _NL_CURRENT (LC_COLLATE, _NL_COLLATE_INDIRECTMB); p = pstr->mbs + idx; - findidx (&p, pstr->len - idx); + findidx (table, indirect, extra, &p, pstr->len - idx); return p - pstr->mbs - idx; } else -# endif /* _LIBC */ +# endif /* _LIBC */ return 1; } -# endif #endif /* RE_ENABLE_I18N */ #ifndef __GNUC_PREREQ diff --git a/lib/regexec.c b/lib/regexec.c index 05a8e807e..afdc1737b 100644 --- a/lib/regexec.c +++ b/lib/regexec.c @@ -1,5 +1,5 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2014 Free Software Foundation, Inc. + Copyright (C) 2002-2016 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa . @@ -219,12 +219,8 @@ static reg_errcode_t extend_buffers (re_match_context_t *mctx, int min_len) We return 0 if we find a match and REG_NOMATCH if not. */ int -regexec (preg, string, nmatch, pmatch, eflags) - const regex_t *_Restrict_ preg; - const char *_Restrict_ string; - size_t nmatch; - regmatch_t pmatch[_Restrict_arr_]; - int eflags; +regexec (const regex_t *_Restrict_ preg, const char *_Restrict_ string, + size_t nmatch, regmatch_t pmatch[], int eflags) { reg_errcode_t err; Idx start, length; @@ -305,11 +301,8 @@ compat_symbol (libc, __compat_regexec, regexec, GLIBC_2_0); match was found and -2 indicates an internal error. */ regoff_t -re_match (bufp, string, length, start, regs) - struct re_pattern_buffer *bufp; - const char *string; - Idx length, start; - struct re_registers *regs; +re_match (struct re_pattern_buffer *bufp, const char *string, Idx length, + Idx start, struct re_registers *regs) { return re_search_stub (bufp, string, length, start, 0, length, regs, true); } @@ -318,12 +311,8 @@ weak_alias (__re_match, re_match) #endif regoff_t -re_search (bufp, string, length, start, range, regs) - struct re_pattern_buffer *bufp; - const char *string; - Idx length, start; - regoff_t range; - struct re_registers *regs; +re_search (struct re_pattern_buffer *bufp, const char *string, Idx length, + Idx start, regoff_t range, struct re_registers *regs) { return re_search_stub (bufp, string, length, start, range, length, regs, false); @@ -333,11 +322,9 @@ weak_alias (__re_search, re_search) #endif regoff_t -re_match_2 (bufp, string1, length1, string2, length2, start, regs, stop) - struct re_pattern_buffer *bufp; - const char *string1, *string2; - Idx length1, length2, start, stop; - struct re_registers *regs; +re_match_2 (struct re_pattern_buffer *bufp, const char *string1, Idx length1, + const char *string2, Idx length2, Idx start, + struct re_registers *regs, Idx stop) { return re_search_2_stub (bufp, string1, length1, string2, length2, start, 0, regs, stop, true); @@ -347,12 +334,9 @@ weak_alias (__re_match_2, re_match_2) #endif regoff_t -re_search_2 (bufp, string1, length1, string2, length2, start, range, regs, stop) - struct re_pattern_buffer *bufp; - const char *string1, *string2; - Idx length1, length2, start, stop; - regoff_t range; - struct re_registers *regs; +re_search_2 (struct re_pattern_buffer *bufp, const char *string1, Idx length1, + const char *string2, Idx length2, Idx start, regoff_t range, + struct re_registers *regs, Idx stop) { return re_search_2_stub (bufp, string1, length1, string2, length2, start, range, regs, stop, false); @@ -362,10 +346,10 @@ weak_alias (__re_search_2, re_search_2) #endif static regoff_t -re_search_2_stub (struct re_pattern_buffer *bufp, - const char *string1, Idx length1, - const char *string2, Idx length2, - Idx start, regoff_t range, struct re_registers *regs, +internal_function +re_search_2_stub (struct re_pattern_buffer *bufp, const char *string1, + Idx length1, const char *string2, Idx length2, Idx start, + regoff_t range, struct re_registers *regs, Idx stop, bool ret_len) { const char *str; @@ -409,8 +393,8 @@ re_search_2_stub (struct re_pattern_buffer *bufp, otherwise the position of the match is returned. */ static regoff_t -re_search_stub (struct re_pattern_buffer *bufp, - const char *string, Idx length, +internal_function +re_search_stub (struct re_pattern_buffer *bufp, const char *string, Idx length, Idx start, regoff_t range, Idx stop, struct re_registers *regs, bool ret_len) { @@ -499,6 +483,7 @@ re_search_stub (struct re_pattern_buffer *bufp, } static unsigned +internal_function re_copy_regs (struct re_registers *regs, regmatch_t *pmatch, Idx nregs, int regs_allocated) { @@ -577,11 +562,8 @@ re_copy_regs (struct re_registers *regs, regmatch_t *pmatch, Idx nregs, freeing the old data. */ void -re_set_registers (bufp, regs, num_regs, starts, ends) - struct re_pattern_buffer *bufp; - struct re_registers *regs; - __re_size_t num_regs; - regoff_t *starts, *ends; +re_set_registers (struct re_pattern_buffer *bufp, struct re_registers *regs, + __re_size_t num_regs, regoff_t *starts, regoff_t *ends) { if (num_regs) { @@ -609,8 +591,7 @@ int # ifdef _LIBC weak_function # endif -re_exec (s) - const char *s; +re_exec (const char *s) { return 0 == regexec (&re_comp_buf, s, 0, NULL, 0); } @@ -628,12 +609,10 @@ re_exec (s) (0 <= LAST_START && LAST_START <= LENGTH) */ static reg_errcode_t -__attribute_warn_unused_result__ -re_search_internal (const regex_t *preg, - const char *string, Idx length, - Idx start, Idx last_start, Idx stop, - size_t nmatch, regmatch_t pmatch[], - int eflags) +__attribute_warn_unused_result__ internal_function +re_search_internal (const regex_t *preg, const char *string, Idx length, + Idx start, Idx last_start, Idx stop, size_t nmatch, + regmatch_t pmatch[], int eflags) { reg_errcode_t err; const re_dfa_t *dfa = preg->buffer; @@ -642,7 +621,7 @@ re_search_internal (const regex_t *preg, bool fl_longest_match; int match_kind; Idx match_first; - Idx match_last = REG_MISSING; + Idx match_last = -1; Idx extra_nmatch; bool sb; int ch; @@ -851,9 +830,9 @@ re_search_internal (const regex_t *preg, mctx.state_log_top = mctx.nbkref_ents = mctx.max_mb_elem_len = 0; match_last = check_matching (&mctx, fl_longest_match, start <= last_start ? &match_first : NULL); - if (match_last != REG_MISSING) + if (match_last != -1) { - if (BE (match_last == REG_ERROR, 0)) + if (BE (match_last == -2, 0)) { err = REG_ESPACE; goto free_return; @@ -875,7 +854,7 @@ re_search_internal (const regex_t *preg, break; if (BE (err != REG_NOMATCH, 0)) goto free_return; - match_last = REG_MISSING; + match_last = -1; } else break; /* We found a match. */ @@ -886,7 +865,7 @@ re_search_internal (const regex_t *preg, } #ifdef DEBUG - assert (match_last != REG_MISSING); + assert (match_last != -1); assert (err == REG_NOERROR); #endif @@ -964,7 +943,7 @@ re_search_internal (const regex_t *preg, } static reg_errcode_t -__attribute_warn_unused_result__ +internal_function __attribute_warn_unused_result__ prune_impossible_nodes (re_match_context_t *mctx) { const re_dfa_t *const dfa = mctx->dfa; @@ -1012,7 +991,7 @@ prune_impossible_nodes (re_match_context_t *mctx) do { --match_last; - if (! REG_VALID_INDEX (match_last)) + if (match_last < 0) { ret = REG_NOMATCH; goto free_return; @@ -1093,8 +1072,8 @@ acquire_init_state_context (reg_errcode_t *err, const re_match_context_t *mctx, } /* Check whether the regular expression match input string INPUT or not, - and return the index where the matching end. Return REG_MISSING if - there is no match, and return REG_ERROR in case of an error. + and return the index where the matching end. Return -1 if + there is no match, and return -2 in case of an error. FL_LONGEST_MATCH means we want the POSIX longest matching. If P_MATCH_FIRST is not NULL, and the match fails, it is set to the next place where we may want to try matching. @@ -1109,7 +1088,7 @@ check_matching (re_match_context_t *mctx, bool fl_longest_match, const re_dfa_t *const dfa = mctx->dfa; reg_errcode_t err; Idx match = 0; - Idx match_last = REG_MISSING; + Idx match_last = -1; Idx cur_str_idx = re_string_cur_idx (&mctx->input); re_dfastate_t *cur_state; bool at_init_state = p_match_first != NULL; @@ -1121,7 +1100,7 @@ check_matching (re_match_context_t *mctx, bool fl_longest_match, if (BE (cur_state == NULL, 0)) { assert (err == REG_ESPACE); - return REG_ERROR; + return -2; } if (mctx->state_log != NULL) @@ -1176,7 +1155,7 @@ check_matching (re_match_context_t *mctx, bool fl_longest_match, if (BE (err != REG_NOERROR, 0)) { assert (err == REG_ESPACE); - return REG_ERROR; + return -2; } } @@ -1190,7 +1169,7 @@ check_matching (re_match_context_t *mctx, bool fl_longest_match, state using the state log, if available and if we have not already found a valid (even if not the longest) match. */ if (BE (err != REG_NOERROR, 0)) - return REG_ERROR; + return -2; if (mctx->state_log == NULL || (match && !fl_longest_match) @@ -1273,7 +1252,7 @@ check_halt_state_context (const re_match_context_t *mctx, /* Compute the next node to which "NFA" transit from NODE("NFA" is a NFA corresponding to the DFA). Return the destination node, and update EPS_VIA_NODES; - return REG_MISSING in case of errors. */ + return -1 in case of errors. */ static Idx internal_function @@ -1291,15 +1270,15 @@ proceed_next_node (const re_match_context_t *mctx, Idx nregs, regmatch_t *regs, Idx dest_node; ok = re_node_set_insert (eps_via_nodes, node); if (BE (! ok, 0)) - return REG_ERROR; - /* Pick up a valid destination, or return REG_MISSING if none + return -2; + /* Pick up a valid destination, or return -1 if none is found. */ - for (dest_node = REG_MISSING, i = 0; i < edests->nelem; ++i) + for (dest_node = -1, i = 0; i < edests->nelem; ++i) { Idx candidate = edests->elems[i]; if (!re_node_set_contains (cur_nodes, candidate)) continue; - if (dest_node == REG_MISSING) + if (dest_node == -1) dest_node = candidate; else @@ -1313,7 +1292,7 @@ proceed_next_node (const re_match_context_t *mctx, Idx nregs, regmatch_t *regs, else if (fs != NULL && push_fail_stack (fs, *pidx, candidate, nregs, regs, eps_via_nodes)) - return REG_ERROR; + return -2; /* We know we are going to exit. */ break; @@ -1338,13 +1317,13 @@ proceed_next_node (const re_match_context_t *mctx, Idx nregs, regmatch_t *regs, if (fs != NULL) { if (regs[subexp_idx].rm_so == -1 || regs[subexp_idx].rm_eo == -1) - return REG_MISSING; + return -1; else if (naccepted) { char *buf = (char *) re_string_get_buffer (&mctx->input); if (memcmp (buf + regs[subexp_idx].rm_so, buf + *pidx, naccepted) != 0) - return REG_MISSING; + return -1; } } @@ -1353,7 +1332,7 @@ proceed_next_node (const re_match_context_t *mctx, Idx nregs, regmatch_t *regs, Idx dest_node; ok = re_node_set_insert (eps_via_nodes, node); if (BE (! ok, 0)) - return REG_ERROR; + return -2; dest_node = dfa->edests[node].elems[0]; if (re_node_set_contains (&mctx->state_log[*pidx]->nodes, dest_node)) @@ -1369,12 +1348,12 @@ proceed_next_node (const re_match_context_t *mctx, Idx nregs, regmatch_t *regs, if (fs && (*pidx > mctx->match_last || mctx->state_log[*pidx] == NULL || !re_node_set_contains (&mctx->state_log[*pidx]->nodes, dest_node))) - return REG_MISSING; + return -1; re_node_set_empty (eps_via_nodes); return dest_node; } } - return REG_MISSING; + return -1; } static reg_errcode_t @@ -1410,7 +1389,7 @@ pop_fail_stack (struct re_fail_stack_t *fs, Idx *pidx, Idx nregs, regmatch_t *regs, re_node_set *eps_via_nodes) { Idx num = --fs->num; - assert (REG_VALID_INDEX (num)); + assert (num >= 0); *pidx = fs->stack[num].idx; memcpy (regs, fs->stack[num].regs, sizeof (regmatch_t) * nregs); re_node_set_free (eps_via_nodes); @@ -1503,9 +1482,9 @@ set_regs (const regex_t *preg, const re_match_context_t *mctx, size_t nmatch, cur_node = proceed_next_node (mctx, nmatch, pmatch, &idx, cur_node, &eps_via_nodes, fs); - if (BE (! REG_VALID_INDEX (cur_node), 0)) + if (BE (cur_node < 0, 0)) { - if (BE (cur_node == REG_ERROR, 0)) + if (BE (cur_node == -2, 0)) { re_node_set_free (&eps_via_nodes); if (prev_idx_match_malloced) @@ -1889,10 +1868,10 @@ sub_epsilon_src_nodes (const re_dfa_t *dfa, Idx node, re_node_set *dest_nodes, { Idx edst1 = dfa->edests[cur_node].elems[0]; Idx edst2 = ((dfa->edests[cur_node].nelem > 1) - ? dfa->edests[cur_node].elems[1] : REG_MISSING); + ? dfa->edests[cur_node].elems[1] : -1); if ((!re_node_set_contains (inv_eclosure, edst1) && re_node_set_contains (dest_nodes, edst1)) - || (REG_VALID_NONZERO_INDEX (edst2) + || (edst2 > 0 && !re_node_set_contains (inv_eclosure, edst2) && re_node_set_contains (dest_nodes, edst2))) { @@ -1972,7 +1951,7 @@ check_dst_limits_calc_pos_1 (const re_match_context_t *mctx, int boundaries, switch (dfa->nodes[node].type) { case OP_BACK_REF: - if (bkref_idx != REG_MISSING) + if (bkref_idx != -1) { struct re_backref_cache_entry *ent = mctx->bkref_ents + bkref_idx; do @@ -2088,8 +2067,8 @@ check_subexp_limits (const re_dfa_t *dfa, re_node_set *dest_nodes, subexp_idx = dfa->nodes[ent->node].opr.idx; if (ent->subexp_to == str_idx) { - Idx ops_node = REG_MISSING; - Idx cls_node = REG_MISSING; + Idx ops_node = -1; + Idx cls_node = -1; for (node_idx = 0; node_idx < dest_nodes->nelem; ++node_idx) { Idx node = dest_nodes->elems[node_idx]; @@ -2104,7 +2083,7 @@ check_subexp_limits (const re_dfa_t *dfa, re_node_set *dest_nodes, /* Check the limitation of the open subexpression. */ /* Note that (ent->subexp_to = str_idx != ent->subexp_from). */ - if (REG_VALID_INDEX (ops_node)) + if (ops_node >= 0) { err = sub_epsilon_src_nodes (dfa, ops_node, dest_nodes, candidates); @@ -2113,7 +2092,7 @@ check_subexp_limits (const re_dfa_t *dfa, re_node_set *dest_nodes, } /* Check the limitation of the close subexpression. */ - if (REG_VALID_INDEX (cls_node)) + if (cls_node >= 0) for (node_idx = 0; node_idx < dest_nodes->nelem; ++node_idx) { Idx node = dest_nodes->elems[node_idx]; @@ -2166,7 +2145,7 @@ sift_states_bkref (const re_match_context_t *mctx, re_sift_context_t *sctx, re_sift_context_t local_sctx; Idx first_idx = search_cur_bkref_entry (mctx, str_idx); - if (first_idx == REG_MISSING) + if (first_idx == -1) return REG_NOERROR; local_sctx.sifted_states = NULL; /* Mark that it hasn't been initialized. */ @@ -2570,7 +2549,7 @@ transit_state_mb (re_match_context_t *mctx, re_dfastate_t *pstate) if (BE (err != REG_NOERROR, 0)) return err; #ifdef DEBUG - assert (dfa->nexts[cur_node_idx] != REG_MISSING); + assert (dfa->nexts[cur_node_idx] != -1); #endif new_nodes = dfa->eclosures + dfa->nexts[cur_node_idx]; @@ -2636,7 +2615,7 @@ transit_state_bkref (re_match_context_t *mctx, const re_node_set *nodes) /* And add the epsilon closures (which is 'new_dest_nodes') of the backreference to appropriate state_log. */ #ifdef DEBUG - assert (dfa->nexts[node_idx] != REG_MISSING); + assert (dfa->nexts[node_idx] != -1); #endif for (; bkc_idx < mctx->nbkref_ents; ++bkc_idx) { @@ -2720,7 +2699,7 @@ get_subexp (re_match_context_t *mctx, Idx bkref_node, Idx bkref_str_idx) const char *buf = (const char *) re_string_get_buffer (&mctx->input); /* Return if we have already checked BKREF_NODE at BKREF_STR_IDX. */ Idx cache_idx = search_cur_bkref_entry (mctx, bkref_str_idx); - if (cache_idx != REG_MISSING) + if (cache_idx != -1) { const struct re_backref_cache_entry *entry = mctx->bkref_ents + cache_idx; @@ -2825,7 +2804,7 @@ get_subexp (re_match_context_t *mctx, Idx bkref_node, Idx bkref_str_idx) nodes = &mctx->state_log[sl_str]->nodes; cls_node = find_subexp_node (dfa, nodes, subexp_num, OP_CLOSE_SUBEXP); - if (cls_node == REG_MISSING) + if (cls_node == -1) continue; /* No. */ if (sub_top->path == NULL) { @@ -2904,7 +2883,7 @@ find_subexp_node (const re_dfa_t *dfa, const re_node_set *nodes, && node->opr.idx == subexp_idx) return cls_node; } - return REG_MISSING; + return -1; } /* Check whether the node TOP_NODE at TOP_STR can arrive to the node @@ -3180,7 +3159,7 @@ check_arrival_expand_ecl (const re_dfa_t *dfa, re_node_set *cur_nodes, Idx cur_node = cur_nodes->elems[idx]; const re_node_set *eclosure = dfa->eclosures + cur_node; outside_node = find_subexp_node (dfa, eclosure, ex_subexp, type); - if (outside_node == REG_MISSING) + if (outside_node == -1) { /* There are no problematic nodes, just merge them. */ err = re_node_set_merge (&new_nodes, eclosure); @@ -3266,7 +3245,7 @@ expand_bkref_cache (re_match_context_t *mctx, re_node_set *cur_nodes, Idx cache_idx_start = search_cur_bkref_entry (mctx, cur_str); struct re_backref_cache_entry *ent; - if (cache_idx_start == REG_MISSING) + if (cache_idx_start == -1) return REG_NOERROR; restart: @@ -3391,7 +3370,7 @@ build_trtable (const re_dfa_t *dfa, re_dfastate_t *state) /* At first, group all nodes belonging to 'state' into several destinations. */ ndests = group_nodes_into_DFAstates (dfa, state, dests_node, dests_ch); - if (BE (! REG_VALID_NONZERO_INDEX (ndests), 0)) + if (BE (ndests <= 0, 0)) { if (dests_node_malloced) free (dests_alloc); @@ -3453,7 +3432,7 @@ out_free: for (j = 0; j < dests_node[i].nelem; ++j) { next_node = dfa->nexts[dests_node[i].elems[j]]; - if (next_node != REG_MISSING) + if (next_node != -1) { err = re_node_set_merge (&follows, dfa->eclosures + next_node); if (BE (err != REG_NOERROR, 0)) @@ -3764,7 +3743,7 @@ group_nodes_into_DFAstates (const re_dfa_t *dfa, const re_dfastate_t *state, error_return: for (j = 0; j < ndests; ++j) re_node_set_free (dests_node + j); - return REG_MISSING; + return -1; } #ifdef RE_ENABLE_I18N @@ -3776,6 +3755,10 @@ group_nodes_into_DFAstates (const re_dfa_t *dfa, const re_dfastate_t *state, one collating element like '.', '[a-z]', opposite to the other nodes can only accept one byte. */ +# ifdef _LIBC +# include +# endif + static int internal_function check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx, @@ -3895,8 +3878,6 @@ check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx, const int32_t *table, *indirect; const unsigned char *weights, *extra; const char *collseqwc; - /* This #include defines a local function! */ -# include /* match with collating_symbol? */ if (cset->ncoll_syms) @@ -3953,7 +3934,7 @@ check_node_accept_bytes (const re_dfa_t *dfa, Idx node_idx, _NL_CURRENT (LC_COLLATE, _NL_COLLATE_EXTRAMB); indirect = (const int32_t *) _NL_CURRENT (LC_COLLATE, _NL_COLLATE_INDIRECTMB); - int32_t idx = findidx (&cp, elem_len); + int32_t idx = findidx (table, indirect, extra, &cp, elem_len); if (idx > 0) for (i = 0; i < cset->nequiv_classes; ++i) { @@ -4193,7 +4174,7 @@ internal_function __attribute_warn_unused_result__ match_ctx_init (re_match_context_t *mctx, int eflags, Idx n) { mctx->eflags = eflags; - mctx->match_last = REG_MISSING; + mctx->match_last = -1; if (n > 0) { /* Avoid overflow. */ @@ -4314,7 +4295,7 @@ match_ctx_add_entry (re_match_context_t *mctx, Idx node, Idx str_idx, Idx from, return REG_NOERROR; } -/* Return the first entry with the same str_idx, or REG_MISSING if none is +/* Return the first entry with the same str_idx, or -1 if none is found. Note that MCTX->BKREF_ENTS is already sorted by MCTX->STR_IDX. */ static Idx @@ -4334,7 +4315,7 @@ search_cur_bkref_entry (const re_match_context_t *mctx, Idx str_idx) if (left < last && mctx->bkref_ents[left].str_idx == str_idx) return left; else - return REG_MISSING; + return -1; } /* Register the node NODE, whose type is OP_OPEN_SUBEXP, and which matches diff --git a/lib/rename.c b/lib/rename.c index 1cd4e6da3..53fde10a7 100644 --- a/lib/rename.c +++ b/lib/rename.c @@ -1,6 +1,6 @@ /* Work around rename bugs in some systems. - Copyright (C) 2001-2003, 2005-2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2001-2003, 2005-2006, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -285,7 +285,7 @@ rpl_rename (char const *src, char const *dst) char *dst_temp = (char *) dst; bool src_slash; bool dst_slash; - bool dst_exists; + bool dst_exists _GL_UNUSED; int ret_val = -1; int rename_errno = ENOTDIR; struct stat src_st; @@ -462,7 +462,9 @@ rpl_rename (char const *src, char const *dst) ret_val = rename (src_temp, dst_temp); rename_errno = errno; - out: + + out: _GL_UNUSED_LABEL; + if (src_temp != src) free (src_temp); if (dst_temp != dst) diff --git a/lib/rmdir.c b/lib/rmdir.c index 964dd2028..cd4d9c1c6 100644 --- a/lib/rmdir.c +++ b/lib/rmdir.c @@ -1,6 +1,6 @@ /* Work around rmdir bugs. - Copyright (C) 1988, 1990, 1999, 2003-2006, 2009-2014 Free Software + Copyright (C) 1988, 1990, 1999, 2003-2006, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/round.c b/lib/round.c index d1c2aac5a..7a595ad4f 100644 --- a/lib/round.c +++ b/lib/round.c @@ -1,5 +1,5 @@ /* Round toward nearest, breaking ties away from zero. - Copyright (C) 2007, 2010-2014 Free Software Foundation, Inc. + Copyright (C) 2007, 2010-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/safe-read.c b/lib/safe-read.c index 6c9639f40..57978af6b 100644 --- a/lib/safe-read.c +++ b/lib/safe-read.c @@ -1,6 +1,6 @@ /* An interface to read and write that retries after interrupts. - Copyright (C) 1993-1994, 1998, 2002-2006, 2009-2014 Free Software + Copyright (C) 1993-1994, 1998, 2002-2006, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/safe-read.h b/lib/safe-read.h index 6cd5f68fc..6665f2dd8 100644 --- a/lib/safe-read.h +++ b/lib/safe-read.h @@ -1,5 +1,5 @@ /* An interface to read() that retries after interrupts. - Copyright (C) 2002, 2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2002, 2006, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/safe-write.c b/lib/safe-write.c index 3e7ffd627..96c5db28a 100644 --- a/lib/safe-write.c +++ b/lib/safe-write.c @@ -1,5 +1,5 @@ /* An interface to write that retries after interrupts. - Copyright (C) 2002, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2002, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/safe-write.h b/lib/safe-write.h index 45a61463a..3bae8535d 100644 --- a/lib/safe-write.h +++ b/lib/safe-write.h @@ -1,5 +1,5 @@ /* An interface to write() that retries after interrupts. - Copyright (C) 2002, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2002, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/same-inode.h b/lib/same-inode.h index f85a3cce8..e19c68ae4 100644 --- a/lib/same-inode.h +++ b/lib/same-inode.h @@ -1,6 +1,6 @@ /* Determine whether two stat buffers refer to the same file. - Copyright (C) 2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2006, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/secure_getenv.c b/lib/secure_getenv.c index 7b86173bb..821cb092d 100644 --- a/lib/secure_getenv.c +++ b/lib/secure_getenv.c @@ -1,6 +1,6 @@ -/* Look up an environment variable more securely. +/* Look up an environment variable, returning NULL in insecure situations. - Copyright 2013-2014 Free Software Foundation, Inc. + Copyright 2013-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published @@ -20,22 +20,35 @@ #include #if !HAVE___SECURE_GETENV -# if HAVE_ISSETUGID +# if HAVE_ISSETUGID || (HAVE_GETUID && HAVE_GETEUID && HAVE_GETGID && HAVE_GETEGID) # include -# else -# undef issetugid -# define issetugid() 1 # endif #endif char * secure_getenv (char const *name) { -#if HAVE___SECURE_GETENV +#if HAVE___SECURE_GETENV /* glibc */ return __secure_getenv (name); -#else +#elif HAVE_ISSETUGID /* OS X, FreeBSD, NetBSD, OpenBSD */ if (issetugid ()) - return 0; + return NULL; return getenv (name); +#elif HAVE_GETUID && HAVE_GETEUID && HAVE_GETGID && HAVE_GETEGID /* other Unix */ + if (geteuid () != getuid () || getegid () != getgid ()) + return NULL; + return getenv (name); +#elif (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ /* native Windows */ + /* On native Windows, there is no such concept as setuid or setgid binaries. + - Programs launched as system services have high privileges, but they don't + inherit environment variables from a user. + - Programs launched by a user with "Run as Administrator" have high + privileges and use the environment variables, but the user has been asked + whether he agrees. + - Programs launched by a user without "Run as Administrator" cannot gain + high privileges, therefore there is no risk. */ + return getenv (name); +#else + return NULL; #endif } diff --git a/lib/select.c b/lib/select.c index a31f90224..4f6acccd2 100644 --- a/lib/select.c +++ b/lib/select.c @@ -1,7 +1,7 @@ /* Emulation for select(2) Contributed by Paolo Bonzini. - Copyright 2008-2014 Free Software Foundation, Inc. + Copyright 2008-2016 Free Software Foundation, Inc. This file is part of gnulib. @@ -82,9 +82,11 @@ typedef DWORD (WINAPI *PNtQueryInformationFile) #define PIPE_BUF 512 #endif -/* Optimized test whether a HANDLE refers to a console. - See . */ -#define IsConsoleHandle(h) (((intptr_t) (h) & 3) == 3) +static BOOL IsConsoleHandle (HANDLE h) +{ + DWORD mode; + return GetConsoleMode (h, &mode) != 0; +} static BOOL IsSocketHandle (HANDLE h) @@ -252,6 +254,7 @@ rpl_select (int nfds, fd_set *rfds, fd_set *wfds, fd_set *xfds, DWORD ret, wait_timeout, nhandles, nsock, nbuffer; MSG msg; int i, fd, rc; + clock_t tend; if (nfds > FD_SETSIZE) nfds = FD_SETSIZE; @@ -388,6 +391,10 @@ rpl_select (int nfds, fd_set *rfds, fd_set *wfds, fd_set *xfds, /* Place a sentinel at the end of the array. */ handle_array[nhandles] = NULL; + /* When will the waiting period expire? */ + if (wait_timeout != INFINITE) + tend = clock () + wait_timeout; + restart: if (wait_timeout == 0 || nsock == 0) rc = 0; @@ -408,6 +415,16 @@ restart: wait_timeout = 0; } + /* How much is left to wait? */ + if (wait_timeout != INFINITE) + { + clock_t tnow = clock (); + if (tend >= tnow) + wait_timeout = tend - tnow; + else + wait_timeout = 0; + } + for (;;) { ret = MsgWaitForMultipleObjects (nhandles, handle_array, FALSE, @@ -453,7 +470,16 @@ restart: } } - if (rc == 0 && wait_timeout == INFINITE) + if (rc == 0 + && (wait_timeout == INFINITE + /* If NHANDLES > 1, but no bits are set, it means we've + been told incorrectly that some handle was signaled. + This happens with anonymous pipes, which always cause + MsgWaitForMultipleObjects to exit immediately, but no + data is found ready to be read by windows_poll_handle. + To avoid a total failure (whereby we return zero and + don't wait at all), let's poll in a more busy loop. */ + || (wait_timeout != 0 && nhandles > 1))) { /* Sleep 1 millisecond to avoid busy wait and retry with the original fd_sets. */ @@ -463,6 +489,8 @@ restart: SleepEx (1, TRUE); goto restart; } + if (timeout && wait_timeout == 0 && rc == 0) + timeout->tv_sec = timeout->tv_usec = 0; } /* Now fill in the results. */ diff --git a/lib/send.c b/lib/send.c index 9e70c91af..3f1c567f5 100644 --- a/lib/send.c +++ b/lib/send.c @@ -1,6 +1,6 @@ /* send.c --- wrappers for Windows send function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sendto.c b/lib/sendto.c index 69b8ebc9f..494f3885d 100644 --- a/lib/sendto.c +++ b/lib/sendto.c @@ -1,6 +1,6 @@ /* sendto.c --- wrappers for Windows sendto function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/setenv.c b/lib/setenv.c index 50e686025..f67233b0f 100644 --- a/lib/setenv.c +++ b/lib/setenv.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1992, 1995-2003, 2005-2014 Free Software Foundation, Inc. +/* Copyright (C) 1992, 1995-2003, 2005-2016 Free Software Foundation, Inc. This file is part of the GNU C Library. This program is free software: you can redistribute it and/or modify diff --git a/lib/setsockopt.c b/lib/setsockopt.c index 2b905daa0..1e863a8f0 100644 --- a/lib/setsockopt.c +++ b/lib/setsockopt.c @@ -1,6 +1,6 @@ /* setsockopt.c --- wrappers for Windows setsockopt function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/shutdown.c b/lib/shutdown.c index 54b7728dd..b9539712d 100644 --- a/lib/shutdown.c +++ b/lib/shutdown.c @@ -1,6 +1,6 @@ /* shutdown.c --- wrappers for Windows shutdown function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/signal.in.h b/lib/signal.in.h index 057fa9ef5..90f7d309e 100644 --- a/lib/signal.in.h +++ b/lib/signal.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 2006-2014 Free Software Foundation, Inc. + Copyright (C) 2006-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -55,11 +55,13 @@ #ifndef _@GUARD_PREFIX@_SIGNAL_H #define _@GUARD_PREFIX@_SIGNAL_H -/* Mac OS X 10.3, FreeBSD 6.4, OpenBSD 3.8, OSF/1 4.0, Solaris 2.6 declare - pthread_sigmask in , not in . +/* Mac OS X 10.3, FreeBSD 6.4, OpenBSD 3.8, OSF/1 4.0, Solaris 2.6, Android + declare pthread_sigmask in , not in . But avoid namespace pollution on glibc systems.*/ #if (@GNULIB_PTHREAD_SIGMASK@ || defined GNULIB_POSIXCHECK) \ - && ((defined __APPLE__ && defined __MACH__) || defined __FreeBSD__ || defined __OpenBSD__ || defined __osf__ || defined __sun) \ + && ((defined __APPLE__ && defined __MACH__) \ + || defined __FreeBSD__ || defined __OpenBSD__ || defined __osf__ \ + || defined __sun || defined __ANDROID__) \ && ! defined __GLIBC__ # include #endif diff --git a/lib/signbitd.c b/lib/signbitd.c index 1efb6e6a2..f584fe2f1 100644 --- a/lib/signbitd.c +++ b/lib/signbitd.c @@ -1,5 +1,5 @@ /* signbit() macro: Determine the sign bit of a floating-point number. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/signbitf.c b/lib/signbitf.c index 3240e4ec0..7d35edaa5 100644 --- a/lib/signbitf.c +++ b/lib/signbitf.c @@ -1,5 +1,5 @@ /* signbit() macro: Determine the sign bit of a floating-point number. - Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/signbitl.c b/lib/signbitl.c index 3f847257c..b12590dc8 100644 --- a/lib/signbitl.c +++ b/lib/signbitl.c @@ -1,5 +1,5 @@ /* signbit() macro: Determine the sign bit of a floating-point number. - Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/size_max.h b/lib/size_max.h index 680ca0fff..5b04b79fa 100644 --- a/lib/size_max.h +++ b/lib/size_max.h @@ -1,5 +1,5 @@ /* size_max.h -- declare SIZE_MAX through system headers - Copyright (C) 2005-2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2005-2006, 2009-2016 Free Software Foundation, Inc. Written by Simon Josefsson. This program is free software; you can redistribute it and/or modify diff --git a/lib/snprintf.c b/lib/snprintf.c index 0b8cbf88f..2205cb78d 100644 --- a/lib/snprintf.c +++ b/lib/snprintf.c @@ -1,5 +1,5 @@ /* Formatted output to strings. - Copyright (C) 2004, 2006-2014 Free Software Foundation, Inc. + Copyright (C) 2004, 2006-2016 Free Software Foundation, Inc. Written by Simon Josefsson and Paul Eggert. This program is free software; you can redistribute it and/or modify diff --git a/lib/socket.c b/lib/socket.c index c10d4f6ad..af269820b 100644 --- a/lib/socket.c +++ b/lib/socket.c @@ -1,6 +1,6 @@ /* socket.c --- wrappers for Windows socket function - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sockets.c b/lib/sockets.c index 98fe879ee..ca6595448 100644 --- a/lib/sockets.c +++ b/lib/sockets.c @@ -1,6 +1,6 @@ /* sockets.c --- wrappers for Windows socket functions - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -121,8 +121,11 @@ gl_sockets_startup (int version _GL_UNUSED) if (err != 0) return 1; - if (data.wVersion < version) - return 2; + if (data.wVersion != version) + { + WSACleanup (); + return 2; + } if (initialized_sockets_version == 0) register_fd_hook (close_fd_maybe_socket, ioctl_fd_maybe_socket, diff --git a/lib/sockets.h b/lib/sockets.h index dd99ec172..a1555a099 100644 --- a/lib/sockets.h +++ b/lib/sockets.h @@ -1,6 +1,6 @@ /* sockets.h - wrappers for Windows socket functions - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -20,11 +20,11 @@ #ifndef SOCKETS_H # define SOCKETS_H 1 -#define SOCKETS_1_0 0x100 /* don't use - does not work on Windows XP */ -#define SOCKETS_1_1 0x101 -#define SOCKETS_2_0 0x200 /* don't use - does not work on Windows XP */ -#define SOCKETS_2_1 0x201 -#define SOCKETS_2_2 0x202 +#define SOCKETS_1_0 0x0001 +#define SOCKETS_1_1 0x0101 +#define SOCKETS_2_0 0x0002 +#define SOCKETS_2_1 0x0102 +#define SOCKETS_2_2 0x0202 int gl_sockets_startup (int version) #if !WINDOWS_SOCKETS diff --git a/lib/stat-time.h b/lib/stat-time.h index 570001361..1399246d4 100644 --- a/lib/stat-time.h +++ b/lib/stat-time.h @@ -1,6 +1,6 @@ /* stat-related time functions. - Copyright (C) 2005, 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2005, 2007, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -54,7 +54,7 @@ _GL_INLINE_HEADER_BEGIN #endif /* Return the nanosecond component of *ST's access time. */ -_GL_STAT_TIME_INLINE long int +_GL_STAT_TIME_INLINE long int _GL_ATTRIBUTE_PURE get_stat_atime_ns (struct stat const *st) { # if defined STAT_TIMESPEC @@ -67,7 +67,7 @@ get_stat_atime_ns (struct stat const *st) } /* Return the nanosecond component of *ST's status change time. */ -_GL_STAT_TIME_INLINE long int +_GL_STAT_TIME_INLINE long int _GL_ATTRIBUTE_PURE get_stat_ctime_ns (struct stat const *st) { # if defined STAT_TIMESPEC @@ -80,7 +80,7 @@ get_stat_ctime_ns (struct stat const *st) } /* Return the nanosecond component of *ST's data modification time. */ -_GL_STAT_TIME_INLINE long int +_GL_STAT_TIME_INLINE long int _GL_ATTRIBUTE_PURE get_stat_mtime_ns (struct stat const *st) { # if defined STAT_TIMESPEC @@ -93,7 +93,7 @@ get_stat_mtime_ns (struct stat const *st) } /* Return the nanosecond component of *ST's birth time. */ -_GL_STAT_TIME_INLINE long int +_GL_STAT_TIME_INLINE long int _GL_ATTRIBUTE_PURE get_stat_birthtime_ns (struct stat const *st) { # if defined HAVE_STRUCT_STAT_ST_BIRTHTIMESPEC_TV_NSEC @@ -108,7 +108,7 @@ get_stat_birthtime_ns (struct stat const *st) } /* Return *ST's access time. */ -_GL_STAT_TIME_INLINE struct timespec +_GL_STAT_TIME_INLINE struct timespec _GL_ATTRIBUTE_PURE get_stat_atime (struct stat const *st) { #ifdef STAT_TIMESPEC @@ -122,7 +122,7 @@ get_stat_atime (struct stat const *st) } /* Return *ST's status change time. */ -_GL_STAT_TIME_INLINE struct timespec +_GL_STAT_TIME_INLINE struct timespec _GL_ATTRIBUTE_PURE get_stat_ctime (struct stat const *st) { #ifdef STAT_TIMESPEC @@ -136,7 +136,7 @@ get_stat_ctime (struct stat const *st) } /* Return *ST's data modification time. */ -_GL_STAT_TIME_INLINE struct timespec +_GL_STAT_TIME_INLINE struct timespec _GL_ATTRIBUTE_PURE get_stat_mtime (struct stat const *st) { #ifdef STAT_TIMESPEC @@ -151,7 +151,7 @@ get_stat_mtime (struct stat const *st) /* Return *ST's birth time, if available; otherwise return a value with tv_sec and tv_nsec both equal to -1. */ -_GL_STAT_TIME_INLINE struct timespec +_GL_STAT_TIME_INLINE struct timespec _GL_ATTRIBUTE_PURE get_stat_birthtime (struct stat const *st) { struct timespec t; diff --git a/lib/stat.c b/lib/stat.c index 60bbd693e..83a9a6e4a 100644 --- a/lib/stat.c +++ b/lib/stat.c @@ -1,5 +1,5 @@ /* Work around platform bugs in stat. - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/stdalign.in.h b/lib/stdalign.in.h index 29861efe1..41913c0be 100644 --- a/lib/stdalign.in.h +++ b/lib/stdalign.in.h @@ -1,6 +1,6 @@ /* A substitute for ISO C11 . - Copyright 2011-2014 Free Software Foundation, Inc. + Copyright 2011-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -52,7 +52,10 @@ #undef _Alignas #undef _Alignof -#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112 +/* GCC releases before GCC 4.9 had a bug in _Alignof. See GCC bug 52023 + . */ +#if (!defined __STDC_VERSION__ || __STDC_VERSION__ < 201112 \ + || (defined __GNUC__ && __GNUC__ < 4 + (__GNUC_MINOR__ < 9))) # ifdef __cplusplus # if 201103 <= __cplusplus # define _Alignof(type) alignof (type) @@ -64,7 +67,9 @@ # define _Alignof(type) offsetof (struct { char __a; type __b; }, __b) # endif #endif -#define alignof _Alignof +#if ! (defined __cplusplus && 201103 <= __cplusplus) +# define alignof _Alignof +#endif #define __alignof_is_defined 1 /* alignas (A), also known as _Alignas (A), aligns a variable or type @@ -95,15 +100,21 @@ #if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112 # if defined __cplusplus && 201103 <= __cplusplus # define _Alignas(a) alignas (a) -# elif (__GNUC__ || __HP_cc || __HP_aCC || __IBMC__ || __IBMCPP__ \ - || __ICC || 0x5110 <= __SUNPRO_C) +# elif ((defined __APPLE__ && defined __MACH__ \ + ? 4 < __GNUC__ + (1 <= __GNUC_MINOR__) \ + : __GNUC__) \ + || 061200 <= __HP_cc || 061200 <= __HP_aCC \ + || __ICC || 0x590 <= __SUNPRO_C || 0x0600 <= __xlC__) # define _Alignas(a) __attribute__ ((__aligned__ (a))) # elif 1300 <= _MSC_VER # define _Alignas(a) __declspec (align (a)) # endif #endif -#if defined _Alignas || (defined __STDC_VERSION && 201112 <= __STDC_VERSION__) +#if ((defined _Alignas && ! (defined __cplusplus && 201103 <= __cplusplus)) \ + || (defined __STDC_VERSION__ && 201112 <= __STDC_VERSION__)) # define alignas _Alignas +#endif +#if defined alignas || (defined __cplusplus && 201103 <= __cplusplus) # define __alignas_is_defined 1 #endif diff --git a/lib/stdbool.in.h b/lib/stdbool.in.h index 2f34a13fb..267215bcc 100644 --- a/lib/stdbool.in.h +++ b/lib/stdbool.in.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2001-2003, 2006-2014 Free Software Foundation, Inc. +/* Copyright (C) 2001-2003, 2006-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2001. This program is free software; you can redistribute it and/or modify diff --git a/lib/stddef.in.h b/lib/stddef.in.h index 204c4bcf0..927bc2db4 100644 --- a/lib/stddef.in.h +++ b/lib/stddef.in.h @@ -1,6 +1,6 @@ /* A substitute for POSIX 2008 , for platforms that have issues. - Copyright (C) 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2009-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -39,7 +39,6 @@ # if !(defined _@GUARD_PREFIX@_STDDEF_H && defined _GL_STDDEF_WINT_T) # ifdef __need_wint_t -# undef _@GUARD_PREFIX@_STDDEF_H # define _GL_STDDEF_WINT_T # endif # @INCLUDE_NEXT@ @NEXT_STDDEF_H@ @@ -54,33 +53,58 @@ # @INCLUDE_NEXT@ @NEXT_STDDEF_H@ -# ifndef _@GUARD_PREFIX@_STDDEF_H -# define _@GUARD_PREFIX@_STDDEF_H - /* On NetBSD 5.0, the definition of NULL lacks proper parentheses. */ -#if @REPLACE_NULL@ -# undef NULL -# ifdef __cplusplus +# if (@REPLACE_NULL@ \ + && (!defined _@GUARD_PREFIX@_STDDEF_H || defined _GL_STDDEF_WINT_T)) +# undef NULL +# ifdef __cplusplus /* ISO C++ says that the macro NULL must expand to an integer constant expression, hence '((void *) 0)' is not allowed in C++. */ -# if __GNUG__ >= 3 +# if __GNUG__ >= 3 /* GNU C++ has a __null macro that behaves like an integer ('int' or 'long') but has the same size as a pointer. Use that, to avoid warnings. */ -# define NULL __null -# else -# define NULL 0L +# define NULL __null +# else +# define NULL 0L +# endif +# else +# define NULL ((void *) 0) +# endif # endif -# else -# define NULL ((void *) 0) -# endif -#endif + +# ifndef _@GUARD_PREFIX@_STDDEF_H +# define _@GUARD_PREFIX@_STDDEF_H /* Some platforms lack wchar_t. */ #if !@HAVE_WCHAR_T@ # define wchar_t int #endif +/* Some platforms lack max_align_t. The check for _GCC_MAX_ALIGN_T is + a hack in case the configure-time test was done with g++ even though + we are currently compiling with gcc. */ +#if ! (@HAVE_MAX_ALIGN_T@ || defined _GCC_MAX_ALIGN_T) +/* On the x86, the maximum storage alignment of double, long, etc. is 4, + but GCC's C11 ABI for x86 says that max_align_t has an alignment of 8, + and the C11 standard allows this. Work around this problem by + using __alignof__ (which returns 8 for double) rather than _Alignof + (which returns 4), and align each union member accordingly. */ +# ifdef __GNUC__ +# define _GL_STDDEF_ALIGNAS(type) \ + __attribute__ ((__aligned__ (__alignof__ (type)))) +# else +# define _GL_STDDEF_ALIGNAS(type) /* */ +# endif +typedef union +{ + char *__p _GL_STDDEF_ALIGNAS (char *); + double __d _GL_STDDEF_ALIGNAS (double); + long double __ld _GL_STDDEF_ALIGNAS (long double); + long int __i _GL_STDDEF_ALIGNAS (long int); +} max_align_t; +#endif + # endif /* _@GUARD_PREFIX@_STDDEF_H */ # endif /* _@GUARD_PREFIX@_STDDEF_H */ #endif /* __need_XXX */ diff --git a/lib/stdint.in.h b/lib/stdint.in.h index b1296f9ea..d5698477c 100644 --- a/lib/stdint.in.h +++ b/lib/stdint.in.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2001-2002, 2004-2014 Free Software Foundation, Inc. +/* Copyright (C) 2001-2002, 2004-2016 Free Software Foundation, Inc. Written by Paul Eggert, Bruno Haible, Sam Steingold, Peter Burwood. This file is part of gnulib. @@ -38,8 +38,7 @@ other system header files; just include the system's . Ideally we should test __BIONIC__ here, but it is only defined after has been included; hence test __ANDROID__ instead. */ -#if defined __ANDROID__ \ - && defined _SYS_TYPES_H_ && !defined __need_size_t +#if defined __ANDROID__ && defined _GL_INCLUDING_SYS_TYPES_H # @INCLUDE_NEXT@ @NEXT_STDINT_H@ #else @@ -119,15 +118,10 @@ picky compilers. */ #define _STDINT_MIN(signed, bits, zero) \ - ((signed) ? (- ((zero) + 1) << ((bits) ? (bits) - 1 : 0)) : (zero)) + ((signed) ? ~ _STDINT_MAX (signed, bits, zero) : (zero)) #define _STDINT_MAX(signed, bits, zero) \ - ((signed) \ - ? ~ _STDINT_MIN (signed, bits, zero) \ - : /* The expression for the unsigned case. The subtraction of (signed) \ - is a nop in the unsigned case and avoids "signed integer overflow" \ - warnings in the signed case. */ \ - ((((zero) + 1) << ((bits) ? (bits) - 1 - (signed) : 0)) - 1) * 2 + 1) + (((((zero) + 1) << ((bits) ? (bits) - 1 - (signed) : 0)) - 1) * 2 + 1) #if !GNULIB_defined_stdint_types @@ -289,12 +283,17 @@ typedef gl_uint_fast32_t gl_uint_fast16_t; /* 7.18.1.4. Integer types capable of holding object pointers */ +/* kLIBC's stdint.h defines _INTPTR_T_DECLARED and needs its own + definitions of intptr_t and uintptr_t (which use int and unsigned) + to avoid clashes with declarations of system functions like sbrk. */ +#ifndef _INTPTR_T_DECLARED #undef intptr_t #undef uintptr_t typedef long int gl_intptr_t; typedef unsigned long int gl_uintptr_t; #define intptr_t gl_intptr_t #define uintptr_t gl_uintptr_t +#endif /* 7.18.1.5. Greatest-width integer types */ diff --git a/lib/stdio.in.h b/lib/stdio.in.h index faa778b1d..ce100aa8e 100644 --- a/lib/stdio.in.h +++ b/lib/stdio.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 2004, 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2004, 2007-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -84,8 +84,13 @@ except that it indicates to GCC that the supported format string directives are the ones of the system printf(), rather than the ones standardized by ISO C99 and POSIX. */ -#define _GL_ATTRIBUTE_FORMAT_PRINTF_SYSTEM(formatstring_parameter, first_argument) \ +#if GNULIB_PRINTF_ATTRIBUTE_FLAVOR_GNU +# define _GL_ATTRIBUTE_FORMAT_PRINTF_SYSTEM(formatstring_parameter, first_argument) \ + _GL_ATTRIBUTE_FORMAT_PRINTF (formatstring_parameter, first_argument) +#else +# define _GL_ATTRIBUTE_FORMAT_PRINTF_SYSTEM(formatstring_parameter, first_argument) \ _GL_ATTRIBUTE_FORMAT ((__printf__, formatstring_parameter, first_argument)) +#endif /* _GL_ATTRIBUTE_FORMAT_SCANF indicates to GCC that the function takes a format string and arguments, @@ -718,11 +723,10 @@ _GL_WARN_ON_USE (getline, "getline is unportable - " so any use of gets warrants an unconditional warning; besides, C11 removed it. */ #undef gets -#if HAVE_RAW_DECL_GETS +#if HAVE_RAW_DECL_GETS && !defined __cplusplus _GL_WARN_ON_USE (gets, "gets is a security hole - use fgets instead"); #endif - #if @GNULIB_OBSTACK_PRINTF@ || @GNULIB_OBSTACK_PRINTF_POSIX@ struct obstack; /* Grow an obstack with formatted output. Return the number of diff --git a/lib/stdlib.in.h b/lib/stdlib.in.h index 57d32cc48..ec7a2efbe 100644 --- a/lib/stdlib.in.h +++ b/lib/stdlib.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 1995, 2001-2004, 2006-2014 Free Software Foundation, Inc. + Copyright (C) 1995, 2001-2004, 2006-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -520,6 +520,29 @@ _GL_CXXALIAS_SYS (putenv, int, (char *string)); _GL_CXXALIASWARN (putenv); #endif +#if @GNULIB_QSORT_R@ +# if @REPLACE_QSORT_R@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef qsort_r +# define qsort_r rpl_qsort_r +# endif +_GL_FUNCDECL_RPL (qsort_r, void, (void *base, size_t nmemb, size_t size, + int (*compare) (void const *, void const *, + void *), + void *arg) _GL_ARG_NONNULL ((1, 4))); +_GL_CXXALIAS_RPL (qsort_r, void, (void *base, size_t nmemb, size_t size, + int (*compare) (void const *, void const *, + void *), + void *arg)); +# else +_GL_CXXALIAS_SYS (qsort_r, void, (void *base, size_t nmemb, size_t size, + int (*compare) (void const *, void const *, + void *), + void *arg)); +# endif +_GL_CXXALIASWARN (qsort_r); +#endif + #if @GNULIB_RANDOM_R@ # if !@HAVE_RANDOM_R@ diff --git a/lib/strdup.c b/lib/strdup.c index bde582927..b44862daf 100644 --- a/lib/strdup.c +++ b/lib/strdup.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1991, 1996-1998, 2002-2004, 2006-2007, 2009-2014 Free Software +/* Copyright (C) 1991, 1996-1998, 2002-2004, 2006-2007, 2009-2016 Free Software Foundation, Inc. This file is part of the GNU C Library. diff --git a/lib/streq.h b/lib/streq.h index 0f7bc72b2..9be29390c 100644 --- a/lib/streq.h +++ b/lib/streq.h @@ -1,5 +1,5 @@ /* Optimized string comparison. - Copyright (C) 2001-2002, 2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2001-2002, 2007, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/strftime.c b/lib/strftime.c index eb458d117..b10f82f0e 100644 --- a/lib/strftime.c +++ b/lib/strftime.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1991-2001, 2003-2007, 2009-2014 Free Software Foundation, Inc. +/* Copyright (C) 1991-2001, 2003-2007, 2009-2016 Free Software Foundation, Inc. NOTE: The canonical source of this file is maintained with the GNU C Library. Bugs can be reported to bug-glibc@prep.ai.mit.edu. @@ -30,6 +30,7 @@ # else # include "strftime.h" # endif +# include "time-internal.h" #endif #include @@ -121,22 +122,11 @@ extern char *tzname[]; #ifdef _LIBC +# define mktime_z(tz, tm) mktime (tm) # define tzname __tzname # define tzset __tzset #endif -#if !HAVE_TM_GMTOFF -/* Portable standalone applications should supply a "time.h" that - declares a POSIX-compliant localtime_r, for the benefit of older - implementations that lack localtime_r or have a nonstandard one. - See the gnulib time_r module for one way to implement this. */ -# undef __gmtime_r -# undef __localtime_r -# define __gmtime_r gmtime_r -# define __localtime_r localtime_r -#endif - - #ifndef FPRINTFTIME # define FPRINTFTIME 0 #endif @@ -385,12 +375,7 @@ iso_week_days (int yday, int wday) /* When compiling this file, GNU applications can #define my_strftime to a symbol (typically nstrftime) to get an extended strftime with - extra arguments UT and NS. Emacs is a special case for now, but - this Emacs-specific code can be removed once Emacs's config.h - defines my_strftime. */ -#if defined emacs && !defined my_strftime -# define my_strftime nstrftime -#endif + extra arguments TZ and NS. */ #if FPRINTFTIME # undef my_strftime @@ -398,8 +383,9 @@ iso_week_days (int yday, int wday) #endif #ifdef my_strftime -# define extra_args , ut, ns -# define extra_args_spec , int ut, int ns +# undef HAVE_TZSET +# define extra_args , tz, ns +# define extra_args_spec , timezone_t tz, int ns #else # if defined COMPILE_WIDE # define my_strftime wcsftime @@ -411,7 +397,7 @@ iso_week_days (int yday, int wday) # define extra_args # define extra_args_spec /* We don't have this information in general. */ -# define ut 0 +# define tz 1 # define ns 0 #endif @@ -454,6 +440,9 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, # define aw_len STRLEN (a_wkday) # define am_len STRLEN (a_month) # define ap_len STRLEN (ampm) +#endif +#if HAVE_TZNAME + char **tzname_vec = tzname; #endif const char *zone; size_t i = 0; @@ -483,20 +472,29 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, zone = (const char *) tp->tm_zone; #endif #if HAVE_TZNAME - if (ut) + if (!tz) { if (! (zone && *zone)) zone = "GMT"; } else { +# if !HAVE_TM_ZONE + /* Infer the zone name from *TZ instead of from TZNAME. */ + tzname_vec = tz->tzname_copy; +# endif /* POSIX.1 requires that local time zone information be used as though strftime called tzset. */ # if HAVE_TZSET tzset (); # endif } + /* The tzset() call might have changed the value. */ + if (!(zone && *zone) && tp->tm_isdst >= 0) + zone = tzname_vec[tp->tm_isdst != 0]; #endif + if (! zone) + zone = ""; if (hour12 > 12) hour12 -= 12; @@ -643,7 +641,7 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, break; } - /* As a GNU extension we allow to specify the field width. */ + /* As a GNU extension we allow the field width to be specified. */ if (ISDIGIT (*f)) { width = 0; @@ -681,24 +679,44 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, switch (format_char) { #define DO_NUMBER(d, v) \ - digits = d; \ - number_value = v; goto do_number + do \ + { \ + digits = d; \ + number_value = v; \ + goto do_number; \ + } \ + while (0) #define DO_SIGNED_NUMBER(d, negative, v) \ - digits = d; \ - negative_number = negative; \ - u_number_value = v; goto do_signed_number + do \ + { \ + digits = d; \ + negative_number = negative; \ + u_number_value = v; \ + goto do_signed_number; \ + } \ + while (0) /* The mask is not what you might think. When the ordinal i'th bit is set, insert a colon before the i'th digit of the time zone representation. */ #define DO_TZ_OFFSET(d, negative, mask, v) \ - digits = d; \ - negative_number = negative; \ - tz_colon_mask = mask; \ - u_number_value = v; goto do_tz_offset + do \ + { \ + digits = d; \ + negative_number = negative; \ + tz_colon_mask = mask; \ + u_number_value = v; \ + goto do_tz_offset; \ + } \ + while (0) #define DO_NUMBER_SPACEPAD(d, v) \ - digits = d; \ - number_value = v; goto do_number_spacepad + do \ + { \ + digits = d; \ + number_value = v; \ + goto do_number_spacepad; \ + } \ + while (0) case L_('%'): if (modifier != 0) @@ -1124,7 +1142,7 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, time_t t; ltm = *tp; - t = mktime (<m); + t = mktime_z (tz, <m); /* Generate string value for T using time_t arithmetic; this works even if sizeof (long) < sizeof (time_t). */ @@ -1265,9 +1283,9 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, } if (modifier == L_('O')) goto bad_format; - else - DO_SIGNED_NUMBER (4, tp->tm_year < -TM_YEAR_BASE, - tp->tm_year + (unsigned int) TM_YEAR_BASE); + + DO_SIGNED_NUMBER (4, tp->tm_year < -TM_YEAR_BASE, + tp->tm_year + (unsigned int) TM_YEAR_BASE); case L_('y'): if (modifier == L_('E')) @@ -1299,14 +1317,6 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, to_lowcase = true; } -#if HAVE_TZNAME - /* The tzset() call might have changed the value. */ - if (!(zone && *zone) && tp->tm_isdst >= 0) - zone = tzname[tp->tm_isdst != 0]; -#endif - if (! zone) - zone = ""; - #ifdef COMPILE_WIDE { /* The zone string is always given in multibyte form. We have @@ -1346,7 +1356,7 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, #if HAVE_TM_GMTOFF diff = tp->tm_gmtoff; #else - if (ut) + if (!tz) diff = 0; else { @@ -1355,7 +1365,7 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, time_t lt; ltm = *tp; - lt = mktime (<m); + lt = mktime_z (tz, <m); if (lt == (time_t) -1) { @@ -1364,7 +1374,7 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, occurred. */ struct tm tm; - if (! __localtime_r (<, &tm) + if (! localtime_rz (tz, <, &tm) || ((ltm.tm_sec ^ tm.tm_sec) | (ltm.tm_min ^ tm.tm_min) | (ltm.tm_hour ^ tm.tm_hour) @@ -1374,7 +1384,7 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, break; } - if (! __gmtime_r (<, >m)) + if (! localtime_rz (0, <, >m)) break; diff = tm_diff (<m, >m); @@ -1453,15 +1463,3 @@ my_strftime (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize) #if defined _LIBC && ! FPRINTFTIME libc_hidden_def (my_strftime) #endif - - -#if defined emacs && ! FPRINTFTIME -/* For Emacs we have a separate interface which corresponds to the normal - strftime function plus the ut argument, but without the ns argument. */ -size_t -emacs_strftimeu (char *s, size_t maxsize, const char *format, - const struct tm *tp, int ut) -{ - return my_strftime (s, maxsize, format, tp, ut, 0); -} -#endif diff --git a/lib/strftime.h b/lib/strftime.h index a394640e6..9247af68b 100644 --- a/lib/strftime.h +++ b/lib/strftime.h @@ -1,6 +1,6 @@ /* declarations for strftime.c - Copyright (C) 2002, 2004, 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2002, 2004, 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -23,11 +23,10 @@ extern "C" { /* Just like strftime, but with two more arguments: POSIX requires that strftime use the local timezone information. - When __UTC is nonzero and tm->tm_zone is NULL or the empty string, - use UTC instead. Use __NS as the number of nanoseconds in the - %N directive. */ + Use the timezone __TZ instead. Use __NS as the number of + nanoseconds in the %N directive. */ size_t nstrftime (char *, size_t, char const *, struct tm const *, - int __utc, int __ns); + timezone_t __tz, int __ns); #ifdef __cplusplus } diff --git a/lib/striconveh.c b/lib/striconveh.c index 1a2f62e44..23a071825 100644 --- a/lib/striconveh.c +++ b/lib/striconveh.c @@ -1,5 +1,5 @@ /* Character set conversion with error handling. - Copyright (C) 2001-2014 Free Software Foundation, Inc. + Copyright (C) 2001-2016 Free Software Foundation, Inc. Written by Bruno Haible and Simon Josefsson. This program is free software: you can redistribute it and/or modify diff --git a/lib/striconveh.h b/lib/striconveh.h index a4e425aa2..a6fe7cfe5 100644 --- a/lib/striconveh.h +++ b/lib/striconveh.h @@ -1,5 +1,5 @@ /* Character set conversion with error handling. - Copyright (C) 2001-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2001-2007, 2009-2016 Free Software Foundation, Inc. Written by Bruno Haible and Simon Josefsson. This program is free software: you can redistribute it and/or modify diff --git a/lib/string.in.h b/lib/string.in.h index eaaaa9dda..94019c6b2 100644 --- a/lib/string.in.h +++ b/lib/string.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 1995-1996, 2001-2014 Free Software Foundation, Inc. + Copyright (C) 1995-1996, 2001-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -15,16 +15,32 @@ You should have received a copy of the GNU Lesser General Public License along with this program; if not, see . */ -#ifndef _@GUARD_PREFIX@_STRING_H - #if __GNUC__ >= 3 @PRAGMA_SYSTEM_HEADER@ #endif @PRAGMA_COLUMNS@ +#if defined _GL_ALREADY_INCLUDING_STRING_H +/* Special invocation convention: + - On OS X/NetBSD we have a sequence of nested includes + -> -> "string.h" + In this situation system _chk variants due to -D_FORTIFY_SOURCE + might be used after any replacements defined here. */ + +#@INCLUDE_NEXT@ @NEXT_STRING_H@ + +#else +/* Normal invocation convention. */ + +#ifndef _@GUARD_PREFIX@_STRING_H + +#define _GL_ALREADY_INCLUDING_STRING_H + /* The include_next requires a split double-inclusion guard. */ #@INCLUDE_NEXT@ @NEXT_STRING_H@ +#undef _GL_ALREADY_INCLUDING_STRING_H + #ifndef _@GUARD_PREFIX@_STRING_H #define _@GUARD_PREFIX@_STRING_H @@ -1027,3 +1043,4 @@ _GL_WARN_ON_USE (strverscmp, "strverscmp is unportable - " #endif /* _@GUARD_PREFIX@_STRING_H */ #endif /* _@GUARD_PREFIX@_STRING_H */ +#endif diff --git a/lib/stripslash.c b/lib/stripslash.c index 22295e57a..809ab7a28 100644 --- a/lib/stripslash.c +++ b/lib/stripslash.c @@ -1,6 +1,6 @@ /* stripslash.c -- remove redundant trailing slashes from a file name - Copyright (C) 1990, 2001, 2003-2006, 2009-2014 Free Software Foundation, + Copyright (C) 1990, 2001, 2003-2006, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/sys_file.in.h b/lib/sys_file.in.h index 1df6946a5..9973c27f0 100644 --- a/lib/sys_file.in.h +++ b/lib/sys_file.in.h @@ -1,6 +1,6 @@ /* Provide a more complete sys/file.h. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sys_select.in.h b/lib/sys_select.in.h index 7e5c3a389..53e318a3c 100644 --- a/lib/sys_select.in.h +++ b/lib/sys_select.in.h @@ -1,5 +1,5 @@ /* Substitute for . - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -24,8 +24,8 @@ On Cygwin, includes . Simply delegate to the system's header in this case. */ #if (@HAVE_SYS_SELECT_H@ \ + && !defined _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TYPES_H \ && ((defined __osf__ && defined _SYS_TYPES_H_ \ - && !defined _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TIME_H \ && defined _OSF_SOURCE) \ || (defined __sun && defined _SYS_TYPES_H \ && (! (defined _XOPEN_SOURCE || defined _POSIX_C_SOURCE) \ @@ -36,12 +36,13 @@ #elif (@HAVE_SYS_SELECT_H@ \ && (defined _CYGWIN_SYS_TIME_H \ - || (defined __osf__ && defined _SYS_TIME_H_ \ - && !defined _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TIME_H \ - && defined _OSF_SOURCE) \ - || (defined __sun && defined _SYS_TIME_H \ - && (! (defined _XOPEN_SOURCE || defined _POSIX_C_SOURCE) \ - || defined __EXTENSIONS__)))) + || (!defined _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TIME_H \ + && ((defined __osf__ && defined _SYS_TIME_H_ \ + && defined _OSF_SOURCE) \ + || (defined __sun && defined _SYS_TIME_H \ + && (! (defined _XOPEN_SOURCE \ + || defined _POSIX_C_SOURCE) \ + || defined __EXTENSIONS__)))))) # define _GL_SYS_SELECT_H_REDIRECT_FROM_SYS_TIME_H # @INCLUDE_NEXT@ @NEXT_SYS_SELECT_H@ @@ -80,8 +81,9 @@ of 'struct timeval', and no definition of this type. Also, Mac OS X, AIX, HP-UX, IRIX, Solaris, Interix declare select() in . - But avoid namespace pollution on glibc systems. */ -# ifndef __GLIBC__ + But avoid namespace pollution on glibc systems and "unknown type + name" problems on Cygwin. */ +# if !(defined __GLIBC__ || defined __CYGWIN__) # include # endif @@ -99,10 +101,11 @@ #endif /* Get definition of 'sigset_t'. - But avoid namespace pollution on glibc systems. + But avoid namespace pollution on glibc systems and "unknown type + name" problems on Cygwin. Do this after the include_next (for the sake of OpenBSD 5.0) but before the split double-inclusion guard (for the sake of Solaris). */ -#if !(defined __GLIBC__ && !defined __UCLIBC__) +#if !((defined __GLIBC__ || defined __CYGWIN__) && !defined __UCLIBC__) # include #endif @@ -288,12 +291,15 @@ _GL_WARN_ON_USE (pselect, "pselect is not portable - " # define select rpl_select # endif _GL_FUNCDECL_RPL (select, int, - (int, fd_set *, fd_set *, fd_set *, struct timeval *)); + (int, fd_set *restrict, fd_set *restrict, fd_set *restrict, + struct timeval *restrict)); _GL_CXXALIAS_RPL (select, int, - (int, fd_set *, fd_set *, fd_set *, struct timeval *)); + (int, fd_set *restrict, fd_set *restrict, fd_set *restrict, + struct timeval *restrict)); # else _GL_CXXALIAS_SYS (select, int, - (int, fd_set *, fd_set *, fd_set *, struct timeval *)); + (int, fd_set *restrict, fd_set *restrict, fd_set *restrict, + struct timeval *restrict)); # endif _GL_CXXALIASWARN (select); #elif @HAVE_WINSOCK2_H@ diff --git a/lib/sys_socket.c b/lib/sys_socket.c index 3f017f8fc..3b261da03 100644 --- a/lib/sys_socket.c +++ b/lib/sys_socket.c @@ -1,3 +1,4 @@ #include #define _GL_SYS_SOCKET_INLINE _GL_EXTERN_INLINE #include "sys/socket.h" +typedef int dummy; diff --git a/lib/sys_socket.in.h b/lib/sys_socket.in.h index 0cbc3e4fe..26024f69b 100644 --- a/lib/sys_socket.in.h +++ b/lib/sys_socket.in.h @@ -1,6 +1,6 @@ /* Provide a sys/socket header file for systems lacking it (read: MinGW) and for systems where it is incomplete. - Copyright (C) 2005-2014 Free Software Foundation, Inc. + Copyright (C) 2005-2016 Free Software Foundation, Inc. Written by Simon Josefsson. This program is free software; you can redistribute it and/or modify diff --git a/lib/sys_stat.in.h b/lib/sys_stat.in.h index 32c23a055..2d063956d 100644 --- a/lib/sys_stat.in.h +++ b/lib/sys_stat.in.h @@ -1,5 +1,5 @@ /* Provide a more complete sys/stat header file. - Copyright (C) 2005-2014 Free Software Foundation, Inc. + Copyright (C) 2005-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sys_time.in.h b/lib/sys_time.in.h index f19326e02..e1e26e33b 100644 --- a/lib/sys_time.in.h +++ b/lib/sys_time.in.h @@ -1,6 +1,6 @@ /* Provide a more complete sys/time.h. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sys_times.in.h b/lib/sys_times.in.h index b3babfb80..693eedec5 100644 --- a/lib/sys_times.in.h +++ b/lib/sys_times.in.h @@ -1,5 +1,5 @@ /* Provide a sys/times.h header file. - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sys_types.in.h b/lib/sys_types.in.h index c8d0bb48f..9ca53ac0e 100644 --- a/lib/sys_types.in.h +++ b/lib/sys_types.in.h @@ -1,6 +1,6 @@ /* Provide a more complete sys/types.h. - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -23,7 +23,9 @@ #ifndef _@GUARD_PREFIX@_SYS_TYPES_H /* The include_next requires a split double-inclusion guard. */ +# define _GL_INCLUDING_SYS_TYPES_H #@INCLUDE_NEXT@ @NEXT_SYS_TYPES_H@ +# undef _GL_INCLUDING_SYS_TYPES_H #ifndef _@GUARD_PREFIX@_SYS_TYPES_H #define _@GUARD_PREFIX@_SYS_TYPES_H diff --git a/lib/sys_uio.in.h b/lib/sys_uio.in.h index 8cad7de32..d72eb568a 100644 --- a/lib/sys_uio.in.h +++ b/lib/sys_uio.in.h @@ -1,5 +1,5 @@ /* Substitute for . - Copyright (C) 2011-2014 Free Software Foundation, Inc. + Copyright (C) 2011-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/tempname.c b/lib/tempname.c index f0f7e7f29..5136bb495 100644 --- a/lib/tempname.c +++ b/lib/tempname.c @@ -1,6 +1,6 @@ /* tempname.c - generate the name of a temporary file. - Copyright (C) 1991-2003, 2005-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 1991-2003, 2005-2007, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -62,6 +62,7 @@ # define struct_stat64 struct stat64 #else # define struct_stat64 struct stat +# define __try_tempname try_tempname # define __gen_tempname gen_tempname # define __getpid getpid # define __gettimeofday gettimeofday @@ -176,21 +177,9 @@ __path_search (char *tmpl, size_t tmpl_len, const char *dir, const char *pfx, static const char letters[] = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"; -/* Generate a temporary file name based on TMPL. TMPL must match the - rules for mk[s]temp (i.e. end in "XXXXXX", possibly with a suffix). - The name constructed does not exist at the time of the call to - __gen_tempname. TMPL is overwritten with the result. - - KIND may be one of: - __GT_NOCREATE: simply verify that the name does not exist - at the time of the call. - __GT_FILE: create the file using open(O_CREAT|O_EXCL) - and return a read-write fd. The file is mode 0600. - __GT_DIR: create a directory, which will be mode 0700. - - We use a clever algorithm to get hard-to-predict names. */ int -__gen_tempname (char *tmpl, int suffixlen, int flags, int kind) +__try_tempname (char *tmpl, int suffixlen, void *args, + int (*tryfunc) (char *, void *)) { int len; char *XXXXXX; @@ -199,7 +188,6 @@ __gen_tempname (char *tmpl, int suffixlen, int flags, int kind) unsigned int count; int fd = -1; int save_errno = errno; - struct_stat64 st; /* A lower bound on the number of temporary files to attempt to generate. The maximum total number of temporary file names that @@ -256,41 +244,7 @@ __gen_tempname (char *tmpl, int suffixlen, int flags, int kind) v /= 62; XXXXXX[5] = letters[v % 62]; - switch (kind) - { - case __GT_FILE: - fd = __open (tmpl, - (flags & ~O_ACCMODE) - | O_RDWR | O_CREAT | O_EXCL, S_IRUSR | S_IWUSR); - break; - - case __GT_DIR: - fd = __mkdir (tmpl, S_IRUSR | S_IWUSR | S_IXUSR); - break; - - case __GT_NOCREATE: - /* This case is backward from the other three. __gen_tempname - succeeds if __xstat fails because the name does not exist. - Note the continue to bypass the common logic at the bottom - of the loop. */ - if (__lxstat64 (_STAT_VER, tmpl, &st) < 0) - { - if (errno == ENOENT) - { - __set_errno (save_errno); - return 0; - } - else - /* Give up now. */ - return -1; - } - continue; - - default: - assert (! "invalid KIND in __gen_tempname"); - abort (); - } - + fd = tryfunc (tmpl, args); if (fd >= 0) { __set_errno (save_errno); @@ -304,3 +258,67 @@ __gen_tempname (char *tmpl, int suffixlen, int flags, int kind) __set_errno (EEXIST); return -1; } + +static int +try_file (char *tmpl, void *flags) +{ + int *openflags = flags; + return __open (tmpl, + (*openflags & ~O_ACCMODE) + | O_RDWR | O_CREAT | O_EXCL, S_IRUSR | S_IWUSR); +} + +static int +try_dir (char *tmpl, void *flags _GL_UNUSED) +{ + return __mkdir (tmpl, S_IRUSR | S_IWUSR | S_IXUSR); +} + +static int +try_nocreate (char *tmpl, void *flags _GL_UNUSED) +{ + struct_stat64 st; + + if (__lxstat64 (_STAT_VER, tmpl, &st) == 0) + __set_errno (EEXIST); + return errno == ENOENT ? 0 : -1; +} + +/* Generate a temporary file name based on TMPL. TMPL must match the + rules for mk[s]temp (i.e. end in "XXXXXX", possibly with a suffix). + The name constructed does not exist at the time of the call to + __gen_tempname. TMPL is overwritten with the result. + + KIND may be one of: + __GT_NOCREATE: simply verify that the name does not exist + at the time of the call. + __GT_FILE: create the file using open(O_CREAT|O_EXCL) + and return a read-write fd. The file is mode 0600. + __GT_DIR: create a directory, which will be mode 0700. + + We use a clever algorithm to get hard-to-predict names. */ +int +__gen_tempname (char *tmpl, int suffixlen, int flags, int kind) +{ + int (*tryfunc) (char *, void *); + + switch (kind) + { + case __GT_FILE: + tryfunc = try_file; + break; + + case __GT_DIR: + tryfunc = try_dir; + break; + + case __GT_NOCREATE: + tryfunc = try_nocreate; + break; + + default: + assert (! "invalid KIND in __gen_tempname"); + abort (); + } + return __try_tempname (tmpl, suffixlen, &flags, tryfunc); +} diff --git a/lib/tempname.h b/lib/tempname.h index bd46f93f9..4e032880a 100644 --- a/lib/tempname.h +++ b/lib/tempname.h @@ -1,6 +1,6 @@ /* Create a temporary file or directory. - Copyright (C) 2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2006, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -32,6 +32,10 @@ # define GT_NOCREATE 2 # endif +#ifdef __cplusplus +extern "C" { +#endif + /* Generate a temporary file name based on TMPL. TMPL must match the rules for mk[s]temp (i.e. end in "XXXXXX", possibly with a suffix). The name constructed does not exist at the time of the call to @@ -47,4 +51,15 @@ We use a clever algorithm to get hard-to-predict names. */ extern int gen_tempname (char *tmpl, int suffixlen, int flags, int kind); +/* Similar to gen_tempname, but TRYFUNC is called for each temporary + name to try. If TRYFUNC returns a non-negative number, TRY_GEN_TEMPNAME + returns with this value. Otherwise, if errno is set to EEXIST, another + name is tried, or else TRY_GEN_TEMPNAME returns -1. */ +extern int try_tempname (char *tmpl, int suffixlen, void *args, + int (*tryfunc) (char *, void *)); + +#ifdef __cplusplus +} +#endif + #endif /* GL_TEMPNAME_H */ diff --git a/lib/time-internal.h b/lib/time-internal.h new file mode 100644 index 000000000..48c0977d1 --- /dev/null +++ b/lib/time-internal.h @@ -0,0 +1,49 @@ +/* Time internal interface + + Copyright 2015-2016 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License along + with this program; if not, see . */ + +/* Written by Paul Eggert. */ + +/* A time zone rule. */ +struct tm_zone +{ + /* More abbreviations, should they be needed. Their TZ_IS_SET + members are zero. */ + struct tm_zone *next; + +#if HAVE_TZNAME && !HAVE_TM_ZONE + /* Copies of recent strings taken from tzname[0] and tzname[1]. + The copies are in ABBRS, so that they survive tzset. Null if unknown. */ + char *tzname_copy[2]; +#endif + + /* If nonzero, the rule represents the TZ environment variable set + to the first "abbreviation" (this may be the empty string). + Otherwise, it represents an unset TZ. */ + char tz_is_set; + + /* A sequence of null-terminated strings packed next to each other. + The strings are followed by an extra null byte. If TZ_IS_SET, + there must be at least one string and the first string (which is + actually a TZ environment value value) may be empty. Otherwise + all strings must be nonempty. + + Abbreviations are stored here because otherwise the values of + tm_zone and/or tzname would be dead after changing TZ and calling + tzset. Abbreviations never move once allocated, and are live + until tzfree is called. */ + char abbrs[FLEXIBLE_ARRAY_MEMBER]; +}; diff --git a/lib/time.in.h b/lib/time.in.h index 01681cc8c..503085a60 100644 --- a/lib/time.in.h +++ b/lib/time.in.h @@ -1,6 +1,6 @@ /* A more-standard . - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -22,11 +22,13 @@ /* Don't get in the way of glibc when it includes time.h merely to declare a few standard symbols, rather than to declare all the - symbols. Also, Solaris 8 eventually includes itself + symbols. (However, skip this for MinGW as it treats __need_time_t + incompatibly.) Also, Solaris 8 eventually includes itself recursively; if that is happening, just include the system without adding our own declarations. */ -#if (defined __need_time_t || defined __need_clock_t \ - || defined __need_timespec \ +#if (((defined __need_time_t || defined __need_clock_t \ + || defined __need_timespec) \ + && !defined __MINGW32__) \ || defined _@GUARD_PREFIX@_TIME_H) # @INCLUDE_NEXT@ @NEXT_TIME_H@ @@ -55,6 +57,8 @@ # include # elif @PTHREAD_H_DEFINES_STRUCT_TIMESPEC@ # include +# elif @UNISTD_H_DEFINES_STRUCT_TIMESPEC@ +# include # else # ifdef __cplusplus @@ -229,6 +233,25 @@ _GL_CXXALIAS_SYS (strptime, char *, (char const *restrict __buf, _GL_CXXALIASWARN (strptime); # endif +# if defined _GNU_SOURCE && @GNULIB_TIME_RZ@ && ! @HAVE_TIMEZONE_T@ +typedef struct tm_zone *timezone_t; +_GL_FUNCDECL_SYS (tzalloc, timezone_t, (char const *__name)); +_GL_CXXALIAS_SYS (tzalloc, timezone_t, (char const *__name)); +_GL_FUNCDECL_SYS (tzfree, void, (timezone_t __tz)); +_GL_CXXALIAS_SYS (tzfree, void, (timezone_t __tz)); +_GL_FUNCDECL_SYS (localtime_rz, struct tm *, + (timezone_t __tz, time_t const *restrict __timer, + struct tm *restrict __result) _GL_ARG_NONNULL ((2, 3))); +_GL_CXXALIAS_SYS (localtime_rz, struct tm *, + (timezone_t __tz, time_t const *restrict __timer, + struct tm *restrict __result)); +_GL_FUNCDECL_SYS (mktime_z, time_t, + (timezone_t __tz, struct tm *restrict __result) + _GL_ARG_NONNULL ((2))); +_GL_CXXALIAS_SYS (mktime_z, time_t, + (timezone_t __tz, struct tm *restrict __result)); +# endif + /* Convert TM to a time_t value, assuming UTC. */ # if @GNULIB_TIMEGM@ # if @REPLACE_TIMEGM@ diff --git a/lib/time_r.c b/lib/time_r.c index 0249750e8..34ced96bf 100644 --- a/lib/time_r.c +++ b/lib/time_r.c @@ -1,6 +1,6 @@ /* Reentrant time functions like localtime_r. - Copyright (C) 2003, 2006-2007, 2010-2014 Free Software Foundation, Inc. + Copyright (C) 2003, 2006-2007, 2010-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/time_rz.c b/lib/time_rz.c new file mode 100644 index 000000000..612093bbc --- /dev/null +++ b/lib/time_rz.c @@ -0,0 +1,321 @@ +/* Time zone functions such as tzalloc and localtime_rz + + Copyright 2015-2016 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License along + with this program; if not, see . */ + +/* Written by Paul Eggert. */ + +/* Although this module is not thread-safe, any races should be fairly + rare and reasonably benign. For complete thread-safety, use a C + library with a working timezone_t type, so that this module is not + needed. */ + +#include + +#include + +#include +#include +#include +#include +#include + +#include "time-internal.h" + +#if !HAVE_TZSET +static void tzset (void) { } +#endif + +/* The approximate size to use for small allocation requests. This is + the largest "small" request for the GNU C library malloc. */ +enum { DEFAULT_MXFAST = 64 * sizeof (size_t) / 4 }; + +/* Minimum size of the ABBRS member of struct abbr. ABBRS is larger + only in the unlikely case where an abbreviation longer than this is + used. */ +enum { ABBR_SIZE_MIN = DEFAULT_MXFAST - offsetof (struct tm_zone, abbrs) }; + +/* Magic cookie timezone_t value, for local time. It differs from + NULL and from all other timezone_t values. Only the address + matters; the pointer is never dereferenced. */ +static timezone_t const local_tz = (timezone_t) 1; + +#if HAVE_TM_ZONE || HAVE_TZNAME + +/* Return true if the values A and B differ according to the rules for + tm_isdst: A and B differ if one is zero and the other positive. */ +static bool +isdst_differ (int a, int b) +{ + return !a != !b && 0 <= a && 0 <= b; +} + +/* Return true if A and B are equal. */ +static int +equal_tm (const struct tm *a, const struct tm *b) +{ + return ! ((a->tm_sec ^ b->tm_sec) + | (a->tm_min ^ b->tm_min) + | (a->tm_hour ^ b->tm_hour) + | (a->tm_mday ^ b->tm_mday) + | (a->tm_mon ^ b->tm_mon) + | (a->tm_year ^ b->tm_year) + | isdst_differ (a->tm_isdst, b->tm_isdst)); +} + +#endif + +/* Copy to ABBRS the abbreviation at ABBR with size ABBR_SIZE (this + includes its trailing null byte). Append an extra null byte to + mark the end of ABBRS. */ +static void +extend_abbrs (char *abbrs, char const *abbr, size_t abbr_size) +{ + memcpy (abbrs, abbr, abbr_size); + abbrs[abbr_size] = '\0'; +} + +/* Return a newly allocated time zone for NAME, or NULL on failure. + A null NAME stands for wall clock time (which is like unset TZ). */ +timezone_t +tzalloc (char const *name) +{ + size_t name_size = name ? strlen (name) + 1 : 0; + size_t abbr_size = name_size < ABBR_SIZE_MIN ? ABBR_SIZE_MIN : name_size + 1; + timezone_t tz = malloc (offsetof (struct tm_zone, abbrs) + abbr_size); + if (tz) + { + tz->next = NULL; +#if HAVE_TZNAME && !HAVE_TM_ZONE + tz->tzname_copy[0] = tz->tzname_copy[1] = NULL; +#endif + tz->tz_is_set = !!name; + tz->abbrs[0] = '\0'; + if (name) + extend_abbrs (tz->abbrs, name, name_size); + } + return tz; +} + +/* Save into TZ any nontrivial time zone abbreviation used by TM, and + update *TM (if HAVE_TM_ZONE) or *TZ (if !HAVE_TM_ZONE && + HAVE_TZNAME) if they use the abbreviation. Return true if + successful, false (setting errno) otherwise. */ +static bool +save_abbr (timezone_t tz, struct tm *tm) +{ +#if HAVE_TM_ZONE || HAVE_TZNAME + char const *zone = NULL; + char *zone_copy = (char *) ""; + +# if HAVE_TZNAME + int tzname_index = -1; +# endif + +# if HAVE_TM_ZONE + zone = tm->tm_zone; +# endif + +# if HAVE_TZNAME + if (! (zone && *zone) && 0 <= tm->tm_isdst) + { + tzname_index = tm->tm_isdst != 0; + zone = tzname[tzname_index]; + } +# endif + + /* No need to replace null zones, or zones within the struct tm. */ + if (!zone || ((char *) tm <= zone && zone < (char *) (tm + 1))) + return true; + + if (*zone) + { + zone_copy = tz->abbrs; + + while (strcmp (zone_copy, zone) != 0) + { + if (! (*zone_copy || (zone_copy == tz->abbrs && tz->tz_is_set))) + { + size_t zone_size = strlen (zone) + 1; + if (zone_size < tz->abbrs + ABBR_SIZE_MIN - zone_copy) + extend_abbrs (zone_copy, zone, zone_size); + else + { + tz = tz->next = tzalloc (zone); + if (!tz) + return false; + tz->tz_is_set = 0; + zone_copy = tz->abbrs; + } + break; + } + + zone_copy += strlen (zone_copy) + 1; + if (!*zone_copy && tz->next) + { + tz = tz->next; + zone_copy = tz->abbrs; + } + } + } + + /* Replace the zone name so that its lifetime matches that of TZ. */ +# if HAVE_TM_ZONE + tm->tm_zone = zone_copy; +# else + if (0 <= tzname_index) + tz->tzname_copy[tzname_index] = zone_copy; +# endif +#endif + + return true; +} + +/* Free a time zone. */ +void +tzfree (timezone_t tz) +{ + if (tz != local_tz) + while (tz) + { + timezone_t next = tz->next; + free (tz); + tz = next; + } +} + +/* Get and set the TZ environment variable. These functions can be + overridden by programs like Emacs that manage their own environment. */ + +#ifndef getenv_TZ +static char * +getenv_TZ (void) +{ + return getenv ("TZ"); +} +#endif + +#ifndef setenv_TZ +static int +setenv_TZ (char const *tz) +{ + return tz ? setenv ("TZ", tz, 1) : unsetenv ("TZ"); +} +#endif + +/* Change the environment to match the specified timezone_t value. + Return true if successful, false (setting errno) otherwise. */ +static bool +change_env (timezone_t tz) +{ + if (setenv_TZ (tz->tz_is_set ? tz->abbrs : NULL) != 0) + return false; + tzset (); + return true; +} + +/* Temporarily set the time zone to TZ, which must not be null. + Return LOCAL_TZ if the time zone setting is already correct. + Otherwise return a newly allocated time zone representing the old + setting, or NULL (setting errno) on failure. */ +static timezone_t +set_tz (timezone_t tz) +{ + char *env_tz = getenv_TZ (); + if (env_tz + ? tz->tz_is_set && strcmp (tz->abbrs, env_tz) == 0 + : !tz->tz_is_set) + return local_tz; + else + { + timezone_t old_tz = tzalloc (env_tz); + if (!old_tz) + return old_tz; + if (! change_env (tz)) + { + int saved_errno = errno; + tzfree (old_tz); + errno = saved_errno; + return NULL; + } + return old_tz; + } +} + +/* Restore an old setting returned by set_tz. It must not be null. + Return true (preserving errno) if successful, false (setting errno) + otherwise. */ +static bool +revert_tz (timezone_t tz) +{ + if (tz == local_tz) + return true; + else + { + int saved_errno = errno; + bool ok = change_env (tz); + if (!ok) + saved_errno = errno; + tzfree (tz); + errno = saved_errno; + return ok; + } +} + +/* Use time zone TZ to compute localtime_r (T, TM). */ +struct tm * +localtime_rz (timezone_t tz, time_t const *t, struct tm *tm) +{ + if (!tz) + return gmtime_r (t, tm); + else + { + timezone_t old_tz = set_tz (tz); + if (old_tz) + { + bool abbr_saved = localtime_r (t, tm) && save_abbr (tz, tm); + if (revert_tz (old_tz) && abbr_saved) + return tm; + } + return NULL; + } +} + +/* Use time zone TZ to compute mktime (TM). */ +time_t +mktime_z (timezone_t tz, struct tm *tm) +{ + if (!tz) + return timegm (tm); + else + { + timezone_t old_tz = set_tz (tz); + if (old_tz) + { + time_t t = mktime (tm); +#if HAVE_TM_ZONE || HAVE_TZNAME + time_t badtime = -1; + struct tm tm_1; + if ((t != badtime + || (localtime_r (&t, &tm_1) && equal_tm (tm, &tm_1))) + && !save_abbr (tz, tm)) + t = badtime; +#endif + if (revert_tz (old_tz)) + return t; + } + return -1; + } +} diff --git a/lib/timegm.c b/lib/timegm.c new file mode 100644 index 000000000..112be1ac6 --- /dev/null +++ b/lib/timegm.c @@ -0,0 +1,40 @@ +/* Convert UTC calendar time to simple time. Like mktime but assumes UTC. + + Copyright (C) 1994, 1997, 2003-2004, 2006-2007, 2009-2016 Free Software + Foundation, Inc. This file is part of the GNU C Library. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, see . */ + +#ifndef _LIBC +# include +#endif + +#include + +#ifdef _LIBC +typedef time_t mktime_offset_t; +#else +# undef __gmtime_r +# define __gmtime_r gmtime_r +# define __mktime_internal mktime_internal +# include "mktime-internal.h" +#endif + +time_t +timegm (struct tm *tmp) +{ + static mktime_offset_t gmtime_offset; + tmp->tm_isdst = 0; + return __mktime_internal (tmp, __gmtime_r, &gmtime_offset); +} diff --git a/lib/times.c b/lib/times.c index 605f2356f..4fa15c2df 100644 --- a/lib/times.c +++ b/lib/times.c @@ -1,6 +1,6 @@ /* Get process times - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -62,5 +62,5 @@ times (struct tms * buffer) buffer->tms_cutime = 0; buffer->tms_cstime = 0; - return filetime2clock (creation_time); + return clock (); } diff --git a/lib/trunc.c b/lib/trunc.c index e2857335b..eba389a3e 100644 --- a/lib/trunc.c +++ b/lib/trunc.c @@ -1,5 +1,5 @@ /* Round towards zero. - Copyright (C) 2007, 2010-2014 Free Software Foundation, Inc. + Copyright (C) 2007, 2010-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/unistd.c b/lib/unistd.c index 6c6a8e268..72bad1c05 100644 --- a/lib/unistd.c +++ b/lib/unistd.c @@ -1,3 +1,4 @@ #include #define _GL_UNISTD_INLINE _GL_EXTERN_INLINE #include "unistd.h" +typedef int dummy; diff --git a/lib/unistd.in.h b/lib/unistd.in.h index 842025024..26b73a8a2 100644 --- a/lib/unistd.in.h +++ b/lib/unistd.in.h @@ -1,5 +1,5 @@ /* Substitute for and wrapper around . - Copyright (C) 2003-2014 Free Software Foundation, Inc. + Copyright (C) 2003-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -401,6 +401,12 @@ _GL_WARN_ON_USE (dup3, "dup3 is unportable - " /* Set of environment variables and values. An array of strings of the form "VARIABLE=VALUE", terminated with a NULL. */ # if defined __APPLE__ && defined __MACH__ +# include +# if !TARGET_OS_IPHONE && !TARGET_IPHONE_SIMULATOR +# define _GL_USE_CRT_EXTERNS +# endif +# endif +# ifdef _GL_USE_CRT_EXTERNS # include # define environ (*_NSGetEnviron ()) # else @@ -1287,13 +1293,24 @@ _GL_WARN_ON_USE (readlink, "readlink is unportable - " #if @GNULIB_READLINKAT@ -# if !@HAVE_READLINKAT@ +# if @REPLACE_READLINKAT@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# define readlinkat rpl_readlinkat +# endif +_GL_FUNCDECL_RPL (readlinkat, ssize_t, + (int fd, char const *file, char *buf, size_t len) + _GL_ARG_NONNULL ((2, 3))); +_GL_CXXALIAS_RPL (readlinkat, ssize_t, + (int fd, char const *file, char *buf, size_t len)); +# else +# if !@HAVE_READLINKAT@ _GL_FUNCDECL_SYS (readlinkat, ssize_t, (int fd, char const *file, char *buf, size_t len) _GL_ARG_NONNULL ((2, 3))); -# endif +# endif _GL_CXXALIAS_SYS (readlinkat, ssize_t, (int fd, char const *file, char *buf, size_t len)); +# endif _GL_CXXALIASWARN (readlinkat); #elif defined GNULIB_POSIXCHECK # undef readlinkat @@ -1407,13 +1424,25 @@ _GL_WARN_ON_USE (symlink, "symlink is not portable - " #if @GNULIB_SYMLINKAT@ -# if !@HAVE_SYMLINKAT@ +# if @REPLACE_SYMLINKAT@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef symlinkat +# define symlinkat rpl_symlinkat +# endif +_GL_FUNCDECL_RPL (symlinkat, int, + (char const *contents, int fd, char const *file) + _GL_ARG_NONNULL ((1, 3))); +_GL_CXXALIAS_RPL (symlinkat, int, + (char const *contents, int fd, char const *file)); +# else +# if !@HAVE_SYMLINKAT@ _GL_FUNCDECL_SYS (symlinkat, int, (char const *contents, int fd, char const *file) _GL_ARG_NONNULL ((1, 3))); -# endif +# endif _GL_CXXALIAS_SYS (symlinkat, int, (char const *contents, int fd, char const *file)); +# endif _GL_CXXALIASWARN (symlinkat); #elif defined GNULIB_POSIXCHECK # undef symlinkat diff --git a/lib/unistr.in.h b/lib/unistr.in.h index 73d2c23c0..2a64b31d9 100644 --- a/lib/unistr.in.h +++ b/lib/unistr.in.h @@ -1,5 +1,5 @@ /* Elementary Unicode string functions. - Copyright (C) 2001-2002, 2005-2014 Free Software Foundation, Inc. + Copyright (C) 2001-2002, 2005-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/unistr/u8-mbtouc-aux.c b/lib/unistr/u8-mbtouc-aux.c index 02cdacd9d..d546ae7af 100644 --- a/lib/unistr/u8-mbtouc-aux.c +++ b/lib/unistr/u8-mbtouc-aux.c @@ -1,5 +1,5 @@ /* Conversion UTF-8 to UCS-4. - Copyright (C) 2001-2002, 2006-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2001-2002, 2006-2007, 2009-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2001. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-mbtouc-unsafe-aux.c b/lib/unistr/u8-mbtouc-unsafe-aux.c index bfa96f4ab..61783e4ba 100644 --- a/lib/unistr/u8-mbtouc-unsafe-aux.c +++ b/lib/unistr/u8-mbtouc-unsafe-aux.c @@ -1,5 +1,5 @@ /* Conversion UTF-8 to UCS-4. - Copyright (C) 2001-2002, 2006-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2001-2002, 2006-2007, 2009-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2001. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-mbtouc-unsafe.c b/lib/unistr/u8-mbtouc-unsafe.c index 9c2095b68..b73e99a1b 100644 --- a/lib/unistr/u8-mbtouc-unsafe.c +++ b/lib/unistr/u8-mbtouc-unsafe.c @@ -1,5 +1,5 @@ /* Look at first character in UTF-8 string. - Copyright (C) 1999-2002, 2006-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 1999-2002, 2006-2007, 2009-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2001. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-mbtouc.c b/lib/unistr/u8-mbtouc.c index 2b389deb7..bfb0e4df8 100644 --- a/lib/unistr/u8-mbtouc.c +++ b/lib/unistr/u8-mbtouc.c @@ -1,5 +1,5 @@ /* Look at first character in UTF-8 string. - Copyright (C) 1999-2002, 2006-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 1999-2002, 2006-2007, 2009-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2001. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-mbtoucr.c b/lib/unistr/u8-mbtoucr.c index 3a75a4118..5fd45b57e 100644 --- a/lib/unistr/u8-mbtoucr.c +++ b/lib/unistr/u8-mbtoucr.c @@ -1,5 +1,5 @@ /* Look at first character in UTF-8 string, returning an error code. - Copyright (C) 1999-2002, 2006-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 1999-2002, 2006-2007, 2009-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2001. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-prev.c b/lib/unistr/u8-prev.c index b2c2b9b41..b609acf73 100644 --- a/lib/unistr/u8-prev.c +++ b/lib/unistr/u8-prev.c @@ -1,5 +1,5 @@ /* Iterate over previous character in UTF-8 string. - Copyright (C) 2002, 2006-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2002, 2006-2007, 2009-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2002. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-uctomb-aux.c b/lib/unistr/u8-uctomb-aux.c index 8d94bf57a..48adae10e 100644 --- a/lib/unistr/u8-uctomb-aux.c +++ b/lib/unistr/u8-uctomb-aux.c @@ -1,5 +1,5 @@ /* Conversion UCS-4 to UTF-8. - Copyright (C) 2002, 2006-2007, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2002, 2006-2007, 2009-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2002. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unistr/u8-uctomb.c b/lib/unistr/u8-uctomb.c index 1ce271fe8..d62ad0fa1 100644 --- a/lib/unistr/u8-uctomb.c +++ b/lib/unistr/u8-uctomb.c @@ -1,5 +1,5 @@ /* Store a character in UTF-8 string. - Copyright (C) 2002, 2005-2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2002, 2005-2006, 2009-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2002. This program is free software: you can redistribute it and/or modify it diff --git a/lib/unitypes.in.h b/lib/unitypes.in.h index e5ff9923c..4a1e65ede 100644 --- a/lib/unitypes.in.h +++ b/lib/unitypes.in.h @@ -1,5 +1,5 @@ /* Elementary types and macros for the GNU UniString library. - Copyright (C) 2002, 2005-2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2002, 2005-2006, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/unsetenv.c b/lib/unsetenv.c new file mode 100644 index 000000000..e94ea8f26 --- /dev/null +++ b/lib/unsetenv.c @@ -0,0 +1,127 @@ +/* Copyright (C) 1992, 1995-2002, 2005-2016 Free Software Foundation, Inc. + This file is part of the GNU C Library. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +/* Don't use __attribute__ __nonnull__ in this compilation unit. Otherwise gcc + optimizes away the name == NULL test below. */ +#define _GL_ARG_NONNULL(params) + +#include + +/* Specification. */ +#include + +#include +#if !_LIBC +# define __set_errno(ev) ((errno) = (ev)) +#endif + +#include +#include + +#if !_LIBC +# define __environ environ +#endif + +#if _LIBC +/* This lock protects against simultaneous modifications of 'environ'. */ +# include +__libc_lock_define_initialized (static, envlock) +# define LOCK __libc_lock_lock (envlock) +# define UNLOCK __libc_lock_unlock (envlock) +#else +# define LOCK +# define UNLOCK +#endif + +/* In the GNU C library we must keep the namespace clean. */ +#ifdef _LIBC +# define unsetenv __unsetenv +#endif + +#if _LIBC || !HAVE_UNSETENV + +int +unsetenv (const char *name) +{ + size_t len; + char **ep; + + if (name == NULL || *name == '\0' || strchr (name, '=') != NULL) + { + __set_errno (EINVAL); + return -1; + } + + len = strlen (name); + + LOCK; + + ep = __environ; + while (*ep != NULL) + if (!strncmp (*ep, name, len) && (*ep)[len] == '=') + { + /* Found it. Remove this pointer by moving later ones back. */ + char **dp = ep; + + do + dp[0] = dp[1]; + while (*dp++); + /* Continue the loop in case NAME appears again. */ + } + else + ++ep; + + UNLOCK; + + return 0; +} + +#ifdef _LIBC +# undef unsetenv +weak_alias (__unsetenv, unsetenv) +#endif + +#else /* HAVE_UNSETENV */ + +# undef unsetenv +# if !HAVE_DECL_UNSETENV +# if VOID_UNSETENV +extern void unsetenv (const char *); +# else +extern int unsetenv (const char *); +# endif +# endif + +/* Call the underlying unsetenv, in case there is hidden bookkeeping + that needs updating beyond just modifying environ. */ +int +rpl_unsetenv (const char *name) +{ + int result = 0; + if (!name || !*name || strchr (name, '=')) + { + errno = EINVAL; + return -1; + } + while (getenv (name)) +# if !VOID_UNSETENV + result = +# endif + unsetenv (name); + return result; +} + +#endif /* HAVE_UNSETENV */ diff --git a/lib/vasnprintf.c b/lib/vasnprintf.c index 7282b0504..e31dbadf0 100644 --- a/lib/vasnprintf.c +++ b/lib/vasnprintf.c @@ -1,5 +1,5 @@ /* vsprintf with automatic memory allocation. - Copyright (C) 1999, 2002-2014 Free Software Foundation, Inc. + Copyright (C) 1999, 2002-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -195,7 +195,7 @@ /* GCC >= 4.0 with -Wall emits unjustified "... may be used uninitialized" warnings in this file. Use -Dlint to suppress them. */ -#ifdef lint +#if defined GCC_LINT || defined lint # define IF_LINT(Code) Code #else # define IF_LINT(Code) /* empty */ @@ -1886,7 +1886,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, else { do - result[length++] = (unsigned char) *cp++; + result[length++] = *cp++; while (--n > 0); } } @@ -1957,15 +1957,14 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, if (!(a.arg[dp->width_arg_index].type == TYPE_INT)) abort (); arg = a.arg[dp->width_arg_index].a.a_int; + width = arg; if (arg < 0) { /* "A negative field width is taken as a '-' flag followed by a positive field width." */ flags |= FLAG_LEFT; - width = (unsigned int) (-arg); + width = -width; } - else - width = arg; } else { @@ -2073,8 +2072,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, characters = 0; } - if (has_width && width > characters - && !(dp->flags & FLAG_LEFT)) + if (characters < width && !(dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2127,8 +2125,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, } # endif - if (has_width && width > characters - && (dp->flags & FLAG_LEFT)) + if (characters < width && (dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2201,8 +2198,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, characters = 0; } - if (has_width && width > characters - && !(dp->flags & FLAG_LEFT)) + if (characters < width && !(dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2255,8 +2251,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, } # endif - if (has_width && width > characters - && (dp->flags & FLAG_LEFT)) + if (characters < width && (dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2329,8 +2324,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, characters = 0; } - if (has_width && width > characters - && !(dp->flags & FLAG_LEFT)) + if (characters < width && !(dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2383,8 +2377,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, } # endif - if (has_width && width > characters - && (dp->flags & FLAG_LEFT)) + if (characters < width && (dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2435,15 +2428,14 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, if (!(a.arg[dp->width_arg_index].type == TYPE_INT)) abort (); arg = a.arg[dp->width_arg_index].a.a_int; + width = arg; if (arg < 0) { /* "A negative field width is taken as a '-' flag followed by a positive field width." */ flags |= FLAG_LEFT; - width = (unsigned int) (-arg); + width = -width; } - else - width = arg; } else { @@ -2573,8 +2565,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, characters = 0; } - if (has_width && width > characters - && !(dp->flags & FLAG_LEFT)) + if (characters < width && !(dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2635,8 +2626,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, } } - if (has_width && width > characters - && (dp->flags & FLAG_LEFT)) + if (characters < width && (dp->flags & FLAG_LEFT)) { size_t n = width - characters; ENSURE_ALLOCATION (xsum (length, n)); @@ -2827,8 +2817,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, /* w doesn't matter. */ w = 0; - if (has_width && width > w - && !(dp->flags & FLAG_LEFT)) + if (w < width && !(dp->flags & FLAG_LEFT)) { size_t n = width - w; ENSURE_ALLOCATION (xsum (length, n)); @@ -2911,8 +2900,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, length += tmpdst_len; # endif - if (has_width && width > w - && (dp->flags & FLAG_LEFT)) + if (w < width && (dp->flags & FLAG_LEFT)) { size_t n = width - w; ENSURE_ALLOCATION (xsum (length, n)); @@ -2939,17 +2927,16 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, { arg_type type = a.arg[dp->arg_index].type; int flags = dp->flags; - int has_width; size_t width; int has_precision; size_t precision; size_t tmp_length; + size_t count; DCHAR_T tmpbuf[700]; DCHAR_T *tmp; DCHAR_T *pad_ptr; DCHAR_T *p; - has_width = 0; width = 0; if (dp->width_start != dp->width_end) { @@ -2960,15 +2947,14 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, if (!(a.arg[dp->width_arg_index].type == TYPE_INT)) abort (); arg = a.arg[dp->width_arg_index].a.a_int; + width = arg; if (arg < 0) { /* "A negative field width is taken as a '-' flag followed by a positive field width." */ flags |= FLAG_LEFT; - width = (unsigned int) (-arg); + width = -width; } - else - width = arg; } else { @@ -2978,7 +2964,6 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, width = xsum (xtimes (width, 10), *digitp++ - '0'); while (digitp != dp->width_end); } - has_width = 1; } has_precision = 0; @@ -3354,11 +3339,14 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, abort (); # endif } + /* The generated string now extends from tmp to p, with the zero padding insertion point being at pad_ptr. */ - if (has_width && p - tmp < width) + count = p - tmp; + + if (count < width) { - size_t pad = width - (p - tmp); + size_t pad = width - count; DCHAR_T *end = p + pad; if (flags & FLAG_LEFT) @@ -3391,28 +3379,26 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, p = end; } - { - size_t count = p - tmp; + count = p - tmp; - if (count >= tmp_length) - /* tmp_length was incorrectly calculated - fix the - code above! */ - abort (); + if (count >= tmp_length) + /* tmp_length was incorrectly calculated - fix the + code above! */ + abort (); - /* Make room for the result. */ - if (count >= allocated - length) - { - size_t n = xsum (length, count); + /* Make room for the result. */ + if (count >= allocated - length) + { + size_t n = xsum (length, count); - ENSURE_ALLOCATION (n); - } + ENSURE_ALLOCATION (n); + } - /* Append the result. */ - memcpy (result + length, tmp, count * sizeof (DCHAR_T)); - if (tmp != tmpbuf) - free (tmp); - length += count; - } + /* Append the result. */ + memcpy (result + length, tmp, count * sizeof (DCHAR_T)); + if (tmp != tmpbuf) + free (tmp); + length += count; } #endif #if (NEED_PRINTF_INFINITE_DOUBLE || NEED_PRINTF_DOUBLE || NEED_PRINTF_INFINITE_LONG_DOUBLE || NEED_PRINTF_LONG_DOUBLE) && !defined IN_LIBINTL @@ -3446,8 +3432,8 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, arg_type type = a.arg[dp->arg_index].type; # endif int flags = dp->flags; - int has_width; size_t width; + size_t count; int has_precision; size_t precision; size_t tmp_length; @@ -3456,7 +3442,6 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, DCHAR_T *pad_ptr; DCHAR_T *p; - has_width = 0; width = 0; if (dp->width_start != dp->width_end) { @@ -3467,15 +3452,14 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, if (!(a.arg[dp->width_arg_index].type == TYPE_INT)) abort (); arg = a.arg[dp->width_arg_index].a.a_int; + width = arg; if (arg < 0) { /* "A negative field width is taken as a '-' flag followed by a positive field width." */ flags |= FLAG_LEFT; - width = (unsigned int) (-arg); + width = -width; } - else - width = arg; } else { @@ -3485,7 +3469,6 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, width = xsum (xtimes (width, 10), *digitp++ - '0'); while (digitp != dp->width_end); } - has_width = 1; } has_precision = 0; @@ -3925,9 +3908,9 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, digits without trailing zeroes. */ if (exponent >= 0) { - size_t count = exponent + 1; + size_t ecount = exponent + 1; /* Note: count <= precision = ndigits. */ - for (; count > 0; count--) + for (; ecount > 0; ecount--) *p++ = digits[--ndigits]; if ((flags & FLAG_ALT) || ndigits > nzeroes) { @@ -3941,10 +3924,10 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, } else { - size_t count = -exponent - 1; + size_t ecount = -exponent - 1; *p++ = '0'; *p++ = decimal_point_char (); - for (; count > 0; count--) + for (; ecount > 0; ecount--) *p++ = '0'; while (ndigits > nzeroes) { @@ -4395,9 +4378,9 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, digits without trailing zeroes. */ if (exponent >= 0) { - size_t count = exponent + 1; - /* Note: count <= precision = ndigits. */ - for (; count > 0; count--) + size_t ecount = exponent + 1; + /* Note: ecount <= precision = ndigits. */ + for (; ecount > 0; ecount--) *p++ = digits[--ndigits]; if ((flags & FLAG_ALT) || ndigits > nzeroes) { @@ -4411,10 +4394,10 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, } else { - size_t count = -exponent - 1; + size_t ecount = -exponent - 1; *p++ = '0'; *p++ = decimal_point_char (); - for (; count > 0; count--) + for (; ecount > 0; ecount--) *p++ = '0'; while (ndigits > nzeroes) { @@ -4542,9 +4525,11 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, /* The generated string now extends from tmp to p, with the zero padding insertion point being at pad_ptr. */ - if (has_width && p - tmp < width) + count = p - tmp; + + if (count < width) { - size_t pad = width - (p - tmp); + size_t pad = width - count; DCHAR_T *end = p + pad; if (flags & FLAG_LEFT) @@ -4577,36 +4562,36 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, p = end; } - { - size_t count = p - tmp; + count = p - tmp; - if (count >= tmp_length) - /* tmp_length was incorrectly calculated - fix the - code above! */ - abort (); + if (count >= tmp_length) + /* tmp_length was incorrectly calculated - fix the + code above! */ + abort (); - /* Make room for the result. */ - if (count >= allocated - length) - { - size_t n = xsum (length, count); + /* Make room for the result. */ + if (count >= allocated - length) + { + size_t n = xsum (length, count); - ENSURE_ALLOCATION (n); - } + ENSURE_ALLOCATION (n); + } - /* Append the result. */ - memcpy (result + length, tmp, count * sizeof (DCHAR_T)); - if (tmp != tmpbuf) - free (tmp); - length += count; - } + /* Append the result. */ + memcpy (result + length, tmp, count * sizeof (DCHAR_T)); + if (tmp != tmpbuf) + free (tmp); + length += count; } #endif else { arg_type type = a.arg[dp->arg_index].type; int flags = dp->flags; -#if !USE_SNPRINTF || !HAVE_SNPRINTF_RETVAL_C99 || !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_LEFTADJUST || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION +#if !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_LEFTADJUST || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION int has_width; +#endif +#if !USE_SNPRINTF || !HAVE_SNPRINTF_RETVAL_C99 || !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_LEFTADJUST || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION size_t width; #endif #if !USE_SNPRINTF || !HAVE_SNPRINTF_RETVAL_C99 || NEED_PRINTF_UNBOUNDED_PRECISION @@ -4635,8 +4620,10 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, TCHAR_T *tmp; #endif -#if !USE_SNPRINTF || !HAVE_SNPRINTF_RETVAL_C99 || !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_LEFTADJUST || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION +#if !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_LEFTADJUST || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION has_width = 0; +#endif +#if !USE_SNPRINTF || !HAVE_SNPRINTF_RETVAL_C99 || !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_LEFTADJUST || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION width = 0; if (dp->width_start != dp->width_end) { @@ -4647,15 +4634,14 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, if (!(a.arg[dp->width_arg_index].type == TYPE_INT)) abort (); arg = a.arg[dp->width_arg_index].a.a_int; + width = arg; if (arg < 0) { /* "A negative field width is taken as a '-' flag followed by a positive field width." */ flags |= FLAG_LEFT; - width = (unsigned int) (-arg); + width = -width; } - else - width = arg; } else { @@ -4665,7 +4651,9 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, width = xsum (xtimes (width, 10), *digitp++ - '0'); while (digitp != dp->width_end); } +#if !DCHAR_IS_TCHAR || ENABLE_UNISTDIO || NEED_PRINTF_FLAG_LEFTADJUST || NEED_PRINTF_FLAG_ZERO || NEED_PRINTF_UNBOUNDED_PRECISION has_width = 1; +#endif } #endif @@ -4805,7 +4793,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, { const FCHAR_T *mp = dp->width_start; do - *fbp++ = (unsigned char) *mp++; + *fbp++ = *mp++; while (--n > 0); } } @@ -4826,7 +4814,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, { const FCHAR_T *mp = dp->precision_start; do - *fbp++ = (unsigned char) *mp++; + *fbp++ = *mp++; while (--n > 0); } } @@ -5153,7 +5141,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, size_t tmp_length = MAX_ROOM_NEEDED (&a, dp->arg_index, dp->conversion, type, flags, - has_width ? width : 0, + width, has_precision, precision, pad_ourselves); @@ -5191,18 +5179,21 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, /* SNPRINTF or sprintf failed. Save and use the errno that it has set, if any. */ int saved_errno = errno; + if (saved_errno == 0) + { + if (dp->conversion == 'c' || dp->conversion == 's') + saved_errno = EILSEQ; + else + saved_errno = EINVAL; + } if (!(result == resultbuf || result == NULL)) free (result); if (buf_malloced != NULL) free (buf_malloced); CLEANUP (); - errno = - (saved_errno != 0 - ? saved_errno - : (dp->conversion == 'c' || dp->conversion == 's' - ? EILSEQ - : EINVAL)); + + errno = saved_errno; return NULL; } @@ -5391,7 +5382,7 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, tmpsrc += count; tmpdst += count; for (n = count; n > 0; n--) - *--tmpdst = (unsigned char) *--tmpsrc; + *--tmpdst = *--tmpsrc; } } #endif diff --git a/lib/vasnprintf.h b/lib/vasnprintf.h index a3f48e828..47216c4c0 100644 --- a/lib/vasnprintf.h +++ b/lib/vasnprintf.h @@ -1,5 +1,5 @@ /* vsprintf with automatic memory allocation. - Copyright (C) 2002-2004, 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2002-2004, 2007-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/verify.h b/lib/verify.h index 78d543f04..356c7fa0d 100644 --- a/lib/verify.h +++ b/lib/verify.h @@ -1,6 +1,6 @@ /* Compile-time assert-like macros. - Copyright (C) 2005-2006, 2009-2014 Free Software Foundation, Inc. + Copyright (C) 2005-2006, 2009-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -263,7 +263,7 @@ template # define assume(R) ((R) ? (void) 0 : __builtin_unreachable ()) #elif 1200 <= _MSC_VER # define assume(R) __assume (R) -#elif (defined lint \ +#elif ((defined GCC_LINT || defined lint) \ && (__has_builtin (__builtin_trap) \ || 3 < __GNUC__ + (3 < __GNUC_MINOR__ + (4 <= __GNUC_PATCHLEVEL__)))) /* Doing it this way helps various packages when configured with diff --git a/lib/vsnprintf.c b/lib/vsnprintf.c index 26b1887b0..af0517401 100644 --- a/lib/vsnprintf.c +++ b/lib/vsnprintf.c @@ -1,5 +1,5 @@ /* Formatted output to strings. - Copyright (C) 2004, 2006-2014 Free Software Foundation, Inc. + Copyright (C) 2004, 2006-2016 Free Software Foundation, Inc. Written by Simon Josefsson and Yoann Vandoorselaere . This program is free software; you can redistribute it and/or modify diff --git a/lib/w32sock.h b/lib/w32sock.h index 3946d4945..f9506b71e 100644 --- a/lib/w32sock.h +++ b/lib/w32sock.h @@ -1,6 +1,6 @@ /* w32sock.h --- internal auxiliary functions for Windows socket functions - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/wchar.in.h b/lib/wchar.in.h index 1874b4d7e..7d1aa162b 100644 --- a/lib/wchar.in.h +++ b/lib/wchar.in.h @@ -1,6 +1,6 @@ /* A substitute for ISO C99 , for platforms that have issues. - Copyright (C) 2007-2014 Free Software Foundation, Inc. + Copyright (C) 2007-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -30,9 +30,14 @@ #endif @PRAGMA_COLUMNS@ -#if defined __need_mbstate_t || defined __need_wint_t || (defined __hpux && ((defined _INTTYPES_INCLUDED && !defined strtoimax) || defined _GL_JUST_INCLUDE_SYSTEM_WCHAR_H)) || defined _GL_ALREADY_INCLUDING_WCHAR_H +#if (((defined __need_mbstate_t || defined __need_wint_t) \ + && !defined __MINGW32__ && !defined __KLIBC__) \ + || (defined __hpux \ + && ((defined _INTTYPES_INCLUDED && !defined strtoimax) \ + || defined _GL_JUST_INCLUDE_SYSTEM_WCHAR_H)) \ + || defined _GL_ALREADY_INCLUDING_WCHAR_H) /* Special invocation convention: - - Inside glibc and uClibc header files. + - Inside glibc and uClibc header files, but not MinGW. - On HP-UX 11.00 we have a sequence of nested includes -> -> , and the latter includes , once indirectly -> -> -> @@ -440,6 +445,11 @@ _GL_CXXALIAS_RPL (wcwidth, int, (wchar_t)); # if !@HAVE_DECL_WCWIDTH@ /* wcwidth exists but is not declared. */ _GL_FUNCDECL_SYS (wcwidth, int, (wchar_t) _GL_ATTRIBUTE_PURE); +# elif defined __KLIBC__ +/* On OS/2 kLIBC, wcwidth is a macro that expands to the name of a + static inline function. The implementation of wcwidth in wcwidth.c + causes a "conflicting types" error. */ +# undef wcwidth # endif _GL_CXXALIAS_SYS (wcwidth, int, (wchar_t)); # endif diff --git a/lib/wcrtomb.c b/lib/wcrtomb.c index ebbdddccc..d6cc58a14 100644 --- a/lib/wcrtomb.c +++ b/lib/wcrtomb.c @@ -1,5 +1,5 @@ /* Convert wide character to multibyte character. - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2008. This program is free software: you can redistribute it and/or modify diff --git a/lib/wctype.in.h b/lib/wctype.in.h index b5b6093d7..3d889f0fc 100644 --- a/lib/wctype.in.h +++ b/lib/wctype.in.h @@ -1,6 +1,6 @@ /* A substitute for ISO C99 , for platforms that lack it. - Copyright (C) 2006-2014 Free Software Foundation, Inc. + Copyright (C) 2006-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/write.c b/lib/write.c index 51cc1d91e..e3cd35a36 100644 --- a/lib/write.c +++ b/lib/write.c @@ -1,5 +1,5 @@ /* POSIX compatible write() function. - Copyright (C) 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2008-2016 Free Software Foundation, Inc. Written by Bruno Haible , 2008. This program is free software: you can redistribute it and/or modify diff --git a/lib/xsize.h b/lib/xsize.h index 83cb960b5..840d6829f 100644 --- a/lib/xsize.h +++ b/lib/xsize.h @@ -1,6 +1,6 @@ /* xsize.h -- Checked size_t computations. - Copyright (C) 2003, 2008-2014 Free Software Foundation, Inc. + Copyright (C) 2003, 2008-2016 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/m4/00gnulib.m4 b/m4/00gnulib.m4 index 8eca5518a..bb37e32aa 100644 --- a/m4/00gnulib.m4 +++ b/m4/00gnulib.m4 @@ -1,5 +1,5 @@ # 00gnulib.m4 serial 3 -dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/absolute-header.m4 b/m4/absolute-header.m4 index ce3e39e9b..7ffc38d7a 100644 --- a/m4/absolute-header.m4 +++ b/m4/absolute-header.m4 @@ -1,5 +1,5 @@ # absolute-header.m4 serial 16 -dnl Copyright (C) 2006-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/alloca.m4 b/m4/alloca.m4 index d7bdea631..2382ff1ee 100644 --- a/m4/alloca.m4 +++ b/m4/alloca.m4 @@ -1,5 +1,5 @@ # alloca.m4 serial 14 -dnl Copyright (C) 2002-2004, 2006-2007, 2009-2014 Free Software Foundation, +dnl Copyright (C) 2002-2004, 2006-2007, 2009-2016 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/arpa_inet_h.m4 b/m4/arpa_inet_h.m4 index f01699a9d..5387f2840 100644 --- a/m4/arpa_inet_h.m4 +++ b/m4/arpa_inet_h.m4 @@ -1,5 +1,5 @@ # arpa_inet_h.m4 serial 13 -dnl Copyright (C) 2006, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/autobuild.m4 b/m4/autobuild.m4 index 00d870930..66b183b23 100644 --- a/m4/autobuild.m4 +++ b/m4/autobuild.m4 @@ -1,5 +1,5 @@ # autobuild.m4 serial 7 -dnl Copyright (C) 2004, 2006-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2004, 2006-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/btowc.m4 b/m4/btowc.m4 index 99889445f..47e8fd8a1 100644 --- a/m4/btowc.m4 +++ b/m4/btowc.m4 @@ -1,5 +1,5 @@ # btowc.m4 serial 10 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/byteswap.m4 b/m4/byteswap.m4 index 6d6357cbe..27f0fd69d 100644 --- a/m4/byteswap.m4 +++ b/m4/byteswap.m4 @@ -1,5 +1,5 @@ # byteswap.m4 serial 4 -dnl Copyright (C) 2005, 2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2005, 2007, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/canonicalize.m4 b/m4/canonicalize.m4 index ace455661..cbbf3e267 100644 --- a/m4/canonicalize.m4 +++ b/m4/canonicalize.m4 @@ -1,6 +1,6 @@ -# canonicalize.m4 serial 26 +# canonicalize.m4 serial 28 -dnl Copyright (C) 2003-2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2003-2007, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -83,22 +83,27 @@ AC_DEFUN([gl_FUNC_REALPATH_WORKS], char *name = realpath ("conftest.a", NULL); if (!(name && *name == '/')) result |= 1; + free (name); } { char *name = realpath ("conftest.b/../conftest.a", NULL); if (name != NULL) result |= 2; + free (name); } { char *name = realpath ("conftest.a/", NULL); if (name != NULL) result |= 4; + free (name); } { char *name1 = realpath (".", NULL); char *name2 = realpath ("conftest.d//./..", NULL); - if (strcmp (name1, name2) != 0) + if (! name1 || ! name2 || strcmp (name1, name2)) result |= 8; + free (name1); + free (name2); } return result; ]]) diff --git a/m4/ceil.m4 b/m4/ceil.m4 index 128353ae7..214e5657a 100644 --- a/m4/ceil.m4 +++ b/m4/ceil.m4 @@ -1,5 +1,5 @@ # ceil.m4 serial 9 -dnl Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/check-math-lib.m4 b/m4/check-math-lib.m4 index a3894aa64..58af05100 100644 --- a/m4/check-math-lib.m4 +++ b/m4/check-math-lib.m4 @@ -1,5 +1,5 @@ # check-math-lib.m4 serial 4 -dnl Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/clock_time.m4 b/m4/clock_time.m4 index be36a42b8..beace12c7 100644 --- a/m4/clock_time.m4 +++ b/m4/clock_time.m4 @@ -1,5 +1,5 @@ # clock_time.m4 serial 10 -dnl Copyright (C) 2002-2006, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2006, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/close.m4 b/m4/close.m4 index 68510c5c5..310f076be 100644 --- a/m4/close.m4 +++ b/m4/close.m4 @@ -1,5 +1,5 @@ # close.m4 serial 8 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/codeset.m4 b/m4/codeset.m4 index d7de8d67e..bc98201e3 100644 --- a/m4/codeset.m4 +++ b/m4/codeset.m4 @@ -1,5 +1,6 @@ # codeset.m4 serial 5 (gettext-0.18.2) -dnl Copyright (C) 2000-2002, 2006, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2000-2002, 2006, 2008-2014, 2016 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/configmake.m4 b/m4/configmake.m4 index 0cd86cf99..80b92548c 100644 --- a/m4/configmake.m4 +++ b/m4/configmake.m4 @@ -1,5 +1,5 @@ # configmake.m4 serial 2 -dnl Copyright (C) 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/copysign.m4 b/m4/copysign.m4 index 1bb2d6fb9..fd1f7be4b 100644 --- a/m4/copysign.m4 +++ b/m4/copysign.m4 @@ -1,5 +1,5 @@ # copysign.m4 serial 1 -dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/dirent_h.m4 b/m4/dirent_h.m4 index 3f2b16b12..68836a406 100644 --- a/m4/dirent_h.m4 +++ b/m4/dirent_h.m4 @@ -1,5 +1,5 @@ # dirent_h.m4 serial 16 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/dirfd.m4 b/m4/dirfd.m4 index b42276948..1d7cb080d 100644 --- a/m4/dirfd.m4 +++ b/m4/dirfd.m4 @@ -1,8 +1,8 @@ -# serial 22 -*- Autoconf -*- +# serial 24 -*- Autoconf -*- dnl Find out how to get the file descriptor associated with an open DIR*. -# Copyright (C) 2001-2006, 2008-2014 Free Software Foundation, Inc. +# Copyright (C) 2001-2006, 2008-2016 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. @@ -35,13 +35,15 @@ AC_DEFUN([gl_FUNC_DIRFD], gl_cv_func_dirfd_macro=yes, gl_cv_func_dirfd_macro=no)]) - # Use the replacement only if we have no function or macro with that name. - if test $ac_cv_func_dirfd = no && test $gl_cv_func_dirfd_macro = no; then - if test $ac_cv_have_decl_dirfd = yes; then - # If the system declares dirfd already, let's declare rpl_dirfd instead. + # Use the replacement if we have no function or macro with that name, + # or if OS/2 kLIBC whose dirfd() does not work. + # Replace only if the system declares dirfd already. + case $ac_cv_func_dirfd,$gl_cv_func_dirfd_macro,$host_os,$ac_cv_have_decl_dirfd in + no,no,*,yes | *,*,os2*,yes) REPLACE_DIRFD=1 - fi - fi + AC_DEFINE([REPLACE_DIRFD], [1], + [Define to 1 if gnulib's dirfd() replacement is used.]);; + esac ]) dnl Prerequisites of lib/dirfd.c. diff --git a/m4/dirname.m4 b/m4/dirname.m4 index d2627b8a8..6f8bec32c 100644 --- a/m4/dirname.m4 +++ b/m4/dirname.m4 @@ -1,5 +1,5 @@ #serial 10 -*- autoconf -*- -dnl Copyright (C) 2002-2006, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2006, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/double-slash-root.m4 b/m4/double-slash-root.m4 index 937f4bca9..dfd3921d1 100644 --- a/m4/double-slash-root.m4 +++ b/m4/double-slash-root.m4 @@ -1,5 +1,5 @@ # double-slash-root.m4 serial 4 -*- Autoconf -*- -dnl Copyright (C) 2006, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/dup2.m4 b/m4/dup2.m4 index 89638a0bf..5b68312b1 100644 --- a/m4/dup2.m4 +++ b/m4/dup2.m4 @@ -1,5 +1,5 @@ -#serial 20 -dnl Copyright (C) 2002, 2005, 2007, 2009-2014 Free Software Foundation, Inc. +#serial 25 +dnl Copyright (C) 2002, 2005, 2007, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -19,33 +19,60 @@ AC_DEFUN([gl_FUNC_DUP2], if test $HAVE_DUP2 = 1; then AC_CACHE_CHECK([whether dup2 works], [gl_cv_func_dup2_works], [AC_RUN_IFELSE([ - AC_LANG_PROGRAM([[#include -#include -#include ]], - [int result = 0; -#ifdef FD_CLOEXEC - if (fcntl (1, F_SETFD, FD_CLOEXEC) == -1) - result |= 1; -#endif - if (dup2 (1, 1) == 0) - result |= 2; -#ifdef FD_CLOEXEC - if (fcntl (1, F_GETFD) != FD_CLOEXEC) - result |= 4; -#endif - close (0); - if (dup2 (0, 0) != -1) - result |= 8; - /* Many gnulib modules require POSIX conformance of EBADF. */ - if (dup2 (2, 1000000) == -1 && errno != EBADF) - result |= 16; - /* Flush out some cygwin core dumps. */ - if (dup2 (2, -1) != -1 || errno != EBADF) - result |= 32; - dup2 (2, 255); - dup2 (2, 256); - return result; - ]) + AC_LANG_PROGRAM( + [[#include + #include + #include + #include + #include + #ifndef RLIM_SAVED_CUR + # define RLIM_SAVED_CUR RLIM_INFINITY + #endif + #ifndef RLIM_SAVED_MAX + # define RLIM_SAVED_MAX RLIM_INFINITY + #endif + ]], + [[int result = 0; + int bad_fd = INT_MAX; + struct rlimit rlim; + if (getrlimit (RLIMIT_NOFILE, &rlim) == 0 + && 0 <= rlim.rlim_cur && rlim.rlim_cur <= INT_MAX + && rlim.rlim_cur != RLIM_INFINITY + && rlim.rlim_cur != RLIM_SAVED_MAX + && rlim.rlim_cur != RLIM_SAVED_CUR) + bad_fd = rlim.rlim_cur; + #ifdef FD_CLOEXEC + if (fcntl (1, F_SETFD, FD_CLOEXEC) == -1) + result |= 1; + #endif + if (dup2 (1, 1) != 1) + result |= 2; + #ifdef FD_CLOEXEC + if (fcntl (1, F_GETFD) != FD_CLOEXEC) + result |= 4; + #endif + close (0); + if (dup2 (0, 0) != -1) + result |= 8; + /* Many gnulib modules require POSIX conformance of EBADF. */ + if (dup2 (2, bad_fd) == -1 && errno != EBADF) + result |= 16; + /* Flush out some cygwin core dumps. */ + if (dup2 (2, -1) != -1 || errno != EBADF) + result |= 32; + dup2 (2, 255); + dup2 (2, 256); + /* On OS/2 kLIBC, dup2() does not work on a directory fd. */ + { + int fd = open (".", O_RDONLY); + if (fd == -1) + result |= 64; + else if (dup2 (fd, fd + 1) == -1) + result |= 128; + + close (fd); + } + return result;]]) ], [gl_cv_func_dup2_works=yes], [gl_cv_func_dup2_works=no], [case "$host_os" in @@ -53,13 +80,16 @@ AC_DEFUN([gl_FUNC_DUP2], gl_cv_func_dup2_works="guessing no" ;; cygwin*) # on cygwin 1.5.x, dup2(1,1) returns 0 gl_cv_func_dup2_works="guessing no" ;; - linux*) # On linux between 2008-07-27 and 2009-05-11, dup2 of a - # closed fd may yield -EBADF instead of -1 / errno=EBADF. - gl_cv_func_dup2_works="guessing no" ;; - freebsd*) # on FreeBSD 6.1, dup2(1,1000000) gives EMFILE, not EBADF. + aix* | freebsd*) + # on AIX 7.1 and FreeBSD 6.1, dup2 (1,toobig) gives EMFILE, + # not EBADF. gl_cv_func_dup2_works="guessing no" ;; haiku*) # on Haiku alpha 2, dup2(1, 1) resets FD_CLOEXEC. gl_cv_func_dup2_works="guessing no" ;; + *-android*) # implemented using dup3(), which fails if oldfd == newfd + gl_cv_func_dup2_works="guessing no" ;; + os2*) # on OS/2 kLIBC, dup2() does not work on a directory fd. + gl_cv_func_dup2_works="guessing no" ;; *) gl_cv_func_dup2_works="guessing yes" ;; esac]) ]) diff --git a/m4/duplocale.m4 b/m4/duplocale.m4 index d45891d4f..fcf9d3980 100644 --- a/m4/duplocale.m4 +++ b/m4/duplocale.m4 @@ -1,5 +1,5 @@ -# duplocale.m4 serial 7 -dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. +# duplocale.m4 serial 8 +dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -25,8 +25,10 @@ AC_DEFUN([gl_FUNC_DUPLOCALE], #endif int main () { - if (duplocale (LC_GLOBAL_LOCALE) == (locale_t)0) + locale_t loc = duplocale (LC_GLOBAL_LOCALE); + if (!loc) return 1; + freelocale (loc); return 0; }]])], [gl_cv_func_duplocale_works=yes], diff --git a/m4/eealloc.m4 b/m4/eealloc.m4 index 8a51fe7c5..63d74defe 100644 --- a/m4/eealloc.m4 +++ b/m4/eealloc.m4 @@ -1,5 +1,5 @@ # eealloc.m4 serial 3 -dnl Copyright (C) 2003, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/environ.m4 b/m4/environ.m4 index cfabe46f5..9a0ea7e21 100644 --- a/m4/environ.m4 +++ b/m4/environ.m4 @@ -1,5 +1,5 @@ # environ.m4 serial 6 -dnl Copyright (C) 2001-2004, 2006-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2004, 2006-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/errno_h.m4 b/m4/errno_h.m4 index 4ee9e6a14..b111fce05 100644 --- a/m4/errno_h.m4 +++ b/m4/errno_h.m4 @@ -1,5 +1,5 @@ # errno_h.m4 serial 12 -dnl Copyright (C) 2004, 2006, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2004, 2006, 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/exponentd.m4 b/m4/exponentd.m4 index 7bee63571..7869a7d6c 100644 --- a/m4/exponentd.m4 +++ b/m4/exponentd.m4 @@ -1,5 +1,5 @@ # exponentd.m4 serial 3 -dnl Copyright (C) 2007-2008, 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2008, 2010-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/exponentf.m4 b/m4/exponentf.m4 index b2dfeef96..d4298f299 100644 --- a/m4/exponentf.m4 +++ b/m4/exponentf.m4 @@ -1,5 +1,5 @@ # exponentf.m4 serial 2 -dnl Copyright (C) 2007-2008, 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2008, 2010-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/exponentl.m4 b/m4/exponentl.m4 index d6f4ba7ff..c49cf2c3e 100644 --- a/m4/exponentl.m4 +++ b/m4/exponentl.m4 @@ -1,5 +1,5 @@ # exponentl.m4 serial 3 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/extensions.m4 b/m4/extensions.m4 index 37f55ca3d..6d378ec41 100644 --- a/m4/extensions.m4 +++ b/m4/extensions.m4 @@ -1,7 +1,7 @@ # serial 13 -*- Autoconf -*- # Enable extensions on systems that normally disable them. -# Copyright (C) 2003, 2006-2014 Free Software Foundation, Inc. +# Copyright (C) 2003, 2006-2016 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. @@ -68,6 +68,10 @@ dnl configure.ac when using autoheader 2.62. #ifndef _GNU_SOURCE # undef _GNU_SOURCE #endif +/* Use GNU style printf and scanf. */ +#ifndef __USE_MINGW_ANSI_STDIO +# undef __USE_MINGW_ANSI_STDIO +#endif /* Enable threading extensions on Solaris. */ #ifndef _POSIX_PTHREAD_SEMANTICS # undef _POSIX_PTHREAD_SEMANTICS @@ -100,6 +104,7 @@ dnl configure.ac when using autoheader 2.62. AC_DEFINE([_ALL_SOURCE]) AC_DEFINE([_DARWIN_C_SOURCE]) AC_DEFINE([_GNU_SOURCE]) + AC_DEFINE([__USE_MINGW_ANSI_STDIO]) AC_DEFINE([_POSIX_PTHREAD_SEMANTICS]) AC_DEFINE([_TANDEM_SOURCE]) AC_CACHE_CHECK([whether _XOPEN_SOURCE should be defined], diff --git a/m4/extern-inline.m4 b/m4/extern-inline.m4 index 240150efb..1e578f3de 100644 --- a/m4/extern-inline.m4 +++ b/m4/extern-inline.m4 @@ -1,6 +1,6 @@ dnl 'extern inline' a la ISO C99. -dnl Copyright 2012-2014 Free Software Foundation, Inc. +dnl Copyright 2012-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -19,13 +19,28 @@ AC_DEFUN([gl_EXTERN_INLINE], 'reference to static identifier "f" in extern inline function'. This bug was observed with Sun C 5.12 SunOS_i386 2011/11/16. - Suppress the use of extern inline on problematic Apple configurations. - OS X 10.8 and earlier mishandle it; see, e.g., - . + Suppress extern inline (with or without __attribute__ ((__gnu_inline__))) + on configurations that mistakenly use 'static inline' to implement + functions or macros in standard C headers like . For example, + if isdigit is mistakenly implemented via a static inline function, + a program containing an extern inline function that calls isdigit + may not work since the C standard prohibits extern inline functions + from calling static functions. This bug is known to occur on: + + OS X 10.8 and earlier; see: + http://lists.gnu.org/archive/html/bug-gnulib/2012-12/msg00023.html + + DragonFly; see + http://muscles.dragonflybsd.org/bulk/bleeding-edge-potential/latest-per-pkg/ah-tty-0.3.12.log + + FreeBSD; see: + http://lists.gnu.org/archive/html/bug-gnulib/2014-07/msg00104.html + OS X 10.9 has a macro __header_inline indicating the bug is fixed for C and for clang but remains for g++; see . - Perhaps Apple will fix this some day. */ -#if (defined __APPLE__ \ + Assume DragonFly and FreeBSD will be similar. */ +#if (((defined __APPLE__ && defined __MACH__) \ + || defined __DragonFly__ || defined __FreeBSD__) \ && (defined __header_inline \ ? (defined __cplusplus && defined __GNUC_STDC_INLINE__ \ && ! defined __clang__) \ @@ -33,19 +48,20 @@ AC_DEFUN([gl_EXTERN_INLINE], && (defined __GNUC__ || defined __cplusplus)) \ || (defined _FORTIFY_SOURCE && 0 < _FORTIFY_SOURCE \ && defined __GNUC__ && ! defined __cplusplus)))) -# define _GL_EXTERN_INLINE_APPLE_BUG +# define _GL_EXTERN_INLINE_STDHEADER_BUG #endif #if ((__GNUC__ \ ? defined __GNUC_STDC_INLINE__ && __GNUC_STDC_INLINE__ \ : (199901L <= __STDC_VERSION__ \ && !defined __HP_cc \ + && !defined __PGI \ && !(defined __SUNPRO_C && __STDC__))) \ - && !defined _GL_EXTERN_INLINE_APPLE_BUG) + && !defined _GL_EXTERN_INLINE_STDHEADER_BUG) # define _GL_INLINE inline # define _GL_EXTERN_INLINE extern inline # define _GL_EXTERN_INLINE_IN_USE #elif (2 < __GNUC__ + (7 <= __GNUC_MINOR__) && !defined __STRICT_ANSI__ \ - && !defined _GL_EXTERN_INLINE_APPLE_BUG) + && !defined _GL_EXTERN_INLINE_STDHEADER_BUG) # if defined __GNUC_GNU_INLINE__ && __GNUC_GNU_INLINE__ /* __gnu_inline__ suppresses a GCC 4.2 diagnostic. */ # define _GL_INLINE extern inline __attribute__ ((__gnu_inline__)) @@ -59,17 +75,19 @@ AC_DEFUN([gl_EXTERN_INLINE], # define _GL_EXTERN_INLINE static _GL_UNUSED #endif -#if 4 < __GNUC__ + (6 <= __GNUC_MINOR__) +/* In GCC 4.6 (inclusive) to 5.1 (exclusive), + suppress bogus "no previous prototype for 'FOO'" + and "no previous declaration for 'FOO'" diagnostics, + when FOO is an inline function in the header; see + and + . */ +#if __GNUC__ == 4 && 6 <= __GNUC_MINOR__ # if defined __GNUC_STDC_INLINE__ && __GNUC_STDC_INLINE__ # define _GL_INLINE_HEADER_CONST_PRAGMA # else # define _GL_INLINE_HEADER_CONST_PRAGMA \ _Pragma ("GCC diagnostic ignored \"-Wsuggest-attribute=const\"") # endif - /* Suppress GCC's bogus "no previous prototype for 'FOO'" - and "no previous declaration for 'FOO'" diagnostics, - when FOO is an inline function in the header; see - . */ # define _GL_INLINE_HEADER_BEGIN \ _Pragma ("GCC diagnostic push") \ _Pragma ("GCC diagnostic ignored \"-Wmissing-prototypes\"") \ diff --git a/m4/fcntl-o.m4 b/m4/fcntl-o.m4 index 43c93124e..24fcf88d0 100644 --- a/m4/fcntl-o.m4 +++ b/m4/fcntl-o.m4 @@ -1,5 +1,5 @@ # fcntl-o.m4 serial 4 -dnl Copyright (C) 2006, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/fcntl_h.m4 b/m4/fcntl_h.m4 index fb2556d37..ef0d78dde 100644 --- a/m4/fcntl_h.m4 +++ b/m4/fcntl_h.m4 @@ -1,6 +1,6 @@ # serial 15 # Configure fcntl.h. -dnl Copyright (C) 2006-2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2007, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/flexmember.m4 b/m4/flexmember.m4 new file mode 100644 index 000000000..baa9ff8fb --- /dev/null +++ b/m4/flexmember.m4 @@ -0,0 +1,41 @@ +# serial 3 +# Check for flexible array member support. + +# Copyright (C) 2006, 2009-2016 Free Software Foundation, Inc. +# This file is free software; the Free Software Foundation +# gives unlimited permission to copy and/or distribute it, +# with or without modifications, as long as this notice is preserved. + +# Written by Paul Eggert. + +AC_DEFUN([AC_C_FLEXIBLE_ARRAY_MEMBER], +[ + AC_CACHE_CHECK([for flexible array member], + ac_cv_c_flexmember, + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM( + [[#include + #include + #include + struct s { int n; double d[]; };]], + [[int m = getchar (); + struct s *p = malloc (offsetof (struct s, d) + + m * sizeof (double)); + p->d[0] = 0.0; + return p->d != (double *) NULL;]])], + [ac_cv_c_flexmember=yes], + [ac_cv_c_flexmember=no])]) + if test $ac_cv_c_flexmember = yes; then + AC_DEFINE([FLEXIBLE_ARRAY_MEMBER], [], + [Define to nothing if C supports flexible array members, and to + 1 if it does not. That way, with a declaration like 'struct s + { int n; double d@<:@FLEXIBLE_ARRAY_MEMBER@:>@; };', the struct hack + can be used with pre-C99 compilers. + When computing the size of such an object, don't use 'sizeof (struct s)' + as it overestimates the size. Use 'offsetof (struct s, d)' instead. + Don't use 'offsetof (struct s, d@<:@0@:>@)', as this doesn't work with + MSVC and with C++ compilers.]) + else + AC_DEFINE([FLEXIBLE_ARRAY_MEMBER], [1]) + fi +]) diff --git a/m4/float_h.m4 b/m4/float_h.m4 index a27ef7f97..e2887eb5c 100644 --- a/m4/float_h.m4 +++ b/m4/float_h.m4 @@ -1,5 +1,5 @@ # float_h.m4 serial 9 -dnl Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/flock.m4 b/m4/flock.m4 index ad2d1290c..01b38b7d5 100644 --- a/m4/flock.m4 +++ b/m4/flock.m4 @@ -1,5 +1,5 @@ # flock.m4 serial 3 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/floor.m4 b/m4/floor.m4 index a38c03d14..cd895054f 100644 --- a/m4/floor.m4 +++ b/m4/floor.m4 @@ -1,5 +1,5 @@ # floor.m4 serial 8 -dnl Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/fpieee.m4 b/m4/fpieee.m4 index 729afe859..e11ac9f09 100644 --- a/m4/fpieee.m4 +++ b/m4/fpieee.m4 @@ -1,5 +1,5 @@ -# fpieee.m4 serial 2 -dnl Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. +# fpieee.m4 serial 2 -*- coding: utf-8 -*- +dnl Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/frexp.m4 b/m4/frexp.m4 index 579826213..23f582167 100644 --- a/m4/frexp.m4 +++ b/m4/frexp.m4 @@ -1,5 +1,5 @@ # frexp.m4 serial 15 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/fstat.m4 b/m4/fstat.m4 index ddd3fb976..29f9b8165 100644 --- a/m4/fstat.m4 +++ b/m4/fstat.m4 @@ -1,5 +1,5 @@ # fstat.m4 serial 4 -dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/fsync.m4 b/m4/fsync.m4 index 888a65def..405d43d6d 100644 --- a/m4/fsync.m4 +++ b/m4/fsync.m4 @@ -1,5 +1,5 @@ # fsync.m4 serial 2 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/func.m4 b/m4/func.m4 index 0ab14c9e4..f537b157d 100644 --- a/m4/func.m4 +++ b/m4/func.m4 @@ -1,5 +1,5 @@ # func.m4 serial 2 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/getaddrinfo.m4 b/m4/getaddrinfo.m4 index 2e6658486..2af1e0136 100644 --- a/m4/getaddrinfo.m4 +++ b/m4/getaddrinfo.m4 @@ -1,5 +1,5 @@ # getaddrinfo.m4 serial 30 -dnl Copyright (C) 2004-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2004-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/getlogin.m4 b/m4/getlogin.m4 index 47b8f0897..b3b2655db 100644 --- a/m4/getlogin.m4 +++ b/m4/getlogin.m4 @@ -1,5 +1,5 @@ # getlogin.m4 serial 3 -dnl Copyright (C) 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/gettimeofday.m4 b/m4/gettimeofday.m4 index 1c2d66ee2..4ae5d63fe 100644 --- a/m4/gettimeofday.m4 +++ b/m4/gettimeofday.m4 @@ -1,6 +1,6 @@ # serial 21 -# Copyright (C) 2001-2003, 2005, 2007, 2009-2014 Free Software Foundation, Inc. +# Copyright (C) 2001-2003, 2005, 2007, 2009-2016 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/glibc21.m4 b/m4/glibc21.m4 index ab58b7121..dafebf501 100644 --- a/m4/glibc21.m4 +++ b/m4/glibc21.m4 @@ -1,5 +1,5 @@ # glibc21.m4 serial 5 -dnl Copyright (C) 2000-2002, 2004, 2008, 2010-2014 Free Software Foundation, +dnl Copyright (C) 2000-2002, 2004, 2008, 2010-2016 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index 26c96b3e3..917e7ffbe 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -1,4 +1,4 @@ -# Copyright (C) 2002-2014 Free Software Foundation, Inc. +# Copyright (C) 2002-2016 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -27,7 +27,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --dir=. --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --lgpl=3 --no-conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkstemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar +# gnulib-tool --import --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --lgpl=3 --conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkstemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([gnulib-local]) @@ -76,7 +76,6 @@ gl_MODULES([ isfinite isinf isnan - largefile ldexp lib-symbol-versions lib-symbol-visibility @@ -127,7 +126,7 @@ gl_MODULES([ warnings wchar ]) -gl_AVOID([lock]) +gl_AVOID([ lock]) gl_SOURCE_BASE([lib]) gl_M4_BASE([m4]) gl_PO_BASE([]) @@ -136,6 +135,7 @@ gl_TESTS_BASE([tests]) gl_LIB([libgnu]) gl_LGPL([3]) gl_MAKEFILE_NAME([]) +gl_CONDITIONAL_DEPENDENCIES gl_LIBTOOL gl_MACRO_PREFIX([gl]) gl_PO_DOMAIN([]) diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4 index 20ce40e74..f8454c8a0 100644 --- a/m4/gnulib-common.m4 +++ b/m4/gnulib-common.m4 @@ -1,5 +1,5 @@ -# gnulib-common.m4 serial 34 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +# gnulib-common.m4 serial 36 +dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -49,6 +49,16 @@ AC_DEFUN([gl_COMMON_BODY], [ is a misnomer outside of parameter lists. */ #define _UNUSED_PARAMETER_ _GL_UNUSED +/* gcc supports the "unused" attribute on possibly unused labels, and + g++ has since version 4.5. Note to support C++ as well as C, + _GL_UNUSED_LABEL should be used with a trailing ; */ +#if !defined __cplusplus || __GNUC__ > 4 \ + || (__GNUC__ == 4 && __GNUC_MINOR__ >= 5) +# define _GL_UNUSED_LABEL _GL_UNUSED +#else +# define _GL_UNUSED_LABEL +#endif + /* The __pure__ attribute was added in gcc 2.96. */ #if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 96) # define _GL_ATTRIBUTE_PURE __attribute__ ((__pure__)) @@ -243,9 +253,10 @@ AC_DEFUN([gl_PROG_AR_RANLIB], [ dnl Minix 3 comes with two toolchains: The Amsterdam Compiler Kit compiler dnl as "cc", and GCC as "gcc". They have different object file formats and - dnl library formats. In particular, the GNU binutils programs ar, ranlib + dnl library formats. In particular, the GNU binutils programs ar and ranlib dnl produce libraries that work only with gcc, not with cc. AC_REQUIRE([AC_PROG_CC]) + AC_BEFORE([$0], [AM_PROG_AR]) AC_CACHE_CHECK([for Minix Amsterdam compiler], [gl_cv_c_amsterdam_compiler], [ AC_EGREP_CPP([Amsterdam], @@ -257,25 +268,37 @@ Amsterdam [gl_cv_c_amsterdam_compiler=yes], [gl_cv_c_amsterdam_compiler=no]) ]) - if test -z "$AR"; then - if test $gl_cv_c_amsterdam_compiler = yes; then + + dnl Don't compete with AM_PROG_AR's decision about AR/ARFLAGS if we are not + dnl building with __ACK__. + if test $gl_cv_c_amsterdam_compiler = yes; then + if test -z "$AR"; then AR='cc -c.a' - if test -z "$ARFLAGS"; then - ARFLAGS='-o' - fi - else - dnl Use the Automake-documented default values for AR and ARFLAGS, - dnl but prefer ${host}-ar over ar (useful for cross-compiling). - AC_CHECK_TOOL([AR], [ar], [ar]) - if test -z "$ARFLAGS"; then - ARFLAGS='cru' - fi + fi + if test -z "$ARFLAGS"; then + ARFLAGS='-o' fi else - if test -z "$ARFLAGS"; then - ARFLAGS='cru' - fi + dnl AM_PROG_AR was added in automake v1.11.2. AM_PROG_AR does not AC_SUBST + dnl ARFLAGS variable (it is filed into Makefile.in directly by automake + dnl script on-demand, if not specified by ./configure of course). + dnl Don't AC_REQUIRE the AM_PROG_AR otherwise the code for __ACK__ above + dnl will be ignored. Also, pay attention to call AM_PROG_AR in else block + dnl because AM_PROG_AR is written so it could re-set AR variable even for + dnl __ACK__. It may seem like its easier to avoid calling the macro here, + dnl but we need to AC_SUBST both AR/ARFLAGS (thus those must have some good + dnl default value and automake should usually know them). + m4_ifdef([AM_PROG_AR], [AM_PROG_AR], [:]) fi + + dnl In case the code above has not helped with setting AR/ARFLAGS, use + dnl Automake-documented default values for AR and ARFLAGS, but prefer + dnl ${host}-ar over ar (useful for cross-compiling). + AC_CHECK_TOOL([AR], [ar], [ar]) + if test -z "$ARFLAGS"; then + ARFLAGS='cr' + fi + AC_SUBST([AR]) AC_SUBST([ARFLAGS]) if test -z "$RANLIB"; then @@ -309,26 +332,28 @@ m4_ifdef([AC_PROG_MKDIR_P], [ ]) # AC_C_RESTRICT -# This definition overrides the AC_C_RESTRICT macro from autoconf 2.60..2.61, -# so that mixed use of GNU C and GNU C++ and mixed use of Sun C and Sun C++ -# works. -# This definition can be removed once autoconf >= 2.62 can be assumed. -# AC_AUTOCONF_VERSION was introduced in 2.62, so use that as the witness. -m4_ifndef([AC_AUTOCONF_VERSION],[ +# This definition is copied from post-2.69 Autoconf and overrides the +# AC_C_RESTRICT macro from autoconf 2.60..2.69. It can be removed +# once autoconf >= 2.70 can be assumed. It's painful to check version +# numbers, and in practice this macro is more up-to-date than Autoconf +# is, so override Autoconf unconditionally. AC_DEFUN([AC_C_RESTRICT], [AC_CACHE_CHECK([for C/C++ restrict keyword], [ac_cv_c_restrict], [ac_cv_c_restrict=no # The order here caters to the fact that C++ does not require restrict. for ac_kw in __restrict __restrict__ _Restrict restrict; do - AC_COMPILE_IFELSE([AC_LANG_PROGRAM( - [[typedef int * int_ptr; - int foo (int_ptr $ac_kw ip) { - return ip[0]; - }]], - [[int s[1]; - int * $ac_kw t = s; - t[0] = 0; - return foo(t)]])], + AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM( + [[typedef int *int_ptr; + int foo (int_ptr $ac_kw ip) { return ip[0]; } + int bar (int [$ac_kw]); /* Catch GCC bug 14050. */ + int bar (int ip[$ac_kw]) { return ip[0]; } + ]], + [[int s[1]; + int *$ac_kw t = s; + t[0] = 0; + return foo (t) + bar (t); + ]])], [ac_cv_c_restrict=$ac_kw]) test "$ac_cv_c_restrict" != no && break done @@ -338,21 +363,21 @@ AC_DEFUN([AC_C_RESTRICT], nothing if this is not supported. Do not define if restrict is supported directly. */ #undef restrict -/* Work around a bug in Sun C++: it does not support _Restrict, even - though the corresponding Sun C compiler does, which causes - "#define restrict _Restrict" in the previous line. Perhaps some future - version of Sun C++ will work with _Restrict; if so, it'll probably - define __RESTRICT, just as Sun C does. */ +/* Work around a bug in Sun C++: it does not support _Restrict or + __restrict__, even though the corresponding Sun C compiler ends up with + "#define restrict _Restrict" or "#define restrict __restrict__" in the + previous line. Perhaps some future version of Sun C++ will work with + restrict; if so, hopefully it defines __RESTRICT like Sun C does. */ #if defined __SUNPRO_CC && !defined __RESTRICT # define _Restrict +# define __restrict__ #endif]) case $ac_cv_c_restrict in restrict) ;; no) AC_DEFINE([restrict], []) ;; *) AC_DEFINE_UNQUOTED([restrict], [$ac_cv_c_restrict]) ;; esac -]) -]) +])# AC_C_RESTRICT # gl_BIGENDIAN # is like AC_C_BIGENDIAN, except that it can be AC_REQUIREd. diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 429fee422..fbdb1e85c 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -1,5 +1,5 @@ # DO NOT EDIT! GENERATED AUTOMATICALLY! -# Copyright (C) 2002-2014 Free Software Foundation, Inc. +# Copyright (C) 2002-2016 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -37,7 +37,11 @@ AC_DEFUN([gl_EARLY], m4_pattern_allow([^gl_ES$])dnl a valid locale name m4_pattern_allow([^gl_LIBOBJS$])dnl a variable m4_pattern_allow([^gl_LTLIBOBJS$])dnl a variable + + # Pre-early section. + AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) AC_REQUIRE([gl_PROG_AR_RANLIB]) + AC_REQUIRE([AM_PROG_CC_C_O]) # Code from module absolute-header: # Code from module accept: @@ -46,6 +50,7 @@ AC_DEFUN([gl_EARLY], # Code from module alloca-opt: # Code from module announce-gen: # Code from module arpa_inet: + # Code from module assure: # Code from module autobuild: AB_INIT # Code from module binary-io: @@ -73,10 +78,10 @@ AC_DEFUN([gl_EARLY], # Code from module environ: # Code from module errno: # Code from module extensions: - AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) # Code from module extern-inline: # Code from module fcntl-h: # Code from module fd-hook: + # Code from module flexmember: # Code from module float: # Code from module flock: # Code from module floor: @@ -102,6 +107,7 @@ AC_DEFUN([gl_EARLY], # Code from module gnumakefile: # Code from module gnupload: # Code from module gperf: + # Code from module hard-locale: # Code from module havelib: # Code from module hostent: # Code from module iconv: @@ -112,6 +118,7 @@ AC_DEFUN([gl_EARLY], # Code from module inet_ntop: # Code from module inet_pton: # Code from module inline: + # Code from module intprops: # Code from module isfinite: # Code from module isinf: # Code from module isnan: @@ -147,6 +154,8 @@ AC_DEFUN([gl_EARLY], # Code from module memchr: # Code from module mkdir: # Code from module mkstemp: + # Code from module mktime: + # Code from module mktime-internal: # Code from module msvc-inval: # Code from module msvc-nothrow: # Code from module multiarch: @@ -220,6 +229,8 @@ AC_DEFUN([gl_EARLY], # Code from module tempname: # Code from module time: # Code from module time_r: + # Code from module time_rz: + # Code from module timegm: # Code from module times: # Code from module trunc: # Code from module unistd: @@ -230,6 +241,7 @@ AC_DEFUN([gl_EARLY], # Code from module unistr/u8-prev: # Code from module unistr/u8-uctomb: # Code from module unitypes: + # Code from module unsetenv: # Code from module useless-if-before-free: # Code from module vasnprintf: # Code from module vc-list-files: @@ -262,10 +274,6 @@ AC_DEFUN([gl_INIT], AC_LIBOBJ([accept]) fi gl_SYS_SOCKET_MODULE_INDICATOR([accept]) -changequote(,)dnl -LTALLOCA=`echo "$ALLOCA" | sed -e 's/\.[^.]* /.lo /g;s/\.[^.]*$/.lo/'` -changequote([, ])dnl -AC_SUBST([LTALLOCA]) gl_FUNC_ALLOCA gl_HEADER_ARPA_INET AC_PROG_MKDIR_P @@ -274,12 +282,6 @@ AC_SUBST([LTALLOCA]) AC_LIBOBJ([bind]) fi gl_SYS_SOCKET_MODULE_INDICATOR([bind]) - gl_FUNC_BTOWC - if test $HAVE_BTOWC = 0 || test $REPLACE_BTOWC = 1; then - AC_LIBOBJ([btowc]) - gl_PREREQ_BTOWC - fi - gl_WCHAR_MODULE_INDICATOR([btowc]) gl_BYTESWAP gl_CANONICALIZE_LGPL if test $HAVE_CANONICALIZE_FILE_NAME = 0 || test $REPLACE_CANONICALIZE_FILE_NAME = 1; then @@ -293,7 +295,6 @@ AC_SUBST([LTALLOCA]) AC_LIBOBJ([ceil]) fi gl_MATH_MODULE_INDICATOR([ceil]) - gl_UNISTD_MODULE_INDICATOR([chdir]) gl_CLOCK_TIME gl_FUNC_CLOSE if test $REPLACE_CLOSE = 1; then @@ -313,19 +314,12 @@ AC_SUBST([LTALLOCA]) gl_MATH_MODULE_INDICATOR([copysign]) gl_DIRENT_H gl_FUNC_DIRFD - if test $ac_cv_func_dirfd = no && test $gl_cv_func_dirfd_macro = no; then + if test $ac_cv_func_dirfd = no && test $gl_cv_func_dirfd_macro = no \ + || test $REPLACE_DIRFD = 1; then AC_LIBOBJ([dirfd]) gl_PREREQ_DIRFD fi gl_DIRENT_MODULE_INDICATOR([dirfd]) - gl_DIRNAME_LGPL - gl_DOUBLE_SLASH_ROOT - gl_FUNC_DUP2 - if test $HAVE_DUP2 = 0 || test $REPLACE_DUP2 = 1; then - AC_LIBOBJ([dup2]) - gl_PREREQ_DUP2 - fi - gl_UNISTD_MODULE_INDICATOR([dup2]) gl_FUNC_DUPLOCALE if test $REPLACE_DUPLOCALE = 1; then AC_LIBOBJ([duplocale]) @@ -401,8 +395,6 @@ AC_SUBST([LTALLOCA]) AC_LIBOBJ([getsockopt]) fi gl_SYS_SOCKET_MODULE_INDICATOR([getsockopt]) - AC_SUBST([LIBINTL]) - AC_SUBST([LTLIBINTL]) gl_FUNC_GETTIMEOFDAY if test $HAVE_GETTIMEOFDAY = 0 || test $REPLACE_GETTIMEOFDAY = 1; then AC_LIBOBJ([gettimeofday]) @@ -419,7 +411,6 @@ AC_SUBST([LTALLOCA]) m4_defn([m4_PACKAGE_VERSION])), [1], [], [AC_CONFIG_LINKS([$GNUmakefile:$GNUmakefile], [], [GNUmakefile=$GNUmakefile])]) - gl_HOSTENT AM_ICONV m4_ifdef([gl_ICONV_MODULE_INDICATOR], [gl_ICONV_MODULE_INDICATOR([iconv])]) @@ -467,11 +458,6 @@ AC_SUBST([LTALLOCA]) gl_PREREQ_ISNAND fi gl_MATH_MODULE_INDICATOR([isnand]) - gl_FUNC_ISNAND_NO_LIBM - if test $gl_func_isnand_no_libm != yes; then - AC_LIBOBJ([isnand]) - gl_PREREQ_ISNAND - fi gl_FUNC_ISNANF m4_ifdef([gl_ISNAN], [ AC_REQUIRE([gl_ISNAN]) @@ -481,11 +467,6 @@ AC_SUBST([LTALLOCA]) gl_PREREQ_ISNANF fi gl_MATH_MODULE_INDICATOR([isnanf]) - gl_FUNC_ISNANF_NO_LIBM - if test $gl_func_isnanf_no_libm != yes; then - AC_LIBOBJ([isnanf]) - gl_PREREQ_ISNANF - fi gl_FUNC_ISNANL m4_ifdef([gl_ISNAN], [ AC_REQUIRE([gl_ISNAN]) @@ -495,11 +476,6 @@ AC_SUBST([LTALLOCA]) gl_PREREQ_ISNANL fi gl_MATH_MODULE_INDICATOR([isnanl]) - gl_FUNC_ISNANL_NO_LIBM - if test $gl_func_isnanl_no_libm != yes; then - AC_LIBOBJ([isnanl]) - gl_PREREQ_ISNANL - fi gl_LANGINFO_H AC_REQUIRE([gl_LARGEFILE]) gl_FUNC_LDEXP @@ -520,17 +496,6 @@ AC_SUBST([LTALLOCA]) LOCALCHARSET_TESTS_ENVIRONMENT="CHARSETALIASDIR=\"\$(abs_top_builddir)/$gl_source_base\"" AC_SUBST([LOCALCHARSET_TESTS_ENVIRONMENT]) gl_LOCALE_H - gl_FUNC_LOCALECONV - if test $REPLACE_LOCALECONV = 1; then - AC_LIBOBJ([localeconv]) - gl_PREREQ_LOCALECONV - fi - gl_LOCALE_MODULE_INDICATOR([localeconv]) - AC_REQUIRE([gl_FUNC_LOG]) - if test $REPLACE_LOG = 1; then - AC_LIBOBJ([log]) - fi - gl_MATH_MODULE_INDICATOR([log]) gl_FUNC_LOG1P if test $HAVE_LOG1P = 0 || test $REPLACE_LOG1P = 1; then AC_LIBOBJ([log1p]) @@ -557,30 +522,6 @@ AC_SUBST([LTALLOCA]) gl_STDLIB_MODULE_INDICATOR([malloc-posix]) gl_MALLOCA gl_MATH_H - gl_FUNC_MBRTOWC - if test $HAVE_MBRTOWC = 0 || test $REPLACE_MBRTOWC = 1; then - AC_LIBOBJ([mbrtowc]) - gl_PREREQ_MBRTOWC - fi - gl_WCHAR_MODULE_INDICATOR([mbrtowc]) - gl_FUNC_MBSINIT - if test $HAVE_MBSINIT = 0 || test $REPLACE_MBSINIT = 1; then - AC_LIBOBJ([mbsinit]) - gl_PREREQ_MBSINIT - fi - gl_WCHAR_MODULE_INDICATOR([mbsinit]) - gl_FUNC_MBTOWC - if test $REPLACE_MBTOWC = 1; then - AC_LIBOBJ([mbtowc]) - gl_PREREQ_MBTOWC - fi - gl_STDLIB_MODULE_INDICATOR([mbtowc]) - gl_FUNC_MEMCHR - if test $HAVE_MEMCHR = 0 || test $REPLACE_MEMCHR = 1; then - AC_LIBOBJ([memchr]) - gl_PREREQ_MEMCHR - fi - gl_STRING_MODULE_INDICATOR([memchr]) gl_FUNC_MKDIR if test $REPLACE_MKDIR = 1; then AC_LIBOBJ([mkdir]) @@ -591,14 +532,6 @@ AC_SUBST([LTALLOCA]) gl_PREREQ_MKSTEMP fi gl_STDLIB_MODULE_INDICATOR([mkstemp]) - gl_MSVC_INVAL - if test $HAVE_MSVC_INVALID_PARAMETER_HANDLER = 1; then - AC_LIBOBJ([msvc-inval]) - fi - gl_MSVC_NOTHROW - if test $HAVE_MSVC_INVALID_PARAMETER_HANDLER = 1; then - AC_LIBOBJ([msvc-nothrow]) - fi gl_MULTIARCH gl_HEADER_NETDB gl_HEADER_NETINET_IN @@ -615,7 +548,6 @@ AC_SUBST([LTALLOCA]) gl_PREREQ_OPEN fi gl_FCNTL_MODULE_INDICATOR([open]) - gl_PATHMAX gl_FUNC_PIPE if test $HAVE_PIPE = 0; then AC_LIBOBJ([pipe]) @@ -636,12 +568,6 @@ AC_SUBST([LTALLOCA]) gl_PREREQ_PUTENV fi gl_STDLIB_MODULE_INDICATOR([putenv]) - gl_FUNC_RAISE - if test $HAVE_RAISE = 0 || test $REPLACE_RAISE = 1; then - AC_LIBOBJ([raise]) - gl_PREREQ_RAISE - fi - gl_SIGNAL_MODULE_INDICATOR([raise]) gl_FUNC_READ if test $REPLACE_READ = 1; then AC_LIBOBJ([read]) @@ -679,19 +605,8 @@ AC_SUBST([LTALLOCA]) AC_LIBOBJ([rmdir]) fi gl_UNISTD_MODULE_INDICATOR([rmdir]) - gl_FUNC_ROUND - if test $HAVE_ROUND = 0 || test $REPLACE_ROUND = 1; then - AC_LIBOBJ([round]) - fi - gl_MATH_MODULE_INDICATOR([round]) gl_PREREQ_SAFE_READ gl_PREREQ_SAFE_WRITE - gl_FUNC_SECURE_GETENV - if test $HAVE_SECURE_GETENV = 0; then - AC_LIBOBJ([secure_getenv]) - gl_PREREQ_SECURE_GETENV - fi - gl_STDLIB_MODULE_INDICATOR([secure_getenv]) gl_FUNC_SELECT if test $REPLACE_SELECT = 1; then AC_LIBOBJ([select]) @@ -707,7 +622,6 @@ AC_SUBST([LTALLOCA]) AC_LIBOBJ([sendto]) fi gl_SYS_SOCKET_MODULE_INDICATOR([sendto]) - gl_SERVENT gl_FUNC_SETENV if test $HAVE_SETENV = 0 || test $REPLACE_SETENV = 1; then AC_LIBOBJ([setenv]) @@ -724,17 +638,6 @@ AC_SUBST([LTALLOCA]) fi gl_SYS_SOCKET_MODULE_INDICATOR([shutdown]) gl_SIGNAL_H - gl_SIGNBIT - if test $REPLACE_SIGNBIT = 1; then - AC_LIBOBJ([signbitf]) - AC_LIBOBJ([signbitd]) - AC_LIBOBJ([signbitl]) - fi - gl_MATH_MODULE_INDICATOR([signbit]) - gl_SIZE_MAX - gl_FUNC_SNPRINTF - gl_STDIO_MODULE_INDICATOR([snprintf]) - gl_MODULE_INDICATOR([snprintf]) AC_REQUIRE([gl_HEADER_SYS_SOCKET]) if test "$ac_cv_header_winsock2_h" = yes; then AC_LIBOBJ([socket]) @@ -749,16 +652,9 @@ AC_SUBST([LTALLOCA]) SYS_IOCTL_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS=1 fi gl_SYS_SOCKET_MODULE_INDICATOR([socket]) - gl_SOCKETLIB - gl_SOCKETS + AC_REQUIRE([gl_SOCKETLIB]) gl_TYPE_SOCKLEN_T gt_TYPE_SSIZE_T - gl_FUNC_STAT - if test $REPLACE_STAT = 1; then - AC_LIBOBJ([stat]) - gl_PREREQ_STAT - fi - gl_SYS_STAT_MODULE_INDICATOR([stat]) gl_STAT_TIME gl_STAT_BIRTHTIME gl_STDALIGN_H @@ -767,12 +663,6 @@ AC_SUBST([LTALLOCA]) gl_STDINT_H gl_STDIO_H gl_STDLIB_H - gl_FUNC_STRDUP_POSIX - if test $ac_cv_func_strdup = no || test $REPLACE_STRDUP = 1; then - AC_LIBOBJ([strdup]) - gl_PREREQ_STRDUP - fi - gl_STRING_MODULE_INDICATOR([strdup]) gl_FUNC_GNU_STRFTIME if test $gl_cond_libtool = false; then gl_ltlibdeps="$gl_ltlibdeps $LTLIBICONV" @@ -783,7 +673,7 @@ AC_SUBST([LTALLOCA]) AC_PROG_MKDIR_P gl_HEADER_SYS_SELECT AC_PROG_MKDIR_P - gl_HEADER_SYS_SOCKET + AC_REQUIRE([gl_HEADER_SYS_SOCKET]) AC_PROG_MKDIR_P gl_HEADER_SYS_STAT_H AC_PROG_MKDIR_P @@ -795,14 +685,12 @@ AC_SUBST([LTALLOCA]) AC_PROG_MKDIR_P gl_HEADER_SYS_UIO AC_PROG_MKDIR_P - gl_FUNC_GEN_TEMPNAME gl_HEADER_TIME_H - gl_TIME_R - if test $HAVE_LOCALTIME_R = 0 || test $REPLACE_LOCALTIME_R = 1; then - AC_LIBOBJ([time_r]) - gl_PREREQ_TIME_R + gl_TIME_RZ + if test "$HAVE_TIMEZONE_T" = 0; then + AC_LIBOBJ([time_rz]) fi - gl_TIME_MODULE_INDICATOR([time_r]) + gl_TIME_MODULE_INDICATOR([time_rz]) gl_FUNC_TIMES if test $HAVE_TIMES = 0; then AC_LIBOBJ([times]) @@ -814,7 +702,7 @@ AC_SUBST([LTALLOCA]) fi gl_MATH_MODULE_INDICATOR([trunc]) gl_UNISTD_H - gl_LIBUNISTRING_LIBHEADER([0.9.2], [unistr.h]) + gl_LIBUNISTRING_LIBHEADER([0.9.4], [unistr.h]) gl_MODULE_INDICATOR([unistr/u8-mbtouc]) gl_LIBUNISTRING_MODULE([0.9.4], [unistr/u8-mbtouc]) gl_MODULE_INDICATOR([unistr/u8-mbtouc-unsafe]) @@ -824,25 +712,845 @@ AC_SUBST([LTALLOCA]) gl_LIBUNISTRING_MODULE([0.9], [unistr/u8-prev]) gl_MODULE_INDICATOR([unistr/u8-uctomb]) gl_LIBUNISTRING_MODULE([0.9], [unistr/u8-uctomb]) - gl_LIBUNISTRING_LIBHEADER([0.9], [unitypes.h]) - gl_FUNC_VASNPRINTF + gl_LIBUNISTRING_LIBHEADER([0.9.4], [unitypes.h]) gl_FUNC_VSNPRINTF gl_STDIO_MODULE_INDICATOR([vsnprintf]) gl_WCHAR_H - gl_FUNC_WCRTOMB - if test $HAVE_WCRTOMB = 0 || test $REPLACE_WCRTOMB = 1; then - AC_LIBOBJ([wcrtomb]) - gl_PREREQ_WCRTOMB - fi - gl_WCHAR_MODULE_INDICATOR([wcrtomb]) - gl_WCTYPE_H gl_FUNC_WRITE if test $REPLACE_WRITE = 1; then AC_LIBOBJ([write]) gl_PREREQ_WRITE fi gl_UNISTD_MODULE_INDICATOR([write]) - gl_XSIZE + gl_gnulib_enabled_alloca=false + gl_gnulib_enabled_assure=false + gl_gnulib_enabled_btowc=false + gl_gnulib_enabled_chdir=false + gl_gnulib_enabled_a691da99c1d83b83238e45f41a696f5c=false + gl_gnulib_enabled_dosname=false + gl_gnulib_enabled_36afd6902ac3aacf32e3ff12a686c346=false + gl_gnulib_enabled_dup2=false + gl_gnulib_enabled_43fe87a341d9b4b93c47c3ad819a5239=false + gl_gnulib_enabled_flexmember=false + gl_gnulib_enabled_be453cec5eecf5731a274f2de7f2db36=false + gl_gnulib_enabled_30838f5439487421042f2225bed3af76=false + gl_gnulib_enabled_hostent=false + gl_gnulib_enabled_intprops=false + gl_gnulib_enabled_b1df7117b479d2da59d76deba468ee21=false + gl_gnulib_enabled_3f0e593033d1fc2c127581960f641b66=false + gl_gnulib_enabled_dbdf22868a5367f28bf18e0013ac6f8f=false + gl_gnulib_enabled_localeconv=false + gl_gnulib_enabled_log=false + gl_gnulib_enabled_mbrtowc=false + gl_gnulib_enabled_mbsinit=false + gl_gnulib_enabled_mbtowc=false + gl_gnulib_enabled_memchr=false + gl_gnulib_enabled_mktime=false + gl_gnulib_enabled_5264294aa0a5557541b53c8c741f7f31=false + gl_gnulib_enabled_f691f076f650964c9f5598c3ee487616=false + gl_gnulib_enabled_676220fa4366efa9bdbfccf11a857c07=false + gl_gnulib_enabled_pathmax=false + gl_gnulib_enabled_raise=false + gl_gnulib_enabled_round=false + gl_gnulib_enabled_9bc5f216d57e231e4834049d67d0db62=false + gl_gnulib_enabled_secure_getenv=false + gl_gnulib_enabled_servent=false + gl_gnulib_enabled_signbit=false + gl_gnulib_enabled_size_max=false + gl_gnulib_enabled_snprintf=false + gl_gnulib_enabled_sockets=false + gl_gnulib_enabled_stat=false + gl_gnulib_enabled_f9850631dca91859e9cddac9359921c0=false + gl_gnulib_enabled_streq=false + gl_gnulib_enabled_tempname=false + gl_gnulib_enabled_time_r=false + gl_gnulib_enabled_timegm=false + gl_gnulib_enabled_unsetenv=false + gl_gnulib_enabled_vasnprintf=false + gl_gnulib_enabled_wcrtomb=false + gl_gnulib_enabled_3dcce957eadc896e63ab5f137947b410=false + gl_gnulib_enabled_xsize=false + func_gl_gnulib_m4code_alloca () + { + if ! $gl_gnulib_enabled_alloca; then +changequote(,)dnl +LTALLOCA=`echo "$ALLOCA" | sed -e 's/\.[^.]* /.lo /g;s/\.[^.]*$/.lo/'` +changequote([, ])dnl +AC_SUBST([LTALLOCA]) + gl_gnulib_enabled_alloca=true + fi + } + func_gl_gnulib_m4code_assure () + { + if ! $gl_gnulib_enabled_assure; then + gl_gnulib_enabled_assure=true + fi + } + func_gl_gnulib_m4code_btowc () + { + if ! $gl_gnulib_enabled_btowc; then + gl_FUNC_BTOWC + if test $HAVE_BTOWC = 0 || test $REPLACE_BTOWC = 1; then + AC_LIBOBJ([btowc]) + gl_PREREQ_BTOWC + fi + gl_WCHAR_MODULE_INDICATOR([btowc]) + gl_gnulib_enabled_btowc=true + if test $HAVE_BTOWC = 0 || test $REPLACE_BTOWC = 1; then + func_gl_gnulib_m4code_mbtowc + fi + fi + } + func_gl_gnulib_m4code_chdir () + { + if ! $gl_gnulib_enabled_chdir; then + gl_UNISTD_MODULE_INDICATOR([chdir]) + gl_gnulib_enabled_chdir=true + fi + } + func_gl_gnulib_m4code_a691da99c1d83b83238e45f41a696f5c () + { + if ! $gl_gnulib_enabled_a691da99c1d83b83238e45f41a696f5c; then + gl_DIRNAME_LGPL + gl_gnulib_enabled_a691da99c1d83b83238e45f41a696f5c=true + func_gl_gnulib_m4code_dosname + func_gl_gnulib_m4code_36afd6902ac3aacf32e3ff12a686c346 + fi + } + func_gl_gnulib_m4code_dosname () + { + if ! $gl_gnulib_enabled_dosname; then + gl_gnulib_enabled_dosname=true + fi + } + func_gl_gnulib_m4code_36afd6902ac3aacf32e3ff12a686c346 () + { + if ! $gl_gnulib_enabled_36afd6902ac3aacf32e3ff12a686c346; then + gl_DOUBLE_SLASH_ROOT + gl_gnulib_enabled_36afd6902ac3aacf32e3ff12a686c346=true + fi + } + func_gl_gnulib_m4code_dup2 () + { + if ! $gl_gnulib_enabled_dup2; then + gl_FUNC_DUP2 + if test $HAVE_DUP2 = 0 || test $REPLACE_DUP2 = 1; then + AC_LIBOBJ([dup2]) + gl_PREREQ_DUP2 + fi + gl_UNISTD_MODULE_INDICATOR([dup2]) + gl_gnulib_enabled_dup2=true + if test $HAVE_DUP2 = 0 || test $REPLACE_DUP2 = 1; then + func_gl_gnulib_m4code_f691f076f650964c9f5598c3ee487616 + fi + if test $HAVE_DUP2 = 0 || test $REPLACE_DUP2 = 1; then + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 + fi + fi + } + func_gl_gnulib_m4code_43fe87a341d9b4b93c47c3ad819a5239 () + { + if ! $gl_gnulib_enabled_43fe87a341d9b4b93c47c3ad819a5239; then + gl_gnulib_enabled_43fe87a341d9b4b93c47c3ad819a5239=true + fi + } + func_gl_gnulib_m4code_flexmember () + { + if ! $gl_gnulib_enabled_flexmember; then + AC_C_FLEXIBLE_ARRAY_MEMBER + gl_gnulib_enabled_flexmember=true + fi + } + func_gl_gnulib_m4code_be453cec5eecf5731a274f2de7f2db36 () + { + if ! $gl_gnulib_enabled_be453cec5eecf5731a274f2de7f2db36; then + AC_SUBST([LIBINTL]) + AC_SUBST([LTLIBINTL]) + gl_gnulib_enabled_be453cec5eecf5731a274f2de7f2db36=true + fi + } + func_gl_gnulib_m4code_30838f5439487421042f2225bed3af76 () + { + if ! $gl_gnulib_enabled_30838f5439487421042f2225bed3af76; then + gl_HARD_LOCALE + gl_gnulib_enabled_30838f5439487421042f2225bed3af76=true + fi + } + func_gl_gnulib_m4code_hostent () + { + if ! $gl_gnulib_enabled_hostent; then + gl_HOSTENT + gl_gnulib_enabled_hostent=true + fi + } + func_gl_gnulib_m4code_intprops () + { + if ! $gl_gnulib_enabled_intprops; then + gl_gnulib_enabled_intprops=true + fi + } + func_gl_gnulib_m4code_b1df7117b479d2da59d76deba468ee21 () + { + if ! $gl_gnulib_enabled_b1df7117b479d2da59d76deba468ee21; then + gl_FUNC_ISNAND_NO_LIBM + if test $gl_func_isnand_no_libm != yes; then + AC_LIBOBJ([isnand]) + gl_PREREQ_ISNAND + fi + gl_gnulib_enabled_b1df7117b479d2da59d76deba468ee21=true + fi + } + func_gl_gnulib_m4code_3f0e593033d1fc2c127581960f641b66 () + { + if ! $gl_gnulib_enabled_3f0e593033d1fc2c127581960f641b66; then + gl_FUNC_ISNANF_NO_LIBM + if test $gl_func_isnanf_no_libm != yes; then + AC_LIBOBJ([isnanf]) + gl_PREREQ_ISNANF + fi + gl_gnulib_enabled_3f0e593033d1fc2c127581960f641b66=true + fi + } + func_gl_gnulib_m4code_dbdf22868a5367f28bf18e0013ac6f8f () + { + if ! $gl_gnulib_enabled_dbdf22868a5367f28bf18e0013ac6f8f; then + gl_FUNC_ISNANL_NO_LIBM + if test $gl_func_isnanl_no_libm != yes; then + AC_LIBOBJ([isnanl]) + gl_PREREQ_ISNANL + fi + gl_gnulib_enabled_dbdf22868a5367f28bf18e0013ac6f8f=true + fi + } + func_gl_gnulib_m4code_localeconv () + { + if ! $gl_gnulib_enabled_localeconv; then + gl_FUNC_LOCALECONV + if test $REPLACE_LOCALECONV = 1; then + AC_LIBOBJ([localeconv]) + gl_PREREQ_LOCALECONV + fi + gl_LOCALE_MODULE_INDICATOR([localeconv]) + gl_gnulib_enabled_localeconv=true + fi + } + func_gl_gnulib_m4code_log () + { + if ! $gl_gnulib_enabled_log; then + AC_REQUIRE([gl_FUNC_LOG]) + if test $REPLACE_LOG = 1; then + AC_LIBOBJ([log]) + fi + gl_MATH_MODULE_INDICATOR([log]) + gl_gnulib_enabled_log=true + fi + } + func_gl_gnulib_m4code_mbrtowc () + { + if ! $gl_gnulib_enabled_mbrtowc; then + gl_FUNC_MBRTOWC + if test $HAVE_MBRTOWC = 0 || test $REPLACE_MBRTOWC = 1; then + AC_LIBOBJ([mbrtowc]) + gl_PREREQ_MBRTOWC + fi + gl_WCHAR_MODULE_INDICATOR([mbrtowc]) + gl_gnulib_enabled_mbrtowc=true + if test $HAVE_MBRTOWC = 0 || test $REPLACE_MBRTOWC = 1; then + func_gl_gnulib_m4code_30838f5439487421042f2225bed3af76 + fi + if test $HAVE_MBRTOWC = 0 || test $REPLACE_MBRTOWC = 1; then + func_gl_gnulib_m4code_mbsinit + fi + if test $HAVE_MBRTOWC = 0 || test $REPLACE_MBRTOWC = 1; then + func_gl_gnulib_m4code_streq + fi + fi + } + func_gl_gnulib_m4code_mbsinit () + { + if ! $gl_gnulib_enabled_mbsinit; then + gl_FUNC_MBSINIT + if test $HAVE_MBSINIT = 0 || test $REPLACE_MBSINIT = 1; then + AC_LIBOBJ([mbsinit]) + gl_PREREQ_MBSINIT + fi + gl_WCHAR_MODULE_INDICATOR([mbsinit]) + gl_gnulib_enabled_mbsinit=true + if test $HAVE_MBSINIT = 0 || test $REPLACE_MBSINIT = 1; then + func_gl_gnulib_m4code_mbrtowc + fi + fi + } + func_gl_gnulib_m4code_mbtowc () + { + if ! $gl_gnulib_enabled_mbtowc; then + gl_FUNC_MBTOWC + if test $REPLACE_MBTOWC = 1; then + AC_LIBOBJ([mbtowc]) + gl_PREREQ_MBTOWC + fi + gl_STDLIB_MODULE_INDICATOR([mbtowc]) + gl_gnulib_enabled_mbtowc=true + if test $REPLACE_MBTOWC = 1; then + func_gl_gnulib_m4code_mbrtowc + fi + fi + } + func_gl_gnulib_m4code_memchr () + { + if ! $gl_gnulib_enabled_memchr; then + gl_FUNC_MEMCHR + if test $HAVE_MEMCHR = 0 || test $REPLACE_MEMCHR = 1; then + AC_LIBOBJ([memchr]) + gl_PREREQ_MEMCHR + fi + gl_STRING_MODULE_INDICATOR([memchr]) + gl_gnulib_enabled_memchr=true + fi + } + func_gl_gnulib_m4code_mktime () + { + if ! $gl_gnulib_enabled_mktime; then + gl_FUNC_MKTIME + if test $REPLACE_MKTIME = 1; then + AC_LIBOBJ([mktime]) + gl_PREREQ_MKTIME + fi + gl_TIME_MODULE_INDICATOR([mktime]) + gl_gnulib_enabled_mktime=true + if test $REPLACE_MKTIME = 1; then + func_gl_gnulib_m4code_intprops + fi + if test $REPLACE_MKTIME = 1; then + func_gl_gnulib_m4code_time_r + fi + fi + } + func_gl_gnulib_m4code_5264294aa0a5557541b53c8c741f7f31 () + { + if ! $gl_gnulib_enabled_5264294aa0a5557541b53c8c741f7f31; then + gl_FUNC_MKTIME_INTERNAL + if test $REPLACE_MKTIME = 1; then + AC_LIBOBJ([mktime]) + gl_PREREQ_MKTIME + fi + gl_gnulib_enabled_5264294aa0a5557541b53c8c741f7f31=true + func_gl_gnulib_m4code_mktime + fi + } + func_gl_gnulib_m4code_f691f076f650964c9f5598c3ee487616 () + { + if ! $gl_gnulib_enabled_f691f076f650964c9f5598c3ee487616; then + AC_REQUIRE([gl_MSVC_INVAL]) + if test $HAVE_MSVC_INVALID_PARAMETER_HANDLER = 1; then + AC_LIBOBJ([msvc-inval]) + fi + gl_gnulib_enabled_f691f076f650964c9f5598c3ee487616=true + fi + } + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 () + { + if ! $gl_gnulib_enabled_676220fa4366efa9bdbfccf11a857c07; then + AC_REQUIRE([gl_MSVC_NOTHROW]) + if test $HAVE_MSVC_INVALID_PARAMETER_HANDLER = 1; then + AC_LIBOBJ([msvc-nothrow]) + fi + gl_gnulib_enabled_676220fa4366efa9bdbfccf11a857c07=true + func_gl_gnulib_m4code_f691f076f650964c9f5598c3ee487616 + fi + } + func_gl_gnulib_m4code_pathmax () + { + if ! $gl_gnulib_enabled_pathmax; then + gl_PATHMAX + gl_gnulib_enabled_pathmax=true + fi + } + func_gl_gnulib_m4code_raise () + { + if ! $gl_gnulib_enabled_raise; then + gl_FUNC_RAISE + if test $HAVE_RAISE = 0 || test $REPLACE_RAISE = 1; then + AC_LIBOBJ([raise]) + gl_PREREQ_RAISE + fi + gl_SIGNAL_MODULE_INDICATOR([raise]) + gl_gnulib_enabled_raise=true + if test $HAVE_RAISE = 0 || test $REPLACE_RAISE = 1; then + func_gl_gnulib_m4code_f691f076f650964c9f5598c3ee487616 + fi + fi + } + func_gl_gnulib_m4code_round () + { + if ! $gl_gnulib_enabled_round; then + gl_FUNC_ROUND + if test $HAVE_ROUND = 0 || test $REPLACE_ROUND = 1; then + AC_LIBOBJ([round]) + fi + gl_MATH_MODULE_INDICATOR([round]) + gl_gnulib_enabled_round=true + fi + } + func_gl_gnulib_m4code_9bc5f216d57e231e4834049d67d0db62 () + { + if ! $gl_gnulib_enabled_9bc5f216d57e231e4834049d67d0db62; then + gl_gnulib_enabled_9bc5f216d57e231e4834049d67d0db62=true + fi + } + func_gl_gnulib_m4code_secure_getenv () + { + if ! $gl_gnulib_enabled_secure_getenv; then + gl_FUNC_SECURE_GETENV + if test $HAVE_SECURE_GETENV = 0; then + AC_LIBOBJ([secure_getenv]) + gl_PREREQ_SECURE_GETENV + fi + gl_STDLIB_MODULE_INDICATOR([secure_getenv]) + gl_gnulib_enabled_secure_getenv=true + fi + } + func_gl_gnulib_m4code_servent () + { + if ! $gl_gnulib_enabled_servent; then + gl_SERVENT + gl_gnulib_enabled_servent=true + fi + } + func_gl_gnulib_m4code_signbit () + { + if ! $gl_gnulib_enabled_signbit; then + gl_SIGNBIT + if test $REPLACE_SIGNBIT = 1; then + AC_LIBOBJ([signbitf]) + AC_LIBOBJ([signbitd]) + AC_LIBOBJ([signbitl]) + fi + gl_MATH_MODULE_INDICATOR([signbit]) + gl_gnulib_enabled_signbit=true + if test $REPLACE_SIGNBIT = 1; then + func_gl_gnulib_m4code_b1df7117b479d2da59d76deba468ee21 + fi + if test $REPLACE_SIGNBIT = 1; then + func_gl_gnulib_m4code_3f0e593033d1fc2c127581960f641b66 + fi + if test $REPLACE_SIGNBIT = 1; then + func_gl_gnulib_m4code_dbdf22868a5367f28bf18e0013ac6f8f + fi + fi + } + func_gl_gnulib_m4code_size_max () + { + if ! $gl_gnulib_enabled_size_max; then + gl_SIZE_MAX + gl_gnulib_enabled_size_max=true + fi + } + func_gl_gnulib_m4code_snprintf () + { + if ! $gl_gnulib_enabled_snprintf; then + gl_FUNC_SNPRINTF + gl_STDIO_MODULE_INDICATOR([snprintf]) + gl_MODULE_INDICATOR([snprintf]) + gl_gnulib_enabled_snprintf=true + if test $ac_cv_func_snprintf = no || test $REPLACE_SNPRINTF = 1; then + func_gl_gnulib_m4code_vasnprintf + fi + fi + } + func_gl_gnulib_m4code_sockets () + { + if ! $gl_gnulib_enabled_sockets; then + AC_REQUIRE([gl_SOCKETS]) + gl_gnulib_enabled_sockets=true + func_gl_gnulib_m4code_43fe87a341d9b4b93c47c3ad819a5239 + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 + fi + } + func_gl_gnulib_m4code_stat () + { + if ! $gl_gnulib_enabled_stat; then + gl_FUNC_STAT + if test $REPLACE_STAT = 1; then + AC_LIBOBJ([stat]) + gl_PREREQ_STAT + fi + gl_SYS_STAT_MODULE_INDICATOR([stat]) + gl_gnulib_enabled_stat=true + if test $REPLACE_STAT = 1; then + func_gl_gnulib_m4code_dosname + fi + if test $REPLACE_STAT = 1; then + func_gl_gnulib_m4code_pathmax + fi + fi + } + func_gl_gnulib_m4code_f9850631dca91859e9cddac9359921c0 () + { + if ! $gl_gnulib_enabled_f9850631dca91859e9cddac9359921c0; then + gl_FUNC_STRDUP_POSIX + if test $ac_cv_func_strdup = no || test $REPLACE_STRDUP = 1; then + AC_LIBOBJ([strdup]) + gl_PREREQ_STRDUP + fi + gl_STRING_MODULE_INDICATOR([strdup]) + gl_gnulib_enabled_f9850631dca91859e9cddac9359921c0=true + fi + } + func_gl_gnulib_m4code_streq () + { + if ! $gl_gnulib_enabled_streq; then + gl_gnulib_enabled_streq=true + fi + } + func_gl_gnulib_m4code_tempname () + { + if ! $gl_gnulib_enabled_tempname; then + gl_FUNC_GEN_TEMPNAME + gl_gnulib_enabled_tempname=true + func_gl_gnulib_m4code_secure_getenv + fi + } + func_gl_gnulib_m4code_time_r () + { + if ! $gl_gnulib_enabled_time_r; then + gl_TIME_R + if test $HAVE_LOCALTIME_R = 0 || test $REPLACE_LOCALTIME_R = 1; then + AC_LIBOBJ([time_r]) + gl_PREREQ_TIME_R + fi + gl_TIME_MODULE_INDICATOR([time_r]) + gl_gnulib_enabled_time_r=true + fi + } + func_gl_gnulib_m4code_timegm () + { + if ! $gl_gnulib_enabled_timegm; then + gl_FUNC_TIMEGM + if test $HAVE_TIMEGM = 0 || test $REPLACE_TIMEGM = 1; then + AC_LIBOBJ([timegm]) + gl_PREREQ_TIMEGM + fi + gl_TIME_MODULE_INDICATOR([timegm]) + gl_gnulib_enabled_timegm=true + if test $HAVE_TIMEGM = 0 || test $REPLACE_TIMEGM = 1; then + func_gl_gnulib_m4code_5264294aa0a5557541b53c8c741f7f31 + fi + if test $HAVE_TIMEGM = 0 || test $REPLACE_TIMEGM = 1; then + func_gl_gnulib_m4code_time_r + fi + fi + } + func_gl_gnulib_m4code_unsetenv () + { + if ! $gl_gnulib_enabled_unsetenv; then + gl_FUNC_UNSETENV + if test $HAVE_UNSETENV = 0 || test $REPLACE_UNSETENV = 1; then + AC_LIBOBJ([unsetenv]) + gl_PREREQ_UNSETENV + fi + gl_STDLIB_MODULE_INDICATOR([unsetenv]) + gl_gnulib_enabled_unsetenv=true + fi + } + func_gl_gnulib_m4code_vasnprintf () + { + if ! $gl_gnulib_enabled_vasnprintf; then + gl_FUNC_VASNPRINTF + gl_gnulib_enabled_vasnprintf=true + func_gl_gnulib_m4code_memchr + func_gl_gnulib_m4code_xsize + fi + } + func_gl_gnulib_m4code_wcrtomb () + { + if ! $gl_gnulib_enabled_wcrtomb; then + gl_FUNC_WCRTOMB + if test $HAVE_WCRTOMB = 0 || test $REPLACE_WCRTOMB = 1; then + AC_LIBOBJ([wcrtomb]) + gl_PREREQ_WCRTOMB + fi + gl_WCHAR_MODULE_INDICATOR([wcrtomb]) + gl_gnulib_enabled_wcrtomb=true + if test $HAVE_WCRTOMB = 0 || test $REPLACE_WCRTOMB = 1; then + func_gl_gnulib_m4code_mbsinit + fi + fi + } + func_gl_gnulib_m4code_3dcce957eadc896e63ab5f137947b410 () + { + if ! $gl_gnulib_enabled_3dcce957eadc896e63ab5f137947b410; then + gl_WCTYPE_H + gl_gnulib_enabled_3dcce957eadc896e63ab5f137947b410=true + fi + } + func_gl_gnulib_m4code_xsize () + { + if ! $gl_gnulib_enabled_xsize; then + gl_XSIZE + gl_gnulib_enabled_xsize=true + func_gl_gnulib_m4code_size_max + fi + } + if test "$ac_cv_header_winsock2_h" = yes; then + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 + fi + if test "$ac_cv_header_winsock2_h" = yes; then + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 + fi + if test $HAVE_CANONICALIZE_FILE_NAME = 0 || test $REPLACE_CANONICALIZE_FILE_NAME = 1; then + func_gl_gnulib_m4code_pathmax + fi + if test $REPLACE_CLOSE = 1; then + func_gl_gnulib_m4code_43fe87a341d9b4b93c47c3ad819a5239 + fi + if test $REPLACE_CLOSE = 1; then + func_gl_gnulib_m4code_f691f076f650964c9f5598c3ee487616 + fi + if test "$ac_cv_header_winsock2_h" = yes; then + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 + fi + if test $HAVE_COPYSIGN = 0; then + func_gl_gnulib_m4code_signbit + fi + if test $HAVE_FLOCK = 0; then + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 + fi + if test $gl_func_frexp != yes; then + func_gl_gnulib_m4code_b1df7117b479d2da59d76deba468ee21 + fi + if test $REPLACE_STAT = 1; then + func_gl_gnulib_m4code_f691f076f650964c9f5598c3ee487616 + fi + if test $HAVE_FSYNC = 0; then + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 + fi + if test $HAVE_GETADDRINFO = 0 || test $HAVE_DECL_GAI_STRERROR = 0 || test $REPLACE_GAI_STRERROR = 1; then + func_gl_gnulib_m4code_be453cec5eecf5731a274f2de7f2db36 + fi + if test $HAVE_GETADDRINFO = 0; then + func_gl_gnulib_m4code_hostent + fi + if test $HAVE_GETADDRINFO = 0; then + func_gl_gnulib_m4code_servent + fi + if test $HAVE_GETADDRINFO = 0; then + func_gl_gnulib_m4code_snprintf + fi + if test $HAVE_GETADDRINFO = 0; then + func_gl_gnulib_m4code_sockets + fi + if test "$ac_cv_header_winsock2_h" = yes; then + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 + fi + if test "$ac_cv_header_winsock2_h" = yes; then + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 + fi + if test "$ac_cv_header_winsock2_h" = yes; then + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 + fi + if test $REPLACE_ISFINITE = 1; then + func_gl_gnulib_m4code_b1df7117b479d2da59d76deba468ee21 + fi + if test $REPLACE_ISFINITE = 1; then + func_gl_gnulib_m4code_3f0e593033d1fc2c127581960f641b66 + fi + if test $REPLACE_ISFINITE = 1; then + func_gl_gnulib_m4code_dbdf22868a5367f28bf18e0013ac6f8f + fi + if test $HAVE_LINK = 0 || test $REPLACE_LINK = 1; then + func_gl_gnulib_m4code_stat + fi + if test $HAVE_LINK = 0 || test $REPLACE_LINK = 1; then + func_gl_gnulib_m4code_f9850631dca91859e9cddac9359921c0 + fi + if test "$ac_cv_header_winsock2_h" = yes; then + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 + fi + if test $HAVE_LOG1P = 0 || test $REPLACE_LOG1P = 1; then + func_gl_gnulib_m4code_log + fi + if test $HAVE_LOG1P = 0 || test $REPLACE_LOG1P = 1; then + func_gl_gnulib_m4code_round + fi + if test $REPLACE_LSTAT = 1; then + func_gl_gnulib_m4code_dosname + fi + if test $REPLACE_LSTAT = 1; then + func_gl_gnulib_m4code_stat + fi + if test $REPLACE_MKDIR = 1; then + func_gl_gnulib_m4code_a691da99c1d83b83238e45f41a696f5c + fi + if test $HAVE_MKSTEMP = 0 || test $REPLACE_MKSTEMP = 1; then + func_gl_gnulib_m4code_tempname + fi + if test $HAVE_NL_LANGINFO = 0 || test $REPLACE_NL_LANGINFO = 1; then + func_gl_gnulib_m4code_localeconv + fi + if test $REPLACE_OPEN = 1; then + func_gl_gnulib_m4code_stat + fi + if test $HAVE_POLL = 0 || test $REPLACE_POLL = 1; then + func_gl_gnulib_m4code_alloca + fi + if test $HAVE_POLL = 0 || test $REPLACE_POLL = 1; then + func_gl_gnulib_m4code_assure + fi + if test $HAVE_POLL = 0 || test $REPLACE_POLL = 1; then + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 + fi + if test $HAVE_POLL = 0 || test $REPLACE_POLL = 1; then + func_gl_gnulib_m4code_sockets + fi + if test $REPLACE_READ = 1; then + func_gl_gnulib_m4code_f691f076f650964c9f5598c3ee487616 + fi + if test $REPLACE_READ = 1; then + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 + fi + if test $HAVE_READLINK = 0 || test $REPLACE_READLINK = 1; then + func_gl_gnulib_m4code_stat + fi + if test "$ac_cv_header_winsock2_h" = yes; then + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 + fi + if test "$ac_cv_header_winsock2_h" = yes; then + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 + fi + if test $ac_use_included_regex = yes; then + func_gl_gnulib_m4code_btowc + fi + if test $ac_use_included_regex = yes; then + func_gl_gnulib_m4code_be453cec5eecf5731a274f2de7f2db36 + fi + if test $ac_use_included_regex = yes; then + func_gl_gnulib_m4code_mbrtowc + fi + if test $ac_use_included_regex = yes; then + func_gl_gnulib_m4code_mbsinit + fi + if test $ac_use_included_regex = yes; then + func_gl_gnulib_m4code_wcrtomb + fi + if test $ac_use_included_regex = yes; then + func_gl_gnulib_m4code_3dcce957eadc896e63ab5f137947b410 + fi + if test $REPLACE_RENAME = 1; then + func_gl_gnulib_m4code_chdir + fi + if test $REPLACE_RENAME = 1; then + func_gl_gnulib_m4code_a691da99c1d83b83238e45f41a696f5c + fi + if test $REPLACE_RENAME = 1; then + func_gl_gnulib_m4code_9bc5f216d57e231e4834049d67d0db62 + fi + if test $REPLACE_RMDIR = 1; then + func_gl_gnulib_m4code_dosname + fi + if test $REPLACE_SELECT = 1; then + func_gl_gnulib_m4code_alloca + fi + if test $REPLACE_SELECT = 1; then + func_gl_gnulib_m4code_dup2 + fi + if test $REPLACE_SELECT = 1; then + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 + fi + if test $REPLACE_SELECT = 1; then + func_gl_gnulib_m4code_sockets + fi + if test "$ac_cv_header_winsock2_h" = yes; then + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 + fi + if test "$ac_cv_header_winsock2_h" = yes; then + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 + fi + if test "$ac_cv_header_winsock2_h" = yes; then + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 + fi + if test "$ac_cv_header_winsock2_h" = yes; then + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 + fi + if test "$ac_cv_header_winsock2_h" = yes; then + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 + fi + if test "$ac_cv_header_winsock2_h" = yes; then + func_gl_gnulib_m4code_sockets + fi + if test "$HAVE_TIMEZONE_T" = 0; then + func_gl_gnulib_m4code_flexmember + fi + if test "$HAVE_TIMEZONE_T" = 0; then + func_gl_gnulib_m4code_time_r + fi + if test "$HAVE_TIMEZONE_T" = 0; then + func_gl_gnulib_m4code_timegm + fi + if test "$HAVE_TIMEZONE_T" = 0; then + func_gl_gnulib_m4code_unsetenv + fi + if test $ac_cv_func_vsnprintf = no || test $REPLACE_VSNPRINTF = 1; then + func_gl_gnulib_m4code_vasnprintf + fi + if test $REPLACE_WRITE = 1; then + func_gl_gnulib_m4code_f691f076f650964c9f5598c3ee487616 + fi + if test $REPLACE_WRITE = 1; then + func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 + fi + if test $REPLACE_WRITE = 1; then + func_gl_gnulib_m4code_raise + fi + m4_pattern_allow([^gl_GNULIB_ENABLED_]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_alloca], [$gl_gnulib_enabled_alloca]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_assure], [$gl_gnulib_enabled_assure]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_btowc], [$gl_gnulib_enabled_btowc]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_chdir], [$gl_gnulib_enabled_chdir]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_a691da99c1d83b83238e45f41a696f5c], [$gl_gnulib_enabled_a691da99c1d83b83238e45f41a696f5c]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_dosname], [$gl_gnulib_enabled_dosname]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_36afd6902ac3aacf32e3ff12a686c346], [$gl_gnulib_enabled_36afd6902ac3aacf32e3ff12a686c346]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_dup2], [$gl_gnulib_enabled_dup2]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_43fe87a341d9b4b93c47c3ad819a5239], [$gl_gnulib_enabled_43fe87a341d9b4b93c47c3ad819a5239]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_flexmember], [$gl_gnulib_enabled_flexmember]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36], [$gl_gnulib_enabled_be453cec5eecf5731a274f2de7f2db36]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_30838f5439487421042f2225bed3af76], [$gl_gnulib_enabled_30838f5439487421042f2225bed3af76]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_hostent], [$gl_gnulib_enabled_hostent]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_intprops], [$gl_gnulib_enabled_intprops]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_b1df7117b479d2da59d76deba468ee21], [$gl_gnulib_enabled_b1df7117b479d2da59d76deba468ee21]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_3f0e593033d1fc2c127581960f641b66], [$gl_gnulib_enabled_3f0e593033d1fc2c127581960f641b66]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_dbdf22868a5367f28bf18e0013ac6f8f], [$gl_gnulib_enabled_dbdf22868a5367f28bf18e0013ac6f8f]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_localeconv], [$gl_gnulib_enabled_localeconv]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_log], [$gl_gnulib_enabled_log]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_mbrtowc], [$gl_gnulib_enabled_mbrtowc]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_mbsinit], [$gl_gnulib_enabled_mbsinit]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_mbtowc], [$gl_gnulib_enabled_mbtowc]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_memchr], [$gl_gnulib_enabled_memchr]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_mktime], [$gl_gnulib_enabled_mktime]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31], [$gl_gnulib_enabled_5264294aa0a5557541b53c8c741f7f31]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_f691f076f650964c9f5598c3ee487616], [$gl_gnulib_enabled_f691f076f650964c9f5598c3ee487616]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_676220fa4366efa9bdbfccf11a857c07], [$gl_gnulib_enabled_676220fa4366efa9bdbfccf11a857c07]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_pathmax], [$gl_gnulib_enabled_pathmax]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_raise], [$gl_gnulib_enabled_raise]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_round], [$gl_gnulib_enabled_round]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_9bc5f216d57e231e4834049d67d0db62], [$gl_gnulib_enabled_9bc5f216d57e231e4834049d67d0db62]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_secure_getenv], [$gl_gnulib_enabled_secure_getenv]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_servent], [$gl_gnulib_enabled_servent]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_signbit], [$gl_gnulib_enabled_signbit]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_size_max], [$gl_gnulib_enabled_size_max]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_snprintf], [$gl_gnulib_enabled_snprintf]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_sockets], [$gl_gnulib_enabled_sockets]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_stat], [$gl_gnulib_enabled_stat]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_f9850631dca91859e9cddac9359921c0], [$gl_gnulib_enabled_f9850631dca91859e9cddac9359921c0]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_streq], [$gl_gnulib_enabled_streq]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_tempname], [$gl_gnulib_enabled_tempname]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_time_r], [$gl_gnulib_enabled_time_r]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_timegm], [$gl_gnulib_enabled_timegm]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_unsetenv], [$gl_gnulib_enabled_unsetenv]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_vasnprintf], [$gl_gnulib_enabled_vasnprintf]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_wcrtomb], [$gl_gnulib_enabled_wcrtomb]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_3dcce957eadc896e63ab5f137947b410], [$gl_gnulib_enabled_3dcce957eadc896e63ab5f137947b410]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_xsize], [$gl_gnulib_enabled_xsize]) # End of code from modules m4_ifval(gl_LIBSOURCES_LIST, [ m4_syscmd([test ! -d ]m4_defn([gl_LIBSOURCES_DIR])[ || @@ -889,6 +1597,7 @@ changequote([, ])dnl AC_SUBST([gltests_WITNESS]) gl_module_indicator_condition=$gltests_WITNESS m4_pushdef([gl_MODULE_INDICATOR_CONDITION], [$gl_module_indicator_condition]) + m4_pattern_allow([^gl_GNULIB_ENABLED_]) m4_popdef([gl_MODULE_INDICATOR_CONDITION]) m4_ifval(gltests_LIBSOURCES_LIST, [ m4_syscmd([test ! -d ]m4_defn([gltests_LIBSOURCES_DIR])[ || @@ -994,12 +1703,14 @@ AC_DEFUN([gl_FILE_LIST], [ build-aux/useless-if-before-free build-aux/vc-list-files doc/gendocs_template + doc/gendocs_template_min lib/accept.c lib/alignof.h lib/alloca.c lib/alloca.in.h lib/arpa_inet.in.h lib/asnprintf.c + lib/assure.h lib/basename-lgpl.c lib/binary-io.c lib/binary-io.h @@ -1049,6 +1760,8 @@ AC_DEFUN([gl_FILE_LIST], [ lib/getsockopt.c lib/gettext.h lib/gettimeofday.c + lib/hard-locale.c + lib/hard-locale.h lib/iconv.c lib/iconv.in.h lib/iconv_close.c @@ -1061,6 +1774,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/iconveh.h lib/inet_ntop.c lib/inet_pton.c + lib/intprops.h lib/isfinite.c lib/isinf.c lib/isnan.c @@ -1096,6 +1810,8 @@ AC_DEFUN([gl_FILE_LIST], [ lib/memchr.valgrind lib/mkdir.c lib/mkstemp.c + lib/mktime-internal.h + lib/mktime.c lib/msvc-inval.c lib/msvc-inval.h lib/msvc-nothrow.c @@ -1181,8 +1897,11 @@ AC_DEFUN([gl_FILE_LIST], [ lib/sys_uio.in.h lib/tempname.c lib/tempname.h + lib/time-internal.h lib/time.in.h lib/time_r.c + lib/time_rz.c + lib/timegm.c lib/times.c lib/trunc.c lib/unistd.c @@ -1197,6 +1916,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/unistr/u8-uctomb-aux.c lib/unistr/u8-uctomb.c lib/unitypes.in.h + lib/unsetenv.c lib/vasnprintf.c lib/vasnprintf.h lib/verify.h @@ -1240,6 +1960,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/extern-inline.m4 m4/fcntl-o.m4 m4/fcntl_h.m4 + m4/flexmember.m4 m4/float_h.m4 m4/flock.m4 m4/floor.m4 @@ -1253,6 +1974,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/gettimeofday.m4 m4/glibc21.m4 m4/gnulib-common.m4 + m4/hard-locale.m4 m4/hostent.m4 m4/iconv.m4 m4/iconv_h.m4 @@ -1301,6 +2023,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/memchr.m4 m4/mkdir.m4 m4/mkstemp.m4 + m4/mktime.m4 m4/mmap-anon.m4 m4/mode_t.m4 m4/msvc-inval.m4 @@ -1365,6 +2088,8 @@ AC_DEFUN([gl_FILE_LIST], [ m4/tempname.m4 m4/time_h.m4 m4/time_r.m4 + m4/time_rz.m4 + m4/timegm.m4 m4/times.m4 m4/tm_gmtoff.m4 m4/trunc.m4 diff --git a/m4/gnulib-tool.m4 b/m4/gnulib-tool.m4 index a588e1519..0d2ee444b 100644 --- a/m4/gnulib-tool.m4 +++ b/m4/gnulib-tool.m4 @@ -1,5 +1,5 @@ # gnulib-tool.m4 serial 2 -dnl Copyright (C) 2004-2005, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2004-2005, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/hard-locale.m4 b/m4/hard-locale.m4 new file mode 100644 index 000000000..4661bfc5a --- /dev/null +++ b/m4/hard-locale.m4 @@ -0,0 +1,11 @@ +# hard-locale.m4 serial 8 +dnl Copyright (C) 2002-2006, 2009-2016 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl No prerequisites of lib/hard-locale.c. +AC_DEFUN([gl_HARD_LOCALE], +[ + : +]) diff --git a/m4/hostent.m4 b/m4/hostent.m4 index dd8fc0709..1b2488abc 100644 --- a/m4/hostent.m4 +++ b/m4/hostent.m4 @@ -1,5 +1,5 @@ # hostent.m4 serial 2 -dnl Copyright (C) 2008, 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008, 2010-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/iconv.m4 b/m4/iconv.m4 index 4b29c5f2c..aa159c539 100644 --- a/m4/iconv.m4 +++ b/m4/iconv.m4 @@ -1,5 +1,5 @@ -# iconv.m4 serial 18 (gettext-0.18.2) -dnl Copyright (C) 2000-2002, 2007-2014 Free Software Foundation, Inc. +# iconv.m4 serial 19 (gettext-0.18.2) +dnl Copyright (C) 2000-2002, 2007-2014, 2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -72,27 +72,33 @@ AC_DEFUN([AM_ICONV_LINK], if test $am_cv_lib_iconv = yes; then LIBS="$LIBS $LIBICONV" fi - AC_RUN_IFELSE( - [AC_LANG_SOURCE([[ + am_cv_func_iconv_works=no + for ac_iconv_const in '' 'const'; do + AC_RUN_IFELSE( + [AC_LANG_PROGRAM( + [[ #include #include -int main () -{ - int result = 0; + +#ifndef ICONV_CONST +# define ICONV_CONST $ac_iconv_const +#endif + ]], + [[int result = 0; /* Test against AIX 5.1 bug: Failures are not distinguishable from successful returns. */ { iconv_t cd_utf8_to_88591 = iconv_open ("ISO8859-1", "UTF-8"); if (cd_utf8_to_88591 != (iconv_t)(-1)) { - static const char input[] = "\342\202\254"; /* EURO SIGN */ + static ICONV_CONST char input[] = "\342\202\254"; /* EURO SIGN */ char buf[10]; - const char *inptr = input; + ICONV_CONST char *inptr = input; size_t inbytesleft = strlen (input); char *outptr = buf; size_t outbytesleft = sizeof (buf); size_t res = iconv (cd_utf8_to_88591, - (char **) &inptr, &inbytesleft, + &inptr, &inbytesleft, &outptr, &outbytesleft); if (res == 0) result |= 1; @@ -105,14 +111,14 @@ int main () iconv_t cd_ascii_to_88591 = iconv_open ("ISO8859-1", "646"); if (cd_ascii_to_88591 != (iconv_t)(-1)) { - static const char input[] = "\263"; + static ICONV_CONST char input[] = "\263"; char buf[10]; - const char *inptr = input; + ICONV_CONST char *inptr = input; size_t inbytesleft = strlen (input); char *outptr = buf; size_t outbytesleft = sizeof (buf); size_t res = iconv (cd_ascii_to_88591, - (char **) &inptr, &inbytesleft, + &inptr, &inbytesleft, &outptr, &outbytesleft); if (res == 0) result |= 2; @@ -124,14 +130,14 @@ int main () iconv_t cd_88591_to_utf8 = iconv_open ("UTF-8", "ISO-8859-1"); if (cd_88591_to_utf8 != (iconv_t)(-1)) { - static const char input[] = "\304"; + static ICONV_CONST char input[] = "\304"; static char buf[2] = { (char)0xDE, (char)0xAD }; - const char *inptr = input; + ICONV_CONST char *inptr = input; size_t inbytesleft = 1; char *outptr = buf; size_t outbytesleft = 1; size_t res = iconv (cd_88591_to_utf8, - (char **) &inptr, &inbytesleft, + &inptr, &inbytesleft, &outptr, &outbytesleft); if (res != (size_t)(-1) || outptr - buf > 1 || buf[1] != (char)0xAD) result |= 4; @@ -144,14 +150,14 @@ int main () iconv_t cd_88591_to_utf8 = iconv_open ("utf8", "iso88591"); if (cd_88591_to_utf8 != (iconv_t)(-1)) { - static const char input[] = "\304rger mit b\366sen B\374bchen ohne Augenma\337"; + static ICONV_CONST char input[] = "\304rger mit b\366sen B\374bchen ohne Augenma\337"; char buf[50]; - const char *inptr = input; + ICONV_CONST char *inptr = input; size_t inbytesleft = strlen (input); char *outptr = buf; size_t outbytesleft = sizeof (buf); size_t res = iconv (cd_88591_to_utf8, - (char **) &inptr, &inbytesleft, + &inptr, &inbytesleft, &outptr, &outbytesleft); if ((int)res > 0) result |= 8; @@ -171,17 +177,14 @@ int main () && iconv_open ("utf8", "eucJP") == (iconv_t)(-1)) result |= 16; return result; -}]])], - [am_cv_func_iconv_works=yes], - [am_cv_func_iconv_works=no], - [ -changequote(,)dnl - case "$host_os" in - aix* | hpux*) am_cv_func_iconv_works="guessing no" ;; - *) am_cv_func_iconv_works="guessing yes" ;; - esac -changequote([,])dnl - ]) +]])], + [am_cv_func_iconv_works=yes], , + [case "$host_os" in + aix* | hpux*) am_cv_func_iconv_works="guessing no" ;; + *) am_cv_func_iconv_works="guessing yes" ;; + esac]) + test "$am_cv_func_iconv_works" = no || break + done LIBS="$am_save_LIBS" ]) case "$am_cv_func_iconv_works" in diff --git a/m4/iconv_h.m4 b/m4/iconv_h.m4 index e992fa399..c95ecc294 100644 --- a/m4/iconv_h.m4 +++ b/m4/iconv_h.m4 @@ -1,5 +1,5 @@ # iconv_h.m4 serial 8 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/iconv_open-utf.m4 b/m4/iconv_open-utf.m4 index 31ced265a..2c1802357 100644 --- a/m4/iconv_open-utf.m4 +++ b/m4/iconv_open-utf.m4 @@ -1,5 +1,5 @@ # iconv_open-utf.m4 serial 1 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/iconv_open.m4 b/m4/iconv_open.m4 index e0bfd7203..54e1dc8a6 100644 --- a/m4/iconv_open.m4 +++ b/m4/iconv_open.m4 @@ -1,5 +1,5 @@ # iconv_open.m4 serial 14 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/include_next.m4 b/m4/include_next.m4 index 69ad3dbb0..db0f2c079 100644 --- a/m4/include_next.m4 +++ b/m4/include_next.m4 @@ -1,5 +1,5 @@ # include_next.m4 serial 23 -dnl Copyright (C) 2006-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/inet_ntop.m4 b/m4/inet_ntop.m4 index 5b27759c5..26464c34a 100644 --- a/m4/inet_ntop.m4 +++ b/m4/inet_ntop.m4 @@ -1,5 +1,5 @@ # inet_ntop.m4 serial 19 -dnl Copyright (C) 2005-2006, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2005-2006, 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/inet_pton.m4 b/m4/inet_pton.m4 index 136ed24d0..4f5db7149 100644 --- a/m4/inet_pton.m4 +++ b/m4/inet_pton.m4 @@ -1,5 +1,5 @@ # inet_pton.m4 serial 17 -dnl Copyright (C) 2006, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/inline.m4 b/m4/inline.m4 index c49957f80..28fd2d091 100644 --- a/m4/inline.m4 +++ b/m4/inline.m4 @@ -1,5 +1,5 @@ # inline.m4 serial 4 -dnl Copyright (C) 2006, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/intmax_t.m4 b/m4/intmax_t.m4 index af5561e5d..9559accab 100644 --- a/m4/intmax_t.m4 +++ b/m4/intmax_t.m4 @@ -1,5 +1,5 @@ # intmax_t.m4 serial 8 -dnl Copyright (C) 1997-2004, 2006-2007, 2009-2014 Free Software Foundation, +dnl Copyright (C) 1997-2004, 2006-2007, 2009-2016 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/inttypes_h.m4 b/m4/inttypes_h.m4 index 87be9cfb5..76571199f 100644 --- a/m4/inttypes_h.m4 +++ b/m4/inttypes_h.m4 @@ -1,5 +1,5 @@ # inttypes_h.m4 serial 10 -dnl Copyright (C) 1997-2004, 2006, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 1997-2004, 2006, 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/isfinite.m4 b/m4/isfinite.m4 index 53ad9092a..7b9641c03 100644 --- a/m4/isfinite.m4 +++ b/m4/isfinite.m4 @@ -1,5 +1,5 @@ -# isfinite.m4 serial 13 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +# isfinite.m4 serial 15 +dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -34,13 +34,8 @@ AC_DEFUN([gl_ISFINITE], AC_SUBST([ISFINITE_LIBM]) ]) -dnl Test whether isfinite() on 'long double' recognizes all numbers which are -dnl neither finite nor infinite. This test fails e.g. on i686, x86_64, ia64, -dnl because of -dnl - pseudo-denormals on x86_64, -dnl - pseudo-zeroes, unnormalized numbers, and pseudo-denormals on i686, -dnl - pseudo-NaN, pseudo-Infinity, pseudo-zeroes, unnormalized numbers, and -dnl pseudo-denormals on ia64. +dnl Test whether isfinite() on 'long double' recognizes all canonical values +dnl which are neither finite nor infinite. AC_DEFUN([gl_ISFINITEL_WORKS], [ AC_REQUIRE([AC_PROG_CC]) @@ -94,7 +89,7 @@ int main () # ifdef WORDS_BIGENDIAN # define LDBL80_WORDS(exponent,manthi,mantlo) \ { ((unsigned int) (exponent) << 16) | ((unsigned int) (manthi) >> 16), \ - ((unsigned int) (manthi) << 16) | (unsigned int) (mantlo) >> 16), \ + ((unsigned int) (manthi) << 16) | ((unsigned int) (mantlo) >> 16), \ (unsigned int) (mantlo) << 16 \ } # else @@ -114,52 +109,41 @@ int main () if (isfinite (x.value)) result |= 2; } - /* The isfinite macro should recognize Pseudo-NaNs, Pseudo-Infinities, - Pseudo-Zeroes, Unnormalized Numbers, and Pseudo-Denormals, as defined in - Intel IA-64 Architecture Software Developer's Manual, Volume 1: - Application Architecture. - Table 5-2 "Floating-Point Register Encodings" - Figure 5-6 "Memory to Floating-Point Register Data Translation" - */ + /* isfinite should return something even for noncanonical values. */ { /* Pseudo-NaN. */ static memory_long_double x = { LDBL80_WORDS (0xFFFF, 0x40000001, 0x00000000) }; - if (isfinite (x.value)) + if (isfinite (x.value) && !isfinite (x.value)) result |= 4; } { /* Pseudo-Infinity. */ static memory_long_double x = { LDBL80_WORDS (0xFFFF, 0x00000000, 0x00000000) }; - if (isfinite (x.value)) + if (isfinite (x.value) && !isfinite (x.value)) result |= 8; } { /* Pseudo-Zero. */ static memory_long_double x = { LDBL80_WORDS (0x4004, 0x00000000, 0x00000000) }; - if (isfinite (x.value)) + if (isfinite (x.value) && !isfinite (x.value)) result |= 16; } { /* Unnormalized number. */ static memory_long_double x = { LDBL80_WORDS (0x4000, 0x63333333, 0x00000000) }; - if (isfinite (x.value)) + if (isfinite (x.value) && !isfinite (x.value)) result |= 32; } { /* Pseudo-Denormal. */ static memory_long_double x = { LDBL80_WORDS (0x0000, 0x83333333, 0x00000000) }; - if (isfinite (x.value)) + if (isfinite (x.value) && !isfinite (x.value)) result |= 64; } #endif return result; }]])], [gl_cv_func_isfinitel_works=yes], [gl_cv_func_isfinitel_works=no], - [case "$host_cpu" in - # Guess no on ia64, x86_64, i386. - ia64 | x86_64 | i*86) gl_cv_func_isfinitel_works="guessing no";; - *) gl_cv_func_isfinitel_works="guessing yes";; - esac - ]) + [gl_cv_func_isfinitel_works="guessing yes"]) ]) ]) diff --git a/m4/isinf.m4 b/m4/isinf.m4 index 7174acecd..d062be02b 100644 --- a/m4/isinf.m4 +++ b/m4/isinf.m4 @@ -1,5 +1,5 @@ -# isinf.m4 serial 9 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +# isinf.m4 serial 11 +dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -37,13 +37,8 @@ AC_DEFUN([gl_ISINF], dnl Test whether isinf() works: dnl 1) Whether it correctly returns false for LDBL_MAX. -dnl 2) Whether on 'long double' recognizes all numbers which are neither -dnl finite nor infinite. This test fails on OpenBSD/x86, but could also -dnl fail e.g. on i686, x86_64, ia64, because of -dnl - pseudo-denormals on x86_64, -dnl - pseudo-zeroes, unnormalized numbers, and pseudo-denormals on i686, -dnl - pseudo-NaN, pseudo-Infinity, pseudo-zeroes, unnormalized numbers, and -dnl pseudo-denormals on ia64. +dnl 2) Whether on 'long double' recognizes all canonical values which are +dnl infinite. AC_DEFUN([gl_ISINFL_WORKS], [ AC_REQUIRE([AC_PROG_CC]) @@ -101,7 +96,7 @@ int main () # ifdef WORDS_BIGENDIAN # define LDBL80_WORDS(exponent,manthi,mantlo) \ { ((unsigned int) (exponent) << 16) | ((unsigned int) (manthi) >> 16), \ - ((unsigned int) (manthi) << 16) | (unsigned int) (mantlo) >> 16), \ + ((unsigned int) (manthi) << 16) | ((unsigned int) (mantlo) >> 16), \ (unsigned int) (mantlo) << 16 \ } # else @@ -121,55 +116,41 @@ int main () if (isinf (x.value)) result |= 2; } - /* The isinf macro should recognize Pseudo-NaNs, Pseudo-Infinities, - Pseudo-Zeroes, Unnormalized Numbers, and Pseudo-Denormals, as defined in - Intel IA-64 Architecture Software Developer's Manual, Volume 1: - Application Architecture. - Table 5-2 "Floating-Point Register Encodings" - Figure 5-6 "Memory to Floating-Point Register Data Translation" - */ + /* isinf should return something even for noncanonical values. */ { /* Pseudo-NaN. */ static memory_long_double x = { LDBL80_WORDS (0xFFFF, 0x40000001, 0x00000000) }; - if (isinf (x.value)) + if (isinf (x.value) && !isinf (x.value)) result |= 4; } { /* Pseudo-Infinity. */ static memory_long_double x = { LDBL80_WORDS (0xFFFF, 0x00000000, 0x00000000) }; - if (isinf (x.value)) + if (isinf (x.value) && !isinf (x.value)) result |= 8; } { /* Pseudo-Zero. */ static memory_long_double x = { LDBL80_WORDS (0x4004, 0x00000000, 0x00000000) }; - if (isinf (x.value)) + if (isinf (x.value) && !isinf (x.value)) result |= 16; } { /* Unnormalized number. */ static memory_long_double x = { LDBL80_WORDS (0x4000, 0x63333333, 0x00000000) }; - if (isinf (x.value)) + if (isinf (x.value) && !isinf (x.value)) result |= 32; } { /* Pseudo-Denormal. */ static memory_long_double x = { LDBL80_WORDS (0x0000, 0x83333333, 0x00000000) }; - if (isinf (x.value)) + if (isinf (x.value) && !isinf (x.value)) result |= 64; } #endif return result; }]])], [gl_cv_func_isinfl_works=yes], [gl_cv_func_isinfl_works=no], - [ - case "$host" in - # Guess no on OpenBSD ia64, x86_64, i386. - ia64-*-openbsd* | x86_64-*-openbsd* | i*86-*-openbsd*) - gl_cv_func_isinfl_works="guessing no";; - *) - gl_cv_func_isinfl_works="guessing yes";; - esac - ]) + [gl_cv_func_isinfl_works="guessing yes"]) ]) ]) diff --git a/m4/isnan.m4 b/m4/isnan.m4 index 579340312..98a32f3ab 100644 --- a/m4/isnan.m4 +++ b/m4/isnan.m4 @@ -1,5 +1,5 @@ # isnan.m4 serial 5 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/isnand.m4 b/m4/isnand.m4 index 36e4ea307..bcf3840db 100644 --- a/m4/isnand.m4 +++ b/m4/isnand.m4 @@ -1,5 +1,5 @@ # isnand.m4 serial 11 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/isnanf.m4 b/m4/isnanf.m4 index 1f2717d5e..f49d20c6d 100644 --- a/m4/isnanf.m4 +++ b/m4/isnanf.m4 @@ -1,5 +1,5 @@ # isnanf.m4 serial 14 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/isnanl.m4 b/m4/isnanl.m4 index 98b2b69fc..9766e4720 100644 --- a/m4/isnanl.m4 +++ b/m4/isnanl.m4 @@ -1,5 +1,5 @@ -# isnanl.m4 serial 17 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +# isnanl.m4 serial 19 +dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -108,11 +108,8 @@ AC_DEFUN([gl_HAVE_ISNANL_IN_LIBM], ]) ]) -dnl Test whether isnanl() recognizes all numbers which are neither finite nor -dnl infinite. This test fails e.g. on NetBSD/i386 and on glibc/ia64. -dnl Also, the GCC >= 4.0 built-in __builtin_isnanl does not pass the tests -dnl - for pseudo-denormals on i686 and x86_64, -dnl - for pseudo-zeroes, unnormalized numbers, and pseudo-denormals on ia64. +dnl Test whether isnanl() recognizes all canonical numbers which are neither +dnl finite nor infinite. AC_DEFUN([gl_FUNC_ISNANL_WORKS], [ AC_REQUIRE([AC_PROG_CC]) @@ -177,7 +174,7 @@ int main () # ifdef WORDS_BIGENDIAN # define LDBL80_WORDS(exponent,manthi,mantlo) \ { ((unsigned int) (exponent) << 16) | ((unsigned int) (manthi) >> 16), \ - ((unsigned int) (manthi) << 16) | (unsigned int) (mantlo) >> 16), \ + ((unsigned int) (manthi) << 16) | ((unsigned int) (mantlo) >> 16), \ (unsigned int) (mantlo) << 16 \ } # else @@ -197,41 +194,35 @@ int main () if (!isnanl (x.value)) result |= 2; } - /* The isnanl function should recognize Pseudo-NaNs, Pseudo-Infinities, - Pseudo-Zeroes, Unnormalized Numbers, and Pseudo-Denormals, as defined in - Intel IA-64 Architecture Software Developer's Manual, Volume 1: - Application Architecture. - Table 5-2 "Floating-Point Register Encodings" - Figure 5-6 "Memory to Floating-Point Register Data Translation" - */ + /* isnanl should return something even for noncanonical values. */ { /* Pseudo-NaN. */ static memory_long_double x = { LDBL80_WORDS (0xFFFF, 0x40000001, 0x00000000) }; - if (!isnanl (x.value)) + if (isnanl (x.value) && !isnanl (x.value)) result |= 4; } { /* Pseudo-Infinity. */ static memory_long_double x = { LDBL80_WORDS (0xFFFF, 0x00000000, 0x00000000) }; - if (!isnanl (x.value)) + if (isnanl (x.value) && !isnanl (x.value)) result |= 8; } { /* Pseudo-Zero. */ static memory_long_double x = { LDBL80_WORDS (0x4004, 0x00000000, 0x00000000) }; - if (!isnanl (x.value)) + if (isnanl (x.value) && !isnanl (x.value)) result |= 16; } { /* Unnormalized number. */ static memory_long_double x = { LDBL80_WORDS (0x4000, 0x63333333, 0x00000000) }; - if (!isnanl (x.value)) + if (isnanl (x.value) && !isnanl (x.value)) result |= 32; } { /* Pseudo-Denormal. */ static memory_long_double x = { LDBL80_WORDS (0x0000, 0x83333333, 0x00000000) }; - if (!isnanl (x.value)) + if (isnanl (x.value) && !isnanl (x.value)) result |= 64; } #endif @@ -240,16 +231,6 @@ int main () }]])], [gl_cv_func_isnanl_works=yes], [gl_cv_func_isnanl_works=no], - [case "$host_cpu" in - # Guess no on ia64, x86_64, i386. - ia64 | x86_64 | i*86) gl_cv_func_isnanl_works="guessing no";; - *) - case "$host_os" in - netbsd*) gl_cv_func_isnanl_works="guessing no";; - *) gl_cv_func_isnanl_works="guessing yes";; - esac - ;; - esac - ]) + [gl_cv_func_isnanl_works="guessing yes"]) ]) ]) diff --git a/m4/langinfo_h.m4 b/m4/langinfo_h.m4 index e8d78f9d0..edbbe762c 100644 --- a/m4/langinfo_h.m4 +++ b/m4/langinfo_h.m4 @@ -1,5 +1,5 @@ # langinfo_h.m4 serial 7 -dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/largefile.m4 b/m4/largefile.m4 index a1b564ad9..8bbdfaac1 100644 --- a/m4/largefile.m4 +++ b/m4/largefile.m4 @@ -1,6 +1,6 @@ # Enable large files on systems where this is not the default. -# Copyright 1992-1996, 1998-2014 Free Software Foundation, Inc. +# Copyright 1992-1996, 1998-2016 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/ld-version-script.m4 b/m4/ld-version-script.m4 index f8b4a5c51..330c2ccf0 100644 --- a/m4/ld-version-script.m4 +++ b/m4/ld-version-script.m4 @@ -1,5 +1,5 @@ -# ld-version-script.m4 serial 3 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +# ld-version-script.m4 serial 4 +dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -18,20 +18,18 @@ dnl From Simon Josefsson AC_DEFUN([gl_LD_VERSION_SCRIPT], [ AC_ARG_ENABLE([ld-version-script], - AS_HELP_STRING([--enable-ld-version-script], - [enable linker version script (default is enabled when possible)]), - [have_ld_version_script=$enableval], []) - if test -z "$have_ld_version_script"; then - AC_MSG_CHECKING([if LD -Wl,--version-script works]) - save_LDFLAGS="$LDFLAGS" - LDFLAGS="$LDFLAGS -Wl,--version-script=conftest.map" - cat > conftest.map < conftest.map <conftest.map + AC_LINK_IFELSE([AC_LANG_PROGRAM([], [])], + [], + [cat > conftest.map <conftest.file - if test "$as_ln_s" = "ln -s" && ln -s conftest.file conftest.sym; then - AC_RUN_IFELSE( - [AC_LANG_PROGRAM( - [AC_INCLUDES_DEFAULT], - [[struct stat sbuf; - /* Linux will dereference the symlink and fail, as required by - POSIX. That is better in the sense that it means we will not - have to compile and use the lstat wrapper. */ - return lstat ("conftest.sym/", &sbuf) == 0; - ]])], - [gl_cv_func_lstat_dereferences_slashed_symlink=yes], - [gl_cv_func_lstat_dereferences_slashed_symlink=no], - [case "$host_os" in - # Guess yes on glibc systems. - *-gnu*) gl_cv_func_lstat_dereferences_slashed_symlink="guessing yes" ;; - # If we don't know, assume the worst. - *) gl_cv_func_lstat_dereferences_slashed_symlink="guessing no" ;; - esac - ]) - else - # If the 'ln -s' command failed, then we probably don't even - # have an lstat function. - gl_cv_func_lstat_dereferences_slashed_symlink="guessing no" - fi + AC_RUN_IFELSE( + [AC_LANG_PROGRAM( + [AC_INCLUDES_DEFAULT], + [[struct stat sbuf; + if (symlink ("conftest.file", "conftest.sym") != 0) + return 1; + /* Linux will dereference the symlink and fail, as required by + POSIX. That is better in the sense that it means we will not + have to compile and use the lstat wrapper. */ + return lstat ("conftest.sym/", &sbuf) == 0; + ]])], + [gl_cv_func_lstat_dereferences_slashed_symlink=yes], + [gl_cv_func_lstat_dereferences_slashed_symlink=no], + [case "$host_os" in + *-gnu*) + # Guess yes on glibc systems. + gl_cv_func_lstat_dereferences_slashed_symlink="guessing yes" ;; + *) + # If we don't know, assume the worst. + gl_cv_func_lstat_dereferences_slashed_symlink="guessing no" ;; + esac + ]) rm -f conftest.sym conftest.file ]) case "$gl_cv_func_lstat_dereferences_slashed_symlink" in diff --git a/m4/malloc.m4 b/m4/malloc.m4 index 322ad6eff..c393690e2 100644 --- a/m4/malloc.m4 +++ b/m4/malloc.m4 @@ -1,13 +1,13 @@ -# malloc.m4 serial 14 -dnl Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. +# malloc.m4 serial 15 +dnl Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. m4_version_prereq([2.70], [] ,[ -# This is taken from the following Autoconf patch: -# http://git.savannah.gnu.org/gitweb/?p=autoconf.git;a=commitdiff;h=7fbb553727ed7e0e689a17594b58559ecf3ea6e9 +# This is adapted with modifications from upstream Autoconf here: +# http://git.savannah.gnu.org/cgit/autoconf.git/commit/?id=04be2b7a29d65d9a08e64e8e56e594c91749598c AC_DEFUN([_AC_FUNC_MALLOC_IF], [ AC_REQUIRE([AC_HEADER_STDC])dnl @@ -23,7 +23,10 @@ AC_DEFUN([_AC_FUNC_MALLOC_IF], char *malloc (); #endif ]], - [[return ! malloc (0);]]) + [[char *p = malloc (0); + int result = !p; + free (p); + return result;]]) ], [ac_cv_func_malloc_0_nonnull=yes], [ac_cv_func_malloc_0_nonnull=no], diff --git a/m4/malloca.m4 b/m4/malloca.m4 index dcc1a0843..b368b20e5 100644 --- a/m4/malloca.m4 +++ b/m4/malloca.m4 @@ -1,5 +1,5 @@ # malloca.m4 serial 1 -dnl Copyright (C) 2003-2004, 2006-2007, 2009-2014 Free Software Foundation, +dnl Copyright (C) 2003-2004, 2006-2007, 2009-2016 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/math_h.m4 b/m4/math_h.m4 index 9e2adfbac..35d07ee5f 100644 --- a/m4/math_h.m4 +++ b/m4/math_h.m4 @@ -1,5 +1,5 @@ # math_h.m4 serial 114 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mathfunc.m4 b/m4/mathfunc.m4 index 6f0e6aacd..0170697a7 100644 --- a/m4/mathfunc.m4 +++ b/m4/mathfunc.m4 @@ -1,5 +1,5 @@ # mathfunc.m4 serial 11 -dnl Copyright (C) 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mbrtowc.m4 b/m4/mbrtowc.m4 index a9d157092..d370fccf0 100644 --- a/m4/mbrtowc.m4 +++ b/m4/mbrtowc.m4 @@ -1,5 +1,5 @@ -# mbrtowc.m4 serial 25 -dnl Copyright (C) 2001-2002, 2004-2005, 2008-2014 Free Software Foundation, +# mbrtowc.m4 serial 27 -*- coding: utf-8 -*- +dnl Copyright (C) 2001-2002, 2004-2005, 2008-2016 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -39,6 +39,8 @@ AC_DEFUN([gl_FUNC_MBRTOWC], gl_MBRTOWC_NULL_ARG2 gl_MBRTOWC_RETVAL gl_MBRTOWC_NUL_RETVAL + gl_MBRTOWC_EMPTY_INPUT + gl_MBRTOWC_C_LOCALE case "$gl_cv_func_mbrtowc_null_arg1" in *yes) ;; *) AC_DEFINE([MBRTOWC_NULL_ARG1_BUG], [1], @@ -67,6 +69,21 @@ AC_DEFUN([gl_FUNC_MBRTOWC], REPLACE_MBRTOWC=1 ;; esac + case "$gl_cv_func_mbrtowc_empty_input" in + *yes) ;; + *) AC_DEFINE([MBRTOWC_EMPTY_INPUT_BUG], [1], + [Define if the mbrtowc function does not return (size_t) -2 + for empty input.]) + REPLACE_MBRTOWC=1 + ;; + esac + case $gl_cv_C_locale_sans_EILSEQ in + *yes) ;; + *) AC_DEFINE([C_LOCALE_MAYBE_EILSEQ], [1], + [Define to 1 if the C locale may have encoding errors.]) + REPLACE_MBRTOWC=1 + ;; + esac fi fi ]) @@ -533,6 +550,81 @@ int main () ]) ]) +dnl Test whether mbrtowc returns the correct value on empty input. + +AC_DEFUN([gl_MBRTOWC_EMPTY_INPUT], +[ + AC_REQUIRE([AC_PROG_CC]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CACHE_CHECK([whether mbrtowc works on empty input], + [gl_cv_func_mbrtowc_empty_input], + [ + dnl Initial guess, used when cross-compiling or when no suitable locale + dnl is present. +changequote(,)dnl + case "$host_os" in + # Guess no on AIX and glibc systems. + aix* | *-gnu*) + gl_cv_func_mbrtowc_empty_input="guessing no" ;; + *) gl_cv_func_mbrtowc_empty_input="guessing yes" ;; + esac +changequote([,])dnl + AC_RUN_IFELSE( + [AC_LANG_SOURCE([[ + #include + static wchar_t wc; + static mbstate_t mbs; + int + main (void) + { + return mbrtowc (&wc, "", 0, &mbs) != (size_t) -2; + }]])], + [gl_cv_func_mbrtowc_empty_input=yes], + [gl_cv_func_mbrtowc_empty_input=no], + [:]) + ]) +]) + +dnl Test whether mbrtowc reports encoding errors in the C locale. +dnl Although POSIX was never intended to allow this, the GNU C Library +dnl and other implementations do it. See: +dnl https://sourceware.org/bugzilla/show_bug.cgi?id=19932 + +AC_DEFUN([gl_MBRTOWC_C_LOCALE], +[ + AC_CACHE_CHECK([whether the C locale is free of encoding errors], + [gl_cv_C_locale_sans_EILSEQ], + [ + dnl Initial guess, used when cross-compiling or when no suitable locale + dnl is present. + gl_cv_C_locale_sans_EILSEQ="guessing no" + + AC_RUN_IFELSE( + [AC_LANG_PROGRAM( + [[#include + #include + #include + ]], [[ + int i; + char *locale = setlocale (LC_ALL, "C"); + if (! locale) + return 1; + for (i = CHAR_MIN; i <= CHAR_MAX; i++) + { + char c = i; + wchar_t wc; + mbstate_t mbs = { 0, }; + size_t ss = mbrtowc (&wc, &c, 1, &mbs); + if (1 < ss) + return 1; + } + return 0; + ]])], + [gl_cv_C_locale_sans_EILSEQ=yes], + [gl_cv_C_locale_sans_EILSEQ=no], + [:])]) +]) + # Prerequisites of lib/mbrtowc.c. AC_DEFUN([gl_PREREQ_MBRTOWC], [ : diff --git a/m4/mbsinit.m4 b/m4/mbsinit.m4 index e1598a1d7..88f08367a 100644 --- a/m4/mbsinit.m4 +++ b/m4/mbsinit.m4 @@ -1,5 +1,5 @@ # mbsinit.m4 serial 8 -dnl Copyright (C) 2008, 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008, 2010-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mbstate_t.m4 b/m4/mbstate_t.m4 index 068155a52..0a8eae254 100644 --- a/m4/mbstate_t.m4 +++ b/m4/mbstate_t.m4 @@ -1,5 +1,5 @@ # mbstate_t.m4 serial 13 -dnl Copyright (C) 2000-2002, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2000-2002, 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mbtowc.m4 b/m4/mbtowc.m4 index cacfe1610..e770bbf70 100644 --- a/m4/mbtowc.m4 +++ b/m4/mbtowc.m4 @@ -1,5 +1,5 @@ # mbtowc.m4 serial 2 -dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/memchr.m4 b/m4/memchr.m4 index b9f126cfa..25d32f0ec 100644 --- a/m4/memchr.m4 +++ b/m4/memchr.m4 @@ -1,5 +1,5 @@ # memchr.m4 serial 12 -dnl Copyright (C) 2002-2004, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2004, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mkdir.m4 b/m4/mkdir.m4 index 51e78c13d..574092bb2 100644 --- a/m4/mkdir.m4 +++ b/m4/mkdir.m4 @@ -1,6 +1,6 @@ # serial 11 -# Copyright (C) 2001, 2003-2004, 2006, 2008-2014 Free Software Foundation, Inc. +# Copyright (C) 2001, 2003-2004, 2006, 2008-2016 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/mkstemp.m4 b/m4/mkstemp.m4 index 9033a4e60..131e4a7b2 100644 --- a/m4/mkstemp.m4 +++ b/m4/mkstemp.m4 @@ -1,6 +1,6 @@ #serial 23 -# Copyright (C) 2001, 2003-2007, 2009-2014 Free Software Foundation, Inc. +# Copyright (C) 2001, 2003-2007, 2009-2016 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/mktime.m4 b/m4/mktime.m4 new file mode 100644 index 000000000..23cad732f --- /dev/null +++ b/m4/mktime.m4 @@ -0,0 +1,268 @@ +# serial 27 +dnl Copyright (C) 2002-2003, 2005-2007, 2009-2016 Free Software Foundation, +dnl Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl From Jim Meyering. + +AC_DEFUN([gl_TIME_T_IS_SIGNED], +[ + AC_CACHE_CHECK([whether time_t is signed], + [gl_cv_time_t_is_signed], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([[#include + char time_t_signed[(time_t) -1 < 0 ? 1 : -1];]])], + [gl_cv_time_t_is_signed=yes], + [gl_cv_time_t_is_signed=no])]) + if test $gl_cv_time_t_is_signed = yes; then + AC_DEFINE([TIME_T_IS_SIGNED], [1], [Define to 1 if time_t is signed.]) + fi +]) + +AC_DEFUN([gl_FUNC_MKTIME], +[ + AC_REQUIRE([gl_HEADER_TIME_H_DEFAULTS]) + AC_REQUIRE([gl_TIME_T_IS_SIGNED]) + + dnl We don't use AC_FUNC_MKTIME any more, because it is no longer maintained + dnl in Autoconf and because it invokes AC_LIBOBJ. + AC_CHECK_HEADERS_ONCE([unistd.h]) + AC_CHECK_DECLS_ONCE([alarm]) + AC_CHECK_FUNCS_ONCE([tzset]) + AC_REQUIRE([gl_MULTIARCH]) + if test $APPLE_UNIVERSAL_BUILD = 1; then + # A universal build on Apple Mac OS X platforms. + # The test result would be 'yes' in 32-bit mode and 'no' in 64-bit mode. + # But we need a configuration result that is valid in both modes. + gl_cv_func_working_mktime=no + fi + AC_CACHE_CHECK([for working mktime], [gl_cv_func_working_mktime], + [AC_RUN_IFELSE( + [AC_LANG_SOURCE( +[[/* Test program from Paul Eggert and Tony Leneis. */ +#include +#include +#include + +#ifdef HAVE_UNISTD_H +# include +#endif + +#if HAVE_DECL_ALARM +# include +#endif + +/* Work around redefinition to rpl_putenv by other config tests. */ +#undef putenv + +static time_t time_t_max; +static time_t time_t_min; + +/* Values we'll use to set the TZ environment variable. */ +static char *tz_strings[] = { + (char *) 0, "TZ=GMT0", "TZ=JST-9", + "TZ=EST+3EDT+2,M10.1.0/00:00:00,M2.3.0/00:00:00" +}; +#define N_STRINGS (sizeof (tz_strings) / sizeof (tz_strings[0])) + +/* Return 0 if mktime fails to convert a date in the spring-forward gap. + Based on a problem report from Andreas Jaeger. */ +static int +spring_forward_gap () +{ + /* glibc (up to about 1998-10-07) failed this test. */ + struct tm tm; + + /* Use the portable POSIX.1 specification "TZ=PST8PDT,M4.1.0,M10.5.0" + instead of "TZ=America/Vancouver" in order to detect the bug even + on systems that don't support the Olson extension, or don't have the + full zoneinfo tables installed. */ + putenv ("TZ=PST8PDT,M4.1.0,M10.5.0"); + + tm.tm_year = 98; + tm.tm_mon = 3; + tm.tm_mday = 5; + tm.tm_hour = 2; + tm.tm_min = 0; + tm.tm_sec = 0; + tm.tm_isdst = -1; + return mktime (&tm) != (time_t) -1; +} + +static int +mktime_test1 (time_t now) +{ + struct tm *lt; + return ! (lt = localtime (&now)) || mktime (lt) == now; +} + +static int +mktime_test (time_t now) +{ + return (mktime_test1 (now) + && mktime_test1 ((time_t) (time_t_max - now)) + && mktime_test1 ((time_t) (time_t_min + now))); +} + +static int +irix_6_4_bug () +{ + /* Based on code from Ariel Faigon. */ + struct tm tm; + tm.tm_year = 96; + tm.tm_mon = 3; + tm.tm_mday = 0; + tm.tm_hour = 0; + tm.tm_min = 0; + tm.tm_sec = 0; + tm.tm_isdst = -1; + mktime (&tm); + return tm.tm_mon == 2 && tm.tm_mday == 31; +} + +static int +bigtime_test (int j) +{ + struct tm tm; + time_t now; + tm.tm_year = tm.tm_mon = tm.tm_mday = tm.tm_hour = tm.tm_min = tm.tm_sec = j; + now = mktime (&tm); + if (now != (time_t) -1) + { + struct tm *lt = localtime (&now); + if (! (lt + && lt->tm_year == tm.tm_year + && lt->tm_mon == tm.tm_mon + && lt->tm_mday == tm.tm_mday + && lt->tm_hour == tm.tm_hour + && lt->tm_min == tm.tm_min + && lt->tm_sec == tm.tm_sec + && lt->tm_yday == tm.tm_yday + && lt->tm_wday == tm.tm_wday + && ((lt->tm_isdst < 0 ? -1 : 0 < lt->tm_isdst) + == (tm.tm_isdst < 0 ? -1 : 0 < tm.tm_isdst)))) + return 0; + } + return 1; +} + +static int +year_2050_test () +{ + /* The correct answer for 2050-02-01 00:00:00 in Pacific time, + ignoring leap seconds. */ + unsigned long int answer = 2527315200UL; + + struct tm tm; + time_t t; + tm.tm_year = 2050 - 1900; + tm.tm_mon = 2 - 1; + tm.tm_mday = 1; + tm.tm_hour = tm.tm_min = tm.tm_sec = 0; + tm.tm_isdst = -1; + + /* Use the portable POSIX.1 specification "TZ=PST8PDT,M4.1.0,M10.5.0" + instead of "TZ=America/Vancouver" in order to detect the bug even + on systems that don't support the Olson extension, or don't have the + full zoneinfo tables installed. */ + putenv ("TZ=PST8PDT,M4.1.0,M10.5.0"); + + t = mktime (&tm); + + /* Check that the result is either a failure, or close enough + to the correct answer that we can assume the discrepancy is + due to leap seconds. */ + return (t == (time_t) -1 + || (0 < t && answer - 120 <= t && t <= answer + 120)); +} + +int +main () +{ + int result = 0; + time_t t, delta; + int i, j; + int time_t_signed_magnitude = (time_t) ~ (time_t) 0 < (time_t) -1; + +#if HAVE_DECL_ALARM + /* This test makes some buggy mktime implementations loop. + Give up after 60 seconds; a mktime slower than that + isn't worth using anyway. */ + signal (SIGALRM, SIG_DFL); + alarm (60); +#endif + + time_t_max = (! TIME_T_IS_SIGNED + ? (time_t) -1 + : ((((time_t) 1 << (sizeof (time_t) * CHAR_BIT - 2)) - 1) + * 2 + 1)); + time_t_min = (! TIME_T_IS_SIGNED + ? (time_t) 0 + : time_t_signed_magnitude + ? ~ (time_t) 0 + : ~ time_t_max); + + delta = time_t_max / 997; /* a suitable prime number */ + for (i = 0; i < N_STRINGS; i++) + { + if (tz_strings[i]) + putenv (tz_strings[i]); + + for (t = 0; t <= time_t_max - delta && (result & 1) == 0; t += delta) + if (! mktime_test (t)) + result |= 1; + if ((result & 2) == 0 + && ! (mktime_test ((time_t) 1) + && mktime_test ((time_t) (60 * 60)) + && mktime_test ((time_t) (60 * 60 * 24)))) + result |= 2; + + for (j = 1; (result & 4) == 0; j <<= 1) + { + if (! bigtime_test (j)) + result |= 4; + if (INT_MAX / 2 < j) + break; + } + if ((result & 8) == 0 && ! bigtime_test (INT_MAX)) + result |= 8; + } + if (! irix_6_4_bug ()) + result |= 16; + if (! spring_forward_gap ()) + result |= 32; + if (! year_2050_test ()) + result |= 64; + return result; +}]])], + [gl_cv_func_working_mktime=yes], + [gl_cv_func_working_mktime=no], + [gl_cv_func_working_mktime=no]) + ]) + + if test $gl_cv_func_working_mktime = no; then + REPLACE_MKTIME=1 + else + REPLACE_MKTIME=0 + fi +]) + +AC_DEFUN([gl_FUNC_MKTIME_INTERNAL], [ + AC_REQUIRE([gl_FUNC_MKTIME]) + if test $REPLACE_MKTIME = 0; then + dnl BeOS has __mktime_internal in libc, but other platforms don't. + AC_CHECK_FUNC([__mktime_internal], + [AC_DEFINE([mktime_internal], [__mktime_internal], + [Define to the real name of the mktime_internal function.]) + ], + [dnl mktime works but it doesn't export __mktime_internal, + dnl so we need to substitute our own mktime implementation. + REPLACE_MKTIME=1 + ]) + fi +]) + +# Prerequisites of lib/mktime.c. +AC_DEFUN([gl_PREREQ_MKTIME], [:]) diff --git a/m4/mmap-anon.m4 b/m4/mmap-anon.m4 index 94ae2e2f2..853c89dc9 100644 --- a/m4/mmap-anon.m4 +++ b/m4/mmap-anon.m4 @@ -1,5 +1,5 @@ # mmap-anon.m4 serial 10 -dnl Copyright (C) 2005, 2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2005, 2007, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mode_t.m4 b/m4/mode_t.m4 index db6e192be..0cd40dba4 100644 --- a/m4/mode_t.m4 +++ b/m4/mode_t.m4 @@ -1,5 +1,5 @@ # mode_t.m4 serial 2 -dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/msvc-inval.m4 b/m4/msvc-inval.m4 index 7f26087e7..f5e4c8930 100644 --- a/m4/msvc-inval.m4 +++ b/m4/msvc-inval.m4 @@ -1,5 +1,5 @@ # msvc-inval.m4 serial 1 -dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/msvc-nothrow.m4 b/m4/msvc-nothrow.m4 index 9e32c171e..58f5c0bc2 100644 --- a/m4/msvc-nothrow.m4 +++ b/m4/msvc-nothrow.m4 @@ -1,5 +1,5 @@ # msvc-nothrow.m4 serial 1 -dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/multiarch.m4 b/m4/multiarch.m4 index 2cb956dee..43b5d0575 100644 --- a/m4/multiarch.m4 +++ b/m4/multiarch.m4 @@ -1,5 +1,5 @@ # multiarch.m4 serial 7 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/netdb_h.m4 b/m4/netdb_h.m4 index cd7d48291..4e5206ceb 100644 --- a/m4/netdb_h.m4 +++ b/m4/netdb_h.m4 @@ -1,5 +1,5 @@ # netdb_h.m4 serial 11 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/netinet_in_h.m4 b/m4/netinet_in_h.m4 index 1d447d6f1..93dcc6894 100644 --- a/m4/netinet_in_h.m4 +++ b/m4/netinet_in_h.m4 @@ -1,5 +1,5 @@ # netinet_in_h.m4 serial 5 -dnl Copyright (C) 2006-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/nl_langinfo.m4 b/m4/nl_langinfo.m4 index 6976e7767..a2f7196eb 100644 --- a/m4/nl_langinfo.m4 +++ b/m4/nl_langinfo.m4 @@ -1,5 +1,5 @@ # nl_langinfo.m4 serial 5 -dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/nocrash.m4 b/m4/nocrash.m4 index 5a5d77d63..d8dd8f13a 100644 --- a/m4/nocrash.m4 +++ b/m4/nocrash.m4 @@ -1,5 +1,5 @@ # nocrash.m4 serial 4 -dnl Copyright (C) 2005, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2005, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -110,11 +110,12 @@ nocrash_init (void) #else /* Avoid a crash on POSIX systems. */ #include +#include /* A POSIX signal handler. */ static void exception_handler (int sig) { - exit (1); + _exit (1); } static void nocrash_init (void) diff --git a/m4/nproc.m4 b/m4/nproc.m4 index 937c4a920..fead2346b 100644 --- a/m4/nproc.m4 +++ b/m4/nproc.m4 @@ -1,5 +1,5 @@ # nproc.m4 serial 4 -dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/off_t.m4 b/m4/off_t.m4 index f5885b34b..282751b47 100644 --- a/m4/off_t.m4 +++ b/m4/off_t.m4 @@ -1,5 +1,5 @@ # off_t.m4 serial 1 -dnl Copyright (C) 2012-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2012-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/open.m4 b/m4/open.m4 index 68f116f0a..53d30381d 100644 --- a/m4/open.m4 +++ b/m4/open.m4 @@ -1,5 +1,5 @@ # open.m4 serial 14 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/pathmax.m4 b/m4/pathmax.m4 index 114f91f04..6f8e59a1a 100644 --- a/m4/pathmax.m4 +++ b/m4/pathmax.m4 @@ -1,5 +1,5 @@ # pathmax.m4 serial 10 -dnl Copyright (C) 2002-2003, 2005-2006, 2009-2014 Free Software Foundation, +dnl Copyright (C) 2002-2003, 2005-2006, 2009-2016 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/pipe.m4 b/m4/pipe.m4 index d3532d5dd..0fe69755f 100644 --- a/m4/pipe.m4 +++ b/m4/pipe.m4 @@ -1,5 +1,5 @@ # pipe.m4 serial 2 -dnl Copyright (C) 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/pipe2.m4 b/m4/pipe2.m4 index 1cff1fef0..c09fceebb 100644 --- a/m4/pipe2.m4 +++ b/m4/pipe2.m4 @@ -1,5 +1,5 @@ # pipe2.m4 serial 2 -dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/poll.m4 b/m4/poll.m4 index f523b1873..edeaaeb8a 100644 --- a/m4/poll.m4 +++ b/m4/poll.m4 @@ -1,5 +1,5 @@ # poll.m4 serial 17 -dnl Copyright (c) 2003, 2005-2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (c) 2003, 2005-2007, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/poll_h.m4 b/m4/poll_h.m4 index fcfe7fa4d..85699e01b 100644 --- a/m4/poll_h.m4 +++ b/m4/poll_h.m4 @@ -1,5 +1,5 @@ # poll_h.m4 serial 2 -dnl Copyright (C) 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/printf.m4 b/m4/printf.m4 index 9346ab041..e495e0cbc 100644 --- a/m4/printf.m4 +++ b/m4/printf.m4 @@ -1,5 +1,5 @@ -# printf.m4 serial 50 -dnl Copyright (C) 2003, 2007-2014 Free Software Foundation, Inc. +# printf.m4 serial 52 +dnl Copyright (C) 2003, 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -61,7 +61,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_printf_sizes_c99="guessing yes";; # Guess yes on FreeBSD >= 5. - freebsd[1-4]*) gl_cv_func_printf_sizes_c99="guessing no";; + freebsd[1-4].*) gl_cv_func_printf_sizes_c99="guessing no";; freebsd* | kfreebsd*) gl_cv_func_printf_sizes_c99="guessing yes";; # Guess yes on Mac OS X >= 10.3. darwin[1-6].*) gl_cv_func_printf_sizes_c99="guessing no";; @@ -220,7 +220,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_printf_infinite="guessing yes";; # Guess yes on FreeBSD >= 6. - freebsd[1-5]*) gl_cv_func_printf_infinite="guessing no";; + freebsd[1-5].*) gl_cv_func_printf_infinite="guessing no";; freebsd* | kfreebsd*) gl_cv_func_printf_infinite="guessing yes";; # Guess yes on Mac OS X >= 10.3. darwin[1-6].*) gl_cv_func_printf_infinite="guessing no";; @@ -328,7 +328,7 @@ int main () # ifdef WORDS_BIGENDIAN # define LDBL80_WORDS(exponent,manthi,mantlo) \ { ((unsigned int) (exponent) << 16) | ((unsigned int) (manthi) >> 16), \ - ((unsigned int) (manthi) << 16) | (unsigned int) (mantlo) >> 16), \ + ((unsigned int) (manthi) << 16) | ((unsigned int) (mantlo) >> 16), \ (unsigned int) (mantlo) << 16 \ } # else @@ -365,66 +365,51 @@ int main () { /* Pseudo-NaN. */ static union { unsigned int word[4]; long double value; } x = { LDBL80_WORDS (0xFFFF, 0x40000001, 0x00000000) }; - if (sprintf (buf, "%Lf", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Lf", x.value) <= 0) result |= 4; - if (sprintf (buf, "%Le", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Le", x.value) <= 0) result |= 4; - if (sprintf (buf, "%Lg", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Lg", x.value) <= 0) result |= 4; } { /* Pseudo-Infinity. */ static union { unsigned int word[4]; long double value; } x = { LDBL80_WORDS (0xFFFF, 0x00000000, 0x00000000) }; - if (sprintf (buf, "%Lf", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Lf", x.value) <= 0) result |= 8; - if (sprintf (buf, "%Le", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Le", x.value) <= 0) result |= 8; - if (sprintf (buf, "%Lg", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Lg", x.value) <= 0) result |= 8; } { /* Pseudo-Zero. */ static union { unsigned int word[4]; long double value; } x = { LDBL80_WORDS (0x4004, 0x00000000, 0x00000000) }; - if (sprintf (buf, "%Lf", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Lf", x.value) <= 0) result |= 16; - if (sprintf (buf, "%Le", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Le", x.value) <= 0) result |= 16; - if (sprintf (buf, "%Lg", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Lg", x.value) <= 0) result |= 16; } { /* Unnormalized number. */ static union { unsigned int word[4]; long double value; } x = { LDBL80_WORDS (0x4000, 0x63333333, 0x00000000) }; - if (sprintf (buf, "%Lf", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Lf", x.value) <= 0) result |= 32; - if (sprintf (buf, "%Le", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Le", x.value) <= 0) result |= 32; - if (sprintf (buf, "%Lg", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Lg", x.value) <= 0) result |= 32; } { /* Pseudo-Denormal. */ static union { unsigned int word[4]; long double value; } x = { LDBL80_WORDS (0x0000, 0x83333333, 0x00000000) }; - if (sprintf (buf, "%Lf", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Lf", x.value) <= 0) result |= 64; - if (sprintf (buf, "%Le", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Le", x.value) <= 0) result |= 64; - if (sprintf (buf, "%Lg", x.value) < 0 - || !strisnan (buf, 0, strlen (buf))) + if (sprintf (buf, "%Lg", x.value) <= 0) result |= 64; } #endif @@ -442,7 +427,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_printf_infinite_long_double="guessing yes";; # Guess yes on FreeBSD >= 6. - freebsd[1-5]*) gl_cv_func_printf_infinite_long_double="guessing no";; + freebsd[1-5].*) gl_cv_func_printf_infinite_long_double="guessing no";; freebsd* | kfreebsd*) gl_cv_func_printf_infinite_long_double="guessing yes";; # Guess yes on HP-UX >= 11. hpux[7-9]* | hpux10*) gl_cv_func_printf_infinite_long_double="guessing no";; @@ -588,7 +573,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_printf_directive_f="guessing yes";; # Guess yes on FreeBSD >= 6. - freebsd[1-5]*) gl_cv_func_printf_directive_f="guessing no";; + freebsd[1-5].*) gl_cv_func_printf_directive_f="guessing no";; freebsd* | kfreebsd*) gl_cv_func_printf_directive_f="guessing yes";; # Guess yes on Mac OS X >= 10.3. darwin[1-6].*) gl_cv_func_printf_directive_f="guessing no";; @@ -1136,7 +1121,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_snprintf_truncation_c99="guessing yes";; # Guess yes on FreeBSD >= 5. - freebsd[1-4]*) gl_cv_func_snprintf_truncation_c99="guessing no";; + freebsd[1-4].*) gl_cv_func_snprintf_truncation_c99="guessing no";; freebsd* | kfreebsd*) gl_cv_func_snprintf_truncation_c99="guessing yes";; # Guess yes on Mac OS X >= 10.3. darwin[1-6].*) gl_cv_func_snprintf_truncation_c99="guessing no";; @@ -1235,7 +1220,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_snprintf_retval_c99="guessing yes";; # Guess yes on FreeBSD >= 5. - freebsd[1-4]*) gl_cv_func_snprintf_retval_c99="guessing no";; + freebsd[1-4].*) gl_cv_func_snprintf_retval_c99="guessing no";; freebsd* | kfreebsd*) gl_cv_func_snprintf_retval_c99="guessing yes";; # Guess yes on Mac OS X >= 10.3. darwin[1-6].*) gl_cv_func_snprintf_retval_c99="guessing no";; @@ -1316,7 +1301,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_snprintf_directive_n="guessing yes";; # Guess yes on FreeBSD >= 5. - freebsd[1-4]*) gl_cv_func_snprintf_directive_n="guessing no";; + freebsd[1-4].*) gl_cv_func_snprintf_directive_n="guessing no";; freebsd* | kfreebsd*) gl_cv_func_snprintf_directive_n="guessing yes";; # Guess yes on Mac OS X >= 10.3. darwin[1-6].*) gl_cv_func_snprintf_directive_n="guessing no";; @@ -1458,7 +1443,7 @@ changequote(,)dnl # Guess yes on glibc systems. *-gnu*) gl_cv_func_vsnprintf_zerosize_c99="guessing yes";; # Guess yes on FreeBSD >= 5. - freebsd[1-4]*) gl_cv_func_vsnprintf_zerosize_c99="guessing no";; + freebsd[1-4].*) gl_cv_func_vsnprintf_zerosize_c99="guessing no";; freebsd* | kfreebsd*) gl_cv_func_vsnprintf_zerosize_c99="guessing yes";; # Guess yes on Mac OS X >= 10.3. darwin[1-6].*) gl_cv_func_vsnprintf_zerosize_c99="guessing no";; diff --git a/m4/putenv.m4 b/m4/putenv.m4 index d79321be9..c3c30d845 100644 --- a/m4/putenv.m4 +++ b/m4/putenv.m4 @@ -1,5 +1,5 @@ # putenv.m4 serial 20 -dnl Copyright (C) 2002-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/raise.m4 b/m4/raise.m4 index 8656578ef..71c1f4c37 100644 --- a/m4/raise.m4 +++ b/m4/raise.m4 @@ -1,5 +1,5 @@ # raise.m4 serial 3 -dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/read.m4 b/m4/read.m4 index 176b0b04d..5a18c11d0 100644 --- a/m4/read.m4 +++ b/m4/read.m4 @@ -1,5 +1,5 @@ # read.m4 serial 4 -dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/readlink.m4 b/m4/readlink.m4 index f9ce868c2..ede0378b4 100644 --- a/m4/readlink.m4 +++ b/m4/readlink.m4 @@ -1,5 +1,5 @@ # readlink.m4 serial 12 -dnl Copyright (C) 2003, 2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2007, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/regex.m4 b/m4/regex.m4 index 08bd46a96..abfd262de 100644 --- a/m4/regex.m4 +++ b/m4/regex.m4 @@ -1,6 +1,6 @@ -# serial 65 +# serial 66 -# Copyright (C) 1996-2001, 2003-2014 Free Software Foundation, Inc. +# Copyright (C) 1996-2001, 2003-2016 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -93,6 +93,7 @@ AC_DEFUN([gl_REGEX], 0, sizeof data - 1, ®s) != -1) result |= 1; + regfree (®ex); } { @@ -124,6 +125,7 @@ AC_DEFUN([gl_REGEX], if (i != 0 && i != 21) result |= 1; } + regfree (®ex); } if (! setlocale (LC_ALL, "C")) diff --git a/m4/rename.m4 b/m4/rename.m4 index ea5779491..fbcc758d5 100644 --- a/m4/rename.m4 +++ b/m4/rename.m4 @@ -1,6 +1,6 @@ # serial 26 -# Copyright (C) 2001, 2003, 2005-2006, 2009-2014 Free Software Foundation, Inc. +# Copyright (C) 2001, 2003, 2005-2006, 2009-2016 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/rmdir.m4 b/m4/rmdir.m4 index db6a9399c..ebb3b5db1 100644 --- a/m4/rmdir.m4 +++ b/m4/rmdir.m4 @@ -1,5 +1,5 @@ # rmdir.m4 serial 13 -dnl Copyright (C) 2002, 2005, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002, 2005, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/round.m4 b/m4/round.m4 index 13049b7cf..35ffa40ee 100644 --- a/m4/round.m4 +++ b/m4/round.m4 @@ -1,5 +1,5 @@ # round.m4 serial 16 -dnl Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/safe-read.m4 b/m4/safe-read.m4 index f0c42e08f..2221682ef 100644 --- a/m4/safe-read.m4 +++ b/m4/safe-read.m4 @@ -1,5 +1,5 @@ # safe-read.m4 serial 6 -dnl Copyright (C) 2002-2003, 2005-2006, 2009-2014 Free Software Foundation, +dnl Copyright (C) 2002-2003, 2005-2006, 2009-2016 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/safe-write.m4 b/m4/safe-write.m4 index 66648bbb5..a99fb1f10 100644 --- a/m4/safe-write.m4 +++ b/m4/safe-write.m4 @@ -1,5 +1,5 @@ # safe-write.m4 serial 4 -dnl Copyright (C) 2002, 2005-2006, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002, 2005-2006, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/secure_getenv.m4 b/m4/secure_getenv.m4 index 149888df4..398317360 100644 --- a/m4/secure_getenv.m4 +++ b/m4/secure_getenv.m4 @@ -1,5 +1,5 @@ # Look up an environment variable more securely. -dnl Copyright 2013-2014 Free Software Foundation, Inc. +dnl Copyright 2013-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -22,4 +22,5 @@ AC_DEFUN([gl_PREREQ_SECURE_GETENV], [ if test $ac_cv_func___secure_getenv = no; then AC_CHECK_FUNCS([issetugid]) fi + AC_CHECK_FUNCS_ONCE([getuid geteuid getgid getegid]) ]) diff --git a/m4/select.m4 b/m4/select.m4 index 1d2fcb373..d19365541 100644 --- a/m4/select.m4 +++ b/m4/select.m4 @@ -1,5 +1,5 @@ -# select.m4 serial 7 -dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. +# select.m4 serial 8 +dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -7,6 +7,7 @@ dnl with or without modifications, as long as this notice is preserved. AC_DEFUN([gl_FUNC_SELECT], [ AC_REQUIRE([gl_HEADER_SYS_SELECT]) + AC_REQUIRE([AC_C_RESTRICT]) AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles AC_REQUIRE([gl_SOCKETS]) if test "$ac_cv_header_winsock2_h" = yes; then diff --git a/m4/servent.m4 b/m4/servent.m4 index 4dc7a9f70..182e7f627 100644 --- a/m4/servent.m4 +++ b/m4/servent.m4 @@ -1,5 +1,5 @@ # servent.m4 serial 2 -dnl Copyright (C) 2008, 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008, 2010-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/setenv.m4 b/m4/setenv.m4 index 0f46a7bec..5d49aba60 100644 --- a/m4/setenv.m4 +++ b/m4/setenv.m4 @@ -1,5 +1,5 @@ # setenv.m4 serial 26 -dnl Copyright (C) 2001-2004, 2006-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2004, 2006-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/signal_h.m4 b/m4/signal_h.m4 index c8f664fbf..bcfd7b4be 100644 --- a/m4/signal_h.m4 +++ b/m4/signal_h.m4 @@ -1,5 +1,5 @@ # signal_h.m4 serial 18 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/signbit.m4 b/m4/signbit.m4 index 9ed48c780..e42f18319 100644 --- a/m4/signbit.m4 +++ b/m4/signbit.m4 @@ -1,5 +1,5 @@ # signbit.m4 serial 13 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/size_max.m4 b/m4/size_max.m4 index 7e192d5e9..de69025d6 100644 --- a/m4/size_max.m4 +++ b/m4/size_max.m4 @@ -1,5 +1,5 @@ # size_max.m4 serial 10 -dnl Copyright (C) 2003, 2005-2006, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2005-2006, 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/snprintf.m4 b/m4/snprintf.m4 index 888db35c0..f876b5599 100644 --- a/m4/snprintf.m4 +++ b/m4/snprintf.m4 @@ -1,5 +1,5 @@ # snprintf.m4 serial 6 -dnl Copyright (C) 2002-2004, 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2004, 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/socketlib.m4 b/m4/socketlib.m4 index 041498baf..5da64fcac 100644 --- a/m4/socketlib.m4 +++ b/m4/socketlib.m4 @@ -1,5 +1,5 @@ # socketlib.m4 serial 1 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sockets.m4 b/m4/sockets.m4 index da6ff7427..7e77a62e8 100644 --- a/m4/sockets.m4 +++ b/m4/sockets.m4 @@ -1,5 +1,5 @@ # sockets.m4 serial 7 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/socklen.m4 b/m4/socklen.m4 index 4c07f864c..634c43a35 100644 --- a/m4/socklen.m4 +++ b/m4/socklen.m4 @@ -1,5 +1,5 @@ # socklen.m4 serial 10 -dnl Copyright (C) 2005-2007, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2005-2007, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sockpfaf.m4 b/m4/sockpfaf.m4 index 31d436f0e..dce8b8f01 100644 --- a/m4/sockpfaf.m4 +++ b/m4/sockpfaf.m4 @@ -1,5 +1,5 @@ # sockpfaf.m4 serial 8 -dnl Copyright (C) 2004, 2006, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2004, 2006, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/ssize_t.m4 b/m4/ssize_t.m4 index fbe1d0687..3e7b9e6e0 100644 --- a/m4/ssize_t.m4 +++ b/m4/ssize_t.m4 @@ -1,5 +1,5 @@ # ssize_t.m4 serial 5 (gettext-0.18.2) -dnl Copyright (C) 2001-2003, 2006, 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2003, 2006, 2010-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/stat-time.m4 b/m4/stat-time.m4 index ea5c4fc59..231cb7403 100644 --- a/m4/stat-time.m4 +++ b/m4/stat-time.m4 @@ -1,6 +1,6 @@ # Checks for stat-related time functions. -# Copyright (C) 1998-1999, 2001, 2003, 2005-2007, 2009-2014 Free Software +# Copyright (C) 1998-1999, 2001, 2003, 2005-2007, 2009-2016 Free Software # Foundation, Inc. # This file is free software; the Free Software Foundation diff --git a/m4/stat.m4 b/m4/stat.m4 index 1ae327b36..a794975de 100644 --- a/m4/stat.m4 +++ b/m4/stat.m4 @@ -1,6 +1,6 @@ # serial 11 -# Copyright (C) 2009-2014 Free Software Foundation, Inc. +# Copyright (C) 2009-2016 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, diff --git a/m4/stdalign.m4 b/m4/stdalign.m4 index 9efafe5c5..49980cd63 100644 --- a/m4/stdalign.m4 +++ b/m4/stdalign.m4 @@ -1,6 +1,6 @@ # Check for stdalign.h that conforms to C11. -dnl Copyright 2011-2014 Free Software Foundation, Inc. +dnl Copyright 2011-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -32,8 +32,12 @@ AC_DEFUN([gl_STDALIGN_H], /* Test _Alignas only on platforms where gnulib can help. */ #if \ ((defined __cplusplus && 201103 <= __cplusplus) \ - || __GNUC__ || __IBMC__ || __IBMCPP__ || __ICC \ - || 0x5110 <= __SUNPRO_C || 1300 <= _MSC_VER) + || (defined __APPLE__ && defined __MACH__ \ + ? 4 < __GNUC__ + (1 <= __GNUC_MINOR__) \ + : __GNUC__) \ + || __HP_cc || __HP_aCC || __IBMC__ || __IBMCPP__ \ + || __ICC || 0x5110 <= __SUNPRO_C \ + || 1300 <= _MSC_VER) struct alignas_test { char c; char alignas (8) alignas_8; }; char test_alignas[offsetof (struct alignas_test, alignas_8) == 8 ? 1 : -1]; diff --git a/m4/stdbool.m4 b/m4/stdbool.m4 index 006ed52de..a55615318 100644 --- a/m4/stdbool.m4 +++ b/m4/stdbool.m4 @@ -1,11 +1,11 @@ # Check for stdbool.h that conforms to C99. -dnl Copyright (C) 2002-2006, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2006, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. -#serial 5 +#serial 6 # Prepare for substituting if it is not supported. @@ -43,21 +43,25 @@ AC_DEFUN([AC_CHECK_HEADER_STDBOOL], [AC_LANG_PROGRAM( [[ #include - #ifndef bool - "error: bool is not defined" - #endif - #ifndef false - "error: false is not defined" - #endif - #if false - "error: false is not 0" - #endif - #ifndef true - "error: true is not defined" - #endif - #if true != 1 - "error: true is not 1" + + #if __cplusplus < 201103 + #ifndef bool + "error: bool is not defined" + #endif + #ifndef false + "error: false is not defined" + #endif + #if false + "error: false is not 0" + #endif + #ifndef true + "error: true is not defined" + #endif + #if true != 1 + "error: true is not 1" + #endif #endif + #ifndef __bool_true_false_are_defined "error: __bool_true_false_are_defined is not defined" #endif diff --git a/m4/stddef_h.m4 b/m4/stddef_h.m4 index c555e2952..c045c65f9 100644 --- a/m4/stddef_h.m4 +++ b/m4/stddef_h.m4 @@ -1,6 +1,6 @@ -dnl A placeholder for POSIX 2008 , for platforms that have issues. -# stddef_h.m4 serial 4 -dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. +dnl A placeholder for , for platforms that have issues. +# stddef_h.m4 serial 5 +dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -10,6 +10,9 @@ AC_DEFUN([gl_STDDEF_H], AC_REQUIRE([gl_STDDEF_H_DEFAULTS]) AC_REQUIRE([gt_TYPE_WCHAR_T]) STDDEF_H= + AC_CHECK_TYPE([max_align_t], [], [HAVE_MAX_ALIGN_T=0; STDDEF_H=stddef.h], + [[#include + ]]) if test $gt_cv_c_wchar_t = no; then HAVE_WCHAR_T=0 STDDEF_H=stddef.h @@ -43,5 +46,6 @@ AC_DEFUN([gl_STDDEF_H_DEFAULTS], [ dnl Assume proper GNU behavior unless another module says otherwise. REPLACE_NULL=0; AC_SUBST([REPLACE_NULL]) + HAVE_MAX_ALIGN_T=1; AC_SUBST([HAVE_MAX_ALIGN_T]) HAVE_WCHAR_T=1; AC_SUBST([HAVE_WCHAR_T]) ]) diff --git a/m4/stdint.m4 b/m4/stdint.m4 index 1981d9dbc..0b4b9060d 100644 --- a/m4/stdint.m4 +++ b/m4/stdint.m4 @@ -1,5 +1,5 @@ -# stdint.m4 serial 43 -dnl Copyright (C) 2001-2014 Free Software Foundation, Inc. +# stdint.m4 serial 44 +dnl Copyright (C) 2001-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -70,6 +70,8 @@ AC_DEFUN_ONCE([gl_STDINT_H], AC_COMPILE_IFELSE([ AC_LANG_PROGRAM([[ #define _GL_JUST_INCLUDE_SYSTEM_STDINT_H 1 /* work if build isn't clean */ +#define __STDC_CONSTANT_MACROS 1 +#define __STDC_LIMIT_MACROS 1 #include /* Dragonfly defines WCHAR_MIN, WCHAR_MAX only in . */ #if !(defined WCHAR_MIN && defined WCHAR_MAX) @@ -218,6 +220,8 @@ struct s { AC_RUN_IFELSE([ AC_LANG_PROGRAM([[ #define _GL_JUST_INCLUDE_SYSTEM_STDINT_H 1 /* work if build isn't clean */ +#define __STDC_CONSTANT_MACROS 1 +#define __STDC_LIMIT_MACROS 1 #include ] gl_STDINT_INCLUDES @@ -279,6 +283,29 @@ static const char *macro_values[] = ]) fi if test "$gl_cv_header_working_stdint_h" = yes; then + dnl Now see whether the system works without + dnl __STDC_CONSTANT_MACROS/__STDC_LIMIT_MACROS defined. + AC_CACHE_CHECK([whether stdint.h predates C++11], + [gl_cv_header_stdint_predates_cxx11_h], + [gl_cv_header_stdint_predates_cxx11_h=yes + AC_COMPILE_IFELSE([ + AC_LANG_PROGRAM([[ +#define _GL_JUST_INCLUDE_SYSTEM_STDINT_H 1 /* work if build isn't clean */ +#include +] +gl_STDINT_INCLUDES +[ +intmax_t im = INTMAX_MAX; +int32_t i32 = INT32_C (0x7fffffff); + ]])], + [gl_cv_header_stdint_predates_cxx11_h=no])]) + + if test "$gl_cv_header_stdint_predates_cxx11_h" = yes; then + AC_DEFINE([__STDC_CONSTANT_MACROS], [1], + [Define to 1 if the system predates C++11.]) + AC_DEFINE([__STDC_LIMIT_MACROS], [1], + [Define to 1 if the system predates C++11.]) + fi STDINT_H= else dnl Check for , and for diff --git a/m4/stdint_h.m4 b/m4/stdint_h.m4 index 7fc2ce9a8..f823b94c3 100644 --- a/m4/stdint_h.m4 +++ b/m4/stdint_h.m4 @@ -1,5 +1,5 @@ # stdint_h.m4 serial 9 -dnl Copyright (C) 1997-2004, 2006, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 1997-2004, 2006, 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/stdio_h.m4 b/m4/stdio_h.m4 index d15913a3c..0e387585d 100644 --- a/m4/stdio_h.m4 +++ b/m4/stdio_h.m4 @@ -1,14 +1,41 @@ -# stdio_h.m4 serial 43 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +# stdio_h.m4 serial 46 +dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. AC_DEFUN([gl_STDIO_H], [ + dnl For __USE_MINGW_ANSI_STDIO + AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) + AC_REQUIRE([gl_STDIO_H_DEFAULTS]) gl_NEXT_HEADERS([stdio.h]) + dnl Determine whether __USE_MINGW_ANSI_STDIO makes printf and + dnl inttypes.h behave like gnu instead of system; we must give our + dnl printf wrapper the right attribute to match. + AC_CACHE_CHECK([which flavor of printf attribute matches inttypes macros], + [gl_cv_func_printf_attribute_flavor], + [AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[ + #define __STDC_FORMAT_MACROS 1 + #include + #include + /* For non-mingw systems, compilation will trivially succeed. + For mingw, compilation will succeed for older mingw (system + printf, "I64d") and fail for newer mingw (gnu printf, "lld"). */ + #if ((defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__) && \ + (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 4)) + extern char PRIdMAX_probe[sizeof PRIdMAX == sizeof "I64d" ? 1 : -1]; + #endif + ]])], [gl_cv_func_printf_attribute_flavor=system], + [gl_cv_func_printf_attribute_flavor=gnu])]) + if test "$gl_cv_func_printf_attribute_flavor" = gnu; then + AC_DEFINE([GNULIB_PRINTF_ATTRIBUTE_FLAVOR_GNU], [1], + [Define to 1 if printf and friends should be labeled with + attribute "__gnu_printf__" instead of "__printf__"]) + fi + dnl No need to create extra modules for these functions. Everyone who uses dnl likely needs them. GNULIB_FSCANF=1 diff --git a/m4/stdlib_h.m4 b/m4/stdlib_h.m4 index 03b448b94..19107c419 100644 --- a/m4/stdlib_h.m4 +++ b/m4/stdlib_h.m4 @@ -1,5 +1,5 @@ # stdlib_h.m4 serial 42 -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -55,6 +55,7 @@ AC_DEFUN([gl_STDLIB_H_DEFAULTS], GNULIB_PTSNAME=0; AC_SUBST([GNULIB_PTSNAME]) GNULIB_PTSNAME_R=0; AC_SUBST([GNULIB_PTSNAME_R]) GNULIB_PUTENV=0; AC_SUBST([GNULIB_PUTENV]) + GNULIB_QSORT_R=0; AC_SUBST([GNULIB_QSORT_R]) GNULIB_RANDOM=0; AC_SUBST([GNULIB_RANDOM]) GNULIB_RANDOM_R=0; AC_SUBST([GNULIB_RANDOM_R]) GNULIB_REALLOC_POSIX=0; AC_SUBST([GNULIB_REALLOC_POSIX]) @@ -107,6 +108,7 @@ AC_DEFUN([gl_STDLIB_H_DEFAULTS], REPLACE_PTSNAME=0; AC_SUBST([REPLACE_PTSNAME]) REPLACE_PTSNAME_R=0; AC_SUBST([REPLACE_PTSNAME_R]) REPLACE_PUTENV=0; AC_SUBST([REPLACE_PUTENV]) + REPLACE_QSORT_R=0; AC_SUBST([REPLACE_QSORT_R]) REPLACE_RANDOM_R=0; AC_SUBST([REPLACE_RANDOM_R]) REPLACE_REALLOC=0; AC_SUBST([REPLACE_REALLOC]) REPLACE_REALPATH=0; AC_SUBST([REPLACE_REALPATH]) diff --git a/m4/strdup.m4 b/m4/strdup.m4 index 1681a30eb..ff7060abd 100644 --- a/m4/strdup.m4 +++ b/m4/strdup.m4 @@ -1,6 +1,6 @@ # strdup.m4 serial 13 -dnl Copyright (C) 2002-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/strftime.m4 b/m4/strftime.m4 index 0ba3dd074..9598e7272 100644 --- a/m4/strftime.m4 +++ b/m4/strftime.m4 @@ -1,6 +1,6 @@ # serial 33 -# Copyright (C) 1996-1997, 1999-2007, 2009-2014 Free Software Foundation, Inc. +# Copyright (C) 1996-1997, 1999-2007, 2009-2016 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, diff --git a/m4/string_h.m4 b/m4/string_h.m4 index 64e683f9d..0c5ec6f9a 100644 --- a/m4/string_h.m4 +++ b/m4/string_h.m4 @@ -1,6 +1,6 @@ # Configure a GNU-like replacement for . -# Copyright (C) 2007-2014 Free Software Foundation, Inc. +# Copyright (C) 2007-2016 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_file_h.m4 b/m4/sys_file_h.m4 index ad78efb9c..cacc625a0 100644 --- a/m4/sys_file_h.m4 +++ b/m4/sys_file_h.m4 @@ -1,7 +1,7 @@ # Configure a replacement for . # serial 6 -# Copyright (C) 2008-2014 Free Software Foundation, Inc. +# Copyright (C) 2008-2016 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_select_h.m4 b/m4/sys_select_h.m4 index 1a502b4eb..23526e5f5 100644 --- a/m4/sys_select_h.m4 +++ b/m4/sys_select_h.m4 @@ -1,5 +1,5 @@ # sys_select_h.m4 serial 20 -dnl Copyright (C) 2006-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_socket_h.m4 b/m4/sys_socket_h.m4 index 114d82817..ae500c760 100644 --- a/m4/sys_socket_h.m4 +++ b/m4/sys_socket_h.m4 @@ -1,5 +1,5 @@ # sys_socket_h.m4 serial 23 -dnl Copyright (C) 2005-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2005-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_stat_h.m4 b/m4/sys_stat_h.m4 index eaa7642ba..3d43b6f5e 100644 --- a/m4/sys_stat_h.m4 +++ b/m4/sys_stat_h.m4 @@ -1,5 +1,5 @@ # sys_stat_h.m4 serial 28 -*- Autoconf -*- -dnl Copyright (C) 2006-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_time_h.m4 b/m4/sys_time_h.m4 index 5c79300f8..3061a9c18 100644 --- a/m4/sys_time_h.m4 +++ b/m4/sys_time_h.m4 @@ -1,7 +1,7 @@ # Configure a replacement for . # serial 8 -# Copyright (C) 2007, 2009-2014 Free Software Foundation, Inc. +# Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. @@ -105,6 +105,7 @@ AC_DEFUN([gl_HEADER_SYS_TIME_H_DEFAULTS], HAVE_GETTIMEOFDAY=1; AC_SUBST([HAVE_GETTIMEOFDAY]) HAVE_STRUCT_TIMEVAL=1; AC_SUBST([HAVE_STRUCT_TIMEVAL]) HAVE_SYS_TIME_H=1; AC_SUBST([HAVE_SYS_TIME_H]) + HAVE_TIMEZONE_T=0; AC_SUBST([HAVE_TIMEZONE_T]) REPLACE_GETTIMEOFDAY=0; AC_SUBST([REPLACE_GETTIMEOFDAY]) REPLACE_STRUCT_TIMEVAL=0; AC_SUBST([REPLACE_STRUCT_TIMEVAL]) ]) diff --git a/m4/sys_times_h.m4 b/m4/sys_times_h.m4 index fad63c4f0..e472e717a 100644 --- a/m4/sys_times_h.m4 +++ b/m4/sys_times_h.m4 @@ -1,7 +1,7 @@ # Configure a replacement for . # serial 8 -# Copyright (C) 2008-2014 Free Software Foundation, Inc. +# Copyright (C) 2008-2016 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_types_h.m4 b/m4/sys_types_h.m4 index 9748905b5..b0aabb478 100644 --- a/m4/sys_types_h.m4 +++ b/m4/sys_types_h.m4 @@ -1,5 +1,5 @@ # sys_types_h.m4 serial 5 -dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_uio_h.m4 b/m4/sys_uio_h.m4 index ba6b4b5ed..d4d967fd5 100644 --- a/m4/sys_uio_h.m4 +++ b/m4/sys_uio_h.m4 @@ -1,5 +1,5 @@ # sys_uio_h.m4 serial 1 -dnl Copyright (C) 2011-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/tempname.m4 b/m4/tempname.m4 index 1594e1f5d..acf4c8d07 100644 --- a/m4/tempname.m4 +++ b/m4/tempname.m4 @@ -1,6 +1,6 @@ #serial 5 -# Copyright (C) 2006-2007, 2009-2014 Free Software Foundation, Inc. +# Copyright (C) 2006-2007, 2009-2016 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/time_h.m4 b/m4/time_h.m4 index 9852778f9..eb2a631e2 100644 --- a/m4/time_h.m4 +++ b/m4/time_h.m4 @@ -1,8 +1,8 @@ # Configure a more-standard replacement for . -# Copyright (C) 2000-2001, 2003-2007, 2009-2014 Free Software Foundation, Inc. +# Copyright (C) 2000-2001, 2003-2007, 2009-2016 Free Software Foundation, Inc. -# serial 8 +# serial 9 # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -26,7 +26,7 @@ AC_DEFUN([gl_HEADER_TIME_H_BODY], ]) dnl Check whether 'struct timespec' is declared -dnl in time.h, sys/time.h, or pthread.h. +dnl in time.h, sys/time.h, pthread.h, or unistd.h. AC_DEFUN([gl_CHECK_TYPE_STRUCT_TIMESPEC], [ @@ -44,6 +44,7 @@ AC_DEFUN([gl_CHECK_TYPE_STRUCT_TIMESPEC], TIME_H_DEFINES_STRUCT_TIMESPEC=0 SYS_TIME_H_DEFINES_STRUCT_TIMESPEC=0 PTHREAD_H_DEFINES_STRUCT_TIMESPEC=0 + UNISTD_H_DEFINES_STRUCT_TIMESPEC=0 if test $gl_cv_sys_struct_timespec_in_time_h = yes; then TIME_H_DEFINES_STRUCT_TIMESPEC=1 else @@ -70,12 +71,26 @@ AC_DEFUN([gl_CHECK_TYPE_STRUCT_TIMESPEC], [gl_cv_sys_struct_timespec_in_pthread_h=no])]) if test $gl_cv_sys_struct_timespec_in_pthread_h = yes; then PTHREAD_H_DEFINES_STRUCT_TIMESPEC=1 + else + AC_CACHE_CHECK([for struct timespec in ], + [gl_cv_sys_struct_timespec_in_unistd_h], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM( + [[#include + ]], + [[static struct timespec x; x.tv_sec = x.tv_nsec;]])], + [gl_cv_sys_struct_timespec_in_unistd_h=yes], + [gl_cv_sys_struct_timespec_in_unistd_h=no])]) + if test $gl_cv_sys_struct_timespec_in_unistd_h = yes; then + UNISTD_H_DEFINES_STRUCT_TIMESPEC=1 + fi fi fi fi AC_SUBST([TIME_H_DEFINES_STRUCT_TIMESPEC]) AC_SUBST([SYS_TIME_H_DEFINES_STRUCT_TIMESPEC]) AC_SUBST([PTHREAD_H_DEFINES_STRUCT_TIMESPEC]) + AC_SUBST([UNISTD_H_DEFINES_STRUCT_TIMESPEC]) ]) AC_DEFUN([gl_TIME_MODULE_INDICATOR], @@ -94,6 +109,7 @@ AC_DEFUN([gl_HEADER_TIME_H_DEFAULTS], GNULIB_STRPTIME=0; AC_SUBST([GNULIB_STRPTIME]) GNULIB_TIMEGM=0; AC_SUBST([GNULIB_TIMEGM]) GNULIB_TIME_R=0; AC_SUBST([GNULIB_TIME_R]) + GNULIB_TIME_RZ=0; AC_SUBST([GNULIB_TIME_RZ]) dnl Assume proper GNU behavior unless another module says otherwise. HAVE_DECL_LOCALTIME_R=1; AC_SUBST([HAVE_DECL_LOCALTIME_R]) HAVE_NANOSLEEP=1; AC_SUBST([HAVE_NANOSLEEP]) diff --git a/m4/time_r.m4 b/m4/time_r.m4 index 7e15600f7..21b4a2cc1 100644 --- a/m4/time_r.m4 +++ b/m4/time_r.m4 @@ -1,6 +1,6 @@ dnl Reentrant time functions: localtime_r, gmtime_r. -dnl Copyright (C) 2003, 2006-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2006-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/time_rz.m4 b/m4/time_rz.m4 new file mode 100644 index 000000000..9b1db1b24 --- /dev/null +++ b/m4/time_rz.m4 @@ -0,0 +1,21 @@ +dnl Time zone functions: tzalloc, localtime_rz, etc. + +dnl Copyright (C) 2015-2016 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl Written by Paul Eggert. + +AC_DEFUN([gl_TIME_RZ], +[ + AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) + AC_REQUIRE([gl_HEADER_SYS_TIME_H_DEFAULTS]) + AC_REQUIRE([AC_STRUCT_TIMEZONE]) + AC_CHECK_FUNCS_ONCE([tzset]) + + AC_CHECK_TYPES([timezone_t], [], [], [[#include ]]) + if test "$ac_cv_type_timezone_t" = yes; then + HAVE_TIMEZONE_T=1 + fi +]) diff --git a/m4/timegm.m4 b/m4/timegm.m4 new file mode 100644 index 000000000..752aa43d7 --- /dev/null +++ b/m4/timegm.m4 @@ -0,0 +1,26 @@ +# timegm.m4 serial 11 +dnl Copyright (C) 2003, 2007, 2009-2016 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_FUNC_TIMEGM], +[ + AC_REQUIRE([gl_HEADER_TIME_H_DEFAULTS]) + AC_REQUIRE([gl_FUNC_MKTIME]) + REPLACE_TIMEGM=0 + AC_CHECK_FUNCS_ONCE([timegm]) + if test $ac_cv_func_timegm = yes; then + if test $gl_cv_func_working_mktime = no; then + # Assume that timegm is buggy if mktime is. + REPLACE_TIMEGM=1 + fi + else + HAVE_TIMEGM=0 + fi +]) + +# Prerequisites of lib/timegm.c. +AC_DEFUN([gl_PREREQ_TIMEGM], [ + : +]) diff --git a/m4/times.m4 b/m4/times.m4 index 3ee364b8c..ad44c5c7f 100644 --- a/m4/times.m4 +++ b/m4/times.m4 @@ -1,5 +1,5 @@ # times.m4 serial 2 -dnl Copyright (C) 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/tm_gmtoff.m4 b/m4/tm_gmtoff.m4 index 486351b47..ce0671fd1 100644 --- a/m4/tm_gmtoff.m4 +++ b/m4/tm_gmtoff.m4 @@ -1,5 +1,5 @@ # tm_gmtoff.m4 serial 3 -dnl Copyright (C) 2002, 2009-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002, 2009-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/trunc.m4 b/m4/trunc.m4 index ba87bd0c0..4759b47f2 100644 --- a/m4/trunc.m4 +++ b/m4/trunc.m4 @@ -1,5 +1,5 @@ # trunc.m4 serial 9 -dnl Copyright (C) 2007, 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2010-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/unistd_h.m4 b/m4/unistd_h.m4 index 1fa197e69..544dadb41 100644 --- a/m4/unistd_h.m4 +++ b/m4/unistd_h.m4 @@ -1,5 +1,5 @@ -# unistd_h.m4 serial 67 -dnl Copyright (C) 2006-2014 Free Software Foundation, Inc. +# unistd_h.m4 serial 68 +dnl Copyright (C) 2006-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -173,9 +173,11 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS], REPLACE_PWRITE=0; AC_SUBST([REPLACE_PWRITE]) REPLACE_READ=0; AC_SUBST([REPLACE_READ]) REPLACE_READLINK=0; AC_SUBST([REPLACE_READLINK]) + REPLACE_READLINKAT=0; AC_SUBST([REPLACE_READLINKAT]) REPLACE_RMDIR=0; AC_SUBST([REPLACE_RMDIR]) REPLACE_SLEEP=0; AC_SUBST([REPLACE_SLEEP]) REPLACE_SYMLINK=0; AC_SUBST([REPLACE_SYMLINK]) + REPLACE_SYMLINKAT=0; AC_SUBST([REPLACE_SYMLINKAT]) REPLACE_TTYNAME_R=0; AC_SUBST([REPLACE_TTYNAME_R]) REPLACE_UNLINK=0; AC_SUBST([REPLACE_UNLINK]) REPLACE_UNLINKAT=0; AC_SUBST([REPLACE_UNLINKAT]) diff --git a/m4/vasnprintf.m4 b/m4/vasnprintf.m4 index 106192ea2..2d4b46310 100644 --- a/m4/vasnprintf.m4 +++ b/m4/vasnprintf.m4 @@ -1,5 +1,5 @@ # vasnprintf.m4 serial 36 -dnl Copyright (C) 2002-2004, 2006-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2004, 2006-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/visibility.m4 b/m4/visibility.m4 index 552e39772..e99e3fbad 100644 --- a/m4/visibility.m4 +++ b/m4/visibility.m4 @@ -1,5 +1,5 @@ # visibility.m4 serial 5 (gettext-0.18.2) -dnl Copyright (C) 2005, 2008, 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2005, 2008, 2010-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/vsnprintf.m4 b/m4/vsnprintf.m4 index 07f739df9..e056f05cd 100644 --- a/m4/vsnprintf.m4 +++ b/m4/vsnprintf.m4 @@ -1,5 +1,5 @@ # vsnprintf.m4 serial 6 -dnl Copyright (C) 2002-2004, 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2004, 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/warn-on-use.m4 b/m4/warn-on-use.m4 index cc690f8e2..08440ec59 100644 --- a/m4/warn-on-use.m4 +++ b/m4/warn-on-use.m4 @@ -1,5 +1,5 @@ # warn-on-use.m4 serial 5 -dnl Copyright (C) 2010-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/warnings.m4 b/m4/warnings.m4 index 43156f450..924e21d5e 100644 --- a/m4/warnings.m4 +++ b/m4/warnings.m4 @@ -1,5 +1,5 @@ # warnings.m4 serial 11 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/wchar_h.m4 b/m4/wchar_h.m4 index 85db95286..b40b73237 100644 --- a/m4/wchar_h.m4 +++ b/m4/wchar_h.m4 @@ -1,6 +1,6 @@ dnl A placeholder for ISO C99 , for platforms that have issues. -dnl Copyright (C) 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/wchar_t.m4 b/m4/wchar_t.m4 index 839a04c17..2db8c3f2f 100644 --- a/m4/wchar_t.m4 +++ b/m4/wchar_t.m4 @@ -1,5 +1,5 @@ # wchar_t.m4 serial 4 (gettext-0.18.2) -dnl Copyright (C) 2002-2003, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2003, 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/wcrtomb.m4 b/m4/wcrtomb.m4 index 844ef6a8c..267b3c9b2 100644 --- a/m4/wcrtomb.m4 +++ b/m4/wcrtomb.m4 @@ -1,5 +1,5 @@ # wcrtomb.m4 serial 11 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/wctype_h.m4 b/m4/wctype_h.m4 index 3fac0ee09..accc001ca 100644 --- a/m4/wctype_h.m4 +++ b/m4/wctype_h.m4 @@ -2,7 +2,7 @@ dnl A placeholder for ISO C99 , for platforms that lack it. -dnl Copyright (C) 2006-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/wint_t.m4 b/m4/wint_t.m4 index 9b07b0709..8ff2a5b5a 100644 --- a/m4/wint_t.m4 +++ b/m4/wint_t.m4 @@ -1,5 +1,5 @@ # wint_t.m4 serial 5 (gettext-0.18.2) -dnl Copyright (C) 2003, 2007-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2007-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/write.m4 b/m4/write.m4 index 820dd4f77..d9b93f9a3 100644 --- a/m4/write.m4 +++ b/m4/write.m4 @@ -1,5 +1,5 @@ # write.m4 serial 5 -dnl Copyright (C) 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/xsize.m4 b/m4/xsize.m4 index 3af23ec75..16764e89d 100644 --- a/m4/xsize.m4 +++ b/m4/xsize.m4 @@ -1,5 +1,5 @@ # xsize.m4 serial 5 -dnl Copyright (C) 2003-2004, 2008-2014 Free Software Foundation, Inc. +dnl Copyright (C) 2003-2004, 2008-2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/maint.mk b/maint.mk index 30f2e8e69..aa23364a1 100644 --- a/maint.mk +++ b/maint.mk @@ -2,7 +2,7 @@ # This Makefile fragment tries to be general-purpose enough to be # used by many projects via the gnulib maintainer-makefile module. -## Copyright (C) 2001-2014 Free Software Foundation, Inc. +## Copyright (C) 2001-2016 Free Software Foundation, Inc. ## ## This program is free software: you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by @@ -21,13 +21,6 @@ # ME := $(word $(words $(MAKEFILE_LIST)),$(MAKEFILE_LIST)) ME := maint.mk -# Diagnostic for continued use of deprecated variable. -# Remove in 2013 -ifneq ($(build_aux),) - $(error "$(ME): \ -set $$(_build-aux) relative to $$(srcdir) instead of $$(build_aux)") -endif - # Helper variables. _empty = _sp = $(_empty) $(_empty) @@ -155,6 +148,7 @@ export LC_ALL = C ## Sanity checks. ## ## --------------- ## +ifneq ($(_gl-Makefile),) _cfg_mk := $(wildcard $(srcdir)/cfg.mk) # Collect the names of rules starting with 'sc_'. @@ -196,6 +190,7 @@ local-check := \ $(filter-out $(local-checks-to-skip), $(local-checks-available))) syntax-check: $(local-check) +endif # _sc_search_regexp # @@ -445,7 +440,7 @@ sc_require_config_h: # You must include before including any other header file. # This can possibly be via a package-specific header, if given by cfg.mk. sc_require_config_h_first: - @if $(VC_LIST_EXCEPT) | grep -l '\.c$$' > /dev/null; then \ + @if $(VC_LIST_EXCEPT) | grep '\.c$$' > /dev/null; then \ fail=0; \ for i in $$($(VC_LIST_EXCEPT) | grep '\.c$$'); do \ grep '^# *include\>' $$i | $(SED) 1q \ @@ -469,7 +464,7 @@ sc_prohibit_HAVE_MBRTOWC: define _sc_header_without_use dummy=; : so we do not need a semicolon before each use; \ h_esc=`echo '[<"]'"$$h"'[">]'|$(SED) 's/\./\\\\./g'`; \ - if $(VC_LIST_EXCEPT) | grep -l '\.c$$' > /dev/null; then \ + if $(VC_LIST_EXCEPT) | grep '\.c$$' > /dev/null; then \ files=$$(grep -l '^# *include '"$$h_esc" \ $$($(VC_LIST_EXCEPT) | grep '\.c$$')) && \ grep -LE "$$re" $$files | grep . && \ @@ -656,8 +651,7 @@ sc_prohibit_strings_without_use: # Get the list of symbol names with this: # perl -lne '/^# *define ([A-Z]\w+)\(/ and print $1' lib/intprops.h|fmt _intprops_names = \ - TYPE_IS_INTEGER TYPE_TWOS_COMPLEMENT TYPE_ONES_COMPLEMENT \ - TYPE_SIGNED_MAGNITUDE TYPE_SIGNED TYPE_MINIMUM TYPE_MAXIMUM \ + TYPE_IS_INTEGER TYPE_SIGNED TYPE_MINIMUM TYPE_MAXIMUM \ INT_BITS_STRLEN_BOUND INT_STRLEN_BOUND INT_BUFSIZE_BOUND \ INT_ADD_RANGE_OVERFLOW INT_SUBTRACT_RANGE_OVERFLOW \ INT_NEGATE_RANGE_OVERFLOW INT_MULTIPLY_RANGE_OVERFLOW \ @@ -716,7 +710,7 @@ sc_changelog: # Ensure that each .c file containing a "main" function also # calls set_program_name. sc_program_name: - @require='set_program_name *\(m?argv\[0\]\);' \ + @require='set_program_name *\(.*\);' \ in_vc_files='\.c$$' \ containing='\
&2; exit 1; } || : +# Except for shell files and for loops, double semicolon is probably a mistake +sc_prohibit_double_semicolon: + @prohibit='; *;[ {} \]*(/[/*]|$$)' \ + in_vc_files='\.[chly]$$' \ + exclude='\bfor *\(.*\)' \ + halt="Double semicolon detected" \ + $(_sc_search_regexp) + _ptm1 = use "test C1 && test C2", not "test C1 -''a C2" _ptm2 = use "test C1 || test C2", not "test C1 -''o C2" # Using test's -a and -o operators is not portable. @@ -1192,7 +1194,7 @@ sc_copyright_check: in_vc_files=$(sample-test) \ halt='out of date copyright in $(sample-test); update it' \ $(_sc_search_regexp) - @require='Copyright @copyright\{\} .*'$$(date +%Y)' Free' \ + @require='Copyright @copyright\{\} .*'$$(date +%Y) \ in_vc_files=$(texi) \ halt='out of date copyright in $(texi); update it' \ $(_sc_search_regexp) @@ -1597,7 +1599,7 @@ ifeq (a,b) # do not need to be marked. Symbols matching '__.*' are # reserved by the compiler, so are automatically excluded below. _gl_TS_unmarked_extern_functions ?= main usage -_gl_TS_function_match ?= /^(?:$(_gl_TS_extern)) +.*?(\S+) *\(/ +_gl_TS_function_match ?= /^(?:$(_gl_TS_extern)) +.*?(\w+) *\(/ # If your project uses a macro like "XTERN", then put # the following in cfg.mk to override this default: @@ -1630,6 +1632,7 @@ _gl_TS_other_headers ?= *.h .PHONY: _gl_tight_scope _gl_tight_scope: $(bin_PROGRAMS) + sed_wrap='s/^/^_?/;s/$$/$$/'; \ t=exceptions-$$$$; \ trap 's=$$?; rm -f $$t; exit $$s' 0; \ for sig in 1 2 3 13 15; do \ @@ -1639,20 +1642,20 @@ _gl_tight_scope: $(bin_PROGRAMS) test -f $$f && d= || d=$(srcdir)/; echo $$d$$f; done`; \ hdr=`for f in $(_gl_TS_headers); do \ test -f $$f && d= || d=$(srcdir)/; echo $$d$$f; done`; \ - ( printf '^%s$$\n' '__.*' $(_gl_TS_unmarked_extern_functions); \ + ( printf '%s\n' '__.*' $(_gl_TS_unmarked_extern_functions); \ grep -h -A1 '^extern .*[^;]$$' $$src \ - | grep -vE '^(extern |--)' | $(SED) 's/ .*//'; \ + | grep -vE '^(extern |--|#)' | $(SED) 's/ .*//; /^$$/d'; \ perl -lne \ - '$(_gl_TS_function_match) and print "^$$1\$$"' $$hdr; \ - ) | sort -u > $$t; \ - nm -e $(_gl_TS_obj_files)|$(SED) -n 's/.* T //p'|grep -Ev -f $$t \ + '$(_gl_TS_function_match) and print $$1' $$hdr; \ + ) | sort -u | $(SED) "$$sed_wrap" > $$t; \ + nm -g $(_gl_TS_obj_files)|$(SED) -n 's/.* T //p'|grep -Ev -f $$t \ && { echo the above functions should have static scope >&2; \ exit 1; } || : ; \ - ( printf '^%s$$\n' '__.*' $(_gl_TS_unmarked_extern_vars); \ - perl -lne '$(_gl_TS_var_match) and print "^$$1\$$"' \ + ( printf '%s\n' '__.*' main $(_gl_TS_unmarked_extern_vars); \ + perl -lne '$(_gl_TS_var_match) and print $$1' \ $$hdr $(_gl_TS_other_headers) \ - ) | sort -u > $$t; \ - nm -e $(_gl_TS_obj_files) | $(SED) -n 's/.* [BCDGRS] //p' \ + ) | sort -u | $(SED) "$$sed_wrap" > $$t; \ + nm -g $(_gl_TS_obj_files) | $(SED) -n 's/.* [BCDGRS] //p' \ | sort -u | grep -Ev -f $$t \ && { echo the above variables should have static scope >&2; \ exit 1; } || : From b05b67b2b3677be51297791ad16cd73a37918ada Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 10 Jul 2016 12:44:35 +0200 Subject: [PATCH 446/865] Avoid Gnulib unistr/* modules (unistr/base, unistr/u8-mbtouc, unistr/u8-mbtouc-unsafe) (unistr/u8-mbtoucr, unistr/u8-prev unistr/u8-uctomb, unitypes): --avoid these modules. --- build-aux/snippet/unused-parameter.h | 36 -- lib/Makefile.am | 101 +--- lib/unistr.in.h | 750 --------------------------- lib/unistr/u8-mbtouc-aux.c | 240 --------- lib/unistr/u8-mbtouc-unsafe-aux.c | 260 ---------- lib/unistr/u8-mbtouc-unsafe.c | 271 ---------- lib/unistr/u8-mbtouc.c | 250 --------- lib/unistr/u8-mbtoucr.c | 285 ---------- lib/unistr/u8-prev.c | 93 ---- lib/unistr/u8-uctomb-aux.c | 69 --- lib/unistr/u8-uctomb.c | 88 ---- lib/unitypes.in.h | 46 -- m4/gnulib-cache.m4 | 4 +- m4/gnulib-comp.m4 | 35 -- m4/inline.m4 | 40 -- m4/libunistring-base.m4 | 141 ----- 16 files changed, 4 insertions(+), 2705 deletions(-) delete mode 100644 build-aux/snippet/unused-parameter.h delete mode 100644 lib/unistr.in.h delete mode 100644 lib/unistr/u8-mbtouc-aux.c delete mode 100644 lib/unistr/u8-mbtouc-unsafe-aux.c delete mode 100644 lib/unistr/u8-mbtouc-unsafe.c delete mode 100644 lib/unistr/u8-mbtouc.c delete mode 100644 lib/unistr/u8-mbtoucr.c delete mode 100644 lib/unistr/u8-prev.c delete mode 100644 lib/unistr/u8-uctomb-aux.c delete mode 100644 lib/unistr/u8-uctomb.c delete mode 100644 lib/unitypes.in.h delete mode 100644 m4/inline.m4 delete mode 100644 m4/libunistring-base.m4 diff --git a/build-aux/snippet/unused-parameter.h b/build-aux/snippet/unused-parameter.h deleted file mode 100644 index 843db76af..000000000 --- a/build-aux/snippet/unused-parameter.h +++ /dev/null @@ -1,36 +0,0 @@ -/* A C macro for declaring that specific function parameters are not used. - Copyright (C) 2008-2016 Free Software Foundation, Inc. - - This program is free software: you can redistribute it and/or modify it - under the terms of the GNU General Public License as published - by the Free Software Foundation; either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see . */ - -/* _GL_UNUSED_PARAMETER is a marker that can be appended to function parameter - declarations for parameters that are not used. This helps to reduce - warnings, such as from GCC -Wunused-parameter. The syntax is as follows: - type param _GL_UNUSED_PARAMETER - or more generally - param_decl _GL_UNUSED_PARAMETER - For example: - int param _GL_UNUSED_PARAMETER - int *(*param)(void) _GL_UNUSED_PARAMETER - Other possible, but obscure and discouraged syntaxes: - int _GL_UNUSED_PARAMETER *(*param)(void) - _GL_UNUSED_PARAMETER int *(*param)(void) - */ -#ifndef _GL_UNUSED_PARAMETER -# if __GNUC__ >= 3 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 7) -# define _GL_UNUSED_PARAMETER __attribute__ ((__unused__)) -# else -# define _GL_UNUSED_PARAMETER -# endif -#endif diff --git a/lib/Makefile.am b/lib/Makefile.am index b65c94279..adf95373e 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -21,9 +21,9 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --lgpl=3 --conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkstemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar +# Reproduce by: gnulib-tool --import --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --avoid=unistr/base --avoid=unistr/u8-mbtouc --avoid=unistr/u8-mbtouc-unsafe --avoid=unistr/u8-mbtoucr --avoid=unistr/u8-prev --avoid=unistr/u8-uctomb --avoid=unitypes --lgpl=3 --conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkstemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar -AUTOMAKE_OPTIONS = 1.9.6 gnits subdir-objects +AUTOMAKE_OPTIONS = 1.9.6 gnits SUBDIRS = noinst_HEADERS = @@ -2014,31 +2014,6 @@ EXTRA_DIST += $(top_srcdir)/build-aux/snippet/c++defs.h ## end gnulib module snippet/c++defs -## begin gnulib module snippet/unused-parameter - -# The BUILT_SOURCES created by this Makefile snippet are not used via #include -# statements but through direct file reference. Therefore this snippet must be -# present in all Makefile.am that need it. This is ensured by the applicability -# 'all' defined above. - -BUILT_SOURCES += unused-parameter.h -# The unused-parameter.h that gets inserted into generated .h files is the same -# as build-aux/snippet/unused-parameter.h, except that it has the copyright -# header cut off. -unused-parameter.h: $(top_srcdir)/build-aux/snippet/unused-parameter.h - $(AM_V_GEN)rm -f $@-t $@ && \ - sed -n -e '/GL_UNUSED_PARAMETER/,$$p' \ - < $(top_srcdir)/build-aux/snippet/unused-parameter.h \ - > $@-t && \ - mv $@-t $@ -MOSTLYCLEANFILES += unused-parameter.h unused-parameter.h-t - -UNUSED_PARAMETER_H=unused-parameter.h - -EXTRA_DIST += $(top_srcdir)/build-aux/snippet/unused-parameter.h - -## end gnulib module snippet/unused-parameter - ## begin gnulib module snippet/warn-on-use BUILT_SOURCES += warn-on-use.h @@ -3161,78 +3136,6 @@ EXTRA_DIST += unistd.in.h ## end gnulib module unistd -## begin gnulib module unistr/base - -BUILT_SOURCES += $(LIBUNISTRING_UNISTR_H) - -unistr.h: unistr.in.h - $(AM_V_GEN)rm -f $@-t $@ && \ - { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ - cat $(srcdir)/unistr.in.h; \ - } > $@-t && \ - mv -f $@-t $@ -MOSTLYCLEANFILES += unistr.h unistr.h-t - -EXTRA_DIST += unistr.in.h - -## end gnulib module unistr/base - -## begin gnulib module unistr/u8-mbtouc - -if LIBUNISTRING_COMPILE_UNISTR_U8_MBTOUC -libgnu_la_SOURCES += unistr/u8-mbtouc.c unistr/u8-mbtouc-aux.c -endif - -## end gnulib module unistr/u8-mbtouc - -## begin gnulib module unistr/u8-mbtouc-unsafe - -if LIBUNISTRING_COMPILE_UNISTR_U8_MBTOUC_UNSAFE -libgnu_la_SOURCES += unistr/u8-mbtouc-unsafe.c unistr/u8-mbtouc-unsafe-aux.c -endif - -## end gnulib module unistr/u8-mbtouc-unsafe - -## begin gnulib module unistr/u8-mbtoucr - -if LIBUNISTRING_COMPILE_UNISTR_U8_MBTOUCR -libgnu_la_SOURCES += unistr/u8-mbtoucr.c -endif - -## end gnulib module unistr/u8-mbtoucr - -## begin gnulib module unistr/u8-prev - -if LIBUNISTRING_COMPILE_UNISTR_U8_PREV -libgnu_la_SOURCES += unistr/u8-prev.c -endif - -## end gnulib module unistr/u8-prev - -## begin gnulib module unistr/u8-uctomb - -if LIBUNISTRING_COMPILE_UNISTR_U8_UCTOMB -libgnu_la_SOURCES += unistr/u8-uctomb.c unistr/u8-uctomb-aux.c -endif - -## end gnulib module unistr/u8-uctomb - -## begin gnulib module unitypes - -BUILT_SOURCES += $(LIBUNISTRING_UNITYPES_H) - -unitypes.h: unitypes.in.h - $(AM_V_GEN)rm -f $@-t $@ && \ - { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ - cat $(srcdir)/unitypes.in.h; \ - } > $@-t && \ - mv -f $@-t $@ -MOSTLYCLEANFILES += unitypes.h unitypes.h-t - -EXTRA_DIST += unitypes.in.h - -## end gnulib module unitypes - ## begin gnulib module unsetenv if gl_GNULIB_ENABLED_unsetenv diff --git a/lib/unistr.in.h b/lib/unistr.in.h deleted file mode 100644 index 2a64b31d9..000000000 --- a/lib/unistr.in.h +++ /dev/null @@ -1,750 +0,0 @@ -/* Elementary Unicode string functions. - Copyright (C) 2001-2002, 2005-2016 Free Software Foundation, Inc. - - This program is free software: you can redistribute it and/or modify it - under the terms of the GNU Lesser General Public License as published - by the Free Software Foundation; either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public License - along with this program. If not, see . */ - -#ifndef _UNISTR_H -#define _UNISTR_H - -#include "unitypes.h" - -/* Get common macros for C. */ -#include "unused-parameter.h" - -/* Get bool. */ -#include - -/* Get size_t. */ -#include - -#ifdef __cplusplus -extern "C" { -#endif - - -/* Conventions: - - All functions prefixed with u8_ operate on UTF-8 encoded strings. - Their unit is an uint8_t (1 byte). - - All functions prefixed with u16_ operate on UTF-16 encoded strings. - Their unit is an uint16_t (a 2-byte word). - - All functions prefixed with u32_ operate on UCS-4 encoded strings. - Their unit is an uint32_t (a 4-byte word). - - All argument pairs (s, n) denote a Unicode string s[0..n-1] with exactly - n units. - - All arguments starting with "str" and the arguments of functions starting - with u8_str/u16_str/u32_str denote a NUL terminated string, i.e. a string - which terminates at the first NUL unit. This termination unit is - considered part of the string for all memory allocation purposes, but - is not considered part of the string for all other logical purposes. - - Functions returning a string result take a (resultbuf, lengthp) argument - pair. If resultbuf is not NULL and the result fits into *lengthp units, - it is put in resultbuf, and resultbuf is returned. Otherwise, a freshly - allocated string is returned. In both cases, *lengthp is set to the - length (number of units) of the returned string. In case of error, - NULL is returned and errno is set. */ - - -/* Elementary string checks. */ - -/* Check whether an UTF-8 string is well-formed. - Return NULL if valid, or a pointer to the first invalid unit otherwise. */ -extern const uint8_t * - u8_check (const uint8_t *s, size_t n) - _UC_ATTRIBUTE_PURE; - -/* Check whether an UTF-16 string is well-formed. - Return NULL if valid, or a pointer to the first invalid unit otherwise. */ -extern const uint16_t * - u16_check (const uint16_t *s, size_t n) - _UC_ATTRIBUTE_PURE; - -/* Check whether an UCS-4 string is well-formed. - Return NULL if valid, or a pointer to the first invalid unit otherwise. */ -extern const uint32_t * - u32_check (const uint32_t *s, size_t n) - _UC_ATTRIBUTE_PURE; - - -/* Elementary string conversions. */ - -/* Convert an UTF-8 string to an UTF-16 string. */ -extern uint16_t * - u8_to_u16 (const uint8_t *s, size_t n, uint16_t *resultbuf, - size_t *lengthp); - -/* Convert an UTF-8 string to an UCS-4 string. */ -extern uint32_t * - u8_to_u32 (const uint8_t *s, size_t n, uint32_t *resultbuf, - size_t *lengthp); - -/* Convert an UTF-16 string to an UTF-8 string. */ -extern uint8_t * - u16_to_u8 (const uint16_t *s, size_t n, uint8_t *resultbuf, - size_t *lengthp); - -/* Convert an UTF-16 string to an UCS-4 string. */ -extern uint32_t * - u16_to_u32 (const uint16_t *s, size_t n, uint32_t *resultbuf, - size_t *lengthp); - -/* Convert an UCS-4 string to an UTF-8 string. */ -extern uint8_t * - u32_to_u8 (const uint32_t *s, size_t n, uint8_t *resultbuf, - size_t *lengthp); - -/* Convert an UCS-4 string to an UTF-16 string. */ -extern uint16_t * - u32_to_u16 (const uint32_t *s, size_t n, uint16_t *resultbuf, - size_t *lengthp); - - -/* Elementary string functions. */ - -/* Return the length (number of units) of the first character in S, which is - no longer than N. Return 0 if it is the NUL character. Return -1 upon - failure. */ -/* Similar to mblen(), except that s must not be NULL. */ -extern int - u8_mblen (const uint8_t *s, size_t n) - _UC_ATTRIBUTE_PURE; -extern int - u16_mblen (const uint16_t *s, size_t n) - _UC_ATTRIBUTE_PURE; -extern int - u32_mblen (const uint32_t *s, size_t n) - _UC_ATTRIBUTE_PURE; - -/* Return the length (number of units) of the first character in S, putting - its 'ucs4_t' representation in *PUC. Upon failure, *PUC is set to 0xfffd, - and an appropriate number of units is returned. - The number of available units, N, must be > 0. */ -/* Similar to mbtowc(), except that puc and s must not be NULL, n must be > 0, - and the NUL character is not treated specially. */ -/* The variants with _safe suffix are safe, even if the library is compiled - without --enable-safety. */ - -#if GNULIB_UNISTR_U8_MBTOUC_UNSAFE || HAVE_LIBUNISTRING -# if !HAVE_INLINE -extern int - u8_mbtouc_unsafe (ucs4_t *puc, const uint8_t *s, size_t n); -# else -extern int - u8_mbtouc_unsafe_aux (ucs4_t *puc, const uint8_t *s, size_t n); -static inline int -u8_mbtouc_unsafe (ucs4_t *puc, const uint8_t *s, size_t n) -{ - uint8_t c = *s; - - if (c < 0x80) - { - *puc = c; - return 1; - } - else - return u8_mbtouc_unsafe_aux (puc, s, n); -} -# endif -#endif - -#if GNULIB_UNISTR_U16_MBTOUC_UNSAFE || HAVE_LIBUNISTRING -# if !HAVE_INLINE -extern int - u16_mbtouc_unsafe (ucs4_t *puc, const uint16_t *s, size_t n); -# else -extern int - u16_mbtouc_unsafe_aux (ucs4_t *puc, const uint16_t *s, size_t n); -static inline int -u16_mbtouc_unsafe (ucs4_t *puc, const uint16_t *s, size_t n) -{ - uint16_t c = *s; - - if (c < 0xd800 || c >= 0xe000) - { - *puc = c; - return 1; - } - else - return u16_mbtouc_unsafe_aux (puc, s, n); -} -# endif -#endif - -#if GNULIB_UNISTR_U32_MBTOUC_UNSAFE || HAVE_LIBUNISTRING -# if !HAVE_INLINE -extern int - u32_mbtouc_unsafe (ucs4_t *puc, const uint32_t *s, size_t n); -# else -static inline int -u32_mbtouc_unsafe (ucs4_t *puc, - const uint32_t *s, size_t n _GL_UNUSED_PARAMETER) -{ - uint32_t c = *s; - -# if CONFIG_UNICODE_SAFETY - if (c < 0xd800 || (c >= 0xe000 && c < 0x110000)) -# endif - *puc = c; -# if CONFIG_UNICODE_SAFETY - else - /* invalid multibyte character */ - *puc = 0xfffd; -# endif - return 1; -} -# endif -#endif - -#if GNULIB_UNISTR_U8_MBTOUC || HAVE_LIBUNISTRING -# if !HAVE_INLINE -extern int - u8_mbtouc (ucs4_t *puc, const uint8_t *s, size_t n); -# else -extern int - u8_mbtouc_aux (ucs4_t *puc, const uint8_t *s, size_t n); -static inline int -u8_mbtouc (ucs4_t *puc, const uint8_t *s, size_t n) -{ - uint8_t c = *s; - - if (c < 0x80) - { - *puc = c; - return 1; - } - else - return u8_mbtouc_aux (puc, s, n); -} -# endif -#endif - -#if GNULIB_UNISTR_U16_MBTOUC || HAVE_LIBUNISTRING -# if !HAVE_INLINE -extern int - u16_mbtouc (ucs4_t *puc, const uint16_t *s, size_t n); -# else -extern int - u16_mbtouc_aux (ucs4_t *puc, const uint16_t *s, size_t n); -static inline int -u16_mbtouc (ucs4_t *puc, const uint16_t *s, size_t n) -{ - uint16_t c = *s; - - if (c < 0xd800 || c >= 0xe000) - { - *puc = c; - return 1; - } - else - return u16_mbtouc_aux (puc, s, n); -} -# endif -#endif - -#if GNULIB_UNISTR_U32_MBTOUC || HAVE_LIBUNISTRING -# if !HAVE_INLINE -extern int - u32_mbtouc (ucs4_t *puc, const uint32_t *s, size_t n); -# else -static inline int -u32_mbtouc (ucs4_t *puc, const uint32_t *s, size_t n _GL_UNUSED_PARAMETER) -{ - uint32_t c = *s; - - if (c < 0xd800 || (c >= 0xe000 && c < 0x110000)) - *puc = c; - else - /* invalid multibyte character */ - *puc = 0xfffd; - return 1; -} -# endif -#endif - -/* Return the length (number of units) of the first character in S, putting - its 'ucs4_t' representation in *PUC. Upon failure, *PUC is set to 0xfffd, - and -1 is returned for an invalid sequence of units, -2 is returned for an - incomplete sequence of units. - The number of available units, N, must be > 0. */ -/* Similar to u*_mbtouc(), except that the return value gives more details - about the failure, similar to mbrtowc(). */ - -#if GNULIB_UNISTR_U8_MBTOUCR || HAVE_LIBUNISTRING -extern int - u8_mbtoucr (ucs4_t *puc, const uint8_t *s, size_t n); -#endif - -#if GNULIB_UNISTR_U16_MBTOUCR || HAVE_LIBUNISTRING -extern int - u16_mbtoucr (ucs4_t *puc, const uint16_t *s, size_t n); -#endif - -#if GNULIB_UNISTR_U32_MBTOUCR || HAVE_LIBUNISTRING -extern int - u32_mbtoucr (ucs4_t *puc, const uint32_t *s, size_t n); -#endif - -/* Put the multibyte character represented by UC in S, returning its - length. Return -1 upon failure, -2 if the number of available units, N, - is too small. The latter case cannot occur if N >= 6/2/1, respectively. */ -/* Similar to wctomb(), except that s must not be NULL, and the argument n - must be specified. */ - -#if GNULIB_UNISTR_U8_UCTOMB || HAVE_LIBUNISTRING -/* Auxiliary function, also used by u8_chr, u8_strchr, u8_strrchr. */ -extern int - u8_uctomb_aux (uint8_t *s, ucs4_t uc, int n); -# if !HAVE_INLINE -extern int - u8_uctomb (uint8_t *s, ucs4_t uc, int n); -# else -static inline int -u8_uctomb (uint8_t *s, ucs4_t uc, int n) -{ - if (uc < 0x80 && n > 0) - { - s[0] = uc; - return 1; - } - else - return u8_uctomb_aux (s, uc, n); -} -# endif -#endif - -#if GNULIB_UNISTR_U16_UCTOMB || HAVE_LIBUNISTRING -/* Auxiliary function, also used by u16_chr, u16_strchr, u16_strrchr. */ -extern int - u16_uctomb_aux (uint16_t *s, ucs4_t uc, int n); -# if !HAVE_INLINE -extern int - u16_uctomb (uint16_t *s, ucs4_t uc, int n); -# else -static inline int -u16_uctomb (uint16_t *s, ucs4_t uc, int n) -{ - if (uc < 0xd800 && n > 0) - { - s[0] = uc; - return 1; - } - else - return u16_uctomb_aux (s, uc, n); -} -# endif -#endif - -#if GNULIB_UNISTR_U32_UCTOMB || HAVE_LIBUNISTRING -# if !HAVE_INLINE -extern int - u32_uctomb (uint32_t *s, ucs4_t uc, int n); -# else -static inline int -u32_uctomb (uint32_t *s, ucs4_t uc, int n) -{ - if (uc < 0xd800 || (uc >= 0xe000 && uc < 0x110000)) - { - if (n > 0) - { - *s = uc; - return 1; - } - else - return -2; - } - else - return -1; -} -# endif -#endif - -/* Copy N units from SRC to DEST. */ -/* Similar to memcpy(). */ -extern uint8_t * - u8_cpy (uint8_t *dest, const uint8_t *src, size_t n); -extern uint16_t * - u16_cpy (uint16_t *dest, const uint16_t *src, size_t n); -extern uint32_t * - u32_cpy (uint32_t *dest, const uint32_t *src, size_t n); - -/* Copy N units from SRC to DEST, guaranteeing correct behavior for - overlapping memory areas. */ -/* Similar to memmove(). */ -extern uint8_t * - u8_move (uint8_t *dest, const uint8_t *src, size_t n); -extern uint16_t * - u16_move (uint16_t *dest, const uint16_t *src, size_t n); -extern uint32_t * - u32_move (uint32_t *dest, const uint32_t *src, size_t n); - -/* Set the first N characters of S to UC. UC should be a character that - occupies only 1 unit. */ -/* Similar to memset(). */ -extern uint8_t * - u8_set (uint8_t *s, ucs4_t uc, size_t n); -extern uint16_t * - u16_set (uint16_t *s, ucs4_t uc, size_t n); -extern uint32_t * - u32_set (uint32_t *s, ucs4_t uc, size_t n); - -/* Compare S1 and S2, each of length N. */ -/* Similar to memcmp(). */ -extern int - u8_cmp (const uint8_t *s1, const uint8_t *s2, size_t n) - _UC_ATTRIBUTE_PURE; -extern int - u16_cmp (const uint16_t *s1, const uint16_t *s2, size_t n) - _UC_ATTRIBUTE_PURE; -extern int - u32_cmp (const uint32_t *s1, const uint32_t *s2, size_t n) - _UC_ATTRIBUTE_PURE; - -/* Compare S1 and S2. */ -/* Similar to the gnulib function memcmp2(). */ -extern int - u8_cmp2 (const uint8_t *s1, size_t n1, const uint8_t *s2, size_t n2) - _UC_ATTRIBUTE_PURE; -extern int - u16_cmp2 (const uint16_t *s1, size_t n1, const uint16_t *s2, size_t n2) - _UC_ATTRIBUTE_PURE; -extern int - u32_cmp2 (const uint32_t *s1, size_t n1, const uint32_t *s2, size_t n2) - _UC_ATTRIBUTE_PURE; - -/* Search the string at S for UC. */ -/* Similar to memchr(). */ -extern uint8_t * - u8_chr (const uint8_t *s, size_t n, ucs4_t uc) - _UC_ATTRIBUTE_PURE; -extern uint16_t * - u16_chr (const uint16_t *s, size_t n, ucs4_t uc) - _UC_ATTRIBUTE_PURE; -extern uint32_t * - u32_chr (const uint32_t *s, size_t n, ucs4_t uc) - _UC_ATTRIBUTE_PURE; - -/* Count the number of Unicode characters in the N units from S. */ -/* Similar to mbsnlen(). */ -extern size_t - u8_mbsnlen (const uint8_t *s, size_t n) - _UC_ATTRIBUTE_PURE; -extern size_t - u16_mbsnlen (const uint16_t *s, size_t n) - _UC_ATTRIBUTE_PURE; -extern size_t - u32_mbsnlen (const uint32_t *s, size_t n) - _UC_ATTRIBUTE_PURE; - -/* Elementary string functions with memory allocation. */ - -/* Make a freshly allocated copy of S, of length N. */ -extern uint8_t * - u8_cpy_alloc (const uint8_t *s, size_t n); -extern uint16_t * - u16_cpy_alloc (const uint16_t *s, size_t n); -extern uint32_t * - u32_cpy_alloc (const uint32_t *s, size_t n); - -/* Elementary string functions on NUL terminated strings. */ - -/* Return the length (number of units) of the first character in S. - Return 0 if it is the NUL character. Return -1 upon failure. */ -extern int - u8_strmblen (const uint8_t *s) - _UC_ATTRIBUTE_PURE; -extern int - u16_strmblen (const uint16_t *s) - _UC_ATTRIBUTE_PURE; -extern int - u32_strmblen (const uint32_t *s) - _UC_ATTRIBUTE_PURE; - -/* Return the length (number of units) of the first character in S, putting - its 'ucs4_t' representation in *PUC. Return 0 if it is the NUL - character. Return -1 upon failure. */ -extern int - u8_strmbtouc (ucs4_t *puc, const uint8_t *s); -extern int - u16_strmbtouc (ucs4_t *puc, const uint16_t *s); -extern int - u32_strmbtouc (ucs4_t *puc, const uint32_t *s); - -/* Forward iteration step. Advances the pointer past the next character, - or returns NULL if the end of the string has been reached. Puts the - character's 'ucs4_t' representation in *PUC. */ -extern const uint8_t * - u8_next (ucs4_t *puc, const uint8_t *s); -extern const uint16_t * - u16_next (ucs4_t *puc, const uint16_t *s); -extern const uint32_t * - u32_next (ucs4_t *puc, const uint32_t *s); - -/* Backward iteration step. Advances the pointer to point to the previous - character, or returns NULL if the beginning of the string had been reached. - Puts the character's 'ucs4_t' representation in *PUC. */ -extern const uint8_t * - u8_prev (ucs4_t *puc, const uint8_t *s, const uint8_t *start); -extern const uint16_t * - u16_prev (ucs4_t *puc, const uint16_t *s, const uint16_t *start); -extern const uint32_t * - u32_prev (ucs4_t *puc, const uint32_t *s, const uint32_t *start); - -/* Return the number of units in S. */ -/* Similar to strlen(), wcslen(). */ -extern size_t - u8_strlen (const uint8_t *s) - _UC_ATTRIBUTE_PURE; -extern size_t - u16_strlen (const uint16_t *s) - _UC_ATTRIBUTE_PURE; -extern size_t - u32_strlen (const uint32_t *s) - _UC_ATTRIBUTE_PURE; - -/* Return the number of units in S, but at most MAXLEN. */ -/* Similar to strnlen(), wcsnlen(). */ -extern size_t - u8_strnlen (const uint8_t *s, size_t maxlen) - _UC_ATTRIBUTE_PURE; -extern size_t - u16_strnlen (const uint16_t *s, size_t maxlen) - _UC_ATTRIBUTE_PURE; -extern size_t - u32_strnlen (const uint32_t *s, size_t maxlen) - _UC_ATTRIBUTE_PURE; - -/* Copy SRC to DEST. */ -/* Similar to strcpy(), wcscpy(). */ -extern uint8_t * - u8_strcpy (uint8_t *dest, const uint8_t *src); -extern uint16_t * - u16_strcpy (uint16_t *dest, const uint16_t *src); -extern uint32_t * - u32_strcpy (uint32_t *dest, const uint32_t *src); - -/* Copy SRC to DEST, returning the address of the terminating NUL in DEST. */ -/* Similar to stpcpy(). */ -extern uint8_t * - u8_stpcpy (uint8_t *dest, const uint8_t *src); -extern uint16_t * - u16_stpcpy (uint16_t *dest, const uint16_t *src); -extern uint32_t * - u32_stpcpy (uint32_t *dest, const uint32_t *src); - -/* Copy no more than N units of SRC to DEST. */ -/* Similar to strncpy(), wcsncpy(). */ -extern uint8_t * - u8_strncpy (uint8_t *dest, const uint8_t *src, size_t n); -extern uint16_t * - u16_strncpy (uint16_t *dest, const uint16_t *src, size_t n); -extern uint32_t * - u32_strncpy (uint32_t *dest, const uint32_t *src, size_t n); - -/* Copy no more than N units of SRC to DEST. Return a pointer past the last - non-NUL unit written into DEST. */ -/* Similar to stpncpy(). */ -extern uint8_t * - u8_stpncpy (uint8_t *dest, const uint8_t *src, size_t n); -extern uint16_t * - u16_stpncpy (uint16_t *dest, const uint16_t *src, size_t n); -extern uint32_t * - u32_stpncpy (uint32_t *dest, const uint32_t *src, size_t n); - -/* Append SRC onto DEST. */ -/* Similar to strcat(), wcscat(). */ -extern uint8_t * - u8_strcat (uint8_t *dest, const uint8_t *src); -extern uint16_t * - u16_strcat (uint16_t *dest, const uint16_t *src); -extern uint32_t * - u32_strcat (uint32_t *dest, const uint32_t *src); - -/* Append no more than N units of SRC onto DEST. */ -/* Similar to strncat(), wcsncat(). */ -extern uint8_t * - u8_strncat (uint8_t *dest, const uint8_t *src, size_t n); -extern uint16_t * - u16_strncat (uint16_t *dest, const uint16_t *src, size_t n); -extern uint32_t * - u32_strncat (uint32_t *dest, const uint32_t *src, size_t n); - -/* Compare S1 and S2. */ -/* Similar to strcmp(), wcscmp(). */ -#ifdef __sun -/* Avoid a collision with the u8_strcmp() function in Solaris 11 libc. */ -extern int - u8_strcmp_gnu (const uint8_t *s1, const uint8_t *s2) - _UC_ATTRIBUTE_PURE; -# define u8_strcmp u8_strcmp_gnu -#else -extern int - u8_strcmp (const uint8_t *s1, const uint8_t *s2) - _UC_ATTRIBUTE_PURE; -#endif -extern int - u16_strcmp (const uint16_t *s1, const uint16_t *s2) - _UC_ATTRIBUTE_PURE; -extern int - u32_strcmp (const uint32_t *s1, const uint32_t *s2) - _UC_ATTRIBUTE_PURE; - -/* Compare S1 and S2 using the collation rules of the current locale. - Return -1 if S1 < S2, 0 if S1 = S2, 1 if S1 > S2. - Upon failure, set errno and return any value. */ -/* Similar to strcoll(), wcscoll(). */ -extern int - u8_strcoll (const uint8_t *s1, const uint8_t *s2); -extern int - u16_strcoll (const uint16_t *s1, const uint16_t *s2); -extern int - u32_strcoll (const uint32_t *s1, const uint32_t *s2); - -/* Compare no more than N units of S1 and S2. */ -/* Similar to strncmp(), wcsncmp(). */ -extern int - u8_strncmp (const uint8_t *s1, const uint8_t *s2, size_t n) - _UC_ATTRIBUTE_PURE; -extern int - u16_strncmp (const uint16_t *s1, const uint16_t *s2, size_t n) - _UC_ATTRIBUTE_PURE; -extern int - u32_strncmp (const uint32_t *s1, const uint32_t *s2, size_t n) - _UC_ATTRIBUTE_PURE; - -/* Duplicate S, returning an identical malloc'd string. */ -/* Similar to strdup(), wcsdup(). */ -extern uint8_t * - u8_strdup (const uint8_t *s); -extern uint16_t * - u16_strdup (const uint16_t *s); -extern uint32_t * - u32_strdup (const uint32_t *s); - -/* Find the first occurrence of UC in STR. */ -/* Similar to strchr(), wcschr(). */ -extern uint8_t * - u8_strchr (const uint8_t *str, ucs4_t uc) - _UC_ATTRIBUTE_PURE; -extern uint16_t * - u16_strchr (const uint16_t *str, ucs4_t uc) - _UC_ATTRIBUTE_PURE; -extern uint32_t * - u32_strchr (const uint32_t *str, ucs4_t uc) - _UC_ATTRIBUTE_PURE; - -/* Find the last occurrence of UC in STR. */ -/* Similar to strrchr(), wcsrchr(). */ -extern uint8_t * - u8_strrchr (const uint8_t *str, ucs4_t uc) - _UC_ATTRIBUTE_PURE; -extern uint16_t * - u16_strrchr (const uint16_t *str, ucs4_t uc) - _UC_ATTRIBUTE_PURE; -extern uint32_t * - u32_strrchr (const uint32_t *str, ucs4_t uc) - _UC_ATTRIBUTE_PURE; - -/* Return the length of the initial segment of STR which consists entirely - of Unicode characters not in REJECT. */ -/* Similar to strcspn(), wcscspn(). */ -extern size_t - u8_strcspn (const uint8_t *str, const uint8_t *reject) - _UC_ATTRIBUTE_PURE; -extern size_t - u16_strcspn (const uint16_t *str, const uint16_t *reject) - _UC_ATTRIBUTE_PURE; -extern size_t - u32_strcspn (const uint32_t *str, const uint32_t *reject) - _UC_ATTRIBUTE_PURE; - -/* Return the length of the initial segment of STR which consists entirely - of Unicode characters in ACCEPT. */ -/* Similar to strspn(), wcsspn(). */ -extern size_t - u8_strspn (const uint8_t *str, const uint8_t *accept) - _UC_ATTRIBUTE_PURE; -extern size_t - u16_strspn (const uint16_t *str, const uint16_t *accept) - _UC_ATTRIBUTE_PURE; -extern size_t - u32_strspn (const uint32_t *str, const uint32_t *accept) - _UC_ATTRIBUTE_PURE; - -/* Find the first occurrence in STR of any character in ACCEPT. */ -/* Similar to strpbrk(), wcspbrk(). */ -extern uint8_t * - u8_strpbrk (const uint8_t *str, const uint8_t *accept) - _UC_ATTRIBUTE_PURE; -extern uint16_t * - u16_strpbrk (const uint16_t *str, const uint16_t *accept) - _UC_ATTRIBUTE_PURE; -extern uint32_t * - u32_strpbrk (const uint32_t *str, const uint32_t *accept) - _UC_ATTRIBUTE_PURE; - -/* Find the first occurrence of NEEDLE in HAYSTACK. */ -/* Similar to strstr(), wcsstr(). */ -extern uint8_t * - u8_strstr (const uint8_t *haystack, const uint8_t *needle) - _UC_ATTRIBUTE_PURE; -extern uint16_t * - u16_strstr (const uint16_t *haystack, const uint16_t *needle) - _UC_ATTRIBUTE_PURE; -extern uint32_t * - u32_strstr (const uint32_t *haystack, const uint32_t *needle) - _UC_ATTRIBUTE_PURE; - -/* Test whether STR starts with PREFIX. */ -extern bool - u8_startswith (const uint8_t *str, const uint8_t *prefix) - _UC_ATTRIBUTE_PURE; -extern bool - u16_startswith (const uint16_t *str, const uint16_t *prefix) - _UC_ATTRIBUTE_PURE; -extern bool - u32_startswith (const uint32_t *str, const uint32_t *prefix) - _UC_ATTRIBUTE_PURE; - -/* Test whether STR ends with SUFFIX. */ -extern bool - u8_endswith (const uint8_t *str, const uint8_t *suffix) - _UC_ATTRIBUTE_PURE; -extern bool - u16_endswith (const uint16_t *str, const uint16_t *suffix) - _UC_ATTRIBUTE_PURE; -extern bool - u32_endswith (const uint32_t *str, const uint32_t *suffix) - _UC_ATTRIBUTE_PURE; - -/* Divide STR into tokens separated by characters in DELIM. - This interface is actually more similar to wcstok than to strtok. */ -/* Similar to strtok_r(), wcstok(). */ -extern uint8_t * - u8_strtok (uint8_t *str, const uint8_t *delim, uint8_t **ptr); -extern uint16_t * - u16_strtok (uint16_t *str, const uint16_t *delim, uint16_t **ptr); -extern uint32_t * - u32_strtok (uint32_t *str, const uint32_t *delim, uint32_t **ptr); - - -#ifdef __cplusplus -} -#endif - -#endif /* _UNISTR_H */ diff --git a/lib/unistr/u8-mbtouc-aux.c b/lib/unistr/u8-mbtouc-aux.c deleted file mode 100644 index d546ae7af..000000000 --- a/lib/unistr/u8-mbtouc-aux.c +++ /dev/null @@ -1,240 +0,0 @@ -/* Conversion UTF-8 to UCS-4. - Copyright (C) 2001-2002, 2006-2007, 2009-2016 Free Software Foundation, Inc. - Written by Bruno Haible , 2001. - - This program is free software: you can redistribute it and/or modify it - under the terms of the GNU Lesser General Public License as published - by the Free Software Foundation; either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public License - along with this program. If not, see . */ - -#include - -/* Specification. */ -#include "unistr.h" - -#if defined IN_LIBUNISTRING || HAVE_INLINE - -int -u8_mbtouc_aux (ucs4_t *puc, const uint8_t *s, size_t n) -{ - uint8_t c = *s; - - if (c >= 0xc2) - { - if (c < 0xe0) - { - if (n >= 2) - { - if ((s[1] ^ 0x80) < 0x40) - { - *puc = ((unsigned int) (c & 0x1f) << 6) - | (unsigned int) (s[1] ^ 0x80); - return 2; - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return 1; - } - } - else if (c < 0xf0) - { - if (n >= 3) - { - if ((s[1] ^ 0x80) < 0x40) - { - if ((s[2] ^ 0x80) < 0x40) - { - if ((c >= 0xe1 || s[1] >= 0xa0) - && (c != 0xed || s[1] < 0xa0)) - { - *puc = ((unsigned int) (c & 0x0f) << 12) - | ((unsigned int) (s[1] ^ 0x80) << 6) - | (unsigned int) (s[2] ^ 0x80); - return 3; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 3; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 2; - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - if (n == 1 || (s[1] ^ 0x80) >= 0x40) - return 1; - else - return 2; - } - } - else if (c < 0xf8) - { - if (n >= 4) - { - if ((s[1] ^ 0x80) < 0x40) - { - if ((s[2] ^ 0x80) < 0x40) - { - if ((s[3] ^ 0x80) < 0x40) - { - if ((c >= 0xf1 || s[1] >= 0x90) -#if 1 - && (c < 0xf4 || (c == 0xf4 && s[1] < 0x90)) -#endif - ) - { - *puc = ((unsigned int) (c & 0x07) << 18) - | ((unsigned int) (s[1] ^ 0x80) << 12) - | ((unsigned int) (s[2] ^ 0x80) << 6) - | (unsigned int) (s[3] ^ 0x80); - return 4; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 4; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 3; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 2; - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - if (n == 1 || (s[1] ^ 0x80) >= 0x40) - return 1; - else if (n == 2 || (s[2] ^ 0x80) >= 0x40) - return 2; - else - return 3; - } - } -#if 0 - else if (c < 0xfc) - { - if (n >= 5) - { - if ((s[1] ^ 0x80) < 0x40) - { - if ((s[2] ^ 0x80) < 0x40) - { - if ((s[3] ^ 0x80) < 0x40) - { - if ((s[4] ^ 0x80) < 0x40) - { - if (c >= 0xf9 || s[1] >= 0x88) - { - *puc = ((unsigned int) (c & 0x03) << 24) - | ((unsigned int) (s[1] ^ 0x80) << 18) - | ((unsigned int) (s[2] ^ 0x80) << 12) - | ((unsigned int) (s[3] ^ 0x80) << 6) - | (unsigned int) (s[4] ^ 0x80); - return 5; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 5; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 4; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 3; - } - /* invalid multibyte character */ - return 2; - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return n; - } - } - else if (c < 0xfe) - { - if (n >= 6) - { - if ((s[1] ^ 0x80) < 0x40) - { - if ((s[2] ^ 0x80) < 0x40) - { - if ((s[3] ^ 0x80) < 0x40) - { - if ((s[4] ^ 0x80) < 0x40) - { - if ((s[5] ^ 0x80) < 0x40) - { - if (c >= 0xfd || s[1] >= 0x84) - { - *puc = ((unsigned int) (c & 0x01) << 30) - | ((unsigned int) (s[1] ^ 0x80) << 24) - | ((unsigned int) (s[2] ^ 0x80) << 18) - | ((unsigned int) (s[3] ^ 0x80) << 12) - | ((unsigned int) (s[4] ^ 0x80) << 6) - | (unsigned int) (s[5] ^ 0x80); - return 6; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 6; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 5; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 4; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 3; - } - /* invalid multibyte character */ - return 2; - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return n; - } - } -#endif - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 1; -} - -#endif diff --git a/lib/unistr/u8-mbtouc-unsafe-aux.c b/lib/unistr/u8-mbtouc-unsafe-aux.c deleted file mode 100644 index 61783e4ba..000000000 --- a/lib/unistr/u8-mbtouc-unsafe-aux.c +++ /dev/null @@ -1,260 +0,0 @@ -/* Conversion UTF-8 to UCS-4. - Copyright (C) 2001-2002, 2006-2007, 2009-2016 Free Software Foundation, Inc. - Written by Bruno Haible , 2001. - - This program is free software: you can redistribute it and/or modify it - under the terms of the GNU Lesser General Public License as published - by the Free Software Foundation; either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public License - along with this program. If not, see . */ - -#include - -/* Specification. */ -#include "unistr.h" - -#if defined IN_LIBUNISTRING || HAVE_INLINE - -int -u8_mbtouc_unsafe_aux (ucs4_t *puc, const uint8_t *s, size_t n) -{ - uint8_t c = *s; - - if (c >= 0xc2) - { - if (c < 0xe0) - { - if (n >= 2) - { -#if CONFIG_UNICODE_SAFETY - if ((s[1] ^ 0x80) < 0x40) -#endif - { - *puc = ((unsigned int) (c & 0x1f) << 6) - | (unsigned int) (s[1] ^ 0x80); - return 2; - } -#if CONFIG_UNICODE_SAFETY - /* invalid multibyte character */ -#endif - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return 1; - } - } - else if (c < 0xf0) - { - if (n >= 3) - { -#if CONFIG_UNICODE_SAFETY - if ((s[1] ^ 0x80) < 0x40) - { - if ((s[2] ^ 0x80) < 0x40) - { - if ((c >= 0xe1 || s[1] >= 0xa0) - && (c != 0xed || s[1] < 0xa0)) -#endif - { - *puc = ((unsigned int) (c & 0x0f) << 12) - | ((unsigned int) (s[1] ^ 0x80) << 6) - | (unsigned int) (s[2] ^ 0x80); - return 3; - } -#if CONFIG_UNICODE_SAFETY - /* invalid multibyte character */ - *puc = 0xfffd; - return 3; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 2; - } - /* invalid multibyte character */ -#endif - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - if (n == 1 || (s[1] ^ 0x80) >= 0x40) - return 1; - else - return 2; - } - } - else if (c < 0xf8) - { - if (n >= 4) - { -#if CONFIG_UNICODE_SAFETY - if ((s[1] ^ 0x80) < 0x40) - { - if ((s[2] ^ 0x80) < 0x40) - { - if ((s[3] ^ 0x80) < 0x40) - { - if ((c >= 0xf1 || s[1] >= 0x90) -#if 1 - && (c < 0xf4 || (c == 0xf4 && s[1] < 0x90)) -#endif - ) -#endif - { - *puc = ((unsigned int) (c & 0x07) << 18) - | ((unsigned int) (s[1] ^ 0x80) << 12) - | ((unsigned int) (s[2] ^ 0x80) << 6) - | (unsigned int) (s[3] ^ 0x80); - return 4; - } -#if CONFIG_UNICODE_SAFETY - /* invalid multibyte character */ - *puc = 0xfffd; - return 4; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 3; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 2; - } - /* invalid multibyte character */ -#endif - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - if (n == 1 || (s[1] ^ 0x80) >= 0x40) - return 1; - else if (n == 2 || (s[2] ^ 0x80) >= 0x40) - return 2; - else - return 3; - } - } -#if 0 - else if (c < 0xfc) - { - if (n >= 5) - { -#if CONFIG_UNICODE_SAFETY - if ((s[1] ^ 0x80) < 0x40) - { - if ((s[2] ^ 0x80) < 0x40) - { - if ((s[3] ^ 0x80) < 0x40) - { - if ((s[4] ^ 0x80) < 0x40) - { - if (c >= 0xf9 || s[1] >= 0x88) -#endif - { - *puc = ((unsigned int) (c & 0x03) << 24) - | ((unsigned int) (s[1] ^ 0x80) << 18) - | ((unsigned int) (s[2] ^ 0x80) << 12) - | ((unsigned int) (s[3] ^ 0x80) << 6) - | (unsigned int) (s[4] ^ 0x80); - return 5; - } -#if CONFIG_UNICODE_SAFETY - /* invalid multibyte character */ - *puc = 0xfffd; - return 5; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 4; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 3; - } - /* invalid multibyte character */ - return 2; - } - /* invalid multibyte character */ -#endif - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return n; - } - } - else if (c < 0xfe) - { - if (n >= 6) - { -#if CONFIG_UNICODE_SAFETY - if ((s[1] ^ 0x80) < 0x40) - { - if ((s[2] ^ 0x80) < 0x40) - { - if ((s[3] ^ 0x80) < 0x40) - { - if ((s[4] ^ 0x80) < 0x40) - { - if ((s[5] ^ 0x80) < 0x40) - { - if (c >= 0xfd || s[1] >= 0x84) -#endif - { - *puc = ((unsigned int) (c & 0x01) << 30) - | ((unsigned int) (s[1] ^ 0x80) << 24) - | ((unsigned int) (s[2] ^ 0x80) << 18) - | ((unsigned int) (s[3] ^ 0x80) << 12) - | ((unsigned int) (s[4] ^ 0x80) << 6) - | (unsigned int) (s[5] ^ 0x80); - return 6; - } -#if CONFIG_UNICODE_SAFETY - /* invalid multibyte character */ - *puc = 0xfffd; - return 6; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 5; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 4; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 3; - } - /* invalid multibyte character */ - return 2; - } - /* invalid multibyte character */ -#endif - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return n; - } - } -#endif - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 1; -} - -#endif diff --git a/lib/unistr/u8-mbtouc-unsafe.c b/lib/unistr/u8-mbtouc-unsafe.c deleted file mode 100644 index b73e99a1b..000000000 --- a/lib/unistr/u8-mbtouc-unsafe.c +++ /dev/null @@ -1,271 +0,0 @@ -/* Look at first character in UTF-8 string. - Copyright (C) 1999-2002, 2006-2007, 2009-2016 Free Software Foundation, Inc. - Written by Bruno Haible , 2001. - - This program is free software: you can redistribute it and/or modify it - under the terms of the GNU Lesser General Public License as published - by the Free Software Foundation; either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public License - along with this program. If not, see . */ - -#include - -#if defined IN_LIBUNISTRING -/* Tell unistr.h to declare u8_mbtouc_unsafe as 'extern', not - 'static inline'. */ -# include "unistring-notinline.h" -#endif - -/* Specification. */ -#include "unistr.h" - -#if !HAVE_INLINE - -int -u8_mbtouc_unsafe (ucs4_t *puc, const uint8_t *s, size_t n) -{ - uint8_t c = *s; - - if (c < 0x80) - { - *puc = c; - return 1; - } - else if (c >= 0xc2) - { - if (c < 0xe0) - { - if (n >= 2) - { -#if CONFIG_UNICODE_SAFETY - if ((s[1] ^ 0x80) < 0x40) -#endif - { - *puc = ((unsigned int) (c & 0x1f) << 6) - | (unsigned int) (s[1] ^ 0x80); - return 2; - } -#if CONFIG_UNICODE_SAFETY - /* invalid multibyte character */ -#endif - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return 1; - } - } - else if (c < 0xf0) - { - if (n >= 3) - { -#if CONFIG_UNICODE_SAFETY - if ((s[1] ^ 0x80) < 0x40) - { - if ((s[2] ^ 0x80) < 0x40) - { - if ((c >= 0xe1 || s[1] >= 0xa0) - && (c != 0xed || s[1] < 0xa0)) -#endif - { - *puc = ((unsigned int) (c & 0x0f) << 12) - | ((unsigned int) (s[1] ^ 0x80) << 6) - | (unsigned int) (s[2] ^ 0x80); - return 3; - } -#if CONFIG_UNICODE_SAFETY - /* invalid multibyte character */ - *puc = 0xfffd; - return 3; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 2; - } - /* invalid multibyte character */ -#endif - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - if (n == 1 || (s[1] ^ 0x80) >= 0x40) - return 1; - else - return 2; - } - } - else if (c < 0xf8) - { - if (n >= 4) - { -#if CONFIG_UNICODE_SAFETY - if ((s[1] ^ 0x80) < 0x40) - { - if ((s[2] ^ 0x80) < 0x40) - { - if ((s[3] ^ 0x80) < 0x40) - { - if ((c >= 0xf1 || s[1] >= 0x90) -#if 1 - && (c < 0xf4 || (c == 0xf4 && s[1] < 0x90)) -#endif - ) -#endif - { - *puc = ((unsigned int) (c & 0x07) << 18) - | ((unsigned int) (s[1] ^ 0x80) << 12) - | ((unsigned int) (s[2] ^ 0x80) << 6) - | (unsigned int) (s[3] ^ 0x80); - return 4; - } -#if CONFIG_UNICODE_SAFETY - /* invalid multibyte character */ - *puc = 0xfffd; - return 4; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 3; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 2; - } - /* invalid multibyte character */ -#endif - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - if (n == 1 || (s[1] ^ 0x80) >= 0x40) - return 1; - else if (n == 2 || (s[2] ^ 0x80) >= 0x40) - return 2; - else - return 3; - } - } -#if 0 - else if (c < 0xfc) - { - if (n >= 5) - { -#if CONFIG_UNICODE_SAFETY - if ((s[1] ^ 0x80) < 0x40) - { - if ((s[2] ^ 0x80) < 0x40) - { - if ((s[3] ^ 0x80) < 0x40) - { - if ((s[4] ^ 0x80) < 0x40) - { - if (c >= 0xf9 || s[1] >= 0x88) -#endif - { - *puc = ((unsigned int) (c & 0x03) << 24) - | ((unsigned int) (s[1] ^ 0x80) << 18) - | ((unsigned int) (s[2] ^ 0x80) << 12) - | ((unsigned int) (s[3] ^ 0x80) << 6) - | (unsigned int) (s[4] ^ 0x80); - return 5; - } -#if CONFIG_UNICODE_SAFETY - /* invalid multibyte character */ - *puc = 0xfffd; - return 5; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 4; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 3; - } - /* invalid multibyte character */ - return 2; - } - /* invalid multibyte character */ -#endif - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return n; - } - } - else if (c < 0xfe) - { - if (n >= 6) - { -#if CONFIG_UNICODE_SAFETY - if ((s[1] ^ 0x80) < 0x40) - { - if ((s[2] ^ 0x80) < 0x40) - { - if ((s[3] ^ 0x80) < 0x40) - { - if ((s[4] ^ 0x80) < 0x40) - { - if ((s[5] ^ 0x80) < 0x40) - { - if (c >= 0xfd || s[1] >= 0x84) -#endif - { - *puc = ((unsigned int) (c & 0x01) << 30) - | ((unsigned int) (s[1] ^ 0x80) << 24) - | ((unsigned int) (s[2] ^ 0x80) << 18) - | ((unsigned int) (s[3] ^ 0x80) << 12) - | ((unsigned int) (s[4] ^ 0x80) << 6) - | (unsigned int) (s[5] ^ 0x80); - return 6; - } -#if CONFIG_UNICODE_SAFETY - /* invalid multibyte character */ - *puc = 0xfffd; - return 6; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 5; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 4; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 3; - } - /* invalid multibyte character */ - return 2; - } - /* invalid multibyte character */ -#endif - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return n; - } - } -#endif - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 1; -} - -#endif diff --git a/lib/unistr/u8-mbtouc.c b/lib/unistr/u8-mbtouc.c deleted file mode 100644 index bfb0e4df8..000000000 --- a/lib/unistr/u8-mbtouc.c +++ /dev/null @@ -1,250 +0,0 @@ -/* Look at first character in UTF-8 string. - Copyright (C) 1999-2002, 2006-2007, 2009-2016 Free Software Foundation, Inc. - Written by Bruno Haible , 2001. - - This program is free software: you can redistribute it and/or modify it - under the terms of the GNU Lesser General Public License as published - by the Free Software Foundation; either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public License - along with this program. If not, see . */ - -#include - -#if defined IN_LIBUNISTRING -/* Tell unistr.h to declare u8_mbtouc as 'extern', not 'static inline'. */ -# include "unistring-notinline.h" -#endif - -/* Specification. */ -#include "unistr.h" - -#if !HAVE_INLINE - -int -u8_mbtouc (ucs4_t *puc, const uint8_t *s, size_t n) -{ - uint8_t c = *s; - - if (c < 0x80) - { - *puc = c; - return 1; - } - else if (c >= 0xc2) - { - if (c < 0xe0) - { - if (n >= 2) - { - if ((s[1] ^ 0x80) < 0x40) - { - *puc = ((unsigned int) (c & 0x1f) << 6) - | (unsigned int) (s[1] ^ 0x80); - return 2; - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return 1; - } - } - else if (c < 0xf0) - { - if (n >= 3) - { - if ((s[1] ^ 0x80) < 0x40) - { - if ((s[2] ^ 0x80) < 0x40) - { - if ((c >= 0xe1 || s[1] >= 0xa0) - && (c != 0xed || s[1] < 0xa0)) - { - *puc = ((unsigned int) (c & 0x0f) << 12) - | ((unsigned int) (s[1] ^ 0x80) << 6) - | (unsigned int) (s[2] ^ 0x80); - return 3; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 3; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 2; - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - if (n == 1 || (s[1] ^ 0x80) >= 0x40) - return 1; - else - return 2; - } - } - else if (c < 0xf8) - { - if (n >= 4) - { - if ((s[1] ^ 0x80) < 0x40) - { - if ((s[2] ^ 0x80) < 0x40) - { - if ((s[3] ^ 0x80) < 0x40) - { - if ((c >= 0xf1 || s[1] >= 0x90) -#if 1 - && (c < 0xf4 || (c == 0xf4 && s[1] < 0x90)) -#endif - ) - { - *puc = ((unsigned int) (c & 0x07) << 18) - | ((unsigned int) (s[1] ^ 0x80) << 12) - | ((unsigned int) (s[2] ^ 0x80) << 6) - | (unsigned int) (s[3] ^ 0x80); - return 4; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 4; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 3; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 2; - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - if (n == 1 || (s[1] ^ 0x80) >= 0x40) - return 1; - else if (n == 2 || (s[2] ^ 0x80) >= 0x40) - return 2; - else - return 3; - } - } -#if 0 - else if (c < 0xfc) - { - if (n >= 5) - { - if ((s[1] ^ 0x80) < 0x40) - { - if ((s[2] ^ 0x80) < 0x40) - { - if ((s[3] ^ 0x80) < 0x40) - { - if ((s[4] ^ 0x80) < 0x40) - { - if (c >= 0xf9 || s[1] >= 0x88) - { - *puc = ((unsigned int) (c & 0x03) << 24) - | ((unsigned int) (s[1] ^ 0x80) << 18) - | ((unsigned int) (s[2] ^ 0x80) << 12) - | ((unsigned int) (s[3] ^ 0x80) << 6) - | (unsigned int) (s[4] ^ 0x80); - return 5; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 5; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 4; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 3; - } - /* invalid multibyte character */ - return 2; - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return n; - } - } - else if (c < 0xfe) - { - if (n >= 6) - { - if ((s[1] ^ 0x80) < 0x40) - { - if ((s[2] ^ 0x80) < 0x40) - { - if ((s[3] ^ 0x80) < 0x40) - { - if ((s[4] ^ 0x80) < 0x40) - { - if ((s[5] ^ 0x80) < 0x40) - { - if (c >= 0xfd || s[1] >= 0x84) - { - *puc = ((unsigned int) (c & 0x01) << 30) - | ((unsigned int) (s[1] ^ 0x80) << 24) - | ((unsigned int) (s[2] ^ 0x80) << 18) - | ((unsigned int) (s[3] ^ 0x80) << 12) - | ((unsigned int) (s[4] ^ 0x80) << 6) - | (unsigned int) (s[5] ^ 0x80); - return 6; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 6; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 5; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 4; - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 3; - } - /* invalid multibyte character */ - return 2; - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return n; - } - } -#endif - } - /* invalid multibyte character */ - *puc = 0xfffd; - return 1; -} - -#endif diff --git a/lib/unistr/u8-mbtoucr.c b/lib/unistr/u8-mbtoucr.c deleted file mode 100644 index 5fd45b57e..000000000 --- a/lib/unistr/u8-mbtoucr.c +++ /dev/null @@ -1,285 +0,0 @@ -/* Look at first character in UTF-8 string, returning an error code. - Copyright (C) 1999-2002, 2006-2007, 2009-2016 Free Software Foundation, Inc. - Written by Bruno Haible , 2001. - - This program is free software: you can redistribute it and/or modify it - under the terms of the GNU Lesser General Public License as published - by the Free Software Foundation; either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public License - along with this program. If not, see . */ - -#include - -/* Specification. */ -#include "unistr.h" - -int -u8_mbtoucr (ucs4_t *puc, const uint8_t *s, size_t n) -{ - uint8_t c = *s; - - if (c < 0x80) - { - *puc = c; - return 1; - } - else if (c >= 0xc2) - { - if (c < 0xe0) - { - if (n >= 2) - { - if ((s[1] ^ 0x80) < 0x40) - { - *puc = ((unsigned int) (c & 0x1f) << 6) - | (unsigned int) (s[1] ^ 0x80); - return 2; - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return -2; - } - } - else if (c < 0xf0) - { - if (n >= 2) - { - if ((s[1] ^ 0x80) < 0x40 - && (c >= 0xe1 || s[1] >= 0xa0) - && (c != 0xed || s[1] < 0xa0)) - { - if (n >= 3) - { - if ((s[2] ^ 0x80) < 0x40) - { - *puc = ((unsigned int) (c & 0x0f) << 12) - | ((unsigned int) (s[1] ^ 0x80) << 6) - | (unsigned int) (s[2] ^ 0x80); - return 3; - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return -2; - } - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return -2; - } - } - else if (c < 0xf8) - { - if (n >= 2) - { - if ((s[1] ^ 0x80) < 0x40 - && (c >= 0xf1 || s[1] >= 0x90) -#if 1 - && (c < 0xf4 || (c == 0xf4 && s[1] < 0x90)) -#endif - ) - { - if (n >= 3) - { - if ((s[2] ^ 0x80) < 0x40) - { - if (n >= 4) - { - if ((s[3] ^ 0x80) < 0x40) - { - *puc = ((unsigned int) (c & 0x07) << 18) - | ((unsigned int) (s[1] ^ 0x80) << 12) - | ((unsigned int) (s[2] ^ 0x80) << 6) - | (unsigned int) (s[3] ^ 0x80); - return 4; - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return -2; - } - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return -2; - } - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return -2; - } - } -#if 0 - else if (c < 0xfc) - { - if (n >= 2) - { - if ((s[1] ^ 0x80) < 0x40 - && (c >= 0xf9 || s[1] >= 0x88)) - { - if (n >= 3) - { - if ((s[2] ^ 0x80) < 0x40) - { - if (n >= 4) - { - if ((s[3] ^ 0x80) < 0x40) - { - if (n >= 5) - { - if ((s[4] ^ 0x80) < 0x40) - { - *puc = ((unsigned int) (c & 0x03) << 24) - | ((unsigned int) (s[1] ^ 0x80) << 18) - | ((unsigned int) (s[2] ^ 0x80) << 12) - | ((unsigned int) (s[3] ^ 0x80) << 6) - | (unsigned int) (s[4] ^ 0x80); - return 5; - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return -2; - } - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return -2; - } - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return -2; - } - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return -2; - } - } - else if (c < 0xfe) - { - if (n >= 2) - { - if ((s[1] ^ 0x80) < 0x40 - && (c >= 0xfd || s[1] >= 0x84)) - { - if (n >= 3) - { - if ((s[2] ^ 0x80) < 0x40) - { - if (n >= 4) - { - if ((s[3] ^ 0x80) < 0x40) - { - if (n >= 5) - { - if ((s[4] ^ 0x80) < 0x40) - { - if (n >= 6) - { - if ((s[5] ^ 0x80) < 0x40) - { - *puc = ((unsigned int) (c & 0x01) << 30) - | ((unsigned int) (s[1] ^ 0x80) << 24) - | ((unsigned int) (s[2] ^ 0x80) << 18) - | ((unsigned int) (s[3] ^ 0x80) << 12) - | ((unsigned int) (s[4] ^ 0x80) << 6) - | (unsigned int) (s[5] ^ 0x80); - return 6; - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return -2; - } - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return -2; - } - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return -2; - } - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return -2; - } - } - /* invalid multibyte character */ - } - else - { - /* incomplete multibyte character */ - *puc = 0xfffd; - return -2; - } - } -#endif - } - /* invalid multibyte character */ - *puc = 0xfffd; - return -1; -} diff --git a/lib/unistr/u8-prev.c b/lib/unistr/u8-prev.c deleted file mode 100644 index b609acf73..000000000 --- a/lib/unistr/u8-prev.c +++ /dev/null @@ -1,93 +0,0 @@ -/* Iterate over previous character in UTF-8 string. - Copyright (C) 2002, 2006-2007, 2009-2016 Free Software Foundation, Inc. - Written by Bruno Haible , 2002. - - This program is free software: you can redistribute it and/or modify it - under the terms of the GNU Lesser General Public License as published - by the Free Software Foundation; either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public License - along with this program. If not, see . */ - -#include - -/* Specification. */ -#include "unistr.h" - -const uint8_t * -u8_prev (ucs4_t *puc, const uint8_t *s, const uint8_t *start) -{ - /* Keep in sync with unistr.h and u8-mbtouc-aux.c. */ - if (s != start) - { - uint8_t c_1 = s[-1]; - - if (c_1 < 0x80) - { - *puc = c_1; - return s - 1; - } -#if CONFIG_UNICODE_SAFETY - if ((c_1 ^ 0x80) < 0x40) -#endif - if (s - 1 != start) - { - uint8_t c_2 = s[-2]; - - if (c_2 >= 0xc2 && c_2 < 0xe0) - { - *puc = ((unsigned int) (c_2 & 0x1f) << 6) - | (unsigned int) (c_1 ^ 0x80); - return s - 2; - } -#if CONFIG_UNICODE_SAFETY - if ((c_2 ^ 0x80) < 0x40) -#endif - if (s - 2 != start) - { - uint8_t c_3 = s[-3]; - - if (c_3 >= 0xe0 && c_3 < 0xf0 -#if CONFIG_UNICODE_SAFETY - && (c_3 >= 0xe1 || c_2 >= 0xa0) - && (c_3 != 0xed || c_2 < 0xa0) -#endif - ) - { - *puc = ((unsigned int) (c_3 & 0x0f) << 12) - | ((unsigned int) (c_2 ^ 0x80) << 6) - | (unsigned int) (c_1 ^ 0x80); - return s - 3; - } -#if CONFIG_UNICODE_SAFETY - if ((c_3 ^ 0x80) < 0x40) -#endif - if (s - 3 != start) - { - uint8_t c_4 = s[-4]; - - if (c_4 >= 0xf0 && c_4 < 0xf8 -#if CONFIG_UNICODE_SAFETY - && (c_4 >= 0xf1 || c_3 >= 0x90) - && (c_4 < 0xf4 || (c_4 == 0xf4 && c_3 < 0x90)) -#endif - ) - { - *puc = ((unsigned int) (c_4 & 0x07) << 18) - | ((unsigned int) (c_3 ^ 0x80) << 12) - | ((unsigned int) (c_2 ^ 0x80) << 6) - | (unsigned int) (c_1 ^ 0x80); - return s - 4; - } - } - } - } - } - return NULL; -} diff --git a/lib/unistr/u8-uctomb-aux.c b/lib/unistr/u8-uctomb-aux.c deleted file mode 100644 index 48adae10e..000000000 --- a/lib/unistr/u8-uctomb-aux.c +++ /dev/null @@ -1,69 +0,0 @@ -/* Conversion UCS-4 to UTF-8. - Copyright (C) 2002, 2006-2007, 2009-2016 Free Software Foundation, Inc. - Written by Bruno Haible , 2002. - - This program is free software: you can redistribute it and/or modify it - under the terms of the GNU Lesser General Public License as published - by the Free Software Foundation; either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public License - along with this program. If not, see . */ - -#include - -/* Specification. */ -#include "unistr.h" - -int -u8_uctomb_aux (uint8_t *s, ucs4_t uc, int n) -{ - int count; - - if (uc < 0x80) - /* The case n >= 1 is already handled by the caller. */ - return -2; - else if (uc < 0x800) - count = 2; - else if (uc < 0x10000) - { - if (uc < 0xd800 || uc >= 0xe000) - count = 3; - else - return -1; - } -#if 0 - else if (uc < 0x200000) - count = 4; - else if (uc < 0x4000000) - count = 5; - else if (uc <= 0x7fffffff) - count = 6; -#else - else if (uc < 0x110000) - count = 4; -#endif - else - return -1; - - if (n < count) - return -2; - - switch (count) /* note: code falls through cases! */ - { -#if 0 - case 6: s[5] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x4000000; - case 5: s[4] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x200000; -#endif - case 4: s[3] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x10000; - case 3: s[2] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x800; - case 2: s[1] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0xc0; - /*case 1:*/ s[0] = uc; - } - return count; -} diff --git a/lib/unistr/u8-uctomb.c b/lib/unistr/u8-uctomb.c deleted file mode 100644 index d62ad0fa1..000000000 --- a/lib/unistr/u8-uctomb.c +++ /dev/null @@ -1,88 +0,0 @@ -/* Store a character in UTF-8 string. - Copyright (C) 2002, 2005-2006, 2009-2016 Free Software Foundation, Inc. - Written by Bruno Haible , 2002. - - This program is free software: you can redistribute it and/or modify it - under the terms of the GNU Lesser General Public License as published - by the Free Software Foundation; either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public License - along with this program. If not, see . */ - -#include - -#if defined IN_LIBUNISTRING -/* Tell unistr.h to declare u8_uctomb as 'extern', not 'static inline'. */ -# include "unistring-notinline.h" -#endif - -/* Specification. */ -#include "unistr.h" - -#if !HAVE_INLINE - -int -u8_uctomb (uint8_t *s, ucs4_t uc, int n) -{ - if (uc < 0x80) - { - if (n > 0) - { - s[0] = uc; - return 1; - } - /* else return -2, below. */ - } - else - { - int count; - - if (uc < 0x800) - count = 2; - else if (uc < 0x10000) - { - if (uc < 0xd800 || uc >= 0xe000) - count = 3; - else - return -1; - } -#if 0 - else if (uc < 0x200000) - count = 4; - else if (uc < 0x4000000) - count = 5; - else if (uc <= 0x7fffffff) - count = 6; -#else - else if (uc < 0x110000) - count = 4; -#endif - else - return -1; - - if (n >= count) - { - switch (count) /* note: code falls through cases! */ - { -#if 0 - case 6: s[5] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x4000000; - case 5: s[4] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x200000; -#endif - case 4: s[3] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x10000; - case 3: s[2] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0x800; - case 2: s[1] = 0x80 | (uc & 0x3f); uc = uc >> 6; uc |= 0xc0; - /*case 1:*/ s[0] = uc; - } - return count; - } - } - return -2; -} - -#endif diff --git a/lib/unitypes.in.h b/lib/unitypes.in.h deleted file mode 100644 index 4a1e65ede..000000000 --- a/lib/unitypes.in.h +++ /dev/null @@ -1,46 +0,0 @@ -/* Elementary types and macros for the GNU UniString library. - Copyright (C) 2002, 2005-2006, 2009-2016 Free Software Foundation, Inc. - - This program is free software: you can redistribute it and/or modify it - under the terms of the GNU Lesser General Public License as published - by the Free Software Foundation; either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public License - along with this program. If not, see . */ - -#ifndef _UNITYPES_H -#define _UNITYPES_H - -/* Get uint8_t, uint16_t, uint32_t. */ -#include - -/* Type representing a Unicode character. */ -typedef uint32_t ucs4_t; - -/* Attribute of a function whose result depends only on the arguments - (not pointers!) and which has no side effects. */ -#ifndef _UC_ATTRIBUTE_CONST -# if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 95) -# define _UC_ATTRIBUTE_CONST __attribute__ ((__const__)) -# else -# define _UC_ATTRIBUTE_CONST -# endif -#endif - -/* Attribute of a function whose result depends only on the arguments - (possibly pointers) and global memory, and which has no side effects. */ -#ifndef _UC_ATTRIBUTE_PURE -# if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 96) -# define _UC_ATTRIBUTE_PURE __attribute__ ((__pure__)) -# else -# define _UC_ATTRIBUTE_PURE -# endif -#endif - -#endif /* _UNITYPES_H */ diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index 917e7ffbe..fc4fbc631 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -27,7 +27,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --lgpl=3 --conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkstemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar +# gnulib-tool --import --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --avoid=unistr/base --avoid=unistr/u8-mbtouc --avoid=unistr/u8-mbtouc-unsafe --avoid=unistr/u8-mbtoucr --avoid=unistr/u8-prev --avoid=unistr/u8-uctomb --avoid=unitypes --lgpl=3 --conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkstemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([gnulib-local]) @@ -126,7 +126,7 @@ gl_MODULES([ warnings wchar ]) -gl_AVOID([ lock]) +gl_AVOID([ lock unistr/base unistr/u8-mbtouc unistr/u8-mbtouc-unsafe unistr/u8-mbtoucr unistr/u8-prev unistr/u8-uctomb unitypes]) gl_SOURCE_BASE([lib]) gl_M4_BASE([m4]) gl_PO_BASE([]) diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index fbdb1e85c..98de2b765 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -42,7 +42,6 @@ AC_DEFUN([gl_EARLY], AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) AC_REQUIRE([gl_PROG_AR_RANLIB]) - AC_REQUIRE([AM_PROG_CC_C_O]) # Code from module absolute-header: # Code from module accept: # Code from module alignof: @@ -117,7 +116,6 @@ AC_DEFUN([gl_EARLY], # Code from module include_next: # Code from module inet_ntop: # Code from module inet_pton: - # Code from module inline: # Code from module intprops: # Code from module isfinite: # Code from module isinf: @@ -197,7 +195,6 @@ AC_DEFUN([gl_EARLY], # Code from module snippet/_Noreturn: # Code from module snippet/arg-nonnull: # Code from module snippet/c++defs: - # Code from module snippet/unused-parameter: # Code from module snippet/warn-on-use: # Code from module snprintf: # Code from module socket: @@ -234,13 +231,6 @@ AC_DEFUN([gl_EARLY], # Code from module times: # Code from module trunc: # Code from module unistd: - # Code from module unistr/base: - # Code from module unistr/u8-mbtouc: - # Code from module unistr/u8-mbtouc-unsafe: - # Code from module unistr/u8-mbtoucr: - # Code from module unistr/u8-prev: - # Code from module unistr/u8-uctomb: - # Code from module unitypes: # Code from module unsetenv: # Code from module useless-if-before-free: # Code from module vasnprintf: @@ -436,7 +426,6 @@ AC_DEFUN([gl_INIT], gl_PREREQ_INET_PTON fi gl_ARPA_INET_MODULE_INDICATOR([inet_pton]) - gl_INLINE gl_ISFINITE if test $REPLACE_ISFINITE = 1; then AC_LIBOBJ([isfinite]) @@ -702,17 +691,6 @@ AC_DEFUN([gl_INIT], fi gl_MATH_MODULE_INDICATOR([trunc]) gl_UNISTD_H - gl_LIBUNISTRING_LIBHEADER([0.9.4], [unistr.h]) - gl_MODULE_INDICATOR([unistr/u8-mbtouc]) - gl_LIBUNISTRING_MODULE([0.9.4], [unistr/u8-mbtouc]) - gl_MODULE_INDICATOR([unistr/u8-mbtouc-unsafe]) - gl_LIBUNISTRING_MODULE([0.9.4], [unistr/u8-mbtouc-unsafe]) - gl_MODULE_INDICATOR([unistr/u8-mbtoucr]) - gl_LIBUNISTRING_MODULE([0.9], [unistr/u8-mbtoucr]) - gl_LIBUNISTRING_MODULE([0.9], [unistr/u8-prev]) - gl_MODULE_INDICATOR([unistr/u8-uctomb]) - gl_LIBUNISTRING_MODULE([0.9], [unistr/u8-uctomb]) - gl_LIBUNISTRING_LIBHEADER([0.9.4], [unitypes.h]) gl_FUNC_VSNPRINTF gl_STDIO_MODULE_INDICATOR([vsnprintf]) gl_WCHAR_H @@ -1698,7 +1676,6 @@ AC_DEFUN([gl_FILE_LIST], [ build-aux/snippet/_Noreturn.h build-aux/snippet/arg-nonnull.h build-aux/snippet/c++defs.h - build-aux/snippet/unused-parameter.h build-aux/snippet/warn-on-use.h build-aux/useless-if-before-free build-aux/vc-list-files @@ -1906,16 +1883,6 @@ AC_DEFUN([gl_FILE_LIST], [ lib/trunc.c lib/unistd.c lib/unistd.in.h - lib/unistr.in.h - lib/unistr/u8-mbtouc-aux.c - lib/unistr/u8-mbtouc-unsafe-aux.c - lib/unistr/u8-mbtouc-unsafe.c - lib/unistr/u8-mbtouc.c - lib/unistr/u8-mbtoucr.c - lib/unistr/u8-prev.c - lib/unistr/u8-uctomb-aux.c - lib/unistr/u8-uctomb.c - lib/unitypes.in.h lib/unsetenv.c lib/vasnprintf.c lib/vasnprintf.h @@ -1983,7 +1950,6 @@ AC_DEFUN([gl_FILE_LIST], [ m4/include_next.m4 m4/inet_ntop.m4 m4/inet_pton.m4 - m4/inline.m4 m4/intmax_t.m4 m4/inttypes_h.m4 m4/isfinite.m4 @@ -1999,7 +1965,6 @@ AC_DEFUN([gl_FILE_LIST], [ m4/lib-ld.m4 m4/lib-link.m4 m4/lib-prefix.m4 - m4/libunistring-base.m4 m4/libunistring.m4 m4/link.m4 m4/localcharset.m4 diff --git a/m4/inline.m4 b/m4/inline.m4 deleted file mode 100644 index 28fd2d091..000000000 --- a/m4/inline.m4 +++ /dev/null @@ -1,40 +0,0 @@ -# inline.m4 serial 4 -dnl Copyright (C) 2006, 2009-2016 Free Software Foundation, Inc. -dnl This file is free software; the Free Software Foundation -dnl gives unlimited permission to copy and/or distribute it, -dnl with or without modifications, as long as this notice is preserved. - -dnl Test for the 'inline' keyword or equivalent. -dnl Define 'inline' to a supported equivalent, or to nothing if not supported, -dnl like AC_C_INLINE does. Also, define HAVE_INLINE if 'inline' or an -dnl equivalent is effectively supported, i.e. if the compiler is likely to -dnl drop unused 'static inline' functions. -AC_DEFUN([gl_INLINE], -[ - AC_REQUIRE([AC_C_INLINE]) - AC_CACHE_CHECK([whether the compiler generally respects inline], - [gl_cv_c_inline_effective], - [if test $ac_cv_c_inline = no; then - gl_cv_c_inline_effective=no - else - dnl GCC defines __NO_INLINE__ if not optimizing or if -fno-inline is - dnl specified. - dnl Use AC_COMPILE_IFELSE here, not AC_EGREP_CPP, because the result - dnl depends on optimization flags, which can be in CFLAGS. - dnl (AC_EGREP_CPP looks only at the CPPFLAGS.) - AC_COMPILE_IFELSE( - [AC_LANG_PROGRAM([[]], - [[#ifdef __NO_INLINE__ - #error "inline is not effective" - #endif]])], - [gl_cv_c_inline_effective=yes], - [gl_cv_c_inline_effective=no]) - fi - ]) - if test $gl_cv_c_inline_effective = yes; then - AC_DEFINE([HAVE_INLINE], [1], - [Define to 1 if the compiler supports one of the keywords - 'inline', '__inline__', '__inline' and effectively inlines - functions marked as such.]) - fi -]) diff --git a/m4/libunistring-base.m4 b/m4/libunistring-base.m4 deleted file mode 100644 index f911216b5..000000000 --- a/m4/libunistring-base.m4 +++ /dev/null @@ -1,141 +0,0 @@ -# libunistring-base.m4 serial 5 -dnl Copyright (C) 2010-2016 Free Software Foundation, Inc. -dnl This file is free software; the Free Software Foundation -dnl gives unlimited permission to copy and/or distribute it, -dnl with or without modifications, as long as this notice is preserved. - -dnl From Paolo Bonzini and Bruno Haible. - -dnl gl_LIBUNISTRING_MODULE([VERSION], [Module]) -dnl Declares that the source files of Module should be compiled, unless we -dnl are linking with libunistring and its version is >= the given VERSION. -dnl Defines an automake conditional LIBUNISTRING_COMPILE_$MODULE that is -dnl true if the source files of Module should be compiled. -dnl This macro is to be used for public libunistring API, not for -dnl undocumented API. -dnl -dnl You have to bump the VERSION argument to the next projected version -dnl number each time you make a change that affects the behaviour of the -dnl functions defined in Module (even if the sources of Module itself do not -dnl change). - -AC_DEFUN([gl_LIBUNISTRING_MODULE], -[ - AC_REQUIRE([gl_LIBUNISTRING_LIB_PREPARE]) - dnl Use the variables HAVE_LIBUNISTRING, LIBUNISTRING_VERSION from - dnl gl_LIBUNISTRING_CORE if that macro has been run. - AM_CONDITIONAL(AS_TR_CPP([LIBUNISTRING_COMPILE_$2]), - [gl_LIBUNISTRING_VERSION_CMP([$1])]) -]) - -dnl gl_LIBUNISTRING_LIBHEADER([VERSION], [HeaderFile]) -dnl Declares that HeaderFile should be created, unless we are linking -dnl with libunistring and its version is >= the given VERSION. -dnl HeaderFile should be relative to the lib directory and end in '.h'. -dnl Prepares for substituting LIBUNISTRING_HEADERFILE (to HeaderFile or empty). -dnl -dnl When we are linking with the already installed libunistring and its version -dnl is < VERSION, we create HeaderFile here, because we may compile functions -dnl (via gl_LIBUNISTRING_MODULE above) that are not contained in the installed -dnl version. -dnl When we are linking with the already installed libunistring and its version -dnl is > VERSION, we don't create HeaderFile here: it could cause compilation -dnl errors in other libunistring header files if some types are missing. -dnl -dnl You have to bump the VERSION argument to the next projected version -dnl number each time you make a non-comment change to the HeaderFile. - -AC_DEFUN([gl_LIBUNISTRING_LIBHEADER], -[ - AC_REQUIRE([gl_LIBUNISTRING_LIB_PREPARE]) - dnl Use the variables HAVE_LIBUNISTRING, LIBUNISTRING_VERSION from - dnl gl_LIBUNISTRING_CORE if that macro has been run. - if gl_LIBUNISTRING_VERSION_CMP([$1]); then - LIBUNISTRING_[]AS_TR_CPP([$2])='$2' - else - LIBUNISTRING_[]AS_TR_CPP([$2])= - fi - AC_SUBST([LIBUNISTRING_]AS_TR_CPP([$2])) -]) - -dnl Miscellaneous preparations/initializations. - -AC_DEFUN([gl_LIBUNISTRING_LIB_PREPARE], -[ - dnl Ensure that HAVE_LIBUNISTRING is fully determined at this point. - m4_ifdef([gl_LIBUNISTRING], [AC_REQUIRE([gl_LIBUNISTRING])]) - - AC_REQUIRE([AC_PROG_AWK]) - -dnl Sed expressions to extract the parts of a version number. -changequote(,) -gl_libunistring_sed_extract_major='/^[0-9]/{s/^\([0-9]*\).*/\1/p;q;} -i\ -0 -q -' -gl_libunistring_sed_extract_minor='/^[0-9][0-9]*[.][0-9]/{s/^[0-9]*[.]\([0-9]*\).*/\1/p;q;} -i\ -0 -q -' -gl_libunistring_sed_extract_subminor='/^[0-9][0-9]*[.][0-9][0-9]*[.][0-9]/{s/^[0-9]*[.][0-9]*[.]\([0-9]*\).*/\1/p;q;} -i\ -0 -q -' -changequote([,]) - - if test "$HAVE_LIBUNISTRING" = yes; then - LIBUNISTRING_VERSION_MAJOR=`echo "$LIBUNISTRING_VERSION" | sed -n -e "$gl_libunistring_sed_extract_major"` - LIBUNISTRING_VERSION_MINOR=`echo "$LIBUNISTRING_VERSION" | sed -n -e "$gl_libunistring_sed_extract_minor"` - LIBUNISTRING_VERSION_SUBMINOR=`echo "$LIBUNISTRING_VERSION" | sed -n -e "$gl_libunistring_sed_extract_subminor"` - fi -]) - -dnl gl_LIBUNISTRING_VERSION_CMP([VERSION]) -dnl Expands to a shell statement that evaluates to true if LIBUNISTRING_VERSION -dnl is less than the VERSION argument. -AC_DEFUN([gl_LIBUNISTRING_VERSION_CMP], -[ { test "$HAVE_LIBUNISTRING" != yes \ - || { - dnl AS_LITERAL_IF exists and works fine since autoconf-2.59 at least. - AS_LITERAL_IF([$1], - [dnl This is the optimized variant, that assumes the argument is a literal: - m4_pushdef([requested_version_major], - [gl_LIBUNISTRING_ARG_OR_ZERO(m4_bpatsubst([$1], [^\([0-9]*\).*], [\1]), [])]) - m4_pushdef([requested_version_minor], - [gl_LIBUNISTRING_ARG_OR_ZERO(m4_bpatsubst([$1], [^[0-9]*[.]\([0-9]*\).*], [\1]), [$1])]) - m4_pushdef([requested_version_subminor], - [gl_LIBUNISTRING_ARG_OR_ZERO(m4_bpatsubst([$1], [^[0-9]*[.][0-9]*[.]\([0-9]*\).*], [\1]), [$1])]) - test $LIBUNISTRING_VERSION_MAJOR -lt requested_version_major \ - || { test $LIBUNISTRING_VERSION_MAJOR -eq requested_version_major \ - && { test $LIBUNISTRING_VERSION_MINOR -lt requested_version_minor \ - || { test $LIBUNISTRING_VERSION_MINOR -eq requested_version_minor \ - && test $LIBUNISTRING_VERSION_SUBMINOR -lt requested_version_subminor - } - } - } - m4_popdef([requested_version_subminor]) - m4_popdef([requested_version_minor]) - m4_popdef([requested_version_major]) - ], - [dnl This is the unoptimized variant: - requested_version_major=`echo '$1' | sed -n -e "$gl_libunistring_sed_extract_major"` - requested_version_minor=`echo '$1' | sed -n -e "$gl_libunistring_sed_extract_minor"` - requested_version_subminor=`echo '$1' | sed -n -e "$gl_libunistring_sed_extract_subminor"` - test $LIBUNISTRING_VERSION_MAJOR -lt $requested_version_major \ - || { test $LIBUNISTRING_VERSION_MAJOR -eq $requested_version_major \ - && { test $LIBUNISTRING_VERSION_MINOR -lt $requested_version_minor \ - || { test $LIBUNISTRING_VERSION_MINOR -eq $requested_version_minor \ - && test $LIBUNISTRING_VERSION_SUBMINOR -lt $requested_version_subminor - } - } - } - ]) - } - }]) - -dnl gl_LIBUNISTRING_ARG_OR_ZERO([ARG], [ORIG]) expands to ARG if it is not the -dnl same as ORIG, otherwise to 0. -m4_define([gl_LIBUNISTRING_ARG_OR_ZERO], [m4_if([$1], [$2], [0], [$1])]) From 38f23e75a5508bc6c1016f1809dc522e36ccd08b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 10 Jul 2016 13:21:38 +0200 Subject: [PATCH 447/865] Add meta/build-env * meta/build-env.in: New file which sets up an environment that does not inherit GUILE_LOAD_PATH / GUILE_LOAD_COMPILED_PATH (unless cross-compiling). * doc/ref/Makefile.am (autoconf-macros.texi): * libguile/Makefile.am (snarf2checkedtexi): * module/Makefile.am (ice-9/psyntax-pp.go): * test-suite/standalone/Makefile.am (GUILE_INSTALL_LOCALE): * am/bootstrap.am (.scm.go): * am/guilec (.scm.go): Use build-env. * configure.ac: Create build-env. --- am/bootstrap.am | 2 +- am/guilec | 4 +- configure.ac | 1 + doc/ref/Makefile.am | 2 +- libguile/Makefile.am | 2 +- meta/build-env.in | 121 ++++++++++++++++++++++++++++++ module/Makefile.am | 2 +- test-suite/standalone/Makefile.am | 2 +- 8 files changed, 129 insertions(+), 7 deletions(-) create mode 100644 meta/build-env.in diff --git a/am/bootstrap.am b/am/bootstrap.am index 0eaa87b06..d5f25abfa 100644 --- a/am/bootstrap.am +++ b/am/bootstrap.am @@ -41,7 +41,7 @@ SUFFIXES = .scm .go .scm.go: $(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \ - $(top_builddir)/meta/uninstalled-env \ + $(top_builddir)/meta/build-env \ guild compile --target="$(GUILE_TARGET)" \ $(GUILE_WARNINGS) $(GUILE_OPTIMIZATIONS) \ -L "$(abs_top_srcdir)/module" \ diff --git a/am/guilec b/am/guilec index 7ab9cccb7..fa2054eeb 100644 --- a/am/guilec +++ b/am/guilec @@ -28,7 +28,7 @@ SUFFIXES = .scm .el .go .scm.go: $(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \ - $(top_builddir)/meta/uninstalled-env \ + $(top_builddir)/meta/build-env \ guild compile --target="$(host)" $(GUILE_WARNINGS) \ -L "$(abs_srcdir)" -L "$(abs_builddir)" \ -L "$(abs_top_srcdir)/guile-readline" \ @@ -36,7 +36,7 @@ SUFFIXES = .scm .el .go .el.go: $(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \ - $(top_builddir)/meta/uninstalled-env \ + $(top_builddir)/meta/build-env \ guild compile --target="$(host)" $(GUILE_WARNINGS) \ -L "$(abs_srcdir)" -L "$(abs_builddir)" \ -L "$(abs_top_srcdir)/guile-readline" \ diff --git a/configure.ac b/configure.ac index 4c78b0712..1735c5606 100644 --- a/configure.ac +++ b/configure.ac @@ -1663,6 +1663,7 @@ AC_CONFIG_FILES([ GUILE_CONFIG_SCRIPT([check-guile]) GUILE_CONFIG_SCRIPT([benchmark-guile]) GUILE_CONFIG_SCRIPT([meta/guile]) +GUILE_CONFIG_SCRIPT([meta/build-env]) GUILE_CONFIG_SCRIPT([meta/uninstalled-env]) GUILE_CONFIG_SCRIPT([meta/gdb-uninstalled-guile]) GUILE_CONFIG_SCRIPT([libguile/guile-snarf]) diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index 83c6e5ee0..ada4f363b 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -120,7 +120,7 @@ EXTRA_DIST = ChangeLog-2008 $(PICTURES) libguile-autoconf.texi: autoconf-macros.texi autoconf-macros.texi: $(top_srcdir)/meta/guile.m4 - GUILE_AUTO_COMPILE=0 $(top_builddir)/meta/uninstalled-env guild \ + GUILE_AUTO_COMPILE=0 $(top_builddir)/meta/build-env guild \ snarf-guile-m4-docs $(top_srcdir)/meta/guile.m4 \ > $(srcdir)/$@ diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 909101c51..855a57faa 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -762,7 +762,7 @@ load.x: libpath.h dynl.x: libpath.h alldotdocfiles = $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) -snarf2checkedtexi = GUILE_AUTO_COMPILE=0 $(top_builddir)/meta/uninstalled-env guild snarf-check-and-output-texi +snarf2checkedtexi = GUILE_AUTO_COMPILE=0 $(top_builddir)/meta/build-env guild snarf-check-and-output-texi dotdoc2texi = cat $(alldotdocfiles) | $(snarf2checkedtexi) guile.texi: $(alldotdocfiles) guile$(EXEEXT) diff --git a/meta/build-env.in b/meta/build-env.in new file mode 100644 index 000000000..7a5bf3339 --- /dev/null +++ b/meta/build-env.in @@ -0,0 +1,121 @@ +#!/bin/sh + +# Copyright (C) 2003, 2006, 2008-2012, 2016 Free Software Foundation +# +# This file is part of GNU Guile. +# +# This script is free software; you can redistribute it and/or modify +# it under the terms of the GNU Lesser General Public License as +# published by the Free Software Foundation; either version 3 of the +# License, or (at your option) any later version. +# +# This library is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# Lesser General Public License for more details. +# +# You should have received a copy of the GNU Lesser General Public +# License along with this library; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +# 02110-1301 USA + +# Usage: build-env [ARGS] + +# This script arranges for the environment to support running Guile from +# the build tree. Unlike uninstalled-env, we clobber the environment so +# as to avoid inheriting environment variables that could make Guile +# load .scm, .go, or .so files from installed directories. + +# Example: build-env guile -c '(display "hello\n")' +# Example: ../../build-env ./guile-test-foo + +top_srcdir="@top_srcdir_absolute@" +top_builddir="@top_builddir_absolute@" + +[ x"$top_srcdir" = x -o ! -d "$top_srcdir" -o \ + x"$top_builddir" = x -o ! -d "$top_builddir" ] && { + echo $0: bad environment + echo top_srcdir=$top_srcdir + echo top_builddir=$top_builddir + exit 1 +} + +# When cross-compiling, let $GUILE_FOR_BUILD use its own .go files since +# the ones that are being built may be incompatible ($GUILE_FOR_BUILD is +# typically used to run `guild compile --target=$host'.) Likewise, +# $GUILE_FOR_BUILD must use its own source files when booting; for +# instance, $srcdir/module/ice-9/boot-9.scm must not be in its search +# path, because it would then end up using its C evaluator to run the +# compiler. +if test "@cross_compiling@" = "no" +then + GUILE_LOAD_PATH="${top_srcdir}/module:${top_srcdir}/guile-readline" + if test "${top_srcdir}" != "${top_builddir}"; then + GUILE_LOAD_PATH="$GUILE_LOAD_PATH:${top_builddir}/module:${top_builddir}/guile-readline" + fi + export GUILE_LOAD_PATH + GUILE_LOAD_COMPILED_PATH="${top_builddir}/module:${top_builddir}/bootstrap:${top_builddir}/prebuilt/@host@:${top_builddir}/guile-readline" + export GUILE_LOAD_COMPILED_PATH + + # Don't look in installed dirs for guile modules + if ( env | grep -v '^GUILE_SYSTEM_PATH=' > /dev/null ); then + GUILE_SYSTEM_PATH= + export GUILE_SYSTEM_PATH + fi + # Don't look in installed dirs for compiled guile modules + if ( env | grep -v '^GUILE_SYSTEM_COMPILED_PATH=' > /dev/null ); then + GUILE_SYSTEM_COMPILED_PATH= + export GUILE_SYSTEM_COMPILED_PATH + fi + # Don't look in installed dirs for dlopen-able modules + if ( env | grep -v '^GUILE_SYSTEM_EXTENSIONS_PATH=' > /dev/null ); then + GUILE_SYSTEM_EXTENSIONS_PATH= + export GUILE_SYSTEM_EXTENSIONS_PATH + fi +fi + +# handle LTDL_LIBRARY_PATH (no clobber) +for dir in guile-readline libguile ; do + if test -z "$LTDL_LIBRARY_PATH"; then + LTDL_LIBRARY_PATH="${top_builddir}/${dir}" + else + LTDL_LIBRARY_PATH="${top_builddir}/${dir}:${LTDL_LIBRARY_PATH}" + fi + if test -z "$DYLD_LIBRARY_PATH"; then + DYLD_LIBRARY_PATH="${top_builddir}/${dir}/.libs" + else + DYLD_LIBRARY_PATH="${top_builddir}/${dir}/.libs:${DYLD_LIBRARY_PATH}" + fi +done +export LTDL_LIBRARY_PATH +export DYLD_LIBRARY_PATH + +if [ x"$PKG_CONFIG_PATH" = x ] +then + PKG_CONFIG_PATH="${top_builddir}/meta" +else + PKG_CONFIG_PATH="${top_builddir}/meta:$PKG_CONFIG_PATH" +fi +export PKG_CONFIG_PATH + +# handle PATH (no clobber) +PATH="${top_builddir}/libguile:${PATH}" +PATH="${top_srcdir}/meta:${PATH}" +if test "x${top_srcdir}" != "x${top_builddir}"; then + PATH="${top_builddir}/meta:${PATH}" +fi +export PATH + +# Define $GUILE, used by `guild'. +if test "@cross_compiling@" = "no" +then + GUILE=${top_builddir}/libguile/guile@EXEEXT@ +else + GUILE="@GUILE_FOR_BUILD@" +fi +export GUILE + +XDG_CACHE_HOME=${top_builddir}/cache +export XDG_CACHE_HOME + +exec "$@" diff --git a/module/Makefile.am b/module/Makefile.am index 3f14ed8b4..f590fb96d 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -36,7 +36,7 @@ $(nobase_ccache_DATA): ../bootstrap/ice-9/eval.go # Keep this rule in sync with that in `am/guilec'. ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm $(AM_V_GUILEC)GUILE_AUTO_COMPILE=0 \ - $(top_builddir)/meta/uninstalled-env \ + $(top_builddir)/meta/build-env \ guild compile --target="$(host)" $(GUILE_WARNINGS) \ -L "$(abs_srcdir)" -L "$(abs_builddir)" \ -L "$(abs_top_srcdir)/guile-readline" \ diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index 524a1445e..2aba708da 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -35,7 +35,7 @@ TESTS_ENVIRONMENT = \ srcdir="$(srcdir)" \ builddir="$(builddir)" \ @LOCALCHARSET_TESTS_ENVIRONMENT@ \ - GUILE_AUTO_COMPILE=0 "${top_builddir}/meta/uninstalled-env" + GUILE_AUTO_COMPILE=0 "${top_builddir}/meta/build-env" ## Check for headers in $(srcdir) and build dir before $(CPPFLAGS), which ## may point us to an old, installed version of guile. From 867316ffcd65bd1e5e23813c22ba2515586ae845 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 11 Jul 2016 09:26:25 +0200 Subject: [PATCH 448/865] build-env: prebuilt .go files are in srcdir * meta/build-env.in (GUILE_LOAD_COMPILED_PATH): Look for prebuilt files in the srcdir, not the builddir. --- meta/build-env.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/meta/build-env.in b/meta/build-env.in index 7a5bf3339..b271d0bc8 100644 --- a/meta/build-env.in +++ b/meta/build-env.in @@ -54,7 +54,7 @@ then GUILE_LOAD_PATH="$GUILE_LOAD_PATH:${top_builddir}/module:${top_builddir}/guile-readline" fi export GUILE_LOAD_PATH - GUILE_LOAD_COMPILED_PATH="${top_builddir}/module:${top_builddir}/bootstrap:${top_builddir}/prebuilt/@host@:${top_builddir}/guile-readline" + GUILE_LOAD_COMPILED_PATH="${top_builddir}/module:${top_builddir}/bootstrap:${top_srcdir}/prebuilt/@host@:${top_builddir}/guile-readline" export GUILE_LOAD_COMPILED_PATH # Don't look in installed dirs for guile modules From 147ba05deedfd3198daa07087d5fba09da117697 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 11 Jul 2016 10:59:04 +0200 Subject: [PATCH 449/865] build: Remove unneeded check for 'unsetenv'. * configure.ac: Remove check for 'unsetenv', which is unneeded since we use Gnulib's 'unsetenv'. --- configure.ac | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/configure.ac b/configure.ac index 1735c5606..e9ce9e62b 100644 --- a/configure.ac +++ b/configure.ac @@ -5,7 +5,7 @@ dnl define(GUILE_CONFIGURE_COPYRIGHT,[[ Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, - 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc. + 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 Free Software Foundation, Inc. This file is part of GUILE @@ -765,7 +765,7 @@ AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \ strptime symlink sync sysconf tcgetpgrp tcsetpgrp uname waitpid \ strdup system usleep atexit on_exit chown link fcntl ttyname getpwent \ getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp \ - index bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron \ + index bcopy memcpy rindex truncate isblank _NSGetEnviron \ strcoll strcoll_l strtod_l strtol_l newlocale uselocale utimensat \ sched_getaffinity sched_setaffinity sendfile]) From abb0b54be8167bef2d7772697645f51f72432eaa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 11 Jul 2016 11:00:38 +0200 Subject: [PATCH 450/865] Unconditionally include from Gnulib. * libguile/stime.c: Unconditionally include . --- libguile/stime.c | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/libguile/stime.c b/libguile/stime.c index f656d886c..232ec6f2f 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -61,11 +61,7 @@ #include "libguile/stime.h" #include - - -#ifdef HAVE_CLOCK_GETTIME -# include -#endif +#include /* Gnulib-provided */ #include #include From b505ad9ad335de453e0ebcbd4e63e866e09092b0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 11 Jul 2016 11:01:16 +0200 Subject: [PATCH 451/865] Add missing 'const' qualifier. * libguile/stime.c (tzvar): Add 'const'. --- libguile/stime.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/stime.c b/libguile/stime.c index 232ec6f2f..d8c825106 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -327,7 +327,7 @@ filltime (struct tm *bd_time, int zoff, const char *zname) return result; } -static char tzvar[3] = "TZ"; +static const char tzvar[3] = "TZ"; /* if zone is set, create a temporary environment with only a TZ string. other threads or interrupt handlers shouldn't be allowed From a9e726eda73b8f08ce64b201471b46789a105a7a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 11 Jul 2016 22:14:38 +0200 Subject: [PATCH 452/865] More robust setuid, setgid, etc detection * configure.ac: Check for getuid, getgid, setuid, and setgid. * libguile/posix.c (scm_getuid, scm_getgid, scm_setuid, scm_setgid): Only provide Scheme functions if the OS provides these facilities. (scm_geteuid, scm_getegid, scm_seteuid, scm_setegid): Provide if the host has getuid, getgid, etc, instead of being in a MinGW guard. --- configure.ac | 4 ++-- libguile/posix.c | 30 ++++++++++++++++-------------- 2 files changed, 18 insertions(+), 16 deletions(-) diff --git a/configure.ac b/configure.ac index e9ce9e62b..7bddae766 100644 --- a/configure.ac +++ b/configure.ac @@ -759,9 +759,9 @@ AC_CHECK_HEADERS([assert.h crt_externs.h]) # AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \ fesetround ftime ftruncate fchown fchmod getcwd geteuid getsid \ - gettimeofday gmtime_r ioctl lstat mkdir mknod nice \ + gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mknod nice \ readdir_r readdir64_r readlink rename rmdir setegid seteuid \ - setlocale setpgid setsid sigaction siginterrupt stat64 \ + setlocale setuid setgid setpgid setsid sigaction siginterrupt stat64 \ strptime symlink sync sysconf tcgetpgrp tcsetpgrp uname waitpid \ strdup system usleep atexit on_exit chown link fcntl ttyname getpwent \ getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp \ diff --git a/libguile/posix.c b/libguile/posix.c index 494df1e0c..dfb5bf9c9 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -800,8 +800,7 @@ SCM_DEFINE (scm_getppid, "getppid", 0, 0, 0, #undef FUNC_NAME #endif /* HAVE_GETPPID */ - -#ifndef __MINGW32__ +#ifdef HAVE_GETUID SCM_DEFINE (scm_getuid, "getuid", 0, 0, 0, (), "Return an integer representing the current real user ID.") @@ -810,9 +809,9 @@ SCM_DEFINE (scm_getuid, "getuid", 0, 0, 0, return scm_from_int (getuid ()); } #undef FUNC_NAME +#endif /* HAVE_GETUID */ - - +#ifdef HAVE_GETGID SCM_DEFINE (scm_getgid, "getgid", 0, 0, 0, (), "Return an integer representing the current real group ID.") @@ -821,9 +820,9 @@ SCM_DEFINE (scm_getgid, "getgid", 0, 0, 0, return scm_from_int (getgid ()); } #undef FUNC_NAME +#endif /* HAVE_GETGID */ - - +#ifdef HAVE_GETUID SCM_DEFINE (scm_geteuid, "geteuid", 0, 0, 0, (), "Return an integer representing the current effective user ID.\n" @@ -839,8 +838,9 @@ SCM_DEFINE (scm_geteuid, "geteuid", 0, 0, 0, #endif } #undef FUNC_NAME +#endif /* HAVE_GETUID */ - +#ifdef HAVE_GETGID SCM_DEFINE (scm_getegid, "getegid", 0, 0, 0, (), "Return an integer representing the current effective group ID.\n" @@ -856,8 +856,9 @@ SCM_DEFINE (scm_getegid, "getegid", 0, 0, 0, #endif } #undef FUNC_NAME +#endif /* HAVE_GETGID */ - +#ifdef HAVE_SETUID SCM_DEFINE (scm_setuid, "setuid", 1, 0, 0, (SCM id), "Sets both the real and effective user IDs to the integer @var{id}, provided\n" @@ -870,7 +871,9 @@ SCM_DEFINE (scm_setuid, "setuid", 1, 0, 0, return SCM_UNSPECIFIED; } #undef FUNC_NAME +#endif /* HAVE_SETUID */ +#ifdef HAVE_SETGID SCM_DEFINE (scm_setgid, "setgid", 1, 0, 0, (SCM id), "Sets both the real and effective group IDs to the integer @var{id}, provided\n" @@ -883,7 +886,9 @@ SCM_DEFINE (scm_setgid, "setgid", 1, 0, 0, return SCM_UNSPECIFIED; } #undef FUNC_NAME +#endif /* HAVE_SETGID */ +#ifdef HAVE_SETUID SCM_DEFINE (scm_seteuid, "seteuid", 1, 0, 0, (SCM id), "Sets the effective user ID to the integer @var{id}, provided the process\n" @@ -905,10 +910,9 @@ SCM_DEFINE (scm_seteuid, "seteuid", 1, 0, 0, return SCM_UNSPECIFIED; } #undef FUNC_NAME -#endif /* __MINGW32__ */ +#endif /* HAVE_SETUID */ - -#ifdef HAVE_SETEGID +#ifdef HAVE_SETGID SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0, (SCM id), "Sets the effective group ID to the integer @var{id}, provided the process\n" @@ -931,8 +935,7 @@ SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0, } #undef FUNC_NAME -#endif - +#endif /* HAVE_SETGID */ #ifdef HAVE_GETPGRP SCM_DEFINE (scm_getpgrp, "getpgrp", 0, 0, 0, @@ -948,7 +951,6 @@ SCM_DEFINE (scm_getpgrp, "getpgrp", 0, 0, 0, #undef FUNC_NAME #endif /* HAVE_GETPGRP */ - #ifdef HAVE_SETPGID SCM_DEFINE (scm_setpgid, "setpgid", 2, 0, 0, (SCM pid, SCM pgid), From a1cb59c47e04a7c135d4a75401c351da8df4eb8f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 11 Jul 2016 22:17:09 +0200 Subject: [PATCH 453/865] Provide `kill' only if supported by the host * libguile/posix.c (scm_kill): Only provide if the host has `kill'. An incompatible change on MinGW, where this function would work only if the PID was the current PID, but that will be fixed by the next process. --- libguile/posix.c | 21 ++------------------- 1 file changed, 2 insertions(+), 19 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index dfb5bf9c9..452b9e37d 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -626,6 +626,7 @@ SCM_DEFINE (scm_setrlimit, "setrlimit", 3, 0, 0, #endif /* HAVE_GETRLIMIT */ +#ifdef HAVE_KILL SCM_DEFINE (scm_kill, "kill", 2, 0, 0, (SCM pid, SCM sig), "Sends a signal to the specified process or group of processes.\n\n" @@ -653,30 +654,12 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0, #define FUNC_NAME s_scm_kill { /* Signal values are interned in scm_init_posix(). */ -#ifdef HAVE_KILL if (kill (scm_to_int (pid), scm_to_int (sig)) != 0) SCM_SYSERROR; -#else - /* Mingw has raise(), but not kill(). (Other raw DOS environments might - be similar.) Use raise() when the requested pid is our own process, - otherwise bomb. */ - if (scm_to_int (pid) == getpid ()) - { - if (raise (scm_to_int (sig)) != 0) - { - err: - SCM_SYSERROR; - } - else - { - errno = ENOSYS; - goto err; - } - } -#endif return SCM_UNSPECIFIED; } #undef FUNC_NAME +#endif #ifdef HAVE_WAITPID SCM_DEFINE (scm_waitpid, "waitpid", 1, 1, 0, From 9222e05ef15e62c0f4c99506646447200e47e8c6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 11 Jul 2016 22:17:59 +0200 Subject: [PATCH 454/865] getaffinity, setaffinity docstring cleanup * libguile/posix.c (scm_getaffinity, scm_setaffinity): Clean up docstrings. Obviously if you have the function, you don't need to be told that you have it in the docstring. --- libguile/posix.c | 14 ++------------ 1 file changed, 2 insertions(+), 12 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index 452b9e37d..66b2bedc7 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1958,7 +1958,6 @@ SCM_DEFINE (scm_setpriority, "setpriority", 3, 0, 0, #endif /* HAVE_SETPRIORITY */ #ifdef HAVE_SCHED_GETAFFINITY - static SCM cpu_set_to_bitvector (const cpu_set_t *cs) { @@ -1983,10 +1982,7 @@ SCM_DEFINE (scm_getaffinity, "getaffinity", 1, 0, 0, "process @var{pid}. Each CPU the process has affinity with\n" "has its corresponding bit set in the returned bitvector.\n" "The number of bits set is a good estimate of how many CPUs\n" - "Guile can use without stepping on other processes' toes.\n\n" - "Currently this procedure is only defined on GNU variants\n" - "(@pxref{CPU Affinity, @code{sched_getaffinity},, libc, The\n" - "GNU C Library Reference Manual}).\n") + "Guile can use without stepping on other processes' toes.") #define FUNC_NAME s_scm_getaffinity { int err; @@ -2000,19 +1996,14 @@ SCM_DEFINE (scm_getaffinity, "getaffinity", 1, 0, 0, return cpu_set_to_bitvector (&cs); } #undef FUNC_NAME - #endif /* HAVE_SCHED_GETAFFINITY */ #ifdef HAVE_SCHED_SETAFFINITY - SCM_DEFINE (scm_setaffinity, "setaffinity", 2, 0, 0, (SCM pid, SCM mask), "Install the CPU affinity mask @var{mask}, a bitvector, for\n" "the process or thread with ID @var{pid}. The return value\n" - "is unspecified.\n\n" - "Currently this procedure is only defined on GNU variants\n" - "(@pxref{CPU Affinity, @code{sched_setaffinity},, libc, The\n" - "GNU C Library Reference Manual}).\n") + "is unspecified.") #define FUNC_NAME s_scm_setaffinity { cpu_set_t cs; @@ -2041,7 +2032,6 @@ SCM_DEFINE (scm_setaffinity, "setaffinity", 2, 0, 0, return SCM_UNSPECIFIED; } #undef FUNC_NAME - #endif /* HAVE_SCHED_SETAFFINITY */ From f632d45c69d00156a63c162371e8a5ef36e1cabf Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 11 Jul 2016 22:52:35 +0200 Subject: [PATCH 455/865] More specific status:exit-val et al compilation guards * libguile/posix.c (scm_status_exit_val, scm_status_term_sig) (scm_status_stop_sig): Guard on WIFEXITED et al macros instead of on MinGW. --- libguile/posix.c | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index 66b2bedc7..8aa0f3e60 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -718,7 +718,7 @@ SCM_DEFINE (scm_waitpid, "waitpid", 1, 1, 0, #undef FUNC_NAME #endif /* HAVE_WAITPID */ -#ifndef __MINGW32__ +#ifdef WIFEXITED SCM_DEFINE (scm_status_exit_val, "status:exit-val", 1, 0, 0, (SCM status), "Return the exit status value, as would be set if a process\n" @@ -737,7 +737,9 @@ SCM_DEFINE (scm_status_exit_val, "status:exit-val", 1, 0, 0, return SCM_BOOL_F; } #undef FUNC_NAME +#endif /* WIFEXITED */ +#ifdef WIFSIGNALED SCM_DEFINE (scm_status_term_sig, "status:term-sig", 1, 0, 0, (SCM status), "Return the signal number which terminated the process, if any,\n" @@ -753,7 +755,9 @@ SCM_DEFINE (scm_status_term_sig, "status:term-sig", 1, 0, 0, return SCM_BOOL_F; } #undef FUNC_NAME +#endif /* WIFSIGNALED */ +#ifdef WIFSTOPPED SCM_DEFINE (scm_status_stop_sig, "status:stop-sig", 1, 0, 0, (SCM status), "Return the signal number which stopped the process, if any,\n" @@ -769,7 +773,7 @@ SCM_DEFINE (scm_status_stop_sig, "status:stop-sig", 1, 0, 0, return SCM_BOOL_F; } #undef FUNC_NAME -#endif /* __MINGW32__ */ +#endif /* WIFSTOPPED */ #ifdef HAVE_GETPPID SCM_DEFINE (scm_getppid, "getppid", 0, 0, 0, From 10ae9cc60197562c72f3a8311bb64d62778df250 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 11 Jul 2016 22:46:55 +0200 Subject: [PATCH 456/865] Factor start_child out of open_process * libguile/posix.c (start_child): Factor out from open_process. Based on initial work by Eli Zaretskii. --- libguile/posix.c | 190 ++++++++++++++++++++++++++--------------------- 1 file changed, 105 insertions(+), 85 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index 8aa0f3e60..8b3fabc03 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1236,10 +1236,96 @@ SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0, return scm_from_int (pid); } #undef FUNC_NAME +#endif /* HAVE_FORK */ +#ifdef HAVE_FORK +#define HAVE_START_CHILD 1 /* Since Guile uses threads, we have to be very careful to avoid calling functions that are not async-signal-safe in the child. That's why this function is implemented in C. */ +static pid_t +start_child (const char *exec_file, char **exec_argv, + int reading, int c2p[2], int writing, int p2c[2], + int in, int out, int err) +{ + int pid; + int max_fd = 1024; + +#if defined (HAVE_GETRLIMIT) && defined (RLIMIT_NOFILE) + { + struct rlimit lim = { 0, 0 }; + if (getrlimit (RLIMIT_NOFILE, &lim) == 0) + max_fd = lim.rlim_cur; + } +#endif + + pid = fork (); + + if (pid != 0) + /* The parent, with either and error (pid == -1), or the PID of the + child. Return directly in either case. */ + return pid; + + /* The child. */ + if (reading) + close (c2p[0]); + if (writing) + close (p2c[1]); + + /* Close all file descriptors in ports inherited from the parent + except for in, out, and err. Heavy-handed, but robust. */ + while (max_fd--) + if (max_fd != in && max_fd != out && max_fd != err) + close (max_fd); + + /* Ignore errors on these open() calls. */ + if (in == -1) + in = open ("/dev/null", O_RDONLY); + if (out == -1) + out = open ("/dev/null", O_WRONLY); + if (err == -1) + err = open ("/dev/null", O_WRONLY); + + if (in > 0) + { + if (out == 0) + do out = dup (out); while (errno == EINTR); + if (err == 0) + do err = dup (err); while (errno == EINTR); + do dup2 (in, 0); while (errno == EINTR); + close (in); + } + if (out > 1) + { + if (err == 1) + do err = dup (err); while (errno == EINTR); + do dup2 (out, 1); while (errno == EINTR); + close (out); + } + if (err > 2) + { + do dup2 (err, 2); while (errno == EINTR); + close (err); + } + + execvp (exec_file, exec_argv); + + /* The exec failed! There is nothing sensible to do. */ + if (err > 0) + { + char *msg = strerror (errno); + fprintf (fdopen (err, "a"), "In execvp of %s: %s\n", + exec_file, msg); + } + + _exit (EXIT_FAILURE); + + /* Not reached. */ + return -1; +} +#endif + +#ifdef HAVE_START_CHILD static SCM scm_open_process (SCM mode, SCM prog, SCM args) #define FUNC_NAME "open-process" @@ -1252,7 +1338,7 @@ scm_open_process (SCM mode, SCM prog, SCM args) int pid; char *exec_file; char **exec_argv; - int max_fd = 1024; + SCM read_port = SCM_BOOL_F, write_port = SCM_BOOL_F; exec_file = scm_to_locale_string (prog); exec_argv = scm_i_allocate_string_pointers (scm_cons (prog, args)); @@ -1301,15 +1387,8 @@ scm_open_process (SCM mode, SCM prog, SCM args) in = SCM_FPORT_FDES (port); } -#if defined (HAVE_GETRLIMIT) && defined (RLIMIT_NOFILE) - { - struct rlimit lim = { 0, 0 }; - if (getrlimit (RLIMIT_NOFILE, &lim) == 0) - max_fd = lim.rlim_cur; - } -#endif - - pid = fork (); + pid = start_child (exec_file, exec_argv, reading, c2p, writing, p2c, + in, out, err); if (pid == -1) { @@ -1329,85 +1408,24 @@ scm_open_process (SCM mode, SCM prog, SCM args) SCM_SYSERROR; } - if (pid) - /* Parent. */ - { - SCM read_port = SCM_BOOL_F, write_port = SCM_BOOL_F; - - /* There is no sense in catching errors on close(). */ - if (reading) - { - close (c2p[1]); - read_port = scm_fdes_to_port (c2p[0], "r0", sym_read_pipe); - } - if (writing) - { - close (p2c[0]); - write_port = scm_fdes_to_port (p2c[1], "w0", sym_write_pipe); - } - - return scm_values - (scm_list_3 (read_port, write_port, scm_from_int (pid))); - } - - /* The child. */ + /* There is no sense in catching errors on close(). */ if (reading) - close (c2p[0]); + { + close (c2p[1]); + read_port = scm_fdes_to_port (c2p[0], "r0", sym_read_pipe); + } if (writing) - close (p2c[1]); - - /* Close all file descriptors in ports inherited from the parent - except for in, out, and err. Heavy-handed, but robust. */ - while (max_fd--) - if (max_fd != in && max_fd != out && max_fd != err) - close (max_fd); - - /* Ignore errors on these open() calls. */ - if (in == -1) - in = open ("/dev/null", O_RDONLY); - if (out == -1) - out = open ("/dev/null", O_WRONLY); - if (err == -1) - err = open ("/dev/null", O_WRONLY); - - if (in > 0) { - if (out == 0) - do out = dup (out); while (errno == EINTR); - if (err == 0) - do err = dup (err); while (errno == EINTR); - do dup2 (in, 0); while (errno == EINTR); - close (in); - } - if (out > 1) - { - if (err == 1) - do err = dup (err); while (errno == EINTR); - do dup2 (out, 1); while (errno == EINTR); - close (out); - } - if (err > 2) - { - do dup2 (err, 2); while (errno == EINTR); - close (err); + close (p2c[0]); + write_port = scm_fdes_to_port (p2c[1], "w0", sym_write_pipe); } - execvp (exec_file, exec_argv); - - /* The exec failed! There is nothing sensible to do. */ - if (err > 0) - { - char *msg = strerror (errno); - fprintf (fdopen (err, "a"), "In execlp of %s: %s\n", - exec_file, msg); - } - - _exit (EXIT_FAILURE); - /* Not reached. */ - return SCM_BOOL_F; + return scm_values (scm_list_3 (read_port, + write_port, + scm_from_int (pid))); } #undef FUNC_NAME -#endif /* HAVE_FORK */ +#endif /* HAVE_START_CHILD */ #ifdef __MINGW32__ # include "win32-uname.h" @@ -2215,13 +2233,13 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0, #endif /* HAVE_GETHOSTNAME */ -#ifdef HAVE_FORK +#ifdef HAVE_START_CHILD static void scm_init_popen (void) { scm_c_define_gsubr ("open-process", 2, 0, 1, scm_open_process); } -#endif +#endif /* HAVE_START_CHILD */ void scm_init_posix () @@ -2320,11 +2338,13 @@ scm_init_posix () #ifdef HAVE_FORK scm_add_feature ("fork"); +#endif /* HAVE_FORK */ +#ifdef HAVE_START_CHILD scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, "scm_init_popen", (scm_t_extension_init_func) scm_init_popen, NULL); -#endif /* HAVE_FORK */ +#endif /* HAVE_START_CHILD */ } /* From d32f37e56ca4b0753e75f465f3e60dac5e9a3416 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 25 Jul 2016 11:35:58 +0200 Subject: [PATCH 457/865] Ignore meta/build-env * .gitignore: Ignore meta/build-env. --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 7f9d630f8..2c1f9d840 100644 --- a/.gitignore +++ b/.gitignore @@ -164,3 +164,4 @@ INSTALL /libguile/vm-operations.h /test-suite/standalone/test-foreign-object-c /test-suite/standalone/test-srfi-4 +/meta/build-env From b2d77c38c45794541e46c235517369a4c8b75d3b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 11 Jul 2016 23:15:03 +0200 Subject: [PATCH 458/865] Rename win32-uname.[ch] to posix-w32.[ch] * libguile/posix-w32.c: * libguile/posix-w32.h: Rename from win32-uname.c and win32-uname.h. * libguile/posix.c: * libguile/Makefile.am (EXTRA_libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES) (noinst_HEADERS): Adapt. --- libguile/Makefile.am | 6 +++--- libguile/{win32-uname.c => posix-w32.c} | 2 +- libguile/{win32-uname.h => posix-w32.h} | 6 +++--- libguile/posix.c | 8 ++++---- 4 files changed, 11 insertions(+), 11 deletions(-) rename libguile/{win32-uname.c => posix-w32.c} (99%) rename libguile/{win32-uname.h => posix-w32.h} (95%) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 855a57faa..dab09e1a3 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -1,7 +1,7 @@ ## Process this file with Automake to create Makefile.in ## ## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, -## 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +## 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2016 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -456,7 +456,7 @@ EXTRA_libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = _scm.h \ dynl.c regex-posix.c \ posix.c net_db.c socket.c \ debug-malloc.c \ - win32-uname.c \ + posix-w32.c \ locale-categories.h ## delete guile-snarf.awk from the installation bindir, in case it's @@ -504,7 +504,7 @@ noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \ elf.h \ srfi-14.i.c \ quicksort.i.c \ - win32-uname.h \ + posix-w32.h \ private-options.h ports-internal.h # vm instructions diff --git a/libguile/win32-uname.c b/libguile/posix-w32.c similarity index 99% rename from libguile/win32-uname.c rename to libguile/posix-w32.c index 5349f1410..f1251b22d 100644 --- a/libguile/win32-uname.c +++ b/libguile/posix-w32.c @@ -26,7 +26,7 @@ #include #include -#include "win32-uname.h" +#include "posix-w32.h" /* * Get name and information about current kernel. diff --git a/libguile/win32-uname.h b/libguile/posix-w32.h similarity index 95% rename from libguile/win32-uname.h rename to libguile/posix-w32.h index 4b7498133..b4c6510eb 100644 --- a/libguile/win32-uname.h +++ b/libguile/posix-w32.h @@ -1,7 +1,7 @@ /* classes: h_files */ -#ifndef SCM_WIN32_UNAME_H -#define SCM_WIN32_UNAME_H +#ifndef SCM_POSIX_W32_H +#define SCM_POSIX_W32_H /* Copyright (C) 2001, 2006 Free Software Foundation, Inc. * @@ -49,4 +49,4 @@ struct utsname int uname (struct utsname * uts); -#endif /* SCM_WIN32_UNAME_H */ +#endif /* SCM_POSIX_W32_H */ diff --git a/libguile/posix.c b/libguile/posix.c index 8b3fabc03..72f105f4b 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -81,6 +81,10 @@ #include "libguile/threads.h" +#ifdef __MINGW32__ +# include "posix-w32.h" +#endif + #if HAVE_SYS_WAIT_H # include #endif @@ -1427,10 +1431,6 @@ scm_open_process (SCM mode, SCM prog, SCM args) #undef FUNC_NAME #endif /* HAVE_START_CHILD */ -#ifdef __MINGW32__ -# include "win32-uname.h" -#endif - #if defined (HAVE_UNAME) || defined (__MINGW32__) SCM_DEFINE (scm_uname, "uname", 0, 0, 0, (), From 3231d7658d4086b26df53f064d374945ced46274 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Mon, 11 Jul 2016 22:52:17 +0200 Subject: [PATCH 459/865] Add POSIX shims for MinGW * libguile/posix-w32.h: * libguile/posix-w32.c (kill, waitpid, getpriority, setpriority) (sched_getaffinity, sched_setaffinity): Add MinGW implementations. Also, provides macros that on Posix hosts are in sys/wait.h, like WIFEXITED and WTERMSIG. (start_child): Add implementation. --- libguile/posix-w32.c | 864 ++++++++++++++++++++++++++++++++++++++++++- libguile/posix-w32.h | 48 ++- libguile/posix.c | 2 +- 3 files changed, 911 insertions(+), 3 deletions(-) diff --git a/libguile/posix-w32.c b/libguile/posix-w32.c index f1251b22d..f7df180f5 100644 --- a/libguile/posix-w32.c +++ b/libguile/posix-w32.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2006, 2008, 2016 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 License @@ -22,8 +22,12 @@ #include "libguile/__scm.h" +# define WIN32_LEAN_AND_MEAN #include +#include +#include #include +#include #include #include "posix-w32.h" @@ -144,3 +148,861 @@ uname (struct utsname *uts) GetComputerName (uts->nodename, &sLength); return 0; } + +/* Run a child process with redirected standard handles, without + redirecting standard handles of the parent. This is required in + multithreaded programs, where redirecting a standard handle affects + all threads. */ + +/* Prepare a possibly redirected file handle to be passed to a child + process. The handle is for the file/device open on file descriptor + FD; if FD is invalid, use the null device instead. + + USE_STD non-zero means we have been passed the descriptor used by + the parent. + + ACCESS is the Windows access mode for opening the null device. + + Returns the Win32 handle to be passed to CreateProcess. */ +static HANDLE +prepare_child_handle (int fd, int use_std, DWORD access) +{ + HANDLE htem, hret; + DWORD err = 0; + + /* Start with the descriptor, if specified by the caller and valid, + otherwise open the null device. */ + if (fd < 0) + htem = INVALID_HANDLE_VALUE; + else + htem = (HANDLE)_get_osfhandle (fd); + + /* Duplicate the handle and make it inheritable. */ + if (DuplicateHandle (GetCurrentProcess (), + htem, + GetCurrentProcess (), + &hret, + 0, + TRUE, + DUPLICATE_SAME_ACCESS) == FALSE) + { + /* If the original standard handle was invalid (happens, e.g., + in GUI programs), open the null device instead. */ + if ((err = GetLastError ()) == ERROR_INVALID_HANDLE + && use_std) + { + htem = CreateFile ("NUL", access, + FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, + OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); + if (htem != INVALID_HANDLE_VALUE + && DuplicateHandle (GetCurrentProcess (), + htem, + GetCurrentProcess (), + &hret, + 0, + TRUE, + DUPLICATE_SAME_ACCESS) == FALSE) + { + err = GetLastError (); + CloseHandle (htem); + hret = INVALID_HANDLE_VALUE; + } + } + } + + if (hret == INVALID_HANDLE_VALUE) + { + switch (err) + { + case ERROR_NO_MORE_FILES: + errno = EMFILE; + break; + case ERROR_INVALID_HANDLE: + default: + errno = EBADF; + break; + } + } + + return hret; +} + +/* A comparison function for sorting the environment. */ +static int +compenv (const void *a1, const void *a2) +{ + return stricmp (*((char**)a1), *((char**)a2)); +} + +/* Convert the program's 'environ' array to a block of environment + variables suitable to be passed to CreateProcess. This is needed + to ensure the child process inherits the up-to-date environment of + the parent, including any variables inserted by the parent. */ +static void +prepare_envblk (char **envp, char **envblk) +{ + char **tmp; + int size_needed; + int envcnt; + char *ptr; + + for (envcnt = 0; envp[envcnt]; envcnt++) + ; + + tmp = scm_calloc ((envcnt + 1) * sizeof (*tmp)); + + for (envcnt = size_needed = 0; envp[envcnt]; envcnt++) + { + tmp[envcnt] = envp[envcnt]; + size_needed += strlen (envp[envcnt]) + 1; + } + size_needed++; + + /* Windows likes its environment variables sorted. */ + qsort ((void *) tmp, (size_t) envcnt, sizeof (char *), compenv); + + /* CreateProcess needs the environment block as a linear array, + where each variable is terminated by a null character, and the + last one is terminated by 2 null characters. */ + ptr = *envblk = scm_calloc (size_needed); + + for (envcnt = 0; tmp[envcnt]; envcnt++) + { + strcpy (ptr, tmp[envcnt]); + ptr += strlen (tmp[envcnt]) + 1; + } + + free (tmp); +} + +/* Find an executable PROGRAM on PATH, return result in malloc'ed + storage. If PROGRAM is /bin/sh, and no sh.exe was found on PATH, + fall back on the Windows shell and set BIN_SH_REPLACED to non-zero. */ +static char * +lookup_cmd (const char *program, int *bin_sh_replaced) +{ + static const char *extensions[] = { + ".exe", ".cmd", ".bat", "", ".com", NULL + }; + int bin_sh_requested = 0; + char *path, *dir, *sep; + char abs_name[MAX_PATH]; + DWORD abs_namelen = 0; + + /* If they ask for the Unix system shell, try to find it on PATH. */ + if (c_strcasecmp (program, "/bin/sh") == 0) + { + bin_sh_requested = 1; + program = "sh.exe"; + } + + /* If PROGRAM includes leading directories, the caller already did + our job. */ + if (strchr (program, '/') != NULL + || strchr (program, '\\') != NULL) + return scm_strdup (program); + + /* Note: It is OK for getenv below to return NULL -- in that case, + SearchPath will search in the directories whose list is specified + by the system Registry. */ + path = getenv ("PATH"); + if (!path) /* shouldn't happen, really */ + path = "."; + dir = sep = path = strdup (path); + for ( ; sep && *sep; dir = sep + 1) + { + int i; + + sep = strpbrk (dir, ";"); + if (sep == dir) /* two or more ;'s in a row */ + continue; + if (sep) + *sep = '\0'; + for (i = 0; extensions[i]; i++) + { + abs_namelen = SearchPath (dir, program, extensions[i], + MAX_PATH, abs_name, NULL); + if (0 < abs_namelen && abs_namelen <= MAX_PATH) /* found! */ + break; + } + if (extensions[i]) /* found! */ + break; + if (sep) + *sep = ';'; + } + + free (path); + + /* If they asked for /bin/sh and we didn't find it, fall back on the + default Windows shell. */ + if (abs_namelen <= 0 && bin_sh_requested) + { + const char *shell = getenv ("ComSpec"); + + if (!shell) + shell = "C:\\Windows\\system32\\cmd.exe"; + + *bin_sh_replaced = 1; + strcpy (abs_name, shell); + abs_namelen = strlen (abs_name); + } + + /* If not found, return the original PROGRAM name. */ + if (abs_namelen <= 0 || abs_namelen > MAX_PATH) + return scm_strdup (program); + + return scm_strndup (abs_name, abs_namelen); +} + +/* Concatenate command-line arguments in argv[] into a single + command-line string, while quoting arguments as needed. The result + is malloc'ed. */ +static char * +prepare_cmdline (const char *cmd, const char * const *argv, int bin_sh_replaced) +{ + /* These characters should include anything that is special to _any_ + program, including both Windows and Unixy shells, and the + widlcard expansion in startup code of a typical Windows app. */ + const char need_quotes[] = " \t#;\"\'*?[]&|<>(){}$`^"; + size_t cmdlen = 1; /* for terminating null */ + char *cmdline = scm_malloc (cmdlen); + char *dst = cmdline; + int cmd_exe_quoting = 0; + int i; + const char *p; + + /* Are we constructing a command line for cmd.exe? */ + if (bin_sh_replaced) + cmd_exe_quoting = 1; + else + { + for (p = cmd + strlen (cmd); + p > cmd && p[-1] != '/' && p[-1] != '\\' && p[-1] != ':'; + p--) + ; + if (c_strcasecmp (p, "cmd.exe") == 0 + || c_strcasecmp (p, "cmd") == 0) + cmd_exe_quoting = 1; + } + + /* Initialize the command line to empty. */ + *dst = '\0'; + + /* Append arguments, if any, from argv[]. */ + for (i = 0; argv[i]; i++) + { + const char *src = argv[i]; + size_t len; + int quote_this = 0, n_backslashes = 0; + int j; + + /* Append the blank separator. We don't do that for argv[0] + because that is the command name (will end up in child's + argv[0]), and is only recognized as such if there're no + blanks before it. */ + if (i > 0) + *dst++ = ' '; + len = dst - cmdline; + + /* How much space is required for this argument? */ + cmdlen += strlen (argv[i]) + 1; /* 1 for a blank separator */ + /* cmd.exe needs a different style of quoting: all the arguments + beyond the /c switch are enclosed in an extra pair of quotes, + and not otherwise quoted/escaped. */ + if (cmd_exe_quoting) + { + if (i == 2) + cmdlen += 2; + } + else if (strpbrk (argv[i], need_quotes)) + { + quote_this = 1; + cmdlen += 2; + for ( ; *src; src++) + { + /* An embedded quote needs to be escaped by a backslash. + Any backslashes immediately preceding that quote need + each one to be escaped by another backslash. */ + if (*src == '\"') + cmdlen += n_backslashes + 1; + if (*src == '\\') + n_backslashes++; + else + n_backslashes = 0; + } + /* If the closing quote we will add is preceded by + backslashes, those backslashes need to be escaped. */ + cmdlen += n_backslashes; + } + + /* Enlarge the command-line string as needed. */ + cmdline = scm_realloc (cmdline, cmdlen); + dst = cmdline + len; + + if (i == 0 + && c_strcasecmp (argv[0], "/bin/sh") == 0 + && bin_sh_replaced) + { + strcpy (dst, "cmd.exe"); + dst += sizeof ("cmd.exe") - 1; + continue; + } + if (i == 1 && bin_sh_replaced && strcmp (argv[1], "-c") == 0) + { + *dst++ = '/'; + *dst++ = 'c'; + *dst = '\0'; + continue; + } + + /* Add this argument, possibly quoted, to the command line. */ + if (quote_this || (i == 2 && cmd_exe_quoting)) + *dst++ = '\"'; + for (src = argv[i]; *src; src++) + { + if (quote_this) + { + if (*src == '\"') + for (j = n_backslashes + 1; j > 0; j--) + *dst++ = '\\'; + if (*src == '\\') + n_backslashes++; + else + n_backslashes = 0; + } + *dst++ = *src; + } + if (quote_this) + { + for (j = n_backslashes; j > 0; j--) + *dst++ = '\\'; + *dst++ = '\"'; + } + *dst = '\0'; + } + + if (cmd_exe_quoting && i > 2) + { + /* One extra slot was already reserved when we enlarged cmdlen + by 2 in the "if (cmd_exe_quoting)" clause above. So we can + safely append a closing quote. */ + *dst++ = '\"'; + *dst = '\0'; + } + + return cmdline; +} + +/* Start a child process running the program in EXEC_FILE with its + standard input and output optionally redirected to a pipe. ARGV is + the array of command-line arguments to pass to the child. P2C and + C2P are 2 pipes for communicating with the child, and ERRFD is the + standard error file descriptor to be inherited by the child. + READING and WRITING, if non-zero, mean that the corresponding pipe + will be used. + + Return the PID of the child process, or -1 if couldn't start a + process. */ +int +start_child (const char *exec_file, char **argv, + int reading, int c2p[2], int writing, int p2c[2], + int infd, int outfd, int errfd) +{ + HANDLE hin = INVALID_HANDLE_VALUE, hout = INVALID_HANDLE_VALUE; + HANDLE herr = INVALID_HANDLE_VALUE; + STARTUPINFO si; + char *env_block = NULL; + char *cmdline = NULL; + PROCESS_INFORMATION pi; + char *progfile, *p; + int errno_save; + intptr_t pid; + int bin_sh_replaced = 0; + + if (!reading) + c2p[1] = outfd; + if (!writing) + p2c[0] = infd; + + /* Prepare standard handles to be passed to the child process. */ + hin = prepare_child_handle (p2c[0], !writing, GENERIC_READ); + if (hin == INVALID_HANDLE_VALUE) + return -1; + hout = prepare_child_handle (c2p[1], !reading, GENERIC_WRITE); + if (hout == INVALID_HANDLE_VALUE) + return -1; + herr = prepare_child_handle (errfd, 1, GENERIC_WRITE); + if (herr == INVALID_HANDLE_VALUE) + return -1; + + /* Make sure the parent side of both pipes is not inherited. This + is required because gnulib's 'pipe' creates pipes whose both ends + are inheritable, which is traditional on Posix (where pipe + descriptors are implicitly duplicated by 'fork'), but wrong on + Windows (where pipe handles need to be explicitly + duplicated). */ + if (writing) + SetHandleInformation ((HANDLE)_get_osfhandle (p2c[1]), + HANDLE_FLAG_INHERIT, 0); + if (reading) + { + SetHandleInformation ((HANDLE)_get_osfhandle (c2p[0]), + HANDLE_FLAG_INHERIT, 0); + /* Gnulib's 'pipe' opens the pipe in binary mode, but we don't + want to read text-mode input of subprocesses in binary more, + because then we will get the ^M (a.k.a. "CR") characters we + don't expect. */ + _setmode (c2p[0], _O_TEXT); + } + + /* Set up the startup info for the child, using the parent's as the + starting point, and specify in it the redirected handles. */ + GetStartupInfo (&si); + si.dwFlags = STARTF_USESTDHANDLES; + si.lpReserved = 0; + si.cbReserved2 = 0; + si.lpReserved2 = 0; + si.hStdInput = hin; + si.hStdOutput = hout; + si.hStdError = herr; + + /* Create the environment block for the child. This is needed + because the environment we have in 'environ' is not in the format + expected by CreateProcess. */ + prepare_envblk (environ, &env_block); + + /* CreateProcess doesn't search PATH, so we must do that for it. */ + progfile = lookup_cmd (exec_file, &bin_sh_replaced); + + /* CreateProcess doesn't like forward slashes in the application + file name. */ + for (p = progfile; *p; p++) + if (*p == '/') + *p = '\\'; + + /* Construct the command line. */ + cmdline = prepare_cmdline (exec_file, (const char * const *)argv, + bin_sh_replaced); + + /* All set and ready to fly. Launch the child process. */ + if (!CreateProcess (progfile, cmdline, NULL, NULL, TRUE, 0, env_block, NULL, + &si, &pi)) + { + pid = -1; + + /* Since we use Win32 APIs directly, we need to translate their + errors to errno values by hand. */ + switch (GetLastError ()) + { + case ERROR_FILE_NOT_FOUND: + case ERROR_PATH_NOT_FOUND: + case ERROR_INVALID_DRIVE: + case ERROR_BAD_PATHNAME: + errno = ENOENT; + break; + case ERROR_ACCESS_DENIED: + errno = EACCES; + break; + case ERROR_BAD_ENVIRONMENT: + errno = E2BIG; + break; + case ERROR_BROKEN_PIPE: + errno = EPIPE; + break; + case ERROR_INVALID_HANDLE: + errno = EBADF; + break; + case ERROR_MAX_THRDS_REACHED: + errno = EAGAIN; + break; + case ERROR_BAD_EXE_FORMAT: + case ERROR_BAD_FORMAT: + default: + errno = ENOEXEC; + break; + } + } + else + pid = (intptr_t)pi.hProcess; + + errno_save = errno; + + /* Free resources. */ + free (progfile); + free (cmdline); + free (env_block); + CloseHandle (hin); + CloseHandle (hout); + CloseHandle (herr); + CloseHandle (pi.hThread); + + /* Posix requires to call the shell if execvp fails to invoke EXEC_FILE. */ + if (errno_save == ENOEXEC || errno_save == ENOENT) + { + const char *shell = getenv ("ComSpec"); + + if (!shell) + shell = "cmd.exe"; + + if (c_strcasecmp (exec_file, shell) != 0) + { + argv[0] = (char *)exec_file; + return start_child (shell, argv, reading, c2p, writing, p2c, errfd); + } + } + + errno = errno_save; + return pid; +} + + +/* Emulation of waitpid which only supports WNOHANG, since _cwait doesn't. */ +int +waitpid (intptr_t pid, int *status, int options) +{ + if ((options & WNOHANG) != 0) + { + DWORD st; + + if (!GetExitCodeProcess ((HANDLE)pid, &st)) + { + errno = ECHILD; + return -1; + } + if (st == STILL_ACTIVE) + return 0; + if (status) + *status = st; + return (int)pid; + } + + return (int)_cwait (status, pid, WAIT_CHILD); +} + + +/* Translate abnormal exit status of Windows programs into the signal + that terminated the program. This is required to support scm_kill + and WTERMSIG. */ + +struct signal_and_status { + int sig; + DWORD status; +}; + +static const struct signal_and_status sigtbl[] = { + {SIGSEGV, 0xC0000005}, /* access to invalid address */ + {SIGSEGV, 0xC0000008}, /* invalid handle */ + {SIGILL, 0xC000001D}, /* illegal instruction */ + {SIGILL, 0xC0000025}, /* non-continuable instruction */ + {SIGSEGV, 0xC000008C}, /* array bounds exceeded */ + {SIGFPE, 0xC000008D}, /* float denormal */ + {SIGFPE, 0xC000008E}, /* float divide by zero */ + {SIGFPE, 0xC000008F}, /* float inexact */ + {SIGFPE, 0xC0000090}, /* float invalid operation */ + {SIGFPE, 0xC0000091}, /* float overflow */ + {SIGFPE, 0xC0000092}, /* float stack check */ + {SIGFPE, 0xC0000093}, /* float underflow */ + {SIGFPE, 0xC0000094}, /* integer divide by zero */ + {SIGFPE, 0xC0000095}, /* integer overflow */ + {SIGILL, 0xC0000096}, /* privileged instruction */ + {SIGSEGV, 0xC00000FD}, /* stack overflow */ + {SIGTERM, 0xC000013A}, /* Ctrl-C exit */ + {SIGINT, 0xC000013A} +}; + +static int +w32_signal_to_status (int sig) +{ + int i; + + for (i = 0; i < sizeof (sigtbl) / sizeof (sigtbl[0]); i++) + if (sig == sigtbl[i].sig) + return sigtbl[i].status; + + return (int)0xC000013A; +} + +int +w32_status_to_termsig (DWORD status) +{ + int i; + + for (i = 0; i < sizeof (sigtbl) / sizeof (sigtbl[0]); i++) + if (status == sigtbl[i].status) + return sigtbl[i].sig; + + return SIGTERM; +} + +/* Support for scm_kill. */ +int +kill (int pid, int sig) +{ + HANDLE ph = OpenProcess (PROCESS_TERMINATE, 0, pid); + + if (!ph) + { + errno = EPERM; + return -1; + } + if (!TerminateProcess (ph, w32_signal_to_status (sig))) + { + errno = EINVAL; + return -1; + } + CloseHandle (ph); + + return 0; +} + +/* Emulation of getpriority and setpriority. */ +#define NZERO 8 + +int +getpriority (int which, int who) +{ + HANDLE hp; + int nice_value = -1; + int error = 0; + + /* We don't support process groups and users. */ + if (which != PRIO_PROCESS) + { + errno = ENOSYS; + return -1; + } + + if (who == 0) + hp = GetCurrentProcess (); + else + hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, who); + + if (hp) + { + DWORD pri_class = GetPriorityClass (hp); + + if (pri_class > 0) + { + switch (pri_class) + { + case IDLE_PRIORITY_CLASS: + nice_value = 4; + break; + case BELOW_NORMAL_PRIORITY_CLASS: + nice_value = 6; + break; + case NORMAL_PRIORITY_CLASS: + nice_value = 8; + break; + case ABOVE_NORMAL_PRIORITY_CLASS: + nice_value = 10; + break; + case HIGH_PRIORITY_CLASS: + nice_value = 13; + break; + case REALTIME_PRIORITY_CLASS: + nice_value = 24; + break; + } + /* If WHO is us, we can provide a more fine-grained value by + looking at the current thread's priority value. (For + other processes, it is not clear which thread to use.) */ + if (who == 0 || who == GetCurrentProcessId ()) + { + HANDLE ht = GetCurrentThread (); + int tprio = GetThreadPriority (ht); + + switch (tprio) + { + case THREAD_PRIORITY_IDLE: + if (pri_class == REALTIME_PRIORITY_CLASS) + nice_value = 16; + else + nice_value = 1; + break; + case THREAD_PRIORITY_TIME_CRITICAL: + if (pri_class == REALTIME_PRIORITY_CLASS) + nice_value = 31; + else + nice_value = 15; + case THREAD_PRIORITY_ERROR_RETURN: + nice_value = -1; + error = 1; + break; + default: + nice_value += tprio; + break; + } + } + /* Map to "nice values" similar to what one would see on + Posix platforms. */ + if (!error) + nice_value = - (nice_value - NZERO); + } + else + error = 1; + } + else + error = 1; + + if (error) + { + DWORD err = GetLastError (); + + switch (err) + { + case ERROR_INVALID_PARAMETER: + case ERROR_INVALID_THREAD_ID: + errno = ESRCH; + break; + default: + errno = EPERM; + break; + } + } + + return nice_value; +} + +int +setpriority (int which, int who, int nice_val) +{ + HANDLE hp; + DWORD err; + + if (which != PRIO_PROCESS) + { + errno = ENOSYS; + return -1; + } + + if (who == 0) + hp = GetCurrentProcess (); + else + hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, who); + + if (hp) + { + DWORD pri_class; + + /* Map "nice values" back to process priority classes. */ + nice_val = -nice_val + NZERO; + if (nice_val < 6) + pri_class = IDLE_PRIORITY_CLASS; + else if (nice_val < 8) + pri_class = BELOW_NORMAL_PRIORITY_CLASS; + else if (nice_val < 10) + pri_class = NORMAL_PRIORITY_CLASS; + else if (nice_val < 13) + pri_class = ABOVE_NORMAL_PRIORITY_CLASS; + else if (nice_val < 16) + pri_class = HIGH_PRIORITY_CLASS; + else + pri_class = REALTIME_PRIORITY_CLASS; + + if (SetPriorityClass (hp, pri_class)) + return 0; + } + + err = GetLastError (); + + switch (err) + { + case ERROR_INVALID_PARAMETER: + errno = ESRCH; + break; + default: + errno = EPERM; + break; + } + + return -1; +} + +/* Emulation of sched_getaffinity and sched_setaffinity. */ +int +sched_getaffinity (int pid, size_t mask_size, cpu_set_t *mask) +{ + HANDLE hp; + DWORD err; + + if (mask == NULL) + { + errno = EFAULT; + return -1; + } + + if (pid == 0) + hp = GetCurrentProcess (); + else + hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, pid); + + if (hp) + { + DWORD_PTR ignored; + BOOL result = GetProcessAffinityMask (hp, (DWORD_PTR *)mask, &ignored); + + if (pid != 0) + CloseHandle (hp); + if (result) + return 0; + } + + err = GetLastError (); + + switch (err) + { + case ERROR_INVALID_PARAMETER: + errno = ESRCH; + break; + case ERROR_ACCESS_DENIED: + default: + errno = EPERM; + break; + } + + return -1; +} + +int +sched_setaffinity (int pid, size_t mask_size, cpu_set_t *mask) +{ + HANDLE hp; + DWORD err; + + if (mask == NULL) + { + errno = EFAULT; + return -1; + } + + if (pid == 0) + hp = GetCurrentProcess (); + else + hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, pid); + + if (hp) + { + BOOL result = SetProcessAffinityMask (hp, *(DWORD_PTR *)mask); + + if (pid != 0) + CloseHandle (hp); + if (result) + return 0; + } + + err = GetLastError (); + + switch (err) + { + case ERROR_INVALID_PARAMETER: + errno = ESRCH; + break; + case ERROR_ACCESS_DENIED: + default: + errno = EPERM; + break; + } + + return -1; +} diff --git a/libguile/posix-w32.h b/libguile/posix-w32.h index b4c6510eb..f11a25e49 100644 --- a/libguile/posix-w32.h +++ b/libguile/posix-w32.h @@ -21,6 +21,8 @@ * 02110-1301 USA */ +#include + #define _UTSNAME_LENGTH 65 #define _UTSNAME_NODENAME_LENGTH _UTSNAME_LENGTH #define _UTSNAME_DOMAIN_LENGTH _UTSNAME_LENGTH @@ -47,6 +49,50 @@ struct utsname char domainname[_UTSNAME_DOMAIN_LENGTH]; }; -int uname (struct utsname * uts); +#define WNOHANG 1 + +#define WEXITSTATUS(stat_val) ((stat_val) & 255) +/* MS-Windows programs that crash due to a fatal exception exit with + an exit code whose 2 MSB bits are set. */ +#define WIFEXITED(stat_val) (((stat_val) & 0xC0000000) == 0) +#define WIFSIGNALED(stat_val) (((stat_val) & 0xC0000000) == 0xC0000000) +#define WTERMSIG(stat_val) w32_status_to_termsig (stat_val) +/* The funny conditional avoids a compiler warning in status:stop_sig. */ +#define WIFSTOPPED(stat_val) ((stat_val) == (stat_val) ? 0 : 0) +#define WSTOPSIG(stat_var) (0) + +#define CPU_ZERO(s) memset(s,0,sizeof(*s)) +#define CPU_ISSET(b,s) ((*s) & (1U << (b))) != 0 +#define CPU_SET(b,s) (*s) |= (1U << (b)) +#define CPU_SETSIZE (8*sizeof(DWORD_PTR)) +typedef DWORD_PTR cpu_set_t; + +#define PRIO_PROCESS 1 +#define PRIO_PGRP 2 +#define PRIO_USER 3 + +SCM_INTERNAL int uname (struct utsname * uts); +SCM_INTERNAL int waitpid (intptr_t, int *, int); +SCM_INTERNAL int w32_status_to_termsig (DWORD status); + +SCM_INTERNAL int start_child (const char *exec_file, char **argv, + int reading, int c2p[2], int writing, int p2c[2], + int infd, int outfd, int errfd); + +SCM_INTERNAL int kill (int pid, int sig); + +SCM_INTERNAL int getpriority (int which, int who); +SCM_INTERNAL int setpriority (int which, int who, int nice_val); +SCM_INTERNAL int sched_getaffinity (int pid, size_t mask_size, cpu_set_t *mask); +SCM_INTERNAL int sched_setaffinity (int pid, size_t mask_size, cpu_set_t *mask); + +#define HAVE_UNAME 1 +#define HAVE_WAITPID 1 +#define HAVE_START_CHILD 1 +#define HAVE_KILL 1 +#define HAVE_GETPRIORITY 1 +#define HAVE_SETPRIORITY 1 +#define HAVE_SCHED_GETAFFINITY 1 +#define HAVE_SCHED_SETAFFINITY 1 #endif /* SCM_POSIX_W32_H */ diff --git a/libguile/posix.c b/libguile/posix.c index 72f105f4b..15d2e816c 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1431,7 +1431,7 @@ scm_open_process (SCM mode, SCM prog, SCM args) #undef FUNC_NAME #endif /* HAVE_START_CHILD */ -#if defined (HAVE_UNAME) || defined (__MINGW32__) +#ifdef HAVE_UNAME SCM_DEFINE (scm_uname, "uname", 0, 0, 0, (), "Return an object with some information about the computer\n" From 513344e33d17a72b693f1dac774567ba3231886e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 14 Jul 2016 16:33:32 +0200 Subject: [PATCH 460/865] Add popen feature * doc/ref/api-options.texi (Common Feature Symbols): Document the popen feature. * doc/ref/posix.texi (Pipes): Depend on the popen feature, not fork. * libguile/posix.c (scm_init_posix): Add popen feature if we can. --- doc/ref/api-options.texi | 7 +++++-- doc/ref/posix.texi | 2 +- libguile/posix.c | 1 + 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/doc/ref/api-options.texi b/doc/ref/api-options.texi index 152bf4693..0259b4b21 100644 --- a/doc/ref/api-options.texi +++ b/doc/ref/api-options.texi @@ -284,8 +284,11 @@ Indicates support for POSIX functions: @code{pipe}, @code{getgroups}, @item fork Indicates support for the POSIX @code{fork} function (@pxref{Processes, -@code{primitive-fork}}). This is a prerequisite for the @code{(ice-9 -popen)} module (@pxref{Pipes}). +@code{primitive-fork}}). + +@item popen +Indicates support for @code{open-pipe} in the @code{(ice-9 popen)} +module (@pxref{Pipes}). @item random Indicates availability of random number generation functions: diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 118843d79..2799ddb86 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -2253,7 +2253,7 @@ controlling terminal. The return value is unspecified. The following procedures are similar to the @code{popen} and @code{pclose} system routines. The code is in a separate ``popen'' module@footnote{This module is only available on systems where the -@code{fork} feature is provided (@pxref{Common Feature Symbols}).}: +@code{popen} feature is provided (@pxref{Common Feature Symbols}).}: @lisp (use-modules (ice-9 popen)) diff --git a/libguile/posix.c b/libguile/posix.c index 15d2e816c..33838089e 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -2340,6 +2340,7 @@ scm_init_posix () scm_add_feature ("fork"); #endif /* HAVE_FORK */ #ifdef HAVE_START_CHILD + scm_add_feature ("popen"); scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, "scm_init_popen", (scm_t_extension_init_func) scm_init_popen, From ea223b07c2955dc3fdb42d9f8c0941ab2bdac096 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 14 Jul 2016 16:37:20 +0200 Subject: [PATCH 461/865] Update NEWS * NEWS: Update. --- NEWS | 2 ++ 1 file changed, 2 insertions(+) diff --git a/NEWS b/NEWS index e1e924d23..f08ac253e 100644 --- a/NEWS +++ b/NEWS @@ -878,6 +878,7 @@ More ARM cross-compilation targets are supported: "arm.*eb", () *** Reduce eq? and eqv? over constants using equal? () +*** Skip invalid .go files found in GUILE_LOAD_COMPILED_PATH ** Threads *** Fix data races leading to corruption () @@ -899,6 +900,7 @@ More ARM cross-compilation targets are supported: "arm.*eb", ** System *** {get,set}sockopt now expect type 'int' for SO_SNDBUF/SO_RCVBUF *** 'system*' now available on MS-Windows +*** 'open-pipe' now available on MS-Windows *** Better support for file names containing backslashes on Windows ** Web From a58bfb4ada9e6b8197232affaed6e2a37f576b45 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 16 Jul 2016 10:35:21 +0200 Subject: [PATCH 462/865] Fix MinGW build error * configure.ac: Fix for recent rename of win32-uname.c to posix-w32.c. --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 7bddae766..c2c7f52ad 100644 --- a/configure.ac +++ b/configure.ac @@ -715,7 +715,7 @@ case $host in AC_CHECK_HEADER(winsock2.h, [AC_DEFINE([HAVE_WINSOCK2_H], 1, [Define if you have the header file.])]) AC_CHECK_LIB(ws2_32, main) - AC_LIBOBJ([win32-uname]) + AC_LIBOBJ([posix-w32]) if test "$enable_shared" = yes ; then EXTRA_DEFS="-DSCM_IMPORT" AC_DEFINE([USE_DLL_IMPORT], 1, From da0ee4dc80a6c0283292ab25648afaa3a55d55e9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 16 Jul 2016 10:51:38 +0200 Subject: [PATCH 463/865] Fix unused static variables in net_db.c * libguile/net_db.c (SCM_DEFINE_CONSTANT): New helper. Use it to define constants and avoid the unneeded static variables that were used before, named "sym_" but actually holding variables. Thanks to Eli Zaretskii for the report. --- libguile/net_db.c | 83 ++++++++++++++++------------------------------- 1 file changed, 28 insertions(+), 55 deletions(-) diff --git a/libguile/net_db.c b/libguile/net_db.c index d7a12c50f..98c6feddd 100644 --- a/libguile/net_db.c +++ b/libguile/net_db.c @@ -447,24 +447,18 @@ SCM_DEFINE (scm_setserv, "setserv", 0, 1, 0, SCM_SYMBOL (sym_getaddrinfo_error, "getaddrinfo-error"); -/* Make sure the `AI_*' flags can be stored as INUMs. */ -verify (AI_ALL < SCM_MOST_POSITIVE_FIXNUM); +#define SCM_DEFINE_CONSTANT(constant) \ +SCM_SNARF_HERE(verify (constant < SCM_MOST_POSITIVE_FIXNUM)) \ +SCM_SNARF_INIT(scm_c_define (#constant, SCM_I_MAKINUM (constant));) /* Valid values for the `ai_flags' to `struct addrinfo'. */ -SCM_VARIABLE_INIT (sym_ai_passive, "AI_PASSIVE", - SCM_I_MAKINUM (AI_PASSIVE)); -SCM_VARIABLE_INIT (sym_ai_canonname, "AI_CANONNAME", - SCM_I_MAKINUM (AI_CANONNAME)); -SCM_VARIABLE_INIT (sym_ai_numerichost, "AI_NUMERICHOST", - SCM_I_MAKINUM (AI_NUMERICHOST)); -SCM_VARIABLE_INIT (sym_ai_numericserv, "AI_NUMERICSERV", - SCM_I_MAKINUM (AI_NUMERICSERV)); -SCM_VARIABLE_INIT (sym_ai_v4mapped, "AI_V4MAPPED", - SCM_I_MAKINUM (AI_V4MAPPED)); -SCM_VARIABLE_INIT (sym_ai_all, "AI_ALL", - SCM_I_MAKINUM (AI_ALL)); -SCM_VARIABLE_INIT (sym_ai_addrconfig, "AI_ADDRCONFIG", - SCM_I_MAKINUM (AI_ADDRCONFIG)); +SCM_DEFINE_CONSTANT (AI_PASSIVE); +SCM_DEFINE_CONSTANT (AI_CANONNAME); +SCM_DEFINE_CONSTANT (AI_NUMERICHOST); +SCM_DEFINE_CONSTANT (AI_NUMERICSERV); +SCM_DEFINE_CONSTANT (AI_V4MAPPED); +SCM_DEFINE_CONSTANT (AI_ALL); +SCM_DEFINE_CONSTANT (AI_ADDRCONFIG); /* Return a Scheme vector whose elements correspond to the fields of C_AI, ignoring the `ai_next' field. This function is not exported because the @@ -673,63 +667,42 @@ SCM_DEFINE (scm_getaddrinfo, "getaddrinfo", 1, 5, 0, } #undef FUNC_NAME -/* Make sure the `EAI_*' flags can be stored as INUMs. */ -verify (EAI_BADFLAGS < SCM_MOST_POSITIVE_FIXNUM); - /* Error codes returned by `getaddrinfo'. */ -SCM_VARIABLE_INIT (sym_eai_badflags, "EAI_BADFLAGS", - SCM_I_MAKINUM (EAI_BADFLAGS)); -SCM_VARIABLE_INIT (sym_eai_noname, "EAI_NONAME", - SCM_I_MAKINUM (EAI_NONAME)); -SCM_VARIABLE_INIT (sym_eai_again, "EAI_AGAIN", - SCM_I_MAKINUM (EAI_AGAIN)); -SCM_VARIABLE_INIT (sym_eai_fail, "EAI_FAIL", - SCM_I_MAKINUM (EAI_FAIL)); -SCM_VARIABLE_INIT (sym_eai_family, "EAI_FAMILY", - SCM_I_MAKINUM (EAI_FAMILY)); -SCM_VARIABLE_INIT (sym_eai_socktype, "EAI_SOCKTYPE", - SCM_I_MAKINUM (EAI_SOCKTYPE)); -SCM_VARIABLE_INIT (sym_eai_service, "EAI_SERVICE", - SCM_I_MAKINUM (EAI_SERVICE)); -SCM_VARIABLE_INIT (sym_eai_memory, "EAI_MEMORY", - SCM_I_MAKINUM (EAI_MEMORY)); -SCM_VARIABLE_INIT (sym_eai_system, "EAI_SYSTEM", - SCM_I_MAKINUM (EAI_SYSTEM)); -SCM_VARIABLE_INIT (sym_eai_overflow, "EAI_OVERFLOW", - SCM_I_MAKINUM (EAI_OVERFLOW)); +SCM_DEFINE_CONSTANT (EAI_BADFLAGS); +SCM_DEFINE_CONSTANT (EAI_NONAME); +SCM_DEFINE_CONSTANT (EAI_AGAIN); +SCM_DEFINE_CONSTANT (EAI_FAIL); +SCM_DEFINE_CONSTANT (EAI_FAMILY); +SCM_DEFINE_CONSTANT (EAI_SOCKTYPE); +SCM_DEFINE_CONSTANT (EAI_SERVICE); +SCM_DEFINE_CONSTANT (EAI_MEMORY); +SCM_DEFINE_CONSTANT (EAI_SYSTEM); +SCM_DEFINE_CONSTANT (EAI_OVERFLOW); /* The following values are GNU extensions. */ #ifdef EAI_NODATA -SCM_VARIABLE_INIT (sym_eai_nodata, "EAI_NODATA", - SCM_I_MAKINUM (EAI_NODATA)); +SCM_DEFINE_CONSTANT (EAI_NODATA); #endif #ifdef EAI_ADDRFAMILY -SCM_VARIABLE_INIT (sym_eai_addrfamily, "EAI_ADDRFAMILY", - SCM_I_MAKINUM (EAI_ADDRFAMILY)); +SCM_DEFINE_CONSTANT (EAI_ADDRFAMILY); #endif #ifdef EAI_INPROGRESS -SCM_VARIABLE_INIT (sym_eai_inprogress, "EAI_INPROGRESS", - SCM_I_MAKINUM (EAI_INPROGRESS)); +SCM_DEFINE_CONSTANT (EAI_INPROGRESS); #endif #ifdef EAI_CANCELED -SCM_VARIABLE_INIT (sym_eai_canceled, "EAI_CANCELED", - SCM_I_MAKINUM (EAI_CANCELED)); +SCM_DEFINE_CONSTANT (EAI_CANCELED); #endif #ifdef EAI_NOTCANCELED -SCM_VARIABLE_INIT (sym_eai_notcanceled, "EAI_NOTCANCELED", - SCM_I_MAKINUM (EAI_NOTCANCELED)); +SCM_DEFINE_CONSTANT (EAI_NOTCANCELED); #endif #ifdef EAI_ALLDONE -SCM_VARIABLE_INIT (sym_eai_alldone, "EAI_ALLDONE", - SCM_I_MAKINUM (EAI_ALLDONE)); +SCM_DEFINE_CONSTANT (EAI_ALLDONE); #endif #ifdef EAI_INTR -SCM_VARIABLE_INIT (sym_eai_intr, "EAI_INTR", - SCM_I_MAKINUM (EAI_INTR)); +SCM_DEFINE_CONSTANT (EAI_INTR); #endif #ifdef EAI_IDN_ENCODE -SCM_VARIABLE_INIT (sym_eai_idn_encode, "EAI_IDN_ENCODE", - SCM_I_MAKINUM (EAI_IDN_ENCODE)); +SCM_DEFINE_CONSTANT (EAI_IDN_ENCODE); #endif SCM_DEFINE (scm_gai_strerror, "gai-strerror", 1, 0, 0, From d87915f25d47711f0061e7ff92485859bb5747e6 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 16 Jul 2016 10:54:45 +0200 Subject: [PATCH 464/865] Update uname implementation in posix-w32 * libguile/posix-w32.c (uname): Update to modern processors (ia64 and x86_64) and OS versions (Vista to Windows 10). Delete trailing whitespace. --- libguile/posix-w32.c | 35 +++++++++++++++++++++++++++-------- 1 file changed, 27 insertions(+), 8 deletions(-) diff --git a/libguile/posix-w32.c b/libguile/posix-w32.c index f7df180f5..21b779e4e 100644 --- a/libguile/posix-w32.c +++ b/libguile/posix-w32.c @@ -59,13 +59,26 @@ uname (struct utsname *uts) strcpy (uts->sysname, "Windows NT3x"); /* NT3x */ else if (osver.dwMajorVersion == 5 && osver.dwMinorVersion < 1) strcpy (uts->sysname, "Windows 2000"); /* 2k */ - else if (osver.dwMajorVersion >= 5) + else if (osver.dwMajorVersion < 6) strcpy (uts->sysname, "Windows XP"); /* XP */ + else if (osver.dwMajorVersion == 6) + { + if (osver.dwMinorVersion < 1) + strcpy (uts->sysname, "Windows Vista"); /* Vista */ + else if (osver.dwMinorVersion < 2) + strcpy (uts->sysname, "Windows 7"); /* Windows 7 */ + else if (osver.dwMinorVersion < 3) + strcpy (uts->sysname, "Windows 8"); /* Windows 8 */ + else if (osver.dwMinorVersion < 4) + strcpy (uts->sysname, "Windows 8.1"); /* Windows 8.1 */ + } + else if (osver.dwMajorVersion >= 10) + strcpy (uts->sysname, "Windows 10 or later"); /* Windows 10 and later */ os = WinNT; break; case VER_PLATFORM_WIN32_WINDOWS: /* Win95, Win98 or WinME */ - if ((osver.dwMajorVersion > 4) || + if ((osver.dwMajorVersion > 4) || ((osver.dwMajorVersion == 4) && (osver.dwMinorVersion > 0))) { if (osver.dwMinorVersion >= 90) @@ -86,11 +99,11 @@ uname (struct utsname *uts) break; } - sprintf (uts->version, "%ld.%02ld", + sprintf (uts->version, "%ld.%02ld", osver.dwMajorVersion, osver.dwMinorVersion); if (osver.szCSDVersion[0] != '\0' && - (strlen (osver.szCSDVersion) + strlen (uts->version) + 1) < + (strlen (osver.szCSDVersion) + strlen (uts->version) + 1) < sizeof (uts->version)) { strcat (uts->version, " "); @@ -110,10 +123,13 @@ uname (struct utsname *uts) case PROCESSOR_ARCHITECTURE_MIPS: strcpy (uts->machine, "mips"); break; + case PROCESSOR_ARCHITECTURE_IA64: + strcpy (uts->machine, "ia64"); + break; case PROCESSOR_ARCHITECTURE_INTEL: - /* + /* * dwProcessorType is only valid in Win95 and Win98 and WinME - * wProcessorLevel is only valid in WinNT + * wProcessorLevel is only valid in WinNT */ switch (os) { @@ -137,13 +153,16 @@ uname (struct utsname *uts) default: strcpy (uts->machine, "unknown"); break; - } + } + break; + case PROCESSOR_ARCHITECTURE_AMD64: + strcpy (uts->machine, "x86_64"); break; default: strcpy (uts->machine, "unknown"); break; } - + sLength = sizeof (uts->nodename) - 1; GetComputerName (uts->nodename, &sLength); return 0; From e868fae6585d82c0b46a9a840913f0674dde0d3e Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Fri, 15 Jul 2016 09:41:02 +0200 Subject: [PATCH 465/865] doc: Do not gender the programmer. * doc/ref/api-foreign.texi: Replace "his" with "their". * doc/ref/sxml.texi: Likewise. --- doc/ref/api-foreign.texi | 2 +- doc/ref/sxml.texi | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi index c2c49ec48..76614f021 100644 --- a/doc/ref/api-foreign.texi +++ b/doc/ref/api-foreign.texi @@ -52,7 +52,7 @@ automatically the next time they are run. Now, when all the necessary machinery is there to perform part of the linking at run-time, why not take the next step and allow the programmer -to explicitly take advantage of it from within his program? Of course, +to explicitly take advantage of it from within their program? Of course, many operating systems that support shared libraries do just that, and chances are that Guile will allow you to access this feature from within your Scheme programs. As you might have guessed already, this feature diff --git a/doc/ref/sxml.texi b/doc/ref/sxml.texi index 17c3d01b7..3b940bd3e 100644 --- a/doc/ref/sxml.texi +++ b/doc/ref/sxml.texi @@ -275,7 +275,7 @@ the middle- and high-level parsers are single-threaded through the the @var{seed} in any way: they simply pass it around as an instance of an opaque datatype. User functions, on the other hand, can use the seed to maintain user's state, to accumulate parsing results, etc. A user -can freely mix his own functions with those of the framework. On the +can freely mix their own functions with those of the framework. On the other hand, the user may wish to instantiate a high-level parser: @code{SSAX:make-elem-parser} or @code{SSAX:make-parser}. In the latter case, the user must provide functions of specific signatures, which are From aae356158412662c97b7178768bfe4be41749a3b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 16 Jul 2016 15:34:41 +0200 Subject: [PATCH 466/865] Allow mkstemp! to have optional "mode" argument * m4/mkstemp.m4: Remove. * lib/mkstemp.c: Remove. * lib/mkostemp.c: New file. * m4/mkostemp.m4: New file. * lib/Makefile.am: * m4/gnulib-cache.m4: * m4/gnulib-comp.m4: Remove mkstemp module, replace with mkostemp. * libguile/fports.h: * libguile/fports.c (scm_i_mode_to_open_flags): Factor out helper to parse mode string to open flags. (scm_open_file_with_encoding): Use the new helper. * libguile/filesys.c: (scm_i_mkstemp): Adapt to take optional second argument, being a mode string. Use mkostemp. (scm_mkstemp): Backwards compatible shim that calls scm_i_mkstemp. * doc/ref/posix.texi: * NEWS: Update. * module/system/base/compile.scm (call-with-output-file/atomic): Pass "wb" as mode, to cause O_BINARY to be added on MinGW. --- NEWS | 14 ++++++ doc/ref/posix.texi | 6 ++- lib/Makefile.am | 10 ++--- lib/{mkstemp.c => mkostemp.c} | 12 ++--- libguile/filesys.c | 45 ++++++++++++++++--- libguile/fports.c | 77 +++++++++++++++++-------------- libguile/fports.h | 2 + m4/gnulib-cache.m4 | 4 +- m4/gnulib-comp.m4 | 19 ++++---- m4/mkostemp.m4 | 23 ++++++++++ m4/mkstemp.m4 | 82 ---------------------------------- module/system/base/compile.scm | 2 +- 12 files changed, 149 insertions(+), 147 deletions(-) rename lib/{mkstemp.c => mkostemp.c} (80%) create mode 100644 m4/mkostemp.m4 delete mode 100644 m4/mkstemp.m4 diff --git a/NEWS b/NEWS index f08ac253e..5286a437c 100644 --- a/NEWS +++ b/NEWS @@ -743,6 +743,20 @@ longer installed to the libdir. This change should be transparent to users, but packagers may be interested. + +Changes in 2.0.13 (since 2.0.12): + +* Notable changes +* New interfaces +** mkstemp! takes optional "mode" argument + +See "File System" in the manual, for more. + +* Bug fixes +** Fix optimizer bug when compiling fixpoint operator +** Fix build error on MinGW +** Update `uname' implementation on MinGW + Changes in 2.0.12 (since 2.0.11): diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 2799ddb86..5ca9402fd 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -954,7 +954,7 @@ another name if the file exists (error @code{EEXIST}). @code{mkstemp!} below does that. @end deffn -@deffn {Scheme Procedure} mkstemp! tmpl +@deffn {Scheme Procedure} mkstemp! tmpl [mode] @deffnx {C Function} scm_mkstemp (tmpl) @cindex temporary file Create a new unique file in the file system and return a new buffered @@ -975,6 +975,10 @@ which is usual for ordinary file creation, (chmod port (logand #o666 (lognot (umask)))) ...) @end example + +The optional @var{mode} argument specifies a mode with which to open the +new file, as a string in the same format that @code{open-file} takes. +It defaults to @code{"w+"}. @end deffn @deffn {Scheme Procedure} tmpfile diff --git a/lib/Makefile.am b/lib/Makefile.am index adf95373e..b9749062b 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -21,7 +21,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --avoid=unistr/base --avoid=unistr/u8-mbtouc --avoid=unistr/u8-mbtouc-unsafe --avoid=unistr/u8-mbtoucr --avoid=unistr/u8-prev --avoid=unistr/u8-uctomb --avoid=unitypes --lgpl=3 --conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkstemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar +# Reproduce by: gnulib-tool --import --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --avoid=unistr/base --avoid=unistr/u8-mbtouc --avoid=unistr/u8-mbtouc-unsafe --avoid=unistr/u8-mbtoucr --avoid=unistr/u8-prev --avoid=unistr/u8-uctomb --avoid=unitypes --lgpl=3 --conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkostemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar AUTOMAKE_OPTIONS = 1.9.6 gnits @@ -1500,14 +1500,14 @@ EXTRA_libgnu_la_SOURCES += mkdir.c ## end gnulib module mkdir -## begin gnulib module mkstemp +## begin gnulib module mkostemp -EXTRA_DIST += mkstemp.c +EXTRA_DIST += mkostemp.c -EXTRA_libgnu_la_SOURCES += mkstemp.c +EXTRA_libgnu_la_SOURCES += mkostemp.c -## end gnulib module mkstemp +## end gnulib module mkostemp ## begin gnulib module mktime diff --git a/lib/mkstemp.c b/lib/mkostemp.c similarity index 80% rename from lib/mkstemp.c rename to lib/mkostemp.c index bbad5f9cd..25a63b7b1 100644 --- a/lib/mkstemp.c +++ b/lib/mkostemp.c @@ -24,7 +24,7 @@ #if !_LIBC # include "tempname.h" # define __gen_tempname gen_tempname -# ifndef __GT_FILE +# ifndef __GTFILE # define __GT_FILE GT_FILE # endif #endif @@ -38,13 +38,9 @@ /* Generate a unique temporary file name from XTEMPLATE. The last six characters of XTEMPLATE must be "XXXXXX"; they are replaced with a string that makes the file name unique. - Then open the file and return a fd. - - If you are creating temporary files which will later be removed, - consider using the clean-temp module, which avoids several pitfalls - of using mkstemp directly. */ + Then open the file and return a fd. */ int -mkstemp (char *xtemplate) +mkostemp (char *xtemplate, int flags) { - return __gen_tempname (xtemplate, 0, 0, __GT_FILE); + return __gen_tempname (xtemplate, 0, flags, __GT_FILE); } diff --git a/libguile/filesys.c b/libguile/filesys.c index 25501ef76..879a72df0 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1439,8 +1439,9 @@ SCM_DEFINE (scm_umask, "umask", 0, 1, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0, - (SCM tmpl), +SCM_INTERNAL SCM scm_i_mkstemp (SCM, SCM); +SCM_DEFINE (scm_i_mkstemp, "mkstemp!", 1, 1, 0, + (SCM tmpl, SCM mode), "Create a new unique file in the file system and return a new\n" "buffered port open for reading and writing to the file.\n" "\n" @@ -1459,18 +1460,38 @@ SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0, "(let ((port (mkstemp! (string-copy \"/tmp/myfile-XXXXXX\"))))\n" " (chmod port (logand #o666 (lognot (umask))))\n" " ...)\n" - "@end example") -#define FUNC_NAME s_scm_mkstemp + "@end example\n" + "\n" + "The optional @var{mode} argument specifies a mode, as a string\n" + "in the same format that @code{open-file} takes. It defaults\n" + "to @code{\"w+\"}.") +#define FUNC_NAME s_scm_i_mkstemp { char *c_tmpl; + long mode_bits; int rv; + int open_flags, is_binary; + SCM port; scm_dynwind_begin (0); c_tmpl = scm_to_locale_string (tmpl); scm_dynwind_free (c_tmpl); + if (SCM_UNBNDP (mode)) + { + /* mkostemp will create a read/write file and add on additional + flags; open_flags just adjoins flags to that set. */ + open_flags = 0; + is_binary = 0; + mode_bits = SCM_OPN | SCM_RDNG | SCM_WRTNG; + } + else + { + open_flags = scm_i_mode_to_open_flags (mode, &is_binary, FUNC_NAME); + mode_bits = scm_i_mode_bits (mode); + } - SCM_SYSCALL (rv = mkstemp (c_tmpl)); + SCM_SYSCALL (rv = mkostemp (c_tmpl, open_flags)); if (rv == -1) SCM_SYSERROR; @@ -1479,10 +1500,22 @@ SCM_DEFINE (scm_mkstemp, "mkstemp!", 1, 0, 0, tmpl, SCM_INUM0); scm_dynwind_end (); - return scm_fdes_to_port (rv, "w+", tmpl); + + port = scm_i_fdes_to_port (rv, mode_bits, tmpl); + if (is_binary) + /* Use the binary-friendly ISO-8859-1 encoding. */ + scm_i_set_port_encoding_x (port, NULL); + + return port; } #undef FUNC_NAME +SCM +scm_mkstemp (SCM tmpl) +{ + return scm_i_mkstemp (tmpl, SCM_UNDEFINED); +} + /* Filename manipulation */ diff --git a/libguile/fports.c b/libguile/fports.c index 271f3a0a1..f535f8a25 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -152,45 +152,17 @@ fport_canonicalize_filename (SCM filename) } } -/* scm_open_file_with_encoding - Return a new port open on a given file. - - The mode string must match the pattern: [rwa+]** which - is interpreted in the usual unix way. - - Unless binary mode is requested, the character encoding of the new - port is determined as follows: First, if GUESS_ENCODING is true, - 'file-encoding' is used to guess the encoding of the file. If - GUESS_ENCODING is false or if 'file-encoding' fails, ENCODING is used - unless it is also false. As a last resort, the default port encoding - is used. It is an error to pass a non-false GUESS_ENCODING or - ENCODING if binary mode is requested. - - Return the new port. */ -SCM -scm_open_file_with_encoding (SCM filename, SCM mode, - SCM guess_encoding, SCM encoding) -#define FUNC_NAME "open-file" +int +scm_i_mode_to_open_flags (SCM mode, int *is_binary, const char *FUNC_NAME) { - SCM port; - int fdes, flags = 0, binary = 0; - unsigned int retries; - char *file; + int flags = 0; const char *md, *ptr; - if (SCM_UNLIKELY (!(scm_is_false (encoding) || scm_is_string (encoding)))) - scm_wrong_type_arg_msg (FUNC_NAME, 0, encoding, - "encoding to be string or false"); - - scm_dynwind_begin (0); - - file = scm_to_locale_string (filename); - scm_dynwind_free (file); - if (SCM_UNLIKELY (!scm_i_try_narrow_string (mode))) scm_out_of_range (FUNC_NAME, mode); md = scm_i_string_chars (mode); + *is_binary = 0; switch (*md) { @@ -215,7 +187,7 @@ scm_open_file_with_encoding (SCM filename, SCM mode, flags = (flags & ~(O_RDONLY | O_WRONLY)) | O_RDWR; break; case 'b': - binary = 1; + *is_binary = 1; #if defined (O_BINARY) flags |= O_BINARY; #endif @@ -229,6 +201,45 @@ scm_open_file_with_encoding (SCM filename, SCM mode, ptr++; } + return flags; +} + +/* scm_open_file_with_encoding + Return a new port open on a given file. + + The mode string must match the pattern: [rwa+]** which + is interpreted in the usual unix way. + + Unless binary mode is requested, the character encoding of the new + port is determined as follows: First, if GUESS_ENCODING is true, + 'file-encoding' is used to guess the encoding of the file. If + GUESS_ENCODING is false or if 'file-encoding' fails, ENCODING is used + unless it is also false. As a last resort, the default port encoding + is used. It is an error to pass a non-false GUESS_ENCODING or + ENCODING if binary mode is requested. + + Return the new port. */ +SCM +scm_open_file_with_encoding (SCM filename, SCM mode, + SCM guess_encoding, SCM encoding) +#define FUNC_NAME "open-file" +{ + SCM port; + int fdes, flags, binary = 0; + unsigned int retries; + char *file; + + if (SCM_UNLIKELY (!(scm_is_false (encoding) || scm_is_string (encoding)))) + scm_wrong_type_arg_msg (FUNC_NAME, 0, encoding, + "encoding to be string or false"); + + scm_dynwind_begin (0); + + file = scm_to_locale_string (filename); + scm_dynwind_free (file); + + flags = scm_i_mode_to_open_flags (mode, &binary, FUNC_NAME); + for (retries = 0, fdes = -1; fdes < 0 && retries < 2; retries++) diff --git a/libguile/fports.h b/libguile/fports.h index 6b15bd971..ee9bf7cbd 100644 --- a/libguile/fports.h +++ b/libguile/fports.h @@ -53,6 +53,8 @@ SCM_API scm_t_port_type *scm_file_port_type; SCM_API void scm_evict_ports (int fd); +SCM_INTERNAL int scm_i_mode_to_open_flags (SCM mode, int *is_binary, + const char *FUNC_NAME); SCM_API SCM scm_open_file_with_encoding (SCM filename, SCM modes, SCM guess_encoding, SCM encoding); SCM_API SCM scm_open_file (SCM filename, SCM modes); diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index fc4fbc631..85ba6b683 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -27,7 +27,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --avoid=unistr/base --avoid=unistr/u8-mbtouc --avoid=unistr/u8-mbtouc-unsafe --avoid=unistr/u8-mbtoucr --avoid=unistr/u8-prev --avoid=unistr/u8-uctomb --avoid=unitypes --lgpl=3 --conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkstemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar +# gnulib-tool --import --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --avoid=unistr/base --avoid=unistr/u8-mbtouc --avoid=unistr/u8-mbtouc-unsafe --avoid=unistr/u8-mbtoucr --avoid=unistr/u8-prev --avoid=unistr/u8-uctomb --avoid=unitypes --lgpl=3 --conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkostemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([gnulib-local]) @@ -90,7 +90,7 @@ gl_MODULES([ malloc-gnu malloca mkdir - mkstemp + mkostemp nl_langinfo nproc open diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 98de2b765..8834cfc17 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -151,7 +151,7 @@ AC_DEFUN([gl_EARLY], # Code from module mbtowc: # Code from module memchr: # Code from module mkdir: - # Code from module mkstemp: + # Code from module mkostemp: # Code from module mktime: # Code from module mktime-internal: # Code from module msvc-inval: @@ -515,12 +515,13 @@ AC_DEFUN([gl_INIT], if test $REPLACE_MKDIR = 1; then AC_LIBOBJ([mkdir]) fi - gl_FUNC_MKSTEMP - if test $HAVE_MKSTEMP = 0 || test $REPLACE_MKSTEMP = 1; then - AC_LIBOBJ([mkstemp]) - gl_PREREQ_MKSTEMP + gl_FUNC_MKOSTEMP + if test $HAVE_MKOSTEMP = 0; then + AC_LIBOBJ([mkostemp]) + gl_PREREQ_MKOSTEMP fi - gl_STDLIB_MODULE_INDICATOR([mkstemp]) + gl_MODULE_INDICATOR([mkostemp]) + gl_STDLIB_MODULE_INDICATOR([mkostemp]) gl_MULTIARCH gl_HEADER_NETDB gl_HEADER_NETINET_IN @@ -1360,7 +1361,7 @@ AC_SUBST([LTALLOCA]) if test $REPLACE_MKDIR = 1; then func_gl_gnulib_m4code_a691da99c1d83b83238e45f41a696f5c fi - if test $HAVE_MKSTEMP = 0 || test $REPLACE_MKSTEMP = 1; then + if test $HAVE_MKOSTEMP = 0; then func_gl_gnulib_m4code_tempname fi if test $HAVE_NL_LANGINFO = 0 || test $REPLACE_NL_LANGINFO = 1; then @@ -1786,7 +1787,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/memchr.c lib/memchr.valgrind lib/mkdir.c - lib/mkstemp.c + lib/mkostemp.c lib/mktime-internal.h lib/mktime.c lib/msvc-inval.c @@ -1987,7 +1988,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/mbtowc.m4 m4/memchr.m4 m4/mkdir.m4 - m4/mkstemp.m4 + m4/mkostemp.m4 m4/mktime.m4 m4/mmap-anon.m4 m4/mode_t.m4 diff --git a/m4/mkostemp.m4 b/m4/mkostemp.m4 new file mode 100644 index 000000000..1f44a0390 --- /dev/null +++ b/m4/mkostemp.m4 @@ -0,0 +1,23 @@ +# mkostemp.m4 serial 2 +dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_FUNC_MKOSTEMP], +[ + AC_REQUIRE([gl_STDLIB_H_DEFAULTS]) + + dnl Persuade glibc to declare mkostemp(). + AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS]) + + AC_CHECK_FUNCS_ONCE([mkostemp]) + if test $ac_cv_func_mkostemp != yes; then + HAVE_MKOSTEMP=0 + fi +]) + +# Prerequisites of lib/mkostemp.c. +AC_DEFUN([gl_PREREQ_MKOSTEMP], +[ +]) diff --git a/m4/mkstemp.m4 b/m4/mkstemp.m4 deleted file mode 100644 index 131e4a7b2..000000000 --- a/m4/mkstemp.m4 +++ /dev/null @@ -1,82 +0,0 @@ -#serial 23 - -# Copyright (C) 2001, 2003-2007, 2009-2016 Free Software Foundation, Inc. -# This file is free software; the Free Software Foundation -# gives unlimited permission to copy and/or distribute it, -# with or without modifications, as long as this notice is preserved. - -# On some hosts (e.g., HP-UX 10.20, SunOS 4.1.4, Solaris 2.5.1), mkstemp has a -# silly limit that it can create no more than 26 files from a given template. -# Other systems lack mkstemp altogether. -# On OSF1/Tru64 V4.0F, the system-provided mkstemp function can create -# only 32 files per process. -# On some hosts, mkstemp creates files with mode 0666, which is a security -# problem and a violation of POSIX 2008. -# On systems like the above, arrange to use the replacement function. -AC_DEFUN([gl_FUNC_MKSTEMP], -[ - AC_REQUIRE([gl_STDLIB_H_DEFAULTS]) - AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles - - AC_CHECK_FUNCS_ONCE([mkstemp]) - if test $ac_cv_func_mkstemp = yes; then - AC_CACHE_CHECK([for working mkstemp], - [gl_cv_func_working_mkstemp], - [ - mkdir conftest.mkstemp - AC_RUN_IFELSE( - [AC_LANG_PROGRAM( - [AC_INCLUDES_DEFAULT], - [[int result = 0; - int i; - off_t large = (off_t) 4294967295u; - if (large < 0) - large = 2147483647; - umask (0); - for (i = 0; i < 70; i++) - { - char templ[] = "conftest.mkstemp/coXXXXXX"; - int (*mkstemp_function) (char *) = mkstemp; - int fd = mkstemp_function (templ); - if (fd < 0) - result |= 1; - else - { - struct stat st; - if (lseek (fd, large, SEEK_SET) != large) - result |= 2; - if (fstat (fd, &st) < 0) - result |= 4; - else if (st.st_mode & 0077) - result |= 8; - if (close (fd)) - result |= 16; - } - } - return result;]])], - [gl_cv_func_working_mkstemp=yes], - [gl_cv_func_working_mkstemp=no], - [case "$host_os" in - # Guess yes on glibc systems. - *-gnu*) gl_cv_func_working_mkstemp="guessing yes" ;; - # If we don't know, assume the worst. - *) gl_cv_func_working_mkstemp="guessing no" ;; - esac - ]) - rm -rf conftest.mkstemp - ]) - case "$gl_cv_func_working_mkstemp" in - *yes) ;; - *) - REPLACE_MKSTEMP=1 - ;; - esac - else - HAVE_MKSTEMP=0 - fi -]) - -# Prerequisites of lib/mkstemp.c. -AC_DEFUN([gl_PREREQ_MKSTEMP], -[ -]) diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index dfe03fde7..c110512f0 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -51,7 +51,7 @@ ;; emacs: (put 'call-with-output-file/atomic 'scheme-indent-function 1) (define* (call-with-output-file/atomic filename proc #:optional reference) (let* ((template (string-append filename ".XXXXXX")) - (tmp (mkstemp! template))) + (tmp (mkstemp! template "wb"))) (call-once (lambda () (with-throw-handler #t From 62843d5475c31214c8c06d4946dcd75ada951bf9 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 16 Jul 2016 19:58:25 +0300 Subject: [PATCH 467/865] Improve process handling on MS-Windows * libguile/posix-w32.c: Include gc.h and threads.h. (proc_record): New structure tag. : New static variables. (find_proc, proc_handle, record_proc, delete_proc): New utility functions. (start_child): Return value is now pid_t, as it is on Posix platforms. Record the new process and returns its PID, instead of returning a handle. Fix the recursive call. (waitpid, kill, getpriority, setpriority, sched_getaffinity) (sched_setaffinity): Look up the PID in the recorded subprocesses before trying to open a process that is not our subprocess. Make sure any open handle is closed before returning, unless it's our subprocess. --- libguile/posix-w32.c | 233 +++++++++++++++++++++++++++++++++++++++---- 1 file changed, 216 insertions(+), 17 deletions(-) diff --git a/libguile/posix-w32.c b/libguile/posix-w32.c index 21b779e4e..a3669e4fb 100644 --- a/libguile/posix-w32.c +++ b/libguile/posix-w32.c @@ -29,8 +29,14 @@ #include #include #include +#include +#include +#include +#include #include "posix-w32.h" +#include "libguile/gc.h" /* for scm_*alloc, scm_strdup */ +#include "libguile/threads.h" /* for scm_i_scm_pthread_mutex_lock */ /* * Get name and information about current kernel. @@ -168,6 +174,80 @@ uname (struct utsname *uts) return 0; } +/* Utility functions for maintaining the list of subprocesses launched + by Guile. */ + +struct proc_record { + DWORD pid; + HANDLE handle; +}; + +static struct proc_record *procs; +static ptrdiff_t proc_size; + +/* Find the process slot that corresponds to PID. Return the index of + the slot, or -1 if not found. */ +static ptrdiff_t +find_proc (pid_t pid) +{ + ptrdiff_t found = -1, i; + + for (i = 0; i < proc_size; i++) + { + if (procs[i].pid == pid && procs[i].handle != INVALID_HANDLE_VALUE) + found = i; + } + + return found; +} + +/* Return the process handle corresponding to its PID. If not found, + return invalid handle value. */ +static HANDLE +proc_handle (pid_t pid) +{ + ptrdiff_t idx = find_proc (pid); + + if (idx < 0) + return INVALID_HANDLE_VALUE; + return procs[idx].handle; +} + +/* Store a process record in the procs[] array. */ +static void +record_proc (pid_t proc_pid, HANDLE proc_handle) +{ + ptrdiff_t i; + + /* Find a vacant slot. */ + for (i = 0; i < proc_size; i++) + { + if (procs[i].handle == INVALID_HANDLE_VALUE) + break; + } + + /* If no vacant slot, enlarge the array. */ + if (i == proc_size) + { + proc_size++; + procs = scm_realloc (procs, proc_size * sizeof(procs[0])); + } + + /* Store the process data. */ + procs[i].pid = proc_pid; + procs[i].handle = proc_handle; +} + +/* Delete a process record for process PID. */ +static void +delete_proc (pid_t pid) +{ + ptrdiff_t idx = find_proc (pid); + + if (0 <= idx && idx < proc_size) + procs[idx].handle = INVALID_HANDLE_VALUE; +} + /* Run a child process with redirected standard handles, without redirecting standard handles of the parent. This is required in multithreaded programs, where redirecting a standard handle affects @@ -522,7 +602,7 @@ prepare_cmdline (const char *cmd, const char * const *argv, int bin_sh_replaced) Return the PID of the child process, or -1 if couldn't start a process. */ -int +pid_t start_child (const char *exec_file, char **argv, int reading, int c2p[2], int writing, int p2c[2], int infd, int outfd, int errfd) @@ -642,7 +722,12 @@ start_child (const char *exec_file, char **argv, } } else - pid = (intptr_t)pi.hProcess; + { + scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex); + record_proc (pi.dwProcessId, pi.hProcess); + scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); + pid = pi.dwProcessId; + } errno_save = errno; @@ -666,7 +751,8 @@ start_child (const char *exec_file, char **argv, if (c_strcasecmp (exec_file, shell) != 0) { argv[0] = (char *)exec_file; - return start_child (shell, argv, reading, c2p, writing, p2c, errfd); + return start_child (shell, argv, reading, c2p, writing, p2c, + infd, outfd, errfd); } } @@ -677,13 +763,33 @@ start_child (const char *exec_file, char **argv, /* Emulation of waitpid which only supports WNOHANG, since _cwait doesn't. */ int -waitpid (intptr_t pid, int *status, int options) +waitpid (pid_t pid, int *status, int options) { + HANDLE ph; + + /* Not supported on MS-Windows. */ + if (pid <= 0) + { + errno = ENOSYS; + return -1; + } + + scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex); + ph = proc_handle (pid); + scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); + /* Since scm_waitpid is documented to work only on child processes, + being unable to find a process in our records means failure. */ + if (ph == INVALID_HANDLE_VALUE) + { + errno = ECHILD; + return -1; + } + if ((options & WNOHANG) != 0) { DWORD st; - if (!GetExitCodeProcess ((HANDLE)pid, &st)) + if (!GetExitCodeProcess (ph, &st)) { errno = ECHILD; return -1; @@ -692,10 +798,16 @@ waitpid (intptr_t pid, int *status, int options) return 0; if (status) *status = st; - return (int)pid; + CloseHandle (ph); } + else + _cwait (status, (intptr_t)ph, WAIT_CHILD); - return (int)_cwait (status, pid, WAIT_CHILD); + scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex); + delete_proc (pid); + scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); + + return pid; } @@ -757,8 +869,25 @@ w32_status_to_termsig (DWORD status) int kill (int pid, int sig) { - HANDLE ph = OpenProcess (PROCESS_TERMINATE, 0, pid); + HANDLE ph; + int child_proc = 0; + if (pid == getpid ()) + { + if (raise (sig) == 0) + errno = ENOSYS; + return -1; + } + + scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex); + ph = proc_handle (pid); + scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); + /* If not found among our subprocesses, look elsewhere in the + system. */ + if (ph == INVALID_HANDLE_VALUE) + ph = OpenProcess (PROCESS_TERMINATE, 0, pid); + else + child_proc = 1; if (!ph) { errno = EPERM; @@ -766,10 +895,23 @@ kill (int pid, int sig) } if (!TerminateProcess (ph, w32_signal_to_status (sig))) { - errno = EINVAL; + /* If it's our subprocess, it could have already exited. In + that case, waitpid will handily delete the process from our + records, and we should return a more meaningful ESRCH to the + caller. */ + if (child_proc && waitpid (pid, NULL, WNOHANG) == pid) + errno = ESRCH; + else + errno = EINVAL; return -1; } CloseHandle (ph); + if (child_proc) + { + scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex); + delete_proc (pid); + scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); + } return 0; } @@ -783,6 +925,7 @@ getpriority (int which, int who) HANDLE hp; int nice_value = -1; int error = 0; + int child_proc = 0; /* We don't support process groups and users. */ if (which != PRIO_PROCESS) @@ -794,12 +937,27 @@ getpriority (int which, int who) if (who == 0) hp = GetCurrentProcess (); else - hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, who); + { + scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex); + hp = proc_handle (who); + scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); + /* If not found among our subprocesses, look elsewhere in the + system. */ + if (hp == INVALID_HANDLE_VALUE) + hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, who); + else + child_proc = 1; + } if (hp) { DWORD pri_class = GetPriorityClass (hp); + /* The pseudo-handle returned by GetCurrentProcess doesn't need + to be closed. */ + if (who > 0 && !child_proc) + CloseHandle (hp); + if (pri_class > 0) { switch (pri_class) @@ -888,6 +1046,7 @@ setpriority (int which, int who, int nice_val) { HANDLE hp; DWORD err; + int child_proc = 0, retval = -1; if (which != PRIO_PROCESS) { @@ -898,7 +1057,17 @@ setpriority (int which, int who, int nice_val) if (who == 0) hp = GetCurrentProcess (); else - hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, who); + { + scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex); + hp = proc_handle (who); + scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); + /* If not found among our subprocesses, look elsewhere in the + system. */ + if (hp == INVALID_HANDLE_VALUE) + hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, who); + else + child_proc = 1; + } if (hp) { @@ -920,7 +1089,7 @@ setpriority (int which, int who, int nice_val) pri_class = REALTIME_PRIORITY_CLASS; if (SetPriorityClass (hp, pri_class)) - return 0; + retval = 0; } err = GetLastError (); @@ -934,8 +1103,12 @@ setpriority (int which, int who, int nice_val) errno = EPERM; break; } + /* The pseudo-handle returned by GetCurrentProcess doesn't + need to be closed. */ + if (hp && who > 0 && !child_proc) + CloseHandle (hp); - return -1; + return retval; } /* Emulation of sched_getaffinity and sched_setaffinity. */ @@ -944,6 +1117,7 @@ sched_getaffinity (int pid, size_t mask_size, cpu_set_t *mask) { HANDLE hp; DWORD err; + int child_proc = 0; if (mask == NULL) { @@ -954,14 +1128,26 @@ sched_getaffinity (int pid, size_t mask_size, cpu_set_t *mask) if (pid == 0) hp = GetCurrentProcess (); else - hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, pid); + { + scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex); + hp = proc_handle (pid); + scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); + /* If not found among our subprocesses, look elsewhere in the + system. */ + if (hp == INVALID_HANDLE_VALUE) + hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, pid); + else + child_proc = 1; + } if (hp) { DWORD_PTR ignored; BOOL result = GetProcessAffinityMask (hp, (DWORD_PTR *)mask, &ignored); - if (pid != 0) + /* The pseudo-handle returned by GetCurrentProcess doesn't + need to be closed. */ + if (pid > 0 && !child_proc) CloseHandle (hp); if (result) return 0; @@ -988,6 +1174,7 @@ sched_setaffinity (int pid, size_t mask_size, cpu_set_t *mask) { HANDLE hp; DWORD err; + int child_proc = 0; if (mask == NULL) { @@ -998,13 +1185,25 @@ sched_setaffinity (int pid, size_t mask_size, cpu_set_t *mask) if (pid == 0) hp = GetCurrentProcess (); else - hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, pid); + { + scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex); + hp = proc_handle (pid); + scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); + /* If not found among our subprocesses, look elsewhere in the + system. */ + if (hp == INVALID_HANDLE_VALUE) + hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, pid); + else + child_proc = 1; + } if (hp) { BOOL result = SetProcessAffinityMask (hp, *(DWORD_PTR *)mask); - if (pid != 0) + /* The pseudo-handle returned by GetCurrentProcess doesn't + need to be closed. */ + if (pid > 0 && !child_proc) CloseHandle (hp); if (result) return 0; From 0cf155be72189c9b3e8af10fc03bac7db9f422df Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 16 Jul 2016 20:00:56 +0300 Subject: [PATCH 468/865] Untabify posix-w32.c --- libguile/posix-w32.c | 602 +++++++++++++++++++++---------------------- 1 file changed, 301 insertions(+), 301 deletions(-) diff --git a/libguile/posix-w32.c b/libguile/posix-w32.c index a3669e4fb..1f00ec168 100644 --- a/libguile/posix-w32.c +++ b/libguile/posix-w32.c @@ -1,5 +1,5 @@ /* Copyright (C) 2001, 2006, 2008, 2016 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 License * as published by the Free Software Foundation; either version 3 of @@ -35,7 +35,7 @@ #include #include "posix-w32.h" -#include "libguile/gc.h" /* for scm_*alloc, scm_strdup */ +#include "libguile/gc.h" /* for scm_*alloc, scm_strdup */ #include "libguile/threads.h" /* for scm_i_scm_pthread_mutex_lock */ /* @@ -68,16 +68,16 @@ uname (struct utsname *uts) else if (osver.dwMajorVersion < 6) strcpy (uts->sysname, "Windows XP"); /* XP */ else if (osver.dwMajorVersion == 6) - { - if (osver.dwMinorVersion < 1) - strcpy (uts->sysname, "Windows Vista"); /* Vista */ - else if (osver.dwMinorVersion < 2) - strcpy (uts->sysname, "Windows 7"); /* Windows 7 */ - else if (osver.dwMinorVersion < 3) - strcpy (uts->sysname, "Windows 8"); /* Windows 8 */ - else if (osver.dwMinorVersion < 4) - strcpy (uts->sysname, "Windows 8.1"); /* Windows 8.1 */ - } + { + if (osver.dwMinorVersion < 1) + strcpy (uts->sysname, "Windows Vista"); /* Vista */ + else if (osver.dwMinorVersion < 2) + strcpy (uts->sysname, "Windows 7"); /* Windows 7 */ + else if (osver.dwMinorVersion < 3) + strcpy (uts->sysname, "Windows 8"); /* Windows 8 */ + else if (osver.dwMinorVersion < 4) + strcpy (uts->sysname, "Windows 8.1"); /* Windows 8.1 */ + } else if (osver.dwMajorVersion >= 10) strcpy (uts->sysname, "Windows 10 or later"); /* Windows 10 and later */ os = WinNT; @@ -87,10 +87,10 @@ uname (struct utsname *uts) if ((osver.dwMajorVersion > 4) || ((osver.dwMajorVersion == 4) && (osver.dwMinorVersion > 0))) { - if (osver.dwMinorVersion >= 90) - strcpy (uts->sysname, "Windows ME"); /* ME */ - else - strcpy (uts->sysname, "Windows 98"); /* 98 */ + if (osver.dwMinorVersion >= 90) + strcpy (uts->sysname, "Windows ME"); /* ME */ + else + strcpy (uts->sysname, "Windows 98"); /* 98 */ os = Win98; } else @@ -195,7 +195,7 @@ find_proc (pid_t pid) for (i = 0; i < proc_size; i++) { if (procs[i].pid == pid && procs[i].handle != INVALID_HANDLE_VALUE) - found = i; + found = i; } return found; @@ -223,7 +223,7 @@ record_proc (pid_t proc_pid, HANDLE proc_handle) for (i = 0; i < proc_size; i++) { if (procs[i].handle == INVALID_HANDLE_VALUE) - break; + break; } /* If no vacant slot, enlarge the array. */ @@ -278,49 +278,49 @@ prepare_child_handle (int fd, int use_std, DWORD access) /* Duplicate the handle and make it inheritable. */ if (DuplicateHandle (GetCurrentProcess (), - htem, - GetCurrentProcess (), - &hret, - 0, - TRUE, - DUPLICATE_SAME_ACCESS) == FALSE) + htem, + GetCurrentProcess (), + &hret, + 0, + TRUE, + DUPLICATE_SAME_ACCESS) == FALSE) { /* If the original standard handle was invalid (happens, e.g., - in GUI programs), open the null device instead. */ + in GUI programs), open the null device instead. */ if ((err = GetLastError ()) == ERROR_INVALID_HANDLE - && use_std) - { - htem = CreateFile ("NUL", access, - FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, - OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); - if (htem != INVALID_HANDLE_VALUE - && DuplicateHandle (GetCurrentProcess (), - htem, - GetCurrentProcess (), - &hret, - 0, - TRUE, - DUPLICATE_SAME_ACCESS) == FALSE) - { - err = GetLastError (); - CloseHandle (htem); - hret = INVALID_HANDLE_VALUE; - } - } + && use_std) + { + htem = CreateFile ("NUL", access, + FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, + OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); + if (htem != INVALID_HANDLE_VALUE + && DuplicateHandle (GetCurrentProcess (), + htem, + GetCurrentProcess (), + &hret, + 0, + TRUE, + DUPLICATE_SAME_ACCESS) == FALSE) + { + err = GetLastError (); + CloseHandle (htem); + hret = INVALID_HANDLE_VALUE; + } + } } if (hret == INVALID_HANDLE_VALUE) { switch (err) - { - case ERROR_NO_MORE_FILES: - errno = EMFILE; - break; - case ERROR_INVALID_HANDLE: - default: - errno = EBADF; - break; - } + { + case ERROR_NO_MORE_FILES: + errno = EMFILE; + break; + case ERROR_INVALID_HANDLE: + default: + errno = EBADF; + break; + } } return hret; @@ -405,7 +405,7 @@ lookup_cmd (const char *program, int *bin_sh_replaced) SearchPath will search in the directories whose list is specified by the system Registry. */ path = getenv ("PATH"); - if (!path) /* shouldn't happen, really */ + if (!path) /* shouldn't happen, really */ path = "."; dir = sep = path = strdup (path); for ( ; sep && *sep; dir = sep + 1) @@ -413,21 +413,21 @@ lookup_cmd (const char *program, int *bin_sh_replaced) int i; sep = strpbrk (dir, ";"); - if (sep == dir) /* two or more ;'s in a row */ - continue; + if (sep == dir) /* two or more ;'s in a row */ + continue; if (sep) - *sep = '\0'; + *sep = '\0'; for (i = 0; extensions[i]; i++) - { - abs_namelen = SearchPath (dir, program, extensions[i], - MAX_PATH, abs_name, NULL); - if (0 < abs_namelen && abs_namelen <= MAX_PATH) /* found! */ - break; - } - if (extensions[i]) /* found! */ - break; + { + abs_namelen = SearchPath (dir, program, extensions[i], + MAX_PATH, abs_name, NULL); + if (0 < abs_namelen && abs_namelen <= MAX_PATH) /* found! */ + break; + } + if (extensions[i]) /* found! */ + break; if (sep) - *sep = ';'; + *sep = ';'; } free (path); @@ -439,7 +439,7 @@ lookup_cmd (const char *program, int *bin_sh_replaced) const char *shell = getenv ("ComSpec"); if (!shell) - shell = "C:\\Windows\\system32\\cmd.exe"; + shell = "C:\\Windows\\system32\\cmd.exe"; *bin_sh_replaced = 1; strcpy (abs_name, shell); @@ -463,7 +463,7 @@ prepare_cmdline (const char *cmd, const char * const *argv, int bin_sh_replaced) program, including both Windows and Unixy shells, and the widlcard expansion in startup code of a typical Windows app. */ const char need_quotes[] = " \t#;\"\'*?[]&|<>(){}$`^"; - size_t cmdlen = 1; /* for terminating null */ + size_t cmdlen = 1; /* for terminating null */ char *cmdline = scm_malloc (cmdlen); char *dst = cmdline; int cmd_exe_quoting = 0; @@ -476,12 +476,12 @@ prepare_cmdline (const char *cmd, const char * const *argv, int bin_sh_replaced) else { for (p = cmd + strlen (cmd); - p > cmd && p[-1] != '/' && p[-1] != '\\' && p[-1] != ':'; - p--) - ; + p > cmd && p[-1] != '/' && p[-1] != '\\' && p[-1] != ':'; + p--) + ; if (c_strcasecmp (p, "cmd.exe") == 0 - || c_strcasecmp (p, "cmd") == 0) - cmd_exe_quoting = 1; + || c_strcasecmp (p, "cmd") == 0) + cmd_exe_quoting = 1; } /* Initialize the command line to empty. */ @@ -496,95 +496,95 @@ prepare_cmdline (const char *cmd, const char * const *argv, int bin_sh_replaced) int j; /* Append the blank separator. We don't do that for argv[0] - because that is the command name (will end up in child's - argv[0]), and is only recognized as such if there're no - blanks before it. */ + because that is the command name (will end up in child's + argv[0]), and is only recognized as such if there're no + blanks before it. */ if (i > 0) - *dst++ = ' '; + *dst++ = ' '; len = dst - cmdline; /* How much space is required for this argument? */ cmdlen += strlen (argv[i]) + 1; /* 1 for a blank separator */ /* cmd.exe needs a different style of quoting: all the arguments - beyond the /c switch are enclosed in an extra pair of quotes, - and not otherwise quoted/escaped. */ + beyond the /c switch are enclosed in an extra pair of quotes, + and not otherwise quoted/escaped. */ if (cmd_exe_quoting) - { - if (i == 2) - cmdlen += 2; - } + { + if (i == 2) + cmdlen += 2; + } else if (strpbrk (argv[i], need_quotes)) - { - quote_this = 1; - cmdlen += 2; - for ( ; *src; src++) - { - /* An embedded quote needs to be escaped by a backslash. - Any backslashes immediately preceding that quote need - each one to be escaped by another backslash. */ - if (*src == '\"') - cmdlen += n_backslashes + 1; - if (*src == '\\') - n_backslashes++; - else - n_backslashes = 0; - } - /* If the closing quote we will add is preceded by - backslashes, those backslashes need to be escaped. */ - cmdlen += n_backslashes; - } + { + quote_this = 1; + cmdlen += 2; + for ( ; *src; src++) + { + /* An embedded quote needs to be escaped by a backslash. + Any backslashes immediately preceding that quote need + each one to be escaped by another backslash. */ + if (*src == '\"') + cmdlen += n_backslashes + 1; + if (*src == '\\') + n_backslashes++; + else + n_backslashes = 0; + } + /* If the closing quote we will add is preceded by + backslashes, those backslashes need to be escaped. */ + cmdlen += n_backslashes; + } /* Enlarge the command-line string as needed. */ cmdline = scm_realloc (cmdline, cmdlen); dst = cmdline + len; if (i == 0 - && c_strcasecmp (argv[0], "/bin/sh") == 0 - && bin_sh_replaced) - { - strcpy (dst, "cmd.exe"); - dst += sizeof ("cmd.exe") - 1; - continue; - } + && c_strcasecmp (argv[0], "/bin/sh") == 0 + && bin_sh_replaced) + { + strcpy (dst, "cmd.exe"); + dst += sizeof ("cmd.exe") - 1; + continue; + } if (i == 1 && bin_sh_replaced && strcmp (argv[1], "-c") == 0) - { - *dst++ = '/'; - *dst++ = 'c'; - *dst = '\0'; - continue; - } + { + *dst++ = '/'; + *dst++ = 'c'; + *dst = '\0'; + continue; + } /* Add this argument, possibly quoted, to the command line. */ if (quote_this || (i == 2 && cmd_exe_quoting)) - *dst++ = '\"'; + *dst++ = '\"'; for (src = argv[i]; *src; src++) - { - if (quote_this) - { - if (*src == '\"') - for (j = n_backslashes + 1; j > 0; j--) - *dst++ = '\\'; - if (*src == '\\') - n_backslashes++; - else - n_backslashes = 0; - } - *dst++ = *src; - } + { + if (quote_this) + { + if (*src == '\"') + for (j = n_backslashes + 1; j > 0; j--) + *dst++ = '\\'; + if (*src == '\\') + n_backslashes++; + else + n_backslashes = 0; + } + *dst++ = *src; + } if (quote_this) - { - for (j = n_backslashes; j > 0; j--) - *dst++ = '\\'; - *dst++ = '\"'; - } + { + for (j = n_backslashes; j > 0; j--) + *dst++ = '\\'; + *dst++ = '\"'; + } *dst = '\0'; } if (cmd_exe_quoting && i > 2) { /* One extra slot was already reserved when we enlarged cmdlen - by 2 in the "if (cmd_exe_quoting)" clause above. So we can - safely append a closing quote. */ + by 2 in the "if (cmd_exe_quoting)" clause above. So we can + safely append a closing quote. */ *dst++ = '\"'; *dst = '\0'; } @@ -604,7 +604,7 @@ prepare_cmdline (const char *cmd, const char * const *argv, int bin_sh_replaced) process. */ pid_t start_child (const char *exec_file, char **argv, - int reading, int c2p[2], int writing, int p2c[2], + int reading, int c2p[2], int writing, int p2c[2], int infd, int outfd, int errfd) { HANDLE hin = INVALID_HANDLE_VALUE, hout = INVALID_HANDLE_VALUE; @@ -642,15 +642,15 @@ start_child (const char *exec_file, char **argv, duplicated). */ if (writing) SetHandleInformation ((HANDLE)_get_osfhandle (p2c[1]), - HANDLE_FLAG_INHERIT, 0); + HANDLE_FLAG_INHERIT, 0); if (reading) { SetHandleInformation ((HANDLE)_get_osfhandle (c2p[0]), - HANDLE_FLAG_INHERIT, 0); + HANDLE_FLAG_INHERIT, 0); /* Gnulib's 'pipe' opens the pipe in binary mode, but we don't - want to read text-mode input of subprocesses in binary more, - because then we will get the ^M (a.k.a. "CR") characters we - don't expect. */ + want to read text-mode input of subprocesses in binary more, + because then we will get the ^M (a.k.a. "CR") characters we + don't expect. */ _setmode (c2p[0], _O_TEXT); } @@ -681,45 +681,45 @@ start_child (const char *exec_file, char **argv, /* Construct the command line. */ cmdline = prepare_cmdline (exec_file, (const char * const *)argv, - bin_sh_replaced); + bin_sh_replaced); /* All set and ready to fly. Launch the child process. */ if (!CreateProcess (progfile, cmdline, NULL, NULL, TRUE, 0, env_block, NULL, - &si, &pi)) + &si, &pi)) { pid = -1; /* Since we use Win32 APIs directly, we need to translate their - errors to errno values by hand. */ + errors to errno values by hand. */ switch (GetLastError ()) - { - case ERROR_FILE_NOT_FOUND: - case ERROR_PATH_NOT_FOUND: - case ERROR_INVALID_DRIVE: - case ERROR_BAD_PATHNAME: - errno = ENOENT; - break; - case ERROR_ACCESS_DENIED: - errno = EACCES; - break; - case ERROR_BAD_ENVIRONMENT: - errno = E2BIG; - break; - case ERROR_BROKEN_PIPE: - errno = EPIPE; - break; - case ERROR_INVALID_HANDLE: - errno = EBADF; - break; - case ERROR_MAX_THRDS_REACHED: - errno = EAGAIN; - break; - case ERROR_BAD_EXE_FORMAT: - case ERROR_BAD_FORMAT: - default: - errno = ENOEXEC; - break; - } + { + case ERROR_FILE_NOT_FOUND: + case ERROR_PATH_NOT_FOUND: + case ERROR_INVALID_DRIVE: + case ERROR_BAD_PATHNAME: + errno = ENOENT; + break; + case ERROR_ACCESS_DENIED: + errno = EACCES; + break; + case ERROR_BAD_ENVIRONMENT: + errno = E2BIG; + break; + case ERROR_BROKEN_PIPE: + errno = EPIPE; + break; + case ERROR_INVALID_HANDLE: + errno = EBADF; + break; + case ERROR_MAX_THRDS_REACHED: + errno = EAGAIN; + break; + case ERROR_BAD_EXE_FORMAT: + case ERROR_BAD_FORMAT: + default: + errno = ENOEXEC; + break; + } } else { @@ -746,14 +746,14 @@ start_child (const char *exec_file, char **argv, const char *shell = getenv ("ComSpec"); if (!shell) - shell = "cmd.exe"; + shell = "cmd.exe"; if (c_strcasecmp (exec_file, shell) != 0) - { - argv[0] = (char *)exec_file; - return start_child (shell, argv, reading, c2p, writing, p2c, - infd, outfd, errfd); - } + { + argv[0] = (char *)exec_file; + return start_child (shell, argv, reading, c2p, writing, p2c, + infd, outfd, errfd); + } } errno = errno_save; @@ -790,14 +790,14 @@ waitpid (pid_t pid, int *status, int options) DWORD st; if (!GetExitCodeProcess (ph, &st)) - { - errno = ECHILD; - return -1; - } + { + errno = ECHILD; + return -1; + } if (st == STILL_ACTIVE) - return 0; + return 0; if (status) - *status = st; + *status = st; CloseHandle (ph); } else @@ -821,23 +821,23 @@ struct signal_and_status { }; static const struct signal_and_status sigtbl[] = { - {SIGSEGV, 0xC0000005}, /* access to invalid address */ - {SIGSEGV, 0xC0000008}, /* invalid handle */ - {SIGILL, 0xC000001D}, /* illegal instruction */ - {SIGILL, 0xC0000025}, /* non-continuable instruction */ - {SIGSEGV, 0xC000008C}, /* array bounds exceeded */ - {SIGFPE, 0xC000008D}, /* float denormal */ - {SIGFPE, 0xC000008E}, /* float divide by zero */ - {SIGFPE, 0xC000008F}, /* float inexact */ - {SIGFPE, 0xC0000090}, /* float invalid operation */ - {SIGFPE, 0xC0000091}, /* float overflow */ - {SIGFPE, 0xC0000092}, /* float stack check */ - {SIGFPE, 0xC0000093}, /* float underflow */ - {SIGFPE, 0xC0000094}, /* integer divide by zero */ - {SIGFPE, 0xC0000095}, /* integer overflow */ - {SIGILL, 0xC0000096}, /* privileged instruction */ - {SIGSEGV, 0xC00000FD}, /* stack overflow */ - {SIGTERM, 0xC000013A}, /* Ctrl-C exit */ + {SIGSEGV, 0xC0000005}, /* access to invalid address */ + {SIGSEGV, 0xC0000008}, /* invalid handle */ + {SIGILL, 0xC000001D}, /* illegal instruction */ + {SIGILL, 0xC0000025}, /* non-continuable instruction */ + {SIGSEGV, 0xC000008C}, /* array bounds exceeded */ + {SIGFPE, 0xC000008D}, /* float denormal */ + {SIGFPE, 0xC000008E}, /* float divide by zero */ + {SIGFPE, 0xC000008F}, /* float inexact */ + {SIGFPE, 0xC0000090}, /* float invalid operation */ + {SIGFPE, 0xC0000091}, /* float overflow */ + {SIGFPE, 0xC0000092}, /* float stack check */ + {SIGFPE, 0xC0000093}, /* float underflow */ + {SIGFPE, 0xC0000094}, /* integer divide by zero */ + {SIGFPE, 0xC0000095}, /* integer overflow */ + {SIGILL, 0xC0000096}, /* privileged instruction */ + {SIGSEGV, 0xC00000FD}, /* stack overflow */ + {SIGTERM, 0xC000013A}, /* Ctrl-C exit */ {SIGINT, 0xC000013A} }; @@ -875,7 +875,7 @@ kill (int pid, int sig) if (pid == getpid ()) { if (raise (sig) == 0) - errno = ENOSYS; + errno = ENOSYS; return -1; } @@ -896,13 +896,13 @@ kill (int pid, int sig) if (!TerminateProcess (ph, w32_signal_to_status (sig))) { /* If it's our subprocess, it could have already exited. In - that case, waitpid will handily delete the process from our - records, and we should return a more meaningful ESRCH to the - caller. */ + that case, waitpid will handily delete the process from our + records, and we should return a more meaningful ESRCH to the + caller. */ if (child_proc && waitpid (pid, NULL, WNOHANG) == pid) - errno = ESRCH; + errno = ESRCH; else - errno = EINVAL; + errno = EINVAL; return -1; } CloseHandle (ph); @@ -942,11 +942,11 @@ getpriority (int which, int who) hp = proc_handle (who); scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); /* If not found among our subprocesses, look elsewhere in the - system. */ + system. */ if (hp == INVALID_HANDLE_VALUE) - hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, who); + hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, who); else - child_proc = 1; + child_proc = 1; } if (hp) @@ -954,70 +954,70 @@ getpriority (int which, int who) DWORD pri_class = GetPriorityClass (hp); /* The pseudo-handle returned by GetCurrentProcess doesn't need - to be closed. */ + to be closed. */ if (who > 0 && !child_proc) - CloseHandle (hp); + CloseHandle (hp); if (pri_class > 0) - { - switch (pri_class) - { - case IDLE_PRIORITY_CLASS: - nice_value = 4; - break; - case BELOW_NORMAL_PRIORITY_CLASS: - nice_value = 6; - break; - case NORMAL_PRIORITY_CLASS: - nice_value = 8; - break; - case ABOVE_NORMAL_PRIORITY_CLASS: - nice_value = 10; - break; - case HIGH_PRIORITY_CLASS: - nice_value = 13; - break; - case REALTIME_PRIORITY_CLASS: - nice_value = 24; - break; - } - /* If WHO is us, we can provide a more fine-grained value by - looking at the current thread's priority value. (For - other processes, it is not clear which thread to use.) */ - if (who == 0 || who == GetCurrentProcessId ()) - { - HANDLE ht = GetCurrentThread (); - int tprio = GetThreadPriority (ht); + { + switch (pri_class) + { + case IDLE_PRIORITY_CLASS: + nice_value = 4; + break; + case BELOW_NORMAL_PRIORITY_CLASS: + nice_value = 6; + break; + case NORMAL_PRIORITY_CLASS: + nice_value = 8; + break; + case ABOVE_NORMAL_PRIORITY_CLASS: + nice_value = 10; + break; + case HIGH_PRIORITY_CLASS: + nice_value = 13; + break; + case REALTIME_PRIORITY_CLASS: + nice_value = 24; + break; + } + /* If WHO is us, we can provide a more fine-grained value by + looking at the current thread's priority value. (For + other processes, it is not clear which thread to use.) */ + if (who == 0 || who == GetCurrentProcessId ()) + { + HANDLE ht = GetCurrentThread (); + int tprio = GetThreadPriority (ht); - switch (tprio) - { - case THREAD_PRIORITY_IDLE: - if (pri_class == REALTIME_PRIORITY_CLASS) - nice_value = 16; - else - nice_value = 1; - break; - case THREAD_PRIORITY_TIME_CRITICAL: - if (pri_class == REALTIME_PRIORITY_CLASS) - nice_value = 31; - else - nice_value = 15; - case THREAD_PRIORITY_ERROR_RETURN: - nice_value = -1; - error = 1; - break; - default: - nice_value += tprio; - break; - } - } - /* Map to "nice values" similar to what one would see on - Posix platforms. */ - if (!error) - nice_value = - (nice_value - NZERO); - } + switch (tprio) + { + case THREAD_PRIORITY_IDLE: + if (pri_class == REALTIME_PRIORITY_CLASS) + nice_value = 16; + else + nice_value = 1; + break; + case THREAD_PRIORITY_TIME_CRITICAL: + if (pri_class == REALTIME_PRIORITY_CLASS) + nice_value = 31; + else + nice_value = 15; + case THREAD_PRIORITY_ERROR_RETURN: + nice_value = -1; + error = 1; + break; + default: + nice_value += tprio; + break; + } + } + /* Map to "nice values" similar to what one would see on + Posix platforms. */ + if (!error) + nice_value = - (nice_value - NZERO); + } else - error = 1; + error = 1; } else error = 1; @@ -1027,15 +1027,15 @@ getpriority (int which, int who) DWORD err = GetLastError (); switch (err) - { - case ERROR_INVALID_PARAMETER: - case ERROR_INVALID_THREAD_ID: - errno = ESRCH; - break; - default: - errno = EPERM; - break; - } + { + case ERROR_INVALID_PARAMETER: + case ERROR_INVALID_THREAD_ID: + errno = ESRCH; + break; + default: + errno = EPERM; + break; + } } return nice_value; @@ -1062,11 +1062,11 @@ setpriority (int which, int who, int nice_val) hp = proc_handle (who); scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); /* If not found among our subprocesses, look elsewhere in the - system. */ + system. */ if (hp == INVALID_HANDLE_VALUE) - hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, who); + hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, who); else - child_proc = 1; + child_proc = 1; } if (hp) @@ -1076,20 +1076,20 @@ setpriority (int which, int who, int nice_val) /* Map "nice values" back to process priority classes. */ nice_val = -nice_val + NZERO; if (nice_val < 6) - pri_class = IDLE_PRIORITY_CLASS; + pri_class = IDLE_PRIORITY_CLASS; else if (nice_val < 8) - pri_class = BELOW_NORMAL_PRIORITY_CLASS; + pri_class = BELOW_NORMAL_PRIORITY_CLASS; else if (nice_val < 10) - pri_class = NORMAL_PRIORITY_CLASS; + pri_class = NORMAL_PRIORITY_CLASS; else if (nice_val < 13) - pri_class = ABOVE_NORMAL_PRIORITY_CLASS; + pri_class = ABOVE_NORMAL_PRIORITY_CLASS; else if (nice_val < 16) - pri_class = HIGH_PRIORITY_CLASS; + pri_class = HIGH_PRIORITY_CLASS; else - pri_class = REALTIME_PRIORITY_CLASS; + pri_class = REALTIME_PRIORITY_CLASS; if (SetPriorityClass (hp, pri_class)) - retval = 0; + retval = 0; } err = GetLastError (); @@ -1133,11 +1133,11 @@ sched_getaffinity (int pid, size_t mask_size, cpu_set_t *mask) hp = proc_handle (pid); scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); /* If not found among our subprocesses, look elsewhere in the - system. */ + system. */ if (hp == INVALID_HANDLE_VALUE) - hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, pid); + hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, pid); else - child_proc = 1; + child_proc = 1; } if (hp) @@ -1146,11 +1146,11 @@ sched_getaffinity (int pid, size_t mask_size, cpu_set_t *mask) BOOL result = GetProcessAffinityMask (hp, (DWORD_PTR *)mask, &ignored); /* The pseudo-handle returned by GetCurrentProcess doesn't - need to be closed. */ + need to be closed. */ if (pid > 0 && !child_proc) - CloseHandle (hp); + CloseHandle (hp); if (result) - return 0; + return 0; } err = GetLastError (); @@ -1190,11 +1190,11 @@ sched_setaffinity (int pid, size_t mask_size, cpu_set_t *mask) hp = proc_handle (pid); scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); /* If not found among our subprocesses, look elsewhere in the - system. */ + system. */ if (hp == INVALID_HANDLE_VALUE) - hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, pid); + hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, pid); else - child_proc = 1; + child_proc = 1; } if (hp) @@ -1202,11 +1202,11 @@ sched_setaffinity (int pid, size_t mask_size, cpu_set_t *mask) BOOL result = SetProcessAffinityMask (hp, *(DWORD_PTR *)mask); /* The pseudo-handle returned by GetCurrentProcess doesn't - need to be closed. */ + need to be closed. */ if (pid > 0 && !child_proc) - CloseHandle (hp); + CloseHandle (hp); if (result) - return 0; + return 0; } err = GetLastError (); From ad7e806a9fdc81062be966614f03f089eac469a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 22 Jul 2016 16:39:12 +0200 Subject: [PATCH 469/865] doc: Add unquote and unquote-splicing examples. Suggested by Vincent Legoll . * doc/ref/api-evaluation.texi (Expression Syntax): Add an unquote and an unquote-splicing example. --- doc/ref/api-evaluation.texi | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index 296f1da5a..3a3e9e632 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -136,6 +136,7 @@ an expression to be evaluated and inserted. The comma syntax @code{,} is simply a shorthand for an @code{unquote} form. For example, @example +`(1 2 (* 9 9) 3 4) @result{} (1 2 (* 9 9) 3 4) `(1 2 ,(* 9 9) 3 4) @result{} (1 2 81 3 4) `(1 (unquote (+ 1 1)) 3) @result{} (1 2 3) `#(1 ,(/ 12 2)) @result{} #(1 6) @@ -153,8 +154,9 @@ the returned list inserted. @var{expr} must evaluate to a list. The @example (define x '(2 3)) +`(1 ,x 4) @result{} (1 (2 3) 4) `(1 ,@@x 4) @result{} (1 2 3 4) -`(1 (unquote-splicing (map 1+ x))) @result{} (1 3 4) +`(1 (unquote-splicing (map 1+ x))) @result{} (1 3 4) `#(9 ,@@x 9) @result{} #(9 2 3 9) @end example From 8868c850e6caef23ab06597ef2e133064b62d683 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 16 Jul 2016 15:59:35 +0200 Subject: [PATCH 470/865] Gnulib: Add dirname-lgpl. * lib/Makefile.am: * m4/gnulib-cache.m4: * m4/gnulib-comp.m4: Add dirname-lgpl. --- lib/Makefile.am | 6 +----- m4/gnulib-cache.m4 | 3 ++- m4/gnulib-comp.m4 | 45 ++------------------------------------------- 3 files changed, 5 insertions(+), 49 deletions(-) diff --git a/lib/Makefile.am b/lib/Makefile.am index b9749062b..666dc0052 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -21,7 +21,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --avoid=unistr/base --avoid=unistr/u8-mbtouc --avoid=unistr/u8-mbtouc-unsafe --avoid=unistr/u8-mbtoucr --avoid=unistr/u8-prev --avoid=unistr/u8-uctomb --avoid=unitypes --lgpl=3 --conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkostemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar +# Reproduce by: gnulib-tool --import --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --avoid=unistr/base --avoid=unistr/u8-mbtouc --avoid=unistr/u8-mbtouc-unsafe --avoid=unistr/u8-mbtoucr --avoid=unistr/u8-prev --avoid=unistr/u8-uctomb --avoid=unitypes --lgpl=3 --conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd dirname-lgpl duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkostemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar AUTOMAKE_OPTIONS = 1.9.6 gnits @@ -404,19 +404,15 @@ EXTRA_libgnu_la_SOURCES += dirfd.c ## begin gnulib module dirname-lgpl -if gl_GNULIB_ENABLED_a691da99c1d83b83238e45f41a696f5c libgnu_la_SOURCES += dirname-lgpl.c basename-lgpl.c stripslash.c -endif EXTRA_DIST += dirname.h ## end gnulib module dirname-lgpl ## begin gnulib module dosname -if gl_GNULIB_ENABLED_dosname -endif EXTRA_DIST += dosname.h ## end gnulib module dosname diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index 85ba6b683..f6d36c733 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -27,7 +27,7 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --avoid=unistr/base --avoid=unistr/u8-mbtouc --avoid=unistr/u8-mbtouc-unsafe --avoid=unistr/u8-mbtoucr --avoid=unistr/u8-prev --avoid=unistr/u8-uctomb --avoid=unitypes --lgpl=3 --conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkostemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar +# gnulib-tool --import --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --avoid=unistr/base --avoid=unistr/u8-mbtouc --avoid=unistr/u8-mbtouc-unsafe --avoid=unistr/u8-mbtoucr --avoid=unistr/u8-prev --avoid=unistr/u8-uctomb --avoid=unitypes --lgpl=3 --conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd dirname-lgpl duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkostemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([gnulib-local]) @@ -47,6 +47,7 @@ gl_MODULES([ connect copysign dirfd + dirname-lgpl duplocale environ extensions diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 8834cfc17..9881c1b75 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -310,6 +310,8 @@ AC_DEFUN([gl_INIT], gl_PREREQ_DIRFD fi gl_DIRENT_MODULE_INDICATOR([dirfd]) + gl_DIRNAME_LGPL + gl_DOUBLE_SLASH_ROOT gl_FUNC_DUPLOCALE if test $REPLACE_DUPLOCALE = 1; then AC_LIBOBJ([duplocale]) @@ -705,9 +707,6 @@ AC_DEFUN([gl_INIT], gl_gnulib_enabled_assure=false gl_gnulib_enabled_btowc=false gl_gnulib_enabled_chdir=false - gl_gnulib_enabled_a691da99c1d83b83238e45f41a696f5c=false - gl_gnulib_enabled_dosname=false - gl_gnulib_enabled_36afd6902ac3aacf32e3ff12a686c346=false gl_gnulib_enabled_dup2=false gl_gnulib_enabled_43fe87a341d9b4b93c47c3ad819a5239=false gl_gnulib_enabled_flexmember=false @@ -787,28 +786,6 @@ AC_SUBST([LTALLOCA]) gl_gnulib_enabled_chdir=true fi } - func_gl_gnulib_m4code_a691da99c1d83b83238e45f41a696f5c () - { - if ! $gl_gnulib_enabled_a691da99c1d83b83238e45f41a696f5c; then - gl_DIRNAME_LGPL - gl_gnulib_enabled_a691da99c1d83b83238e45f41a696f5c=true - func_gl_gnulib_m4code_dosname - func_gl_gnulib_m4code_36afd6902ac3aacf32e3ff12a686c346 - fi - } - func_gl_gnulib_m4code_dosname () - { - if ! $gl_gnulib_enabled_dosname; then - gl_gnulib_enabled_dosname=true - fi - } - func_gl_gnulib_m4code_36afd6902ac3aacf32e3ff12a686c346 () - { - if ! $gl_gnulib_enabled_36afd6902ac3aacf32e3ff12a686c346; then - gl_DOUBLE_SLASH_ROOT - gl_gnulib_enabled_36afd6902ac3aacf32e3ff12a686c346=true - fi - } func_gl_gnulib_m4code_dup2 () { if ! $gl_gnulib_enabled_dup2; then @@ -1156,9 +1133,6 @@ AC_SUBST([LTALLOCA]) fi gl_SYS_STAT_MODULE_INDICATOR([stat]) gl_gnulib_enabled_stat=true - if test $REPLACE_STAT = 1; then - func_gl_gnulib_m4code_dosname - fi if test $REPLACE_STAT = 1; then func_gl_gnulib_m4code_pathmax fi @@ -1352,15 +1326,9 @@ AC_SUBST([LTALLOCA]) if test $HAVE_LOG1P = 0 || test $REPLACE_LOG1P = 1; then func_gl_gnulib_m4code_round fi - if test $REPLACE_LSTAT = 1; then - func_gl_gnulib_m4code_dosname - fi if test $REPLACE_LSTAT = 1; then func_gl_gnulib_m4code_stat fi - if test $REPLACE_MKDIR = 1; then - func_gl_gnulib_m4code_a691da99c1d83b83238e45f41a696f5c - fi if test $HAVE_MKOSTEMP = 0; then func_gl_gnulib_m4code_tempname fi @@ -1418,15 +1386,9 @@ AC_SUBST([LTALLOCA]) if test $REPLACE_RENAME = 1; then func_gl_gnulib_m4code_chdir fi - if test $REPLACE_RENAME = 1; then - func_gl_gnulib_m4code_a691da99c1d83b83238e45f41a696f5c - fi if test $REPLACE_RENAME = 1; then func_gl_gnulib_m4code_9bc5f216d57e231e4834049d67d0db62 fi - if test $REPLACE_RMDIR = 1; then - func_gl_gnulib_m4code_dosname - fi if test $REPLACE_SELECT = 1; then func_gl_gnulib_m4code_alloca fi @@ -1486,9 +1448,6 @@ AC_SUBST([LTALLOCA]) AM_CONDITIONAL([gl_GNULIB_ENABLED_assure], [$gl_gnulib_enabled_assure]) AM_CONDITIONAL([gl_GNULIB_ENABLED_btowc], [$gl_gnulib_enabled_btowc]) AM_CONDITIONAL([gl_GNULIB_ENABLED_chdir], [$gl_gnulib_enabled_chdir]) - AM_CONDITIONAL([gl_GNULIB_ENABLED_a691da99c1d83b83238e45f41a696f5c], [$gl_gnulib_enabled_a691da99c1d83b83238e45f41a696f5c]) - AM_CONDITIONAL([gl_GNULIB_ENABLED_dosname], [$gl_gnulib_enabled_dosname]) - AM_CONDITIONAL([gl_GNULIB_ENABLED_36afd6902ac3aacf32e3ff12a686c346], [$gl_gnulib_enabled_36afd6902ac3aacf32e3ff12a686c346]) AM_CONDITIONAL([gl_GNULIB_ENABLED_dup2], [$gl_gnulib_enabled_dup2]) AM_CONDITIONAL([gl_GNULIB_ENABLED_43fe87a341d9b4b93c47c3ad819a5239], [$gl_gnulib_enabled_43fe87a341d9b4b93c47c3ad819a5239]) AM_CONDITIONAL([gl_GNULIB_ENABLED_flexmember], [$gl_gnulib_enabled_flexmember]) From 1f14900a07ce5542060522a032c99dca99e41dee Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 17 Jul 2016 08:02:33 +0200 Subject: [PATCH 471/865] Use gnulib for basename / dirname * libguile/filesys.c (scm_dirname, scm_basename): Rewrite to use gnulib's dirname-lgpl. --- libguile/filesys.c | 86 +++++++++++++++++----------------------------- 1 file changed, 32 insertions(+), 54 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index 879a72df0..c4f2653c2 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -35,6 +35,7 @@ #endif #include +#include #include #include @@ -1546,31 +1547,22 @@ SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0, "component, @code{.} is returned.") #define FUNC_NAME s_scm_dirname { - long int i; - unsigned long int len; + char *c_filename, *c_dirname; + SCM res; - SCM_VALIDATE_STRING (1, filename); + scm_dynwind_begin (0); + c_filename = scm_to_utf8_string (filename); + scm_dynwind_free (c_filename); - len = scm_i_string_length (filename); + c_dirname = mdir_name (c_filename); + if (!c_dirname) + SCM_SYSERROR; + scm_dynwind_free (c_dirname); - i = len - 1; + res = scm_from_utf8_string (c_dirname); + scm_dynwind_end (); - while (i >= 0 && is_file_name_separator (scm_c_string_ref (filename, i))) - --i; - while (i >= 0 && !is_file_name_separator (scm_c_string_ref (filename, i))) - --i; - while (i >= 0 && is_file_name_separator (scm_c_string_ref (filename, i))) - --i; - - if (i < 0) - { - if (len > 0 && is_file_name_separator (scm_c_string_ref (filename, 0))) - return scm_c_substring (filename, 0, 1); - else - return scm_dot_string; - } - else - return scm_c_substring (filename, 0, i + 1); + return res; } #undef FUNC_NAME @@ -1582,42 +1574,28 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0, "@var{filename}, it is removed also.") #define FUNC_NAME s_scm_basename { - int i, j, len, end; + char *c_filename, *c_last_component; + SCM res; - SCM_VALIDATE_STRING (1, filename); - len = scm_i_string_length (filename); + scm_dynwind_begin (0); + c_filename = scm_to_utf8_string (filename); + scm_dynwind_free (c_filename); - if (SCM_UNBNDP (suffix)) - j = -1; + c_last_component = last_component (c_filename); + if (!c_last_component) + res = filename; else - { - SCM_VALIDATE_STRING (2, suffix); - j = scm_i_string_length (suffix) - 1; - } - i = len - 1; - while (i >= 0 && is_file_name_separator (scm_c_string_ref (filename, i))) - --i; - end = i; - while (i >= 0 && j >= 0 - && (scm_i_string_ref (filename, i) - == scm_i_string_ref (suffix, j))) - { - --i; - --j; - } - if (j == -1) - end = i; - while (i >= 0 && !is_file_name_separator (scm_c_string_ref (filename, i))) - --i; - if (i == end) - { - if (len > 0 && is_file_name_separator (scm_c_string_ref (filename, 0))) - return scm_c_substring (filename, 0, 1); - else - return scm_dot_string; - } - else - return scm_c_substring (filename, i+1, end+1); + res = scm_from_utf8_string (c_last_component); + scm_dynwind_end (); + + if (!SCM_UNBNDP (suffix) && + scm_is_true (scm_string_suffix_p (suffix, filename, + SCM_UNDEFINED, SCM_UNDEFINED, + SCM_UNDEFINED, SCM_UNDEFINED))) + res = scm_c_substring + (res, 0, scm_c_string_length (res) - scm_c_string_length (suffix)); + + return res; } #undef FUNC_NAME From 315acd5ee0bb9ac942d1ca27c2485c8333582ff7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 23 Jul 2016 14:07:11 +0200 Subject: [PATCH 472/865] Use non-deprecated HAVE_STRUCT_TM_TM_ZONE * libguile/stime.c: Change uses of the deprecated HAVE_TM_ZONE to the new HAVE_STRUCT_TM_TM_ZONE. --- libguile/stime.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/libguile/stime.c b/libguile/stime.c index d8c825106..ec319eec0 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -408,7 +408,7 @@ SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0, const char *ptr; /* copy zone name before calling gmtime or restoring zone. */ -#if defined (HAVE_TM_ZONE) +#if defined (HAVE_STRUCT_TM_TM_ZONE) ptr = ltptr->tm_zone; #elif defined (HAVE_TZNAME) ptr = tzname[ (ltptr->tm_isdst == 1) ? 1 : 0 ]; @@ -517,7 +517,7 @@ bdtime2c (SCM sbd_time, struct tm *lt, int pos, const char *subr) #if HAVE_STRUCT_TM_TM_GMTOFF lt->tm_gmtoff = - scm_to_int (SCM_SIMPLE_VECTOR_REF (sbd_time, 9)); #endif -#ifdef HAVE_TM_ZONE +#ifdef HAVE_STRUCT_TM_TM_ZONE if (scm_is_false (SCM_SIMPLE_VECTOR_REF (sbd_time, 10))) lt->tm_zone = NULL; else @@ -568,7 +568,7 @@ SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0, const char *ptr; /* copy zone name before calling gmtime or restoring the zone. */ -#if defined (HAVE_TM_ZONE) +#if defined (HAVE_STRUCT_TM_TM_ZONE) ptr = lt.tm_zone; #elif defined (HAVE_TZNAME) ptr = tzname[ (lt.tm_isdst == 1) ? 1 : 0 ]; @@ -678,7 +678,7 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, tbuf = scm_malloc (size); { -#if !defined (HAVE_TM_ZONE) +#if !defined (HAVE_STRUCT_TM_TM_ZONE) /* it seems the only way to tell non-GNU versions of strftime what zone to use (for the %Z format) is to set TZ in the environment. interrupts and thread switching must be deferred @@ -716,7 +716,7 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, tbuf = scm_malloc (size); } -#if !defined (HAVE_TM_ZONE) +#if !defined (HAVE_STRUCT_TM_TM_ZONE) if (have_zone) { restorezone (zone_spec, oldenv, FUNC_NAME); From ca2d00ad65e1e3db0a88f7964c5b0ab49b9471e9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 24 Jul 2016 13:16:45 +0200 Subject: [PATCH 473/865] Reimplement null-threads as inline functions * libguile/null-threads.h: Reimplement null-threads stubs for pthread data types, initializers, and functions in terms of types and inline functions instead of CPP macros. Fixes unused-value warnings, and tightens things up in general. (scm_i_pthread_cleanup_push, scm_i_pthread_cleanup_pop): Remove these, as they were unused and incorrect -- they would never run the cleanup handler even if 1 was passed to pop. --- libguile/null-threads.h | 179 +++++++++++++++++++++++++++++++++------- 1 file changed, 149 insertions(+), 30 deletions(-) diff --git a/libguile/null-threads.h b/libguile/null-threads.h index 116b845a5..dcb14e6a7 100644 --- a/libguile/null-threads.h +++ b/libguile/null-threads.h @@ -34,53 +34,172 @@ */ #include +#include #include /* Threads */ -#define scm_i_pthread_t int -#define scm_i_pthread_self() 0 -#define scm_i_pthread_create(t,a,f,d) (*(t)=0, (void)(f), ENOSYS) -#define scm_i_pthread_detach(t) do { } while (0) -#define scm_i_pthread_exit(v) exit (EXIT_SUCCESS) -#define scm_i_pthread_cancel(t) 0 -#define scm_i_pthread_cleanup_push(t,v) 0 -#define scm_i_pthread_cleanup_pop(e) 0 -#define scm_i_sched_yield() 0 +typedef int scm_i_pthread_t; +typedef void scm_i_pthread_attr_t; + +static inline scm_i_pthread_t +scm_i_pthread_self (void) +{ + return 0; +} + +static inline int +scm_i_pthread_create (scm_i_pthread_t *t, const scm_i_pthread_attr_t *attr, + void* (*f) (void*), void *arg) +{ + return ENOSYS; +} + +static inline int +scm_i_pthread_detach (scm_i_pthread_t t) +{ + return 0; +} + +static inline void +scm_i_pthread_exit (void *retval) +{ + exit (EXIT_SUCCESS); +} + +static inline int +scm_i_pthread_cancel (scm_i_pthread_t t) +{ + return 0; +} + +static inline int +scm_i_sched_yield (void) +{ + return 0; +} + /* Signals */ -#define scm_i_pthread_sigmask sigprocmask +static inline int +scm_i_pthread_sigmask (int how, const sigset_t *set, sigset_t *oldset) +{ + return sigprocmask (how, set, oldset); +} /* Mutexes */ -#define SCM_I_PTHREAD_MUTEX_INITIALIZER 0 -#define scm_i_pthread_mutex_t int -#define scm_i_pthread_mutex_init(m,a) (*(m) = 0) -#define scm_i_pthread_mutex_destroy(m) do { (void)(m); } while(0) -#define scm_i_pthread_mutex_trylock(m) ((*(m))++) -#define scm_i_pthread_mutex_lock(m) ((*(m))++) -#define scm_i_pthread_mutex_unlock(m) ((*(m))--) +typedef enum { + SCM_I_PTHREAD_MUTEX_INITIALIZER = 0, + SCM_I_PTHREAD_MUTEX_LOCKED = 1 +} scm_i_pthread_mutex_t; +typedef int scm_i_pthread_mutexattr_t; + +static inline int +scm_i_pthread_mutex_init (scm_i_pthread_mutex_t *m, + scm_i_pthread_mutexattr_t *attr) +{ + *m = SCM_I_PTHREAD_MUTEX_INITIALIZER; + return 0; +} + +static inline int +scm_i_pthread_mutex_destroy (scm_i_pthread_mutex_t *m) +{ + return 0; +} + +static inline int +scm_i_pthread_mutex_trylock(scm_i_pthread_mutex_t *m) +{ + if (*m == SCM_I_PTHREAD_MUTEX_LOCKED) + return EDEADLK; + *m = SCM_I_PTHREAD_MUTEX_LOCKED; + return 0; +} + +static inline int +scm_i_pthread_mutex_lock (scm_i_pthread_mutex_t *m) +{ + *m = SCM_I_PTHREAD_MUTEX_LOCKED; + return 0; +} + +static inline int +scm_i_pthread_mutex_unlock (scm_i_pthread_mutex_t *m) +{ + *m = SCM_I_PTHREAD_MUTEX_INITIALIZER; + return 0; +} + #define scm_i_pthread_mutexattr_recursive 0 /* Condition variables */ -#define SCM_I_PTHREAD_COND_INITIALIZER 0 -#define scm_i_pthread_cond_t int -#define scm_i_pthread_cond_init(c,a) (*(c) = 0) -#define scm_i_pthread_cond_destroy(c) do { (void)(c); } while(0) -#define scm_i_pthread_cond_signal(c) (*(c) = 1) -#define scm_i_pthread_cond_broadcast(c) (*(c) = 1) -#define scm_i_pthread_cond_wait(c,m) (abort(), 0) -#define scm_i_pthread_cond_timedwait(c,m,t) (abort(), 0) +typedef enum { + SCM_I_PTHREAD_COND_INITIALIZER = 0 +} scm_i_pthread_cond_t; +typedef int scm_i_pthread_condattr_t; + +static inline int +scm_i_pthread_cond_init (scm_i_pthread_cond_t *c, + scm_i_pthread_condattr_t *attr) +{ + *c = SCM_I_PTHREAD_COND_INITIALIZER; + return 0; +} + +static inline int +scm_i_pthread_cond_destroy (scm_i_pthread_cond_t *c) +{ + return 0; +} + +static inline int +scm_i_pthread_cond_signal (scm_i_pthread_cond_t *c) +{ + return 0; +} + +static inline int +scm_i_pthread_cond_broadcast (scm_i_pthread_cond_t *c) +{ + return 0; +} + +static inline int +scm_i_pthread_cond_wait (scm_i_pthread_cond_t *c, scm_i_pthread_mutex_t *m) +{ + abort (); + return 0; +} + +static inline int +scm_i_pthread_cond_timedwait (scm_i_pthread_cond_t *c, scm_i_pthread_mutex_t *m, + const scm_t_timespec *t) +{ + abort(); + return 0; +} /* Onces */ -#define scm_i_pthread_once_t int -#define SCM_I_PTHREAD_ONCE_INIT 0 -#define scm_i_pthread_once(o,f) do { \ - if(!*(o)) { *(o)=1; f (); } \ - } while(0) +typedef enum { + SCM_I_PTHREAD_ONCE_INIT = 0, + SCM_I_PTHREAD_ONCE_ALREADY = 1 +} scm_i_pthread_once_t; + +static inline int +scm_i_pthread_once (scm_i_pthread_once_t *o, void(*init)(void)) +{ + if (*o == SCM_I_PTHREAD_ONCE_INIT) + { + *o = SCM_I_PTHREAD_ONCE_ALREADY; + init (); + } + return 0; +} /* Thread specific storage */ From 401214313b03803d754ed8836a6cb50ba456b2cb Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 24 Jul 2016 15:29:48 +0200 Subject: [PATCH 474/865] Fix --without-threads against threaded BDW-GC * libguile/gc.c (scm_storage_prehistory): Prevent BDW-GC from spawning marker threads if Guile was built without threading support. --- libguile/gc.c | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/libguile/gc.c b/libguile/gc.c index 13823c054..b75a688aa 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, - * 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. + * 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2016 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 License @@ -608,6 +608,12 @@ scm_storage_prehistory () setenv ("GC_MARKERS", "1", 1); #endif +#if SCM_I_GSC_USE_NULL_THREADS + /* If we have disabled threads in Guile, ensure that the GC doesn't + spawn any marker threads. */ + setenv ("GC_MARKERS", "1", 1); +#endif + GC_INIT (); GC_expand_hp (DEFAULT_INITIAL_HEAP_SIZE); From d2684fe8981146f63877343772628d14b931980a Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sun, 24 Jul 2016 18:13:29 +0300 Subject: [PATCH 475/865] Avoid compilation warnings about alloca in read.c * libguile/read.c: Include alloca.h. --- libguile/read.c | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/read.c b/libguile/read.c index c724fbbc8..f8205fbeb 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -31,6 +31,7 @@ #include #include #include +#include #include "libguile/_scm.h" #include "libguile/bytevectors.h" From 8da33d972a795e0bb1c0e3ed5735d9bf42756950 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 4 Aug 2016 21:35:30 +0200 Subject: [PATCH 476/865] Fix compilation of `continue' in `while'. * module/language/cps/rotate-loops.scm (rotate-loops-in-function): Don't attempt to rotate a loop whose header is a $prompt. Fixes use of `continue' in `while'. Thanks to Nala Ginrut for the report :) --- module/language/cps/rotate-loops.scm | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/module/language/cps/rotate-loops.scm b/module/language/cps/rotate-loops.scm index 0fab94f1d..09c133227 100644 --- a/module/language/cps/rotate-loops.scm +++ b/module/language/cps/rotate-loops.scm @@ -215,12 +215,16 @@ (if (and (can-rotate? back-edges) (trivial-intset (intset-subtract (intmap-ref succs entry) scc)) - (trivial-intset (loop-successors scc succs))) + (trivial-intset (loop-successors scc succs)) + (match (intmap-ref cps entry) + ;; Can't rotate $prompt out of loop header. + (($ $kargs _ _ ($ $continue _ _ ($ $prompt))) #f) + (_ #t))) ;; Loop header is an exit, and there is only one - ;; exit continuation. Loop header must then be a - ;; conditional branch and only one successor is an - ;; exit. The values flowing out of the loop are the - ;; loop variables. + ;; exit continuation. Loop header isn't a prompt, + ;; so it must be a conditional branch and only one + ;; successor is an exit. The values flowing out of + ;; the loop are the loop variables. (rotate-loop cps entry scc succs preds back-edges) cps)))) (else cps))) From 1a1c3bbe597f3682066266ce44bf9bbed2481ad2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 4 Aug 2016 22:29:51 +0200 Subject: [PATCH 477/865] Implement R6RS custom binary input/output ports * NEWS: Add new feature. * doc/ref/r6rs.texi (rnrs io ports): * doc/ref/api-io.texi (Custom Ports): Document new procedure. * libguile/r6rs-ports.h: * libguile/r6rs-ports.c (make_custom_binary_input_output_port) (scm_make_custom_binary_input_output_port) (custom_binary_input_output_port_random_access_p) (initialize_custom_binary_input_output_ports) (scm_init_r6rs_ports): Implement custom binary input/output ports. * module/rnrs/io/ports.scm (rnrs): * module/ice-9/binary-ports.scm (ice-9): Export make-custom-binary-input/output-port. --- NEWS | 1 + doc/ref/api-io.texi | 12 +++++ doc/ref/r6rs.texi | 1 + libguile/r6rs-ports.c | 86 +++++++++++++++++++++++++++++++++++ libguile/r6rs-ports.h | 2 + module/ice-9/binary-ports.scm | 3 +- module/rnrs/io/ports.scm | 1 + 7 files changed, 105 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 5286a437c..75e09883c 100644 --- a/NEWS +++ b/NEWS @@ -12,6 +12,7 @@ Changes in 2.1.4 (changes since the 2.1.3 alpha release): * New interfaces ** Implement R6RS output-buffer-mode +** Implement R6RS custom binary input/output ports ** Implement R6RS bytevector->string, string->bytevector * New deprecations diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 23620538a..76c8db806 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -1299,6 +1299,18 @@ though an end-of-file was sent to the byte sink. The other arguments are as for @code{make-custom-binary-input-port}. @end deffn +@cindex custom binary input/output ports +@deffn {Scheme Procedure} make-custom-binary-input/output-port id read! write! get-position set-position! close +Return a new custom binary input/output port named @var{id} (a string). +The various arguments are the same as for The other arguments are as for +@code{make-custom-binary-input-port} and +@code{make-custom-binary-output-port}. If buffering is enabled on the +port, as is the case by default, input will be buffered in both +directions; @xref{Buffering}. If the @var{set-position!} function is +provided and not @code{#f}, then the port will also be marked as +random-access, causing the buffer to be flushed between reads and +writes. +@end deffn @node Soft Ports @subsubsection Soft Ports diff --git a/doc/ref/r6rs.texi b/doc/ref/r6rs.texi index eaee82105..fa8d7d213 100644 --- a/doc/ref/r6rs.texi +++ b/doc/ref/r6rs.texi @@ -1757,6 +1757,7 @@ respectively. Whether the port supports the @code{port-position} and @deffn {Scheme Procedure} make-custom-binary-input-port id read! get-position set-position! close @deffnx {Scheme Procedure} make-custom-binary-output-port id write! get-position set-position! close +@deffnx {Scheme Procedure} make-custom-binary-input/output-port id read! write! get-position set-position! close @xref{Custom Ports}. @end deffn diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index c53b53bf2..b52eb85d2 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -946,6 +946,91 @@ initialize_custom_binary_output_ports (void) } + + +/* Custom binary input_output ports. */ + +static scm_t_port_type *custom_binary_input_output_port_type; + + +static inline SCM +make_custom_binary_input_output_port (SCM read_proc, SCM write_proc, + SCM get_position_proc, + SCM set_position_proc, SCM close_proc) +{ + struct custom_binary_port *stream; + const unsigned long mode_bits = SCM_WRTNG | SCM_RDNG; + + stream = scm_gc_typed_calloc (struct custom_binary_port); + stream->read = read_proc; + stream->write = write_proc; + stream->get_position = get_position_proc; + stream->set_position_x = set_position_proc; + stream->close = close_proc; + + return scm_c_make_port_with_encoding (custom_binary_input_output_port_type, + mode_bits, sym_ISO_8859_1, sym_error, + (scm_t_bits) stream); +} + +SCM_DEFINE (scm_make_custom_binary_input_output_port, + "make-custom-binary-input/output-port", 6, 0, 0, + (SCM id, SCM read_proc, SCM write_proc, SCM get_position_proc, + SCM set_position_proc, SCM close_proc), + "Return a new custom binary input/output port. The port's input\n" + "is drained by invoking @var{read_proc} and passing it a\n" + "bytevector, an index where octets should be written, and an\n" + "octet count. The output is drained by invoking @var{write_proc}\n" + "and passing it a bytevector, an index where octets should be\n" + "written, and an octet count.") +#define FUNC_NAME s_scm_make_custom_binary_input_output_port +{ + SCM_VALIDATE_STRING (1, id); + SCM_VALIDATE_PROC (2, read_proc); + SCM_VALIDATE_PROC (3, write_proc); + + if (!scm_is_false (get_position_proc)) + SCM_VALIDATE_PROC (4, get_position_proc); + + if (!scm_is_false (set_position_proc)) + SCM_VALIDATE_PROC (5, set_position_proc); + + if (!scm_is_false (close_proc)) + SCM_VALIDATE_PROC (6, close_proc); + + return make_custom_binary_input_output_port + (read_proc, write_proc, get_position_proc, set_position_proc, close_proc); +} +#undef FUNC_NAME + + +static int +custom_binary_input_output_port_random_access_p (SCM port) +{ + struct custom_binary_port *stream = (void *) SCM_STREAM (port); + + return scm_is_true (stream->set_position_x); +} + + +/* Instantiate the custom binary input_output port type. */ +static inline void +initialize_custom_binary_input_output_ports (void) +{ + custom_binary_input_output_port_type = + scm_make_port_type ("r6rs-custom-binary-input/output-port", + custom_binary_input_port_read, + custom_binary_output_port_write); + + scm_set_port_seek (custom_binary_input_output_port_type, + custom_binary_port_seek); + scm_set_port_random_access_p (custom_binary_input_output_port_type, + custom_binary_input_output_port_random_access_p); + scm_set_port_close (custom_binary_input_output_port_type, + custom_binary_port_close); +} + + /* Transcoded ports. */ @@ -1082,5 +1167,6 @@ scm_init_r6rs_ports (void) initialize_custom_binary_input_ports (); initialize_bytevector_output_ports (); initialize_custom_binary_output_ports (); + initialize_custom_binary_input_output_ports (); initialize_transcoded_ports (); } diff --git a/libguile/r6rs-ports.h b/libguile/r6rs-ports.h index 3dde4d5f1..a2c63c7f4 100644 --- a/libguile/r6rs-ports.h +++ b/libguile/r6rs-ports.h @@ -39,6 +39,8 @@ SCM_API SCM scm_put_u8 (SCM, SCM); SCM_API SCM scm_put_bytevector (SCM, SCM, SCM, SCM); SCM_API SCM scm_open_bytevector_output_port (SCM); SCM_API SCM scm_make_custom_binary_output_port (SCM, SCM, SCM, SCM, SCM); +SCM_API SCM scm_make_custom_binary_input_output_port (SCM, SCM, SCM, + SCM, SCM, SCM); SCM_API SCM scm_get_string_n_x (SCM, SCM, SCM, SCM); SCM_API void scm_init_r6rs_ports (void); diff --git a/module/ice-9/binary-ports.scm b/module/ice-9/binary-ports.scm index 9d6c94526..e0da3df1a 100644 --- a/module/ice-9/binary-ports.scm +++ b/module/ice-9/binary-ports.scm @@ -42,7 +42,8 @@ put-bytevector unget-bytevector open-bytevector-output-port - make-custom-binary-output-port)) + make-custom-binary-output-port + make-custom-binary-input/output-port)) ;; Note that this extension also defines %make-transcoded-port, which is ;; not exported but is used by (rnrs io ports). diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm index 5ddc3d58d..e924ad8fc 100644 --- a/module/rnrs/io/ports.scm +++ b/module/rnrs/io/ports.scm @@ -71,6 +71,7 @@ ;; input/output ports open-file-input/output-port + make-custom-binary-input/output-port ;; binary output put-u8 put-bytevector From e68dd5c601ef7975507d4118bcc2ad334b0450b2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 7 Aug 2016 11:45:04 +0200 Subject: [PATCH 478/865] Manual recommends against SRFI-10 * doc/ref/srfi-modules.texi (SRFI-10): Deprecate, or at least recommend against. --- doc/ref/srfi-modules.texi | 101 ++++++++++++++------------------------ 1 file changed, 37 insertions(+), 64 deletions(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 463592e82..c9bde5e68 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -1834,9 +1834,9 @@ documented in the ``Compound Data Types'' section of the manual @cindex hash-comma @cindex #,() This SRFI implements a reader extension @code{#,()} called hash-comma. -It allows the reader to give new kinds of objects, for use both in -data and as constants or literals in source code. This feature is -available with +It allows the reader to give new kinds of objects, for use both in data +and as constants or literals in source code. This feature is available +with @example (use-modules (srfi srfi-10)) @@ -1894,73 +1894,46 @@ addition, (display #,(sum 123 456)) @print{} 579 @end example -A typical use for @nicode{#,()} is to get a read syntax for objects -which don't otherwise have one. For example, the following allows a -hash table to be given literally, with tags and values, ready for fast -lookup. - -@example -(define-reader-ctor 'hash - (lambda elems - (let ((table (make-hash-table))) - (for-each (lambda (elem) - (apply hash-set! table elem)) - elems) - table))) - -(define (animal->family animal) - (hash-ref '#,(hash ("tiger" "cat") - ("lion" "cat") - ("wolf" "dog")) - animal)) - -(animal->family "lion") @result{} "cat" -@end example - -Or for example the following is a syntax for a compiled regular -expression (@pxref{Regular Expressions}). - -@example -(use-modules (ice-9 regex)) - -(define-reader-ctor 'regexp make-regexp) - -(define (extract-angs str) - (let ((match (regexp-exec '#,(regexp "<([A-Z0-9]+)>") str))) - (and match - (match:substring match 1)))) - -(extract-angs "foo quux") @result{} "BAR" -@end example - -@sp 1 -@nicode{#,()} is somewhat similar to @code{define-macro} -(@pxref{Macros}) in that handler code is run to produce a result, but -@nicode{#,()} operates at the read stage, so it can appear in data for -@code{read} (@pxref{Scheme Read}), not just in code to be executed. - -Because @nicode{#,()} is handled at read-time it has no direct access -to variables etc. A symbol in the arguments is just a symbol, not a -variable reference. The arguments are essentially constants, though -the handler procedure can use them in any complicated way it might -want. - Once @code{(srfi srfi-10)} has loaded, @nicode{#,()} is available globally, there's no need to use @code{(srfi srfi-10)} in later modules. Similarly the tags registered are global and can be used anywhere once registered. -There's no attempt to record what previous @nicode{#,()} forms have -been seen, if two identical forms occur then two calls are made to the -handler procedure. The handler might like to maintain a cache or -similar to avoid making copies of large objects, depending on expected -usage. +We do not recommend @nicode{#,()} reader extensions, however, and for +three reasons. -In code the best uses of @nicode{#,()} are generally when there's a -lot of objects of a particular kind as literals or constants. If -there's just a few then some local variables and initializers are -fine, but that becomes tedious and error prone when there's a lot, and -the anonymous and compact syntax of @nicode{#,()} is much better. +First of all, this SRFI is not modular: the tag is matched by name, not +as an identifier within a scope. Defining a reader extension in one +part of a program can thus affect unrelated parts of a program because +the tag is not scoped. + +Secondly, reader extensions can be hard to manage from a time +perspective: when does the reader extension take effect? @xref{Eval +When}, for more discussion. + +Finally, reader extensions can easily produce objects that can't be +reified to an object file by the compiler. For example if you define a +reader extension that makes a hash table (@pxref{Hash Tables}), then it +will work fine when run with the interpreter, and you think you have a +neat hack. But then if you try to compile your program, after wrangling +with the @code{eval-when} concerns mentioned above, the compiler will +carp that it doesn't know how to serialize a hash table to disk. + +In the specific case of hash tables, it would be possible for Guile to +know how to pack hash tables into compiled files, but this doesn't work +in general. What if the object you produce is an instance of a record +type? Guile would then have to serialize the record type to disk too, +and then what happens if the program independently loads the code that +defines the record type? Does it define the same type or a different +type? Guile's record types are nominal, not structural, so the answer +is not clear at all. + +For all of these reasons we recommend macros over reader extensions. +Macros fulfill many of the same needs while preserving modular +composition, and their interaction with @code{eval-when} is well-known. +If you need brevity, instead use @code{read-hash-extend} and make your +reader extension expand to a macro invocation. In that way we preserve +scoping as much as possible. @xref{Reader Extensions}. @node SRFI-11 From 0f1b5674c415b04bc3db592e24eecc8c9c4cded3 Mon Sep 17 00:00:00 2001 From: sirgazil Date: Fri, 5 Aug 2016 19:52:44 -0500 Subject: [PATCH 479/865] Fix typo about pattern variables * doc/ref/sxml-match.texi (Matching XML Elements): Fix typo. --- doc/ref/sxml-match.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/sxml-match.texi b/doc/ref/sxml-match.texi index d2795a5f7..3adf34751 100644 --- a/doc/ref/sxml-match.texi +++ b/doc/ref/sxml-match.texi @@ -147,7 +147,7 @@ expressions which are evaluated if the pattern is successfully match. The example above matches an element @code{e} with an attribute @code{i} and three children. -Pattern variables are must be ``unquoted'' in the pattern. The above expression +Pattern variables must be ``unquoted'' in the pattern. The above expression binds @var{d} to @code{1}, @var{a} to @code{3}, @var{b} to @code{4}, and @var{c} to @code{5}. From 978229a52afd2fd21f79d62e5493e2f9570f77cf Mon Sep 17 00:00:00 2001 From: Calvin Heim Date: Sun, 7 Aug 2016 12:56:55 +0200 Subject: [PATCH 480/865] Fix grammar in api-compound.texi * doc/ref/api-compound.texi: Fix grammar. --- doc/ref/api-compound.texi | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index b4ae79c26..38c44649b 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -3718,9 +3718,9 @@ the following examples. #f @end lisp -Better is to use the procedure @code{hashq-get-handle}, which makes a -distinction between the two cases. Just like @code{assq}, this -procedure returns a key/value-pair on success, and @code{#f} if the +It is often better is to use the procedure @code{hashq-get-handle}, +which makes a distinction between the two cases. Just like @code{assq}, +this procedure returns a key/value-pair on success, and @code{#f} if the key is not found. @lisp From bcc40bc1c7ee25808153b720aa38322c211623cc Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 7 Aug 2016 13:26:18 +0200 Subject: [PATCH 481/865] Capture full path to GUILE_FOR_BUILD. * acinclude.m4: Capture full path to GUILE_FOR_BUILD. Fixes #22342. --- acinclude.m4 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/acinclude.m4 b/acinclude.m4 index 6a1470f24..70cb247aa 100644 --- a/acinclude.m4 +++ b/acinclude.m4 @@ -557,6 +557,8 @@ AC_DEFUN([GUILE_CHECK_GUILE_FOR_BUILD], [ if test "$GUILE_FOR_BUILD" = "not-found"; then AC_MSG_ERROR([a native Guile $PACKAGE_VERSION is required to cross-build Guile]) fi + else + GUILE_FOR_BUILD=$(which "$GUILE_FOR_BUILD" || echo "$GUILE_FOR_BUILD") fi AC_MSG_CHECKING([guile for build]) AC_MSG_RESULT([$GUILE_FOR_BUILD]) From 8ad67667f33b0ab016495145026e65fef40aa2a4 Mon Sep 17 00:00:00 2001 From: Marek Vasut Date: Thu, 28 Jan 2016 05:10:53 +0100 Subject: [PATCH 482/865] Recognize nios2 as compilation target Add support for the nios2 architecture. Signed-off-by: Marek Vasut --- module/system/base/target.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/module/system/base/target.scm b/module/system/base/target.scm index d60a8e0af..d1f6cff79 100644 --- a/module/system/base/target.scm +++ b/module/system/base/target.scm @@ -63,7 +63,7 @@ (cond ((string-match "^i[0-9]86$" cpu) (endianness little)) ((member cpu '("x86_64" "ia64" - "powerpcle" "powerpc64le" "mipsel" "mips64el" "sh4")) + "powerpcle" "powerpc64le" "mipsel" "mips64el" "nios2" "sh4")) (endianness little)) ((member cpu '("sparc" "sparc64" "powerpc" "powerpc64" "spu" "mips" "mips64" "m68k" "s390x")) @@ -102,7 +102,7 @@ ((string-match "64$" cpu) 8) ((string-match "64_?[lbe][lbe]$" cpu) 8) - ((member cpu '("sparc" "powerpc" "mips" "mipsel" "m68k" "sh4")) 4) + ((member cpu '("sparc" "powerpc" "mips" "mipsel" "nios2" "m68k" "sh4")) 4) ((member cpu '("s390x")) 8) ((string-match "^arm.*" cpu) 4) (else (error "unknown CPU word size" cpu))))) From 469970d4b35e973b1fae969a4781a06d6abf0ba4 Mon Sep 17 00:00:00 2001 From: David Kastrup Date: Thu, 11 Feb 2016 12:31:48 +0100 Subject: [PATCH 483/865] Let assv/assoc shortcircuit to assq where feasible * libguile/alist.c (scm_sloppy_assv, scm_sloppy_assoc): (scm_assv, scm_assoc): Shortcircuit to scm_assq where feasible. --- libguile/alist.c | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/libguile/alist.c b/libguile/alist.c index 82c70a03c..1e607f10b 100644 --- a/libguile/alist.c +++ b/libguile/alist.c @@ -28,6 +28,7 @@ #include "libguile/validate.h" #include "libguile/pairs.h" +#include "libguile/numbers.h" #include "libguile/alist.h" @@ -70,6 +71,11 @@ SCM_DEFINE (scm_sloppy_assv, "sloppy-assv", 2, 0, 0, "Recommended only for use in Guile internals.") #define FUNC_NAME s_scm_sloppy_assv { + /* In Guile, `assv' is the same as `assq' for keys of all types except + numbers. */ + if (!SCM_NUMP (key)) + return scm_sloppy_assq (key, alist); + for (; scm_is_pair (alist); alist = SCM_CDR (alist)) { SCM tmp = SCM_CAR (alist); @@ -88,6 +94,10 @@ SCM_DEFINE (scm_sloppy_assoc, "sloppy-assoc", 2, 0, 0, "Recommended only for use in Guile internals.") #define FUNC_NAME s_scm_sloppy_assoc { + /* Immediate values can be checked using `eq?'. */ + if (SCM_IMP (key)) + return scm_sloppy_assq (key, alist); + for (; scm_is_pair (alist); alist = SCM_CDR (alist)) { SCM tmp = SCM_CAR (alist); @@ -137,6 +147,12 @@ SCM_DEFINE (scm_assv, "assv", 2, 0, 0, #define FUNC_NAME s_scm_assv { SCM ls = alist; + + /* In Guile, `assv' is the same as `assq' for keys of all types except + numbers. */ + if (!SCM_NUMP (key)) + return scm_assq (key, alist); + for(; scm_is_pair (ls); ls = SCM_CDR (ls)) { SCM tmp = SCM_CAR (ls); @@ -158,6 +174,11 @@ SCM_DEFINE (scm_assoc, "assoc", 2, 0, 0, #define FUNC_NAME s_scm_assoc { SCM ls = alist; + + /* Immediate values can be checked using `eq?'. */ + if (SCM_IMP (key)) + return scm_assq (key, alist); + for(; scm_is_pair (ls); ls = SCM_CDR (ls)) { SCM tmp = SCM_CAR (ls); From 96d3cb3fcf834f3e017ad69548c89bcf61f3a19c Mon Sep 17 00:00:00 2001 From: Ethan Stefan Day Date: Sun, 7 Aug 2016 23:38:57 +0200 Subject: [PATCH 484/865] Documentation fixes * doc/ref/api-compound.texi: * doc/ref/api-control.texi: * doc/ref/api-data.texi: Fix typos and clarify. --- doc/ref/api-compound.texi | 6 +++--- doc/ref/api-control.texi | 6 +++--- doc/ref/api-data.texi | 18 +++++++++--------- 3 files changed, 15 insertions(+), 15 deletions(-) diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index 38c44649b..8277b35cd 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -1258,14 +1258,14 @@ is an ordinary array of rank 1 with lower bound 0 in dimension 0. is an ordinary array of rank 1 with lower bound 2 in dimension 0. @item #2((1 2 3) (4 5 6)) -is a non-uniform array of rank 2; a 3@cross{}3 matrix with index ranges 0..2 +is a non-uniform array of rank 2; a 2@cross{}3 matrix with index ranges 0..1 and 0..2. @item #u32(0 1 2) is a uniform u8 array of rank 1. @item #2u32@@2@@3((1 2) (2 3)) -is a uniform u8 array of rank 2 with index ranges 2..3 and 3..4. +is a uniform u32 array of rank 2 with index ranges 2..3 and 3..4. @item #2() is a two-dimensional array with index ranges 0..-1 and 0..-1, i.e.@: @@ -2877,7 +2877,7 @@ convenient definition that indicates the number of fields in @code{standard-vtable-fields}. @defvr {Scheme Variable} standard-vtable-fields -A string containing the orderedq set of fields that a vtable must have. +A string containing the ordered set of fields that a vtable must have. @end defvr @defvr {Scheme Variable} vtable-offset-user diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index 10a445cb0..5847b25de 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.texi @@ -168,7 +168,7 @@ Each @code{cond}-clause must look like this: (@var{test} @var{expression} @dots{}) @end lisp -where @var{test} and @var{expression} are arbitrary expression, or like +where @var{test} and @var{expression} are arbitrary expressions, or like this @lisp @@ -178,7 +178,7 @@ this where @var{expression} must evaluate to a procedure. The @var{test}s of the clauses are evaluated in order and as soon as one -of them evaluates to a true values, the corresponding @var{expression}s +of them evaluates to a true value, the corresponding @var{expression}s are evaluated in order and the last value is returned as the value of the @code{cond}-expression. For the @code{=>} clause type, @var{expression} is evaluated and the resulting procedure is applied to @@ -894,7 +894,7 @@ a new values object, and copies into it the @var{n} values starting from @var{base}. Currently this creates a list and passes it to @code{scm_values}, but we -expect that in the future we will be able to use more a efficient +expect that in the future we will be able to use a more efficient representation. @end deftypefn diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index c87b01eca..34e1ff64d 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -1712,7 +1712,7 @@ starts from 0 for the least significant bit. @deffn {Scheme Procedure} ash n count @deffnx {C Function} scm_ash (n, count) -Return @math{floor(n * 2^count)}. +Return @math{floor(n * 2^{count})}. @var{n} and @var{count} must be exact integers. With @var{n} viewed as an infinite-precision twos-complement @@ -5141,7 +5141,7 @@ mapping consistently: @lisp ;; 1=red, 2=green, 3=purple -(if (eq? (colour-of car) 1) +(if (eq? (colour-of vehicle) 1) ...) @end lisp @@ -5154,7 +5154,7 @@ defining constants: (define green 2) (define purple 3) -(if (eq? (colour-of car) red) +(if (eq? (colour-of vehicle) red) ...) @end lisp @@ -5163,7 +5163,7 @@ But the simplest and clearest approach is not to use numbers at all, but symbols whose names specify the colours that they refer to: @lisp -(if (eq? (colour-of car) 'red) +(if (eq? (colour-of vehicle) 'red) ...) @end lisp @@ -5185,15 +5185,15 @@ Then a car's combined property set could be naturally represented and manipulated as a list of symbols: @lisp -(properties-of car1) +(properties-of vehicle1) @result{} (red manual unleaded power-steering) -(if (memq 'power-steering (properties-of car1)) - (display "Unfit people can drive this car.\n") - (display "You'll need strong arms to drive this car!\n")) +(if (memq 'power-steering (properties-of vehicle1)) + (display "Unfit people can drive this vehicle.\n") + (display "You'll need strong arms to drive this vehicle!\n")) @print{} -Unfit people can drive this car. +Unfit people can drive this vehicle. @end lisp Remember, the fundamental property of symbols that we are relying on From 24502780eb1711d9f2ac550da0a16b78a24eae27 Mon Sep 17 00:00:00 2001 From: sirgazil Date: Sun, 7 Aug 2016 13:32:32 -0500 Subject: [PATCH 485/865] Fix typo about variable definitions * doc/ref/api-binding.texi (Top Level Variable Definitions): Fix typo. --- doc/ref/api-binding.texi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/ref/api-binding.texi b/doc/ref/api-binding.texi index 5857e782f..c3ee01b8c 100644 --- a/doc/ref/api-binding.texi +++ b/doc/ref/api-binding.texi @@ -93,7 +93,7 @@ Many people end up in a development style of adding and changing definitions at runtime, building out their program without restarting it. (You can do this using @code{reload-module}, the @code{reload} REPL command, the @code{load} procedure, or even just pasting code into a -REPL.) If you are one of these people, you will find that sometimes you +REPL.) If you are one of these people, you will find that sometimes there are some variables that you @emph{don't} want to redefine all the time. For these, use @code{define-once}. @@ -301,7 +301,7 @@ following case: (define a 1) (define b (+ a a)) (+ a b)) -@end lisp +@end lisp @noindent Guile decided to follow the R6RS in this regard, and now expands From b434ea36d3c264da32ec6fc49b57baadeee704e6 Mon Sep 17 00:00:00 2001 From: James Clarke Date: Sun, 7 Aug 2016 21:24:22 +0100 Subject: [PATCH 486/865] Recognize alpha as compilation target * module/system/base/target.scm (cpu-endianness): Add case for "alpha". (triplet-pointer-size): Likewise. --- module/system/base/target.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/module/system/base/target.scm b/module/system/base/target.scm index d1f6cff79..02febf8e4 100644 --- a/module/system/base/target.scm +++ b/module/system/base/target.scm @@ -63,7 +63,7 @@ (cond ((string-match "^i[0-9]86$" cpu) (endianness little)) ((member cpu '("x86_64" "ia64" - "powerpcle" "powerpc64le" "mipsel" "mips64el" "nios2" "sh4")) + "powerpcle" "powerpc64le" "mipsel" "mips64el" "nios2" "sh4" "alpha")) (endianness little)) ((member cpu '("sparc" "sparc64" "powerpc" "powerpc64" "spu" "mips" "mips64" "m68k" "s390x")) @@ -103,7 +103,7 @@ ((string-match "64$" cpu) 8) ((string-match "64_?[lbe][lbe]$" cpu) 8) ((member cpu '("sparc" "powerpc" "mips" "mipsel" "nios2" "m68k" "sh4")) 4) - ((member cpu '("s390x")) 8) + ((member cpu '("s390x" "alpha")) 8) ((string-match "^arm.*" cpu) 4) (else (error "unknown CPU word size" cpu))))) From 8f2f8db10b44a8f65a713937bbe3e73d5b92e5a5 Mon Sep 17 00:00:00 2001 From: sirgazil Date: Mon, 8 Aug 2016 11:04:03 -0500 Subject: [PATCH 487/865] Fix typo about open-pipe * doc/ref/posix.texi (Pipes): Fix typo. --- doc/ref/posix.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 5ca9402fd..738327835 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -2286,7 +2286,7 @@ For an input pipe, the child's standard output is the pipe and standard input is inherited from @code{current-input-port}. For an output pipe, the child's standard input is the pipe and standard output is inherited from @code{current-output-port}. In all cases -cases the child's standard error is inherited from +the child's standard error is inherited from @code{current-error-port} (@pxref{Default Ports}). If those @code{current-X-ports} are not files of some kind, and hence From aa86ae6bf917846b9e223bb071ecd9609593b58e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 25 Aug 2016 16:08:50 +0200 Subject: [PATCH 488/865] Fix exception when running ",help debug" * module/system/repl/command.scm (*command-table*): Remove entry for ",procedure", a command removed a few months ago. --- module/system/repl/command.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index e84586318..acb18e0a0 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -58,7 +58,7 @@ (disassemble x) (disassemble-file xx)) (profile (time t) (profile pr) (trace tr)) (debug (backtrace bt) (up) (down) (frame fr) - (procedure proc) (locals) (error-message error) + (locals) (error-message error) (break br bp) (break-at-source break-at bs) (step s) (step-instruction si) (next n) (next-instruction ni) From af360e5ce5c63c475d4016c7b9f558fd527b892b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 25 Aug 2016 16:16:39 +0200 Subject: [PATCH 489/865] Tweak to conversion strategy access * libguile/strings.c (scm_from_port_stringn, scm_to_port_stringn): Access the conversion_strategy directly to make sure these functions can run while the port is flushing on close. Fixes web-http.test to allow the closed flag to be atomically cleared on a port before flushing. --- libguile/strings.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/strings.c b/libguile/strings.c index dc2e4f5fe..232ddf90e 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -1778,7 +1778,7 @@ scm_from_port_stringn (const char *str, size_t len, SCM port) else return scm_from_stringn (str, len, scm_i_symbol_chars (pt->encoding), scm_i_string_failed_conversion_handler - (scm_port_conversion_strategy (port))); + (SCM_PORT (port)->conversion_strategy)); } /* Create a new scheme string from the C string STR. The memory of @@ -2217,7 +2217,7 @@ scm_to_port_stringn (SCM str, size_t *lenp, SCM port) else return scm_to_stringn (str, lenp, scm_i_symbol_chars (pt->encoding), scm_i_string_failed_conversion_handler - (scm_port_conversion_strategy (port))); + (SCM_PORT (port)->conversion_strategy)); } /* Return a malloc(3)-allocated buffer containing the contents of STR encoded From 57aff02646287dc8c74a1abb34dd24440d0f96eb Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 28 Aug 2016 11:37:19 +0200 Subject: [PATCH 490/865] Add prebuilt alias for x86_64-pc-linux-gnu * prebuilt/x86_64-pc-linux-gnu: Add as alias to x86_64-unknown-linux-gnu. --- prebuilt/x86_64-pc-linux-gnu | 1 + 1 file changed, 1 insertion(+) create mode 120000 prebuilt/x86_64-pc-linux-gnu diff --git a/prebuilt/x86_64-pc-linux-gnu b/prebuilt/x86_64-pc-linux-gnu new file mode 120000 index 000000000..7ef2cbd31 --- /dev/null +++ b/prebuilt/x86_64-pc-linux-gnu @@ -0,0 +1 @@ +./x86_64-unknown-linux-gnu \ No newline at end of file From 342bd8dfb325eab6610e7c4450aaf810ef71884f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 28 Aug 2016 13:46:31 +0200 Subject: [PATCH 491/865] ETag list headers accept sloppy etags * module/web/http.scm (parse-entity-tag): Add #:sloppy-delimiters keyword argument, and return a second value indicating the end position. (parse-entity-tag-list): Use parse-entity-tag, so that we also accept sloppy etags that aren't qstrings. * test-suite/tests/web-http.test ("request headers"): Add a test. --- module/web/http.scm | 52 +++++++++++++++++++++------------- test-suite/tests/web-http.test | 2 ++ 2 files changed, 35 insertions(+), 19 deletions(-) diff --git a/module/web/http.scm b/module/web/http.scm index 8e95fc755..c9fb195d7 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -872,11 +872,27 @@ as an ordered alist." ;; tag should really be a qstring. However there are a number of ;; servers that emit etags as unquoted strings. Assume that if the ;; value doesn't start with a quote, it's an unquoted strong etag. -(define (parse-entity-tag val) +(define* (parse-entity-tag val #:optional (start 0) (end (string-length val)) + #:key sloppy-delimiters) + (define (parse-proper-etag-at start strong?) + (cond + (sloppy-delimiters + (call-with-values (lambda () + (parse-qstring val start end #:incremental? #t)) + (lambda (tag next) + (values (cons tag strong?) next)))) + (else + (values (cons (parse-qstring val start end) strong?) end)))) (cond - ((string-prefix? "W/" val) (cons (parse-qstring val 2) #f)) - ((string-prefix? "\"" val) (cons (parse-qstring val) #t)) - (else (cons val #t)))) + ((string-prefix? "W/" val 0 2 start end) + (parse-proper-etag-at (+ start 2) #f)) + ((string-prefix? "\"" val 0 1 start end) + (parse-proper-etag-at start #t)) + (else + (let ((delim (or (and sloppy-delimiters + (string-index val sloppy-delimiters start end)) + end))) + (values (cons (substring val start delim) #t) delim))))) (define (entity-tag? val) (and (pair? val) @@ -889,21 +905,19 @@ as an ordered alist." (define* (parse-entity-tag-list val #:optional (start 0) (end (string-length val))) - (let ((strong? (not (string-prefix? "W/" val 0 2 start end)))) - (call-with-values (lambda () - (parse-qstring val (if strong? start (+ start 2)) - end #:incremental? #t)) - (lambda (tag next) - (acons tag strong? - (let ((next (skip-whitespace val next end))) - (if (< next end) - (if (eqv? (string-ref val next) #\,) - (parse-entity-tag-list - val - (skip-whitespace val (1+ next) end) - end) - (bad-header-component 'entity-tag-list val)) - '()))))))) + (call-with-values (lambda () + (parse-entity-tag val start end #:sloppy-delimiters #\,)) + (lambda (etag next) + (cons etag + (let ((next (skip-whitespace val next end))) + (if (< next end) + (if (eqv? (string-ref val next) #\,) + (parse-entity-tag-list + val + (skip-whitespace val (1+ next) end) + end) + (bad-header-component 'entity-tag-list val)) + '())))))) (define (entity-tag-list? val) (list-of? val entity-tag?)) diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test index 3fda4f9fb..762f78c60 100644 --- a/test-suite/tests/web-http.test +++ b/test-suite/tests/web-http.test @@ -331,6 +331,8 @@ "~a, ~d ~b ~Y ~H:~M:~S ~z")) (pass-if-parse if-none-match "\"xyzzy\", W/\"qux\"" '(("xyzzy" . #t) ("qux" . #f))) + (pass-if-parse if-none-match "xyzzy, W/\"qux\"" + '(("xyzzy" . #t) ("qux" . #f))) (pass-if-parse if-none-match "*" '*) (pass-if-parse if-range "\"foo\"" '("foo" . #t)) (pass-if-parse if-range "Tue, 15 Nov 1994 08:12:31 GMT" From ebb8cb7206dfab74e9df2e0b01f773863a74132d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 28 Aug 2016 14:46:32 +0200 Subject: [PATCH 492/865] Remove SCM_I_MAX_PORT_TYPE_COUNT * libguile/ports.h (SCM_I_MAX_PORT_TYPE_COUNT): Remove unused CPP definition. --- libguile/ports.h | 3 --- 1 file changed, 3 deletions(-) diff --git a/libguile/ports.h b/libguile/ports.h index 66b24715d..6fe9ecd2b 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -77,9 +77,6 @@ typedef struct scm_t_port scm_t_port; #define SCM_PORT(x) ((scm_t_port *) SCM_CELL_WORD_2 (x)) #define SCM_PORT_TYPE(port) ((scm_t_port_type *) SCM_CELL_WORD_3 (port)) -/* Maximum number of port types. */ -#define SCM_I_MAX_PORT_TYPE_COUNT 256 - From 4256e0655f6b2aae53c3345196288c92423ff277 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 28 Aug 2016 22:13:59 +0200 Subject: [PATCH 493/865] Remove duplicate documentation * doc/ref/posix.texi (Ports and File Descriptors): Remove duplicate documentation for port-mode and setvbuf. --- doc/ref/posix.texi | 27 --------------------------- 1 file changed, 27 deletions(-) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 738327835..da14b83ae 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -419,13 +419,6 @@ is made to move away ports which are using @var{newfd}. The return value is unspecified. @end deffn -@deffn {Scheme Procedure} port-mode port -Return the port modes associated with the open port @var{port}. -These will not necessarily be identical to the modes used when -the port was opened, since modes such as ``append'' which are -used only during port creation are not retained. -@end deffn - @deffn {Scheme Procedure} port-for-each proc @deffnx {C Function} scm_port_for_each (SCM proc) @deffnx {C Function} scm_c_port_for_each (void (*proc)(void *, SCM), void *data) @@ -443,26 +436,6 @@ a pointer to a C function and passes along a arbitrary @var{data} cookie. @end deffn -@deffn {Scheme Procedure} setvbuf port mode [size] -@deffnx {C Function} scm_setvbuf (port, mode, size) -@cindex port buffering -Set the buffering mode for @var{port}. @var{mode} can be one of the -following symbols: - -@table @code -@item none -non-buffered -@item line -line buffered -@item block -block buffered, using a newly allocated buffer of @var{size} bytes. -If @var{size} is omitted, a default size will be used. -@end table - -Only certain types of ports are supported, most importantly -file ports. -@end deffn - @deffn {Scheme Procedure} fcntl port/fd cmd [value] @deffnx {C Function} scm_fcntl (object, cmd, value) Apply @var{cmd} on @var{port/fd}, either a port or file descriptor. From 2fa2e50a0fdb49e70d6882e06d1a2dcc2ae10a69 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 30 Aug 2016 23:35:10 +0200 Subject: [PATCH 494/865] Add file descriptor finalizers * doc/ref/posix.texi (Ports and File Descriptors): Document new interfaces. * libguile/filesys.c (scm_close, scm_close_fdes) * libguile/fports.c (fport_close): * libguile/ioext.c (scm_primitive_move_to_fdes): Call scm_run_fdes_finalizers. * module/ice-9/fdes-finalizers.scm: * test-suite/tests/fdes-finalizers.test: * libguile/fdes-finalizers.h: * libguile/fdes-finalizers.c: New files. * module/Makefile.am: * test-suite/Makefile.am: * libguile/Makefile.am: * libguile.h: * libguile/init.c: Wire up new files. --- doc/ref/posix.texi | 45 +++++++++ libguile.h | 1 + libguile/Makefile.am | 4 + libguile/fdes-finalizers.c | 129 ++++++++++++++++++++++++++ libguile/fdes-finalizers.h | 34 +++++++ libguile/filesys.c | 3 + libguile/fports.c | 2 + libguile/init.c | 2 + libguile/ioext.c | 2 + module/Makefile.am | 1 + module/ice-9/fdes-finalizers.scm | 25 +++++ test-suite/Makefile.am | 1 + test-suite/tests/fdes-finalizers.test | 65 +++++++++++++ 13 files changed, 314 insertions(+) create mode 100644 libguile/fdes-finalizers.c create mode 100644 libguile/fdes-finalizers.h create mode 100644 module/ice-9/fdes-finalizers.scm create mode 100644 test-suite/tests/fdes-finalizers.test diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index da14b83ae..a78617dc2 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -559,6 +559,51 @@ Duplicates in the input vectors appear only once in output. An additional @code{select!} interface is provided. @end deffn +While it is sometimes necessary to operate at the level of file +descriptors, this is an operation whose correctness can only be +considered as part of a whole program. So for example while the effects +of @code{(string-set! x 34 #\y)} are limited to the bits of code that +can access @var{x}, @code{(close-fdes 34)} mutates the state of the +entire process. In particular if another thread is using file +descriptor 34 then their state might be corrupted; and another thread +which opens a file might cause file descriptor 34 to be re-used, so that +corruption could manifest itself in a strange way. + +@cindex fdes finalizers +@cindex file descriptor finalizers +@cindex finalizers, file descriptor +However when working with file descriptors, it's common to want to +associate information with the file descriptor, perhaps in a side table. +To support this use case and to allow user code to remove an association +when a file descriptor is closed, Guile offers @dfn{fdes finalizers}. + +As the name indicates, fdes finalizers are finalizers -- they can run in +response to garbage collection, and they can also run in response to +explicit calls to @code{close-port}, @code{close-fdes}, or the like. As +such they inherit many of the pitfalls of finalizers: they may be +invoked from concurrent threads, or not at all. @xref{Foreign Object +Memory Management}, for more on finalizers. + +To use fdes finalizers, import their module; + +@example +(use-modules (ice-9 fdes-finalizers)) +@end example + +@deffn {Scheme Procedure} add-fdes-finalizer! fdes finalizer +@deffnx {Scheme Procedure} remove-fdes-finalizer! fdes finalizer +Add or remove a finalizer for @var{fdes}. A finalizer is a procedure +that is called by Guile when a file descriptor is closed. The file +descriptor being closed is passed as the one argument to the finalizer. +If a finalizer has been added multiple times to a file descriptor, to +remove it would require that number of calls to +@code{remove-fdes-finalizer!}. + +The finalizers added to a file descriptor are called by Guile in an +unspecified order, and their return values are ignored. +@end deffn + + @node File System @subsection File System @cindex file system diff --git a/libguile.h b/libguile.h index 4904d6980..d2030eb86 100644 --- a/libguile.h +++ b/libguile.h @@ -47,6 +47,7 @@ extern "C" { #include "libguile/eval.h" #include "libguile/evalext.h" #include "libguile/extensions.h" +#include "libguile/fdes-finalizers.h" #include "libguile/feature.h" #include "libguile/filesys.h" #include "libguile/finalizers.h" diff --git a/libguile/Makefile.am b/libguile/Makefile.am index dab09e1a3..8161ade4e 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -143,6 +143,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ evalext.c \ expand.c \ extensions.c \ + fdes-finalizers.c \ feature.c \ filesys.c \ finalizers.c \ @@ -252,6 +253,7 @@ DOT_X_FILES = \ evalext.x \ expand.x \ extensions.x \ + fdes-finalizers.x \ feature.x \ filesys.x \ fluids.x \ @@ -358,6 +360,7 @@ DOT_DOC_FILES = \ evalext.doc \ expand.doc \ extensions.doc \ + fdes-finalizers.doc \ feature.doc \ filesys.doc \ fluids.doc \ @@ -586,6 +589,7 @@ modinclude_HEADERS = \ evalext.h \ expand.h \ extensions.h \ + fdes-finalizers.h \ feature.h \ finalizers.h \ filesys.h \ diff --git a/libguile/fdes-finalizers.c b/libguile/fdes-finalizers.c new file mode 100644 index 000000000..fd4689e13 --- /dev/null +++ b/libguile/fdes-finalizers.c @@ -0,0 +1,129 @@ +/* Copyright (C) 2016 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 License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include "libguile/_scm.h" +#include "libguile/hashtab.h" +#include "libguile/numbers.h" +#include "libguile/fdes-finalizers.h" + + + +/* Table of fdes finalizers and associated lock. */ +static scm_i_pthread_mutex_t fdes_finalizers_lock = + SCM_I_PTHREAD_MUTEX_INITIALIZER; +static SCM fdes_finalizers; + +SCM_DEFINE (scm_add_fdes_finalizer_x, "add-fdes-finalizer!", 2, 0, 0, + (SCM fd, SCM finalizer), + "Add a finalizer that will be called when @var{fd} is closed.") +#define FUNC_NAME s_scm_add_fdes_finalizer_x +{ + SCM h; + + /* Check type. */ + scm_to_uint (fd); + + scm_i_pthread_mutex_lock (&fdes_finalizers_lock); + h = scm_hashv_create_handle_x (fdes_finalizers, fd, SCM_EOL); + scm_set_cdr_x (h, scm_cons (finalizer, scm_cdr (h))); + scm_i_pthread_mutex_unlock (&fdes_finalizers_lock); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_remove_fdes_finalizer_x, "remove-fdes-finalizer!", 2, 0, 0, + (SCM fd, SCM finalizer), + "Remove a finalizer that was previously added to the file\n" + "descriptor @var{fd}.") +#define FUNC_NAME s_scm_remove_fdes_finalizer_x +{ + SCM h; + + /* Check type. */ + scm_to_uint (fd); + + scm_i_pthread_mutex_lock (&fdes_finalizers_lock); + h = scm_hashv_get_handle (fdes_finalizers, fd); + if (scm_is_true (h)) + scm_set_cdr_x (h, scm_delq1_x (finalizer, scm_cdr (h))); + scm_i_pthread_mutex_unlock (&fdes_finalizers_lock); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +struct fdes_finalizer_data +{ + SCM finalizer; + SCM fd; +}; + +static SCM +do_run_finalizer (void *data) +{ + struct fdes_finalizer_data *fdata = data; + return scm_call_1 (fdata->finalizer, fdata->fd); +} + +void +scm_run_fdes_finalizers (int fd) +{ + SCM finalizers; + struct fdes_finalizer_data data; + + data.fd = scm_from_int (fd); + + scm_i_pthread_mutex_lock (&fdes_finalizers_lock); + finalizers = scm_hashv_ref (fdes_finalizers, data.fd, SCM_EOL); + if (!scm_is_null (finalizers)) + scm_hashv_remove_x (fdes_finalizers, data.fd); + scm_i_pthread_mutex_unlock (&fdes_finalizers_lock); + + for (; !scm_is_null (finalizers); finalizers = scm_cdr (finalizers)) + { + data.finalizer = scm_car (finalizers); + scm_internal_catch (SCM_BOOL_T, do_run_finalizer, &data, + scm_handle_by_message_noexit, NULL); + } +} + + + + +static void +scm_init_fdes_finalizers (void) +{ +#include "libguile/fdes-finalizers.x" +} + +void +scm_register_fdes_finalizers () +{ + fdes_finalizers = scm_c_make_hash_table (0); + + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_fdes_finalizers", + (scm_t_extension_init_func) scm_init_fdes_finalizers, + NULL); +} diff --git a/libguile/fdes-finalizers.h b/libguile/fdes-finalizers.h new file mode 100644 index 000000000..cadbb0404 --- /dev/null +++ b/libguile/fdes-finalizers.h @@ -0,0 +1,34 @@ +#ifndef SCM_FDES_FINALIZERS_H +#define SCM_FDES_FINALIZERS_H + +/* Copyright (C) 2016 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 License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + + + +#include "libguile/__scm.h" + + + +SCM_INTERNAL SCM scm_add_fdes_finalizer_x (SCM fd, SCM finalizer); +SCM_INTERNAL SCM scm_remove_fdes_finalizer_x (SCM fd, SCM finalizer); +SCM_INTERNAL void scm_run_fdes_finalizers (int fd); + +SCM_INTERNAL void scm_register_fdes_finalizers (void); + +#endif /* SCM_FDES_FINALIZERS_H */ diff --git a/libguile/filesys.c b/libguile/filesys.c index c4f2653c2..0bc366953 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -43,6 +43,7 @@ #include "libguile/_scm.h" #include "libguile/smob.h" +#include "libguile/fdes-finalizers.h" #include "libguile/feature.h" #include "libguile/fports.h" #include "libguile/strings.h" @@ -290,6 +291,7 @@ SCM_DEFINE (scm_close, "close", 1, 0, 0, return scm_close_port (fd_or_port); fd = scm_to_int (fd_or_port); scm_evict_ports (fd); /* see scsh manual. */ + scm_run_fdes_finalizers (fd); SCM_SYSCALL (rv = close (fd)); /* following scsh, closing an already closed file descriptor is not an error. */ @@ -312,6 +314,7 @@ SCM_DEFINE (scm_close_fdes, "close-fdes", 1, 0, 0, int rv; c_fd = scm_to_int (fd); + scm_run_fdes_finalizers (c_fd); SCM_SYSCALL (rv = close (c_fd)); if (rv < 0) SCM_SYSERROR; diff --git a/libguile/fports.c b/libguile/fports.c index f535f8a25..5886f628d 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -49,6 +49,7 @@ #include #include "libguile/_scm.h" +#include "libguile/fdes-finalizers.h" #include "libguile/strings.h" #include "libguile/validate.h" #include "libguile/gc.h" @@ -656,6 +657,7 @@ fport_close (SCM port) { scm_t_fport *fp = SCM_FSTREAM (port); + scm_run_fdes_finalizers (fp->fdes); if (close (fp->fdes) != 0) /* It's not useful to retry after EINTR, as the file descriptor is in an undefined state. See http://lwn.net/Articles/365294/. diff --git a/libguile/init.c b/libguile/init.c index 7e0c30d9c..1e4889c97 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -56,6 +56,7 @@ #include "libguile/eval.h" #include "libguile/evalext.h" #include "libguile/expand.h" +#include "libguile/fdes-finalizers.h" #include "libguile/feature.h" #include "libguile/filesys.h" #include "libguile/finalizers.h" @@ -398,6 +399,7 @@ scm_i_init_guile (void *base) scm_bootstrap_programs (); scm_bootstrap_vm (); scm_register_r6rs_ports (); + scm_register_fdes_finalizers (); scm_register_foreign (); scm_register_foreign_object (); scm_register_srfi_1 (); diff --git a/libguile/ioext.c b/libguile/ioext.c index 58a6219f3..43c915a09 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -29,6 +29,7 @@ #include "libguile/_scm.h" #include "libguile/dynwind.h" +#include "libguile/fdes-finalizers.h" #include "libguile/feature.h" #include "libguile/fports.h" #include "libguile/hashtab.h" @@ -266,6 +267,7 @@ SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0, if (rv == -1) SCM_SYSERROR; stream->fdes = new_fd; + scm_run_fdes_finalizers (old_fd); SCM_SYSCALL (close (old_fd)); return SCM_BOOL_T; } diff --git a/module/Makefile.am b/module/Makefile.am index f590fb96d..00c394738 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -59,6 +59,7 @@ SOURCES = \ ice-9/eval-string.scm \ ice-9/eval.scm \ ice-9/expect.scm \ + ice-9/fdes-finalizers.scm \ ice-9/format.scm \ ice-9/ftw.scm \ ice-9/futures.scm \ diff --git a/module/ice-9/fdes-finalizers.scm b/module/ice-9/fdes-finalizers.scm new file mode 100644 index 000000000..acb2ed1c3 --- /dev/null +++ b/module/ice-9/fdes-finalizers.scm @@ -0,0 +1,25 @@ +;;;; Copyright (C) 2016 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 License +;;;; as published by the Free Software Foundation; either version 3 of +;;;; the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + + +(define-module (ice-9 fdes-finalizers) + #:export (add-fdes-finalizer! + remove-fdes-finalizer!)) + +(eval-when (expand load eval) + (load-extension (string-append "libguile-" (effective-version)) + "scm_init_fdes_finalizers")) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 473501ee2..3c88405cb 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -54,6 +54,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/eval.test \ tests/eval-string.test \ tests/exceptions.test \ + tests/fdes-finalizers.test \ tests/filesys.test \ tests/fluids.test \ tests/foreign.test \ diff --git a/test-suite/tests/fdes-finalizers.test b/test-suite/tests/fdes-finalizers.test new file mode 100644 index 000000000..6d48fa918 --- /dev/null +++ b/test-suite/tests/fdes-finalizers.test @@ -0,0 +1,65 @@ +;;;; Copyright (C) 2016 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-suite test-fdes-finalizers) + #:use-module (test-suite lib) + #:use-module (test-suite guile-test) + #:use-module (ice-9 fdes-finalizers)) + +(define (test-file suffix) + (data-file-name (string-append "ports-test.tmp" suffix))) + +(close-port (open-output-file (test-file ".1"))) +(close-port (open-output-file (test-file ".2"))) + +(with-test-prefix "simple" + (let* ((call-count 0) + (f (lambda (fdes) (set! call-count (1+ call-count)))) + (p (open-input-file (test-file ".1"))) + (q (open-input-file (test-file ".2")))) + (pass-if-equal 0 call-count) + (add-fdes-finalizer! (fileno p) f) + (pass-if-equal 0 call-count) + (close-port q) + (pass-if-equal 0 call-count) + (close-port p) + (pass-if-equal 1 call-count))) + +(with-test-prefix "multiple" + (let* ((call-count 0) + (f (lambda (fdes) (set! call-count (1+ call-count)))) + (p (open-input-file (test-file ".1")))) + (pass-if-equal 0 call-count) + (add-fdes-finalizer! (fileno p) f) + (add-fdes-finalizer! (fileno p) f) + (pass-if-equal 0 call-count) + (close-port p) + (pass-if-equal 2 call-count))) + +(with-test-prefix "with removal" + (let* ((call-count 0) + (f (lambda (fdes) (set! call-count (1+ call-count)))) + (p (open-input-file (test-file ".1")))) + (pass-if-equal 0 call-count) + (add-fdes-finalizer! (fileno p) f) + (add-fdes-finalizer! (fileno p) f) + (remove-fdes-finalizer! (fileno p) f) + (pass-if-equal 0 call-count) + (close-port p) + (pass-if-equal 1 call-count))) + +(delete-file (test-file ".1")) +(delete-file (test-file ".2")) From ad4fe88ffb9193e7b5da8350d71334be525eed84 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 31 Aug 2016 10:42:21 +0200 Subject: [PATCH 495/865] Move system* to posix.c, impl on open-process * libguile/simpos.c: Trim includes. (scm_system_star): Move to posix.c. * libguile/simpos.h (scm_system_star): Remove. * libguile/posix.h (scm_system_star): Add. * libguile/posix.c (scm_system_star): Move here and implement in terms of open-process. This lets system* work on Windows. Inspired by a patch by Eli Zaretskii. (start_child): Exit with 127 if the command isn't found. --- libguile/posix.c | 72 ++++++++++++++++++++++++- libguile/posix.h | 1 + libguile/simpos.c | 130 ++-------------------------------------------- libguile/simpos.h | 1 - 4 files changed, 75 insertions(+), 129 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index 33838089e..5d0b1ed8f 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1322,7 +1322,9 @@ start_child (const char *exec_file, char **exec_argv, exec_file, msg); } - _exit (EXIT_FAILURE); + /* Use exit status 127, like shells in this case, as per POSIX + . */ + _exit (127); /* Not reached. */ return -1; @@ -1429,6 +1431,74 @@ scm_open_process (SCM mode, SCM prog, SCM args) scm_from_int (pid))); } #undef FUNC_NAME + +static void +restore_sigaction (SCM pair) +{ + SCM sig, handler, flags; + sig = scm_car (pair); + handler = scm_cadr (pair); + flags = scm_cddr (pair); + scm_sigaction (sig, handler, flags); +} + +static void +scm_dynwind_sigaction (int sig, SCM handler, SCM flags) +{ + SCM old, scm_sig; + scm_sig = scm_from_int (sig); + old = scm_sigaction (scm_sig, handler, flags); + scm_dynwind_unwind_handler_with_scm (restore_sigaction, + scm_cons (scm_sig, old), + SCM_F_WIND_EXPLICITLY); +} + +SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, + (SCM args), +"Execute the command indicated by @var{args}. The first element must\n" +"be a string indicating the command to be executed, and the remaining\n" +"items must be strings representing each of the arguments to that\n" +"command.\n" +"\n" +"This function returns the exit status of the command as provided by\n" +"@code{waitpid}. This value can be handled with @code{status:exit-val}\n" +"and the related functions.\n" +"\n" +"@code{system*} is similar to @code{system}, but accepts only one\n" +"string per-argument, and performs no shell interpretation. The\n" +"command is executed using fork and execlp. Accordingly this function\n" +"may be safer than @code{system} in situations where shell\n" +"interpretation is not required.\n" +"\n" +"Example: (system* \"echo\" \"foo\" \"bar\")") +#define FUNC_NAME s_scm_system_star +{ + SCM prog, res; + int pid, status, wait_result; + + if (scm_is_null (args)) + SCM_WRONG_NUM_ARGS (); + prog = scm_car (args); + args = scm_cdr (args); + + scm_dynwind_begin (0); + /* Make sure the child can't kill us (as per normal system call). */ + scm_dynwind_sigaction (SIGINT, scm_from_ulong (SIG_IGN), SCM_UNDEFINED); +#ifdef SIGQUIT + scm_dynwind_sigaction (SIGQUIT, scm_from_ulong (SIG_IGN), SCM_UNDEFINED); +#endif + + res = scm_open_process (scm_nullstr, prog, args); + pid = scm_to_int (scm_c_value_ref (res, 2)); + SCM_SYSCALL (wait_result = waitpid (pid, &status, 0)); + if (wait_result == -1) + SCM_SYSERROR; + + scm_dynwind_end (); + + return scm_from_int (status); +} +#undef FUNC_NAME #endif /* HAVE_START_CHILD */ #ifdef HAVE_UNAME diff --git a/libguile/posix.h b/libguile/posix.h index 92f8b3514..078edf5eb 100644 --- a/libguile/posix.h +++ b/libguile/posix.h @@ -72,6 +72,7 @@ SCM_API SCM scm_mkstemp (SCM tmpl); SCM_API SCM scm_tmpfile (void); SCM_API SCM scm_open_pipe (SCM pipestr, SCM modes); SCM_API SCM scm_close_pipe (SCM port); +SCM_API SCM scm_system_star (SCM cmds); SCM_API SCM scm_utime (SCM pathname, SCM actime, SCM modtime, SCM actimens, SCM modtimens, SCM flags); SCM_API SCM scm_access (SCM path, SCM how); diff --git a/libguile/simpos.c b/libguile/simpos.c index 70058285a..38d8dfde1 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -24,35 +24,15 @@ #endif #include -#include /* for SIG constants */ -#include /* for getenv */ -#include +#include /* for getenv, system, exit, free */ +#include /* for _exit */ #include "libguile/_scm.h" -#include "libguile/scmsigs.h" #include "libguile/strings.h" - #include "libguile/validate.h" #include "libguile/simpos.h" -#include "libguile/dynwind.h" -#ifdef HAVE_STRING_H -#include -#endif -#include -#if HAVE_SYS_WAIT_H -# include -#endif - -#ifdef __MINGW32__ -# include /* for spawnvp and friends */ -#endif - -#include "posix.h" - - -extern int system(); #ifdef HAVE_SYSTEM @@ -74,7 +54,7 @@ SCM_DEFINE (scm_system, "system", 0, 1, 0, if (SCM_UNBNDP (cmd)) { rv = system (NULL); - return scm_from_bool(rv); + return scm_from_bool (rv); } SCM_VALIDATE_STRING (1, cmd); errno = 0; @@ -89,110 +69,6 @@ SCM_DEFINE (scm_system, "system", 0, 1, 0, #endif /* HAVE_SYSTEM */ -#ifdef HAVE_SYSTEM - -SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, - (SCM args), -"Execute the command indicated by @var{args}. The first element must\n" -"be a string indicating the command to be executed, and the remaining\n" -"items must be strings representing each of the arguments to that\n" -"command.\n" -"\n" -"This function returns the exit status of the command as provided by\n" -"@code{waitpid}. This value can be handled with @code{status:exit-val}\n" -"and the related functions.\n" -"\n" -"@code{system*} is similar to @code{system}, but accepts only one\n" -"string per-argument, and performs no shell interpretation. The\n" -"command is executed using fork and execlp. Accordingly this function\n" -"may be safer than @code{system} in situations where shell\n" -"interpretation is not required.\n" -"\n" -"Example: (system* \"echo\" \"foo\" \"bar\")") -#define FUNC_NAME s_scm_system_star -{ - if (scm_is_null (args)) - SCM_WRONG_NUM_ARGS (); - - if (scm_is_pair (args)) - { - SCM oldint; - SCM sig_ign; - SCM sigint; - /* SIGQUIT is undefined on MS-Windows. */ -#ifdef SIGQUIT - SCM oldquit; - SCM sigquit; -#endif -#ifdef HAVE_FORK - int pid; -#else - int status; -#endif - char **execargv; - - /* allocate before fork */ - execargv = scm_i_allocate_string_pointers (args); - - /* make sure the child can't kill us (as per normal system call) */ - sig_ign = scm_from_ulong ((unsigned long) SIG_IGN); - sigint = scm_from_int (SIGINT); - oldint = scm_sigaction (sigint, sig_ign, SCM_UNDEFINED); -#ifdef SIGQUIT - sigquit = scm_from_int (SIGQUIT); - oldquit = scm_sigaction (sigquit, sig_ign, SCM_UNDEFINED); -#endif - -#ifdef HAVE_FORK - pid = fork (); - if (pid == 0) - { - /* child */ - execvp (execargv[0], execargv); - - /* Something went wrong. */ - fprintf (stderr, "In execvp of %s: %s\n", - execargv[0], strerror (errno)); - - /* Exit directly instead of throwing, because otherwise this - process may keep on running. Use exit status 127, like - shells in this case, as per POSIX - . */ - _exit (127); - } - else - { - /* parent */ - int wait_result, status; - - if (pid == -1) - SCM_SYSERROR; - - SCM_SYSCALL (wait_result = waitpid (pid, &status, 0)); - if (wait_result == -1) - SCM_SYSERROR; - scm_sigaction (sigint, SCM_CAR (oldint), SCM_CDR (oldint)); - scm_sigaction (sigquit, SCM_CAR (oldquit), SCM_CDR (oldquit)); - - return scm_from_int (status); - } -#else /* !HAVE_FORK */ - status = spawnvp (P_WAIT, execargv[0], (const char * const *)execargv); - scm_sigaction (sigint, SCM_CAR (oldint), SCM_CDR (oldint)); -#ifdef SIGQUIT - scm_sigaction (sigquit, SCM_CAR (oldquit), SCM_CDR (oldquit)); -#endif - - return scm_from_int (status); -#endif /* !HAVE_FORK */ - } - else - SCM_WRONG_TYPE_ARG (1, args); -} -#undef FUNC_NAME -#endif /* HAVE_SYSTEM */ - - SCM_DEFINE (scm_getenv, "getenv", 1, 0, 0, (SCM nam), "Looks up the string @var{nam} in the current environment. The return\n" diff --git a/libguile/simpos.h b/libguile/simpos.h index 1e2076870..9ebb0c52b 100644 --- a/libguile/simpos.h +++ b/libguile/simpos.h @@ -28,7 +28,6 @@ SCM_API SCM scm_system (SCM cmd); -SCM_API SCM scm_system_star (SCM cmds); SCM_API SCM scm_getenv (SCM nam); SCM_API SCM scm_primitive_exit (SCM status); SCM_API SCM scm_primitive__exit (SCM status); From 40c673446a01970b4146778651ad16f4d5441188 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Thu, 11 Aug 2016 17:06:10 -0500 Subject: [PATCH 496/865] Correct section number for "Input Ports" tests. * test-suite/tests/r6rs-ports.test: Correct "Input Ports" section heading from "7.2.7" -> "8.2.7", "7.2.5" -> "8.2.5", "7.2.8" -> "8.2.8", and "7.2.11" -> "8.2.11". --- test-suite/tests/r6rs-ports.test | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index b3f11bb20..9aa605bfe 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -74,7 +74,7 @@ receiver)))) -(with-test-prefix "7.2.5 End-of-File Object" +(with-test-prefix "8.2.5 End-of-File Object" (pass-if "eof-object" (and (eqv? (eof-object) (eof-object)) @@ -84,7 +84,7 @@ (port-eof? (open-input-string "")))) -(with-test-prefix "7.2.8 Binary Input" +(with-test-prefix "8.2.8 Binary Input" (pass-if "get-u8" (let ((port (open-input-string "A"))) @@ -236,7 +236,7 @@ (lambda () #t)) ;; close-port "rw"))) -(with-test-prefix "7.2.11 Binary Output" +(with-test-prefix "8.2.11 Binary Output" (pass-if "put-u8" (let ((port (make-soft-output-port))) @@ -328,7 +328,7 @@ (delete-file filename)) -(with-test-prefix "7.2.7 Input Ports" +(with-test-prefix "8.2.7 Input Ports" (with-test-prefix "open-file-input-port" (test-input-file-opener open-file-input-port (test-file))) From b9b235243eeb9ad8271bd2a0c9b0f5148cfba7fe Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Sat, 20 Aug 2016 16:20:53 -0500 Subject: [PATCH 497/865] Add tests for make-custom-binary-input/output-port * test-suite/tests/r6rs-ports.test ("8.2.13 Input/output ports"): Add tests for custom binary input/output ports, copied from existing binary input and binary output tests. --- test-suite/tests/r6rs-ports.test | 383 ++++++++++++++++++++++++++++++- 1 file changed, 382 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index 9aa605bfe..94d9fc072 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -1059,11 +1059,392 @@ not `set-port-position!'" values)) (delete-file filename))) +;; Used for a lot of the make-custom-input/output tests to stub out +;; the read/write section for whatever part we're ignoring +(define dummy-write! (const 0)) +(define dummy-read! (const 0)) + (with-test-prefix "8.2.13 Input/output ports" (with-test-prefix "open-file-input/output-port [output]" (test-output-file-opener open-file-input/output-port (test-file))) (with-test-prefix "open-file-input/output-port [input]" - (test-input-file-opener open-file-input/output-port (test-file)))) + (test-input-file-opener open-file-input/output-port (test-file))) + + ;; Custom binary input/output tests. Most of these are simple + ;; ports of the custom-binary-input-port tests or custom-binary-ouput-port + ;; tests, simply ported to use a custom-binary-input/output port. + ;; The copy-pasta is strong here; a diet lighter in spaghetti may wish + ;; to make the previous tests more reusable. + (pass-if "make-custom-binary-input/output-port" + (let* ((source (make-bytevector 7777)) + (read! (let ((pos 0) + (len (bytevector-length source))) + (lambda (bv start count) + (let ((amount (min count (- len pos)))) + (if (> amount 0) + (bytevector-copy! source pos + bv start amount)) + (set! pos (+ pos amount)) + amount)))) + (write! (lambda (x y z) 0)) + (port (make-custom-binary-input/output-port + "the port" read! write! + #f #f #f))) + (and (binary-port? port) + (input-port? port) + (output-port? port) + (bytevector=? (get-bytevector-all port) source) + (not (port-has-port-position? port)) + (not (port-has-set-port-position!? port))))) + + (pass-if-equal "make-custom-binary-input/output-port uses ISO-8859-1 (Guile \ +extension) [input]" + "©©" + (with-fluids ((%default-port-encoding "UTF-8")) + (let* ((source #vu8(194 169 194 169)) + (read! (let ((pos 0) + (len (bytevector-length source))) + (lambda (bv start count) + (let ((amount (min count (- len pos)))) + (if (> amount 0) + (bytevector-copy! source pos + bv start amount)) + (set! pos (+ pos amount)) + amount)))) + (port (make-custom-binary-input/output-port + "the port" read! dummy-write! + #f #f #f))) + (get-string-all port)))) + + (pass-if "custom binary input/output port does not support `port-position'" + (let* ((str "Hello Port!") + (source (open-bytevector-input-port + (u8-list->bytevector + (map char->integer (string->list str))))) + (read! (lambda (bv start count) + (let ((r (get-bytevector-n! source bv start count))) + (if (eof-object? r) + 0 + r)))) + (port (make-custom-binary-input/output-port + "the port" read! dummy-write! + #f #f #f))) + (not (or (port-has-port-position? port) + (port-has-set-port-position!? port))))) + + (pass-if-exception "custom binary input/output port 'read!' returns too much" + exception:out-of-range + ;; In Guile <= 2.0.9 this would segfault. + (let* ((read! (lambda (bv start count) + (+ count 4242))) + (port (make-custom-binary-input/output-port + "the port" read! dummy-write! + #f #f #f))) + (get-bytevector-all port))) + + (pass-if-equal "custom binary input/output port supports `port-position', \ +not `set-port-position!'" + 42 + (let ((port (make-custom-binary-input/output-port + "the port" (const 0) dummy-write! + (const 42) #f #f))) + (and (port-has-port-position? port) + (not (port-has-set-port-position!? port)) + (port-position port)))) + + (pass-if "custom binary input/output port supports `port-position'" + (let* ((str "Hello Port!") + (source (open-bytevector-input-port + (u8-list->bytevector + (map char->integer (string->list str))))) + (read! (lambda (bv start count) + (let ((r (get-bytevector-n! source bv start count))) + (if (eof-object? r) + 0 + r)))) + (get-pos (lambda () + (port-position source))) + (set-pos! (lambda (pos) + (set-port-position! source pos))) + (port (make-custom-binary-input/output-port + "the port" read! dummy-write! + get-pos set-pos! #f))) + + (and (port-has-port-position? port) + (= 0 (port-position port)) + (port-has-set-port-position!? port) + (begin + (set-port-position! port 6) + (= 6 (port-position port))) + (bytevector=? (get-bytevector-all port) + (u8-list->bytevector + (map char->integer (string->list "Port!"))))))) + + (pass-if-equal "custom binary input/output port buffered partial reads" + "Hello Port!" + ;; Check what happens when READ! returns less than COUNT bytes. + (let* ((src (string->utf8 "Hello Port!")) + (chunks '(2 4 5)) ; provide 2 bytes, then 4, etc. + (offset 0) + (read! (lambda (bv start count) + (match chunks + ((count rest ...) + (bytevector-copy! src offset bv start count) + (set! chunks rest) + (set! offset (+ offset count)) + count) + (() + 0)))) + (port (make-custom-binary-input/output-port + "the port" read! dummy-write! + #f #f #f))) + (get-string-all port))) + + (pass-if-equal "custom binary input/output port unbuffered & 'port-position'" + '(0 2 5 11) + ;; Check that the value returned by 'port-position' is correct, and + ;; that each 'port-position' call leads one call to the + ;; 'get-position' method. + (let* ((str "Hello Port!") + (output (make-bytevector (string-length str))) + (source (with-fluids ((%default-port-encoding "UTF-8")) + (open-string-input-port str))) + (read! (lambda (bv start count) + (let ((r (get-bytevector-n! source bv start count))) + (if (eof-object? r) + 0 + r)))) + (pos '()) + (get-pos (lambda () + (let ((p (port-position source))) + (set! pos (cons p pos)) + p))) + (port (make-custom-binary-input/output-port + "the port" read! dummy-write! + get-pos #f #f))) + (setvbuf port 'none) + (and (= 0 (port-position port)) + (begin + (get-bytevector-n! port output 0 2) + (= 2 (port-position port))) + (begin + (get-bytevector-n! port output 2 3) + (= 5 (port-position port))) + (let ((bv (string->utf8 (get-string-all port)))) + (bytevector-copy! bv 0 output 5 (bytevector-length bv)) + (= (string-length str) (port-position port))) + (bytevector=? output (string->utf8 str)) + (reverse pos)))) + + (pass-if-equal "custom binary input/output port unbuffered & 'read!' calls" + `((2 "He") (3 "llo") (42 " Port!")) + (let* ((str "Hello Port!") + (source (with-fluids ((%default-port-encoding "UTF-8")) + (open-string-input-port str))) + (reads '()) + (read! (lambda (bv start count) + (set! reads (cons count reads)) + (let ((r (get-bytevector-n! source bv start count))) + (if (eof-object? r) + 0 + r)))) + (port (make-custom-binary-input/output-port + "the port" read! dummy-write! + #f #f #f))) + + (setvbuf port 'none) + (let ((ret (list (get-bytevector-n port 2) + (get-bytevector-n port 3) + (get-bytevector-n port 42)))) + (zip (reverse reads) + (map (lambda (obj) + (if (bytevector? obj) + (utf8->string obj) + obj)) + ret))))) + + (pass-if-equal "custom binary input/output port unbuffered & 'get-string-all'" + (make-string 1000 #\a) + ;; In Guile 2.0.11 this test would lead to a buffer overrun followed + ;; by an assertion failure. See . + (let* ((input (with-fluids ((%default-port-encoding #f)) + (open-input-string (make-string 1000 #\a)))) + (read! (lambda (bv index count) + (let ((n (get-bytevector-n! input bv index + count))) + (if (eof-object? n) 0 n)))) + (port (make-custom-binary-input/output-port + "foo" read! dummy-write! + #f #f #f))) + (setvbuf port 'none) + (get-string-all port))) + + (pass-if-equal "custom binary input/output port unbuffered UTF-8 & \ +'get-string-all'" + (make-string 1000 #\λ) + ;; In Guile 2.0.11 this test would lead to a buffer overrun followed + ;; by an assertion failure. See . + (let* ((input (with-fluids ((%default-port-encoding "UTF-8")) + (open-input-string (make-string 1000 #\λ)))) + (read! (lambda (bv index count) + (let ((n (get-bytevector-n! input bv index + count))) + (if (eof-object? n) 0 n)))) + (port (make-custom-binary-input/output-port + "foo" read! dummy-write! + #f #f #f))) + (setvbuf port 'none) + (set-port-encoding! port "UTF-8") + (get-string-all port))) + + (pass-if-equal "custom binary input/output port, unbuffered then buffered" + `((6 "Lorem ") (12 "ipsum dolor ") (777 "sit amet, consectetur…") + (777 ,(eof-object))) + (let* ((str "Lorem ipsum dolor sit amet, consectetur…") + (source (with-fluids ((%default-port-encoding "UTF-8")) + (open-string-input-port str))) + (reads '()) + (read! (lambda (bv start count) + (set! reads (cons count reads)) + (let ((r (get-bytevector-n! source bv start count))) + (if (eof-object? r) + 0 + r)))) + (port (make-custom-binary-input/output-port + "the port" read! dummy-write! + #f #f #f))) + + (setvbuf port 'none) + (let ((ret (list (get-bytevector-n port 6) + (get-bytevector-n port 12) + (begin + (setvbuf port 'block 777) + (get-bytevector-n port 42)) + (get-bytevector-n port 42)))) + (zip (reverse reads) + (map (lambda (obj) + (if (bytevector? obj) + (utf8->string obj) + obj)) + ret))))) + + (pass-if-equal "custom binary input/output port, buffered then unbuffered" + `((18 + 42 14 ; scm_c_read tries to fill the 42-byte buffer + 42) + ("Lorem " "ipsum dolor " "sit amet, consectetur bla…" ,(eof-object))) + (let* ((str "Lorem ipsum dolor sit amet, consectetur bla…") + (source (with-fluids ((%default-port-encoding "UTF-8")) + (open-string-input-port str))) + (reads '()) + (read! (lambda (bv start count) + (set! reads (cons count reads)) + (let ((r (get-bytevector-n! source bv start count))) + (if (eof-object? r) + 0 + r)))) + (port (make-custom-binary-input/output-port + "the port" read! dummy-write! + #f #f #f))) + + (setvbuf port 'block 18) + (let ((ret (list (get-bytevector-n port 6) + (get-bytevector-n port 12) + (begin + (setvbuf port 'none) + (get-bytevector-n port 42)) + (get-bytevector-n port 42)))) + (list (reverse reads) + (map (lambda (obj) + (if (bytevector? obj) + (utf8->string obj) + obj)) + ret))))) + + (pass-if "custom binary input/output port `close-proc' is called" + (let* ((closed? #f) + (read! (lambda (bv start count) 0)) + (get-pos (lambda () 0)) + (set-pos! (lambda (pos) #f)) + (close! (lambda () (set! closed? #t))) + (port (make-custom-binary-input/output-port + "the port" read! dummy-write! + get-pos set-pos! close!))) + + (close-port port) + (gc) ; Test for marking a closed port. + closed?)) + + (pass-if "make-custom-binary-input/output-port [partial writes]" + (let* ((source (uint-list->bytevector (iota 333) + (native-endianness) 2)) + (sink (make-bytevector (bytevector-length source))) + (sink-pos 0) + (eof? #f) + (write! (lambda (bv start count) + (if (= 0 count) + (begin + (set! eof? #t) + 0) + (let ((u8 (bytevector-u8-ref bv start))) + ;; Get one byte at a time. + (bytevector-u8-set! sink sink-pos u8) + (set! sink-pos (+ 1 sink-pos)) + 1)))) + (port (make-custom-binary-input/output-port + "cbop" dummy-read! write! + #f #f #f))) + (put-bytevector port source) + (force-output port) + (and (= sink-pos (bytevector-length source)) + (not eof?) + (bytevector=? sink source)))) + + (pass-if "make-custom-binary-input/output-port [full writes]" + (let* ((source (uint-list->bytevector (iota 333) + (native-endianness) 2)) + (sink (make-bytevector (bytevector-length source))) + (sink-pos 0) + (eof? #f) + (write! (lambda (bv start count) + (if (= 0 count) + (begin + (set! eof? #t) + 0) + (begin + (bytevector-copy! bv start + sink sink-pos + count) + (set! sink-pos (+ sink-pos count)) + count)))) + (port (make-custom-binary-input/output-port + "cbop" dummy-read! write! + #f #f #f))) + (put-bytevector port source) + (force-output port) + (and (= sink-pos (bytevector-length source)) + (not eof?) + (bytevector=? sink source)))) + + (pass-if-equal "custom-binary-output-port uses ISO-8859-1 (Guile extension)\ + [output]" + '(194 169 194 169) + (with-fluids ((%default-port-encoding "UTF-8")) + (let* ((sink '()) + (write! (lambda (bv start count) + (if (= 0 count) ; EOF + 0 + (let ((u8 (bytevector-u8-ref bv start))) + ;; Get one byte at a time. + (set! sink (cons u8 sink)) + 1)))) + (port (make-custom-binary-input/output-port + "cbop" dummy-read! write! + #f #f #f))) + (put-string port "©©") + (force-output port) + (reverse sink)))) + ) (define exception:encoding-error '(encoding-error . "")) From 9996695f88b19a48bd8d50b84f85509b8626fb01 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 31 Aug 2016 11:55:26 +0200 Subject: [PATCH 498/865] Require C99 to build Guile. * configure.ac: Require C99 or later. Emacs does, therefore so can we. Note that by default GCC compiles in "gnu11" mode these days, and this declaration doesn't change that. --- configure.ac | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index c2c7f52ad..435bc4e28 100644 --- a/configure.ac +++ b/configure.ac @@ -83,7 +83,8 @@ AC_DEFINE([GNULIB_LOCK], [1], [Define to allow Gnulib modules to use Guile's locks.]) -AC_PROG_CC_C89 +dnl Guile needs C99 or later. +gl_PROG_CC_C99 # for per-target cflags in the libguile subdir AM_PROG_CC_C_O From eeb23e776abc7ec4ae6c71cf4d53814e38695d8e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 31 Aug 2016 15:39:01 +0200 Subject: [PATCH 499/865] Avoid flushing buffers for ftell * libguile/ports.c (scm_seek): Avoid flushing buffers for an ftell. Also allows non-random-access ports to ftell() if they have a seek implementation, as is the case for custom binary ports with a get-position function but no set-position function. * test-suite/tests/ports.test: Adapt expectations, reverting changes made in April by me in b77fb752dd7e14876741ecb6360ef0319eae18e0. --- libguile/ports.c | 14 +++++++++++--- test-suite/tests/ports.test | 8 ++++---- 2 files changed, 15 insertions(+), 7 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 434e48e54..9e5211f62 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -3544,13 +3544,21 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset); off_t_or_off64_t rv; + if (ptob->seek && how == SEEK_CUR && off == 0) + { + /* If we are just querying the current position, avoid + flushing buffers. We don't even need to require that the + port supports random access. */ + rv = ptob->seek (fd_port, off, how); + rv -= scm_port_buffer_can_take (pt->read_buf); + rv += scm_port_buffer_can_take (pt->write_buf); + return scm_from_off_t_or_off64_t (rv); + } + if (!ptob->seek || !pt->rw_random) SCM_MISC_ERROR ("port is not seekable", scm_cons (fd_port, SCM_EOL)); - /* FIXME: Avoid flushing buffers for SEEK_CUR with an offset of - 0. */ - scm_end_input (fd_port); scm_flush (fd_port); diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index ea8eaa796..86165fdef 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -177,8 +177,8 @@ (unread-char #\z iport) (pass-if "file: in tell 0 after unread" (= (seek iport 0 SEEK_CUR) 0)) - (pass-if "file: putback buffer flushed after seek" - (char=? (read-char iport) #\J)) + (pass-if "file: unread char still there" + (char=? (read-char iport) #\z)) (seek iport 7 SEEK_SET) (pass-if "file: in last char" (char=? (read-char iport) #\x)) @@ -699,8 +699,8 @@ (unread-char #\x p) (pass-if "input tell back to 0" (= (seek p 0 SEEK_CUR) 0)) - (pass-if "putback buffer discarded after seek" - (char=? (read-char p) #\t)) + (pass-if "input ungetted char" + (char=? (read-char p) #\x)) (seek p 0 SEEK_END) (pass-if "input seek to end" (= (seek p 0 SEEK_CUR) From f46cb25a17fd9b014e2d7ad0b2d27c5dd94688cd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 31 Aug 2016 15:42:51 +0200 Subject: [PATCH 500/865] Set rw_random correctly for all custom binary port types * libguile/r6rs-ports.c (custom_binary_port_random_access_p): Rename from custom_binary_input_output_port_type, and use for all custom binary port types. --- libguile/r6rs-ports.c | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index b52eb85d2..674d89aaa 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -193,6 +193,14 @@ struct custom_binary_port { SCM close; }; +static int +custom_binary_port_random_access_p (SCM port) +{ + struct custom_binary_port *stream = (void *) SCM_STREAM (port); + + return scm_is_true (stream->set_position_x); +} + static scm_t_off custom_binary_port_seek (SCM port, scm_t_off offset, int whence) #define FUNC_NAME "custom_binary_port_seek" @@ -336,6 +344,8 @@ initialize_custom_binary_input_ports (void) custom_binary_input_port_read, NULL); scm_set_port_seek (custom_binary_input_port_type, custom_binary_port_seek); + scm_set_port_random_access_p (custom_binary_input_port_type, + custom_binary_port_random_access_p); scm_set_port_close (custom_binary_input_port_type, custom_binary_port_close); } @@ -942,6 +952,8 @@ initialize_custom_binary_output_ports (void) NULL, custom_binary_output_port_write); scm_set_port_seek (custom_binary_output_port_type, custom_binary_port_seek); + scm_set_port_random_access_p (custom_binary_output_port_type, + custom_binary_port_random_access_p); scm_set_port_close (custom_binary_output_port_type, custom_binary_port_close); } @@ -1004,15 +1016,6 @@ SCM_DEFINE (scm_make_custom_binary_input_output_port, #undef FUNC_NAME -static int -custom_binary_input_output_port_random_access_p (SCM port) -{ - struct custom_binary_port *stream = (void *) SCM_STREAM (port); - - return scm_is_true (stream->set_position_x); -} - - /* Instantiate the custom binary input_output port type. */ static inline void initialize_custom_binary_input_output_ports (void) @@ -1025,7 +1028,7 @@ initialize_custom_binary_input_output_ports (void) scm_set_port_seek (custom_binary_input_output_port_type, custom_binary_port_seek); scm_set_port_random_access_p (custom_binary_input_output_port_type, - custom_binary_input_output_port_random_access_p); + custom_binary_port_random_access_p); scm_set_port_close (custom_binary_input_output_port_type, custom_binary_port_close); } From cc9e72bd2b896048af2a65c8af9a57868df4352f Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Thu, 11 Aug 2016 15:10:19 -0500 Subject: [PATCH 501/865] Fix example in make-custom-binary-input-port documentation * doc/ref/api-io.texi (Custom Ports): Add additional argument to example's invocation of make-custom-binary-input-port. Previously had mismatched arity by missing "closed" argument. --- doc/ref/api-io.texi | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 76c8db806..e4e4f36ab 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. @c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2009, -@c 2010, 2011, 2013 Free Software Foundation, Inc. +@c 2010, 2011, 2013, 2016 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Input and Output @@ -1278,8 +1278,8 @@ procedure (@pxref{Bytevector Ports}) could be implemented as follows: (set! position new-position)) (make-custom-binary-input-port "the port" read! - get-position - set-position!)) + get-position set-position! + #f)) (read (open-bytevector-input-port (string->utf8 "hello"))) @result{} hello From b8a53b98b33dc89b0ed526ca66232655d24f2ce8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 31 Aug 2016 19:00:27 +0200 Subject: [PATCH 502/865] Only ptob->close() after read/write finish * libguile/Makefile.am (noinst_HEADERS): Add atomics-internal.h. * libguile/atomics-internal.h: New file. * libguile/ports-internal.h (refcount): New member. * libguile/ports.c (release_port, scm_dynwind_acquire_port): New facility for acquiring a port within a dynwind. (scm_port_poll, scm_i_read_bytes, scm_setvbuf, scm_end_input) (scm_i_write_bytes, scm_char_ready_p, scm_seek) (scm_truncate_file, trampoline_to_c_read) (trampoline_to_c_write): Acquire port. (scm_c_make_port_with_encoding): Init refcount to 1. (scm_close_port): Release port. * doc/ref/api-io.texi (I/O Extensions): Add documentation --- doc/ref/api-io.texi | 7 ++ libguile/Makefile.am | 1 + libguile/atomics-internal.h | 85 ++++++++++++++++++++++ libguile/ports-internal.h | 13 +++- libguile/ports.c | 138 +++++++++++++++++++++++++++++------- 5 files changed, 216 insertions(+), 28 deletions(-) create mode 100644 libguile/atomics-internal.h diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index e4e4f36ab..9facb38e0 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -1694,6 +1694,13 @@ operating system inform Guile about the appropriate buffer sizes for the particular file opened by the port. @end table +Note that calls to all of these methods can proceed in parallel and +concurrently and from any thread up until the point that the port is +closed. The call to @code{close} will happen when no other method is +running, and no method will be called after the @code{close} method is +called. If your port implementation needs mutual exclusion to prevent +concurrency, it is responsible for locking appropriately. + @node Non-Blocking I/O @subsection Non-Blocking I/O diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 8161ade4e..ba6be2019 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -507,6 +507,7 @@ noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \ elf.h \ srfi-14.i.c \ quicksort.i.c \ + atomics-internal.h \ posix-w32.h \ private-options.h ports-internal.h diff --git a/libguile/atomics-internal.h b/libguile/atomics-internal.h new file mode 100644 index 000000000..1859daa92 --- /dev/null +++ b/libguile/atomics-internal.h @@ -0,0 +1,85 @@ +#ifndef SCM_ATOMICS_INTERNAL_H +#define SCM_ATOMICS_INTERNAL_H + +/* Copyright (C) 2016 + * 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 License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + + + + +#include + + + + +#define HAVE_C11_ATOMICS (__STDC_VERSION__ >= 201112L && !defined(__STDC_NO_ATOMICS__)) + +#if HAVE_C11_ATOMICS + +#include +static inline uint32_t +scm_atomic_subtract_uint32 (uint32_t *obj, uint32_t arg) +{ + return atomic_fetch_sub (obj, arg); +} +static inline _Bool +scm_atomic_compare_and_swap_uint32 (uint32_t *obj, uint32_t *expected, + uint32_t desired) +{ + return atomic_compare_exchange_weak (obj, expected, desired); +} + +#else /* HAVE_C11_ATOMICS */ + +/* Fallback implementation using locks. */ +#include "libguile/threads.h" +static scm_i_pthread_mutex_t atomics_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; +static inline uint32_t +scm_atomic_subtract_uint32 (uint32_t *obj, uint32_t arg) +{ + uint32_t ret; + scm_i_pthread_mutex_lock (&atomics_lock); + ret = *obj; + *obj -= arg; + scm_i_pthread_mutex_unlock (&atomics_lock); + return ret; +} +static inline int +scm_atomic_compare_and_swap_uint32 (uint32_t *obj, uint32_t *expected, + uint32_t desired) +{ + int ret; + scm_i_pthread_mutex_lock (&atomics_lock); + if (*obj == *expected) + { + *obj = desired; + ret = 1; + } + else + { + *expected = *obj; + ret = 0; + } + scm_i_pthread_mutex_unlock (&atomics_lock); + return ret; +} + +#endif /* HAVE_C11_ATOMICS */ + +#endif /* SCM_ATOMICS_INTERNAL_H */ diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index d01441562..4203a5c51 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -323,12 +323,19 @@ struct scm_t_port `unwrite-byte'. */ size_t read_buffering; + /* Reads and writes can proceed concurrently, but we don't want to + start any read or write after close() has been called. So we have + a refcount which is positive if close has not yet been called. + Reading, writing, and the like temporarily increments this + refcount, provided it was nonzero to start with. */ + scm_t_uint32 refcount; + /* True if the port is random access. Implies that the buffers must be flushed before switching between reading and writing, seeking, and so on. */ - unsigned rw_random : 1; - unsigned at_stream_start_for_bom_read : 1; - unsigned at_stream_start_for_bom_write : 1; + scm_t_uint32 rw_random : 1; + scm_t_uint32 at_stream_start_for_bom_read : 1; + scm_t_uint32 at_stream_start_for_bom_write : 1; /* Character encoding support. */ SCM encoding; /* A symbol of upper-case ASCII. */ diff --git a/libguile/ports.c b/libguile/ports.c index 9e5211f62..278bbe9e7 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -27,6 +27,7 @@ # include #endif +#include #include #include #include /* for chsize on mingw */ @@ -37,10 +38,9 @@ #include #include -#include - #include "libguile/_scm.h" #include "libguile/async.h" +#include "libguile/atomics-internal.h" #include "libguile/deprecation.h" #include "libguile/eval.h" #include "libguile/fports.h" /* direct access for seek and truncate */ @@ -131,6 +131,63 @@ static const scm_t_wchar UNICODE_REPLACEMENT_CHARACTER = 0xFFFD; +static void +release_port (SCM port) +{ + scm_t_port *pt = SCM_PORT (port); + scm_t_uint32 prev; + + prev = scm_atomic_subtract_uint32 (&pt->refcount, 1); + if (prev == 0) + /* Logic failure. */ + abort (); + + if (prev > 1) + /* Port still alive. */ + return; + + /* FIXME: `catch' around the close call? It could throw an exception, + and in that case we'd leak the iconv descriptors, if any. */ + if (SCM_PORT_TYPE (port)->close) + SCM_PORT_TYPE (port)->close (port); + + scm_i_pthread_mutex_lock (&iconv_lock); + pt = SCM_PORT (port); + if (scm_is_true (pt->precise_encoding)) + { + if (pt->input_cd != (iconv_t) -1) + iconv_close (pt->input_cd); + if (pt->output_cd != (iconv_t) -1) + iconv_close (pt->output_cd); + pt->precise_encoding = SCM_BOOL_F; + pt->input_cd = pt->output_cd = (iconv_t) -1; + } + scm_i_pthread_mutex_unlock (&iconv_lock); +} + +static void +scm_dynwind_acquire_port (SCM port) +{ + scm_t_port *pt = SCM_PORT (port); + /* We're acquiring a lease on the port so that we only close it when + no one is using it. The normal case is that it's open with a + refcount of 1 and we're going to push it to 2. Otherwise perhaps + there is someone else using it; that's fine, we just add our + refcount. However if the current refcount is 0 then the port has + been closed or is closing and we must throw an error. */ + scm_t_uint32 cur = 1, next = 2; + while (!scm_atomic_compare_and_swap_uint32 (&pt->refcount, &cur, next)) + { + if (cur == 0) + scm_wrong_type_arg_msg (NULL, 0, port, "open port"); + next = cur + 1; + } + scm_dynwind_unwind_handler_with_scm (release_port, port, + SCM_F_WIND_EXPLICITLY); +} + + + static SCM trampoline_to_c_read_subr; static SCM trampoline_to_c_write_subr; @@ -191,7 +248,10 @@ trampoline_to_c_read (SCM port, SCM dst, SCM start, SCM count) SCM_ASSERT_RANGE (3, start, c_start <= SCM_BYTEVECTOR_LENGTH (dst)); SCM_ASSERT_RANGE (4, count, c_count <= SCM_BYTEVECTOR_LENGTH (dst) - c_start); + scm_dynwind_begin (0); + scm_dynwind_acquire_port (port); ret = SCM_PORT_TYPE (port)->c_read (port, dst, c_start, c_count); + scm_dynwind_end (); return ret == (size_t) -1 ? SCM_BOOL_F : scm_from_size_t (ret); } @@ -218,7 +278,10 @@ trampoline_to_c_write (SCM port, SCM src, SCM start, SCM count) SCM_ASSERT_RANGE (3, start, c_start <= SCM_BYTEVECTOR_LENGTH (src)); SCM_ASSERT_RANGE (4, count, c_count <= SCM_BYTEVECTOR_LENGTH (src) - c_start); + scm_dynwind_begin (0); + scm_dynwind_acquire_port (port); ret = SCM_PORT_TYPE (port)->c_write (port, src, c_start, c_count); + scm_dynwind_end (); return ret == (size_t) -1 ? SCM_BOOL_F : scm_from_size_t (ret); } @@ -691,6 +754,8 @@ scm_c_make_port_with_encoding (scm_t_port_type *ptob, unsigned long mode_bits, pt->file_name = SCM_BOOL_F; pt->position = scm_cons (SCM_INUM0, SCM_INUM0); + pt->refcount = 1; + pt->at_stream_start_for_bom_read = 1; pt->at_stream_start_for_bom_write = 1; @@ -797,11 +862,9 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, "descriptors.") #define FUNC_NAME s_scm_close_port { - scm_t_port *pt; - port = SCM_COERCE_OUTPORT (port); - SCM_VALIDATE_PORT (1, port); + if (SCM_CLOSEDP (port)) return SCM_BOOL_F; @@ -809,28 +872,12 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, if (SCM_OUTPUT_PORT_P (port)) scm_flush (port); - pt = SCM_PORT (port); SCM_CLR_PORT_OPEN_FLAG (port); if (SCM_PORT_TYPE (port)->flags & SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC) scm_weak_set_remove_x (scm_i_port_weak_set, port); - if (SCM_PORT_TYPE (port)->close) - /* Note! This may throw an exception. Anything after this point - should be resilient to non-local exits. */ - SCM_PORT_TYPE (port)->close (port); - - scm_i_pthread_mutex_lock (&iconv_lock); - if (scm_is_true (pt->precise_encoding)) - { - if (pt->input_cd != (iconv_t) -1) - iconv_close (pt->input_cd); - if (pt->output_cd != (iconv_t) -1) - iconv_close (pt->output_cd); - pt->precise_encoding = SCM_BOOL_F; - pt->input_cd = pt->output_cd = (iconv_t) -1; - } - scm_i_pthread_mutex_unlock (&iconv_lock); + release_port (port); return SCM_BOOL_T; } @@ -1314,6 +1361,7 @@ SCM_DEFINE (scm_port_write_wait_fd, "port-write-wait-fd", 1, 0, 0, } #undef FUNC_NAME +/* Call while having acquired the port. */ static int port_poll (SCM port, short events, int timeout) #define FUNC_NAME "port-poll" @@ -1358,6 +1406,7 @@ SCM_DEFINE (scm_port_poll, "port-poll", 2, 1, 0, { short c_events = 0; int c_timeout; + SCM ret; port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_PORT (1, port); @@ -1371,7 +1420,12 @@ SCM_DEFINE (scm_port_poll, "port-poll", 2, 1, 0, if (scm_i_string_contains_char (events, 'w')) c_events |= POLLIN; - return scm_from_int (port_poll (port, c_events, c_timeout)); + scm_dynwind_begin (0); + scm_dynwind_acquire_port (port); + ret = scm_from_int (port_poll (port, c_events, c_timeout)); + scm_dynwind_end (); + + return ret; } #undef FUNC_NAME @@ -1476,6 +1530,9 @@ scm_i_read_bytes (SCM port, SCM dst, size_t start, size_t count) assert (count <= SCM_BYTEVECTOR_LENGTH (dst)); assert (start + count <= SCM_BYTEVECTOR_LENGTH (dst)); + scm_dynwind_begin (0); + scm_dynwind_acquire_port (port); + retry: filled = ptob->c_read (port, dst, start, count); @@ -1485,6 +1542,8 @@ scm_i_read_bytes (SCM port, SCM dst, size_t start, size_t count) goto retry; } + scm_dynwind_end (); + assert (filled <= count); return filled; @@ -2220,8 +2279,11 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, else { read_buf_size = write_buf_size = default_buffer_size; + scm_dynwind_begin (0); + scm_dynwind_acquire_port (port); if (ptob->get_natural_buffer_sizes) ptob->get_natural_buffer_sizes (port, &read_buf_size, &write_buf_size); + scm_dynwind_end (); } /* Minimum buffer size is one byte. */ @@ -2310,7 +2372,12 @@ scm_end_input (SCM port) offset = - (scm_t_off) discarded; if (offset != 0) - SCM_PORT_TYPE (port)->seek (port, offset, SEEK_CUR); + { + scm_dynwind_begin (0); + scm_dynwind_acquire_port (port); + SCM_PORT_TYPE (port)->seek (port, offset, SEEK_CUR); + scm_dynwind_end (); + } } SCM_DEFINE (scm_force_output, "force-output", 0, 1, 0, @@ -2722,6 +2789,9 @@ scm_i_write_bytes (SCM port, SCM src, size_t start, size_t count) assert (count <= SCM_BYTEVECTOR_LENGTH (src)); assert (start + count <= SCM_BYTEVECTOR_LENGTH (src)); + scm_dynwind_begin (0); + scm_dynwind_acquire_port (port); + do { size_t ret = ptob->c_write (port, src, start + written, count - written); @@ -2733,6 +2803,8 @@ scm_i_write_bytes (SCM port, SCM src, size_t start, size_t count) } while (written < count); + scm_dynwind_end (); + assert (written == count); } @@ -3495,7 +3567,14 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, scm_t_port_type *ptob = SCM_PORT_TYPE (port); if (ptob->input_waiting) - return scm_from_bool (ptob->input_waiting (port)); + { + SCM ret; + scm_dynwind_begin (0); + scm_dynwind_acquire_port (port); + ret = scm_from_bool (ptob->input_waiting (port)); + scm_dynwind_end (); + return ret; + } else return SCM_BOOL_T; } @@ -3549,7 +3628,10 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, /* If we are just querying the current position, avoid flushing buffers. We don't even need to require that the port supports random access. */ + scm_dynwind_begin (0); + scm_dynwind_acquire_port (fd_port); rv = ptob->seek (fd_port, off, how); + scm_dynwind_end (); rv -= scm_port_buffer_can_take (pt->read_buf); rv += scm_port_buffer_can_take (pt->write_buf); return scm_from_off_t_or_off64_t (rv); @@ -3562,7 +3644,10 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, scm_end_input (fd_port); scm_flush (fd_port); + scm_dynwind_begin (0); + scm_dynwind_acquire_port (fd_port); rv = ptob->seek (fd_port, off, how); + scm_dynwind_end (); /* Set stream-start flags according to new position. */ pt->at_stream_start_for_bom_read = (rv == 0); @@ -3668,7 +3753,10 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0, scm_end_input (object); scm_flush (object); + scm_dynwind_begin (0); + scm_dynwind_acquire_port (object); ptob->truncate (object, c_length); + scm_dynwind_end (); rv = 0; } else From b733ca461ce03c6daeadca0f2eb4da13ccdd2930 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 31 Aug 2016 19:31:12 +0200 Subject: [PATCH 503/865] GC of non-blocking port does not block * libguile/ports.h (SCM_F_PORT_FINALIZING) (SCM_PORT_FINALIZING_P, SCM_SET_PORT_FINALIZING): New private definitions. * libguile/ports.c (finalize_port): Set the port-finalizing flag. (scm_i_write_bytes): If the port is finalizing but output returned EWOULDBLOCK, warn and discard the output. --- libguile/ports.c | 27 ++++++++++++++++++++++++++- libguile/ports.h | 19 ++++++++++++++----- 2 files changed, 40 insertions(+), 6 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 278bbe9e7..1209b439a 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -691,6 +691,7 @@ finalize_port (void *ptr, void *data) if (SCM_OPENP (port)) { + SCM_SET_PORT_FINALIZING (port); scm_internal_catch (SCM_BOOL_T, do_close, ptr, scm_handle_by_message_noexit, NULL); scm_gc_ports_collected++; @@ -2797,7 +2798,31 @@ scm_i_write_bytes (SCM port, SCM src, size_t start, size_t count) size_t ret = ptob->c_write (port, src, start + written, count - written); if (ret == (size_t) -1) - port_poll (port, POLLOUT, -1); + { + if (SCM_PORT_FINALIZING_P (port)) + { + /* This port is being closed because it became unreachable + and was finalized, but it has buffered output, and the + resource is not currently writable. Instead of + blocking, discard buffered output and warn. To avoid + this situation, force-output on the port before letting + it go! */ + scm_puts + ("Warning: Discarding buffered output on non-blocking port\n" + " ", + scm_current_warning_port ()); + scm_display (port, scm_current_warning_port()); + scm_puts + ("\n" + " closed by the garbage collector. To avoid this\n" + " behavior and this warning, call `force-output' or\n" + " `close-port' on the port before letting go of it.\n", + scm_current_warning_port ()); + break; + } + else + port_poll (port, POLLOUT, -1); + } else written += ret; } diff --git a/libguile/ports.h b/libguile/ports.h index 6fe9ecd2b..93a1a59de 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -52,11 +52,14 @@ SCM_INTERNAL SCM scm_i_port_weak_set; there is a flag indicating whether the port is open or not, and then some "mode bits": flags indicating whether the port is an input and/or an output port and how Guile should buffer the port. */ -#define SCM_OPN (1U<<16) /* Is the port open? */ -#define SCM_RDNG (1U<<17) /* Is it a readable port? */ -#define SCM_WRTNG (1U<<18) /* Is it writable? */ -#define SCM_BUF0 (1U<<19) /* Is it unbuffered? */ -#define SCM_BUFLINE (1U<<20) /* Is it line-buffered? */ +#define SCM_OPN (1U<<8) /* Is the port open? */ +#define SCM_RDNG (1U<<9) /* Is it a readable port? */ +#define SCM_WRTNG (1U<<10) /* Is it writable? */ +#define SCM_BUF0 (1U<<11) /* Is it unbuffered? */ +#define SCM_BUFLINE (1U<<12) /* Is it line-buffered? */ +#ifdef BUILDING_LIBGUILE +#define SCM_F_PORT_FINALIZING (1U<<13) /* Port is being closed via GC. */ +#endif #define SCM_PORTP(x) (SCM_HAS_TYP7 (x, scm_tc7_port)) #define SCM_OPPORTP(x) (SCM_PORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_OPN)) @@ -68,6 +71,12 @@ SCM_INTERNAL SCM scm_i_port_weak_set; #define SCM_CLOSEDP(x) (!SCM_OPENP (x)) #define SCM_CLR_PORT_OPEN_FLAG(p) \ SCM_SET_CELL_WORD_0 ((p), SCM_CELL_WORD_0 (p) & ~SCM_OPN) +#ifdef BUILDING_LIBGUILE +#define SCM_PORT_FINALIZING_P(x) \ + (SCM_CELL_WORD_0 (x) & SCM_F_PORT_FINALIZING) +#define SCM_SET_PORT_FINALIZING(p) \ + SCM_SET_CELL_WORD_0 ((p), SCM_CELL_WORD_0 (p) | SCM_F_PORT_FINALIZING) +#endif typedef struct scm_t_port_type scm_t_port_type; typedef struct scm_t_port scm_t_port; From 49d77b1243aecfd250e4f6160c66603555c4e86a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 1 Sep 2016 10:51:57 +0200 Subject: [PATCH 504/865] Add unboxed logxor on u64 values * libguile/vm-engine.c (ulogxor): New instruction. * module/language/cps/effects-analysis.scm (ulogxor): * module/language/cps/slot-allocation.scm (compute-var-representations): * module/language/cps/types.scm (ulogxor): * module/system/vm/assembler.scm (emit-ulogxor): Add support for new instruction. * doc/ref/vm.texi (Unboxed Integer Arithmetic): Document ulogxor. --- doc/ref/vm.texi | 5 +++-- libguile/vm-engine.c | 17 ++++++++++++++++- module/language/cps/effects-analysis.scm | 1 + module/language/cps/slot-allocation.scm | 2 +- module/language/cps/types.scm | 6 ++++++ module/system/vm/assembler.scm | 1 + 6 files changed, 28 insertions(+), 4 deletions(-) diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 4505a019c..2f32c511f 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -1565,9 +1565,10 @@ operand is an immediate unsigned 8-bit integer. @deftypefn Instruction {} ulogand s8:@var{dst} s8:@var{a} s8:@var{b} @deftypefnx Instruction {} ulogior s8:@var{dst} s8:@var{a} s8:@var{b} +@deftypefnx Instruction {} ulogxor s8:@var{dst} s8:@var{a} s8:@var{b} @deftypefnx Instruction {} ulogsub s8:@var{dst} s8:@var{a} s8:@var{b} -Like @code{logand}, @code{logior}, and @code{logsub}, but operating on -unboxed unsigned 64-bit integers. +Like @code{logand}, @code{logior}, @code{logxor}, and @code{logsub}, but +operating on unboxed unsigned 64-bit integers. @end deftypefn @deftypefn Instruction {} ulsh s8:@var{dst} s8:@var{a} s8:@var{b} diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 4b5b70bd2..f508cd2f2 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -3802,7 +3802,22 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (1); } - VM_DEFINE_OP (177, unused_177, NULL, NOP) + /* ulogxor dst:8 a:8 b:8 + * + * Place the bitwise exclusive OR of the u64 values in A and B into + * DST. + */ + VM_DEFINE_OP (177, ulogxor, "ulogxor", OP1 (X8_S8_S8_S8) | OP_DST) + { + scm_t_uint8 dst, a, b; + + UNPACK_8_8_8 (op, dst, a, b); + + SP_SET_U64 (dst, SP_REF_U64 (a) ^ SP_REF_U64 (b)); + + NEXT (1); + } + VM_DEFINE_OP (178, unused_178, NULL, NOP) VM_DEFINE_OP (179, unused_179, NULL, NOP) VM_DEFINE_OP (180, unused_180, NULL, NOP) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 5698fcd57..aed47d464 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -475,6 +475,7 @@ is or might be a read or a write to the same location as A." ((lognot . _) &type-check) ((ulogand . _)) ((ulogior . _)) + ((ulogxor . _)) ((ulogsub . _)) ((ursh . _)) ((ulsh . _)) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 654dbda39..32f0ace99 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -805,7 +805,7 @@ are comparable with eqv?. A tmp slot may be used." 'char->integer 'bv-length 'vector-length 'string-length 'uadd 'usub 'umul - 'ulogand 'ulogior 'ulogsub 'ursh 'ulsh + 'ulogand 'ulogior 'ulogxor 'ulogsub 'ursh 'ulsh 'uadd/immediate 'usub/immediate 'umul/immediate 'ursh/immediate 'ulsh/immediate 'bv-u8-ref 'bv-u16-ref 'bv-u32-ref 'bv-u64-ref)) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 633fef51b..266cb743d 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -1356,6 +1356,12 @@ minimum, and maximum." ;; For our purposes, treat logxor the same as logior. (define-type-aliases logior logxor) +(define-simple-type-checker (ulogxor &u64 &u64)) +(define-type-inferrer (ulogxor a b result) + (restrict! a &u64 0 &u64-max) + (restrict! b &u64 0 &u64-max) + (define! result &u64 0 &u64-max)) + (define-simple-type-checker (lognot &exact-integer)) (define-type-inferrer (lognot a result) (restrict! a &exact-integer -inf.0 +inf.0) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 20a652c66..c9ef5f191 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -161,6 +161,7 @@ emit-logsub emit-ulogand emit-ulogior + emit-ulogxor emit-ulogsub emit-ursh emit-ulsh From 723efdfc44695dbc816ede8373b5cab4951ad3b2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 1 Sep 2016 10:54:31 +0200 Subject: [PATCH 505/865] Fabricated expression tweak in CSE * module/language/cps/cse.scm (compute-equivalent-subexpressions): u64->scm fabricates equivalence for scm->u64/truncate too. --- module/language/cps/cse.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index c8a5ad30c..e37e8d487 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -314,7 +314,8 @@ false. It could be that both true and false proofs are available." (('primcall 'u64->scm u64) (match defs ((scm) - (add-def! `(primcall scm->u64 ,scm) u64)))) + (add-def! `(primcall scm->u64 ,scm) u64) + (add-def! `(primcall scm->u64/truncate ,scm) u64)))) (('primcall 'scm->s64 scm) (match defs ((s64) From 0f2f5949a21572fad8355473200c7adc6d74f882 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 1 Sep 2016 10:55:45 +0200 Subject: [PATCH 506/865] Better unboxing * module/language/cps/specialize-numbers.scm (truncate-u64): New helper, truncates a SCM value. (specialize-u64-binop): Add ulogxor case. (sigbits-union, sigbits-intersect, sigbits-intersect3) (next-power-of-two, range->sigbits, inferred-sigbits) (significant-bits-handlers, define-significant-bits-handler): (significant-bits-handler, compute-significant-bits): Add facility to compute the bits in a value that are significant. (specialize-operations): Unbox in more cases, when only u64 bits are significant. Unbox logxor. Elide logand where it has no effect. --- module/language/cps/specialize-numbers.scm | 280 ++++++++++++++++----- 1 file changed, 211 insertions(+), 69 deletions(-) diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm index 24ce2095b..d9fe76cac 100644 --- a/module/language/cps/specialize-numbers.scm +++ b/module/language/cps/specialize-numbers.scm @@ -90,6 +90,7 @@ ('mul 'umul) ('logand 'ulogand) ('logior 'ulogior) + ('logxor 'ulogxor) ('logsub 'ulogsub) ('rsh 'ursh) ('lsh 'ulsh)))) @@ -108,6 +109,16 @@ ($continue kunbox-b src ($primcall unbox-a (a))))))) +(define (truncate-u64 cps k src scm) + (with-cps cps + (letv u64) + (letk kbox ($kargs ('u64) (u64) + ($continue k src + ($primcall 'u64->scm (u64))))) + (build-term + ($continue kbox src + ($primcall 'scm->u64/truncate (scm)))))) + (define (specialize-u64-comparison cps kf kt src op a b) (let ((op (symbol-append 'u64- op))) (with-cps cps @@ -133,8 +144,123 @@ ($continue kop src ($primcall 'scm->u64 (a-u64))))))) +(define (sigbits-union x y) + (and x y (logior x y))) + +(define (sigbits-intersect x y) + (cond + ((not x) y) + ((not y) x) + (else (logand x y)))) + +(define (sigbits-intersect3 a b c) + (sigbits-intersect a (sigbits-intersect b c))) + +(define (next-power-of-two n) + (let lp ((out 1)) + (if (< n out) + out + (lp (ash out 1))))) + +(define (range->sigbits min max) + (cond + ((or (< min 0) (> max #xffffFFFFffffFFFF)) #f) + ((eqv? min max) min) + (else (1- (next-power-of-two max))))) + +(define (inferred-sigbits types label var) + (call-with-values (lambda () (lookup-pre-type types label var)) + (lambda (type min max) + (and (or (eqv? type &exact-integer) (eqv? type &u64)) + (range->sigbits min max))))) + +(define significant-bits-handlers (make-hash-table)) +(define-syntax-rule (define-significant-bits-handler + ((primop label types out def ...) arg ...) + body ...) + (hashq-set! significant-bits-handlers 'primop + (lambda (label types out args defs) + (match args ((arg ...) (match defs ((def ...) body ...))))))) + +(define-significant-bits-handler ((logand label types out res) a b) + (let ((sigbits (sigbits-intersect3 (inferred-sigbits types label a) + (inferred-sigbits types label b) + (intmap-ref out res (lambda (_) 0))))) + (intmap-add (intmap-add out a sigbits sigbits-union) + b sigbits sigbits-union))) + +(define (significant-bits-handler primop) + (hashq-ref significant-bits-handlers primop)) + +(define (compute-significant-bits cps types kfun) + "Given the locally inferred types @var{types}, compute a map of VAR -> +BITS indicating the significant bits needed for a variable. BITS may be +#f to indicate all bits, or a non-negative integer indicating a bitmask." + (let ((preds (invert-graph (compute-successors cps kfun)))) + (let lp ((worklist (intmap-keys preds)) (out empty-intmap)) + (match (intset-prev worklist) + (#f out) + (label + (let ((worklist (intset-remove worklist label))) + (define (continue out*) + (if (eq? out out*) + (lp worklist out) + (lp (intset-union worklist (intmap-ref preds label)) out*))) + (define (add-def out var) + (intmap-add out var 0 sigbits-union)) + (define (add-defs out vars) + (match vars + (() out) + ((var . vars) (add-defs (add-def out var) vars)))) + (define (add-unknown-use out var) + (intmap-add out var (inferred-sigbits types label var) + sigbits-union)) + (define (add-unknown-uses out vars) + (match vars + (() out) + ((var . vars) + (add-unknown-uses (add-unknown-use out var) vars)))) + (continue + (match (intmap-ref cps label) + (($ $kfun src meta self) + (add-def out self)) + (($ $kargs names vars ($ $continue k src exp)) + (let ((out (add-defs out vars))) + (match exp + ((or ($ $const) ($ $prim) ($ $fun) ($ $closure) ($ $rec)) + ;; No uses, so no info added to sigbits. + out) + (($ $values args) + (match (intmap-ref cps k) + (($ $kargs _ vars) + (fold (lambda (arg var out) + (intmap-add out arg (intmap-ref out var + (lambda (_) 0)) + sigbits-union)) + out args vars)) + (($ $ktail) + (add-unknown-uses out args)))) + (($ $call proc args) + (add-unknown-use (add-unknown-uses out args) proc)) + (($ $callk label proc args) + (add-unknown-use (add-unknown-uses out args) proc)) + (($ $branch kt ($ $values (arg))) + (add-unknown-use out arg)) + (($ $branch kt ($ $primcall name args)) + (add-unknown-uses out args)) + (($ $primcall name args) + (let ((h (significant-bits-handler name))) + (if h + (match (intmap-ref cps k) + (($ $kargs _ defs) + (h label types out args defs))) + (add-unknown-uses out args)))) + (($ $prompt escape? tag handler) + (add-unknown-use out tag))))) + (_ out))))))))) + (define (specialize-operations cps) - (define (visit-cont label cont cps types) + (define (visit-cont label cont cps types sigbits) (define (operand-in-range? var &type &min &max) (call-with-values (lambda () (lookup-pre-type types label var)) @@ -142,9 +268,25 @@ (and (eqv? type &type) (<= &min min max &max))))) (define (u64-operand? var) (operand-in-range? var &exact-integer 0 #xffffffffffffffff)) + (define (all-u64-bits-set? var) + (operand-in-range? var &exact-integer + #xffffffffffffffff + #xffffffffffffffff)) + (define (only-u64-bits-used? var) + (let ((bits (intmap-ref sigbits var))) + (and bits (= bits (logand bits #xffffFFFFffffFFFF))))) + (define (u64-result? result) + (or (only-u64-bits-used? result) + (call-with-values + (lambda () + (lookup-post-type types label result 0)) + (lambda (type min max) + (and (eqv? type &exact-integer) + (<= 0 min max #xffffffffffffffff)))))) (match cont (($ $kfun) - (values cps (infer-types cps label))) + (let ((types (infer-types cps label))) + (values cps types (compute-significant-bits cps types label)))) (($ $kargs names vars ($ $continue k src ($ $primcall (and op (or 'add 'sub 'mul 'div)) (a b)))) @@ -160,7 +302,8 @@ (let$ body (specialize-f64-binop k src op a b)) (setk label ($kargs names vars ,body)))) ((and (eqv? type &exact-integer) - (<= 0 min max #xffffffffffffffff) + (or (<= 0 min max #xffffffffffffffff) + (only-u64-bits-used? result)) (u64-operand? a) (u64-operand? b) (not (eq? op 'div))) (with-cps cps @@ -168,80 +311,78 @@ (setk label ($kargs names vars ,body)))) (else cps)) - types)))))) + types + sigbits)))))) (($ $kargs names vars ($ $continue k src ($ $primcall 'ash (a b)))) (match (intmap-ref cps k) (($ $kargs (_) (result)) (call-with-values (lambda () - (lookup-post-type types label result 0)) - (lambda (type min max) - (call-with-values (lambda () - (lookup-pre-type types label b)) - (lambda (b-type b-min b-max) - (values - (cond - ((or (not (eqv? type &exact-integer)) - (not (<= 0 min max #xffffffffffffffff)) - (not (u64-operand? a)) - (not (eqv? b-type &exact-integer)) - (< b-min 0 b-max) - (<= b-min -64) - (<= 64 b-max)) - cps) - ((and (< b-min 0) (= b-min b-max)) - (with-cps cps - (let$ body - (with-cps-constants ((bits (- b-min))) - ($ (specialize-u64-binop k src 'rsh a bits)))) - (setk label ($kargs names vars ,body)))) - ((< b-min 0) - (with-cps cps - (let$ body - (with-cps-constants ((zero 0)) - (letv bits) - (let$ body - (specialize-u64-binop k src 'rsh a bits)) - (letk kneg ($kargs ('bits) (bits) ,body)) - (build-term - ($continue kneg src - ($primcall 'sub (zero b)))))) - (setk label ($kargs names vars ,body)))) - (else - (with-cps cps - (let$ body (specialize-u64-binop k src 'lsh a b)) - (setk label ($kargs names vars ,body))))) - types)))))))) - (($ $kargs names vars - ($ $continue k src - ($ $primcall (and op (or 'logand 'logior 'logsub)) (a b)))) - (match (intmap-ref cps k) - (($ $kargs (_) (result)) - (call-with-values (lambda () - (lookup-post-type types label result 0)) - (lambda (type min max) + (lookup-pre-type types label b)) + (lambda (b-type b-min b-max) (values (cond - ((and (eqv? type &exact-integer) - (<= 0 min max #xffffffffffffffff)) - ;; If we know the result is a u64, then any - ;; out-of-range bits won't affect the result and so we - ;; can project the operands onto u64. + ((or (not (u64-result? result)) + (not (u64-operand? a)) + (not (eqv? b-type &exact-integer)) + (< b-min 0 b-max) + (<= b-min -64) + (<= 64 b-max)) + cps) + ((and (< b-min 0) (= b-min b-max)) (with-cps cps (let$ body - (specialize-u64-binop k src op a b - #:unbox-a - (if (u64-operand? a) - 'scm->u64 - 'scm->u64/truncate) - #:unbox-b - (if (u64-operand? b) - 'scm->u64 - 'scm->u64/truncate))) + (with-cps-constants ((bits (- b-min))) + ($ (specialize-u64-binop k src 'rsh a bits)))) + (setk label ($kargs names vars ,body)))) + ((< b-min 0) + (with-cps cps + (let$ body + (with-cps-constants ((zero 0)) + (letv bits) + (let$ body + (specialize-u64-binop k src 'rsh a bits)) + (letk kneg ($kargs ('bits) (bits) ,body)) + (build-term + ($continue kneg src + ($primcall 'sub (zero b)))))) (setk label ($kargs names vars ,body)))) (else - cps)) - types)))))) + (with-cps cps + (let$ body (specialize-u64-binop k src 'lsh a b)) + (setk label ($kargs names vars ,body))))) + types + sigbits)))))) + (($ $kargs names vars + ($ $continue k src + ($ $primcall (and op (or 'logand 'logior 'logsub 'logxor)) (a b)))) + (match (intmap-ref cps k) + (($ $kargs (_) (result)) + (values + (cond + ((u64-result? result) + ;; Given that we know the result can be unboxed to a u64, + ;; any out-of-range bits won't affect the result and so we + ;; can unconditionally project the operands onto u64. + (cond + ((and (eq? op 'logand) (all-u64-bits-set? a)) + (with-cps cps + (let$ body (truncate-u64 k src b)) + (setk label ($kargs names vars ,body)))) + ((and (eq? op 'logand) (all-u64-bits-set? b)) + (with-cps cps + (let$ body (truncate-u64 k src a)) + (setk label ($kargs names vars ,body)))) + (else + (with-cps cps + (let$ body (specialize-u64-binop k src op a b + #:unbox-a + 'scm->u64/truncate + #:unbox-b + 'scm->u64/truncate)) + (setk label ($kargs names vars ,body)))))) + (else cps)) + types sigbits)))) (($ $kargs names vars ($ $continue k src ($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) (a b))))) @@ -260,10 +401,11 @@ (let$ body (specialize-u64-scm-comparison k kt src op b a)) (setk label ($kargs names vars ,body)))) cps)) - types)) - (_ (values cps types)))) + types + sigbits)) + (_ (values cps types sigbits)))) - (values (intmap-fold visit-cont cps cps #f))) + (values (intmap-fold visit-cont cps cps #f #f))) ;; Compute a map from VAR -> LABEL, where LABEL indicates the cont that ;; binds VAR. From 2dbb0e212d76f08be6cd36a7b917b00deeb367cb Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 2 Sep 2016 09:43:42 +0200 Subject: [PATCH 507/865] GOOPS caches created vtables * libguile/goops.c (scm_i_define_class_for_vtable): Cache created vtables. Fixes #24286. * test-suite/tests/goops.test ("classes for built-in types"): Add tests. --- libguile/goops.c | 2 +- test-suite/tests/goops.test | 12 +++++++++++- 2 files changed, 12 insertions(+), 2 deletions(-) diff --git a/libguile/goops.c b/libguile/goops.c index 88a065fd2..3ed60d3f3 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -865,7 +865,7 @@ scm_i_define_class_for_vtable (SCM vtable) supers = scm_list_1 (class_top); } - return scm_make_standard_class (meta, name, supers, SCM_EOL); + class = scm_make_standard_class (meta, name, supers, SCM_EOL); } else /* `create_struct_classes' will fill this in later. */ diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test index 087b6a90a..730aabb31 100644 --- a/test-suite/tests/goops.test +++ b/test-suite/tests/goops.test @@ -149,7 +149,17 @@ ;; for which `struct-vtable-name' is #f. (is-a? (class-of (make-vtable (string-append standard-vtable-fields "prprpr"))) - ))) + )) + + ;; Two cases: one for structs created before goops, one after. + (pass-if "early vtable class cached" + (eq? (class-of (current-module)) + (class-of (current-module)))) + (pass-if "late vtable class cached" + (let ((vtable (make-vtable + (string-append standard-vtable-fields "prprpr")))) + (eq? (class-of vtable) + (class-of vtable))))) (with-test-prefix "defining classes" From 3b2cd09fe277ce3dc02f32962cfc82b0c201691c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 2 Sep 2016 10:02:54 +0200 Subject: [PATCH 508/865] Better char=? . _) &type-check) - ((char>? . _) &type-check) ((integer->char _) &type-check) ((char->integer _) &type-check)) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 266cb743d..e8f53bb3f 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -1423,10 +1423,6 @@ minimum, and maximum." ;;; Characters. ;;; -(define-simple-type (char=? char>?) - (define-simple-type-checker (integer->char (&u64 0 *max-codepoint*))) (define-type-inferrer (integer->char i result) (restrict! i &u64 0 *max-codepoint*) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 0a88f1476..4f960e534 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -549,6 +549,24 @@ (chained-comparison-expander prim-name))) '(< > <= >= =)) +(define (character-comparison-expander char< <) + (lambda (src . args) + (expand-primcall + (make-primcall src < + (map (lambda (arg) + (make-primcall src 'char->integer (list arg))) + args))))) + +(for-each (match-lambda + ((char< . <) + (hashq-set! *primitive-expand-table* char< + (character-comparison-expander char< <)))) + '((char? . >) + (char<=? . <=) + (char>=? . >=) + (char=? . =))) + ;; Appropriate for use with either 'eqv?' or 'equal?'. (define (maybe-simplify-to-eq prim) (case-lambda From b494bc1743910f65e3062f0ced1a212bb72df772 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 2 Sep 2016 10:12:28 +0200 Subject: [PATCH 509/865] Fix typo in Nil documentation * doc/ref/api-languages.texi (Nil): Fix typo. Thanks to Wilfred Hughes for the report. Fixes #24342. --- doc/ref/api-languages.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/api-languages.texi b/doc/ref/api-languages.texi index fb42987d9..dd4f223df 100644 --- a/doc/ref/api-languages.texi +++ b/doc/ref/api-languages.texi @@ -229,7 +229,7 @@ Here are correct versions of the above examples: This problem has a mirror-image case in Elisp: @example -(deffn my-falsep (x) +(defun my-falsep (x) (if (eq x nil) t nil)) From cb421b6546ad3e09299462df63c389aa734fdba8 Mon Sep 17 00:00:00 2001 From: Robin Templeton Date: Sat, 27 Aug 2016 13:42:10 -0400 Subject: [PATCH 510/865] Check for missing debug info in print-program * module/system/vm/program.scm (print-program): Check the return value of find-program-debug-info. Fixes #24320. --- module/system/vm/program.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm index 9f5b764d0..32c96f26a 100644 --- a/module/system/vm/program.scm +++ b/module/system/vm/program.scm @@ -265,7 +265,7 @@ lists." ;; It could be the procedure had its name property set via the ;; procedure property interface. (name (or (and program (procedure-name program)) - (program-debug-info-name pdi))) + (and pdi (program-debug-info-name pdi)))) (source (match (find-program-sources addr) (() #f) ((source . _) source))) From 605a01bfceebf19a7f5ce17500ca82eeefe40fee Mon Sep 17 00:00:00 2001 From: Wilfred Hughes Date: Sun, 4 Sep 2016 20:14:49 -0400 Subject: [PATCH 511/865] Clarify bootstrap docs * doc/ref/vm.texi: Add a sentence stating which parts of the bytecode toolchain are in C, and which are in Scheme. This avoids confusion if users assume Guile==Scheme and so assume the whole toolchain is in Scheme. --- doc/ref/vm.texi | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 2f32c511f..9766ccb67 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -62,10 +62,12 @@ The obvious solution is to compile to a virtual machine that is present on all Guile installations. The easiest (and most fun) way to depend on a virtual machine is to -implement the virtual machine within Guile itself. This way the -virtual machine provides what Scheme needs (tail calls, multiple -values, @code{call/cc}) and can provide optimized inline instructions -for Guile (@code{cons}, @code{struct-ref}, etc.). +implement the virtual machine within Guile itself. Guile contains a +bytecode interpreter (written in C) and a Scheme to bytecode compiler +(written in Scheme). This way the virtual machine provides what Scheme +needs (tail calls, multiple values, @code{call/cc}) and can provide +optimized inline instructions for Guile (@code{cons}, @code{struct-ref}, +etc.). So this is what Guile does. The rest of this section describes that VM that Guile implements, and the compiled procedures that run on it. From 10423dbdaa77b9fa3405fe280f4387dcd84f22d7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 6 Sep 2016 09:04:14 +0200 Subject: [PATCH 512/865] Convert tc7 values to hex in tags.h and elsewhere * libguile/tags.h: * module/system/base/types.scm: * module/system/vm/assembler.scm: Convert tc7 values to hex. No change otherwise. --- libguile/tags.h | 68 +++++++++++++++++----------------- module/system/base/types.scm | 46 +++++++++++------------ module/system/vm/assembler.scm | 14 +++---- 3 files changed, 64 insertions(+), 64 deletions(-) diff --git a/libguile/tags.h b/libguile/tags.h index 1c9dce4b9..cf40c3d4d 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -389,8 +389,8 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; /* Definitions for tc7: */ -#define SCM_ITAG7(x) (127 & SCM_UNPACK (x)) -#define SCM_TYP7(x) (0x7f & SCM_CELL_TYPE (x)) +#define SCM_ITAG7(x) (0x7f & SCM_UNPACK (x)) +#define SCM_TYP7(x) (0x7f & SCM_CELL_TYPE (x)) #define SCM_HAS_HEAP_TYPE(x, type, tag) \ (SCM_NIMP (x) && type (x) == (tag)) #define SCM_HAS_TYP7(x, tag) (SCM_HAS_HEAP_TYPE (x, SCM_TYP7, tag)) @@ -398,49 +398,49 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; /* If you change these numbers, change them also in (system vm assembler). */ -#define scm_tc7_symbol 5 -#define scm_tc7_variable 7 +#define scm_tc7_symbol 0x05 +#define scm_tc7_variable 0x07 /* couple */ -#define scm_tc7_vector 13 -#define scm_tc7_wvect 15 +#define scm_tc7_vector 0x0d +#define scm_tc7_wvect 0x0f -#define scm_tc7_string 21 -#define scm_tc7_number 23 -#define scm_tc7_stringbuf 39 -#define scm_tc7_bytevector 77 +#define scm_tc7_string 0x15 +#define scm_tc7_number 0x17 +#define scm_tc7_stringbuf 0x27 +#define scm_tc7_bytevector 0x4d -#define scm_tc7_pointer 31 -#define scm_tc7_hashtable 29 -#define scm_tc7_fluid 37 -#define scm_tc7_dynamic_state 45 +#define scm_tc7_pointer 0x1f +#define scm_tc7_hashtable 0x1d +#define scm_tc7_fluid 0x25 +#define scm_tc7_dynamic_state 0x2d -#define scm_tc7_frame 47 -#define scm_tc7_keyword 53 -#define scm_tc7_unused_55 55 -#define scm_tc7_vm_cont 71 +#define scm_tc7_frame 0x2f +#define scm_tc7_keyword 0x35 +#define scm_tc7_unused_55 0x37 +#define scm_tc7_vm_cont 0x47 -#define scm_tc7_unused_17 61 -#define scm_tc7_unused_21 63 -#define scm_tc7_program 69 -#define scm_tc7_unused_79 79 -#define scm_tc7_weak_set 85 -#define scm_tc7_weak_table 87 -#define scm_tc7_array 93 -#define scm_tc7_bitvector 95 -#define scm_tc7_unused_12 101 -#define scm_tc7_unused_18 103 -#define scm_tc7_unused_13 109 -#define scm_tc7_unused_14 111 -#define scm_tc7_unused_15 117 -#define scm_tc7_unused_16 119 -#define scm_tc7_port 125 +#define scm_tc7_unused_17 0x3d +#define scm_tc7_unused_21 0x3f +#define scm_tc7_program 0x45 +#define scm_tc7_unused_79 0x4f +#define scm_tc7_weak_set 0x55 +#define scm_tc7_weak_table 0x57 +#define scm_tc7_array 0x5d +#define scm_tc7_bitvector 0x5f +#define scm_tc7_unused_12 0x65 +#define scm_tc7_unused_18 0x67 +#define scm_tc7_unused_13 0x6d +#define scm_tc7_unused_14 0x6f +#define scm_tc7_unused_15 0x75 +#define scm_tc7_unused_16 0x77 +#define scm_tc7_port 0x7d /* There are 256 smob subtypes. [**] If you change scm_tc7_smob, you must * also change the places it is hard coded in this file and possibly others. * Dirk:FIXME:: Any hard coded reference to scm_tc7_smob must be replaced by a * symbolic reference. */ -#define scm_tc7_smob 127 /* DO NOT CHANGE [**] */ +#define scm_tc7_smob 0x7f /* DO NOT CHANGE [**] */ /* Definitions for tc16: */ diff --git a/module/system/base/types.scm b/module/system/base/types.scm index 0e7371baa..a96348872 100644 --- a/module/system/base/types.scm +++ b/module/system/base/types.scm @@ -243,29 +243,29 @@ the matching bits, possibly with bitwise operations to extract it from BITS." (define %tc8-flag (+ %tc3-imm24 0)) ;; Cell types. -(define %tc3-struct 1) -(define %tc7-symbol 5) -(define %tc7-variable 7) -(define %tc7-vector 13) -(define %tc7-wvect 15) -(define %tc7-string 21) -(define %tc7-number 23) -(define %tc7-hashtable 29) -(define %tc7-pointer 31) -(define %tc7-fluid 37) -(define %tc7-stringbuf 39) -(define %tc7-dynamic-state 45) -(define %tc7-frame 47) -(define %tc7-keyword 53) -(define %tc7-program 69) -(define %tc7-vm-continuation 71) -(define %tc7-bytevector 77) -(define %tc7-weak-set 85) -(define %tc7-weak-table 87) -(define %tc7-array 93) -(define %tc7-bitvector 95) -(define %tc7-port 125) -(define %tc7-smob 127) +(define %tc3-struct #x01) +(define %tc7-symbol #x05) +(define %tc7-variable #x07) +(define %tc7-vector #x0d) +(define %tc7-wvect #x0f) +(define %tc7-string #x15) +(define %tc7-number #x17) +(define %tc7-hashtable #x1d) +(define %tc7-pointer #x1f) +(define %tc7-fluid #x25) +(define %tc7-stringbuf #x27) +(define %tc7-dynamic-state #x2d) +(define %tc7-frame #x2f) +(define %tc7-keyword #x35) +(define %tc7-program #x45) +(define %tc7-vm-continuation #x47) +(define %tc7-bytevector #x4d) +(define %tc7-weak-set #x55) +(define %tc7-weak-table #x57) +(define %tc7-array #x5d) +(define %tc7-bitvector #x5f) +(define %tc7-port #x7d) +(define %tc7-smob #x7f) (define %tc16-bignum (+ %tc7-number (* 1 256))) (define %tc16-real (+ %tc7-number (* 2 256))) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index c9ef5f191..e07f7d4e8 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -1152,27 +1152,27 @@ returned instead." ;; ;; FIXME: Define all tc7 values in Scheme in one place, derived from ;; tags.h. -(define-tc7-macro-assembler br-if-symbol 5) -(define-tc7-macro-assembler br-if-variable 7) -(define-tc7-macro-assembler br-if-vector 13) +(define-tc7-macro-assembler br-if-symbol #x05) +(define-tc7-macro-assembler br-if-variable #x07) +(define-tc7-macro-assembler br-if-vector #x0d) ;(define-tc7-macro-assembler br-if-weak-vector 13) -(define-tc7-macro-assembler br-if-string 21) +(define-tc7-macro-assembler br-if-string #x15) ;(define-tc7-macro-assembler br-if-heap-number 23) ;(define-tc7-macro-assembler br-if-stringbuf 39) -(define-tc7-macro-assembler br-if-bytevector 77) +(define-tc7-macro-assembler br-if-bytevector #x4d) ;(define-tc7-macro-assembler br-if-pointer 31) ;(define-tc7-macro-assembler br-if-hashtable 29) ;(define-tc7-macro-assembler br-if-fluid 37) ;(define-tc7-macro-assembler br-if-dynamic-state 45) ;(define-tc7-macro-assembler br-if-frame 47) -(define-tc7-macro-assembler br-if-keyword 53) +(define-tc7-macro-assembler br-if-keyword #x35) ;(define-tc7-macro-assembler br-if-vm 55) ;(define-tc7-macro-assembler br-if-vm-cont 71) ;(define-tc7-macro-assembler br-if-rtl-program 69) ;(define-tc7-macro-assembler br-if-weak-set 85) ;(define-tc7-macro-assembler br-if-weak-table 87) ;(define-tc7-macro-assembler br-if-array 93) -(define-tc7-macro-assembler br-if-bitvector 95) +(define-tc7-macro-assembler br-if-bitvector #x5f) ;(define-tc7-macro-assembler br-if-port 125) ;(define-tc7-macro-assembler br-if-smob 127) From 1bed03224906b2891fedc2c23abc073d4a60adda Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 6 Sep 2016 09:21:49 +0200 Subject: [PATCH 513/865] Tweak value of tc7-smob. * libguile/tags.h (scm_tc7_smob): * module/system/base/types.scm (%tc7-smob): Tweak this value, just to prove that it can be done. Remove scary comment. --- libguile/tags.h | 15 ++------------- module/system/base/types.scm | 2 +- 2 files changed, 3 insertions(+), 14 deletions(-) diff --git a/libguile/tags.h b/libguile/tags.h index cf40c3d4d..5b0bc8c58 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -400,26 +400,20 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; #define scm_tc7_symbol 0x05 #define scm_tc7_variable 0x07 - -/* couple */ #define scm_tc7_vector 0x0d #define scm_tc7_wvect 0x0f - #define scm_tc7_string 0x15 #define scm_tc7_number 0x17 #define scm_tc7_stringbuf 0x27 #define scm_tc7_bytevector 0x4d - #define scm_tc7_pointer 0x1f #define scm_tc7_hashtable 0x1d #define scm_tc7_fluid 0x25 #define scm_tc7_dynamic_state 0x2d - #define scm_tc7_frame 0x2f #define scm_tc7_keyword 0x35 #define scm_tc7_unused_55 0x37 #define scm_tc7_vm_cont 0x47 - #define scm_tc7_unused_17 0x3d #define scm_tc7_unused_21 0x3f #define scm_tc7_program 0x45 @@ -433,14 +427,9 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; #define scm_tc7_unused_13 0x6d #define scm_tc7_unused_14 0x6f #define scm_tc7_unused_15 0x75 -#define scm_tc7_unused_16 0x77 +#define scm_tc7_unused_16 0x7f #define scm_tc7_port 0x7d - -/* There are 256 smob subtypes. [**] If you change scm_tc7_smob, you must - * also change the places it is hard coded in this file and possibly others. - * Dirk:FIXME:: Any hard coded reference to scm_tc7_smob must be replaced by a - * symbolic reference. */ -#define scm_tc7_smob 0x7f /* DO NOT CHANGE [**] */ +#define scm_tc7_smob 0x77 /* Definitions for tc16: */ diff --git a/module/system/base/types.scm b/module/system/base/types.scm index a96348872..cf3c7c9d2 100644 --- a/module/system/base/types.scm +++ b/module/system/base/types.scm @@ -265,7 +265,7 @@ the matching bits, possibly with bitwise operations to extract it from BITS." (define %tc7-array #x5d) (define %tc7-bitvector #x5f) (define %tc7-port #x7d) -(define %tc7-smob #x7f) +(define %tc7-smob #x77) (define %tc16-bignum (+ %tc7-number (* 1 256))) (define %tc16-real (+ %tc7-number (* 2 256))) From 7cdaf0e27b8b7c22b6ca3900eafc3ffeacb62bc9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 6 Sep 2016 09:29:51 +0200 Subject: [PATCH 514/865] Reorder tc7 type codes * libguile/tags.h: Reorder type codes so that they are in numeric order in the header file; no type code value is changed. --- libguile/tags.h | 38 +++++++++++++++++++++----------------- 1 file changed, 21 insertions(+), 17 deletions(-) diff --git a/libguile/tags.h b/libguile/tags.h index 5b0bc8c58..3d6f4bb6a 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -395,8 +395,12 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; (SCM_NIMP (x) && type (x) == (tag)) #define SCM_HAS_TYP7(x, tag) (SCM_HAS_HEAP_TYPE (x, SCM_TYP7, tag)) -/* If you change these numbers, change them also in (system vm - assembler). */ +/* These type codes form part of the ABI and cannot be changed in a + stable series. The low bits of each must have the tc3 of a heap + object type code (see above). If you do change them in a development + series, change them also in (system vm assembler) and (system base + types). Bonus points if you change the build to define these tag + values in only one place! */ #define scm_tc7_symbol 0x05 #define scm_tc7_variable 0x07 @@ -404,32 +408,32 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; #define scm_tc7_wvect 0x0f #define scm_tc7_string 0x15 #define scm_tc7_number 0x17 -#define scm_tc7_stringbuf 0x27 -#define scm_tc7_bytevector 0x4d -#define scm_tc7_pointer 0x1f #define scm_tc7_hashtable 0x1d +#define scm_tc7_pointer 0x1f #define scm_tc7_fluid 0x25 +#define scm_tc7_stringbuf 0x27 #define scm_tc7_dynamic_state 0x2d #define scm_tc7_frame 0x2f #define scm_tc7_keyword 0x35 -#define scm_tc7_unused_55 0x37 -#define scm_tc7_vm_cont 0x47 -#define scm_tc7_unused_17 0x3d -#define scm_tc7_unused_21 0x3f +#define scm_tc7_unused_37 0x37 +#define scm_tc7_unused_3d 0x3d +#define scm_tc7_unused_3f 0x3f #define scm_tc7_program 0x45 -#define scm_tc7_unused_79 0x4f +#define scm_tc7_vm_cont 0x47 +#define scm_tc7_bytevector 0x4d +#define scm_tc7_unused_4f 0x4f #define scm_tc7_weak_set 0x55 #define scm_tc7_weak_table 0x57 #define scm_tc7_array 0x5d #define scm_tc7_bitvector 0x5f -#define scm_tc7_unused_12 0x65 -#define scm_tc7_unused_18 0x67 -#define scm_tc7_unused_13 0x6d -#define scm_tc7_unused_14 0x6f -#define scm_tc7_unused_15 0x75 -#define scm_tc7_unused_16 0x7f -#define scm_tc7_port 0x7d +#define scm_tc7_unused_65 0x65 +#define scm_tc7_unused_67 0x67 +#define scm_tc7_unused_6d 0x6d +#define scm_tc7_unused_6f 0x6f +#define scm_tc7_unused_75 0x75 #define scm_tc7_smob 0x77 +#define scm_tc7_port 0x7d +#define scm_tc7_unused_7f 0x7f /* Definitions for tc16: */ From 3425290a7b1249b8901eabf089869846d05eeb1e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 6 Sep 2016 11:04:25 +0200 Subject: [PATCH 515/865] Add atomic boxes * doc/ref/api-scheduling.texi (Atomics): New manual section. * libguile.h: Include atomic.h. * libguile/Makefile.am (libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES): (DOT_X_FILES, DOT_DOC_FILES, modinclude_HEADERS): Add atomic. * libguile/atomic.c: * libguile/atomic.h: New files. * libguile/atomics-internal.h (scm_atomic_set_scm, scm_atomic_ref_scm) (scm_atomic_swap_scm, scm_atomic_compare_and_swap_scm): New facilities. * libguile/goops.c (class_atomic_box, scm_sys_goops_early_init): Add support for . Remove duplicate fetch. * libguile/init.c (scm_i_init_guile): Call scm_register_atomic_box. * libguile/print.c (iprin1): Add atomic box case. * libguile/tags.h (scm_tc7_atomic_box): New tag. * libguile/validate.h (SCM_VALIDATE_ATOMIC_BOX): New macro. * module/Makefile.am (SOURCES): Add ice-9/atomic.scm. * module/ice-9/atomic.scm: New file. * module/oop/goops.scm (): New var. --- doc/ref/api-scheduling.texi | 67 ++++++++++++++++++ libguile.h | 1 + libguile/Makefile.am | 4 ++ libguile/atomic.c | 128 +++++++++++++++++++++++++++++++++++ libguile/atomic.h | 56 +++++++++++++++ libguile/atomics-internal.h | 88 ++++++++++++++++++++---- libguile/goops.c | 6 +- libguile/init.c | 2 + libguile/print.c | 3 + libguile/tags.h | 2 +- libguile/validate.h | 6 ++ module/Makefile.am | 1 + module/ice-9/atomic.scm | 30 ++++++++ module/oop/goops.scm | 3 +- test-suite/tests/atomic.test | 59 ++++++++++++++++ 15 files changed, 440 insertions(+), 16 deletions(-) create mode 100644 libguile/atomic.c create mode 100644 libguile/atomic.h create mode 100644 module/ice-9/atomic.scm create mode 100644 test-suite/tests/atomic.test diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index 0d036be9e..38f5ac4a2 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -10,6 +10,7 @@ @menu * Arbiters:: Synchronization primitives. * Asyncs:: Asynchronous procedure invocation. +* Atomics:: Atomic references. * Threads:: Multiple threads of execution. * Mutexes and Condition Variables:: Synchronization primitives. * Blocking:: How to block properly in guile mode. @@ -191,6 +192,72 @@ Mark the user async @var{a} for future execution. Execute all thunks from the marked asyncs of the list @var{list_of_a}. @end deffn +@node Atomics +@subsection Atomics + +When accessing data in parallel from multiple threads, updates made by +one thread are not generally guaranteed to be visible by another thread. +It could be that your hardware requires special instructions to be +emitted to propagate a change from one CPU core to another. Or, it +could be that your hardware updates values with a sequence of +instructions, and a parallel thread could see a value that is in the +process of being updated but not fully updated. + +Atomic references solve this problem. Atomics are a standard, primitive +facility to allow for concurrent access and update of mutable variables +from multiple threads with guaranteed forward-progress and well-defined +intermediate states. + +Atomic references serve not only as a hardware memory barrier but also +as a compiler barrier. Normally a compiler might choose to reorder or +elide certain memory accesses due to optimizations like common +subexpression elimination. Atomic accesses however will not be +reordered relative to each other, and normal memory accesses will not be +reordered across atomic accesses. + +As an implementation detail, currently all atomic accesses and updates +use the sequential consistency memory model from C11. We may relax this +in the future to the acquire/release semantics, which still issues a +memory barrier so that non-atomic updates are not reordered across +atomic accesses or updates. + +To use Guile's atomic operations, load the @code{(ice-9 atomic)} module: + +@example +(use-modules (ice-9 atomic)) +@end example + +@deffn {Scheme Procedure} make-atomic-box init +Return an atomic box initialized to value @var{init}. +@end deffn + +@deffn {Scheme Procedure} atomic-box? obj +Return @code{#t} if @var{obj} is an atomic-box object, else +return @code{#f}. +@end deffn + +@deffn {Scheme Procedure} atomic-box-ref box +Fetch the value stored in the atomic box @var{box} and return it. +@end deffn + +@deffn {Scheme Procedure} atomic-box-set! box val +Store @var{val} into the atomic box @var{box}. +@end deffn + +@deffn {Scheme Procedure} atomic-box-swap! box val +Store @var{val} into the atomic box @var{box}, and return the value that +was previously stored in the box. +@end deffn + +@deffn {Scheme Procedure} atomic-box-compare-and-swap! box expected desired +If the value of the atomic box @var{box} is the same as, @var{expected} +(in the sense of @code{eq?}), replace the contents of the box with +@var{desired}. Otherwise does not update the box. Returns the previous +value of the box in either case, so you can know if the swap worked by +checking if the return value is @code{eq?} to @var{expected}. +@end deffn + + @node Threads @subsection Threads @cindex threads diff --git a/libguile.h b/libguile.h index d2030eb86..8354e7cca 100644 --- a/libguile.h +++ b/libguile.h @@ -35,6 +35,7 @@ extern "C" { #include "libguile/array-map.h" #include "libguile/arrays.h" #include "libguile/async.h" +#include "libguile/atomic.h" #include "libguile/boolean.h" #include "libguile/bitvectors.h" #include "libguile/bytevectors.h" diff --git a/libguile/Makefile.am b/libguile/Makefile.am index ba6be2019..e5011da91 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -125,6 +125,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ array-map.c \ arrays.c \ async.c \ + atomic.c \ backtrace.c \ boolean.c \ bitvectors.c \ @@ -235,6 +236,7 @@ DOT_X_FILES = \ array-map.x \ arrays.x \ async.x \ + atomic.x \ backtrace.x \ boolean.x \ bitvectors.x \ @@ -342,6 +344,7 @@ DOT_DOC_FILES = \ array-map.doc \ arrays.doc \ async.doc \ + atomic.doc \ backtrace.doc \ boolean.doc \ bitvectors.doc \ @@ -569,6 +572,7 @@ modinclude_HEADERS = \ array-map.h \ arrays.h \ async.h \ + atomic.h \ backtrace.h \ bdw-gc.h \ boolean.h \ diff --git a/libguile/atomic.c b/libguile/atomic.c new file mode 100644 index 000000000..950874030 --- /dev/null +++ b/libguile/atomic.c @@ -0,0 +1,128 @@ +/* Copyright (C) 2016 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 License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + + + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include "libguile/_scm.h" +#include "libguile/ports.h" +#include "libguile/validate.h" +#include "libguile/atomics-internal.h" +#include "libguile/atomic.h" + + +SCM_DEFINE (scm_make_atomic_box, "make-atomic-box", 1, 0, 0, + (SCM init), + "Return an atomic box initialized to value @var{init}.") +#define FUNC_NAME s_scm_make_atomic_box +{ + SCM ret = scm_cell (scm_tc7_atomic_box, SCM_UNPACK (SCM_UNDEFINED)); + scm_atomic_box_set_x (ret, init); + return ret; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_atomic_box_p, "atomic-box?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is an atomic-box object, else\n" + "return @code{#f}.") +#define FUNC_NAME s_scm_atomic_box_p +{ + return scm_from_bool (scm_is_atomic_box (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_atomic_box_ref, "atomic-box-ref", 1, 0, 0, + (SCM box), + "Fetch the value stored in the atomic box @var{box} and\n" + "return it.") +#define FUNC_NAME s_scm_atomic_box_ref +{ + SCM_VALIDATE_ATOMIC_BOX (1, box); + return scm_atomic_ref_scm (scm_atomic_box_loc (box)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_atomic_box_set_x, "atomic-box-set!", 2, 0, 0, + (SCM box, SCM val), + "Store @var{val} into the atomic box @var{box}.") +#define FUNC_NAME s_scm_atomic_box_set_x +{ + SCM_VALIDATE_ATOMIC_BOX (1, box); + scm_atomic_set_scm (scm_atomic_box_loc (box), val); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_atomic_box_swap_x, "atomic-box-swap!", 2, 0, 0, + (SCM box, SCM val), + "Store @var{val} into the atomic box @var{box},\n" + "and return the value that was previously stored in\n" + "the box.") +#define FUNC_NAME s_scm_atomic_box_swap_x +{ + SCM_VALIDATE_ATOMIC_BOX (1, box); + return scm_atomic_swap_scm (scm_atomic_box_loc (box), val); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_atomic_box_compare_and_swap_x, + "atomic-box-compare-and-swap!", 3, 0, 0, + (SCM box, SCM expected, SCM desired), + "If the value of the atomic box @var{box} is the same as,\n" + "@var{expected} (in the sense of @code{eq?}), replace the\n" + "contents of the box with @var{desired}. Otherwise does not\n" + "update the box. Returns the previous value of the box in\n" + "either case, so you can know if the swap worked by checking\n" + "if the return value is @code{eq?} to @var{expected}.") +#define FUNC_NAME s_scm_atomic_box_compare_and_swap_x +{ + SCM_VALIDATE_ATOMIC_BOX (1, box); + scm_atomic_compare_and_swap_scm (scm_atomic_box_loc (box), + &expected, desired); + return expected; +} +#undef FUNC_NAME + +void +scm_i_atomic_box_print (SCM exp, SCM port, scm_print_state *pstate) +{ + scm_puts ("#', port); +} + +static void +scm_init_atomic (void) +{ +#include "libguile/atomic.x" +} + +void +scm_register_atomic (void) +{ + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_atomic", + (scm_t_extension_init_func) scm_init_atomic, + NULL); +} diff --git a/libguile/atomic.h b/libguile/atomic.h new file mode 100644 index 000000000..9a33f8d1a --- /dev/null +++ b/libguile/atomic.h @@ -0,0 +1,56 @@ +#ifndef SCM_ATOMIC_H +#define SCM_ATOMIC_H + +/* Copyright (C) 2016 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 License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + + + +#include "libguile/__scm.h" +#include "libguile/gc.h" +#include "libguile/tags.h" + + + +static inline int +scm_is_atomic_box (SCM obj) +{ + return SCM_HAS_TYP7 (obj, scm_tc7_atomic_box); +} + +static inline SCM* +scm_atomic_box_loc (SCM obj) +{ + return SCM_CELL_OBJECT_LOC (obj, 1); +} + + + +#ifdef BUILDING_LIBGUILE +SCM_INTERNAL SCM scm_make_atomic_box (SCM init); +SCM_INTERNAL SCM scm_atomic_box_p (SCM obj); +SCM_INTERNAL SCM scm_atomic_box_ref (SCM box); +SCM_INTERNAL SCM scm_atomic_box_set_x (SCM box, SCM val); +SCM_INTERNAL SCM scm_atomic_box_swap_x (SCM box, SCM val); +SCM_INTERNAL SCM scm_atomic_box_compare_and_swap_x (SCM box, SCM expected, SCM desired); +SCM_INTERNAL void scm_i_atomic_box_print (SCM box, SCM port, scm_print_state *pstate); + +SCM_INTERNAL void scm_register_atomic (void); +#endif /* BUILDING_LIBGUILE */ + +#endif /* SCM_ATOMIC_H */ diff --git a/libguile/atomics-internal.h b/libguile/atomics-internal.h index 1859daa92..9d18cbc1a 100644 --- a/libguile/atomics-internal.h +++ b/libguile/atomics-internal.h @@ -34,46 +34,110 @@ #include static inline uint32_t -scm_atomic_subtract_uint32 (uint32_t *obj, uint32_t arg) +scm_atomic_subtract_uint32 (uint32_t *loc, uint32_t arg) { - return atomic_fetch_sub (obj, arg); + return atomic_fetch_sub (loc, arg); } static inline _Bool -scm_atomic_compare_and_swap_uint32 (uint32_t *obj, uint32_t *expected, +scm_atomic_compare_and_swap_uint32 (uint32_t *loc, uint32_t *expected, uint32_t desired) { - return atomic_compare_exchange_weak (obj, expected, desired); + return atomic_compare_exchange_weak (loc, expected, desired); +} +static inline void +scm_atomic_set_scm (SCM *loc, SCM val) +{ + atomic_store (loc, val); +} +static inline SCM +scm_atomic_ref_scm (SCM *loc) +{ + return atomic_load (loc); +} +static inline SCM +scm_atomic_swap_scm (SCM *loc, SCM val) +{ + return atomic_exchange (loc, val); +} +static inline _Bool +scm_atomic_compare_and_swap_scm (SCM *loc, SCM *expected, SCM desired) +{ + return atomic_compare_exchange_weak (loc, expected, desired); } - #else /* HAVE_C11_ATOMICS */ /* Fallback implementation using locks. */ #include "libguile/threads.h" static scm_i_pthread_mutex_t atomics_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; static inline uint32_t -scm_atomic_subtract_uint32 (uint32_t *obj, uint32_t arg) +scm_atomic_subtract_uint32 (uint32_t *loc, uint32_t arg) { uint32_t ret; scm_i_pthread_mutex_lock (&atomics_lock); - ret = *obj; - *obj -= arg; + ret = *loc; + *loc -= arg; scm_i_pthread_mutex_unlock (&atomics_lock); return ret; } static inline int -scm_atomic_compare_and_swap_uint32 (uint32_t *obj, uint32_t *expected, +scm_atomic_compare_and_swap_uint32 (uint32_t *loc, uint32_t *expected, uint32_t desired) { int ret; scm_i_pthread_mutex_lock (&atomics_lock); - if (*obj == *expected) + if (*loc == *expected) { - *obj = desired; + *loc = desired; ret = 1; } else { - *expected = *obj; + *expected = *loc; + ret = 0; + } + scm_i_pthread_mutex_unlock (&atomics_lock); + return ret; +} + +static inline void +scm_atomic_set_scm (SCM *loc, SCM val) +{ + scm_i_pthread_mutex_lock (&atomics_lock); + *loc = val; + scm_i_pthread_mutex_unlock (&atomics_lock); +} +static inline SCM +scm_atomic_ref_scm (SCM *loc) +{ + SCM ret; + scm_i_pthread_mutex_lock (&atomics_lock); + ret = *loc; + scm_i_pthread_mutex_unlock (&atomics_lock); + return ret; +} +static inline SCM +scm_atomic_swap_scm (SCM *loc, SCM val) +{ + SCM ret; + scm_i_pthread_mutex_lock (&atomics_lock); + ret = *loc; + *loc = val; + scm_i_pthread_mutex_unlock (&atomics_lock); + return ret; +} +static inline int +scm_atomic_compare_and_swap_scm (SCM *loc, SCM *expected, SCM desired) +{ + int ret; + scm_i_pthread_mutex_lock (&atomics_lock); + if (*loc == *expected) + { + *loc = desired; + ret = 1; + } + else + { + *expected = *loc; ret = 0; } scm_i_pthread_mutex_unlock (&atomics_lock); diff --git a/libguile/goops.c b/libguile/goops.c index 3ed60d3f3..4e28d06fb 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -110,6 +110,7 @@ static SCM class_applicable_struct_class; static SCM class_applicable_struct_with_setter_class; static SCM class_number, class_list; static SCM class_keyword; +static SCM class_atomic_box; static SCM class_port, class_input_output_port; static SCM class_input_port, class_output_port; static SCM class_foreign_slot; @@ -124,7 +125,6 @@ static SCM class_hashtable; static SCM class_fluid; static SCM class_dynamic_state; static SCM class_frame; -static SCM class_keyword; static SCM class_vm_cont; static SCM class_bytevector; static SCM class_uvec; @@ -227,6 +227,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, return class_frame; case scm_tc7_keyword: return class_keyword; + case scm_tc7_atomic_box: + return class_atomic_box; case scm_tc7_vm_cont: return class_vm_cont; case scm_tc7_bytevector: @@ -998,6 +1000,7 @@ SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0, class_dynamic_state = scm_variable_ref (scm_c_lookup ("")); class_frame = scm_variable_ref (scm_c_lookup ("")); class_keyword = scm_variable_ref (scm_c_lookup ("")); + class_atomic_box = scm_variable_ref (scm_c_lookup ("")); class_vm_cont = scm_variable_ref (scm_c_lookup ("")); class_bytevector = scm_variable_ref (scm_c_lookup ("")); class_uvec = scm_variable_ref (scm_c_lookup ("")); @@ -1008,7 +1011,6 @@ SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0, class_real = scm_variable_ref (scm_c_lookup ("")); class_integer = scm_variable_ref (scm_c_lookup ("")); class_fraction = scm_variable_ref (scm_c_lookup ("")); - class_keyword = scm_variable_ref (scm_c_lookup ("")); class_unknown = scm_variable_ref (scm_c_lookup ("")); class_procedure = scm_variable_ref (scm_c_lookup ("")); class_primitive_generic = scm_variable_ref (scm_c_lookup ("")); diff --git a/libguile/init.c b/libguile/init.c index 1e4889c97..3738538ae 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -37,6 +37,7 @@ #include "libguile/alist.h" #include "libguile/arbiters.h" #include "libguile/async.h" +#include "libguile/atomic.h" #include "libguile/backtrace.h" #include "libguile/bitvectors.h" #include "libguile/boolean.h" @@ -398,6 +399,7 @@ scm_i_init_guile (void *base) scm_bootstrap_loader (); scm_bootstrap_programs (); scm_bootstrap_vm (); + scm_register_atomic (); scm_register_r6rs_ports (); scm_register_fdes_finalizers (); scm_register_foreign (); diff --git a/libguile/print.c b/libguile/print.c index 2485d9716..8161d6581 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -717,6 +717,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) scm_puts ("#:", port); scm_iprin1 (scm_keyword_to_symbol (exp), port, pstate); break; + case scm_tc7_atomic_box: + scm_i_atomic_box_print (exp, port, pstate); + break; case scm_tc7_vm_cont: scm_i_vm_cont_print (exp, port, pstate); break; diff --git a/libguile/tags.h b/libguile/tags.h index 3d6f4bb6a..8f44d96b2 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -415,7 +415,7 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; #define scm_tc7_dynamic_state 0x2d #define scm_tc7_frame 0x2f #define scm_tc7_keyword 0x35 -#define scm_tc7_unused_37 0x37 +#define scm_tc7_atomic_box 0x37 #define scm_tc7_unused_3d 0x3d #define scm_tc7_unused_3f 0x3f #define scm_tc7_program 0x45 diff --git a/libguile/validate.h b/libguile/validate.h index 516a6f750..7c0ce9bbd 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -300,6 +300,12 @@ #define SCM_VALIDATE_VARIABLE(pos, var) SCM_MAKE_VALIDATE_MSG (pos, var, VARIABLEP, "variable") +#define SCM_VALIDATE_ATOMIC_BOX(pos, var) \ + do { \ + SCM_ASSERT_TYPE (scm_is_atomic_box (var), var, pos, FUNC_NAME, \ + "atomic box"); \ + } while (0) + #define SCM_VALIDATE_PROC(pos, proc) \ do { \ SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, pos, FUNC_NAME); \ diff --git a/module/Makefile.am b/module/Makefile.am index 00c394738..0d1f128f1 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -44,6 +44,7 @@ ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm SOURCES = \ ice-9/and-let-star.scm \ + ice-9/atomic.scm \ ice-9/binary-ports.scm \ ice-9/boot-9.scm \ ice-9/buffered-input.scm \ diff --git a/module/ice-9/atomic.scm b/module/ice-9/atomic.scm new file mode 100644 index 000000000..21dba3938 --- /dev/null +++ b/module/ice-9/atomic.scm @@ -0,0 +1,30 @@ +;; Atomic operations + +;;;; Copyright (C) 2016 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + +(define-module (ice-9 atomic) + #:export (make-atomic-box + atomic-box? + atomic-box-ref + atomic-box-set! + atomic-box-swap! + atomic-box-compare-and-swap!)) + +(eval-when (expand load eval) + (load-extension (string-append "libguile-" (effective-version)) + "scm_init_atomic")) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 5a5d469eb..6dae45418 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -62,7 +62,7 @@ - + ;; Numbers. @@ -1009,6 +1009,7 @@ slots as we go." (define-standard-class ()) (define-standard-class ()) (define-standard-class ()) +(define-standard-class ()) (define-standard-class ()) (define-standard-class () #:metaclass ) diff --git a/test-suite/tests/atomic.test b/test-suite/tests/atomic.test new file mode 100644 index 000000000..f6e0c8863 --- /dev/null +++ b/test-suite/tests/atomic.test @@ -0,0 +1,59 @@ +;;;; atomic.test --- test suite for Guile's atomic operations -*- scheme -*- +;;;; +;;;; Copyright (C) 2016 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-suite atomic) + #:use-module (ice-9 atomic) + #:use-module ((oop goops) #:select (class-of )) + #:use-module (test-suite lib)) + +(pass-if (atomic-box? (make-atomic-box 42))) + +(pass-if-equal 42 (atomic-box-ref (make-atomic-box 42))) + +(pass-if-equal 42 (atomic-box-swap! (make-atomic-box 42) 10)) + +(pass-if-equal 10 + (let ((box (make-atomic-box 42))) + (atomic-box-set! box 10) + (atomic-box-ref box))) + +(pass-if-equal 10 + (let ((box (make-atomic-box 42))) + (atomic-box-swap! box 10) + (atomic-box-ref box))) + +(pass-if-equal 42 + (let ((box (make-atomic-box 42))) + (atomic-box-compare-and-swap! box 42 10))) + +(pass-if-equal 42 + (let ((box (make-atomic-box 42))) + (atomic-box-compare-and-swap! box 43 10))) + +(pass-if-equal 10 + (let ((box (make-atomic-box 42))) + (atomic-box-compare-and-swap! box 42 10) + (atomic-box-ref box))) + +(pass-if-equal 42 + (let ((box (make-atomic-box 42))) + (atomic-box-compare-and-swap! box 43 10) + (atomic-box-ref box))) + +(pass-if-equal + (class-of (make-atomic-box 42))) From 73efa8fb06e92eda8221a8a25603fde141ec7949 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 6 Sep 2016 12:05:21 +0200 Subject: [PATCH 516/865] Fix fixnum min/max for assembler * module/system/vm/assembler.scm (immediate-bits): I am a complete and total idiot and got the fixnum mins and maxes swapped. --- module/system/vm/assembler.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index e07f7d4e8..3b9834bcb 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -948,10 +948,10 @@ immediate, and @code{#f} otherwise." ;; Object is an immediate if it is a fixnum on the target. (call-with-values (lambda () (case (asm-word-size asm) - ((4) (values #x1fffffff - (- #x20000000))) - ((8) (values #x1fffffffFFFFFFFF - (- #x2000000000000000))) + ((4) (values (- #x20000000) + #x1fffffff)) + ((8) (values (- #x2000000000000000) + #x1fffffffFFFFFFFF)) (else (error "unexpected word size")))) (lambda (fixnum-min fixnum-max) (and (<= fixnum-min x fixnum-max) From 32f309d5ce3263bde34d392e3df2d1062796d762 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 6 Sep 2016 12:18:35 +0200 Subject: [PATCH 517/865] Compiler support for atomics * doc/ref/vm.texi (Inlined Atomic Instructions): New section. * libguile/vm-engine.c (VM_VALIDATE_ATOMIC_BOX, make-atomic-box) (atomic-box-ref, atomic-box-set!, atomic-box-swap!) (atomic-box-compare-and-swap!): New instructions. * libguile/vm.c: Include atomic and atomics-internal.h. (vm_error_not_a_atomic_box): New function. * module/ice-9/atomic.scm: Register primitives with the compiler. * module/language/cps/compile-bytecode.scm (compile-function): Add support for atomic ops. * module/language/cps/effects-analysis.scm: Add comment about why no effects analysis needed. * module/language/cps/reify-primitives.scm (primitive-module): Add case for (ice-9 atomic). * module/language/tree-il/primitives.scm (*effect-free-primitives*): (*effect+exception-free-primitives*): Add atomic-box?. * module/system/vm/assembler.scm: Add new instructions. * test-suite/tests/atomic.test: Test with compilation and interpretation. --- doc/ref/vm.texi | 32 ++++++++ libguile/vm-engine.c | 95 ++++++++++++++++++++++-- libguile/vm.c | 30 +++++--- module/ice-9/atomic.scm | 10 ++- module/language/cps/compile-bytecode.scm | 15 +++- module/language/cps/effects-analysis.scm | 4 + module/language/cps/reify-primitives.scm | 4 + module/language/tree-il/primitives.scm | 4 +- module/system/vm/assembler.scm | 5 ++ test-suite/tests/atomic.test | 55 +++++++------- 10 files changed, 208 insertions(+), 46 deletions(-) diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 9766ccb67..e870f7391 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -580,6 +580,7 @@ all operands and results are boxed as SCM values. * Dynamic Environment Instructions:: * Miscellaneous Instructions:: * Inlined Scheme Instructions:: +* Inlined Atomic Instructions:: * Inlined Mathematical Instructions:: * Inlined Bytevector Instructions:: * Unboxed Integer Arithmetic:: @@ -1365,6 +1366,37 @@ Convert the Scheme character in @var{src} to an integer, and place it in @end deftypefn +@node Inlined Atomic Instructions +@subsubsection Inlined Atomic Instructions + +@xref{Atomics}, for more on atomic operations in Guile. + +@deftypefn Instruction {} make-atomic-box s12:@var{dst} s12:@var{src} +Create a new atomic box initialized to @var{src}, and place it in +@var{dst}. +@end deftypefn + +@deftypefn Instruction {} atomic-box-ref s12:@var{dst} s12:@var{box} +Fetch the value of the atomic box at @var{box} into @var{dst}. +@end deftypefn + +@deftypefn Instruction {} atomic-box-set! s12:@var{box} s12:@var{val} +Set the contents of the atomic box at @var{box} to @var{val}. +@end deftypefn + +@deftypefn Instruction {} atomic-box-swap! s12:@var{dst} s12:@var{box} x8:@var{_} s24:@var{val} +Replace the contents of the atomic box at @var{box} to @var{val} and +store the previous value at @var{dst}. +@end deftypefn + +@deftypefn Instruction {} atomic-box-compare-and-swap! s12:@var{dst} s12:@var{box} x8:@var{_} s24:@var{expected} x8:@var{_} s24:@var{desired} +If the value of the atomic box at @var{box} is the same as the SCM value +at @var{expected} (in the sense of @code{eq?}), replace the contents of +the box with the SCM value at @var{desired}. Otherwise does not update +the box. Set @var{dst} to the previous value of the box in either case. +@end deftypefn + + @node Inlined Mathematical Instructions @subsubsection Inlined Mathematical Instructions diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index f508cd2f2..852e10d06 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -441,6 +441,8 @@ #define VM_VALIDATE(x, pred, proc, what) \ VM_ASSERT (pred (x), vm_error_not_a_ ## what (proc, x)) +#define VM_VALIDATE_ATOMIC_BOX(x, proc) \ + VM_VALIDATE (x, scm_is_atomic_box, proc, atomic_box) #define VM_VALIDATE_BYTEVECTOR(x, proc) \ VM_VALIDATE (x, SCM_BYTEVECTOR_P, proc, bytevector) #define VM_VALIDATE_CHAR(x, proc) \ @@ -3818,11 +3820,93 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (1); } - VM_DEFINE_OP (178, unused_178, NULL, NOP) - VM_DEFINE_OP (179, unused_179, NULL, NOP) - VM_DEFINE_OP (180, unused_180, NULL, NOP) - VM_DEFINE_OP (181, unused_181, NULL, NOP) - VM_DEFINE_OP (182, unused_182, NULL, NOP) + /* make-atomic-box dst:12 src:12 + * + * Create a new atomic box initialized to SRC, and place it in DST. + */ + VM_DEFINE_OP (178, make_atomic_box, "make-atomic-box", OP1 (X8_S12_S12) | OP_DST) + { + SCM box; + scm_t_uint16 dst, src; + UNPACK_12_12 (op, dst, src); + SYNC_IP (); + box = scm_inline_cell (thread, scm_tc7_atomic_box, + SCM_UNPACK (SCM_UNSPECIFIED)); + scm_atomic_set_scm (scm_atomic_box_loc (box), SP_REF (src)); + SP_SET (dst, box); + NEXT (1); + } + + /* atomic-box-ref dst:12 src:12 + * + * Fetch the value of the atomic box at SRC into DST. + */ + VM_DEFINE_OP (179, atomic_box_ref, "atomic-box-ref", OP1 (X8_S12_S12) | OP_DST) + { + scm_t_uint16 dst, src; + SCM box; + UNPACK_12_12 (op, dst, src); + box = SP_REF (src); + VM_VALIDATE_ATOMIC_BOX (box, "atomic-box-ref"); + SP_SET (dst, scm_atomic_ref_scm (scm_atomic_box_loc (box))); + NEXT (1); + } + + /* atomic-box-set! dst:12 src:12 + * + * Set the contents of the atomic box at DST to SRC. + */ + VM_DEFINE_OP (180, atomic_box_set, "atomic-box-set!", OP1 (X8_S12_S12)) + { + scm_t_uint16 dst, src; + SCM box; + UNPACK_12_12 (op, dst, src); + box = SP_REF (dst); + VM_VALIDATE_ATOMIC_BOX (box, "atomic-box-set!"); + scm_atomic_set_scm (scm_atomic_box_loc (box), SP_REF (src)); + NEXT (1); + } + + /* atomic-box-swap! dst:12 box:12 _:8 val:24 + * + * Replace the contents of the atomic box at BOX to VAL and store the + * previous value at DST. + */ + VM_DEFINE_OP (181, atomic_box_swap, "atomic-box-swap!", OP2 (X8_S12_S12, X8_S24) | OP_DST) + { + scm_t_uint16 dst, box; + scm_t_uint32 val; + SCM scm_box; + UNPACK_12_12 (op, dst, box); + UNPACK_24 (ip[1], val); + scm_box = SP_REF (box); + VM_VALIDATE_ATOMIC_BOX (scm_box, "atomic-box-swap!"); + SP_SET (dst, + scm_atomic_swap_scm (scm_atomic_box_loc (scm_box), SP_REF (val))); + NEXT (2); + } + + /* atomic-box-compare-and-swap! dst:12 box:12 _:8 expected:24 _:8 desired:24 + * + * Set the contents of the atomic box at DST to SET. + */ + VM_DEFINE_OP (182, atomic_box_compare_and_swap, "atomic-box-compare-and-swap!", OP3 (X8_S12_S12, X8_S24, X8_S24) | OP_DST) + { + scm_t_uint16 dst, box; + scm_t_uint32 expected, desired; + SCM scm_box, scm_expected; + UNPACK_12_12 (op, dst, box); + UNPACK_24 (ip[1], expected); + UNPACK_24 (ip[2], desired); + scm_box = SP_REF (box); + VM_VALIDATE_ATOMIC_BOX (scm_box, "atomic-box-compare-and-swap!"); + scm_expected = SP_REF (expected); + scm_atomic_compare_and_swap_scm (scm_atomic_box_loc (scm_box), + &scm_expected, SP_REF (desired)); + SP_SET (dst, scm_expected); + NEXT (3); + } + VM_DEFINE_OP (183, unused_183, NULL, NOP) VM_DEFINE_OP (184, unused_184, NULL, NOP) VM_DEFINE_OP (185, unused_185, NULL, NOP) @@ -3959,6 +4043,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, #undef VM_DEFINE_OP #undef VM_INSTRUCTION_TO_LABEL #undef VM_USE_HOOKS +#undef VM_VALIDATE_ATOMIC_BOX #undef VM_VALIDATE_BYTEVECTOR #undef VM_VALIDATE_PAIR #undef VM_VALIDATE_STRUCT diff --git a/libguile/vm.c b/libguile/vm.c index 60469f631..86e1a0576 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -34,16 +34,19 @@ #include "libguile/bdw-gc.h" #include -#include "_scm.h" -#include "control.h" -#include "frames.h" -#include "gc-inline.h" -#include "instructions.h" -#include "loader.h" -#include "programs.h" -#include "simpos.h" -#include "vm.h" -#include "vm-builtins.h" +#include "libguile/_scm.h" +#include "libguile/atomic.h" +#include "libguile/atomics-internal.h" +#include "libguile/control.h" +#include "libguile/control.h" +#include "libguile/frames.h" +#include "libguile/gc-inline.h" +#include "libguile/instructions.h" +#include "libguile/loader.h" +#include "libguile/programs.h" +#include "libguile/simpos.h" +#include "libguile/vm.h" +#include "libguile/vm-builtins.h" static int vm_default_engine = SCM_VM_REGULAR_ENGINE; @@ -442,6 +445,7 @@ static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_char (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_string (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; +static void vm_error_not_a_atomic_box (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_vector (const char *subr, SCM v) SCM_NORETURN SCM_NOINLINE; @@ -552,6 +556,12 @@ vm_error_not_a_string (const char *subr, SCM x) scm_wrong_type_arg_msg (subr, 1, x, "string"); } +static void +vm_error_not_a_atomic_box (const char *subr, SCM x) +{ + scm_wrong_type_arg_msg (subr, 1, x, "atomic box"); +} + static void vm_error_not_a_bytevector (const char *subr, SCM x) { diff --git a/module/ice-9/atomic.scm b/module/ice-9/atomic.scm index 21dba3938..2a8af901d 100644 --- a/module/ice-9/atomic.scm +++ b/module/ice-9/atomic.scm @@ -18,6 +18,8 @@ ;;;; (define-module (ice-9 atomic) + #:use-module ((language tree-il primitives) + :select (add-interesting-primitive!)) #:export (make-atomic-box atomic-box? atomic-box-ref @@ -27,4 +29,10 @@ (eval-when (expand load eval) (load-extension (string-append "libguile-" (effective-version)) - "scm_init_atomic")) + "scm_init_atomic") + (add-interesting-primitive! 'make-atomic-box) + (add-interesting-primitive! 'atomic-box?) + (add-interesting-primitive! 'atomic-box-ref) + (add-interesting-primitive! 'atomic-box-set!) + (add-interesting-primitive! 'atomic-box-swap!) + (add-interesting-primitive! 'atomic-box-compare-and-swap!)) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 7c69fa6fb..5157ecb70 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -260,6 +260,17 @@ (($ $primcall 'bv-f64-ref (bv idx val)) (emit-bv-f64-ref asm (from-sp dst) (from-sp (slot bv)) (from-sp (slot idx)))) + (($ $primcall 'make-atomic-box (init)) + (emit-make-atomic-box asm (from-sp dst) (from-sp (slot init)))) + (($ $primcall 'atomic-box-ref (box)) + (emit-atomic-box-ref asm (from-sp dst) (from-sp (slot box)))) + (($ $primcall 'atomic-box-swap! (box val)) + (emit-atomic-box-swap! asm (from-sp dst) (from-sp (slot box)) + (from-sp (slot val)))) + (($ $primcall 'atomic-box-compare-and-swap! (box expected desired)) + (emit-atomic-box-compare-and-swap! + asm (from-sp dst) (from-sp (slot box)) + (from-sp (slot expected)) (from-sp (slot desired)))) (($ $primcall name args) ;; FIXME: Inline all the cases. (let ((inst (prim-instruction name))) @@ -351,7 +362,9 @@ (emit-bv-f64-set! asm (from-sp (slot bv)) (from-sp (slot idx)) (from-sp (slot val)))) (($ $primcall 'unwind ()) - (emit-unwind asm)))) + (emit-unwind asm)) + (($ $primcall 'atomic-box-set! (box val)) + (emit-atomic-box-set! asm (from-sp (slot box)) (from-sp (slot val)))))) (define (compile-values label exp syms) (match exp diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 9c408391c..38c0bab7e 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -491,6 +491,10 @@ is or might be a read or a write to the same location as A." ((integer->char _) &type-check) ((char->integer _) &type-check)) +;; Atomics are a memory and a compiler barrier; they cause all effects +;; so no need to have a case for them here. (Though, see +;; https://jfbastien.github.io/no-sane-compiler/.) + (define (primitive-effects constants name args) (let ((proc (hashq-ref *primitive-effects* name))) (if proc diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index 9b700bd83..df4dd248c 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -75,6 +75,10 @@ bytevector-ieee-double-ref bytevector-ieee-double-set! bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!) '(rnrs bytevectors)) + ((atomic-box? + make-atomic-box atomic-box-ref atomic-box-set! + atomic-box-swap! atomic-box-compare-and-swap!) + '(ice-9 atomic)) ((class-of) '(oop goops)) ((u8vector-ref u8vector-set! s8vector-ref s8vector-set! diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 4f960e534..71db1a635 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -171,7 +171,7 @@ not pair? null? nil? list? symbol? variable? vector? struct? string? number? char? - bytevector? keyword? bitvector? + bytevector? keyword? bitvector? atomic-box? complex? real? rational? inf? nan? integer? exact? inexact? even? odd? char=? char>? integer->char char->integer number->string string->number @@ -194,7 +194,7 @@ pair? null? nil? list? symbol? variable? vector? struct? string? number? char? bytevector? keyword? bitvector? - procedure? thunk? + procedure? thunk? atomic-box? acons cons cons* list vector)) ;; Primitives that don't always return one value. diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 3b9834bcb..c72622e70 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -216,6 +216,11 @@ emit-bv-s64-set! emit-bv-f32-set! emit-bv-f64-set! + emit-make-atomic-box + emit-atomic-box-ref + emit-atomic-box-set! + emit-atomic-box-swap! + emit-atomic-box-compare-and-swap! emit-text link-assembly)) diff --git a/test-suite/tests/atomic.test b/test-suite/tests/atomic.test index f6e0c8863..8fc8ba9d3 100644 --- a/test-suite/tests/atomic.test +++ b/test-suite/tests/atomic.test @@ -21,39 +21,40 @@ #:use-module ((oop goops) #:select (class-of )) #:use-module (test-suite lib)) -(pass-if (atomic-box? (make-atomic-box 42))) +(with-test-prefix/c&e "atomics" + (pass-if "predicate" (atomic-box? (make-atomic-box 42))) -(pass-if-equal 42 (atomic-box-ref (make-atomic-box 42))) + (pass-if-equal "ref" 42 (atomic-box-ref (make-atomic-box 42))) -(pass-if-equal 42 (atomic-box-swap! (make-atomic-box 42) 10)) + (pass-if-equal "swap" 42 (atomic-box-swap! (make-atomic-box 42) 10)) -(pass-if-equal 10 - (let ((box (make-atomic-box 42))) - (atomic-box-set! box 10) - (atomic-box-ref box))) + (pass-if-equal "set and ref" 10 + (let ((box (make-atomic-box 42))) + (atomic-box-set! box 10) + (atomic-box-ref box))) -(pass-if-equal 10 - (let ((box (make-atomic-box 42))) - (atomic-box-swap! box 10) - (atomic-box-ref box))) + (pass-if-equal "swap and ref" 10 + (let ((box (make-atomic-box 42))) + (atomic-box-swap! box 10) + (atomic-box-ref box))) -(pass-if-equal 42 - (let ((box (make-atomic-box 42))) - (atomic-box-compare-and-swap! box 42 10))) + (pass-if-equal "compare and swap" 42 + (let ((box (make-atomic-box 42))) + (atomic-box-compare-and-swap! box 42 10))) -(pass-if-equal 42 - (let ((box (make-atomic-box 42))) - (atomic-box-compare-and-swap! box 43 10))) + (pass-if-equal "compare and swap (wrong)" 42 + (let ((box (make-atomic-box 42))) + (atomic-box-compare-and-swap! box 43 10))) -(pass-if-equal 10 - (let ((box (make-atomic-box 42))) - (atomic-box-compare-and-swap! box 42 10) - (atomic-box-ref box))) + (pass-if-equal "compare and swap and ref" 10 + (let ((box (make-atomic-box 42))) + (atomic-box-compare-and-swap! box 42 10) + (atomic-box-ref box))) -(pass-if-equal 42 - (let ((box (make-atomic-box 42))) - (atomic-box-compare-and-swap! box 43 10) - (atomic-box-ref box))) + (pass-if-equal "compare and swap (wrong) and ref" 42 + (let ((box (make-atomic-box 42))) + (atomic-box-compare-and-swap! box 43 10) + (atomic-box-ref box))) -(pass-if-equal - (class-of (make-atomic-box 42))) + (pass-if-equal "class-of" + (class-of (make-atomic-box 42)))) From 5f4a2ac3e793dc45c797f64f3292f6d160068b7b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 6 Sep 2016 21:03:36 +0200 Subject: [PATCH 518/865] Fix cross-compilation of negative fixnums * module/system/vm/assembler.scm (encoder): Use immediate-bits instead of object-address, to fix cross-compilation. --- module/system/vm/assembler.scm | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index c72622e70..a2992b495 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -551,7 +551,7 @@ later by the linker." (record-label-reference asm label) (emit asm opcode)) ((X8_S8_I16 a imm) - (emit asm (pack-u8-u8-u16 opcode a (object-address imm)))) + (emit asm (pack-u8-u8-u16 opcode a (immediate-bits asm imm)))) ((X8_S12_S12 a b) (emit asm (pack-u8-u12-u12 opcode a b))) ((X8_S12_C12 a b) @@ -573,15 +573,14 @@ later by the linker." ((C32 a) (emit asm a)) ((I32 imm) - (let ((val (object-address imm))) - (unless (zero? (ash val -32)) - (error "FIXME: enable truncation of negative fixnums when cross-compiling")) + (let ((val (immediate-bits asm imm))) (emit asm val))) ((A32 imm) (unless (= (asm-word-size asm) 8) (error "make-long-immediate unavailable for this target")) - (emit asm (ash (object-address imm) -32)) - (emit asm (logand (object-address imm) (1- (ash 1 32))))) + (let ((bits (immediate-bits asm imm))) + (emit asm (ash bits -32)) + (emit asm (logand bits (1- (ash 1 32)))))) ((AF32 f64) (let ((u64 (u64vector-ref (f64vector f64) 0))) (emit asm (ash u64 -32)) From b914c518bdd95fb8fbb9a246198de09b72a77490 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 14 Sep 2016 11:06:33 +0200 Subject: [PATCH 519/865] Avoid deprecated statprof interface in test * test-suite/tests/statprof.test ("return values"): Avoid deprecated with-statprof. --- test-suite/tests/statprof.test | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/test-suite/tests/statprof.test b/test-suite/tests/statprof.test index b799f58d3..8965a0374 100644 --- a/test-suite/tests/statprof.test +++ b/test-suite/tests/statprof.test @@ -51,11 +51,12 @@ (lambda () (with-output-to-port (%make-void-port "w") (lambda () - (with-statprof - (let loop ((i 10000)) - (if (zero? i) - (values 42 77) - (loop (1- i)))))))) + (statprof + (lambda () + (let loop ((i 10000)) + (if (zero? i) + (values 42 77) + (loop (1- i))))))))) list)) (pass-if "statistical sample counts within expected range" From 0290b0594a2fa40db0de87703efad47e8981e728 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 14 Sep 2016 11:07:40 +0200 Subject: [PATCH 520/865] Avoid deprecated _IONBF in http tests * test-suite/tests/web-http.test ("chunked encoding"): Avoid deprecated _IONBF. --- test-suite/tests/web-http.test | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test index 762f78c60..03bd8b35b 100644 --- a/test-suite/tests/web-http.test +++ b/test-suite/tests/web-http.test @@ -413,8 +413,8 @@ (input (make-custom-binary-input-port "chunky" read! #f #f #f)) (port (make-chunked-input-port input))) - (setvbuf input _IONBF) - (setvbuf port _IONBF) + (setvbuf input 'none) + (setvbuf port 'none) (list (utf8->string (get-bytevector-n port 6)) (utf8->string (get-bytevector-n port 6)) (utf8->string (get-bytevector-n port 7)) @@ -437,8 +437,8 @@ (input (make-custom-binary-input-port "chunky" read! #f #f #f)) (port (make-chunked-input-port input))) - (setvbuf input _IONBF) - (setvbuf port _IONBF) + (setvbuf input 'none) + (setvbuf port 'none) (list (utf8->string (get-bytevector-n port 6)) (utf8->string (get-bytevector-n port 13)) (utf8->string (get-bytevector-n port 6)) From 6745b9b2bd579656ad8d44cc2488e2a3ff589bea Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 14 Sep 2016 11:27:52 +0200 Subject: [PATCH 521/865] Update NEWS. * NEWS: Update. --- NEWS | 42 +++++++++++++++++++++++++++++++++++++++--- 1 file changed, 39 insertions(+), 3 deletions(-) diff --git a/NEWS b/NEWS index 75e09883c..7576a8224 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,5 @@ Guile NEWS --- history of user-visible changes. -Copyright (C) 1996-2015 Free Software Foundation, Inc. +Copyright (C) 1996-2016 Free Software Foundation, Inc. See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. @@ -9,13 +9,34 @@ Please send Guile bug reports to bug-guile@gnu.org. Changes in 2.1.4 (changes since the 2.1.3 alpha release): * Notable changes +** C99 required + +Following Emacs, you must use a C99-capable compiler when building +Guile. In the future we also expect require C99 to use Guile's C +interface, at least for `stdint' support. + * New interfaces +** Implement R6RS custom binary input/output ports + +See "Custom Ports" in the manual. ** Implement R6RS output-buffer-mode -** Implement R6RS custom binary input/output ports ** Implement R6RS bytevector->string, string->bytevector -* New deprecations +See "R6RS Transcoders" in the manual. + +** Thread-safe atomic boxes (references) + +See "Atomics" in the manual. + +** File descriptor finalizers + +See "Ports and File Descriptors" in the manual. + +* Performance improvements +** Added unboxing support for `logxor' +** Better integer unboxing + * Incompatible changes ** Statically scoped module duplicate handlers @@ -30,12 +51,27 @@ specifies #:duplicates, of course we use that. The handlers of the current module, instead of some global value. * Bug fixes +** Better MinGW support + +`system*' is now supported on MinGW targets. + +** Avoid flushing buffers on ftell + +Fixes regression relative to Guile 2.0. + +** HTTP library does not require ETag lists to be qstrings + ** Fix bug importing specific bindings with #:select It used to be that if #:select didn't find a binding in the public interface of a module, it would actually grovel in the module's unexported private bindings. This was not intended and is now fixed. +** Stronger thread-safety guarantees for port implementations + +See "I/O Extensions" in the manual for notes on threads and port +implementations. + ** Fix fixnum-range checks in R6RS fixnum bitops (http://bugs.gnu.org/14917) From d0e6e3fff84ab5846eee1968e8a89c60b3821a43 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 14 Sep 2016 11:30:50 +0200 Subject: [PATCH 522/865] Bump version to 2.1.4 * GUILE-VERSION (GUILE_MICRO_VERSION): Bump to 2.1.4. --- GUILE-VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index 919a669e4..b287f64e5 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -3,7 +3,7 @@ # Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'. GUILE_MAJOR_VERSION=2 GUILE_MINOR_VERSION=1 -GUILE_MICRO_VERSION=3 +GUILE_MICRO_VERSION=4 GUILE_EFFECTIVE_VERSION=2.2 From f9620e01c3d01abc2fd306ba5dc062a2f252eb97 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 14 Sep 2016 11:50:35 +0200 Subject: [PATCH 523/865] Fix compile warning in posix.c * libguile/posix.c (scm_system_star): Fix SIG_IGN usage to not emit a warning. Still broken on Windows64 and similar systems though! --- libguile/posix.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index 5d0b1ed8f..495bfbbb8 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1483,9 +1483,11 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, scm_dynwind_begin (0); /* Make sure the child can't kill us (as per normal system call). */ - scm_dynwind_sigaction (SIGINT, scm_from_ulong (SIG_IGN), SCM_UNDEFINED); + scm_dynwind_sigaction (SIGINT, scm_from_long ((long) SIG_IGN), + SCM_UNDEFINED); #ifdef SIGQUIT - scm_dynwind_sigaction (SIGQUIT, scm_from_ulong (SIG_IGN), SCM_UNDEFINED); + scm_dynwind_sigaction (SIGQUIT, scm_from_long ((long) SIG_IGN), + SCM_UNDEFINED); #endif res = scm_open_process (scm_nullstr, prog, args); From 67a0b7d3ff57e533fce4f1b58877fbb81dc62a30 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 11 Oct 2016 21:36:42 +0200 Subject: [PATCH 524/865] Remove .gnuploadrc. * .gnuploadrc: Remove file. --- .gnuploadrc | 1 - 1 file changed, 1 deletion(-) delete mode 100644 .gnuploadrc diff --git a/.gnuploadrc b/.gnuploadrc deleted file mode 100644 index 29acf7312..000000000 --- a/.gnuploadrc +++ /dev/null @@ -1 +0,0 @@ ---user ludo@gnu.org From 06e4091c9c05942413cb55b7d9ffef6f83f876f3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 11 Oct 2016 22:08:03 +0200 Subject: [PATCH 525/865] Texinfo serialization: add braces when needed * module/texinfo/serialize.scm (include, empty-command, inline-text): (inline-args, inline-text-args, eol-text-args, eol-text, eol-args) (environ, table-environ, paragraph, item, entry, fragment, serialize) (stexi->texi): Pass extra rest? parameter around to indicate arguments that can take any number of subforms without being surrounded by braces. (embrace, serialize-text-args): Surround non-rest arguments with braces. * test-suite/tests/texinfo.serialize.test: Add tests. --- module/texinfo/serialize.scm | 79 ++++++++++++++++--------- test-suite/tests/texinfo.serialize.test | 9 ++- 2 files changed, 58 insertions(+), 30 deletions(-) diff --git a/module/texinfo/serialize.scm b/module/texinfo/serialize.scm index f3840c49c..05d3facae 100644 --- a/module/texinfo/serialize.scm +++ b/module/texinfo/serialize.scm @@ -28,6 +28,7 @@ #:use-module (texinfo) #:use-module (texinfo string-utils) #:use-module (sxml transform) + #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-13) #:export (stexi->texi)) @@ -61,17 +62,17 @@ ;; Why? Well, because syntax-case defines `include', and carps about its ;; wrong usage below... (eval-when (expand load eval) - (define (include exp lp command type formals args accum) + (define (include exp lp command type formals rest? args accum) (list* "\n" (list-intersperse args " ") " " command "@" accum))) -(define (empty-command exp lp command type formals args accum) +(define (empty-command exp lp command type formals rest? args accum) (list* " " command "@" accum)) -(define (inline-text exp lp command type formals args accum) +(define (inline-text exp lp command type formals rest? args accum) (if (not (string=? command "*braces*")) ;; fixme :( (list* "}" (append-map (lambda (x) (lp x '())) (reverse (cdr exp))) @@ -80,7 +81,7 @@ (append-map (lambda (x) (lp x '())) (reverse (cdr exp))) "@{" accum))) -(define (inline-args exp lp command type formals args accum) +(define (inline-args exp lp command type formals rest? args accum) (list* "}" (if (not args) "" (list-intersperse @@ -98,7 +99,7 @@ ",")) "{" command "@" accum)) -(define (inline-text-args exp lp command type formals args accum) +(define (inline-text-args exp lp command type formals rest? args accum) (list* "}" (if (not args) "" (apply @@ -112,30 +113,49 @@ '(",")))) "{" command "@" accum)) -(define (serialize-text-args lp formals args) - (apply - append - (list-intersperse - (map (lambda (arg) (append-map (lambda (x) (lp x '())) arg)) - (map - reverse - (drop-while - not (map (lambda (x) (assq-ref args x)) - (reverse formals))))) - '(" ")))) +(define (embrace x) + (define (needs-embrace? x) + (define (has-space? x) + (and (string? x) + (string-index x char-set:whitespace))) + (or (null? x) (or-map has-space? x))) + (if (needs-embrace? x) + (append '("}") x '("{")) + x)) -(define (eol-text-args exp lp command type formals args accum) +(define (serialize-text-args lp formals rest? args) + (define (serialize-arg formal rest?) + (let ((val (assq-ref args formal))) + (if val + (let ((out (append-map (lambda (x) (lp x '())) + (reverse val)))) + (if rest? + out + (embrace out))) + #f))) + (define (serialize-args rformals rest?) + (match rformals + (() '()) + ((formal . rformals) + (cons (serialize-arg formal rest?) + (serialize-args rformals #f))))) + (apply append + (list-intersperse + (filter identity (serialize-args (reverse formals) rest?)) + '(" ")))) + +(define (eol-text-args exp lp command type formals rest? args accum) (list* "\n" - (serialize-text-args lp formals args) + (serialize-text-args lp formals rest? args) " " command "@" accum)) -(define (eol-text exp lp command type formals args accum) +(define (eol-text exp lp command type formals rest? args accum) (list* "\n" (append-map (lambda (x) (lp x '())) (reverse (if args (cddr exp) (cdr exp)))) " " command "@" accum)) -(define (eol-args exp lp command type formals args accum) +(define (eol-args exp lp command type formals rest? args accum) (list* "\n" (list-intersperse (apply append @@ -145,7 +165,7 @@ ", ") " " command "@" accum)) -(define (environ exp lp command type formals args accum) +(define (environ exp lp command type formals rest? args accum) (case (car exp) ((texinfo) (list* "@bye\n" @@ -169,10 +189,10 @@ body (cons "\n" body))) "\n" - (serialize-text-args lp formals args) + (serialize-text-args lp formals rest? args) " " command "@" accum)))) -(define (table-environ exp lp command type formals args accum) +(define (table-environ exp lp command type formals rest? args accum) (list* "\n\n" command "@end " (append-map (lambda (x) (lp x '())) (reverse (if args (cddr exp) (cdr exp)))) @@ -188,26 +208,26 @@ #:line-width 72 #:break-long-words? #f)) -(define (paragraph exp lp command type formals args accum) +(define (paragraph exp lp command type formals rest? args accum) (list* "\n\n" (wrap (reverse (append-map (lambda (x) (lp x '())) (reverse (cdr exp))))) accum)) -(define (item exp lp command type formals args accum) +(define (item exp lp command type formals rest? args accum) (list* (append-map (lambda (x) (lp x '())) (reverse (cdr exp))) "@item\n" accum)) -(define (entry exp lp command type formals args accum) +(define (entry exp lp command type formals rest? args accum) (list* (append-map (lambda (x) (lp x '())) (reverse (cddr exp))) "\n" (append-map (lambda (x) (lp x '())) (reverse (cdar args))) "@item " accum)) -(define (fragment exp lp command type formals args accum) +(define (fragment exp lp command type formals rest? args accum) (list* "\n@c %end of fragment\n" (append-map (lambda (x) (lp x '())) (reverse (cdr exp))) "\n@c %start of fragment\n\n" @@ -230,10 +250,10 @@ (FRAGMENT . ,fragment) (#f . ,include))) ; support writing include statements -(define (serialize exp lp command type formals args accum) +(define (serialize exp lp command type formals rest? args accum) ((or (assq-ref serializers type) (error "Unknown command type" exp type)) - exp lp command type formals args accum)) + exp lp command type formals rest? args accum)) (define escaped-chars '(#\} #\{ #\@)) (define (escape str) @@ -263,6 +283,7 @@ (symbol->string (car in)) (cadr command-spec) (filter* symbol? (cddr command-spec)) + (not (list? (cddr command-spec))) (cond ((and (pair? (cdr in)) (pair? (cadr in)) (eq? (caadr in) '%)) diff --git a/test-suite/tests/texinfo.serialize.test b/test-suite/tests/texinfo.serialize.test index 554390c0f..1c28b5a31 100644 --- a/test-suite/tests/texinfo.serialize.test +++ b/test-suite/tests/texinfo.serialize.test @@ -28,7 +28,7 @@ (with-test-prefix "test-serialize" (define (assert-serialize stexi str) - (pass-if str (equal? str (stexi->texi stexi)))) + (pass-if-equal stexi str (stexi->texi stexi))) (assert-serialize '(para) " @@ -182,4 +182,11 @@ foo "@deffnx bar foo (x @code{int}) ") + (assert-serialize '(deffnx (% (name "foo") (category "bar baz") (arguments "(" "x" " " (code "int") ")"))) + "@deffnx {bar baz} foo (x @code{int}) +") + + (assert-serialize '(deffnx (% (name "foo") (category (code "bar") " baz") (arguments "(" "x" " " (code "int") ")"))) + "@deffnx {@code{bar} baz} foo (x @code{int}) +") ) From 8622344a6b435f1e95cf3e84da3607ba3299cdf0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 11 Oct 2016 22:15:15 +0200 Subject: [PATCH 526/865] Fix slot allocation for prompts * module/language/cps/slot-allocation.scm (add-prompt-control-flow-edges): Fix to add links from prompt bodies to handlers, even in cases where the handler can reach the body but the body can't reach the handler. * test-suite/tests/compiler.test ("prompt body slot allocation"): Add test case. --- module/language/cps/slot-allocation.scm | 51 +++++++++++++++---------- test-suite/tests/compiler.test | 25 ++++++++++++ 2 files changed, 55 insertions(+), 21 deletions(-) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 32f0ace99..f3e0dac92 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -217,32 +217,41 @@ body continuation in the prompt." (if (or res (pred i)) #t res)) set #f)) + (define (compute-prompt-body label) + (persistent-intset + (let visit-cont ((label label) (level 1) (labels empty-intset)) + (cond + ((zero? level) labels) + ((intset-ref labels label) labels) + (else + (match (intmap-ref conts label) + (($ $ktail) + ;; Possible for bailouts; never reached and not part of + ;; prompt body. + labels) + (cont + (let ((labels (intset-add! labels label))) + (match cont + (($ $kreceive arity k) (visit-cont k level labels)) + (($ $kargs names syms ($ $continue k src ($ $primcall 'wind))) + (visit-cont k (1+ level) labels)) + (($ $kargs names syms + ($ $continue k src ($ $prompt escape? tag handler))) + (visit-cont handler level (visit-cont k (1+ level) labels))) + (($ $kargs names syms ($ $continue k src ($ $primcall 'unwind))) + (visit-cont k (1- level) labels)) + (($ $kargs names syms ($ $continue k src ($ $branch kt))) + (visit-cont k level (visit-cont kt level labels))) + (($ $kargs names syms ($ $continue k src exp)) + (visit-cont k level labels))))))))))) (define (visit-prompt label handler succs) - ;; FIXME: It isn't correct to use all continuations reachable from - ;; the prompt, because that includes continuations outside the - ;; prompt body. This point is moot if the handler's control flow - ;; joins with the the body, as is usually but not always the case. - ;; - ;; One counter-example is when the handler contifies an infinite - ;; loop; in that case we compute a too-large prompt body. This - ;; error is currently innocuous, but we should fix it at some point. - ;; - ;; The fix is to end the body at the corresponding "pop" primcall, - ;; if any. - (let ((body (intset-subtract (compute-function-body conts label) - (compute-function-body conts handler)))) + (let ((body (compute-prompt-body label))) (define (out-or-back-edge? label) ;; Most uses of visit-prompt-control-flow don't need every body ;; continuation, and would be happy getting called only for ;; continuations that postdominate the rest of the body. Unless ;; you pass #:complete? #t, we only invoke F on continuations ;; that can leave the body, or on back-edges in loops. - ;; - ;; You would think that looking for the final "pop" primcall - ;; would be sufficient, but that is incorrect; it's possible for - ;; a loop in the prompt body to be contified, and that loop need - ;; not continue to the pop if it never terminates. The pop could - ;; even be removed by DCE, in that case. (intset-any (lambda (succ) (or (not (intset-ref body succ)) (<= succ label))) @@ -255,8 +264,8 @@ body continuation in the prompt." (lambda (label cont succs) (match cont (($ $kargs _ _ - ($ $continue _ _ ($ $prompt escape? tag handler))) - (visit-prompt label handler succs)) + ($ $continue k _ ($ $prompt escape? tag handler))) + (visit-prompt k handler succs)) (_ succs))) conts succs)) diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test index bdae9a75d..582ce6e28 100644 --- a/test-suite/tests/compiler.test +++ b/test-suite/tests/compiler.test @@ -214,3 +214,28 @@ (pass-if "Chained comparisons" (not (compile '(false-if-exception (< 'not-a-number)))))) + +(with-test-prefix "prompt body slot allocation" + (define test-code + '(begin + (use-modules (ice-9 control)) + + (define (foo k) (k)) + (define (qux k) 42) + + (define (test) + (let lp ((i 0)) + (when (< i 5) + (let/ec cancel (let lp () (qux cancel) (foo cancel) (lp))) + (lp (1+ i))))) + test)) + (define test-proc #f) + (pass-if "compiling test works" + (begin + (set! test-proc (compile test-code)) + (procedure? test-proc))) + + (pass-if "test terminates without error" + (begin + (test-proc) + #t))) From e61017afa84031ce1c4d3535091a195142a82966 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 17 Oct 2016 21:26:40 +0200 Subject: [PATCH 527/865] Fold 2.1.4 news into 2.2 news * NEWS: Fold 2.1.4 news into main 2.2 news. --- NEWS | 119 +++++++++++++++++++++++------------------------------------ 1 file changed, 46 insertions(+), 73 deletions(-) diff --git a/NEWS b/NEWS index 7576a8224..2ee3d3f6e 100644 --- a/NEWS +++ b/NEWS @@ -6,85 +6,13 @@ Please send Guile bug reports to bug-guile@gnu.org. -Changes in 2.1.4 (changes since the 2.1.3 alpha release): +Changes in 2.1.5 (changes since the 2.1.4 alpha release): * Notable changes -** C99 required - -Following Emacs, you must use a C99-capable compiler when building -Guile. In the future we also expect require C99 to use Guile's C -interface, at least for `stdint' support. - * New interfaces -** Implement R6RS custom binary input/output ports - -See "Custom Ports" in the manual. - -** Implement R6RS output-buffer-mode -** Implement R6RS bytevector->string, string->bytevector - -See "R6RS Transcoders" in the manual. - -** Thread-safe atomic boxes (references) - -See "Atomics" in the manual. - -** File descriptor finalizers - -See "Ports and File Descriptors" in the manual. - * Performance improvements -** Added unboxing support for `logxor' -** Better integer unboxing - * Incompatible changes -** Statically scoped module duplicate handlers - -It used to be that if a module did not specify a #:duplicates handler, -when a name was first referenced in that module and multiple imported -modules provide that name, the value of the -`default-duplicate-binding-handlers' parameter would be used to resolve -the duplicate bindings. We have changed so that instead a module -defaults to the set of handlers described in the manual. If the module -specifies #:duplicates, of course we use that. The -`default-duplicate-binding-handlers' parameter now simply accesses the -handlers of the current module, instead of some global value. - * Bug fixes -** Better MinGW support - -`system*' is now supported on MinGW targets. - -** Avoid flushing buffers on ftell - -Fixes regression relative to Guile 2.0. - -** HTTP library does not require ETag lists to be qstrings - -** Fix bug importing specific bindings with #:select - -It used to be that if #:select didn't find a binding in the public -interface of a module, it would actually grovel in the module's -unexported private bindings. This was not intended and is now fixed. - -** Stronger thread-safety guarantees for port implementations - -See "I/O Extensions" in the manual for notes on threads and port -implementations. - -** Fix fixnum-range checks in R6RS fixnum bitops - (http://bugs.gnu.org/14917) - -** Fix `monitor' macro - -** Fix bug with GUILE_INSTALL_LOCALE=1 and default port encodings - -If GUILE_INSTALL_LOCALE is unset in the environment or set to 1, Guile -will call setlocale() to install the locale. However it was neglecting -to set the default port encoding to the locale's encoding. This is -fixed. - -** Various compiler bug fixes Previous changes in 2.1.x (changes since the 2.0.x series): @@ -188,6 +116,12 @@ date, then no .go file would be loaded. Now Guile will continue to search the path for a file which is both present and up-to-date, with respect to the .scm file. +** C99 required + +Following Emacs, you must use a C99-capable compiler when building +Guile. In the future we also expect require C99 to use Guile's C +interface, at least for `stdint' support. + * Performance improvements ** Faster programs via new virtual machine @@ -293,6 +227,23 @@ See the newly updated "Statprof" section of the manual, for more. See "Non-Blocking I/O" in the manual, for more. +** Implement R6RS custom binary input/output ports + +See "Custom Ports" in the manual. + +** Implement R6RS output-buffer-mode +** Implement R6RS bytevector->string, string->bytevector + +See "R6RS Transcoders" in the manual. + +** Thread-safe atomic boxes (references) + +See "Atomics" in the manual. + +** File descriptor finalizers + +See "Ports and File Descriptors" in the manual. + ** New inline functions: `scm_new_smob', `scm_new_double_smob' These can replace many uses of SCM_NEWSMOB, SCM_RETURN_NEWSMOB2, and the @@ -565,6 +516,24 @@ are matched by binding. This allows literals to be reliably bound to values, renamed by imports or exports, et cetera. See "Syntax-rules Macros" in the manual for more on literals. +** Fix bug importing specific bindings with #:select + +It used to be that if #:select didn't find a binding in the public +interface of a module, it would actually grovel in the module's +unexported private bindings. This was not intended and is now fixed. + +** Statically scoped module duplicate handlers + +It used to be that if a module did not specify a #:duplicates handler, +when a name was first referenced in that module and multiple imported +modules provide that name, the value of the +`default-duplicate-binding-handlers' parameter would be used to resolve +the duplicate bindings. We have changed so that instead a module +defaults to the set of handlers described in the manual. If the module +specifies #:duplicates, of course we use that. The +`default-duplicate-binding-handlers' parameter now simply accesses the +handlers of the current module, instead of some global value. + ** `dynamic-wind' doesn't check that guards are thunks Checking that the dynamic-wind out-guard procedure was actually a thunk @@ -691,6 +660,10 @@ scm_t_debug_info', `scm_pure_generic_p', `SCM_PUREGENERICP', Instead, use the symbol values `none', `line', or `block', respectively, as arguments to the `setvbuf' function. +** Arbiters + +Use mutexes or atomic variables instead. + ** `with-statprof' macro deprecated Use the `statprof' procedure instead. From 56d8d9a2577ea96a598f87f50dd6eafab0fcef26 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 17 Oct 2016 21:25:18 +0200 Subject: [PATCH 528/865] Deprecate arbiters * libguile/arbiters.c: * libguile/arbiters.h: * test-suite/tests/arbiters.test: Delete files. * libguile/deprecated.c: * libguile/deprecated.h: Move arbiters code here. * doc/ref/api-scheduling.texi: Remove section on arbiters. * libguile.h: * libguile/Makefile.am: * libguile/init.c: * module/oop/goops.scm: * test-suite/Makefile.am: Remove mention of arbiters. * NEWS: Update. --- NEWS | 7 ++ doc/ref/api-scheduling.texi | 38 ------- libguile.h | 1 - libguile/Makefile.am | 4 - libguile/arbiters.c | 174 --------------------------------- libguile/arbiters.h | 41 -------- libguile/deprecated.c | 95 ++++++++++++++++++ libguile/deprecated.h | 6 ++ libguile/init.c | 2 - module/oop/goops.scm | 6 +- test-suite/Makefile.am | 1 - test-suite/tests/arbiters.test | 102 ------------------- 12 files changed, 112 insertions(+), 365 deletions(-) delete mode 100644 libguile/arbiters.c delete mode 100644 libguile/arbiters.h delete mode 100644 test-suite/tests/arbiters.test diff --git a/NEWS b/NEWS index 2ee3d3f6e..f94e590bc 100644 --- a/NEWS +++ b/NEWS @@ -12,6 +12,13 @@ Changes in 2.1.5 (changes since the 2.1.4 alpha release): * New interfaces * Performance improvements * Incompatible changes +* New deprecations +** Arbiters deprecated + +Arbiters were an experimental mutual exclusion facility from 20 years +ago that didn't survive the test of time. Use mutexes or atomic boxes +instead. + * Bug fixes diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index 38f5ac4a2..de076374d 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -8,7 +8,6 @@ @section Threads, Mutexes, Asyncs and Dynamic Roots @menu -* Arbiters:: Synchronization primitives. * Asyncs:: Asynchronous procedure invocation. * Atomics:: Atomic references. * Threads:: Multiple threads of execution. @@ -22,43 +21,6 @@ @end menu -@node Arbiters -@subsection Arbiters -@cindex arbiters - -Arbiters are synchronization objects, they can be used by threads to -control access to a shared resource. An arbiter can be locked to -indicate a resource is in use, and unlocked when done. - -An arbiter is like a light-weight mutex (@pxref{Mutexes and Condition -Variables}). It uses less memory and may be faster, but there's no -way for a thread to block waiting on an arbiter, it can only test and -get the status returned. - -@deffn {Scheme Procedure} make-arbiter name -@deffnx {C Function} scm_make_arbiter (name) -Return an object of type arbiter and name @var{name}. Its -state is initially unlocked. Arbiters are a way to achieve -process synchronization. -@end deffn - -@deffn {Scheme Procedure} try-arbiter arb -@deffnx {C Function} scm_try_arbiter (arb) -If @var{arb} is unlocked, then lock it and return @code{#t}. -If @var{arb} is already locked, then do nothing and return -@code{#f}. -@end deffn - -@deffn {Scheme Procedure} release-arbiter arb -@deffnx {C Function} scm_release_arbiter (arb) -If @var{arb} is locked, then unlock it and return @code{#t}. If -@var{arb} is already unlocked, then do nothing and return @code{#f}. - -Typical usage is for the thread which locked an arbiter to later -release it, but that's not required, any thread can release it. -@end deffn - - @node Asyncs @subsection Asyncs diff --git a/libguile.h b/libguile.h index 8354e7cca..0a1f0dcd6 100644 --- a/libguile.h +++ b/libguile.h @@ -30,7 +30,6 @@ extern "C" { #include "libguile/__scm.h" #include "libguile/alist.h" -#include "libguile/arbiters.h" #include "libguile/array-handle.h" #include "libguile/array-map.h" #include "libguile/arrays.h" diff --git a/libguile/Makefile.am b/libguile/Makefile.am index e5011da91..31cff7587 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -120,7 +120,6 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_CFLAGS = $(GUILE_CFLAGS) $(AM_CFLAGS) libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ alist.c \ - arbiters.c \ array-handle.c \ array-map.c \ arrays.c \ @@ -231,7 +230,6 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ DOT_X_FILES = \ alist.x \ - arbiters.x \ array-handle.x \ array-map.x \ arrays.x \ @@ -339,7 +337,6 @@ EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@ DOT_DOC_FILES = \ alist.doc \ - arbiters.doc \ array-handle.doc \ array-map.doc \ arrays.doc \ @@ -567,7 +564,6 @@ modincludedir = $(pkgincludedir)/$(GUILE_EFFECTIVE_VERSION)/libguile modinclude_HEADERS = \ __scm.h \ alist.h \ - arbiters.h \ array-handle.h \ array-map.h \ arrays.h \ diff --git a/libguile/arbiters.c b/libguile/arbiters.c deleted file mode 100644 index f1ace572d..000000000 --- a/libguile/arbiters.c +++ /dev/null @@ -1,174 +0,0 @@ -/* Copyright (C) 1995,1996, 1997, 2000, 2001, 2004, 2005, 2006, 2008, 2011 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 License - * as published by the Free Software Foundation; either version 3 of - * the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA - * 02110-1301 USA - */ - - - -#ifdef HAVE_CONFIG_H -# include -#endif - -#include "libguile/_scm.h" -#include "libguile/ports.h" -#include "libguile/smob.h" - -#include "libguile/validate.h" -#include "libguile/arbiters.h" - - -/* FETCH_STORE sets "fet" to the value fetched from "mem" and then stores - "sto" there. The fetch and store are done atomically, so once the fetch - has been done no other thread or processor can fetch from there before - the store is done. - - The operands are scm_t_bits, fet and sto are plain variables, mem is a - memory location (ie. an lvalue). - - ENHANCE-ME: Add more cpu-specifics. glibc atomicity.h has some of the - sort of thing required. FETCH_STORE could become some sort of - compare-and-store if that better suited what various cpus do. */ - -#if defined (__GNUC__) && defined (i386) && SIZEOF_SCM_T_BITS == 4 -/* This is for i386 with the normal 32-bit scm_t_bits. The xchg instruction - is atomic on a single processor, and it automatically asserts the "lock" - bus signal so it's atomic on a multi-processor (no need for the lock - prefix on the instruction). - - The mem operand is read-write but "+" is not used since old gcc - (eg. 2.7.2) doesn't support that. "1" for the mem input doesn't work - (eg. gcc 3.3) when mem is a pointer dereference like current usage below. - Having mem as a plain input should be ok though. It tells gcc the value - is live, but as an "m" gcc won't fetch it itself (though that would be - harmless). */ - -#define FETCH_STORE(fet,mem,sto) \ - do { \ - asm ("xchg %0, %1" \ - : "=r" (fet), "=m" (mem) \ - : "0" (sto), "m" (mem)); \ - } while (0) -#endif - -#ifndef FETCH_STORE -/* This is a generic version, with a mutex to ensure the operation is - atomic. Unfortunately this approach probably makes arbiters no faster - than mutexes (though still using less memory of course), so some - CPU-specifics are highly desirable. */ -#define FETCH_STORE(fet,mem,sto) \ - do { \ - scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex); \ - (fet) = (mem); \ - (mem) = (sto); \ - scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); \ - } while (0) -#endif - - -static scm_t_bits scm_tc16_arbiter; - - -#define SCM_LOCK_VAL (scm_tc16_arbiter | (1L << 16)) -#define SCM_UNLOCK_VAL scm_tc16_arbiter -#define SCM_ARB_LOCKED(arb) ((SCM_CELL_WORD_0 (arb)) & (1L << 16)) - - -static int -arbiter_print (SCM exp, SCM port, scm_print_state *pstate) -{ - scm_puts ("#', port); - return !0; -} - -SCM_DEFINE (scm_make_arbiter, "make-arbiter", 1, 0, 0, - (SCM name), - "Return an arbiter object, initially unlocked. Currently\n" - "@var{name} is only used for diagnostic output.") -#define FUNC_NAME s_scm_make_arbiter -{ - SCM_RETURN_NEWSMOB (scm_tc16_arbiter, SCM_UNPACK (name)); -} -#undef FUNC_NAME - - -/* The atomic FETCH_STORE here is so two threads can't both see the arbiter - unlocked and return #t. The arbiter itself wouldn't be corrupted by - this, but two threads both getting #t would be contrary to the intended - semantics. */ - -SCM_DEFINE (scm_try_arbiter, "try-arbiter", 1, 0, 0, - (SCM arb), - "If @var{arb} is unlocked, then lock it and return @code{#t}.\n" - "If @var{arb} is already locked, then do nothing and return\n" - "@code{#f}.") -#define FUNC_NAME s_scm_try_arbiter -{ - scm_t_bits old; - scm_t_bits *loc; - SCM_VALIDATE_SMOB (1, arb, arbiter); - loc = (scm_t_bits*)SCM_SMOB_OBJECT_N_LOC (arb, 0); - FETCH_STORE (old, *loc, SCM_LOCK_VAL); - return scm_from_bool (old == SCM_UNLOCK_VAL); -} -#undef FUNC_NAME - - -/* The atomic FETCH_STORE here is so two threads can't both see the arbiter - locked and return #t. The arbiter itself wouldn't be corrupted by this, - but we don't want two threads both thinking they were the unlocker. The - intended usage is for the code which locked to be responsible for - unlocking, but we guarantee the return value even if multiple threads - compete. */ - -SCM_DEFINE (scm_release_arbiter, "release-arbiter", 1, 0, 0, - (SCM arb), - "If @var{arb} is locked, then unlock it and return @code{#t}.\n" - "If @var{arb} is already unlocked, then do nothing and return\n" - "@code{#f}.\n" - "\n" - "Typical usage is for the thread which locked an arbiter to\n" - "later release it, but that's not required, any thread can\n" - "release it.") -#define FUNC_NAME s_scm_release_arbiter -{ - scm_t_bits old; - scm_t_bits *loc; - SCM_VALIDATE_SMOB (1, arb, arbiter); - loc = (scm_t_bits*)SCM_SMOB_OBJECT_N_LOC (arb, 0); - FETCH_STORE (old, *loc, SCM_UNLOCK_VAL); - return scm_from_bool (old == SCM_LOCK_VAL); -} -#undef FUNC_NAME - - - -void -scm_init_arbiters () -{ - scm_tc16_arbiter = scm_make_smob_type ("arbiter", 0); - scm_set_smob_print (scm_tc16_arbiter, arbiter_print); -#include "libguile/arbiters.x" -} - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ diff --git a/libguile/arbiters.h b/libguile/arbiters.h deleted file mode 100644 index 214e92a34..000000000 --- a/libguile/arbiters.h +++ /dev/null @@ -1,41 +0,0 @@ -/* classes: h_files */ - -#ifndef SCM_ARBITERS_H -#define SCM_ARBITERS_H - -/* Copyright (C) 1995,1996,2000, 2006, 2008 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 License - * as published by the Free Software Foundation; either version 3 of - * the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA - * 02110-1301 USA - */ - - - -#include "libguile/__scm.h" - - - -SCM_API SCM scm_make_arbiter (SCM name); -SCM_API SCM scm_try_arbiter (SCM arb); -SCM_API SCM scm_release_arbiter (SCM arb); -SCM_INTERNAL void scm_init_arbiters (void); - -#endif /* SCM_ARBITERS_H */ - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ diff --git a/libguile/deprecated.c b/libguile/deprecated.c index af7643487..bae4ed449 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -485,11 +485,106 @@ scm_slot_exists_using_class_p (SCM class, SCM obj, SCM slot_name) } + +#define FETCH_STORE(fet,mem,sto) \ + do { \ + scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex); \ + (fet) = (mem); \ + (mem) = (sto); \ + scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); \ + } while (0) + +static scm_t_bits scm_tc16_arbiter; + + +#define SCM_LOCK_VAL (scm_tc16_arbiter | (1L << 16)) +#define SCM_UNLOCK_VAL scm_tc16_arbiter +#define SCM_ARB_LOCKED(arb) ((SCM_CELL_WORD_0 (arb)) & (1L << 16)) + + +static int +arbiter_print (SCM exp, SCM port, scm_print_state *pstate) +{ + scm_puts ("#', port); + return !0; +} + +SCM_DEFINE (scm_make_arbiter, "make-arbiter", 1, 0, 0, + (SCM name), + "Return an arbiter object, initially unlocked. Currently\n" + "@var{name} is only used for diagnostic output.") +#define FUNC_NAME s_scm_make_arbiter +{ + scm_c_issue_deprecation_warning + ("Arbiters are deprecated. " + "Use mutexes or atomic variables instead."); + + SCM_RETURN_NEWSMOB (scm_tc16_arbiter, SCM_UNPACK (name)); +} +#undef FUNC_NAME + + +/* The atomic FETCH_STORE here is so two threads can't both see the arbiter + unlocked and return #t. The arbiter itself wouldn't be corrupted by + this, but two threads both getting #t would be contrary to the intended + semantics. */ + +SCM_DEFINE (scm_try_arbiter, "try-arbiter", 1, 0, 0, + (SCM arb), + "If @var{arb} is unlocked, then lock it and return @code{#t}.\n" + "If @var{arb} is already locked, then do nothing and return\n" + "@code{#f}.") +#define FUNC_NAME s_scm_try_arbiter +{ + scm_t_bits old; + scm_t_bits *loc; + SCM_VALIDATE_SMOB (1, arb, arbiter); + loc = (scm_t_bits*)SCM_SMOB_OBJECT_N_LOC (arb, 0); + FETCH_STORE (old, *loc, SCM_LOCK_VAL); + return scm_from_bool (old == SCM_UNLOCK_VAL); +} +#undef FUNC_NAME + + +/* The atomic FETCH_STORE here is so two threads can't both see the arbiter + locked and return #t. The arbiter itself wouldn't be corrupted by this, + but we don't want two threads both thinking they were the unlocker. The + intended usage is for the code which locked to be responsible for + unlocking, but we guarantee the return value even if multiple threads + compete. */ + +SCM_DEFINE (scm_release_arbiter, "release-arbiter", 1, 0, 0, + (SCM arb), + "If @var{arb} is locked, then unlock it and return @code{#t}.\n" + "If @var{arb} is already unlocked, then do nothing and return\n" + "@code{#f}.\n" + "\n" + "Typical usage is for the thread which locked an arbiter to\n" + "later release it, but that's not required, any thread can\n" + "release it.") +#define FUNC_NAME s_scm_release_arbiter +{ + scm_t_bits old; + scm_t_bits *loc; + SCM_VALIDATE_SMOB (1, arb, arbiter); + loc = (scm_t_bits*)SCM_SMOB_OBJECT_N_LOC (arb, 0); + FETCH_STORE (old, *loc, SCM_UNLOCK_VAL); + return scm_from_bool (old == SCM_LOCK_VAL); +} +#undef FUNC_NAME + + void scm_i_init_deprecated () { + scm_tc16_arbiter = scm_make_smob_type ("arbiter", 0); + scm_set_smob_print (scm_tc16_arbiter, arbiter_print); #include "libguile/deprecated.x" } diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 592dc98d5..5e8e8f819 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -217,6 +217,12 @@ SCM_DEPRECATED SCM scm_slot_exists_using_class_p (SCM cls, SCM obj, SCM slot_nam +SCM_DEPRECATED SCM scm_make_arbiter (SCM name); +SCM_DEPRECATED SCM scm_try_arbiter (SCM arb); +SCM_DEPRECATED SCM scm_release_arbiter (SCM arb); + + + void scm_i_init_deprecated (void); #endif diff --git a/libguile/init.c b/libguile/init.c index 3738538ae..31363c69b 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -35,7 +35,6 @@ /* Everybody has an init function. */ #include "libguile/alist.h" -#include "libguile/arbiters.h" #include "libguile/async.h" #include "libguile/atomic.h" #include "libguile/backtrace.h" @@ -419,7 +418,6 @@ scm_i_init_guile (void *base) scm_init_thread_procs (); /* requires gsubrs */ scm_init_procprop (); scm_init_alist (); - scm_init_arbiters (); /* requires smob_prehistory */ scm_init_async (); /* requires smob_prehistory */ scm_init_boolean (); scm_init_chars (); diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 6dae45418..1d56cc7e1 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -74,7 +74,7 @@ ;; corresponding classes, which may be obtained via class-of, ;; once you have an instance. Perhaps FIXME to provide a ;; smob-type-name->class procedure. - + @@ -3096,7 +3096,9 @@ var{initargs}." ;;; {SMOB and port classes} ;;; -(define (find-subclass ')) +(begin-deprecated + (define-public (find-subclass '))) + (define (find-subclass ')) (define (find-subclass ')) (define (find-subclass ')) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 3c88405cb..f940d78c7 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -26,7 +26,6 @@ SCM_TESTS = tests/00-initial-env.test \ tests/00-socket.test \ tests/alist.test \ tests/and-let-star.test \ - tests/arbiters.test \ tests/arrays.test \ tests/bit-operations.test \ tests/bitvectors.test \ diff --git a/test-suite/tests/arbiters.test b/test-suite/tests/arbiters.test deleted file mode 100644 index 36dc7edbd..000000000 --- a/test-suite/tests/arbiters.test +++ /dev/null @@ -1,102 +0,0 @@ -;;;; arbiters.test --- test arbiters functions -*- scheme -*- -;;;; -;;;; Copyright (C) 2004, 2006 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 -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -(define-module (test-suite test-arbiters) - #:use-module (test-suite lib)) - -;;; -;;; arbiter display -;;; - -(with-test-prefix "arbiter display" - ;; nothing fancy, just exercise the printing code - - (pass-if "never locked" - (let ((arb (make-arbiter "foo")) - (port (open-output-string))) - (display arb port) - #t)) - - (pass-if "locked" - (let ((arb (make-arbiter "foo")) - (port (open-output-string))) - (try-arbiter arb) - (display arb port) - #t)) - - (pass-if "unlocked" - (let ((arb (make-arbiter "foo")) - (port (open-output-string))) - (try-arbiter arb) - (release-arbiter arb) - (display arb port) - #t))) - -;;; -;;; try-arbiter -;;; - -(with-test-prefix "try-arbiter" - - (pass-if "lock" - (let ((arb (make-arbiter "foo"))) - (try-arbiter arb))) - - (pass-if "already locked" - (let ((arb (make-arbiter "foo"))) - (try-arbiter arb) - (not (try-arbiter arb)))) - - (pass-if "already locked twice" - (let ((arb (make-arbiter "foo"))) - (try-arbiter arb) - (try-arbiter arb) - (not (try-arbiter arb))))) - -;;; -;;; release-arbiter -;;; - -(with-test-prefix "release-arbiter" - - (pass-if "lock" - (let ((arb (make-arbiter "foo"))) - (try-arbiter arb) - (release-arbiter arb))) - - (pass-if "never locked" - (let ((arb (make-arbiter "foo"))) - (not (release-arbiter arb)))) - - (pass-if "never locked twice" - (let ((arb (make-arbiter "foo"))) - (release-arbiter arb) - (not (release-arbiter arb)))) - - (pass-if "already unlocked" - (let ((arb (make-arbiter "foo"))) - (try-arbiter arb) - (release-arbiter arb) - (not (release-arbiter arb)))) - - (pass-if "already unlocked twice" - (let ((arb (make-arbiter "foo"))) - (try-arbiter arb) - (release-arbiter arb) - (release-arbiter arb) - (not (release-arbiter arb))))) From 59f09d185b143326fb5c4d47bbd66eebe2b28d87 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 17 Oct 2016 21:58:08 +0200 Subject: [PATCH 529/865] Deprecate user asyncs * libguile/async.c: * libguile/async.h: * libguile/deprecated.c: * libguile/deprecated.h (scm_async, scm_async_mark, scm_run_asyncs): Deprecate these functions, which comprise the "users asyncs" facility. * module/oop/goops.scm: Adapt to deprecation. * doc/ref/api-scheduling.texi: * doc/ref/libguile-concepts.texi: * doc/ref/libguile-foreign-objects.texi: * doc/ref/posix.texi: Remove documentation on user asyncs, and replace references to "system asyncs" to be just "asyncs". --- doc/ref/api-scheduling.texi | 128 +++++++++----------------- doc/ref/libguile-concepts.texi | 2 +- doc/ref/libguile-foreign-objects.texi | 8 +- doc/ref/posix.texi | 10 +- libguile/async.c | 86 +---------------- libguile/async.h | 3 - libguile/deprecated.c | 63 +++++++++++++ libguile/deprecated.h | 6 ++ module/oop/goops.scm | 6 +- 9 files changed, 130 insertions(+), 182 deletions(-) diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index de076374d..6048776d4 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -25,45 +25,28 @@ @subsection Asyncs @cindex asyncs -@cindex user asyncs -@cindex system asyncs Asyncs are a means of deferring the execution of Scheme code until it is safe to do so. -Guile provides two kinds of asyncs that share the basic concept but are -otherwise quite different: system asyncs and user asyncs. System asyncs -are integrated into the core of Guile and are executed automatically -when the system is in a state to allow the execution of Scheme code. -For example, it is not possible to execute Scheme code in a POSIX signal -handler, but such a signal handler can queue a system async to be -executed in the near future, when it is safe to do so. +Asyncs are integrated into the core of Guile. A running Guile program +will periodically check if there are asyncs to run, invoking them as +needed. For example, it is not possible to execute Scheme code in a +POSIX signal handler, but in Guile a signal handler can enqueue a system +async to be executed in the near future, when it is safe to do so. -System asyncs can also be queued for threads other than the current one. -This way, you can cause threads to asynchronously execute arbitrary -code. - -User asyncs offer a convenient means of queuing procedures for future -execution and triggering this execution. They will not be executed -automatically. - -@menu -* System asyncs:: -* User asyncs:: -@end menu - -@node System asyncs -@subsubsection System asyncs +Asyncs can also be queued for threads other than the current one. This +way, you can cause threads to asynchronously execute arbitrary code. To cause the future asynchronous execution of a procedure in a given thread, use @code{system-async-mark}. -Automatic invocation of system asyncs can be temporarily disabled by -calling @code{call-with-blocked-asyncs}. This function works by -temporarily increasing the @emph{async blocking level} of the current -thread while a given procedure is running. The blocking level starts -out at zero, and whenever a safe point is reached, a blocking level -greater than zero will prevent the execution of queued asyncs. +Automatic invocation of asyncs can be temporarily disabled by calling +@code{call-with-blocked-asyncs}. This function works by temporarily +increasing the @emph{async blocking level} of the current thread while a +given procedure is running. The blocking level starts out at zero, and +whenever a safe point is reached, a blocking level greater than zero +will prevent the execution of queued asyncs. Analogously, the procedure @code{call-with-unblocked-asyncs} will temporarily decrease the blocking level of the current thread. You @@ -74,7 +57,7 @@ In addition to the C versions of @code{call-with-blocked-asyncs} and @code{call-with-unblocked-asyncs}, C code can use @code{scm_dynwind_block_asyncs} and @code{scm_dynwind_unblock_asyncs} inside a @dfn{dynamic context} (@pxref{Dynamic Wind}) to block or -unblock system asyncs temporarily. +unblock asyncs temporarily. @deffn {Scheme Procedure} system-async-mark proc [thread] @deffnx {C Function} scm_system_async_mark (proc) @@ -85,16 +68,18 @@ in @var{thread}. When @var{proc} has already been marked for When @var{thread} is omitted, the thread that called @code{system-async-mark} is used. -This procedure is not safe to be called from signal handlers. Use +As we mentioned above, Scheme signal handlers are already called within +an async and so can run any Scheme code. However, note that the C +function is not safe to be called from C signal handlers. Use @code{scm_sigaction} or @code{scm_sigaction_for_thread} to install signal handlers. @end deffn @deffn {Scheme Procedure} call-with-blocked-asyncs proc @deffnx {C Function} scm_call_with_blocked_asyncs (proc) -Call @var{proc} and block the execution of system asyncs by one level -for the current thread while it is running. Return the value returned -by @var{proc}. For the first two variants, call @var{proc} with no +Call @var{proc} and block the execution of asyncs by one level for the +current thread while it is running. Return the value returned by +@var{proc}. For the first two variants, call @var{proc} with no arguments; for the third, call it with @var{data}. @end deffn @@ -104,10 +89,10 @@ The same but with a C function @var{proc} instead of a Scheme thunk. @deffn {Scheme Procedure} call-with-unblocked-asyncs proc @deffnx {C Function} scm_call_with_unblocked_asyncs (proc) -Call @var{proc} and unblock the execution of system asyncs by one -level for the current thread while it is running. Return the value -returned by @var{proc}. For the first two variants, call @var{proc} -with no arguments; for the third, call it with @var{data}. +Call @var{proc} and unblock the execution of asyncs by one level for the +current thread while it is running. Return the value returned by +@var{proc}. For the first two variants, call @var{proc} with no +arguments; for the third, call it with @var{data}. @end deffn @deftypefn {C Function} {void *} scm_c_call_with_unblocked_asyncs (void *(*proc) (void *data), void *data) @@ -128,32 +113,6 @@ one level. This function must be used inside a pair of calls to Wind}). @end deftypefn -@node User asyncs -@subsubsection User asyncs - -A user async is a pair of a thunk (a parameterless procedure) and a -mark. Setting the mark on a user async will cause the thunk to be -executed when the user async is passed to @code{run-asyncs}. Setting -the mark more than once is satisfied by one execution of the thunk. - -User asyncs are created with @code{async}. They are marked with -@code{async-mark}. - -@deffn {Scheme Procedure} async thunk -@deffnx {C Function} scm_async (thunk) -Create a new user async for the procedure @var{thunk}. -@end deffn - -@deffn {Scheme Procedure} async-mark a -@deffnx {C Function} scm_async_mark (a) -Mark the user async @var{a} for future execution. -@end deffn - -@deffn {Scheme Procedure} run-asyncs list_of_a -@deffnx {C Function} scm_run_asyncs (list_of_a) -Execute all thunks from the marked asyncs of the list @var{list_of_a}. -@end deffn - @node Atomics @subsection Atomics @@ -443,9 +402,9 @@ If @var{mutex} was locked by a thread that exited before unlocking it, the next attempt to lock @var{mutex} will succeed, but @code{abandoned-mutex-error} will be signalled. -When a system async (@pxref{System asyncs}) is activated for a thread -blocked in @code{lock-mutex}, the wait is interrupted and the async is -executed. When the async returns, the wait resumes. +When an async (@pxref{Asyncs}) is activated for a thread blocked in +@code{lock-mutex}, the wait is interrupted and the async is executed. +When the async returns, the wait resumes. @end deffn @deftypefn {C Function} void scm_dynwind_lock_mutex (SCM mutex) @@ -526,12 +485,11 @@ as returned by @code{gettimeofday}. When the waiting is aborted, signalled, @code{#t} is returned. The mutex is re-locked in any case before @code{wait-condition-variable} returns. -When a system async is activated for a thread that is blocked in a -call to @code{wait-condition-variable}, the waiting is interrupted, -the mutex is locked, and the async is executed. When the async -returns, the mutex is unlocked again and the waiting is resumed. When -the thread block while re-acquiring the mutex, execution of asyncs is -blocked. +When an async is activated for a thread that is blocked in a call to +@code{wait-condition-variable}, the waiting is interrupted, the mutex is +locked, and the async is executed. When the async returns, the mutex is +unlocked again and the waiting is resumed. When the thread block while +re-acquiring the mutex, execution of asyncs is blocked. @end deffn @deffn {Scheme Procedure} signal-condition-variable condvar @@ -625,18 +583,18 @@ leaves guile mode while waiting for the condition variable. @deftypefn {C Function} int scm_std_select (int nfds, fd_set *readfds, fd_set *writefds, fd_set *exceptfds, struct timeval *timeout) Like @code{select} but leaves guile mode while waiting. Also, the -delivery of a system async causes this function to be interrupted with -error code @code{EINTR}. +delivery of an async causes this function to be interrupted with error +code @code{EINTR}. @end deftypefn @deftypefn {C Function} {unsigned int} scm_std_sleep ({unsigned int} seconds) Like @code{sleep}, but leaves guile mode while sleeping. Also, the -delivery of a system async causes this function to be interrupted. +delivery of an async causes this function to be interrupted. @end deftypefn @deftypefn {C Function} {unsigned long} scm_std_usleep ({unsigned long} usecs) Like @code{usleep}, but leaves guile mode while sleeping. Also, the -delivery of a system async causes this function to be interrupted. +delivery of an async causes this function to be interrupted. @end deftypefn @@ -649,14 +607,14 @@ These two macros can be used to delimit a critical section. Syntactically, they are both statements and need to be followed immediately by a semicolon. -Executing @code{SCM_CRITICAL_SECTION_START} will lock a recursive -mutex and block the executing of system asyncs. Executing +Executing @code{SCM_CRITICAL_SECTION_START} will lock a recursive mutex +and block the executing of asyncs. Executing @code{SCM_CRITICAL_SECTION_END} will unblock the execution of system -asyncs and unlock the mutex. Thus, the code that executes between -these two macros can only be executed in one thread at any one time -and no system asyncs will run. However, because the mutex is a -recursive one, the code might still be reentered by the same thread. -You must either allow for this or avoid it, both by careful coding. +asyncs and unlock the mutex. Thus, the code that executes between these +two macros can only be executed in one thread at any one time and no +asyncs will run. However, because the mutex is a recursive one, the +code might still be reentered by the same thread. You must either allow +for this or avoid it, both by careful coding. On the other hand, critical sections delimited with these macros can be nested since the mutex is recursive. diff --git a/doc/ref/libguile-concepts.texi b/doc/ref/libguile-concepts.texi index e93d98711..34010eebf 100644 --- a/doc/ref/libguile-concepts.texi +++ b/doc/ref/libguile-concepts.texi @@ -418,7 +418,7 @@ do such a thing on its own. If you do not want to allow the running of asynchronous signal handlers, you can block them temporarily with @code{scm_dynwind_block_asyncs}, for -example. See @xref{System asyncs}. +example. @xref{Asyncs}. Since signal handling in Guile relies on safe points, you need to make sure that your functions do offer enough of them. Normally, calling diff --git a/doc/ref/libguile-foreign-objects.texi b/doc/ref/libguile-foreign-objects.texi index 11941d566..29e1f8619 100644 --- a/doc/ref/libguile-foreign-objects.texi +++ b/doc/ref/libguile-foreign-objects.texi @@ -279,10 +279,10 @@ Note that the finalizer may be invoked in ways and at times you might not expect. In particular, if the user's Guile is built with support for threads, the finalizer may be called from any thread that is running Guile. In Guile 2.0, finalizers are invoked via ``asyncs'', which -interleaves them with running Scheme code; @pxref{System asyncs}. In -Guile 2.2 there will be a dedicated finalization thread, to ensure that -the finalization doesn't run within the critical section of any other -thread known to Guile. +interleaves them with running Scheme code; @pxref{Asyncs}. In Guile 2.2 +there will be a dedicated finalization thread, to ensure that the +finalization doesn't run within the critical section of any other thread +known to Guile. In either case, finalizers run concurrently with the main program, and so they need to be async-safe and thread-safe. If for some reason this diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index a78617dc2..1c2c1f365 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -2007,11 +2007,11 @@ information. The following procedures raise, handle and wait for signals. -Scheme code signal handlers are run via a system async (@pxref{System -asyncs}), so they're called in the handler's thread at the next safe -opportunity. Generally this is after any currently executing -primitive procedure finishes (which could be a long time for -primitives that wait for an external event). +Scheme code signal handlers are run via an async (@pxref{Asyncs}), so +they're called in the handler's thread at the next safe opportunity. +Generally this is after any currently executing primitive procedure +finishes (which could be a long time for primitives that wait for an +external event). @deffn {Scheme Procedure} kill pid sig @deffnx {C Function} scm_kill (pid, sig) diff --git a/libguile/async.c b/libguile/async.c index 1e5bc302d..1cf105881 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -44,91 +44,17 @@ /* {Asynchronous Events} * - * There are two kinds of asyncs: system asyncs and user asyncs. The - * two kinds have some concepts in commen but work slightly - * differently and are not interchangeable. - * - * System asyncs are used to run arbitrary code at the next safe point - * in a specified thread. You can use them to trigger execution of - * Scheme code from signal handlers or to interrupt a thread, for - * example. + * Asyncs are used to run arbitrary code at the next safe point in a + * specified thread. You can use them to trigger execution of Scheme + * code from signal handlers or to interrupt a thread, for example. * * Each thread has a list of 'activated asyncs', which is a normal * Scheme list of procedures with zero arguments. When a thread - * executes a SCM_ASYNC_TICK statement (which is included in - * SCM_TICK), it will call all procedures on this list. - * - * Also, a thread will wake up when a procedure is added to its list - * of active asyncs and call them. After that, it will go to sleep - * again. (Not implemented yet.) - * - * - * User asyncs are a little data structure that consists of a - * procedure of zero arguments and a mark. There are functions for - * setting the mark of a user async and for calling all procedures of - * marked asyncs in a given list. Nothing you couldn't quickly - * implement yourself. + * executes a SCM_ASYNC_TICK statement (which is included in SCM_TICK), + * it will call all procedures on this list. */ - - -/* User asyncs. */ - -static scm_t_bits tc16_async; - -/* cmm: this has SCM_ prefix because SCM_MAKE_VALIDATE expects it. - this is ugly. */ -#define SCM_ASYNCP(X) SCM_TYP16_PREDICATE (tc16_async, X) -#define VALIDATE_ASYNC(pos, a) SCM_MAKE_VALIDATE_MSG(pos, a, ASYNCP, "user async") - -#define ASYNC_GOT_IT(X) (SCM_SMOB_FLAGS (X)) -#define SET_ASYNC_GOT_IT(X, V) (SCM_SET_SMOB_FLAGS ((X), ((V)))) -#define ASYNC_THUNK(X) SCM_SMOB_OBJECT_1 (X) - - -SCM_DEFINE (scm_async, "async", 1, 0, 0, - (SCM thunk), - "Create a new async for the procedure @var{thunk}.") -#define FUNC_NAME s_scm_async -{ - SCM_RETURN_NEWSMOB (tc16_async, SCM_UNPACK (thunk)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_async_mark, "async-mark", 1, 0, 0, - (SCM a), - "Mark the async @var{a} for future execution.") -#define FUNC_NAME s_scm_async_mark -{ - VALIDATE_ASYNC (1, a); - SET_ASYNC_GOT_IT (a, 1); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0, - (SCM list_of_a), - "Execute all thunks from the asyncs of the list @var{list_of_a}.") -#define FUNC_NAME s_scm_run_asyncs -{ - while (! SCM_NULL_OR_NIL_P (list_of_a)) - { - SCM a; - SCM_VALIDATE_CONS (1, list_of_a); - a = SCM_CAR (list_of_a); - VALIDATE_ASYNC (SCM_ARG1, a); - if (ASYNC_GOT_IT (a)) - { - SET_ASYNC_GOT_IT (a, 0); - scm_call_0 (ASYNC_THUNK (a)); - } - list_of_a = SCM_CDR (list_of_a); - } - return SCM_BOOL_T; -} -#undef FUNC_NAME - static scm_i_pthread_mutex_t async_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; @@ -448,8 +374,6 @@ scm_critical_section_end (void) void scm_init_async () { - tc16_async = scm_make_smob_type ("async", 0); - #include "libguile/async.x" } diff --git a/libguile/async.h b/libguile/async.h index 00b791449..1e9760a58 100644 --- a/libguile/async.h +++ b/libguile/async.h @@ -32,8 +32,6 @@ SCM_API void scm_async_tick (void); SCM_API void scm_switch (void); -SCM_API SCM scm_async (SCM thunk); -SCM_API SCM scm_async_mark (SCM a); SCM_API SCM scm_system_async_mark (SCM a); SCM_API SCM scm_system_async_mark_for_thread (SCM a, SCM thread); SCM_INTERNAL void scm_i_queue_async_cell (SCM cell, scm_i_thread *); @@ -41,7 +39,6 @@ SCM_INTERNAL int scm_i_setup_sleep (scm_i_thread *, SCM obj, scm_i_pthread_mutex_t *m, int fd); SCM_INTERNAL void scm_i_reset_sleep (scm_i_thread *); -SCM_API SCM scm_run_asyncs (SCM list_of_a); SCM_API SCM scm_noop (SCM args); SCM_API SCM scm_call_with_blocked_asyncs (SCM proc); SCM_API SCM scm_call_with_unblocked_asyncs (SCM proc); diff --git a/libguile/deprecated.c b/libguile/deprecated.c index bae4ed449..228c5d83b 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -578,6 +578,68 @@ SCM_DEFINE (scm_release_arbiter, "release-arbiter", 1, 0, 0, #undef FUNC_NAME + + +/* User asyncs. */ + +static scm_t_bits tc16_async; + +/* cmm: this has SCM_ prefix because SCM_MAKE_VALIDATE expects it. + this is ugly. */ +#define SCM_ASYNCP(X) SCM_TYP16_PREDICATE (tc16_async, X) +#define VALIDATE_ASYNC(pos, a) SCM_MAKE_VALIDATE_MSG(pos, a, ASYNCP, "user async") + +#define ASYNC_GOT_IT(X) (SCM_SMOB_FLAGS (X)) +#define SET_ASYNC_GOT_IT(X, V) (SCM_SET_SMOB_FLAGS ((X), ((V)))) +#define ASYNC_THUNK(X) SCM_SMOB_OBJECT_1 (X) + + +SCM_DEFINE (scm_async, "async", 1, 0, 0, + (SCM thunk), + "Create a new async for the procedure @var{thunk}.") +#define FUNC_NAME s_scm_async +{ + scm_c_issue_deprecation_warning + ("\"User asyncs\" are deprecated. Use closures instead."); + + SCM_RETURN_NEWSMOB (tc16_async, SCM_UNPACK (thunk)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_async_mark, "async-mark", 1, 0, 0, + (SCM a), + "Mark the async @var{a} for future execution.") +#define FUNC_NAME s_scm_async_mark +{ + VALIDATE_ASYNC (1, a); + SET_ASYNC_GOT_IT (a, 1); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0, + (SCM list_of_a), + "Execute all thunks from the asyncs of the list @var{list_of_a}.") +#define FUNC_NAME s_scm_run_asyncs +{ + while (! SCM_NULL_OR_NIL_P (list_of_a)) + { + SCM a; + SCM_VALIDATE_CONS (1, list_of_a); + a = SCM_CAR (list_of_a); + VALIDATE_ASYNC (SCM_ARG1, a); + if (ASYNC_GOT_IT (a)) + { + SET_ASYNC_GOT_IT (a, 0); + scm_call_0 (ASYNC_THUNK (a)); + } + list_of_a = SCM_CDR (list_of_a); + } + return SCM_BOOL_T; +} +#undef FUNC_NAME + + void @@ -585,6 +647,7 @@ scm_i_init_deprecated () { scm_tc16_arbiter = scm_make_smob_type ("arbiter", 0); scm_set_smob_print (scm_tc16_arbiter, arbiter_print); + tc16_async = scm_make_smob_type ("async", 0); #include "libguile/deprecated.x" } diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 5e8e8f819..7eb7ee479 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -223,6 +223,12 @@ SCM_DEPRECATED SCM scm_release_arbiter (SCM arb); +SCM_DEPRECATED SCM scm_async (SCM thunk); +SCM_DEPRECATED SCM scm_async_mark (SCM a); +SCM_DEPRECATED SCM scm_run_asyncs (SCM list_of_a); + + + void scm_i_init_deprecated (void); #endif diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 1d56cc7e1..e4f51600e 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -75,7 +75,7 @@ ;; once you have an instance. Perhaps FIXME to provide a ;; smob-type-name->class procedure. - + @@ -3097,7 +3097,8 @@ var{initargs}." ;;; (begin-deprecated - (define-public (find-subclass '))) + (define-public (find-subclass ')) + (define-public (find-subclass '))) (define (find-subclass ')) (define (find-subclass ')) @@ -3107,7 +3108,6 @@ var{initargs}." (define (find-subclass ')) (define (find-subclass ')) (define (find-subclass ')) -(define (find-subclass ')) (define (find-subclass ')) (define (find-subclass ')) (define (find-subclass ')) From 728068113df3294624498531cd0cc1c8714c8eff Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 17 Oct 2016 22:03:30 +0200 Subject: [PATCH 530/865] NEWS item for deprecated user asyncs * NEWS: Add news. --- NEWS | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/NEWS b/NEWS index f94e590bc..7402cadf4 100644 --- a/NEWS +++ b/NEWS @@ -19,6 +19,15 @@ Arbiters were an experimental mutual exclusion facility from 20 years ago that didn't survive the test of time. Use mutexes or atomic boxes instead. +** User asyncs deprecated + +Guile had (and still has) "system asyncs", which are asynchronous +interrupts, and also had this thing called "user asyncs", which was a +trivial unused data structure. Now that we have deprecated the old +`async', `async-mark', and `run-asyncs' procedures that comprised the +"user async" facility, we have been able to clarify our documentation to +only refer to "asyncs". + * Bug fixes From 51d322b2d4a0ea90510087427dfa92d8384c9b76 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 18 Oct 2016 21:24:01 +0200 Subject: [PATCH 531/865] Update "Asyncs" section of manual. * doc/ref/api-scheduling.texi (Asyncs): Update. --- doc/ref/api-scheduling.texi | 79 +++++++++++++++++++++---------------- 1 file changed, 44 insertions(+), 35 deletions(-) diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index 6048776d4..1fb9ec774 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -8,7 +8,7 @@ @section Threads, Mutexes, Asyncs and Dynamic Roots @menu -* Asyncs:: Asynchronous procedure invocation. +* Asyncs:: Asynchronous interrupts. * Atomics:: Atomic references. * Threads:: Multiple threads of execution. * Mutexes and Condition Variables:: Synchronization primitives. @@ -22,31 +22,48 @@ @node Asyncs -@subsection Asyncs +@subsection Asynchronous Interrupts @cindex asyncs +@cindex asynchronous interrupts +@cindex interrupts -Asyncs are a means of deferring the execution of Scheme code until it is -safe to do so. +Every Guile thread can be interrupted. Threads running Guile code will +periodically check if there are pending interrupts and run them if +necessary. To interrupt a thread, call @code{system-async-mark} on that +thread. -Asyncs are integrated into the core of Guile. A running Guile program -will periodically check if there are asyncs to run, invoking them as -needed. For example, it is not possible to execute Scheme code in a -POSIX signal handler, but in Guile a signal handler can enqueue a system -async to be executed in the near future, when it is safe to do so. +@deffn {Scheme Procedure} system-async-mark proc [thread] +@deffnx {C Function} scm_system_async_mark (proc) +@deffnx {C Function} scm_system_async_mark_for_thread (proc, thread) +Enqueue @var{proc} (a procedure with zero arguments) for future +execution in @var{thread}. When @var{proc} has already been enqueued +for @var{thread} but has not been executed yet, this call has no effect. +When @var{thread} is omitted, the thread that called +@code{system-async-mark} is used. +@end deffn -Asyncs can also be queued for threads other than the current one. This -way, you can cause threads to asynchronously execute arbitrary code. +Note that @code{scm_system_async_mark_for_thread} is not +``async-signal-safe'' and so cannot be called from a C signal handler. +(Indeed in general, @code{libguile} functions are not safe to call from +C signal handlers.) -To cause the future asynchronous execution of a procedure in a given -thread, use @code{system-async-mark}. +Though an interrupt procedure can have any side effect permitted to +Guile code, asynchronous interrupts are generally used either for +profiling or for prematurely cancelling a computation. The former case +is mostly transparent to the program being run, by design, but the +latter case can introduce bugs. Like finalizers (@pxref{Foreign Object +Memory Management}), asynchronous interrupts introduce concurrency in a +program. An asyncronous interrupt can run in the middle of some +mutex-protected operation, for example, and potentially corrupt the +program's state. -Automatic invocation of asyncs can be temporarily disabled by calling -@code{call-with-blocked-asyncs}. This function works by temporarily -increasing the @emph{async blocking level} of the current thread while a -given procedure is running. The blocking level starts out at zero, and -whenever a safe point is reached, a blocking level greater than zero -will prevent the execution of queued asyncs. +If some bit of Guile code needs to temporarily inhibit interrupts, it +can use @code{call-with-blocked-asyncs}. This function works by +temporarily increasing the @emph{async blocking level} of the current +thread while a given procedure is running. The blocking level starts +out at zero, and whenever a safe point is reached, a blocking level +greater than zero will prevent the execution of queued asyncs. Analogously, the procedure @code{call-with-unblocked-asyncs} will temporarily decrease the blocking level of the current thread. You @@ -59,22 +76,6 @@ In addition to the C versions of @code{call-with-blocked-asyncs} and inside a @dfn{dynamic context} (@pxref{Dynamic Wind}) to block or unblock asyncs temporarily. -@deffn {Scheme Procedure} system-async-mark proc [thread] -@deffnx {C Function} scm_system_async_mark (proc) -@deffnx {C Function} scm_system_async_mark_for_thread (proc, thread) -Mark @var{proc} (a procedure with zero arguments) for future execution -in @var{thread}. When @var{proc} has already been marked for -@var{thread} but has not been executed yet, this call has no effect. -When @var{thread} is omitted, the thread that called -@code{system-async-mark} is used. - -As we mentioned above, Scheme signal handlers are already called within -an async and so can run any Scheme code. However, note that the C -function is not safe to be called from C signal handlers. Use -@code{scm_sigaction} or @code{scm_sigaction_for_thread} to install -signal handlers. -@end deffn - @deffn {Scheme Procedure} call-with-blocked-asyncs proc @deffnx {C Function} scm_call_with_blocked_asyncs (proc) Call @var{proc} and block the execution of asyncs by one level for the @@ -113,6 +114,14 @@ one level. This function must be used inside a pair of calls to Wind}). @end deftypefn +Finally, note that threads can also be interrupted via POSIX signals. +@xref{Signals}. As an implementation detail, signal handlers will +effectively call @code{system-async-mark} in a signal-safe way, +eventually running the signal handler using the same async mechanism. +In this way you can temporarily inhibit signal handlers from running +using the above interfaces. + + @node Atomics @subsection Atomics From efcc30fc34b49cf2a045457dafae11989ccc0b3d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 18 Oct 2016 21:25:42 +0200 Subject: [PATCH 532/865] Small api-scheduling.texi reorder * doc/ref/api-scheduling.texi: Put "Threads" section at beginning of scheduling chapter. --- doc/ref/api-scheduling.texi | 279 ++++++++++++++++++------------------ 1 file changed, 140 insertions(+), 139 deletions(-) diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index 1fb9ec774..a13208a65 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -8,9 +8,9 @@ @section Threads, Mutexes, Asyncs and Dynamic Roots @menu +* Threads:: Multiple threads of execution. * Asyncs:: Asynchronous interrupts. * Atomics:: Atomic references. -* Threads:: Multiple threads of execution. * Mutexes and Condition Variables:: Synchronization primitives. * Blocking:: How to block properly in guile mode. * Critical Sections:: Avoiding concurrency and reentries. @@ -21,6 +21,145 @@ @end menu +@node Threads +@subsection Threads +@cindex threads +@cindex Guile threads +@cindex POSIX threads + +Guile supports POSIX threads, unless it was configured with +@code{--without-threads} or the host lacks POSIX thread support. When +thread support is available, the @code{threads} feature is provided +(@pxref{Feature Manipulation, @code{provided?}}). + +The procedures below manipulate Guile threads, which are wrappers around +the system's POSIX threads. For application-level parallelism, using +higher-level constructs, such as futures, is recommended +(@pxref{Futures}). + +@deffn {Scheme Procedure} all-threads +@deffnx {C Function} scm_all_threads () +Return a list of all threads. +@end deffn + +@deffn {Scheme Procedure} current-thread +@deffnx {C Function} scm_current_thread () +Return the thread that called this function. +@end deffn + +@c begin (texi-doc-string "guile" "call-with-new-thread") +@deffn {Scheme Procedure} call-with-new-thread thunk [handler] +Call @code{thunk} in a new thread and with a new dynamic state, +returning the new thread. The procedure @var{thunk} is called via +@code{with-continuation-barrier}. + +When @var{handler} is specified, then @var{thunk} is called from +within a @code{catch} with tag @code{#t} that has @var{handler} as its +handler. This catch is established inside the continuation barrier. + +Once @var{thunk} or @var{handler} returns, the return value is made +the @emph{exit value} of the thread and the thread is terminated. +@end deffn + +@deftypefn {C Function} SCM scm_spawn_thread (scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data) +Call @var{body} in a new thread, passing it @var{body_data}, returning +the new thread. The function @var{body} is called via +@code{scm_c_with_continuation_barrier}. + +When @var{handler} is non-@code{NULL}, @var{body} is called via +@code{scm_internal_catch} with tag @code{SCM_BOOL_T} that has +@var{handler} and @var{handler_data} as the handler and its data. This +catch is established inside the continuation barrier. + +Once @var{body} or @var{handler} returns, the return value is made the +@emph{exit value} of the thread and the thread is terminated. +@end deftypefn + +@deffn {Scheme Procedure} thread? obj +@deffnx {C Function} scm_thread_p (obj) +Return @code{#t} ff @var{obj} is a thread; otherwise, return +@code{#f}. +@end deffn + +@c begin (texi-doc-string "guile" "join-thread") +@deffn {Scheme Procedure} join-thread thread [timeout [timeoutval]] +@deffnx {C Function} scm_join_thread (thread) +@deffnx {C Function} scm_join_thread_timed (thread, timeout, timeoutval) +Wait for @var{thread} to terminate and return its exit value. Threads +that have not been created with @code{call-with-new-thread} or +@code{scm_spawn_thread} have an exit value of @code{#f}. When +@var{timeout} is given, it specifies a point in time where the waiting +should be aborted. It can be either an integer as returned by +@code{current-time} or a pair as returned by @code{gettimeofday}. +When the waiting is aborted, @var{timeoutval} is returned (if it is +specified; @code{#f} is returned otherwise). +@end deffn + +@deffn {Scheme Procedure} thread-exited? thread +@deffnx {C Function} scm_thread_exited_p (thread) +Return @code{#t} if @var{thread} has exited, or @code{#f} otherwise. +@end deffn + +@c begin (texi-doc-string "guile" "yield") +@deffn {Scheme Procedure} yield +If one or more threads are waiting to execute, calling yield forces an +immediate context switch to one of them. Otherwise, yield has no effect. +@end deffn + +@deffn {Scheme Procedure} cancel-thread thread +@deffnx {C Function} scm_cancel_thread (thread) +Asynchronously notify @var{thread} to exit. Immediately after +receiving this notification, @var{thread} will call its cleanup handler +(if one has been set) and then terminate, aborting any evaluation that +is in progress. + +Because Guile threads are isomorphic with POSIX threads, @var{thread} +will not receive its cancellation signal until it reaches a cancellation +point. See your operating system's POSIX threading documentation for +more information on cancellation points; note that in Guile, unlike +native POSIX threads, a thread can receive a cancellation notification +while attempting to lock a mutex. +@end deffn + +@deffn {Scheme Procedure} set-thread-cleanup! thread proc +@deffnx {C Function} scm_set_thread_cleanup_x (thread, proc) +Set @var{proc} as the cleanup handler for the thread @var{thread}. +@var{proc}, which must be a thunk, will be called when @var{thread} +exits, either normally or by being canceled. Thread cleanup handlers +can be used to perform useful tasks like releasing resources, such as +locked mutexes, when thread exit cannot be predicted. + +The return value of @var{proc} will be set as the @emph{exit value} of +@var{thread}. + +To remove a cleanup handler, pass @code{#f} for @var{proc}. +@end deffn + +@deffn {Scheme Procedure} thread-cleanup thread +@deffnx {C Function} scm_thread_cleanup (thread) +Return the cleanup handler currently installed for the thread +@var{thread}. If no cleanup handler is currently installed, +thread-cleanup returns @code{#f}. +@end deffn + +Higher level thread procedures are available by loading the +@code{(ice-9 threads)} module. These provide standardized +thread creation. + +@deffn macro make-thread proc arg @dots{} +Apply @var{proc} to @var{arg} @dots{} in a new thread formed by +@code{call-with-new-thread} using a default error handler that display +the error to the current error port. The @var{arg} @dots{} +expressions are evaluated in the new thread. +@end deffn + +@deffn macro begin-thread expr1 expr2 @dots{} +Evaluate forms @var{expr1} @var{expr2} @dots{} in a new thread formed by +@code{call-with-new-thread} using a default error handler that display +the error to the current error port. +@end deffn + + @node Asyncs @subsection Asynchronous Interrupts @@ -188,144 +327,6 @@ checking if the return value is @code{eq?} to @var{expected}. @end deffn -@node Threads -@subsection Threads -@cindex threads -@cindex Guile threads -@cindex POSIX threads - -Guile supports POSIX threads, unless it was configured with -@code{--without-threads} or the host lacks POSIX thread support. When -thread support is available, the @code{threads} feature is provided -(@pxref{Feature Manipulation, @code{provided?}}). - -The procedures below manipulate Guile threads, which are wrappers around -the system's POSIX threads. For application-level parallelism, using -higher-level constructs, such as futures, is recommended -(@pxref{Futures}). - -@deffn {Scheme Procedure} all-threads -@deffnx {C Function} scm_all_threads () -Return a list of all threads. -@end deffn - -@deffn {Scheme Procedure} current-thread -@deffnx {C Function} scm_current_thread () -Return the thread that called this function. -@end deffn - -@c begin (texi-doc-string "guile" "call-with-new-thread") -@deffn {Scheme Procedure} call-with-new-thread thunk [handler] -Call @code{thunk} in a new thread and with a new dynamic state, -returning the new thread. The procedure @var{thunk} is called via -@code{with-continuation-barrier}. - -When @var{handler} is specified, then @var{thunk} is called from -within a @code{catch} with tag @code{#t} that has @var{handler} as its -handler. This catch is established inside the continuation barrier. - -Once @var{thunk} or @var{handler} returns, the return value is made -the @emph{exit value} of the thread and the thread is terminated. -@end deffn - -@deftypefn {C Function} SCM scm_spawn_thread (scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data) -Call @var{body} in a new thread, passing it @var{body_data}, returning -the new thread. The function @var{body} is called via -@code{scm_c_with_continuation_barrier}. - -When @var{handler} is non-@code{NULL}, @var{body} is called via -@code{scm_internal_catch} with tag @code{SCM_BOOL_T} that has -@var{handler} and @var{handler_data} as the handler and its data. This -catch is established inside the continuation barrier. - -Once @var{body} or @var{handler} returns, the return value is made the -@emph{exit value} of the thread and the thread is terminated. -@end deftypefn - -@deffn {Scheme Procedure} thread? obj -@deffnx {C Function} scm_thread_p (obj) -Return @code{#t} ff @var{obj} is a thread; otherwise, return -@code{#f}. -@end deffn - -@c begin (texi-doc-string "guile" "join-thread") -@deffn {Scheme Procedure} join-thread thread [timeout [timeoutval]] -@deffnx {C Function} scm_join_thread (thread) -@deffnx {C Function} scm_join_thread_timed (thread, timeout, timeoutval) -Wait for @var{thread} to terminate and return its exit value. Threads -that have not been created with @code{call-with-new-thread} or -@code{scm_spawn_thread} have an exit value of @code{#f}. When -@var{timeout} is given, it specifies a point in time where the waiting -should be aborted. It can be either an integer as returned by -@code{current-time} or a pair as returned by @code{gettimeofday}. -When the waiting is aborted, @var{timeoutval} is returned (if it is -specified; @code{#f} is returned otherwise). -@end deffn - -@deffn {Scheme Procedure} thread-exited? thread -@deffnx {C Function} scm_thread_exited_p (thread) -Return @code{#t} if @var{thread} has exited, or @code{#f} otherwise. -@end deffn - -@c begin (texi-doc-string "guile" "yield") -@deffn {Scheme Procedure} yield -If one or more threads are waiting to execute, calling yield forces an -immediate context switch to one of them. Otherwise, yield has no effect. -@end deffn - -@deffn {Scheme Procedure} cancel-thread thread -@deffnx {C Function} scm_cancel_thread (thread) -Asynchronously notify @var{thread} to exit. Immediately after -receiving this notification, @var{thread} will call its cleanup handler -(if one has been set) and then terminate, aborting any evaluation that -is in progress. - -Because Guile threads are isomorphic with POSIX threads, @var{thread} -will not receive its cancellation signal until it reaches a cancellation -point. See your operating system's POSIX threading documentation for -more information on cancellation points; note that in Guile, unlike -native POSIX threads, a thread can receive a cancellation notification -while attempting to lock a mutex. -@end deffn - -@deffn {Scheme Procedure} set-thread-cleanup! thread proc -@deffnx {C Function} scm_set_thread_cleanup_x (thread, proc) -Set @var{proc} as the cleanup handler for the thread @var{thread}. -@var{proc}, which must be a thunk, will be called when @var{thread} -exits, either normally or by being canceled. Thread cleanup handlers -can be used to perform useful tasks like releasing resources, such as -locked mutexes, when thread exit cannot be predicted. - -The return value of @var{proc} will be set as the @emph{exit value} of -@var{thread}. - -To remove a cleanup handler, pass @code{#f} for @var{proc}. -@end deffn - -@deffn {Scheme Procedure} thread-cleanup thread -@deffnx {C Function} scm_thread_cleanup (thread) -Return the cleanup handler currently installed for the thread -@var{thread}. If no cleanup handler is currently installed, -thread-cleanup returns @code{#f}. -@end deffn - -Higher level thread procedures are available by loading the -@code{(ice-9 threads)} module. These provide standardized -thread creation. - -@deffn macro make-thread proc arg @dots{} -Apply @var{proc} to @var{arg} @dots{} in a new thread formed by -@code{call-with-new-thread} using a default error handler that display -the error to the current error port. The @var{arg} @dots{} -expressions are evaluated in the new thread. -@end deffn - -@deffn macro begin-thread expr1 expr2 @dots{} -Evaluate forms @var{expr1} @var{expr2} @dots{} in a new thread formed by -@code{call-with-new-thread} using a default error handler that display -the error to the current error port. -@end deffn - @node Mutexes and Condition Variables @subsection Mutexes and Condition Variables @cindex mutex From 206dced87f425af7eed628530313067a45bee2c2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 19 Oct 2016 22:28:26 +0200 Subject: [PATCH 533/865] Adapt run-server* to change to `accept'. * module/system/repl/server.scm (run-server*): Adapt to new #f return value of accept on non-blocking ports. (errs-to-retry): Remove variable. --- module/system/repl/server.scm | 34 +++++++++------------------------- 1 file changed, 9 insertions(+), 25 deletions(-) diff --git a/module/system/repl/server.scm b/module/system/repl/server.scm index ff9ee5cbc..b1b8a6b8c 100644 --- a/module/system/repl/server.scm +++ b/module/system/repl/server.scm @@ -78,15 +78,6 @@ (bind sock AF_UNIX path) sock)) -;; List of errno values from 'select' or 'accept' that should lead to a -;; retry in 'run-server'. -(define errs-to-retry - (delete-duplicates - (filter-map (lambda (name) - (and=> (module-variable the-root-module name) - variable-ref)) - '(EINTR EAGAIN EWOULDBLOCK)))) - (define* (run-server #:optional (server-socket (make-tcp-server-socket))) (run-server* server-socket serve-client)) @@ -107,22 +98,15 @@ shutdown-read-pipe)) (define (accept-new-client) - (catch #t - (lambda () - (let ((ready-ports (car (select monitored-ports '() '())))) - ;; If we've been asked to shut down, return #f. - (and (not (memq shutdown-read-pipe ready-ports)) - (accept server-socket)))) - (lambda k-args - (let ((err (system-error-errno k-args))) - (cond - ((memv err errs-to-retry) - (accept-new-client)) - (else - (warn "Error accepting client" k-args) - ;; Retry after a timeout. - (sleep 1) - (accept-new-client))))))) + (let ((ready-ports (car (select monitored-ports '() '())))) + ;; If we've been asked to shut down, return #f. + (and (not (memq shutdown-read-pipe ready-ports)) + ;; If the socket turns out to actually not be ready, this + ;; will return #f. ECONNABORTED etc are still possible of + ;; course. + (or (false-if-exception (accept server-socket) + #:warning "Failed to accept client:") + (accept-new-client))))) ;; Put the socket into non-blocking mode. (fcntl server-socket F_SETFL From 56b490a4dd9b8d775d476154c0d4b96483b49436 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 23 Oct 2016 11:56:13 +0200 Subject: [PATCH 534/865] Deferred module observers via a parameter * module/ice-9/boot-9.scm (module-defer-observers): Instead of being a global flag, change to be a parameter. (module-defer-observers-mutex, module-defer-observers-table): Remove. (module-modified): Adapt. (call-with-deferred-observers): Adapt. Allow nested called. --- module/ice-9/boot-9.scm | 38 ++++++++++++++++++++------------------ 1 file changed, 20 insertions(+), 18 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 99543e7a5..48ea61d77 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2029,31 +2029,33 @@ written into the port is returned." (set-module-observers! module (delq1! id (module-observers module))))) *unspecified*) -(define module-defer-observers #f) -(define module-defer-observers-mutex (make-mutex 'recursive)) -(define module-defer-observers-table (make-hash-table)) +;; Hash table of module -> #t indicating modules that changed while +;; observers were deferred, or #f if observers are not being deferred. +(define module-defer-observers (make-parameter #f)) (define (module-modified m) - (if module-defer-observers - (hash-set! module-defer-observers-table m #t) - (module-call-observers m))) + (cond + ((module-defer-observers) => (lambda (tab) (hashq-set! tab m #t))) + (else (module-call-observers m)))) ;;; This function can be used to delay calls to observers so that they ;;; can be called once only in the face of massive updating of modules. ;;; (define (call-with-deferred-observers thunk) - (dynamic-wind - (lambda () - (lock-mutex module-defer-observers-mutex) - (set! module-defer-observers #t)) - thunk - (lambda () - (set! module-defer-observers #f) - (hash-for-each (lambda (m dummy) - (module-call-observers m)) - module-defer-observers-table) - (hash-clear! module-defer-observers-table) - (unlock-mutex module-defer-observers-mutex)))) + (cond + ((module-defer-observers) (thunk)) + (else + (let ((modules (make-hash-table))) + (dynamic-wind (lambda () #t) + (lambda () + (parameterize ((module-defer-observers modules)) + (thunk))) + (lambda () + (let ((changed (hash-map->list cons modules))) + (hash-clear! modules) + (for-each (lambda (pair) + (module-call-observers (car pair))) + changed)))))))) (define (module-call-observers m) (for-each (lambda (proc) (proc m)) (module-observers m)) From d74e0fed0d79f4ae30aa1acf309f47cfade5c589 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 23 Oct 2016 20:28:48 +0200 Subject: [PATCH 535/865] Move thread bindings to (ice-9 threads) * libguile/init.c (scm_i_init_guile): Don't call scm_init_thread_procs. * libguile/threads.c (scm_init_ice_9_threads): Rename from scm_init_thread_procs, make static. (scm_init_threads): Register scm_init_thread_procs extension. * libguile/threads.h (scm_init_thread_procs): Remove decl. * module/ice-9/boot-9.scm: Load (ice-9 threads), so that related side effects occur early. * module/ice-9/deprecated.scm (define-deprecated): Fix to allow deprecated bindings to appear in operator position. Export deprecated bindings. (define-deprecated/threads, define-deprecated/threads*): Trampoline thread bindings to (ice-9 threads). * module/ice-9/futures.scm: Use ice-9 threads. * module/ice-9/threads.scm: Load scm_init_ice_9_threads extension. Reorder definitions and imports so that the module circularity with (ice-9 futures) continues to work. * module/language/cps/intmap.scm: * module/language/cps/intset.scm: * module/language/tree-il/primitives.scm: Use (ice-9 threads). * module/language/cps/reify-primitives.scm: Reify current-thread in (ice-9 threads) module. * module/srfi/srfi-18.scm: Use ice-9 threads with a module prefix, and adapt all users. Use proper keywords in module definition form. * test-suite/tests/filesys.test (test-suite): * test-suite/tests/fluids.test (test-suite): * test-suite/tests/srfi-18.test: Use ice-9 threads. * NEWS: Add entry. * doc/ref/api-scheduling.texi (Threads): Update. * doc/ref/posix.texi (Processes): Move current-processor-count and total-processor-count docs to Threads. --- NEWS | 9 + doc/ref/api-scheduling.texi | 44 ++++- doc/ref/posix.texi | 25 +-- libguile/init.c | 1 - libguile/threads.c | 16 +- libguile/threads.h | 1 - module/ice-9/boot-9.scm | 8 + module/ice-9/deprecated.scm | 58 +++++- module/ice-9/futures.scm | 1 + module/ice-9/threads.scm | 129 +++++++++----- module/language/cps/intmap.scm | 1 + module/language/cps/intset.scm | 1 + module/language/cps/reify-primitives.scm | 1 + module/language/tree-il/primitives.scm | 1 + module/srfi/srfi-18.scm | 214 +++++++++++------------ test-suite/tests/filesys.test | 1 + test-suite/tests/fluids.test | 5 +- test-suite/tests/srfi-18.test | 14 +- 18 files changed, 328 insertions(+), 202 deletions(-) diff --git a/NEWS b/NEWS index 7402cadf4..0702eb294 100644 --- a/NEWS +++ b/NEWS @@ -12,6 +12,15 @@ Changes in 2.1.5 (changes since the 2.1.4 alpha release): * New interfaces * Performance improvements * Incompatible changes +** Threading facilities moved to (ice-9 threads) + +It used to be that call-with-new-thread and other threading primitives +were available in the default environment. This is no longer the case; +they have been moved to (ice-9 threads) instead. Existing code will not +break, however; we used the deprecation facility to signal a warning +message while also providing these bindings in the root environment for +the duration of the 2.2 series. + * New deprecations ** Arbiters deprecated diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index a13208a65..551b3fb38 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -37,6 +37,12 @@ the system's POSIX threads. For application-level parallelism, using higher-level constructs, such as futures, is recommended (@pxref{Futures}). +To use these facilities, load the @code{(ice-9 threads)} module. + +@example +(use-modules (ice-9 threads)) +@end example + @deffn {Scheme Procedure} all-threads @deffnx {C Function} scm_all_threads () Return a list of all threads. @@ -142,10 +148,6 @@ Return the cleanup handler currently installed for the thread thread-cleanup returns @code{#f}. @end deffn -Higher level thread procedures are available by loading the -@code{(ice-9 threads)} module. These provide standardized -thread creation. - @deffn macro make-thread proc arg @dots{} Apply @var{proc} to @var{arg} @dots{} in a new thread formed by @code{call-with-new-thread} using a default error handler that display @@ -159,6 +161,34 @@ Evaluate forms @var{expr1} @var{expr2} @dots{} in a new thread formed by the error to the current error port. @end deffn +One often wants to limit the number of threads running to be +proportional to the number of available processors. These interfaces +are therefore exported by (ice-9 threads) as well. + +@deffn {Scheme Procedure} total-processor-count +@deffnx {C Function} scm_total_processor_count () +Return the total number of processors of the machine, which +is guaranteed to be at least 1. A ``processor'' here is a +thread execution unit, which can be either: + +@itemize +@item an execution core in a (possibly multi-core) chip, in a + (possibly multi- chip) module, in a single computer, or +@item a thread execution unit inside a core in the case of + @dfn{hyper-threaded} CPUs. +@end itemize + +Which of the two definitions is used, is unspecified. +@end deffn + +@deffn {Scheme Procedure} current-processor-count +@deffnx {C Function} scm_current_processor_count () +Like @code{total-processor-count}, but return the number of +processors available to the current process. See +@code{setaffinity} and @code{getaffinity} for more +information. +@end deffn + @node Asyncs @subsection Asynchronous Interrupts @@ -350,6 +380,12 @@ then an endless wait will occur (in the current implementation). Acquiring requisite mutexes in a fixed order (like always A before B) in all threads is one way to avoid such problems. +To use these facilities, load the @code{(ice-9 threads)} module. + +@example +(use-modules (ice-9 threads)) +@end example + @sp 1 @deffn {Scheme Procedure} make-mutex flag @dots{} @deffnx {C Function} scm_make_mutex () diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 1c2c1f365..bcb16bd1a 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -1976,29 +1976,8 @@ Currently this procedure is only defined on GNU variants GNU C Library Reference Manual}). @end deffn -@deffn {Scheme Procedure} total-processor-count -@deffnx {C Function} scm_total_processor_count () -Return the total number of processors of the machine, which -is guaranteed to be at least 1. A ``processor'' here is a -thread execution unit, which can be either: - -@itemize -@item an execution core in a (possibly multi-core) chip, in a - (possibly multi- chip) module, in a single computer, or -@item a thread execution unit inside a core in the case of - @dfn{hyper-threaded} CPUs. -@end itemize - -Which of the two definitions is used, is unspecified. -@end deffn - -@deffn {Scheme Procedure} current-processor-count -@deffnx {C Function} scm_current_processor_count () -Like @code{total-processor-count}, but return the number of -processors available to the current process. See -@code{setaffinity} and @code{getaffinity} for more -information. -@end deffn +@xref{Threads}, for information on how get the number of processors +available on a system. @node Signals diff --git a/libguile/init.c b/libguile/init.c index 31363c69b..4b95f3612 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -415,7 +415,6 @@ scm_i_init_guile (void *base) scm_init_root (); /* requires continuations */ scm_init_threads (); /* requires smob_prehistory */ scm_init_gsubr (); - scm_init_thread_procs (); /* requires gsubrs */ scm_init_procprop (); scm_init_alist (); scm_init_async (); /* requires smob_prehistory */ diff --git a/libguile/threads.c b/libguile/threads.c index b6099309f..9f11ac7e8 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -2093,6 +2093,12 @@ scm_t_bits scm_tc16_thread; scm_t_bits scm_tc16_mutex; scm_t_bits scm_tc16_condvar; +static void +scm_init_ice_9_threads (void *unused) +{ +#include "libguile/threads.x" +} + void scm_init_threads () { @@ -2111,6 +2117,10 @@ scm_init_threads () threads_initialized_p = 1; dynwind_critical_section_mutex = scm_make_recursive_mutex (); + + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_ice_9_threads", + scm_init_ice_9_threads, NULL); } void @@ -2120,12 +2130,6 @@ scm_init_threads_default_dynamic_state () scm_i_default_dynamic_state = state; } -void -scm_init_thread_procs () -{ -#include "libguile/threads.x" -} - /* IA64-specific things. */ diff --git a/libguile/threads.h b/libguile/threads.h index 6b85baf52..a8bb21a4a 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -141,7 +141,6 @@ SCM_API void *scm_with_guile (void *(*func)(void *), void *data); SCM_INTERNAL void scm_i_reset_fluid (size_t); SCM_INTERNAL void scm_threads_prehistory (void *); SCM_INTERNAL void scm_init_threads (void); -SCM_INTERNAL void scm_init_thread_procs (void); SCM_INTERNAL void scm_init_threads_default_dynamic_state (void); SCM_INTERNAL void scm_i_dynwind_pthread_mutex_lock_block_asyncs (scm_i_pthread_mutex_t *mutex); diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 48ea61d77..7f620979d 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -4067,6 +4067,14 @@ when none is available, reading FILE-NAME with READER." +;;; {Threads} +;;; + +;; Load (ice-9 threads), initializing some internal data structures. +(resolve-interface '(ice-9 threads)) + + + ;;; SRFI-4 in the default environment. FIXME: we should figure out how ;;; to deprecate this. ;;; diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm index 375846ff3..de917df52 100644 --- a/module/ice-9/deprecated.scm +++ b/module/ice-9/deprecated.scm @@ -16,14 +16,17 @@ ;;;; (define-module (ice-9 deprecated) - #:export (_IONBF _IOLBF _IOFBF)) + #:use-module ((ice-9 threads) #:prefix threads:)) (define-syntax-rule (define-deprecated var msg exp) - (define-syntax var - (lambda (x) - (issue-deprecation-warning msg) - (syntax-case x () - (id (identifier? #'id) #'exp))))) + (begin + (define-syntax var + (lambda (x) + (issue-deprecation-warning msg) + (syntax-case x () + ((id arg (... ...)) #'(let ((x id)) (x arg (... ...)))) + (id (identifier? #'id) #'exp)))) + (export var))) (define-deprecated _IONBF "`_IONBF' is deprecated. Use the symbol 'none instead." @@ -34,3 +37,46 @@ (define-deprecated _IOFBF "`_IOFBF' is deprecated. Use the symbol 'block instead." 'block) + +(define-syntax define-deprecated/threads + (lambda (stx) + (define (threads-name id) + (datum->syntax id (symbol-append 'threads: (syntax->datum id)))) + (syntax-case stx () + ((_ name) + (with-syntax ((name* (threads-name #'name)) + (warning (string-append + "Import (ice-9 threads) to have access to `" + (symbol->string (syntax->datum #'name)) "'."))) + #'(define-deprecated name warning name*)))))) + +(define-syntax-rule (define-deprecated/threads* name ...) + (begin (define-deprecated/threads name) ...)) + +(define-deprecated/threads* + call-with-new-thread + yield + cancel-thread + set-thread-cleanup! + thread-cleanup + join-thread + thread? + make-mutex + make-recursive-mutex + lock-mutex + try-mutex + unlock-mutex + mutex? + mutex-owner + mutex-level + mutex-locked? + make-condition-variable + wait-condition-variable + signal-condition-variable + broadcast-condition-variable + condition-variable? + current-thread + all-threads + thread-exited? + total-processor-count + current-processor-count) diff --git a/module/ice-9/futures.scm b/module/ice-9/futures.scm index 90bbe53ff..cc57e5c61 100644 --- a/module/ice-9/futures.scm +++ b/module/ice-9/futures.scm @@ -24,6 +24,7 @@ #:use-module (ice-9 q) #:use-module (ice-9 match) #:use-module (ice-9 control) + #:use-module (ice-9 threads) #:export (future make-future future? touch)) ;;; Author: Ludovic Courtès diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm index 14da11339..49d070b99 100644 --- a/module/ice-9/threads.scm +++ b/module/ice-9/threads.scm @@ -26,22 +26,50 @@ ;;; Commentary: ;; This module is documented in the Guile Reference Manual. -;; Briefly, one procedure is exported: `%thread-handler'; -;; as well as four macros: `make-thread', `begin-thread', -;; `with-mutex' and `monitor'. ;;; Code: (define-module (ice-9 threads) - #:use-module (ice-9 futures) #:use-module (ice-9 match) + ;; These bindings are marked as #:replace because when deprecated code + ;; is enabled, (ice-9 deprecated) also exports these names. + ;; (Referencing one of the deprecated names prints a warning directing + ;; the user to these bindings.) Anyway once we can remove the + ;; deprecated bindings, we should use #:export instead of #:replace + ;; for these. + #:replace (call-with-new-thread + yield + cancel-thread + set-thread-cleanup! + thread-cleanup + join-thread + thread? + make-mutex + make-recursive-mutex + lock-mutex + try-mutex + unlock-mutex + mutex? + mutex-owner + mutex-level + mutex-locked? + make-condition-variable + wait-condition-variable + signal-condition-variable + broadcast-condition-variable + condition-variable? + current-thread + all-threads + thread-exited? + total-processor-count + current-processor-count) #:export (begin-thread - parallel - letpar make-thread with-mutex monitor + parallel + letpar par-map par-for-each n-par-map @@ -49,6 +77,13 @@ n-for-each-par-map %thread-handler)) +;; Note that this extension also defines %make-transcoded-port, which is +;; not exported but is used by (rnrs io ports). + +(eval-when (expand eval load) + (load-extension (string-append "libguile-" (effective-version)) + "scm_init_ice_9_threads")) + ;;; Macros first, so that the procedures expand correctly. @@ -58,21 +93,6 @@ (lambda () e0 e1 ...) %thread-handler)) -(define-syntax parallel - (lambda (x) - (syntax-case x () - ((_ e0 ...) - (with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...))))) - #'(let ((tmp0 (future e0)) - ...) - (values (touch tmp0) ...))))))) - -(define-syntax-rule (letpar ((v e) ...) b0 b1 ...) - (call-with-values - (lambda () (parallel e ...)) - (lambda (v ...) - b0 b1 ...))) - (define-syntax-rule (make-thread proc arg ...) (call-with-new-thread (lambda () (proc arg ...)) @@ -104,6 +124,48 @@ #`(with-mutex (monitor-mutex-with-id '#,id) body body* ...)))))) +(define (thread-handler tag . args) + (let ((n (length args)) + (p (current-error-port))) + (display "In thread:" p) + (newline p) + (if (>= n 3) + (display-error #f + p + (car args) + (cadr args) + (caddr args) + (if (= n 4) + (cadddr args) + '())) + (begin + (display "uncaught throw to " p) + (display tag p) + (display ": " p) + (display args p) + (newline p))) + #f)) + +;;; Set system thread handler +(define %thread-handler thread-handler) + +(use-modules (ice-9 futures)) + +(define-syntax parallel + (lambda (x) + (syntax-case x () + ((_ e0 ...) + (with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...))))) + #'(let ((tmp0 (future e0)) + ...) + (values (touch tmp0) ...))))))) + +(define-syntax-rule (letpar ((v e) ...) b0 b1 ...) + (call-with-values + (lambda () (parallel e ...)) + (lambda (v ...) + b0 b1 ...))) + (define (par-mapper mapper cons) (lambda (proc . lists) (let loop ((lists lists)) @@ -205,29 +267,4 @@ of applying P-PROC on ARGLISTS." (loop)))))) threads))))) -(define (thread-handler tag . args) - (let ((n (length args)) - (p (current-error-port))) - (display "In thread:" p) - (newline p) - (if (>= n 3) - (display-error #f - p - (car args) - (cadr args) - (caddr args) - (if (= n 4) - (cadddr args) - '())) - (begin - (display "uncaught throw to " p) - (display tag p) - (display ": " p) - (display args p) - (newline p))) - #f)) - -;;; Set system thread handler -(define %thread-handler thread-handler) - ;;; threads.scm ends here diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm index c29fa9ef4..3a4f51776 100644 --- a/module/language/cps/intmap.scm +++ b/module/language/cps/intmap.scm @@ -34,6 +34,7 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) #:use-module (ice-9 match) + #:use-module ((ice-9 threads) #:select (current-thread)) #:export (empty-intmap intmap? transient-intmap? diff --git a/module/language/cps/intset.scm b/module/language/cps/intset.scm index cdf1fbe82..09af0eaa3 100644 --- a/module/language/cps/intset.scm +++ b/module/language/cps/intset.scm @@ -29,6 +29,7 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) #:use-module (ice-9 match) + #:use-module ((ice-9 threads) #:select (current-thread)) #:export (empty-intset intset? transient-intset? diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index df4dd248c..60be330b2 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -79,6 +79,7 @@ make-atomic-box atomic-box-ref atomic-box-set! atomic-box-swap! atomic-box-compare-and-swap!) '(ice-9 atomic)) + ((current-thread) '(ice-9 threads)) ((class-of) '(oop goops)) ((u8vector-ref u8vector-set! s8vector-ref s8vector-set! diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 71db1a635..be613c714 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -21,6 +21,7 @@ (define-module (language tree-il primitives) #:use-module (system base pmatch) #:use-module (ice-9 match) + #:use-module (ice-9 threads) #:use-module (rnrs bytevectors) #:use-module (system base syntax) #:use-module (language tree-il) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 832b43606..e2d904770 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -31,66 +31,63 @@ ;;; Code: (define-module (srfi srfi-18) - :use-module (srfi srfi-34) - :export ( + #:use-module ((ice-9 threads) #:prefix threads:) + #:use-module (srfi srfi-34) + #:export (;; Threads + make-thread + thread-name + thread-specific + thread-specific-set! + thread-start! + thread-yield! + thread-sleep! + thread-terminate! + thread-join! -;;; Threads - ;; current-thread <= in the core - ;; thread? <= in the core - make-thread - thread-name - thread-specific - thread-specific-set! - thread-start! - thread-yield! - thread-sleep! - thread-terminate! - thread-join! + ;; Mutexes + make-mutex + mutex-name + mutex-specific + mutex-specific-set! + mutex-state + mutex-lock! + mutex-unlock! -;;; Mutexes - ;; mutex? <= in the core - make-mutex - mutex-name - mutex-specific - mutex-specific-set! - mutex-state - mutex-lock! - mutex-unlock! + ;; Condition variables + make-condition-variable + condition-variable-name + condition-variable-specific + condition-variable-specific-set! + condition-variable-signal! + condition-variable-broadcast! + condition-variable-wait! -;;; Condition variables - ;; condition-variable? <= in the core - make-condition-variable - condition-variable-name - condition-variable-specific - condition-variable-specific-set! - condition-variable-signal! - condition-variable-broadcast! - condition-variable-wait! - -;;; Time - current-time - time? - time->seconds - seconds->time + ;; Time + current-time + time? + time->seconds + seconds->time - current-exception-handler - with-exception-handler - raise - join-timeout-exception? - abandoned-mutex-exception? - terminated-thread-exception? - uncaught-exception? - uncaught-exception-reason - ) - :re-export (current-thread thread? mutex? condition-variable?) - :replace (current-time - make-thread - make-mutex - make-condition-variable - raise)) + current-exception-handler + with-exception-handler + raise + join-timeout-exception? + abandoned-mutex-exception? + terminated-thread-exception? + uncaught-exception? + uncaught-exception-reason) + #:re-export ((threads:condition-variable? . condition-variable?) + (threads:current-thread . current-thread) + (threads:thread? . thread?) + (threads:mutex? . mutex?)) + #:replace (current-time + make-thread + make-mutex + make-condition-variable + raise)) -(if (not (provided? 'threads)) - (error "SRFI-18 requires Guile with threads support")) +(unless (provided? 'threads) + (error "SRFI-18 requires Guile with threads support")) (cond-expand-provide (current-module) '(srfi-18)) @@ -121,7 +118,7 @@ (define (srfi-18-exception-preserver obj) (if (or (terminated-thread-exception? obj) (uncaught-exception? obj)) - (set! (thread->exception (current-thread)) obj))) + (set! (thread->exception (threads:current-thread)) obj))) (define (srfi-18-exception-handler key . args) @@ -135,12 +132,12 @@ (cons* uncaught-exception key args))))) (define (current-handler-stack) - (let ((ct (current-thread))) + (let ((ct (threads:current-thread))) (or (hashq-ref thread-exception-handlers ct) (hashq-set! thread-exception-handlers ct (list initial-handler))))) (define (with-exception-handler handler thunk) - (let ((ct (current-thread)) + (let ((ct (threads:current-thread)) (hl (current-handler-stack))) (check-arg-type procedure? handler "with-exception-handler") (check-arg-type thunk? thunk "with-exception-handler") @@ -176,12 +173,12 @@ (define make-thread (let ((make-cond-wrapper (lambda (thunk lcond lmutex scond smutex) (lambda () - (lock-mutex lmutex) - (signal-condition-variable lcond) - (lock-mutex smutex) - (unlock-mutex lmutex) - (wait-condition-variable scond smutex) - (unlock-mutex smutex) + (threads:lock-mutex lmutex) + (threads:signal-condition-variable lcond) + (threads:lock-mutex smutex) + (threads:unlock-mutex lmutex) + (threads:wait-condition-variable scond smutex) + (threads:unlock-mutex smutex) (with-exception-handler initial-handler thunk))))) (lambda (thunk . name) @@ -192,40 +189,42 @@ (sm (make-mutex 'start-mutex)) (sc (make-condition-variable 'start-condition-variable))) - (lock-mutex lm) - (let ((t (call-with-new-thread (make-cond-wrapper thunk lc lm sc sm) - srfi-18-exception-handler))) + (threads:lock-mutex lm) + (let ((t (threads:call-with-new-thread + (make-cond-wrapper thunk lc lm sc sm) + srfi-18-exception-handler))) (hashq-set! thread-start-conds t (cons sm sc)) (and n (hashq-set! object-names t n)) - (wait-condition-variable lc lm) - (unlock-mutex lm) + (threads:wait-condition-variable lc lm) + (threads:unlock-mutex lm) t))))) (define (thread-name thread) - (hashq-ref object-names (check-arg-type thread? thread "thread-name"))) + (hashq-ref object-names + (check-arg-type threads:thread? thread "thread-name"))) (define (thread-specific thread) (hashq-ref object-specifics - (check-arg-type thread? thread "thread-specific"))) + (check-arg-type threads:thread? thread "thread-specific"))) (define (thread-specific-set! thread obj) (hashq-set! object-specifics - (check-arg-type thread? thread "thread-specific-set!") + (check-arg-type threads:thread? thread "thread-specific-set!") obj) *unspecified*) (define (thread-start! thread) (let ((x (hashq-ref thread-start-conds - (check-arg-type thread? thread "thread-start!")))) + (check-arg-type threads:thread? thread "thread-start!")))) (and x (let ((smutex (car x)) (scond (cdr x))) (hashq-remove! thread-start-conds thread) - (lock-mutex smutex) - (signal-condition-variable scond) - (unlock-mutex smutex))) + (threads:lock-mutex smutex) + (threads:signal-condition-variable scond) + (threads:unlock-mutex smutex))) thread)) -(define (thread-yield!) (yield) *unspecified*) +(define (thread-yield!) (threads:yield) *unspecified*) (define (thread-sleep! timeout) (let* ((ct (time->seconds (current-time))) @@ -259,25 +258,27 @@ (define (thread-terminate! thread) (define (thread-terminate-inner!) - (let ((current-handler (thread-cleanup thread))) + (let ((current-handler (threads:thread-cleanup thread))) (if (thunk? current-handler) - (set-thread-cleanup! thread - (lambda () - (with-exception-handler initial-handler - current-handler) - (srfi-18-exception-preserver - terminated-thread-exception))) - (set-thread-cleanup! thread - (lambda () (srfi-18-exception-preserver - terminated-thread-exception)))) - (cancel-thread thread) + (threads:set-thread-cleanup! + thread + (lambda () + (with-exception-handler initial-handler + current-handler) + (srfi-18-exception-preserver + terminated-thread-exception))) + (threads:set-thread-cleanup! + thread + (lambda () (srfi-18-exception-preserver + terminated-thread-exception)))) + (threads:cancel-thread thread) *unspecified*)) (thread-terminate-inner!)) (define (thread-join! thread . args) (define thread-join-inner! (wrap (lambda () - (let ((v (apply join-thread thread args)) + (let ((v (apply threads:join-thread thread args)) (e (thread->exception thread))) (if (and (= (length args) 1) (not v)) (raise join-timeout-exception)) @@ -291,41 +292,40 @@ (define make-mutex (lambda name (let ((n (and (pair? name) (car name))) - (m ((@ (guile) make-mutex) - 'unchecked-unlock - 'allow-external-unlock - 'recursive))) + (m (threads:make-mutex 'unchecked-unlock + 'allow-external-unlock + 'recursive))) (and n (hashq-set! object-names m n)) m))) (define (mutex-name mutex) - (hashq-ref object-names (check-arg-type mutex? mutex "mutex-name"))) + (hashq-ref object-names (check-arg-type threads:mutex? mutex "mutex-name"))) (define (mutex-specific mutex) (hashq-ref object-specifics - (check-arg-type mutex? mutex "mutex-specific"))) + (check-arg-type threads:mutex? mutex "mutex-specific"))) (define (mutex-specific-set! mutex obj) (hashq-set! object-specifics - (check-arg-type mutex? mutex "mutex-specific-set!") + (check-arg-type threads:mutex? mutex "mutex-specific-set!") obj) *unspecified*) (define (mutex-state mutex) - (let ((owner (mutex-owner mutex))) + (let ((owner (threads:mutex-owner mutex))) (if owner - (if (thread-exited? owner) 'abandoned owner) - (if (> (mutex-level mutex) 0) 'not-owned 'not-abandoned)))) + (if (threads:thread-exited? owner) 'abandoned owner) + (if (> (threads:mutex-level mutex) 0) 'not-owned 'not-abandoned)))) (define (mutex-lock! mutex . args) (define mutex-lock-inner! (wrap (lambda () (catch 'abandoned-mutex-error - (lambda () (apply lock-mutex mutex args)) + (lambda () (apply threads:lock-mutex mutex args)) (lambda (key . args) (raise abandoned-mutex-exception)))))) (call/cc mutex-lock-inner!)) (define (mutex-unlock! mutex . args) - (apply unlock-mutex mutex args)) + (apply threads:unlock-mutex mutex args)) ;; CONDITION VARIABLES ;; These functions are all pass-thrus to the existing Guile implementations. @@ -333,33 +333,33 @@ (define make-condition-variable (lambda name (let ((n (and (pair? name) (car name))) - (m ((@ (guile) make-condition-variable)))) + (m (threads:make-condition-variable))) (and n (hashq-set! object-names m n)) m))) (define (condition-variable-name condition-variable) - (hashq-ref object-names (check-arg-type condition-variable? + (hashq-ref object-names (check-arg-type threads:condition-variable? condition-variable "condition-variable-name"))) (define (condition-variable-specific condition-variable) - (hashq-ref object-specifics (check-arg-type condition-variable? + (hashq-ref object-specifics (check-arg-type threads:condition-variable? condition-variable "condition-variable-specific"))) (define (condition-variable-specific-set! condition-variable obj) (hashq-set! object-specifics - (check-arg-type condition-variable? + (check-arg-type threads:condition-variable? condition-variable "condition-variable-specific-set!") obj) *unspecified*) (define (condition-variable-signal! cond) - (signal-condition-variable cond) + (threads:signal-condition-variable cond) *unspecified*) (define (condition-variable-broadcast! cond) - (broadcast-condition-variable cond) + (threads:broadcast-condition-variable cond) *unspecified*) ;; TIME diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test index 253c32ac5..fceb182be 100644 --- a/test-suite/tests/filesys.test +++ b/test-suite/tests/filesys.test @@ -19,6 +19,7 @@ (define-module (test-suite test-filesys) #:use-module (test-suite lib) #:use-module (test-suite guile-test) + #:use-module (ice-9 threads) #:use-module (ice-9 match) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors)) diff --git a/test-suite/tests/fluids.test b/test-suite/tests/fluids.test index 9ad9e81f8..ce7e62578 100644 --- a/test-suite/tests/fluids.test +++ b/test-suite/tests/fluids.test @@ -18,8 +18,9 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-fluids) - :use-module (test-suite lib) - :use-module (system base compile)) + #:use-module (ice-9 threads) + #:use-module (test-suite lib) + #:use-module (system base compile)) (define exception:syntax-error diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test index ab055132e..5fba80ef7 100644 --- a/test-suite/tests/srfi-18.test +++ b/test-suite/tests/srfi-18.test @@ -18,6 +18,7 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-srfi-18) + #:use-module ((ice-9 threads) #:prefix threads:) #:use-module (test-suite lib)) ;; two expressions so that the srfi-18 import is in effect for expansion @@ -43,9 +44,9 @@ (with-test-prefix "make-thread" (pass-if "make-thread creates new thread" - (let* ((n (length (all-threads))) + (let* ((n (length (threads:all-threads))) (t (make-thread (lambda () 'foo) 'make-thread-1)) - (r (> (length (all-threads)) n))) + (r (> (length (threads:all-threads)) n))) (thread-terminate! t) r))) (with-test-prefix "thread-name" @@ -110,7 +111,7 @@ (pass-if "termination destroys non-started thread" (let ((t (make-thread (lambda () 'nothing) 'thread-terminate-1)) - (num-threads (length (all-threads))) + (num-threads (length (threads:all-threads))) (success #f)) (thread-terminate! t) (with-exception-handler @@ -375,7 +376,8 @@ (mutex-unlock! m1))) (dec-sem! (lambda () (mutex-lock! m1) - (while (eqv? sem 0) (wait-condition-variable c1 m1)) + (while (eqv? sem 0) + (threads:wait-condition-variable c1 m1)) (set! sem (- sem 1)) (mutex-unlock! m1))) (t1 (make-thread (lambda () @@ -449,13 +451,13 @@ h2 (lambda () (mutex-lock! m) (condition-variable-signal! c) - (wait-condition-variable c m) + (threads:wait-condition-variable c m) (and (eq? (current-exception-handler) h2) (mutex-unlock! m))))) 'current-exception-handler-4))) (mutex-lock! m) (thread-start! t) - (wait-condition-variable c m) + (threads:wait-condition-variable c m) (and (eq? (current-exception-handler) h1) (condition-variable-signal! c) (mutex-unlock! m) From 9807d2dced107aecfb85502e9264e63f74214499 Mon Sep 17 00:00:00 2001 From: Julian Graham Date: Tue, 13 Sep 2016 08:39:43 -0400 Subject: [PATCH 536/865] Fix tree-il code generation for ECMAscript `new' expression. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The compiler was producing `((toplevel foo))' instead of `(toplevel foo)'. Changed to use `call' form with target type and spliced constructor arguments. * module/language/ecmascript/compile-tree-il.scm (comp): Replace `@impl' shorthand with `call' + `@implv' for better control over resulting tree-il. * test-suite/tests/ecmascript.test (compiler): Add test for "new Object();" Signed-off-by: Ludovic Courtès --- module/language/ecmascript/compile-tree-il.scm | 8 ++++---- test-suite/tests/ecmascript.test | 8 +++++++- 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/module/language/ecmascript/compile-tree-il.scm b/module/language/ecmascript/compile-tree-il.scm index a9ac3e0cd..d61f7120d 100644 --- a/module/language/ecmascript/compile-tree-il.scm +++ b/module/language/ecmascript/compile-tree-il.scm @@ -1,6 +1,6 @@ ;;; ECMAScript for Guile -;; Copyright (C) 2009, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2009, 2011, 2016 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 @@ -437,9 +437,9 @@ ((^= ,what ,val) (comp `(= ,what (^ ,what ,val)) e)) ((new ,what ,args) - (@impl new - (map (lambda (x) (comp x e)) - (cons what args)))) + `(call ,(@implv new) + ,(comp what e) + ,@(map (lambda (x) (comp x e)) args))) ((delete (pref ,obj ,prop)) (@impl pdel (comp obj e) diff --git a/test-suite/tests/ecmascript.test b/test-suite/tests/ecmascript.test index 96b1d6666..9f2731e9f 100644 --- a/test-suite/tests/ecmascript.test +++ b/test-suite/tests/ecmascript.test @@ -1,6 +1,6 @@ ;;;; ecmascript.test --- ECMAScript. -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 2010, 2011, 2013, 2016 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 @@ -83,6 +83,12 @@ (ecompile "\"hello\";" "hello") (ecompile "var test = { bar: 1 };") + (pass-if "new Object;" + (not (not + (compile (call-with-input-string "new Object;" read-ecmascript) + #:from 'ecmascript + #:to 'tree-il)))) ; Can't reference `Object' as value here + ;; FIXME: Broken! ;; (ecompile "[1,2,3,4].map(function(x) { return x * x; });" ;; '(1 4 9 16)) From f3bfe29235199e12b961c3fd1fa92666ad031d0d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 25 Oct 2016 22:24:19 +0200 Subject: [PATCH 537/865] Move call-with-new-thread to Scheme * libguile/threads.c (scm_call_with_new_thread): Trampoline to Scheme. (launch_data, really_launch, scm_sys_call_with_new_thread): Simplify. (scm_init_ice_9_threads): Capture call-with-new-thread variable. * module/ice-9/threads.scm (call-with-new-thread): Add implementation in Scheme. Should allow for easier cancel-thread via prompt abort. --- libguile/threads.c | 81 ++++++++++++++-------------------------- module/ice-9/threads.scm | 33 ++++++++++++++++ 2 files changed, 62 insertions(+), 52 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index 9f11ac7e8..1dece5694 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -858,34 +858,29 @@ scm_without_guile (void *(*func)(void *), void *data) /*** Thread creation */ +/* Because (ice-9 boot-9) loads up (ice-9 threads), we know that this + variable will get loaded before a call to scm_call_with_new_thread + and therefore no lock or pthread_once_t is needed. */ +static SCM call_with_new_thread_var; + +SCM +scm_call_with_new_thread (SCM thunk, SCM handler) +{ + SCM call_with_new_thread = scm_variable_ref (call_with_new_thread_var); + if (SCM_UNBNDP (handler)) + return scm_call_1 (call_with_new_thread, thunk); + return scm_call_2 (call_with_new_thread, thunk, handler); +} + typedef struct { SCM parent; SCM thunk; - SCM handler; - SCM thread; - scm_i_pthread_mutex_t mutex; - scm_i_pthread_cond_t cond; } launch_data; static void * really_launch (void *d) { - launch_data *data = (launch_data *)d; - SCM thunk = data->thunk, handler = data->handler; - scm_i_thread *t; - - t = SCM_I_CURRENT_THREAD; - - scm_i_scm_pthread_mutex_lock (&data->mutex); - data->thread = scm_current_thread (); - scm_i_pthread_cond_signal (&data->cond); - scm_i_pthread_mutex_unlock (&data->mutex); - - if (SCM_UNBNDP (handler)) - t->result = scm_call_0 (thunk); - else - t->result = scm_catch (SCM_BOOL_T, thunk, handler); - + SCM_I_CURRENT_THREAD->result = scm_call_0 (((launch_data *)d)->thunk); return 0; } @@ -898,51 +893,29 @@ launch_thread (void *d) return NULL; } -SCM_DEFINE (scm_call_with_new_thread, "call-with-new-thread", 1, 1, 0, - (SCM thunk, SCM handler), - "Call @code{thunk} in a new thread and with a new dynamic state,\n" - "returning a new thread object representing the thread. The procedure\n" - "@var{thunk} is called via @code{with-continuation-barrier}.\n" - "\n" - "When @var{handler} is specified, then @var{thunk} is called from\n" - "within a @code{catch} with tag @code{#t} that has @var{handler} as its\n" - "handler. This catch is established inside the continuation barrier.\n" - "\n" - "Once @var{thunk} or @var{handler} returns, the return value is made\n" - "the @emph{exit value} of the thread and the thread is terminated.") -#define FUNC_NAME s_scm_call_with_new_thread +SCM_INTERNAL SCM scm_sys_call_with_new_thread (SCM); +SCM_DEFINE (scm_sys_call_with_new_thread, "%call-with-new-thread", 1, 0, 0, + (SCM thunk), "") +#define FUNC_NAME s_scm_sys_call_with_new_thread { - launch_data data; + launch_data *data; scm_i_pthread_t id; int err; SCM_ASSERT (scm_is_true (scm_thunk_p (thunk)), thunk, SCM_ARG1, FUNC_NAME); - SCM_ASSERT (SCM_UNBNDP (handler) || scm_is_true (scm_procedure_p (handler)), - handler, SCM_ARG2, FUNC_NAME); GC_collect_a_little (); - data.parent = scm_current_dynamic_state (); - data.thunk = thunk; - data.handler = handler; - data.thread = SCM_BOOL_F; - scm_i_pthread_mutex_init (&data.mutex, NULL); - scm_i_pthread_cond_init (&data.cond, NULL); - - scm_i_scm_pthread_mutex_lock (&data.mutex); - err = scm_i_pthread_create (&id, NULL, launch_thread, &data); + data = scm_gc_typed_calloc (launch_data); + data->parent = scm_current_dynamic_state (); + data->thunk = thunk; + err = scm_i_pthread_create (&id, NULL, launch_thread, data); if (err) { - scm_i_pthread_mutex_unlock (&data.mutex); errno = err; scm_syserror (NULL); } - while (scm_is_false (data.thread)) - scm_i_scm_pthread_cond_wait (&data.cond, &data.mutex); - - scm_i_pthread_mutex_unlock (&data.mutex); - - return data.thread; + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -2097,6 +2070,10 @@ static void scm_init_ice_9_threads (void *unused) { #include "libguile/threads.x" + + call_with_new_thread_var = + scm_module_variable (scm_current_module (), + scm_from_latin1_symbol ("call-with-new-thread")); } void diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm index 49d070b99..f0f08e012 100644 --- a/module/ice-9/threads.scm +++ b/module/ice-9/threads.scm @@ -86,6 +86,39 @@ +(define* (call-with-new-thread thunk #:optional handler) + "Call @code{thunk} in a new thread and with a new dynamic state, +returning a new thread object representing the thread. The procedure +@var{thunk} is called via @code{with-continuation-barrier}. + +When @var{handler} is specified, then @var{thunk} is called from within +a @code{catch} with tag @code{#t} that has @var{handler} as its handler. +This catch is established inside the continuation barrier. + +Once @var{thunk} or @var{handler} returns, the return value is made the +@emph{exit value} of the thread and the thread is terminated." + (let ((cv (make-condition-variable)) + (mutex (make-mutex)) + (thunk (if handler + (lambda () (catch #t thunk handler)) + thunk)) + (thread #f)) + (with-mutex mutex + (%call-with-new-thread + (lambda () + (lock-mutex mutex) + (set! thread (current-thread)) + (signal-condition-variable cv) + (unlock-mutex mutex) + (thunk))) + (let lp () + (unless thread + (wait-condition-variable cv mutex) + (lp)))) + thread)) + + + ;;; Macros first, so that the procedures expand correctly. (define-syntax-rule (begin-thread e0 e1 ...) From c957ec7ab0f0a028910dc737e12191f7bdc1ca93 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 26 Oct 2016 22:32:51 +0200 Subject: [PATCH 538/865] Use atomics for async interrupts * libguile/__scm.h (SCM_TICK): Always define as scm_async_tick(). * libguile/error.c (scm_syserror, scm_syserror_msg): * libguile/fports.c (fport_read, fport_write): * libguile/_scm.h (SCM_SYSCALL): Replace SCM_ASYNC_TICK with scm_async_tick (). (SCM_ASYNC_TICK, SCM_ASYNC_TICK_WITH_CODE) (SCM_ASYNC_TICK_WITH_GUARD_CODE): Remove internal definitions. We inline into vm-engine.c, the only place where it matters. * libguile/async.h: * libguile/async.c (scm_async_tick, scm_i_setup_sleep): (scm_i_reset_sleep, scm_system_async_mark_for_thread): * libguile/threads.h (struct scm_thread_wake_data): * libguile/threads.h (scm_i_thread): * libguile/threads.c (block_self, guilify_self_1, scm_std_select): Rewrite to use sequentially-consistent atomic references. * libguile/atomics-internal.h (scm_atomic_set_pointer): (scm_atomic_ref_pointer): New definitions. * libguile/finalizers.c (queue_finalizer_async): We can allocate, so just use scm_system_async_mark_for_thread instead of the set-cdr! shenanigans. * libguile/scmsigs.c (take_signal): * libguile/gc.c (queue_after_gc_hook): Adapt to new asyncs mechanism. Can't allocate but we're just manipulating the current thread when no other threads are running so we should be good. * libguile/vm-engine.c (VM_HANDLE_INTERRUPTS): Inline the async_tick business. --- libguile/__scm.h | 4 - libguile/_scm.h | 24 +---- libguile/async.c | 181 +++++++++++++----------------------- libguile/async.h | 1 - libguile/atomics-internal.h | 27 ++++++ libguile/error.c | 4 +- libguile/finalizers.c | 26 ++---- libguile/fports.c | 4 +- libguile/gc.c | 9 +- libguile/init.c | 2 +- libguile/scmsigs.c | 5 +- libguile/threads.c | 20 ++-- libguile/threads.h | 18 ++-- libguile/vm-engine.c | 19 +++- 14 files changed, 152 insertions(+), 192 deletions(-) diff --git a/libguile/__scm.h b/libguile/__scm.h index 31e395285..1ea4822a6 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -474,11 +474,7 @@ typedef long SCM_STACKITEM; #define SCM_STACK_PTR(ptr) ((SCM_STACKITEM *) (void *) (ptr)) -#ifdef BUILDING_LIBGUILE -#define SCM_TICK SCM_ASYNC_TICK -#else #define SCM_TICK scm_async_tick () -#endif diff --git a/libguile/_scm.h b/libguile/_scm.h index 60ad08295..e482b7e31 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -100,7 +100,7 @@ errno = 0; \ line; \ if (EVMSERR == errno && (vaxc$errno>>3)==(SS$_CONTROLC>>3)) \ - SCM_ASYNC_TICK; \ + scm_async_tick (); \ else \ break; \ } \ @@ -119,7 +119,7 @@ line; \ if (errno == EINTR) \ { \ - SCM_ASYNC_TICK; \ + scm_async_tick (); \ errno = EINTR; \ } \ } \ @@ -223,26 +223,6 @@ void scm_ia64_longjmp (scm_i_jmp_buf *, int); #define SCM_I_LONGJMP longjmp #endif - - -#define SCM_ASYNC_TICK_WITH_GUARD_CODE(thr, pre, post) \ - do \ - { \ - if (SCM_UNLIKELY (thr->pending_asyncs)) \ - { \ - pre; \ - scm_async_tick (); \ - post; \ - } \ - } \ - while (0) - -#define SCM_ASYNC_TICK_WITH_CODE(thr, stmt) \ - SCM_ASYNC_TICK_WITH_GUARD_CODE (thr, stmt, (void) 0) -#define SCM_ASYNC_TICK \ - SCM_ASYNC_TICK_WITH_CODE (SCM_I_CURRENT_THREAD, (void) 0) - - #if (defined __GNUC__) diff --git a/libguile/async.c b/libguile/async.c index 1cf105881..aa4f508b7 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -24,6 +24,7 @@ #endif #include "libguile/_scm.h" +#include "libguile/atomics-internal.h" #include "libguile/eval.h" #include "libguile/throw.h" #include "libguile/root.h" @@ -50,142 +51,51 @@ * * Each thread has a list of 'activated asyncs', which is a normal * Scheme list of procedures with zero arguments. When a thread - * executes a SCM_ASYNC_TICK statement (which is included in SCM_TICK), - * it will call all procedures on this list. + * executes an scm_async_tick (), it will call all procedures on this + * list. */ - - -static scm_i_pthread_mutex_t async_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; - -/* System asyncs. */ - void scm_async_tick (void) { scm_i_thread *t = SCM_I_CURRENT_THREAD; SCM asyncs; - /* Reset pending_asyncs even when asyncs are blocked and not really - executed since this will avoid future futile calls to this - function. When asyncs are unblocked again, this function is - invoked even when pending_asyncs is zero. - */ + if (t->block_asyncs) + return; - scm_i_scm_pthread_mutex_lock (&async_mutex); - t->pending_asyncs = 0; - if (t->block_asyncs == 0) + asyncs = scm_atomic_swap_scm (&t->pending_asyncs, SCM_EOL); + while (!scm_is_null (asyncs)) { - asyncs = t->active_asyncs; - t->active_asyncs = SCM_EOL; - } - else - asyncs = SCM_EOL; - scm_i_pthread_mutex_unlock (&async_mutex); - - while (scm_is_pair (asyncs)) - { - SCM next = SCM_CDR (asyncs); - SCM_SETCDR (asyncs, SCM_BOOL_F); - scm_call_0 (SCM_CAR (asyncs)); + SCM next = scm_cdr (asyncs); + scm_call_0 (scm_car (asyncs)); + scm_set_cdr_x (asyncs, SCM_BOOL_F); asyncs = next; } } -void -scm_i_queue_async_cell (SCM c, scm_i_thread *t) -{ - SCM sleep_object; - scm_i_pthread_mutex_t *sleep_mutex; - int sleep_fd; - SCM p; - - scm_i_scm_pthread_mutex_lock (&async_mutex); - p = t->active_asyncs; - SCM_SETCDR (c, SCM_EOL); - if (!scm_is_pair (p)) - t->active_asyncs = c; - else - { - SCM pp; - while (scm_is_pair (pp = SCM_CDR (p))) - { - if (scm_is_eq (SCM_CAR (p), SCM_CAR (c))) - { - scm_i_pthread_mutex_unlock (&async_mutex); - return; - } - p = pp; - } - SCM_SETCDR (p, c); - } - t->pending_asyncs = 1; - sleep_object = t->sleep_object; - sleep_mutex = t->sleep_mutex; - sleep_fd = t->sleep_fd; - scm_i_pthread_mutex_unlock (&async_mutex); - - if (sleep_mutex) - { - /* By now, the thread T might be out of its sleep already, or - might even be in the next, unrelated sleep. Interrupting it - anyway does no harm, however. - - The important thing to prevent here is to signal sleep_cond - before T waits on it. This can not happen since T has - sleep_mutex locked while setting t->sleep_mutex and will only - unlock it again while waiting on sleep_cond. - */ - scm_i_scm_pthread_mutex_lock (sleep_mutex); - scm_i_pthread_cond_signal (&t->sleep_cond); - scm_i_pthread_mutex_unlock (sleep_mutex); - } - - if (sleep_fd >= 0) - { - char dummy = 0; - - /* Likewise, T might already been done with sleeping here, but - interrupting it once too often does no harm. T might also - not yet have started sleeping, but this is no problem either - since the data written to a pipe will not be lost, unlike a - condition variable signal. */ - full_write (sleep_fd, &dummy, 1); - } - - /* This is needed to protect sleep_mutex. - */ - scm_remember_upto_here_1 (sleep_object); -} - int scm_i_setup_sleep (scm_i_thread *t, SCM sleep_object, scm_i_pthread_mutex_t *sleep_mutex, int sleep_fd) { - int pending; + struct scm_thread_wake_data *wake; - scm_i_scm_pthread_mutex_lock (&async_mutex); - pending = t->pending_asyncs; - if (!pending) - { - t->sleep_object = sleep_object; - t->sleep_mutex = sleep_mutex; - t->sleep_fd = sleep_fd; - } - scm_i_pthread_mutex_unlock (&async_mutex); - return pending; + wake = scm_gc_typed_calloc (struct scm_thread_wake_data); + wake->object = sleep_object; + wake->mutex = sleep_mutex; + wake->fd = sleep_fd; + + scm_atomic_set_pointer ((void **)&t->wake, wake); + + return !scm_is_null (scm_atomic_ref_scm (&t->pending_asyncs)); } void scm_i_reset_sleep (scm_i_thread *t) { - scm_i_scm_pthread_mutex_lock (&async_mutex); - t->sleep_object = SCM_BOOL_F; - t->sleep_mutex = NULL; - t->sleep_fd = -1; - scm_i_pthread_mutex_unlock (&async_mutex); + scm_atomic_set_pointer ((void **)&t->wake, NULL); } SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0, @@ -200,13 +110,9 @@ SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0, "signal handlers.") #define FUNC_NAME s_scm_system_async_mark_for_thread { - /* The current thread might not have a handle yet. This can happen - when the GC runs immediately before allocating the handle. At - the end of that GC, a system async might be marked. Thus, we can - not use scm_current_thread here. - */ - scm_i_thread *t; + SCM asyncs; + struct scm_thread_wake_data *wake; if (SCM_UNBNDP (thread)) t = SCM_I_CURRENT_THREAD; @@ -217,7 +123,48 @@ SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0, SCM_MISC_ERROR ("thread has already exited", SCM_EOL); t = SCM_I_THREAD_DATA (thread); } - scm_i_queue_async_cell (scm_cons (proc, SCM_BOOL_F), t); + + asyncs = scm_atomic_ref_scm (&t->pending_asyncs); + do + if (scm_is_true (scm_c_memq (proc, asyncs))) + return SCM_UNSPECIFIED; + while (!scm_atomic_compare_and_swap_scm (&t->pending_asyncs, &asyncs, + scm_cons (proc, asyncs))); + + /* At this point the async is enqueued. However if the thread is + sleeping, we have to wake it up. */ + if ((wake = scm_atomic_ref_pointer ((void **) &t->wake))) + { + /* By now, the thread T might be out of its sleep already, or + might even be in the next, unrelated sleep. Interrupting it + anyway does no harm, however. + + The important thing to prevent here is to signal sleep_cond + before T waits on it. This can not happen since T has + sleep_mutex locked while setting t->sleep_mutex and will only + unlock it again while waiting on sleep_cond. + */ + scm_i_scm_pthread_mutex_lock (wake->mutex); + scm_i_pthread_cond_signal (&t->sleep_cond); + scm_i_pthread_mutex_unlock (wake->mutex); + + /* This is needed to protect wake->mutex. + */ + scm_remember_upto_here_1 (wake->object); + + if (wake->fd >= 0) + { + char dummy = 0; + + /* Likewise, T might already been done with sleeping here, but + interrupting it once too often does no harm. T might also + not yet have started sleeping, but this is no problem + either since the data written to a pipe will not be lost, + unlike a condition variable signal. */ + full_write (wake->fd, &dummy, 1); + } + } + return SCM_UNSPECIFIED; } #undef FUNC_NAME diff --git a/libguile/async.h b/libguile/async.h index 1e9760a58..e8b6ee9c2 100644 --- a/libguile/async.h +++ b/libguile/async.h @@ -34,7 +34,6 @@ SCM_API void scm_async_tick (void); SCM_API void scm_switch (void); SCM_API SCM scm_system_async_mark (SCM a); SCM_API SCM scm_system_async_mark_for_thread (SCM a, SCM thread); -SCM_INTERNAL void scm_i_queue_async_cell (SCM cell, scm_i_thread *); SCM_INTERNAL int scm_i_setup_sleep (scm_i_thread *, SCM obj, scm_i_pthread_mutex_t *m, int fd); diff --git a/libguile/atomics-internal.h b/libguile/atomics-internal.h index 9d18cbc1a..9074d8cc3 100644 --- a/libguile/atomics-internal.h +++ b/libguile/atomics-internal.h @@ -45,6 +45,16 @@ scm_atomic_compare_and_swap_uint32 (uint32_t *loc, uint32_t *expected, return atomic_compare_exchange_weak (loc, expected, desired); } static inline void +scm_atomic_set_pointer (void **loc, void *val) +{ + atomic_store (loc, val); +} +static inline void * +scm_atomic_ref_pointer (void **loc) +{ + return atomic_load (loc); +} +static inline void scm_atomic_set_scm (SCM *loc, SCM val) { atomic_store (loc, val); @@ -99,6 +109,23 @@ scm_atomic_compare_and_swap_uint32 (uint32_t *loc, uint32_t *expected, return ret; } +static inline void +scm_atomic_set_pointer (void **loc, void *val) +{ + scm_i_pthread_mutex_lock (&atomics_lock); + *loc = val; + scm_i_pthread_mutex_unlock (&atomics_lock); +} +static inline void * +scm_atomic_ref_pointer (void **loc) +{ + void *ret; + scm_i_pthread_mutex_lock (&atomics_lock); + ret = *loc; + scm_i_pthread_mutex_unlock (&atomics_lock); + return ret; +} + static inline void scm_atomic_set_scm (SCM *loc, SCM val) { diff --git a/libguile/error.c b/libguile/error.c index 89345c2b7..ff84f41d8 100644 --- a/libguile/error.c +++ b/libguile/error.c @@ -163,7 +163,7 @@ scm_syserror (const char *subr) */ #ifdef EINTR if (scm_to_int (err) == EINTR) - SCM_ASYNC_TICK; + scm_async_tick (); #endif scm_error (scm_system_error_key, @@ -179,7 +179,7 @@ scm_syserror_msg (const char *subr, const char *message, SCM args, int eno) /* See above note about the EINTR signal handling race. */ #ifdef EINTR if (eno == EINTR) - SCM_ASYNC_TICK; + scm_async_tick (); #endif scm_error (scm_system_error_key, subr, diff --git a/libguile/finalizers.c b/libguile/finalizers.c index 82f292cd2..9b9075830 100644 --- a/libguile/finalizers.c +++ b/libguile/finalizers.c @@ -40,6 +40,8 @@ static int automatic_finalization_p = 1; static size_t finalization_count; +static SCM run_finalizers_subr; + @@ -132,8 +134,6 @@ scm_i_add_finalizer (void *obj, scm_t_finalizer_proc proc, void *data) -static SCM finalizer_async_cell; - static SCM run_finalizers_async_thunk (void) { @@ -150,19 +150,13 @@ static void queue_finalizer_async (void) { scm_i_thread *t = SCM_I_CURRENT_THREAD; - static scm_i_pthread_mutex_t lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; - scm_i_pthread_mutex_lock (&lock); - /* If t is NULL, that could be because we're allocating in - threads.c:guilify_self_1. In that case, rely on the + /* Could be that the current thread is is NULL when we're allocating + in threads.c:guilify_self_1. In that case, rely on the GC_invoke_finalizers call there after the thread spins up. */ - if (t && scm_is_false (SCM_CDR (finalizer_async_cell))) - { - SCM_SETCDR (finalizer_async_cell, t->active_asyncs); - t->active_asyncs = finalizer_async_cell; - t->pending_asyncs = 1; - } - scm_i_pthread_mutex_unlock (&lock); + if (!t) return; + + scm_system_async_mark_for_thread (run_finalizers_subr, t->handle); } @@ -418,10 +412,8 @@ scm_init_finalizers (void) { /* When the async is to run, the cdr of the pair gets set to the asyncs queue of the current thread. */ - finalizer_async_cell = - scm_cons (scm_c_make_gsubr ("%run-finalizers", 0, 0, 0, - run_finalizers_async_thunk), - SCM_BOOL_F); + run_finalizers_subr = scm_c_make_gsubr ("%run-finalizers", 0, 0, 0, + run_finalizers_async_thunk); if (automatic_finalization_p) GC_set_finalizer_notifier (queue_finalizer_async); diff --git a/libguile/fports.c b/libguile/fports.c index 5886f628d..8fa69933d 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -595,7 +595,7 @@ fport_read (SCM port, SCM dst, size_t start, size_t count) { if (errno == EINTR) { - SCM_ASYNC_TICK; + scm_async_tick (); goto retry; } if (errno == EWOULDBLOCK || errno == EAGAIN) @@ -618,7 +618,7 @@ fport_write (SCM port, SCM src, size_t start, size_t count) { if (errno == EINTR) { - SCM_ASYNC_TICK; + scm_async_tick (); goto retry; } if (errno == EWOULDBLOCK || errno == EAGAIN) diff --git a/libguile/gc.c b/libguile/gc.c index b75a688aa..1e9f59683 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -685,8 +685,8 @@ after_gc_async_thunk (void) */ static void * queue_after_gc_hook (void * hook_data SCM_UNUSED, - void *fn_data SCM_UNUSED, - void *data SCM_UNUSED) + void *fn_data SCM_UNUSED, + void *data SCM_UNUSED) { /* If cell access debugging is enabled, the user may choose to perform * additional garbage collections after an arbitrary number of cell @@ -721,9 +721,8 @@ queue_after_gc_hook (void * hook_data SCM_UNUSED, if (scm_is_false (SCM_CDR (after_gc_async_cell))) { - SCM_SETCDR (after_gc_async_cell, t->active_asyncs); - t->active_asyncs = after_gc_async_cell; - t->pending_asyncs = 1; + SCM_SETCDR (after_gc_async_cell, t->pending_asyncs); + t->pending_asyncs = after_gc_async_cell; } } diff --git a/libguile/init.c b/libguile/init.c index 4b95f3612..8b0813a1b 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -344,7 +344,7 @@ invoke_main_func (void *body_data) * asyncs a chance to run. This must be done after * the call to scm_restore_signals. */ - SCM_ASYNC_TICK; + scm_async_tick (); /* Indicate success by returning non-NULL. */ diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 441da3ec7..b030b0413 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -228,9 +228,8 @@ take_signal (int signum) if (scm_is_false (SCM_CDR (cell))) { - SCM_SETCDR (cell, t->active_asyncs); - t->active_asyncs = cell; - t->pending_asyncs = 1; + SCM_SETCDR (cell, t->pending_asyncs); + t->pending_asyncs = cell; } #ifndef HAVE_SIGACTION diff --git a/libguile/threads.c b/libguile/threads.c index 1dece5694..2a315e472 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -275,7 +275,7 @@ thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) /*** Blocking on queues. */ -/* See also scm_i_queue_async_cell for how such a block is +/* See also scm_system_async_mark_for_thread for how such a block is interrputed. */ @@ -309,7 +309,10 @@ block_self (SCM queue, SCM sleep_object, scm_i_pthread_mutex_t *mutex, int err; if (scm_i_setup_sleep (t, sleep_object, mutex, -1)) - err = EINTR; + { + scm_i_reset_sleep (t); + err = EINTR; + } else { t->block_asyncs++; @@ -415,9 +418,8 @@ guilify_self_1 (struct GC_stack_base *base) t.dynstack.base = NULL; t.dynstack.top = NULL; t.dynstack.limit = NULL; - t.active_asyncs = SCM_EOL; + t.pending_asyncs = SCM_EOL; t.block_asyncs = 1; - t.pending_asyncs = 1; t.critical_section_level = 0; t.base = base->mem_base; #ifdef __ia64__ @@ -426,9 +428,7 @@ guilify_self_1 (struct GC_stack_base *base) t.continuation_root = SCM_EOL; t.continuation_base = t.base; scm_i_pthread_cond_init (&t.sleep_cond, NULL); - t.sleep_mutex = NULL; - t.sleep_object = SCM_BOOL_F; - t.sleep_fd = -1; + t.wake = NULL; t.vp = NULL; if (pipe2 (t.sleep_pipe, O_CLOEXEC) != 0) @@ -1776,7 +1776,10 @@ scm_std_select (int nfds, } while (scm_i_setup_sleep (t, SCM_BOOL_F, NULL, t->sleep_pipe[1])) - SCM_TICK; + { + scm_i_reset_sleep (t); + SCM_TICK; + } wakeup_fd = t->sleep_pipe[0]; FD_SET (wakeup_fd, readfds); @@ -1795,7 +1798,6 @@ scm_std_select (int nfds, res = args.result; eno = args.errno_value; - t->sleep_fd = -1; scm_i_reset_sleep (t); if (res > 0 && FD_ISSET (wakeup_fd, readfds)) diff --git a/libguile/threads.h b/libguile/threads.h index a8bb21a4a..241907db2 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -47,6 +47,13 @@ SCM_API scm_t_bits scm_tc16_thread; SCM_API scm_t_bits scm_tc16_mutex; SCM_API scm_t_bits scm_tc16_condvar; +struct scm_thread_wake_data +{ + SCM object; + scm_i_pthread_mutex_t *mutex; + int fd; +}; + typedef struct scm_i_thread { struct scm_i_thread *next_thread; @@ -67,10 +74,9 @@ typedef struct scm_i_thread { /* Boolean indicating whether the thread is in guile mode. */ int guile_mode; - SCM sleep_object; - scm_i_pthread_mutex_t *sleep_mutex; + struct scm_thread_wake_data *wake; scm_i_pthread_cond_t sleep_cond; - int sleep_fd, sleep_pipe[2]; + int sleep_pipe[2]; /* Thread-local freelists; see gc-inline.h. */ void **freelists; @@ -85,12 +91,10 @@ typedef struct scm_i_thread { /* For system asyncs. */ - SCM active_asyncs; /* The thunks to be run at the next - safe point */ + SCM pending_asyncs; /* The thunks to be run at the next + safe point. Accessed atomically. */ unsigned int block_asyncs; /* Non-zero means that asyncs should not be run. */ - unsigned int pending_asyncs; /* Non-zero means that asyncs might be pending. - */ /* The current continuation root and the stack base for it. diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 852e10d06..4f66b9e7d 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -127,10 +127,25 @@ #define ABORT_CONTINUATION_HOOK() \ RUN_HOOK0 (abort) -#define VM_HANDLE_INTERRUPTS \ - SCM_ASYNC_TICK_WITH_GUARD_CODE (thread, SYNC_IP (), CACHE_SP ()) +/* TODO: Invoke asyncs without trampolining out to C. That will let us + preempt computations via an asynchronous interrupt. */ +#define VM_HANDLE_INTERRUPTS \ + do \ + if (SCM_LIKELY (thread->block_asyncs == 0)) \ + { \ + SCM asyncs = scm_atomic_ref_scm (&thread->pending_asyncs); \ + if (SCM_UNLIKELY (!scm_is_null (asyncs))) \ + { \ + SYNC_IP (); \ + scm_async_tick (); \ + CACHE_SP (); \ + } \ + } \ + while (0) + + /* Virtual Machine The VM has three state bits: the instruction pointer (IP), the frame From a04739b31a561879368c61f7599844fc9a85a7a6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 27 Oct 2016 21:22:28 +0200 Subject: [PATCH 539/865] cancel-thread via asyncs, not pthread_cancel * module/ice-9/threads.scm (cancel-tag): New variable. (cancel-thread): New Scheme function. (call-with-new-thread): Install a prompt around the thread. * libguile/threads.h (scm_i_thread): Remove cancelled member. * libguile/threads.c (scm_cancel_thread): Call out to Scheme. Always available, and works on the current thread too. (scm_set_thread_cleanup_x, scm_thread_cleanup): Adapt. (scm_init_ice_9_threads): Capture cancel-thread var. * doc/ref/api-scheduling.texi (Threads): Update. * NEWS: Update. --- NEWS | 3 +++ doc/ref/api-scheduling.texi | 17 +++++++---------- libguile/threads.c | 36 +++++++++--------------------------- libguile/threads.h | 1 - module/ice-9/threads.scm | 30 +++++++++++++++++++++++++----- 5 files changed, 44 insertions(+), 43 deletions(-) diff --git a/NEWS b/NEWS index 0702eb294..06f2e8c30 100644 --- a/NEWS +++ b/NEWS @@ -38,6 +38,9 @@ trivial unused data structure. Now that we have deprecated the old only refer to "asyncs". * Bug fixes +** cancel-thread uses asynchronous interrupts, not pthread_cancel + +See "Asyncs" in the manual, for more on asynchronous interrupts. Previous changes in 2.1.x (changes since the 2.0.x series): diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index 551b3fb38..45b5315ce 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -114,17 +114,14 @@ immediate context switch to one of them. Otherwise, yield has no effect. @deffn {Scheme Procedure} cancel-thread thread @deffnx {C Function} scm_cancel_thread (thread) -Asynchronously notify @var{thread} to exit. Immediately after -receiving this notification, @var{thread} will call its cleanup handler -(if one has been set) and then terminate, aborting any evaluation that -is in progress. +Asynchronously interrupt @var{thread} and ask it to terminate. +@code{dynamic-wind} post thunks will run, but throw handlers will not. +If @var{thread} has already terminated or been signaled to terminate, +this function is a no-op. -Because Guile threads are isomorphic with POSIX threads, @var{thread} -will not receive its cancellation signal until it reaches a cancellation -point. See your operating system's POSIX threading documentation for -more information on cancellation points; note that in Guile, unlike -native POSIX threads, a thread can receive a cancellation notification -while attempting to lock a mutex. +Under this hood, thread cancellation uses @code{system-async-mark} and +@code{abort-to-prompt}. @xref{Asyncs} for more on asynchronous +interrupts. @end deffn @deffn {Scheme Procedure} set-thread-cleanup! thread proc diff --git a/libguile/threads.c b/libguile/threads.c index 2a315e472..8ac0832c5 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -438,7 +438,6 @@ guilify_self_1 (struct GC_stack_base *base) abort (); scm_i_pthread_mutex_init (&t.admin_mutex, NULL); - t.canceled = 0; t.exited = 0; t.guile_mode = 0; @@ -1012,34 +1011,14 @@ SCM_DEFINE (scm_yield, "yield", 0, 0, 0, /* Some systems, notably Android, lack 'pthread_cancel'. Don't provide 'cancel-thread' on these systems. */ -#if !SCM_USE_PTHREAD_THREADS || defined HAVE_PTHREAD_CANCEL +static SCM cancel_thread_var; -SCM_DEFINE (scm_cancel_thread, "cancel-thread", 1, 0, 0, - (SCM thread), -"Asynchronously force the target @var{thread} to terminate. @var{thread} " -"cannot be the current thread, and if @var{thread} has already terminated or " -"been signaled to terminate, this function is a no-op.") -#define FUNC_NAME s_scm_cancel_thread +SCM +scm_cancel_thread (SCM thread) { - scm_i_thread *t = NULL; - - SCM_VALIDATE_THREAD (1, thread); - t = SCM_I_THREAD_DATA (thread); - scm_i_scm_pthread_mutex_lock (&t->admin_mutex); - if (!t->canceled) - { - t->canceled = 1; - scm_i_pthread_mutex_unlock (&t->admin_mutex); - scm_i_pthread_cancel (t->pthread); - } - else - scm_i_pthread_mutex_unlock (&t->admin_mutex); - + scm_call_1 (scm_variable_ref (cancel_thread_var), thread); return SCM_UNSPECIFIED; } -#undef FUNC_NAME - -#endif SCM_DEFINE (scm_set_thread_cleanup_x, "set-thread-cleanup!", 2, 0, 0, (SCM thread, SCM proc), @@ -1056,7 +1035,7 @@ SCM_DEFINE (scm_set_thread_cleanup_x, "set-thread-cleanup!", 2, 0, 0, t = SCM_I_THREAD_DATA (thread); scm_i_pthread_mutex_lock (&t->admin_mutex); - if (!(t->exited || t->canceled)) + if (!t->exited) t->cleanup_handler = proc; scm_i_pthread_mutex_unlock (&t->admin_mutex); @@ -1077,7 +1056,7 @@ SCM_DEFINE (scm_thread_cleanup, "thread-cleanup", 1, 0, 0, t = SCM_I_THREAD_DATA (thread); scm_i_pthread_mutex_lock (&t->admin_mutex); - ret = (t->exited || t->canceled) ? SCM_BOOL_F : t->cleanup_handler; + ret = t->exited ? SCM_BOOL_F : t->cleanup_handler; scm_i_pthread_mutex_unlock (&t->admin_mutex); return ret; @@ -2073,6 +2052,9 @@ scm_init_ice_9_threads (void *unused) { #include "libguile/threads.x" + cancel_thread_var = + scm_module_variable (scm_current_module (), + scm_from_latin1_symbol ("cancel-thread")); call_with_new_thread_var = scm_module_variable (scm_current_module (), scm_from_latin1_symbol ("call-with-new-thread")); diff --git a/libguile/threads.h b/libguile/threads.h index 241907db2..90bb66163 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -68,7 +68,6 @@ typedef struct scm_i_thread { scm_i_pthread_mutex_t *held_mutex; SCM result; - int canceled; int exited; /* Boolean indicating whether the thread is in guile mode. */ diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm index f0f08e012..4b2f6c6eb 100644 --- a/module/ice-9/threads.scm +++ b/module/ice-9/threads.scm @@ -31,6 +31,7 @@ (define-module (ice-9 threads) #:use-module (ice-9 match) + #:use-module (ice-9 control) ;; These bindings are marked as #:replace because when deprecated code ;; is enabled, (ice-9 deprecated) also exports these names. ;; (Referencing one of the deprecated names prints a warning directing @@ -86,6 +87,21 @@ +(define cancel-tag (make-prompt-tag "cancel")) +(define (cancel-thread thread) + "Asynchronously interrupt the target @var{thread} and ask it to +terminate. @code{dynamic-wind} post thunks will run, but throw handlers +will not. If @var{thread} has already terminated or been signaled to +terminate, this function is a no-op." + (system-async-mark + (lambda () + (catch #t + (lambda () + (abort-to-prompt cancel-tag)) + (lambda _ + (error "thread cancellation failed, throwing error instead???")))) + thread)) + (define* (call-with-new-thread thunk #:optional handler) "Call @code{thunk} in a new thread and with a new dynamic state, returning a new thread object representing the thread. The procedure @@ -106,11 +122,15 @@ Once @var{thunk} or @var{handler} returns, the return value is made the (with-mutex mutex (%call-with-new-thread (lambda () - (lock-mutex mutex) - (set! thread (current-thread)) - (signal-condition-variable cv) - (unlock-mutex mutex) - (thunk))) + (call-with-prompt cancel-tag + (lambda () + (lock-mutex mutex) + (set! thread (current-thread)) + (signal-condition-variable cv) + (unlock-mutex mutex) + (thunk)) + (lambda (k . args) + (apply values args))))) (let lp () (unless thread (wait-condition-variable cv mutex) From e5399d3e7ca5de4e1981a9a9ddf136bd9d743c54 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 30 Oct 2016 20:31:57 +0100 Subject: [PATCH 540/865] Fix srfi-34 indentation * module/srfi/srfi-34.scm (with-exception-handler): Fix indentation. --- module/srfi/srfi-34.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/module/srfi/srfi-34.scm b/module/srfi/srfi-34.scm index 05bbdfa14..183f0ae23 100644 --- a/module/srfi/srfi-34.scm +++ b/module/srfi/srfi-34.scm @@ -41,9 +41,9 @@ procedure that accepts one argument. It is installed as the current exception handler for the dynamic extent (as determined by dynamic-wind) of the invocation of THUNK." (with-throw-handler throw-key - thunk - (lambda (key obj) - (handler obj)))) + thunk + (lambda (key obj) + (handler obj)))) (define (raise obj) "Invokes the current exception handler on OBJ. The handler is From 501c0e67b1977136a6e7677de007e5301f55adda Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 30 Oct 2016 20:38:18 +0100 Subject: [PATCH 541/865] srfi-18: Improve style. * module/srfi/srfi-18.scm (raise): Rely on SRFI-34 to #:replace raise. (make-thread): Use lambda* and when. --- module/srfi/srfi-18.scm | 18 +++++++----------- 1 file changed, 7 insertions(+), 11 deletions(-) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index e2d904770..756508c88 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -70,7 +70,6 @@ current-exception-handler with-exception-handler - raise join-timeout-exception? abandoned-mutex-exception? terminated-thread-exception? @@ -79,12 +78,12 @@ #:re-export ((threads:condition-variable? . condition-variable?) (threads:current-thread . current-thread) (threads:thread? . thread?) - (threads:mutex? . mutex?)) + (threads:mutex? . mutex?) + raise) #:replace (current-time make-thread make-mutex - make-condition-variable - raise)) + make-condition-variable)) (unless (provided? 'threads) (error "SRFI-18 requires Guile with threads support")) @@ -109,7 +108,6 @@ ;; EXCEPTIONS -(define raise (@ (srfi srfi-34) raise)) (define (initial-handler obj) (srfi-18-exception-preserver (cons uncaught-exception obj))) @@ -180,11 +178,9 @@ (threads:wait-condition-variable scond smutex) (threads:unlock-mutex smutex) (with-exception-handler initial-handler - thunk))))) - (lambda (thunk . name) - (let ((n (and (pair? name) (car name))) - - (lm (make-mutex 'launch-mutex)) + thunk))))) + (lambda* (thunk #:optional name) + (let ((lm (make-mutex 'launch-mutex)) (lc (make-condition-variable 'launch-condition-variable)) (sm (make-mutex 'start-mutex)) (sc (make-condition-variable 'start-condition-variable))) @@ -194,7 +190,7 @@ (make-cond-wrapper thunk lc lm sc sm) srfi-18-exception-handler))) (hashq-set! thread-start-conds t (cons sm sc)) - (and n (hashq-set! object-names t n)) + (when name (hashq-set! object-names t name)) (threads:wait-condition-variable lc lm) (threads:unlock-mutex lm) t))))) From 4d23c835c4373355e9d6ccd80cc8fe431f4551b9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 30 Oct 2016 21:43:08 +0100 Subject: [PATCH 542/865] srfi-18: Use `match' in thread-start!. * module/srfi/srfi-18.scm (thread-start!): Use `match'. --- module/srfi/srfi-18.scm | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 756508c88..adad0d987 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -32,6 +32,7 @@ (define-module (srfi srfi-18) #:use-module ((ice-9 threads) #:prefix threads:) + #:use-module (ice-9 match) #:use-module (srfi srfi-34) #:export (;; Threads make-thread @@ -210,15 +211,15 @@ *unspecified*) (define (thread-start! thread) - (let ((x (hashq-ref thread-start-conds - (check-arg-type threads:thread? thread "thread-start!")))) - (and x (let ((smutex (car x)) - (scond (cdr x))) - (hashq-remove! thread-start-conds thread) - (threads:lock-mutex smutex) - (threads:signal-condition-variable scond) - (threads:unlock-mutex smutex))) - thread)) + (match (hashq-ref thread-start-conds + (check-arg-type threads:thread? thread "thread-start!")) + ((smutex . scond) + (hashq-remove! thread-start-conds thread) + (threads:lock-mutex smutex) + (threads:signal-condition-variable scond) + (threads:unlock-mutex smutex)) + (#f #f)) + thread) (define (thread-yield!) (threads:yield) *unspecified*) From bbcc12815328e24686dfd283af0fdb9c80db67f4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 30 Oct 2016 21:43:51 +0100 Subject: [PATCH 543/865] srfi-18: Simplify thread-sleep!, thread-terminate!. * module/srfi/srfi-18.scm (thread-sleep!): Use `when'. (thread-terminate!): Simplify. --- module/srfi/srfi-18.scm | 34 +++++++++++++++------------------- 1 file changed, 15 insertions(+), 19 deletions(-) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index adad0d987..b3a064309 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -233,8 +233,8 @@ '())))) (secs (inexact->exact (truncate t))) (usecs (inexact->exact (truncate (* (- t secs) 1000000))))) - (and (> secs 0) (sleep secs)) - (and (> usecs 0) (usleep usecs)) + (when (> secs 0) (sleep secs)) + (when (> usecs 0) (usleep usecs)) *unspecified*)) ;; A convenience function for installing exception handlers on SRFI-18 @@ -254,23 +254,19 @@ ;; terminated-thread exception, as per SRFI-18, (define (thread-terminate! thread) - (define (thread-terminate-inner!) - (let ((current-handler (threads:thread-cleanup thread))) - (if (thunk? current-handler) - (threads:set-thread-cleanup! - thread - (lambda () - (with-exception-handler initial-handler - current-handler) - (srfi-18-exception-preserver - terminated-thread-exception))) - (threads:set-thread-cleanup! - thread - (lambda () (srfi-18-exception-preserver - terminated-thread-exception)))) - (threads:cancel-thread thread) - *unspecified*)) - (thread-terminate-inner!)) + (let ((current-handler (threads:thread-cleanup thread))) + (threads:set-thread-cleanup! + thread + (if (thunk? current-handler) + (lambda () + (with-exception-handler initial-handler + current-handler) + (srfi-18-exception-preserver + terminated-thread-exception)) + (lambda () (srfi-18-exception-preserver + terminated-thread-exception)))) + (threads:cancel-thread thread) + *unspecified*)) (define (thread-join! thread . args) (define thread-join-inner! From 7078218a9283877841983e22c6e4f5bb734d9288 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 30 Oct 2016 21:44:35 +0100 Subject: [PATCH 544/865] srfi-18: Use lambda* optional arguments. * module/srfi/srfi-18.scm (make-mutex, make-condition-variable): Use optional arguments. --- module/srfi/srfi-18.scm | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index b3a064309..6d74346f6 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -282,13 +282,12 @@ ;; MUTEXES ;; These functions are all pass-thrus to the existing Guile implementations. -(define make-mutex - (lambda name - (let ((n (and (pair? name) (car name))) - (m (threads:make-mutex 'unchecked-unlock - 'allow-external-unlock - 'recursive))) - (and n (hashq-set! object-names m n)) m))) +(define* (make-mutex #:optional name) + (let ((m (threads:make-mutex 'unchecked-unlock + 'allow-external-unlock + 'recursive))) + (when name (hashq-set! object-names m name)) + m)) (define (mutex-name mutex) (hashq-ref object-names (check-arg-type threads:mutex? mutex "mutex-name"))) @@ -323,11 +322,10 @@ ;; CONDITION VARIABLES ;; These functions are all pass-thrus to the existing Guile implementations. -(define make-condition-variable - (lambda name - (let ((n (and (pair? name) (car name))) - (m (threads:make-condition-variable))) - (and n (hashq-set! object-names m n)) m))) +(define* (make-condition-variable #:optional name) + (let ((m (threads:make-condition-variable))) + (when name (hashq-set! object-names m name)) + m)) (define (condition-variable-name condition-variable) (hashq-ref object-names (check-arg-type threads:condition-variable? From 0d57476f0a6ed30c420210946947740d3cf19fde Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 30 Oct 2016 22:15:17 +0100 Subject: [PATCH 545/865] srfi-18: Use parameters. * module/srfi/srfi-18.scm: Use srfi-34 internally with srfi-34: prefix. (current-exception-handler): Be a parameter. (with-exception-handler): Adapt to current-exception-handler change. (thread-join!, mutex-lock!): Adapt to use srfi-34: prefix. --- module/srfi/srfi-18.scm | 40 +++++++++++++++------------------------- 1 file changed, 15 insertions(+), 25 deletions(-) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 6d74346f6..cb2ac1c98 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -33,7 +33,7 @@ (define-module (srfi srfi-18) #:use-module ((ice-9 threads) #:prefix threads:) #:use-module (ice-9 match) - #:use-module (srfi srfi-34) + #:use-module ((srfi srfi-34) #:prefix srfi-34:) #:export (;; Threads make-thread thread-name @@ -80,7 +80,7 @@ (threads:current-thread . current-thread) (threads:thread? . thread?) (threads:mutex? . mutex?) - raise) + (srfi-34:raise . raise)) #:replace (current-time make-thread make-mutex @@ -130,29 +130,19 @@ (cons uncaught-exception key) (cons* uncaught-exception key args))))) -(define (current-handler-stack) - (let ((ct (threads:current-thread))) - (or (hashq-ref thread-exception-handlers ct) - (hashq-set! thread-exception-handlers ct (list initial-handler))))) +(define current-exception-handler (make-parameter initial-handler)) (define (with-exception-handler handler thunk) - (let ((ct (threads:current-thread)) - (hl (current-handler-stack))) - (check-arg-type procedure? handler "with-exception-handler") - (check-arg-type thunk? thunk "with-exception-handler") - (hashq-set! thread-exception-handlers ct (cons handler hl)) - ((@ (srfi srfi-34) with-exception-handler) + (check-arg-type procedure? handler "with-exception-handler") + (check-arg-type thunk? thunk "with-exception-handler") + (srfi-34:with-exception-handler + (let ((prev-handler (current-exception-handler))) (lambda (obj) - (hashq-set! thread-exception-handlers ct hl) - (handler obj)) - (lambda () - (call-with-values thunk - (lambda res - (hashq-set! thread-exception-handlers ct hl) - (apply values res))))))) - -(define (current-exception-handler) - (car (current-handler-stack))) + (parameterize ((current-exception-handler prev-handler)) + (handler obj)))) + (lambda () + (parameterize ((current-exception-handler handler)) + (thunk))))) (define (join-timeout-exception? obj) (eq? obj join-timeout-exception)) (define (abandoned-mutex-exception? obj) (eq? obj abandoned-mutex-exception)) @@ -274,8 +264,8 @@ (let ((v (apply threads:join-thread thread args)) (e (thread->exception thread))) (if (and (= (length args) 1) (not v)) - (raise join-timeout-exception)) - (if e (raise e)) + (srfi-34:raise join-timeout-exception)) + (if e (srfi-34:raise e)) v)))) (call/cc thread-join-inner!)) @@ -313,7 +303,7 @@ (wrap (lambda () (catch 'abandoned-mutex-error (lambda () (apply threads:lock-mutex mutex args)) - (lambda (key . args) (raise abandoned-mutex-exception)))))) + (lambda (key . args) (srfi-34:raise abandoned-mutex-exception)))))) (call/cc mutex-lock-inner!)) (define (mutex-unlock! mutex . args) From 177a058a400e8a718813b73b1cfe33adb5565eae Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 30 Oct 2016 22:30:21 +0100 Subject: [PATCH 546/865] srfi-18: Use srfi-35 conditions. * module/srfi/srfi-18.scm: Use srfi-35 conditions instead of our home-grown equivalent system. (thread-exception-handlers): Remove unused table. (srfi-18-exception-handler): Always capture key consed to args; no special case for bare key. * test-suite/tests/srfi-18.test (provided?): Adapt to reason always being key+args. --- module/srfi/srfi-18.scm | 51 +++++++++++++++++------------------ test-suite/tests/srfi-18.test | 2 +- 2 files changed, 26 insertions(+), 27 deletions(-) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index cb2ac1c98..8e5956bcf 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -34,6 +34,9 @@ #:use-module ((ice-9 threads) #:prefix threads:) #:use-module (ice-9 match) #:use-module ((srfi srfi-34) #:prefix srfi-34:) + #:use-module ((srfi srfi-35) #:select (define-condition-type + &error + condition)) #:export (;; Threads make-thread thread-name @@ -97,27 +100,31 @@ (scm-error 'wrong-type-arg caller "Wrong type argument: ~S" (list arg) '()))) -(define abandoned-mutex-exception (list 'abandoned-mutex-exception)) -(define join-timeout-exception (list 'join-timeout-exception)) -(define terminated-thread-exception (list 'terminated-thread-exception)) -(define uncaught-exception (list 'uncaught-exception)) +(define-condition-type &abandoned-mutex-exception &error + abandoned-mutex-exception?) +(define-condition-type &join-timeout-exception &error + join-timeout-exception?) +(define-condition-type &terminated-thread-exception &error + terminated-thread-exception?) +(define-condition-type &uncaught-exception &error + uncaught-exception? + (reason uncaught-exception-reason)) (define object-names (make-weak-key-hash-table)) (define object-specifics (make-weak-key-hash-table)) (define thread-start-conds (make-weak-key-hash-table)) -(define thread-exception-handlers (make-weak-key-hash-table)) ;; EXCEPTIONS (define (initial-handler obj) - (srfi-18-exception-preserver (cons uncaught-exception obj))) + (srfi-18-exception-preserver (condition (&uncaught-exception (reason obj))))) (define thread->exception (make-object-property)) (define (srfi-18-exception-preserver obj) - (if (or (terminated-thread-exception? obj) - (uncaught-exception? obj)) - (set! (thread->exception (threads:current-thread)) obj))) + (when (or (terminated-thread-exception? obj) + (uncaught-exception? obj)) + (set! (thread->exception (threads:current-thread)) obj))) (define (srfi-18-exception-handler key . args) @@ -125,10 +132,9 @@ ;; if one is caught at this level, it has already been taken care of by ;; `initial-handler'. - (and (not (eq? key 'srfi-34)) - (srfi-18-exception-preserver (if (null? args) - (cons uncaught-exception key) - (cons* uncaught-exception key args))))) + (unless (eq? key 'srfi-34) + (srfi-18-exception-preserver + (condition (&uncaught-exception (reason (cons key args))))))) (define current-exception-handler (make-parameter initial-handler)) @@ -144,15 +150,6 @@ (parameterize ((current-exception-handler handler)) (thunk))))) -(define (join-timeout-exception? obj) (eq? obj join-timeout-exception)) -(define (abandoned-mutex-exception? obj) (eq? obj abandoned-mutex-exception)) -(define (uncaught-exception? obj) - (and (pair? obj) (eq? (car obj) uncaught-exception))) -(define (uncaught-exception-reason exc) - (cdr (check-arg-type uncaught-exception? exc "uncaught-exception-reason"))) -(define (terminated-thread-exception? obj) - (eq? obj terminated-thread-exception)) - ;; THREADS ;; Create a new thread and prevent it from starting using a condition variable. @@ -252,9 +249,9 @@ (with-exception-handler initial-handler current-handler) (srfi-18-exception-preserver - terminated-thread-exception)) + (condition (&terminated-thread-exception)))) (lambda () (srfi-18-exception-preserver - terminated-thread-exception)))) + (condition (&terminated-thread-exception)))))) (threads:cancel-thread thread) *unspecified*)) @@ -264,7 +261,7 @@ (let ((v (apply threads:join-thread thread args)) (e (thread->exception thread))) (if (and (= (length args) 1) (not v)) - (srfi-34:raise join-timeout-exception)) + (srfi-34:raise (condition (&join-timeout-exception)))) (if e (srfi-34:raise e)) v)))) (call/cc thread-join-inner!)) @@ -303,7 +300,9 @@ (wrap (lambda () (catch 'abandoned-mutex-error (lambda () (apply threads:lock-mutex mutex args)) - (lambda (key . args) (srfi-34:raise abandoned-mutex-exception)))))) + (lambda (key . args) + (srfi-34:raise + (condition (&abandoned-mutex-exception)))))))) (call/cc mutex-lock-inner!)) (define (mutex-unlock! mutex . args) diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test index 5fba80ef7..a0474a35f 100644 --- a/test-suite/tests/srfi-18.test +++ b/test-suite/tests/srfi-18.test @@ -484,7 +484,7 @@ (with-exception-handler (lambda (obj) (and (uncaught-exception? obj) - (eq? (uncaught-exception-reason obj) 'foo) + (equal? (uncaught-exception-reason obj) '(foo)) (set! success #t))) (lambda () (thread-join! t))) success))))) From c3f08aa866f285fd944f998646b8a38c41df4575 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 30 Oct 2016 22:37:49 +0100 Subject: [PATCH 547/865] srfi-18: Inline uses of srfi-18-exception-preserver. * module/srfi/srfi-18.scm (srfi-18-exception-preserver): Inline into call sites. --- module/srfi/srfi-18.scm | 29 +++++++++++++---------------- 1 file changed, 13 insertions(+), 16 deletions(-) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 8e5956bcf..d2a7fc018 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -117,15 +117,11 @@ ;; EXCEPTIONS (define (initial-handler obj) - (srfi-18-exception-preserver (condition (&uncaught-exception (reason obj))))) + (set! (thread->exception (threads:current-thread)) + (condition (&uncaught-exception (reason obj))))) (define thread->exception (make-object-property)) -(define (srfi-18-exception-preserver obj) - (when (or (terminated-thread-exception? obj) - (uncaught-exception? obj)) - (set! (thread->exception (threads:current-thread)) obj))) - (define (srfi-18-exception-handler key . args) ;; SRFI 34 exceptions continue to bubble up no matter who handles them, so @@ -133,8 +129,8 @@ ;; `initial-handler'. (unless (eq? key 'srfi-34) - (srfi-18-exception-preserver - (condition (&uncaught-exception (reason (cons key args))))))) + (set! (thread->exception (threads:current-thread)) + (condition (&uncaught-exception (reason (cons key args))))))) (define current-exception-handler (make-parameter initial-handler)) @@ -244,14 +240,15 @@ (let ((current-handler (threads:thread-cleanup thread))) (threads:set-thread-cleanup! thread - (if (thunk? current-handler) - (lambda () - (with-exception-handler initial-handler - current-handler) - (srfi-18-exception-preserver - (condition (&terminated-thread-exception)))) - (lambda () (srfi-18-exception-preserver - (condition (&terminated-thread-exception)))))) + (let ((handler (lambda () + (set! (thread->exception (threads:current-thread)) + (condition (&terminated-thread-exception)))))) + (if (thunk? current-handler) + (lambda () + (with-exception-handler initial-handler + current-handler) + (handler)) + handler))) (threads:cancel-thread thread) *unspecified*)) From 789a4d8d87ecdef9e785e04de4b57e01e762b36e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 31 Oct 2016 20:52:08 +0100 Subject: [PATCH 548/865] srfi-18: Avoid call/cc. * module/srfi/srfi-18.scm (with-exception-handlers-here): New function. (wrap): Remove. (thread-join!, mutex-lock!): Use with-exception-handlers-here instead of the call/cc+wrap mess. --- module/srfi/srfi-18.scm | 62 ++++++++++++++++++++++------------------- 1 file changed, 34 insertions(+), 28 deletions(-) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index d2a7fc018..46c069ee8 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -220,18 +220,26 @@ (when (> usecs 0) (usleep usecs)) *unspecified*)) -;; A convenience function for installing exception handlers on SRFI-18 -;; primitives that resume the calling continuation after the handler is -;; invoked -- this resolves a behavioral incompatibility with Guile's -;; implementation of SRFI-34, which uses lazy-catch and rethrows handled -;; exceptions. (SRFI-18, "Primitives and exceptions") +;; Whereas SRFI-34 leaves the continuation of a call to an exception +;; handler unspecified, SRFI-18 has this to say: +;; +;; When one of the primitives defined in this SRFI raises an exception +;; defined in this SRFI, the exception handler is called with the same +;; continuation as the primitive (i.e. it is a tail call to the +;; exception handler). +;; +;; Therefore arrange for exceptions thrown by SRFI-18 primitives to run +;; handlers with the continuation of the primitive call, for those +;; primitives that throw exceptions. -(define (wrap thunk) - (lambda (continuation) - (with-exception-handler (lambda (obj) - ((current-exception-handler) obj) - (continuation)) - thunk))) +(define (with-exception-handlers-here thunk) + (let ((tag (make-prompt-tag))) + (call-with-prompt tag + (lambda () + (with-exception-handler (lambda (exn) (abort-to-prompt tag exn)) + thunk)) + (lambda (k exn) + ((current-exception-handler) exn))))) ;; A pass-thru to cancel-thread that first installs a handler that throws ;; terminated-thread exception, as per SRFI-18, @@ -253,15 +261,14 @@ *unspecified*)) (define (thread-join! thread . args) - (define thread-join-inner! - (wrap (lambda () - (let ((v (apply threads:join-thread thread args)) - (e (thread->exception thread))) - (if (and (= (length args) 1) (not v)) - (srfi-34:raise (condition (&join-timeout-exception)))) - (if e (srfi-34:raise e)) - v)))) - (call/cc thread-join-inner!)) + (with-exception-handlers-here + (lambda () + (let ((v (apply threads:join-thread thread args)) + (e (thread->exception thread))) + (if (and (= (length args) 1) (not v)) + (srfi-34:raise (condition (&join-timeout-exception)))) + (if e (srfi-34:raise e)) + v)))) ;; MUTEXES ;; These functions are all pass-thrus to the existing Guile implementations. @@ -293,14 +300,13 @@ (if (> (threads:mutex-level mutex) 0) 'not-owned 'not-abandoned)))) (define (mutex-lock! mutex . args) - (define mutex-lock-inner! - (wrap (lambda () - (catch 'abandoned-mutex-error - (lambda () (apply threads:lock-mutex mutex args)) - (lambda (key . args) - (srfi-34:raise - (condition (&abandoned-mutex-exception)))))))) - (call/cc mutex-lock-inner!)) + (with-exception-handlers-here + (lambda () + (catch 'abandoned-mutex-error + (lambda () (apply threads:lock-mutex mutex args)) + (lambda (key . args) + (srfi-34:raise + (condition (&abandoned-mutex-exception)))))))) (define (mutex-unlock! mutex . args) (apply threads:unlock-mutex mutex args)) From 8e305ee0459cf22e4ccc889e38c0fd6f1782648d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 31 Oct 2016 21:07:03 +0100 Subject: [PATCH 549/865] Rationalize exception handling in srfi-18 * module/srfi/srfi-18.scm (make-thread): Inline some helpers, and use just one catch block. (thread->exception): Move up definition. (exception-handler-for-foreign-threads): Use this as the default handler, not the one that squirrels away exceptions in thread->exception. (thread-terminate!): Don't instate an exception handler for the thread cleanup proc. --- module/srfi/srfi-18.scm | 82 +++++++++++++++++++---------------------- 1 file changed, 38 insertions(+), 44 deletions(-) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 46c069ee8..6ff88abcb 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -113,26 +113,20 @@ (define object-names (make-weak-key-hash-table)) (define object-specifics (make-weak-key-hash-table)) (define thread-start-conds (make-weak-key-hash-table)) +(define thread->exception (make-object-property)) ;; EXCEPTIONS -(define (initial-handler obj) - (set! (thread->exception (threads:current-thread)) - (condition (&uncaught-exception (reason obj))))) +;; All threads created by SRFI-18 have an initial handler installed that +;; will squirrel away an uncaught exception to allow it to bubble out to +;; joining threads. However for the main thread and other threads not +;; created by SRFI-18, just let the exception bubble up by passing on +;; doing anything with the exception. +(define (exception-handler-for-foreign-threads obj) + (values)) -(define thread->exception (make-object-property)) - -(define (srfi-18-exception-handler key . args) - - ;; SRFI 34 exceptions continue to bubble up no matter who handles them, so - ;; if one is caught at this level, it has already been taken care of by - ;; `initial-handler'. - - (unless (eq? key 'srfi-34) - (set! (thread->exception (threads:current-thread)) - (condition (&uncaught-exception (reason (cons key args))))))) - -(define current-exception-handler (make-parameter initial-handler)) +(define current-exception-handler + (make-parameter exception-handler-for-foreign-threads)) (define (with-exception-handler handler thunk) (check-arg-type procedure? handler "with-exception-handler") @@ -152,32 +146,33 @@ ;; Once started, install a top-level exception handler that rethrows any ;; exceptions wrapped in an uncaught-exception wrapper. -(define make-thread - (let ((make-cond-wrapper (lambda (thunk lcond lmutex scond smutex) - (lambda () - (threads:lock-mutex lmutex) - (threads:signal-condition-variable lcond) - (threads:lock-mutex smutex) - (threads:unlock-mutex lmutex) - (threads:wait-condition-variable scond smutex) - (threads:unlock-mutex smutex) - (with-exception-handler initial-handler - thunk))))) - (lambda* (thunk #:optional name) - (let ((lm (make-mutex 'launch-mutex)) - (lc (make-condition-variable 'launch-condition-variable)) - (sm (make-mutex 'start-mutex)) - (sc (make-condition-variable 'start-condition-variable))) - - (threads:lock-mutex lm) - (let ((t (threads:call-with-new-thread - (make-cond-wrapper thunk lc lm sc sm) - srfi-18-exception-handler))) - (hashq-set! thread-start-conds t (cons sm sc)) - (when name (hashq-set! object-names t name)) - (threads:wait-condition-variable lc lm) - (threads:unlock-mutex lm) - t))))) +(define* (make-thread thunk #:optional name) + (let ((lm (make-mutex 'launch-mutex)) + (lc (make-condition-variable 'launch-condition-variable)) + (sm (make-mutex 'start-mutex)) + (sc (make-condition-variable 'start-condition-variable))) + (threads:lock-mutex lm) + (let ((t (threads:call-with-new-thread + (lambda () + (threads:lock-mutex lm) + (threads:signal-condition-variable lc) + (threads:lock-mutex sm) + (threads:unlock-mutex lm) + (threads:wait-condition-variable sc sm) + (threads:unlock-mutex sm) + (thunk)) + (lambda (key . args) + (set! (thread->exception (threads:current-thread)) + (condition (&uncaught-exception + (reason + (match (cons key args) + (('srfi-34 obj) obj) + (obj obj)))))))))) + (hashq-set! thread-start-conds t (cons sm sc)) + (when name (hashq-set! object-names t name)) + (threads:wait-condition-variable lc lm) + (threads:unlock-mutex lm) + t))) (define (thread-name thread) (hashq-ref object-names @@ -253,8 +248,7 @@ (condition (&terminated-thread-exception)))))) (if (thunk? current-handler) (lambda () - (with-exception-handler initial-handler - current-handler) + (current-handler) (handler)) handler))) (threads:cancel-thread thread) From 59fdf9cdcd1dfbe0e9542ea82678eee4fb62d753 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 31 Oct 2016 21:36:56 +0100 Subject: [PATCH 550/865] Refactor thread-join! to use optional args. * module/srfi/srfi-18.scm (thread-join!): Use optional args. Also don't treat false return values from threads as meaning anything. --- module/srfi/srfi-18.scm | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 6ff88abcb..aa2b2b226 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -254,15 +254,22 @@ (threads:cancel-thread thread) *unspecified*)) -(define (thread-join! thread . args) +;; A unique value. +(define %sentinel (list 1)) +(define* (thread-join! thread #:optional (timeout %sentinel) + (timeoutval %sentinel)) (with-exception-handlers-here (lambda () - (let ((v (apply threads:join-thread thread args)) - (e (thread->exception thread))) - (if (and (= (length args) 1) (not v)) - (srfi-34:raise (condition (&join-timeout-exception)))) - (if e (srfi-34:raise e)) - v)))) + (let ((v (if (eq? timeout %sentinel) + (threads:join-thread thread) + (threads:join-thread thread timeout %sentinel)))) + (cond + ((eq? v %sentinel) + (if (eq? timeoutval %sentinel) + (srfi-34:raise (condition (&join-timeout-exception))) + timeoutval)) + ((thread->exception thread) => srfi-34:raise) + (else v)))))) ;; MUTEXES ;; These functions are all pass-thrus to the existing Guile implementations. From 6bf9c6541937469f32228008634307824a902ecb Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 31 Oct 2016 21:42:47 +0100 Subject: [PATCH 551/865] Trim srfi-18 thread startup machinery * module/srfi/srfi-18.scm (make-thread): Use just one cond/mutex pair for signalling in both directions: waiting for launch and waiting for start. --- module/srfi/srfi-18.scm | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index aa2b2b226..fe5e76477 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -147,17 +147,13 @@ ;; exceptions wrapped in an uncaught-exception wrapper. (define* (make-thread thunk #:optional name) - (let ((lm (make-mutex 'launch-mutex)) - (lc (make-condition-variable 'launch-condition-variable)) - (sm (make-mutex 'start-mutex)) + (let ((sm (make-mutex 'start-mutex)) (sc (make-condition-variable 'start-condition-variable))) - (threads:lock-mutex lm) + (threads:lock-mutex sm) (let ((t (threads:call-with-new-thread (lambda () - (threads:lock-mutex lm) - (threads:signal-condition-variable lc) (threads:lock-mutex sm) - (threads:unlock-mutex lm) + (threads:signal-condition-variable sc) (threads:wait-condition-variable sc sm) (threads:unlock-mutex sm) (thunk)) @@ -168,10 +164,10 @@ (match (cons key args) (('srfi-34 obj) obj) (obj obj)))))))))) - (hashq-set! thread-start-conds t (cons sm sc)) (when name (hashq-set! object-names t name)) - (threads:wait-condition-variable lc lm) - (threads:unlock-mutex lm) + (threads:wait-condition-variable sc sm) + (hashq-set! thread-start-conds t (cons sm sc)) + (threads:unlock-mutex sm) t))) (define (thread-name thread) From a7114ced5f062a92d34b07f2fcc5a05e8612482a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 31 Oct 2016 22:11:01 +0100 Subject: [PATCH 552/865] cancel-thread can take arguments * doc/ref/api-scheduling.texi (Threads): * module/ice-9/threads.scm (cancel-thread): Additional args to cancel-thread will be returned by the thread. --- doc/ref/api-scheduling.texi | 5 +++-- module/ice-9/threads.scm | 11 ++++++----- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index 45b5315ce..564d43fe0 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -112,12 +112,13 @@ If one or more threads are waiting to execute, calling yield forces an immediate context switch to one of them. Otherwise, yield has no effect. @end deffn -@deffn {Scheme Procedure} cancel-thread thread +@deffn {Scheme Procedure} cancel-thread thread . values @deffnx {C Function} scm_cancel_thread (thread) Asynchronously interrupt @var{thread} and ask it to terminate. @code{dynamic-wind} post thunks will run, but throw handlers will not. If @var{thread} has already terminated or been signaled to terminate, -this function is a no-op. +this function is a no-op. Calling @code{join-thread} on the thread will +return the given @var{values}, if the cancel succeeded. Under this hood, thread cancellation uses @code{system-async-mark} and @code{abort-to-prompt}. @xref{Asyncs} for more on asynchronous diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm index 4b2f6c6eb..5871e9a80 100644 --- a/module/ice-9/threads.scm +++ b/module/ice-9/threads.scm @@ -88,16 +88,17 @@ (define cancel-tag (make-prompt-tag "cancel")) -(define (cancel-thread thread) +(define (cancel-thread thread . values) "Asynchronously interrupt the target @var{thread} and ask it to -terminate. @code{dynamic-wind} post thunks will run, but throw handlers -will not. If @var{thread} has already terminated or been signaled to -terminate, this function is a no-op." +terminate, returning the given @var{values}. @code{dynamic-wind} post +thunks will run, but throw handlers will not. If @var{thread} has +already terminated or been signaled to terminate, this function is a +no-op." (system-async-mark (lambda () (catch #t (lambda () - (abort-to-prompt cancel-tag)) + (apply abort-to-prompt cancel-tag values)) (lambda _ (error "thread cancellation failed, throwing error instead???")))) thread)) From b85f033526c77c89c38a0cdcc156b18a9784bb09 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 31 Oct 2016 22:11:43 +0100 Subject: [PATCH 553/865] srfi-18: thread-terminate! without cleanup handlers * module/srfi/srfi-18.scm (%cancel-sentinel, thread-terminate!): Just use cancel-thread to cause the thread to return a sentinel value. (%timeout-sentinel): Rename from %sentinel. (thread-join!): Adapt and transform %cancel-sentinel to a &terminated-thread-exception. --- module/srfi/srfi-18.scm | 36 +++++++++++++----------------------- 1 file changed, 13 insertions(+), 23 deletions(-) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index fe5e76477..36b19e7e3 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -232,38 +232,28 @@ (lambda (k exn) ((current-exception-handler) exn))))) -;; A pass-thru to cancel-thread that first installs a handler that throws -;; terminated-thread exception, as per SRFI-18, - +;; A unique value. +(define %cancel-sentinel (list 'cancelled)) (define (thread-terminate! thread) - (let ((current-handler (threads:thread-cleanup thread))) - (threads:set-thread-cleanup! - thread - (let ((handler (lambda () - (set! (thread->exception (threads:current-thread)) - (condition (&terminated-thread-exception)))))) - (if (thunk? current-handler) - (lambda () - (current-handler) - (handler)) - handler))) - (threads:cancel-thread thread) - *unspecified*)) + (threads:cancel-thread thread %cancel-sentinel) + *unspecified*) ;; A unique value. -(define %sentinel (list 1)) -(define* (thread-join! thread #:optional (timeout %sentinel) - (timeoutval %sentinel)) +(define %timeout-sentinel (list 1)) +(define* (thread-join! thread #:optional (timeout %timeout-sentinel) + (timeoutval %timeout-sentinel)) (with-exception-handlers-here (lambda () - (let ((v (if (eq? timeout %sentinel) + (let ((v (if (eq? timeout %timeout-sentinel) (threads:join-thread thread) - (threads:join-thread thread timeout %sentinel)))) + (threads:join-thread thread timeout %timeout-sentinel)))) (cond - ((eq? v %sentinel) - (if (eq? timeoutval %sentinel) + ((eq? v %timeout-sentinel) + (if (eq? timeoutval %timeout-sentinel) (srfi-34:raise (condition (&join-timeout-exception))) timeoutval)) + ((eq? v %cancel-sentinel) + (srfi-34:raise (condition (&terminated-thread-exception)))) ((thread->exception thread) => srfi-34:raise) (else v)))))) From 94a3433b9d1da4acf2737aa1db8ce129b90623d9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 31 Oct 2016 22:13:30 +0100 Subject: [PATCH 554/865] REPL server avoids thread cleanup handlers * module/system/repl/server.scm (serve-client): Avoid thread cleanup handlers. --- module/system/repl/server.scm | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/module/system/repl/server.scm b/module/system/repl/server.scm index b1b8a6b8c..f6981edf0 100644 --- a/module/system/repl/server.scm +++ b/module/system/repl/server.scm @@ -133,16 +133,17 @@ (define (serve-client client addr) (let ((thread (current-thread))) - ;; Close the socket when this thread exits, even if canceled. - (set-thread-cleanup! thread (lambda () (close-socket! client))) - ;; Arrange to cancel this thread to forcefully shut down the socket. + ;; To shut down this thread and socket, cause it to unwind. (add-open-socket! client (lambda () (cancel-thread thread)))) - (with-continuation-barrier - (lambda () - (parameterize ((current-input-port client) - (current-output-port client) - (current-error-port client) - (current-warning-port client)) - (with-fluids ((*repl-stack* '())) - (start-repl)))))) + (dynamic-wind + (lambda () #f) + (with-continuation-barrier + (lambda () + (parameterize ((current-input-port client) + (current-output-port client) + (current-error-port client) + (current-warning-port client)) + (with-fluids ((*repl-stack* '())) + (start-repl))))) + (lambda () (close-socket! client)))) From eeeee3297b8d4cb0717ee3b9ae5068b4f0b7f118 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 31 Oct 2016 22:37:46 +0100 Subject: [PATCH 555/865] Remove thread cleanup facility * NEWS: Add entry. * doc/ref/api-scheduling.texi (Threads): Remove thread-cleanup docs. * libguile/threads.c (guilify_self_1, do_thread_exit): (scm_set_thread_cleanup_x, scm_thread_cleanup): Remove these. * libguile/threads.h (scm_i_thread): Remove cleanup_handler. * module/ice-9/threads.scm: * module/ice-9/deprecated.scm (thread-cleanup, set-thread-cleanup!): Remove. * test-suite/tests/threads.test: Adapt to test cancel-thread return values and not test thread-cleanup procs. --- NEWS | 6 ++++ doc/ref/api-scheduling.texi | 21 ------------ libguile/threads.c | 61 ----------------------------------- libguile/threads.h | 3 -- module/ice-9/deprecated.scm | 2 -- module/ice-9/threads.scm | 2 -- test-suite/tests/threads.test | 29 +++-------------- 7 files changed, 10 insertions(+), 114 deletions(-) diff --git a/NEWS b/NEWS index 06f2e8c30..a5b1a01ca 100644 --- a/NEWS +++ b/NEWS @@ -21,6 +21,12 @@ break, however; we used the deprecation facility to signal a warning message while also providing these bindings in the root environment for the duration of the 2.2 series. +** Thread cleanup handlers removed + +The `set-thread-cleanup!' and `thread-cleanup' functions that were added +in Guile 2.0 to support cleanup after thread cancellation are no longer +needed, since threads can declare cleanup handlers via `dynamic-wind'. + * New deprecations ** Arbiters deprecated diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index 564d43fe0..6e9b5b180 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -125,27 +125,6 @@ Under this hood, thread cancellation uses @code{system-async-mark} and interrupts. @end deffn -@deffn {Scheme Procedure} set-thread-cleanup! thread proc -@deffnx {C Function} scm_set_thread_cleanup_x (thread, proc) -Set @var{proc} as the cleanup handler for the thread @var{thread}. -@var{proc}, which must be a thunk, will be called when @var{thread} -exits, either normally or by being canceled. Thread cleanup handlers -can be used to perform useful tasks like releasing resources, such as -locked mutexes, when thread exit cannot be predicted. - -The return value of @var{proc} will be set as the @emph{exit value} of -@var{thread}. - -To remove a cleanup handler, pass @code{#f} for @var{proc}. -@end deffn - -@deffn {Scheme Procedure} thread-cleanup thread -@deffnx {C Function} scm_thread_cleanup (thread) -Return the cleanup handler currently installed for the thread -@var{thread}. If no cleanup handler is currently installed, -thread-cleanup returns @code{#f}. -@end deffn - @deffn macro make-thread proc arg @dots{} Apply @var{proc} to @var{arg} @dots{} in a new thread formed by @code{call-with-new-thread} using a default error handler that display diff --git a/libguile/threads.c b/libguile/threads.c index 8ac0832c5..37381cbbd 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -408,7 +408,6 @@ guilify_self_1 (struct GC_stack_base *base) t.pthread = scm_i_pthread_self (); t.handle = SCM_BOOL_F; t.result = SCM_BOOL_F; - t.cleanup_handler = SCM_BOOL_F; t.mutexes = SCM_EOL; t.held_mutex = NULL; t.join_queue = SCM_EOL; @@ -527,13 +526,6 @@ typedef struct { #define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x) #define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x)) -static SCM -call_cleanup (void *data) -{ - SCM *proc_p = data; - return scm_call_0 (*proc_p); -} - /* Perform thread tear-down, in guile mode. */ static void * @@ -541,16 +533,6 @@ do_thread_exit (void *v) { scm_i_thread *t = (scm_i_thread *) v; - if (!scm_is_false (t->cleanup_handler)) - { - SCM ptr = t->cleanup_handler; - - t->cleanup_handler = SCM_BOOL_F; - t->result = scm_internal_catch (SCM_BOOL_T, - call_cleanup, &ptr, - scm_handle_by_message_noexit, NULL); - } - scm_i_scm_pthread_mutex_lock (&t->admin_mutex); t->exited = 1; @@ -1020,49 +1002,6 @@ scm_cancel_thread (SCM thread) return SCM_UNSPECIFIED; } -SCM_DEFINE (scm_set_thread_cleanup_x, "set-thread-cleanup!", 2, 0, 0, - (SCM thread, SCM proc), -"Set the thunk @var{proc} as the cleanup handler for the thread @var{thread}. " -"This handler will be called when the thread exits.") -#define FUNC_NAME s_scm_set_thread_cleanup_x -{ - scm_i_thread *t; - - SCM_VALIDATE_THREAD (1, thread); - if (!scm_is_false (proc)) - SCM_VALIDATE_THUNK (2, proc); - - t = SCM_I_THREAD_DATA (thread); - scm_i_pthread_mutex_lock (&t->admin_mutex); - - if (!t->exited) - t->cleanup_handler = proc; - - scm_i_pthread_mutex_unlock (&t->admin_mutex); - - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_thread_cleanup, "thread-cleanup", 1, 0, 0, - (SCM thread), -"Return the cleanup handler installed for the thread @var{thread}.") -#define FUNC_NAME s_scm_thread_cleanup -{ - scm_i_thread *t; - SCM ret; - - SCM_VALIDATE_THREAD (1, thread); - - t = SCM_I_THREAD_DATA (thread); - scm_i_pthread_mutex_lock (&t->admin_mutex); - ret = t->exited ? SCM_BOOL_F : t->cleanup_handler; - scm_i_pthread_mutex_unlock (&t->admin_mutex); - - return ret; -} -#undef FUNC_NAME - SCM scm_join_thread (SCM thread) { return scm_join_thread_timed (thread, SCM_UNDEFINED, SCM_UNDEFINED); diff --git a/libguile/threads.h b/libguile/threads.h index 90bb66163..b7f0fd987 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -60,7 +60,6 @@ typedef struct scm_i_thread { SCM handle; scm_i_pthread_t pthread; - SCM cleanup_handler; SCM join_queue; scm_i_pthread_mutex_t admin_mutex; @@ -151,8 +150,6 @@ SCM_INTERNAL void scm_i_dynwind_pthread_mutex_lock_block_asyncs (scm_i_pthread_m SCM_API SCM scm_call_with_new_thread (SCM thunk, SCM handler); SCM_API SCM scm_yield (void); SCM_API SCM scm_cancel_thread (SCM t); -SCM_API SCM scm_set_thread_cleanup_x (SCM thread, SCM proc); -SCM_API SCM scm_thread_cleanup (SCM thread); SCM_API SCM scm_join_thread (SCM t); SCM_API SCM scm_join_thread_timed (SCM t, SCM timeout, SCM timeoutval); SCM_API SCM scm_thread_p (SCM t); diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm index de917df52..52b3d634b 100644 --- a/module/ice-9/deprecated.scm +++ b/module/ice-9/deprecated.scm @@ -57,8 +57,6 @@ call-with-new-thread yield cancel-thread - set-thread-cleanup! - thread-cleanup join-thread thread? make-mutex diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm index 5871e9a80..555143e70 100644 --- a/module/ice-9/threads.scm +++ b/module/ice-9/threads.scm @@ -41,8 +41,6 @@ #:replace (call-with-new-thread yield cancel-thread - set-thread-cleanup! - thread-cleanup join-thread thread? make-mutex diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test index 3b7a3e440..f489d5958 100644 --- a/test-suite/tests/threads.test +++ b/test-suite/tests/threads.test @@ -351,13 +351,12 @@ (join-thread t) #t))) - (pass-if "handler result passed to join" + (pass-if "cancel result passed to join" (require-cancel-thread) (let ((m (make-mutex))) (lock-mutex m) (let ((t (begin-thread (lock-mutex m)))) - (set-thread-cleanup! t (lambda () 'foo)) - (cancel-thread t) + (cancel-thread t 'foo) (eq? (join-thread t) 'foo)))) (pass-if "can cancel self" @@ -365,29 +364,9 @@ (let ((m (make-mutex))) (lock-mutex m) (let ((t (begin-thread (begin - (set-thread-cleanup! (current-thread) - (lambda () 'foo)) - (cancel-thread (current-thread)) + (cancel-thread (current-thread) 'foo) (lock-mutex m))))) - (eq? (join-thread t) 'foo)))) - - (pass-if "handler supplants final expr" - (let ((t (begin-thread (begin (set-thread-cleanup! (current-thread) - (lambda () 'bar)) - 'foo)))) - (eq? (join-thread t) 'bar))) - - (pass-if "remove handler by setting false" - (let ((m (make-mutex))) - (lock-mutex m) - (let ((t (begin-thread (lock-mutex m) 'bar))) - (set-thread-cleanup! t (lambda () 'foo)) - (set-thread-cleanup! t #f) - (unlock-mutex m) - (eq? (join-thread t) 'bar)))) - - (pass-if "initial handler is false" - (not (thread-cleanup (current-thread))))) + (eq? (join-thread t) 'foo))))) ;; ;; mutex ownership From 4280c818c2f9cf3434489c522300c90efca4cada Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Nov 2016 19:40:19 +0100 Subject: [PATCH 556/865] api-scheduling.texi: Syntactic cleanups. * doc/ref/api-scheduling.texi: Remove vestigial comments. --- doc/ref/api-scheduling.texi | 3 --- 1 file changed, 3 deletions(-) diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index 6e9b5b180..ced192d7a 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -53,7 +53,6 @@ Return a list of all threads. Return the thread that called this function. @end deffn -@c begin (texi-doc-string "guile" "call-with-new-thread") @deffn {Scheme Procedure} call-with-new-thread thunk [handler] Call @code{thunk} in a new thread and with a new dynamic state, returning the new thread. The procedure @var{thunk} is called via @@ -87,7 +86,6 @@ Return @code{#t} ff @var{obj} is a thread; otherwise, return @code{#f}. @end deffn -@c begin (texi-doc-string "guile" "join-thread") @deffn {Scheme Procedure} join-thread thread [timeout [timeoutval]] @deffnx {C Function} scm_join_thread (thread) @deffnx {C Function} scm_join_thread_timed (thread, timeout, timeoutval) @@ -106,7 +104,6 @@ specified; @code{#f} is returned otherwise). Return @code{#t} if @var{thread} has exited, or @code{#f} otherwise. @end deffn -@c begin (texi-doc-string "guile" "yield") @deffn {Scheme Procedure} yield If one or more threads are waiting to execute, calling yield forces an immediate context switch to one of them. Otherwise, yield has no effect. From b2e7662ebe1371a007c5b63a9e032fdccbe2a69b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Nov 2016 19:58:06 +0100 Subject: [PATCH 557/865] Add scm_yield to manual alongside yield * doc/ref/api-scheduling.texi (Threads): Mention scm_yield. --- doc/ref/api-scheduling.texi | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index ced192d7a..c7c7c8ebe 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -105,6 +105,7 @@ Return @code{#t} if @var{thread} has exited, or @code{#f} otherwise. @end deffn @deffn {Scheme Procedure} yield +@deffnx {C Function} scm_yield (thread) If one or more threads are waiting to execute, calling yield forces an immediate context switch to one of them. Otherwise, yield has no effect. @end deffn From 0a663877acb5ab5b79d7fafa5075d1f535527942 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Nov 2016 21:26:42 +0100 Subject: [PATCH 558/865] threads: Use a mutex instead of a critical section. * libguile/threads.c: Replace uses of critical sections with a dedicated mutex. --- libguile/threads.c | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index 37381cbbd..b2b352879 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -159,6 +159,8 @@ make_queue () return scm_cons (SCM_EOL, SCM_EOL); } +static scm_i_pthread_mutex_t queue_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; + /* Put T at the back of Q and return a handle that can be used with remqueue to remove T from Q again. */ @@ -166,13 +168,13 @@ static SCM enqueue (SCM q, SCM t) { SCM c = scm_cons (t, SCM_EOL); - SCM_CRITICAL_SECTION_START; + scm_i_pthread_mutex_lock (&queue_lock); if (scm_is_null (SCM_CDR (q))) SCM_SETCDR (q, c); else SCM_SETCDR (SCM_CAR (q), c); SCM_SETCAR (q, c); - SCM_CRITICAL_SECTION_END; + scm_i_pthread_mutex_unlock (&queue_lock); return c; } @@ -185,7 +187,7 @@ static int remqueue (SCM q, SCM c) { SCM p, prev = q; - SCM_CRITICAL_SECTION_START; + scm_i_pthread_mutex_lock (&queue_lock); for (p = SCM_CDR (q); !scm_is_null (p); p = SCM_CDR (p)) { if (scm_is_eq (p, c)) @@ -197,12 +199,12 @@ remqueue (SCM q, SCM c) /* GC-robust */ SCM_SETCDR (c, SCM_EOL); - SCM_CRITICAL_SECTION_END; + scm_i_pthread_mutex_unlock (&queue_lock); return 1; } prev = p; } - SCM_CRITICAL_SECTION_END; + scm_i_pthread_mutex_unlock (&queue_lock); return 0; } @@ -213,11 +215,11 @@ static SCM dequeue (SCM q) { SCM c; - SCM_CRITICAL_SECTION_START; + scm_i_pthread_mutex_lock (&queue_lock); c = SCM_CDR (q); if (scm_is_null (c)) { - SCM_CRITICAL_SECTION_END; + scm_i_pthread_mutex_unlock (&queue_lock); return SCM_BOOL_F; } else @@ -225,7 +227,7 @@ dequeue (SCM q) SCM_SETCDR (q, SCM_CDR (c)); if (scm_is_null (SCM_CDR (q))) SCM_SETCAR (q, SCM_EOL); - SCM_CRITICAL_SECTION_END; + scm_i_pthread_mutex_unlock (&queue_lock); /* GC-robust */ SCM_SETCDR (c, SCM_EOL); From 465466ce4dcb0ca10e9efb3d0746fcee11a96b3f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Nov 2016 21:40:34 +0100 Subject: [PATCH 559/865] sigaction critical section refactor. * libguile/scmsigs.c (scm_sigaction_for_thread): Use critical section dynwinds instead of SCM_CRITICAL_SECTION_START. --- libguile/scmsigs.c | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index b030b0413..d52fe8cba 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -334,7 +334,9 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0, scm_i_ensure_signal_delivery_thread (); - SCM_CRITICAL_SECTION_START; + scm_dynwind_begin (0); + scm_dynwind_critical_section (SCM_BOOL_F); + old_handler = SCM_SIMPLE_VECTOR_REF (*signal_handlers, csig); if (SCM_UNBNDP (handler)) query_only = 1; @@ -353,7 +355,6 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0, } else { - SCM_CRITICAL_SECTION_END; SCM_OUT_OF_RANGE (2, handler); } } @@ -440,7 +441,9 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0, } if (old_action.sa_handler == SIG_DFL || old_action.sa_handler == SIG_IGN) old_handler = scm_from_long ((long) old_action.sa_handler); - SCM_CRITICAL_SECTION_END; + + scm_dynwind_end (); + return scm_cons (old_handler, scm_from_int (old_action.sa_flags)); #else if (query_only) @@ -459,7 +462,9 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0, } if (old_chandler == SIG_DFL || old_chandler == SIG_IGN) old_handler = scm_from_long ((long) old_chandler); - SCM_CRITICAL_SECTION_END; + + scm_dynwind_end (); + return scm_cons (old_handler, scm_from_int (0)); #endif } From 445837754eadd0d3912a7977838280e036766845 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Nov 2016 21:55:16 +0100 Subject: [PATCH 560/865] regexec comment fix * libguile/regex-posix.c (SCM_DEFINE): Remove comment about threadsafety, given that regexec does appear to be threadsafe. --- libguile/regex-posix.c | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c index bec0f89fb..9350fb38b 100644 --- a/libguile/regex-posix.c +++ b/libguile/regex-posix.c @@ -244,17 +244,6 @@ SCM_DEFINE (scm_regexp_exec, "regexp-exec", 2, 2, 0, "@end table") #define FUNC_NAME s_scm_regexp_exec { - /* We used to have an SCM_DEFER_INTS, and then later an - SCM_CRITICAL_SECTION_START, around the regexec() call. Can't quite - remember what defer ints was for, but a critical section would only be - wanted now if we think regexec() is not thread-safe. The posix spec - - http://www.opengroup.org/onlinepubs/009695399/functions/regcomp.html - - reads like regexec is meant to be both thread safe and reentrant - (mentioning simultaneous use in threads, and in signal handlers). So - for now believe no protection needed. */ - int status, nmatches, offset; regmatch_t *matches; char *c_str; From c77ccc58fb216c7882e2dae3700f8490ffb40d42 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Nov 2016 22:10:12 +0100 Subject: [PATCH 561/865] Remove unused internal definitions * libguile/async.h (scm_i_pthread_mutex_lock_block_asyncs) (scm_i_pthread_mutex_unlock_unblock_asyncs): Remove unused internal definitions. --- libguile/async.h | 16 ---------------- 1 file changed, 16 deletions(-) diff --git a/libguile/async.h b/libguile/async.h index e8b6ee9c2..578e901be 100644 --- a/libguile/async.h +++ b/libguile/async.h @@ -75,22 +75,6 @@ SCM_API void scm_critical_section_end (void); scm_async_tick (); \ } while (0) -# define scm_i_pthread_mutex_lock_block_asyncs(m) \ - do \ - { \ - SCM_I_CURRENT_THREAD->block_asyncs++; \ - scm_i_pthread_mutex_lock (m); \ - } \ - while (0) - -# define scm_i_pthread_mutex_unlock_unblock_asyncs(m) \ - do \ - { \ - scm_i_pthread_mutex_unlock (m); \ - SCM_I_CURRENT_THREAD->block_asyncs--; \ - } \ - while (0) - #else /* !BUILDING_LIBGUILE */ # define SCM_CRITICAL_SECTION_START scm_critical_section_start () From cfab7e3bf3f1128a9029c3e446ef93312706ce74 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Nov 2016 22:33:30 +0100 Subject: [PATCH 562/865] Mutexes instead of critical sections in stime.c * libguile/stime.c (scm_current_time): No need for a critical section around time(). (tz_lock): New mutex. (scm_localtime): Use tz_lock in a dynwind. Fixes bug in which critical section was never left on error. (scm_gmtime, scm_mktime, scm_strftime, scm_strptime): Use a normal mutex instead of a critical section. --- libguile/stime.c | 31 ++++++++++++++++--------------- 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/libguile/stime.c b/libguile/stime.c index ec319eec0..f5b700056 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -271,9 +271,7 @@ SCM_DEFINE (scm_current_time, "current-time", 0, 0, 0, { timet timv; - SCM_CRITICAL_SECTION_START; timv = time (NULL); - SCM_CRITICAL_SECTION_END; if (timv == -1) SCM_MISC_ERROR ("current time not available", SCM_EOL); return scm_from_long (timv); @@ -328,6 +326,7 @@ filltime (struct tm *bd_time, int zoff, const char *zname) } static const char tzvar[3] = "TZ"; +static scm_i_pthread_mutex_t tz_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; /* if zone is set, create a temporary environment with only a TZ string. other threads or interrupt handlers shouldn't be allowed @@ -391,9 +390,11 @@ SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0, itime = SCM_NUM2LONG (1, time); - /* deferring interupts is essential since a) setzone may install a temporary - environment b) localtime uses a static buffer. */ - SCM_CRITICAL_SECTION_START; + /* Mutual exclusion is essential since a) setzone may install a + temporary environment b) localtime uses a static buffer. */ + scm_dynwind_begin (0); + scm_dynwind_pthread_mutex_lock (&tz_lock); + oldenv = setzone (zone, SCM_ARG2, FUNC_NAME); #ifdef LOCALTIME_CACHE tzset (); @@ -446,9 +447,9 @@ SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0, zoff += 24 * 60 * 60; result = filltime (<, zoff, zname); - SCM_CRITICAL_SECTION_END; - free (zname); + + scm_dynwind_end (); return result; } #undef FUNC_NAME @@ -479,11 +480,11 @@ SCM_DEFINE (scm_gmtime, "gmtime", 1, 0, 0, #if HAVE_GMTIME_R bd_time = gmtime_r (&itime, &bd_buf); #else - SCM_CRITICAL_SECTION_START; + scm_i_pthread_mutex_lock (&tz_lock); bd_time = gmtime (&itime); if (bd_time != NULL) bd_buf = *bd_time; - SCM_CRITICAL_SECTION_END; + scm_i_pthread_mutex_unlock (&tz_lock); #endif if (bd_time == NULL) SCM_SYSERROR; @@ -552,7 +553,7 @@ SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0, scm_dynwind_free ((char *)lt.tm_zone); #endif - scm_dynwind_critical_section (SCM_BOOL_F); + scm_dynwind_pthread_mutex_lock (&tz_lock); oldenv = setzone (zone, SCM_ARG2, FUNC_NAME); #ifdef LOCALTIME_CACHE @@ -698,7 +699,7 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, scm_from_locale_string ("0"))); have_zone = 1; - SCM_CRITICAL_SECTION_START; + scm_pthread_mutex_lock (&tz_lock); oldenv = setzone (zone, SCM_ARG2, FUNC_NAME); } #endif @@ -720,7 +721,7 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, if (have_zone) { restorezone (zone_spec, oldenv, FUNC_NAME); - SCM_CRITICAL_SECTION_END; + scm_i_pthread_mutex_unlock (&tz_lock); } #endif } @@ -780,11 +781,11 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, /* GNU glibc strptime() "%s" is affected by the current timezone, since it reads a UTC time_t value and converts with localtime_r() to set the tm - fields, hence the use of SCM_CRITICAL_SECTION_START. */ + fields, hence the mutex. */ t.tm_isdst = -1; - SCM_CRITICAL_SECTION_START; + scm_i_pthread_mutex_lock (&tz_lock); rest = strptime (str, fmt, &t); - SCM_CRITICAL_SECTION_END; + scm_i_pthread_mutex_unlock (&tz_lock); if (rest == NULL) { /* POSIX doesn't say strptime sets errno, and on glibc 2.3.2 for From c88d0cc402f9146023df7d6c2309510882599eba Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Nov 2016 22:40:38 +0100 Subject: [PATCH 563/865] Mutex instead of critical sectoin in symbol->keyword * libguile/keywords.c (scm_symbol_to_keyword): Use a mutex in a dynwind instead of a critical section. --- libguile/keywords.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/libguile/keywords.c b/libguile/keywords.c index 49cccd5a5..cd9c9d8a8 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -63,7 +63,8 @@ SCM_DEFINE (scm_symbol_to_keyword, "symbol->keyword", 1, 0, 0, SCM_ASSERT_TYPE (scm_is_symbol (symbol), symbol, 0, NULL, "symbol"); - SCM_CRITICAL_SECTION_START; + scm_dynwind_begin (0); + scm_dynwind_pthread_mutex_lock (&scm_i_misc_mutex); /* Note: `scm_cell' and `scm_hashq_set_x' can raise an out-of-memory error. */ keyword = scm_hashq_ref (keyword_obarray, symbol, SCM_BOOL_F); @@ -72,7 +73,7 @@ SCM_DEFINE (scm_symbol_to_keyword, "symbol->keyword", 1, 0, 0, keyword = scm_cell (scm_tc7_keyword, SCM_UNPACK (symbol)); scm_hashq_set_x (keyword_obarray, symbol, keyword); } - SCM_CRITICAL_SECTION_END; + scm_dynwind_end (); return keyword; } #undef FUNC_NAME From b410667e6434ef62a9c050dc4cbbff6f32a0c656 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Nov 2016 22:48:19 +0100 Subject: [PATCH 564/865] Simplify critical section implementation * libguile/async.h (SCM_CRITICAL_SECTION_START) (SCM_CRITICAL_SECTION_END): Define in just one way. * libguile/async.c (critical_section_mutex): New static variable. (scm_critical_section_start, scm_critical_section_end): Inline internal body of critical section gates. (scm_init_async): Init critical_section_mutex. * libguile/threads.c (scm_threads_prehistory): Don't declare critical section mutex here. --- libguile/async.c | 16 ++++++++++------ libguile/async.h | 32 ++------------------------------ libguile/threads.c | 6 ------ 3 files changed, 12 insertions(+), 42 deletions(-) diff --git a/libguile/async.c b/libguile/async.c index aa4f508b7..d7b266bd2 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -299,21 +299,23 @@ scm_c_call_with_unblocked_asyncs (void *(*proc) (void *data), void *data) } -/* These are function variants of the same-named macros (uppercase) for use - outside of libguile. This is so that `SCM_I_CURRENT_THREAD', which may - reside in TLS, is not accessed from outside of libguile. It thus allows - libguile to be built with the "local-dynamic" TLS model. */ +static scm_i_pthread_mutex_t critical_section_mutex; void scm_critical_section_start (void) { - SCM_CRITICAL_SECTION_START; + scm_i_pthread_mutex_lock (&critical_section_mutex); + SCM_I_CURRENT_THREAD->block_asyncs++; + SCM_I_CURRENT_THREAD->critical_section_level++; } void scm_critical_section_end (void) { - SCM_CRITICAL_SECTION_END; + SCM_I_CURRENT_THREAD->critical_section_level--; + SCM_I_CURRENT_THREAD->block_asyncs--; + scm_i_pthread_mutex_unlock (&critical_section_mutex); + scm_async_tick (); } @@ -321,6 +323,8 @@ scm_critical_section_end (void) void scm_init_async () { + scm_i_pthread_mutex_init (&critical_section_mutex, + scm_i_pthread_mutexattr_recursive); #include "libguile/async.x" } diff --git a/libguile/async.h b/libguile/async.h index 578e901be..b709894c8 100644 --- a/libguile/async.h +++ b/libguile/async.h @@ -48,39 +48,11 @@ SCM_API void scm_dynwind_unblock_asyncs (void); /* Critical sections */ -/* XXX - every critical section needs to be examined whether the - requirements for SCM_CRITICAL_SECTION_START/END are fulfilled. See - the manual. -*/ - -/* Defined in threads.c. */ -SCM_INTERNAL scm_i_pthread_mutex_t scm_i_critical_section_mutex; - SCM_API void scm_critical_section_start (void); SCM_API void scm_critical_section_end (void); -#ifdef BUILDING_LIBGUILE - -# define SCM_CRITICAL_SECTION_START \ - do { \ - scm_i_pthread_mutex_lock (&scm_i_critical_section_mutex); \ - SCM_I_CURRENT_THREAD->block_asyncs++; \ - SCM_I_CURRENT_THREAD->critical_section_level++; \ - } while (0) -# define SCM_CRITICAL_SECTION_END \ - do { \ - SCM_I_CURRENT_THREAD->critical_section_level--; \ - SCM_I_CURRENT_THREAD->block_asyncs--; \ - scm_i_pthread_mutex_unlock (&scm_i_critical_section_mutex); \ - scm_async_tick (); \ - } while (0) - -#else /* !BUILDING_LIBGUILE */ - -# define SCM_CRITICAL_SECTION_START scm_critical_section_start () -# define SCM_CRITICAL_SECTION_END scm_critical_section_end () - -#endif /* !BUILDING_LIBGUILE */ +#define SCM_CRITICAL_SECTION_START scm_critical_section_start () +#define SCM_CRITICAL_SECTION_END scm_critical_section_end () SCM_INTERNAL void scm_init_async (void); diff --git a/libguile/threads.c b/libguile/threads.c index b2b352879..c27a7ea55 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1939,10 +1939,6 @@ static scm_i_pthread_cond_t wake_up_cond; static int threads_initialized_p = 0; -/* This mutex is used by SCM_CRITICAL_SECTION_START/END. - */ -scm_i_pthread_mutex_t scm_i_critical_section_mutex; - static SCM dynwind_critical_section_mutex; void @@ -1971,8 +1967,6 @@ scm_threads_prehistory (void *base) PTHREAD_MUTEX_RECURSIVE); #endif - scm_i_pthread_mutex_init (&scm_i_critical_section_mutex, - scm_i_pthread_mutexattr_recursive); scm_i_pthread_mutex_init (&scm_i_misc_mutex, NULL); scm_i_pthread_cond_init (&wake_up_cond, NULL); From e7e7a719bace8b71b351b9305940a7b4a724cc81 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Nov 2016 22:52:12 +0100 Subject: [PATCH 565/865] Mutex instead of critical section in GOOPS * libguile/goops.c (scm_sys_modify_instance) (scm_sys_modify_class): Use a mutex instead of a critical section. --- libguile/goops.c | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/libguile/goops.c b/libguile/goops.c index 4e28d06fb..8ed0f60ea 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -475,6 +475,8 @@ SCM_DEFINE (scm_sys_clear_fields_x, "%clear-fields!", 2, 0, 0, +static scm_i_pthread_mutex_t goops_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; + SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0, (SCM old, SCM new), "Used by change-class to modify objects in place.") @@ -487,7 +489,7 @@ SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0, * scratch the old value with new to be correct with GC. * See "Class redefinition protocol above". */ - SCM_CRITICAL_SECTION_START; + scm_i_pthread_mutex_lock (&goops_lock); { scm_t_bits word0, word1; word0 = SCM_CELL_WORD_0 (old); @@ -497,7 +499,7 @@ SCM_DEFINE (scm_sys_modify_instance, "%modify-instance", 2, 0, 0, SCM_SET_CELL_WORD_0 (new, word0); SCM_SET_CELL_WORD_1 (new, word1); } - SCM_CRITICAL_SECTION_END; + scm_i_pthread_mutex_unlock (&goops_lock); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -510,7 +512,7 @@ SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0, SCM_VALIDATE_CLASS (1, old); SCM_VALIDATE_CLASS (2, new); - SCM_CRITICAL_SECTION_START; + scm_i_pthread_mutex_lock (&goops_lock); { scm_t_bits word0, word1; word0 = SCM_CELL_WORD_0 (old); @@ -522,7 +524,7 @@ SCM_DEFINE (scm_sys_modify_class, "%modify-class", 2, 0, 0, SCM_SET_CELL_WORD_1 (new, word1); SCM_STRUCT_DATA (new)[scm_vtable_index_self] = SCM_UNPACK (new); } - SCM_CRITICAL_SECTION_END; + scm_i_pthread_mutex_unlock (&goops_lock); return SCM_UNSPECIFIED; } #undef FUNC_NAME From 42882bbf42fa70a3c7174909a32a91b9ff68abbf Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Nov 2016 22:57:54 +0100 Subject: [PATCH 566/865] Mutex instead of critical section in gc.c * libguile/gc.c (scm_gc_protect_object, scm_gc_unprotect_object): Use a mutex instead of a critical section. Remove dead code. --- libguile/gc.c | 27 +++++++++------------------ 1 file changed, 9 insertions(+), 18 deletions(-) diff --git a/libguile/gc.c b/libguile/gc.c index 1e9f59683..6044753ce 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -496,22 +496,21 @@ scm_permanent_object (SCM obj) +static scm_i_pthread_mutex_t gc_protect_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; + SCM scm_gc_protect_object (SCM obj) { SCM handle; - /* This critical section barrier will be replaced by a mutex. */ - /* njrev: Indeed; if my comment above is correct, there is the same - critsec/mutex inconsistency here. */ - SCM_CRITICAL_SECTION_START; + scm_dynwind_begin (0); + scm_dynwind_pthread_mutex_lock (&gc_protect_lock); handle = scm_hashq_create_handle_x (scm_protects, obj, scm_from_int (0)); SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), scm_from_int (1))); - protected_obj_count ++; - - SCM_CRITICAL_SECTION_END; + + scm_dynwind_end (); return obj; } @@ -526,18 +525,10 @@ scm_gc_unprotect_object (SCM obj) { SCM handle; - /* This critical section barrier will be replaced by a mutex. */ - /* njrev: and again. */ - SCM_CRITICAL_SECTION_START; + scm_dynwind_begin (0); + scm_dynwind_pthread_mutex_lock (&gc_protect_lock); - if (scm_gc_running_p) - { - fprintf (stderr, "scm_unprotect_object called during GC.\n"); - abort (); - } - handle = scm_hashq_get_handle (scm_protects, obj); - if (scm_is_false (handle)) { fprintf (stderr, "scm_unprotect_object called on unprotected object\n"); @@ -553,7 +544,7 @@ scm_gc_unprotect_object (SCM obj) } protected_obj_count --; - SCM_CRITICAL_SECTION_END; + scm_dynwind_end (); return obj; } From 399379bf255f7deb7e4da140081b17d6e99df894 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Nov 2016 23:07:56 +0100 Subject: [PATCH 567/865] Remove critical section in scm_debug_options * libguile/debug.c (scm_debug_options): Remove critical section. There is no memory corruption hazard and racing callers to debug options won't produce sensible results anyway; or anyway they will be the same as racing vector-set!. --- libguile/debug.c | 4 ---- 1 file changed, 4 deletions(-) diff --git a/libguile/debug.c b/libguile/debug.c index 878777d56..dfc9bda30 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -109,13 +109,9 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0, { SCM ans; - scm_dynwind_begin (0); - scm_dynwind_critical_section (SCM_BOOL_F); - ans = scm_options (setting, scm_debug_opts, FUNC_NAME); scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; - scm_dynwind_end (); return ans; } #undef FUNC_NAME From 2e2396d28cbf35c753bc831e20b1b6bc2cefb04d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Nov 2016 23:13:17 +0100 Subject: [PATCH 568/865] Mutex in dynamic linker * libguile/dynl.c (scm_dynamic_link, scm_dynamic_unlink) (scm_dynamic_pointer): Use a mutex to provide thread-safety. --- libguile/dynl.c | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/libguile/dynl.c b/libguile/dynl.c index 0061234e8..b1c9fb3a7 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -69,14 +69,8 @@ maybe_drag_in_eprintf () /* From the libtool manual: "Note that libltdl is not threadsafe, i.e. a multithreaded application has to use a mutex for libltdl.". - - Guile does not currently support pre-emptive threads, so there is no - mutex. Previously SCM_CRITICAL_SECTION_START and - SCM_CRITICAL_SECTION_END were used: they are mentioned here in case - somebody is grepping for thread problems ;) */ -/* njrev: not threadsafe, protection needed as described above */ - +static scm_i_pthread_mutex_t ltdl_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; /* LT_PATH_SEP-separated extension library search path, searched last */ static char *system_extensions_path; @@ -259,6 +253,7 @@ SCM_DEFINE (scm_dynamic_link, "dynamic-link", 0, 1, 0, char *file; scm_dynwind_begin (0); + scm_dynwind_pthread_mutex_lock (<dl_lock); if (SCM_UNBNDP (filename)) file = NULL; @@ -301,13 +296,18 @@ SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0, { /*fixme* GC-problem */ SCM_VALIDATE_SMOB (SCM_ARG1, dobj, dynamic_obj); + + scm_dynwind_begin (0); + scm_dynwind_pthread_mutex_lock (<dl_lock); if (DYNL_HANDLE (dobj) == NULL) { SCM_MISC_ERROR ("Already unlinked: ~S", scm_list_1 (dobj)); } else { sysdep_dynl_unlink (DYNL_HANDLE (dobj), FUNC_NAME); SET_DYNL_HANDLE (dobj, NULL); - return SCM_UNSPECIFIED; } + scm_dynwind_end (); + + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -335,6 +335,7 @@ SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 2, 0, 0, char *chars; scm_dynwind_begin (0); + scm_dynwind_pthread_mutex_lock (<dl_lock); chars = scm_to_locale_string (name); scm_dynwind_free (chars); val = sysdep_dynl_value (chars, DYNL_HANDLE (dobj), FUNC_NAME); From 65268ff37a89e02eddb5658c5c0e97ed9d0fe3c4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Nov 2016 23:31:11 +0100 Subject: [PATCH 569/865] Remove last critical section use * libguile/scmsigs.c (signal_handler_lock): New variable. (scm_sigaction_for_thread): Block asyncs and use a mutex instead of using scm_dynwind_critical_section. --- libguile/scmsigs.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index d52fe8cba..d852e7101 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -86,6 +86,8 @@ signal_handler_threads points to the thread that a signal should be delivered to. */ +static scm_i_pthread_mutex_t signal_handler_lock = + SCM_I_PTHREAD_MUTEX_INITIALIZER; static SCM *signal_handlers; static SCM signal_handler_asyncs; static SCM signal_handler_threads; @@ -335,7 +337,8 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0, scm_i_ensure_signal_delivery_thread (); scm_dynwind_begin (0); - scm_dynwind_critical_section (SCM_BOOL_F); + scm_dynwind_pthread_mutex_lock (&signal_handler_lock); + scm_dynwind_block_asyncs (); old_handler = SCM_SIMPLE_VECTOR_REF (*signal_handlers, csig); if (SCM_UNBNDP (handler)) From 8fc9450619a78023b0f4ea7c604569b5c5385927 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Nov 2016 23:27:04 +0100 Subject: [PATCH 570/865] Remove call/cc assertion about critical sections * libguile/continuations.c (scm_dynthrow): Remove assertion about critical section level; it's just a mutex anyway. --- libguile/continuations.c | 6 ------ 1 file changed, 6 deletions(-) diff --git a/libguile/continuations.c b/libguile/continuations.c index 3ce794be1..3e32749dc 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -301,12 +301,6 @@ scm_dynthrow (SCM cont) SCM_STACKITEM *dst = thread->continuation_base; SCM_STACKITEM stack_top_element; - if (thread->critical_section_level) - { - fprintf (stderr, "continuation invoked from within critical section.\n"); - abort (); - } - #if SCM_STACK_GROWS_UP if (dst + continuation->num_stack_items >= &stack_top_element) grow_stack (cont); From 4b78b001d875cee7a4ee383f0cb498afc67835ee Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Nov 2016 23:28:12 +0100 Subject: [PATCH 571/865] Threads no longer track critical section level * libguile/threads.h (scm_i_thread): * libguile/threads.c (guilify_self_1): Remove critical_section_level member of scm_i_thread. * libguile/async.c (scm_critical_section_end) (scm_critical_section_start): Remove bookkeeping. --- libguile/async.c | 2 -- libguile/threads.c | 1 - libguile/threads.h | 4 ---- 3 files changed, 7 deletions(-) diff --git a/libguile/async.c b/libguile/async.c index d7b266bd2..e45616755 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -306,13 +306,11 @@ scm_critical_section_start (void) { scm_i_pthread_mutex_lock (&critical_section_mutex); SCM_I_CURRENT_THREAD->block_asyncs++; - SCM_I_CURRENT_THREAD->critical_section_level++; } void scm_critical_section_end (void) { - SCM_I_CURRENT_THREAD->critical_section_level--; SCM_I_CURRENT_THREAD->block_asyncs--; scm_i_pthread_mutex_unlock (&critical_section_mutex); scm_async_tick (); diff --git a/libguile/threads.c b/libguile/threads.c index c27a7ea55..c1f416981 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -421,7 +421,6 @@ guilify_self_1 (struct GC_stack_base *base) t.dynstack.limit = NULL; t.pending_asyncs = SCM_EOL; t.block_asyncs = 1; - t.critical_section_level = 0; t.base = base->mem_base; #ifdef __ia64__ t.register_backing_store_base = base->reg_base; diff --git a/libguile/threads.h b/libguile/threads.h index b7f0fd987..6cf575be1 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -118,10 +118,6 @@ typedef struct scm_i_thread { void *register_backing_store_base; scm_t_contregs *pending_rbs_continuation; #endif - - /* Whether this thread is in a critical section. */ - int critical_section_level; - } scm_i_thread; #define SCM_I_IS_THREAD(x) SCM_SMOB_PREDICATE (scm_tc16_thread, x) From fcc6a7ba20d08f81602b395c04e04f9acc8403e3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 1 Nov 2016 23:48:42 +0100 Subject: [PATCH 572/865] Deprecate critical sections * NEWS: Deprecate critical sections. * doc/ref/api-scheduling.texi (Critical Sections): Remove. * libguile/async.c: * libguile/async.h: * libguile/deprecated.c: * libguile/deprecated.h: * libguile/threads.c: * libguile/threads.h: Deprecate critical section API. --- NEWS | 8 +++++++ doc/ref/api-scheduling.texi | 46 ------------------------------------- libguile/async.c | 20 ---------------- libguile/async.h | 8 ------- libguile/deprecated.c | 41 +++++++++++++++++++++++++++++++++ libguile/deprecated.h | 9 ++++++++ libguile/threads.c | 13 ----------- libguile/threads.h | 2 -- 8 files changed, 58 insertions(+), 89 deletions(-) diff --git a/NEWS b/NEWS index a5b1a01ca..7233d2f3c 100644 --- a/NEWS +++ b/NEWS @@ -43,6 +43,14 @@ trivial unused data structure. Now that we have deprecated the old "user async" facility, we have been able to clarify our documentation to only refer to "asyncs". +** Critical sections deprecated + +Critical sections have long been just a fancy way to lock a mutex and +defer asynchronous interrupts. Instead of SCM_CRITICAL_SECTION_START, +make sure you're in a "scm_dynwind_begin (0)" and use +scm_dynwind_pthread_mutex_lock instead, possibly also with +scm_dynwind_block_asyncs. + * Bug fixes ** cancel-thread uses asynchronous interrupts, not pthread_cancel diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index c7c7c8ebe..d5633044e 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -13,7 +13,6 @@ * Atomics:: Atomic references. * Mutexes and Condition Variables:: Synchronization primitives. * Blocking:: How to block properly in guile mode. -* Critical Sections:: Avoiding concurrency and reentries. * Fluids and Dynamic States:: Thread-local variables, etc. * Parameters:: Dynamic scoping in Scheme. * Futures:: Fine-grain parallelism. @@ -619,51 +618,6 @@ delivery of an async causes this function to be interrupted. @end deftypefn -@node Critical Sections -@subsection Critical Sections - -@deffn {C Macro} SCM_CRITICAL_SECTION_START -@deffnx {C Macro} SCM_CRITICAL_SECTION_END -These two macros can be used to delimit a critical section. -Syntactically, they are both statements and need to be followed -immediately by a semicolon. - -Executing @code{SCM_CRITICAL_SECTION_START} will lock a recursive mutex -and block the executing of asyncs. Executing -@code{SCM_CRITICAL_SECTION_END} will unblock the execution of system -asyncs and unlock the mutex. Thus, the code that executes between these -two macros can only be executed in one thread at any one time and no -asyncs will run. However, because the mutex is a recursive one, the -code might still be reentered by the same thread. You must either allow -for this or avoid it, both by careful coding. - -On the other hand, critical sections delimited with these macros can -be nested since the mutex is recursive. - -You must make sure that for each @code{SCM_CRITICAL_SECTION_START}, -the corresponding @code{SCM_CRITICAL_SECTION_END} is always executed. -This means that no non-local exit (such as a signalled error) might -happen, for example. -@end deffn - -@deftypefn {C Function} void scm_dynwind_critical_section (SCM mutex) -Call @code{scm_dynwind_lock_mutex} on @var{mutex} and call -@code{scm_dynwind_block_asyncs}. When @var{mutex} is false, a recursive -mutex provided by Guile is used instead. - -The effect of a call to @code{scm_dynwind_critical_section} is that -the current dynwind context (@pxref{Dynamic Wind}) turns into a -critical section. Because of the locked mutex, no second thread can -enter it concurrently and because of the blocked asyncs, no system -async can reenter it from the current thread. - -When the current thread reenters the critical section anyway, the kind -of @var{mutex} determines what happens: When @var{mutex} is recursive, -the reentry is allowed. When it is a normal mutex, an error is -signalled. -@end deftypefn - - @node Fluids and Dynamic States @subsection Fluids and Dynamic States diff --git a/libguile/async.c b/libguile/async.c index e45616755..b4a2c2ad2 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -298,31 +298,11 @@ scm_c_call_with_unblocked_asyncs (void *(*proc) (void *data), void *data) return ans; } - -static scm_i_pthread_mutex_t critical_section_mutex; - -void -scm_critical_section_start (void) -{ - scm_i_pthread_mutex_lock (&critical_section_mutex); - SCM_I_CURRENT_THREAD->block_asyncs++; -} - -void -scm_critical_section_end (void) -{ - SCM_I_CURRENT_THREAD->block_asyncs--; - scm_i_pthread_mutex_unlock (&critical_section_mutex); - scm_async_tick (); -} - void scm_init_async () { - scm_i_pthread_mutex_init (&critical_section_mutex, - scm_i_pthread_mutexattr_recursive); #include "libguile/async.x" } diff --git a/libguile/async.h b/libguile/async.h index b709894c8..2a57236ca 100644 --- a/libguile/async.h +++ b/libguile/async.h @@ -46,14 +46,6 @@ SCM_API void *scm_c_call_with_unblocked_asyncs (void *(*p) (void *d), void *d); SCM_API void scm_dynwind_block_asyncs (void); SCM_API void scm_dynwind_unblock_asyncs (void); -/* Critical sections */ - -SCM_API void scm_critical_section_start (void); -SCM_API void scm_critical_section_end (void); - -#define SCM_CRITICAL_SECTION_START scm_critical_section_start () -#define SCM_CRITICAL_SECTION_END scm_critical_section_end () - SCM_INTERNAL void scm_init_async (void); #endif /* SCM_ASYNC_H */ diff --git a/libguile/deprecated.c b/libguile/deprecated.c index 228c5d83b..c8d353f89 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -639,6 +639,44 @@ SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0, } #undef FUNC_NAME + +static scm_i_pthread_mutex_t critical_section_mutex; +static SCM dynwind_critical_section_mutex; + +void +scm_critical_section_start (void) +{ + scm_c_issue_deprecation_warning + ("Critical sections are deprecated. Instead use dynwinds and " + "\"scm_dynwind_pthread_mutex_lock\" together with " + "\"scm_dynwind_block_asyncs\" if appropriate."); + + scm_i_pthread_mutex_lock (&critical_section_mutex); + SCM_I_CURRENT_THREAD->block_asyncs++; +} + +void +scm_critical_section_end (void) +{ + SCM_I_CURRENT_THREAD->block_asyncs--; + scm_i_pthread_mutex_unlock (&critical_section_mutex); + scm_async_tick (); +} + +void +scm_dynwind_critical_section (SCM mutex) +{ + scm_c_issue_deprecation_warning + ("Critical sections are deprecated. Instead use dynwinds and " + "\"scm_dynwind_pthread_mutex_lock\" together with " + "\"scm_dynwind_block_asyncs\" if appropriate."); + + if (scm_is_false (mutex)) + mutex = dynwind_critical_section_mutex; + scm_dynwind_lock_mutex (mutex); + scm_dynwind_block_asyncs (); +} + @@ -648,6 +686,9 @@ scm_i_init_deprecated () scm_tc16_arbiter = scm_make_smob_type ("arbiter", 0); scm_set_smob_print (scm_tc16_arbiter, arbiter_print); tc16_async = scm_make_smob_type ("async", 0); + scm_i_pthread_mutex_init (&critical_section_mutex, + scm_i_pthread_mutexattr_recursive); + dynwind_critical_section_mutex = scm_make_recursive_mutex (); #include "libguile/deprecated.x" } diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 7eb7ee479..d8ce8166f 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -229,6 +229,15 @@ SCM_DEPRECATED SCM scm_run_asyncs (SCM list_of_a); +SCM_DEPRECATED void scm_critical_section_start (void); +SCM_DEPRECATED void scm_critical_section_end (void); +SCM_DEPRECATED void scm_dynwind_critical_section (SCM mutex); + +#define SCM_CRITICAL_SECTION_START scm_critical_section_start () +#define SCM_CRITICAL_SECTION_END scm_critical_section_end () + + + void scm_i_init_deprecated (void); #endif diff --git a/libguile/threads.c b/libguile/threads.c index c1f416981..43bd31310 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1938,17 +1938,6 @@ static scm_i_pthread_cond_t wake_up_cond; static int threads_initialized_p = 0; -static SCM dynwind_critical_section_mutex; - -void -scm_dynwind_critical_section (SCM mutex) -{ - if (scm_is_false (mutex)) - mutex = dynwind_critical_section_mutex; - scm_dynwind_lock_mutex (mutex); - scm_dynwind_block_asyncs (); -} - /*** Initialization */ scm_i_pthread_mutex_t scm_i_misc_mutex; @@ -2011,8 +2000,6 @@ scm_init_threads () guilify_self_2 (SCM_BOOL_F); threads_initialized_p = 1; - dynwind_critical_section_mutex = scm_make_recursive_mutex (); - scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, "scm_init_ice_9_threads", scm_init_ice_9_threads, NULL); diff --git a/libguile/threads.h b/libguile/threads.h index 6cf575be1..f6165a558 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -178,8 +178,6 @@ SCM_API SCM scm_all_threads (void); SCM_API int scm_c_thread_exited_p (SCM thread); SCM_API SCM scm_thread_exited_p (SCM thread); -SCM_API void scm_dynwind_critical_section (SCM mutex); - #ifdef BUILDING_LIBGUILE /* Though we don't need the key for SCM_I_CURRENT_THREAD if we have TLS, From 10471f40fe7ceed626debd36b2a5fec0a4b49b5a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 2 Nov 2016 19:10:33 +0100 Subject: [PATCH 573/865] Fix typo in threads documentation * doc/ref/api-scheduling.texi (Threads): Fix typo. --- doc/ref/api-scheduling.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index d5633044e..2fb7d15bf 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -117,7 +117,7 @@ If @var{thread} has already terminated or been signaled to terminate, this function is a no-op. Calling @code{join-thread} on the thread will return the given @var{values}, if the cancel succeeded. -Under this hood, thread cancellation uses @code{system-async-mark} and +Under the hood, thread cancellation uses @code{system-async-mark} and @code{abort-to-prompt}. @xref{Asyncs} for more on asynchronous interrupts. @end deffn From 0f5a59b215fdeff23d2632de1dfe7a22bfcb9d82 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 2 Nov 2016 21:29:22 +0100 Subject: [PATCH 574/865] try-mutex in terms of mutex-lock * libguile/threads.c (scm_try_mutex): Just call scm_lock_mutex_timed with a zero timeout. * module/ice-9/threads.scm (try-mutex): Likewise. --- libguile/threads.c | 22 +++------------------- module/ice-9/threads.scm | 5 +++++ 2 files changed, 8 insertions(+), 19 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index 43bd31310..022534808 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1311,27 +1311,11 @@ scm_dynwind_lock_mutex (SCM mutex) SCM_F_WIND_EXPLICITLY); } -SCM_DEFINE (scm_try_mutex, "try-mutex", 1, 0, 0, - (SCM mutex), -"Try to lock @var{mutex}. If the mutex is already locked by someone " -"else, return @code{#f}. Else lock the mutex and return @code{#t}. ") -#define FUNC_NAME s_scm_try_mutex +SCM +scm_try_mutex (SCM mutex) { - SCM exception; - int ret = 0; - scm_t_timespec cwaittime, *waittime = NULL; - - SCM_VALIDATE_MUTEX (1, mutex); - - to_timespec (scm_from_int(0), &cwaittime); - waittime = &cwaittime; - - exception = fat_mutex_lock (mutex, waittime, SCM_UNDEFINED, &ret); - if (!scm_is_false (exception)) - scm_ithrow (SCM_CAR (exception), scm_list_1 (SCM_CDR (exception)), 1); - return ret ? SCM_BOOL_T : SCM_BOOL_F; + return scm_lock_mutex_timed (mutex, SCM_INUM0, SCM_UNDEFINED); } -#undef FUNC_NAME /*** Fat condition variables */ diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm index 555143e70..119334b46 100644 --- a/module/ice-9/threads.scm +++ b/module/ice-9/threads.scm @@ -136,6 +136,11 @@ Once @var{thunk} or @var{handler} returns, the return value is made the (lp)))) thread)) +(define* (try-mutex mutex) + "Try to lock @var{mutex}. If the mutex is already locked, return +@code{#f}. Otherwise lock the mutex and return @code{#t}." + (lock-mutex mutex 0)) + ;;; Macros first, so that the procedures expand correctly. From 255963186902a62455942124e27c3a7e8c2fc476 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 4 Nov 2016 20:15:01 +0100 Subject: [PATCH 575/865] SRFI-18 mutexes disjoint from Guile mutexes * module/srfi/srfi-18.scm (): Define as a wrapper type around Guile mutexes. (thread-mutexes): New variable. (with-thread-mutex-cleanup): New facility to abandon mutexes on SRFI-18 thread exit. Not yet used. (make-thread): Use SRFI-18 interfaces. (make-mutex): Reimplement for our boxed mutexes. (mutex-state): Adapt. (mutex-lock!): Adapt. (mutex-unlock!): Adapt. * test-suite/tests/srfi-18.test: Don't assume that SRFI-18 mutexes are the same as Guile mutexes. --- module/srfi/srfi-18.scm | 103 ++++++++++++++++++++-------------- test-suite/tests/srfi-18.test | 9 ++- 2 files changed, 68 insertions(+), 44 deletions(-) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 36b19e7e3..b9739b25d 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -33,6 +33,7 @@ (define-module (srfi srfi-18) #:use-module ((ice-9 threads) #:prefix threads:) #:use-module (ice-9 match) + #:use-module (srfi srfi-9) #:use-module ((srfi srfi-34) #:prefix srfi-34:) #:use-module ((srfi srfi-35) #:select (define-condition-type &error @@ -50,6 +51,7 @@ ;; Mutexes make-mutex + mutex mutex-name mutex-specific mutex-specific-set! @@ -82,11 +84,11 @@ #:re-export ((threads:condition-variable? . condition-variable?) (threads:current-thread . current-thread) (threads:thread? . thread?) - (threads:mutex? . mutex?) (srfi-34:raise . raise)) #:replace (current-time make-thread make-mutex + mutex? make-condition-variable)) (unless (provided? 'threads) @@ -110,10 +112,18 @@ uncaught-exception? (reason uncaught-exception-reason)) +(define-record-type + (%make-mutex prim name specific) + mutex? + (prim mutex-prim) + (name mutex-name) + (specific mutex-specific mutex-specific-set!)) + (define object-names (make-weak-key-hash-table)) (define object-specifics (make-weak-key-hash-table)) (define thread-start-conds (make-weak-key-hash-table)) (define thread->exception (make-object-property)) +(define thread-mutexes (make-parameter #f)) ;; EXCEPTIONS @@ -146,28 +156,45 @@ ;; Once started, install a top-level exception handler that rethrows any ;; exceptions wrapped in an uncaught-exception wrapper. +(define (with-thread-mutex-cleanup thunk) + (let ((mutexes (make-weak-key-hash-table))) + (dynamic-wind + values + (lambda () + (parameterize ((thread-mutexes mutexes)) + (thunk))) + (lambda () + (let ((thread (current-thread))) + (hash-for-each (lambda (mutex _) + (when (eq? (mutex-state mutex) thread) + (abandon-mutex! mutex))) + mutexes)))))) + (define* (make-thread thunk #:optional name) (let ((sm (make-mutex 'start-mutex)) (sc (make-condition-variable 'start-condition-variable))) - (threads:lock-mutex sm) + (mutex-lock! sm) (let ((t (threads:call-with-new-thread (lambda () - (threads:lock-mutex sm) - (threads:signal-condition-variable sc) - (threads:wait-condition-variable sc sm) - (threads:unlock-mutex sm) - (thunk)) - (lambda (key . args) - (set! (thread->exception (threads:current-thread)) - (condition (&uncaught-exception - (reason - (match (cons key args) - (('srfi-34 obj) obj) - (obj obj)))))))))) + (catch #t + (lambda () + (with-thread-mutex-cleanup + (lambda () + (mutex-lock! sm) + (threads:signal-condition-variable sc) + (mutex-unlock! sm sc) + (thunk)))) + (lambda (key . args) + (set! (thread->exception (threads:current-thread)) + (condition (&uncaught-exception + (reason + (match (cons key args) + (('srfi-34 obj) obj) + (obj obj)))))))))))) (when name (hashq-set! object-names t name)) - (threads:wait-condition-variable sc sm) + (threads:wait-condition-variable sc (mutex-prim sm)) (hashq-set! thread-start-conds t (cons sm sc)) - (threads:unlock-mutex sm) + (mutex-unlock! sm) t))) (define (thread-name thread) @@ -189,9 +216,9 @@ (check-arg-type threads:thread? thread "thread-start!")) ((smutex . scond) (hashq-remove! thread-start-conds thread) - (threads:lock-mutex smutex) + (mutex-lock! smutex) (threads:signal-condition-variable scond) - (threads:unlock-mutex smutex)) + (mutex-unlock! smutex)) (#f #f)) thread) @@ -261,42 +288,36 @@ ;; These functions are all pass-thrus to the existing Guile implementations. (define* (make-mutex #:optional name) - (let ((m (threads:make-mutex 'unchecked-unlock - 'allow-external-unlock - 'recursive))) - (when name (hashq-set! object-names m name)) - m)) - -(define (mutex-name mutex) - (hashq-ref object-names (check-arg-type threads:mutex? mutex "mutex-name"))) - -(define (mutex-specific mutex) - (hashq-ref object-specifics - (check-arg-type threads:mutex? mutex "mutex-specific"))) - -(define (mutex-specific-set! mutex obj) - (hashq-set! object-specifics - (check-arg-type threads:mutex? mutex "mutex-specific-set!") - obj) - *unspecified*) + (%make-mutex (threads:make-mutex 'unchecked-unlock + 'allow-external-unlock + 'recursive) + name + #f)) (define (mutex-state mutex) - (let ((owner (threads:mutex-owner mutex))) + (let* ((prim (mutex-prim mutex)) + (owner (threads:mutex-owner prim))) (if owner - (if (threads:thread-exited? owner) 'abandoned owner) - (if (> (threads:mutex-level mutex) 0) 'not-owned 'not-abandoned)))) + (if (threads:thread-exited? owner) 'abandoned owner) + (if (> (threads:mutex-level prim) 0) 'not-owned 'not-abandoned)))) + +(define (abandon-mutex! mutex) + #t) (define (mutex-lock! mutex . args) + (let ((mutexes (thread-mutexes))) + (when mutexes + (hashq-set! mutexes mutex #t))) (with-exception-handlers-here (lambda () (catch 'abandoned-mutex-error - (lambda () (apply threads:lock-mutex mutex args)) + (lambda () (apply threads:lock-mutex (mutex-prim mutex) args)) (lambda (key . args) (srfi-34:raise (condition (&abandoned-mutex-exception)))))))) (define (mutex-unlock! mutex . args) - (apply threads:unlock-mutex mutex args)) + (apply threads:unlock-mutex (mutex-prim mutex) args)) ;; CONDITION VARIABLES ;; These functions are all pass-thrus to the existing Guile implementations. diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test index a0474a35f..ddd72dbab 100644 --- a/test-suite/tests/srfi-18.test +++ b/test-suite/tests/srfi-18.test @@ -377,7 +377,8 @@ (dec-sem! (lambda () (mutex-lock! m1) (while (eqv? sem 0) - (threads:wait-condition-variable c1 m1)) + (mutex-unlock! m1 c1) + (mutex-lock! m1)) (set! sem (- sem 1)) (mutex-unlock! m1))) (t1 (make-thread (lambda () @@ -451,13 +452,15 @@ h2 (lambda () (mutex-lock! m) (condition-variable-signal! c) - (threads:wait-condition-variable c m) + (mutex-unlock! m c) + (mutex-lock! m) (and (eq? (current-exception-handler) h2) (mutex-unlock! m))))) 'current-exception-handler-4))) (mutex-lock! m) (thread-start! t) - (threads:wait-condition-variable c m) + (mutex-unlock! m c) + (mutex-lock! m) (and (eq? (current-exception-handler) h1) (condition-variable-signal! c) (mutex-unlock! m) From 3794935fedc98e826383f7b5c3b5a63e5d96f44b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 4 Nov 2016 20:20:04 +0100 Subject: [PATCH 576/865] Remove export srfi-18 never had * module/srfi/srfi-18.scm (condition-variable-wait!): Remove undefined export. --- module/srfi/srfi-18.scm | 1 - 1 file changed, 1 deletion(-) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index b9739b25d..bdfeef86f 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -66,7 +66,6 @@ condition-variable-specific-set! condition-variable-signal! condition-variable-broadcast! - condition-variable-wait! ;; Time current-time From 846f7e116e5ae0e9e25d3439fb24eac909a88629 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 4 Nov 2016 20:29:44 +0100 Subject: [PATCH 577/865] srfi-18 condition variables disjoint * module/srfi/srfi-18.scm (): New data type. (make-thread): Use srfi-18 interfaces. (mutex-unlock!): Adapt to optional cond argument being disjoint from Guile condition variables. (make-condition-variable, condition-variable-signal!) (condition-variable-broadcast!): Adapt. --- module/srfi/srfi-18.scm | 59 +++++++++++++++++++---------------------- 1 file changed, 27 insertions(+), 32 deletions(-) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index bdfeef86f..69c03380b 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -80,15 +80,15 @@ terminated-thread-exception? uncaught-exception? uncaught-exception-reason) - #:re-export ((threads:condition-variable? . condition-variable?) - (threads:current-thread . current-thread) + #:re-export ((threads:current-thread . current-thread) (threads:thread? . thread?) (srfi-34:raise . raise)) #:replace (current-time make-thread make-mutex mutex? - make-condition-variable)) + make-condition-variable + condition-variable?)) (unless (provided? 'threads) (error "SRFI-18 requires Guile with threads support")) @@ -118,6 +118,13 @@ (name mutex-name) (specific mutex-specific mutex-specific-set!)) +(define-record-type + (%make-condition-variable prim name specific) + condition-variable? + (prim condition-variable-prim) + (name condition-variable-name) + (specific condition-variable-specific condition-variable-specific-set!)) + (define object-names (make-weak-key-hash-table)) (define object-specifics (make-weak-key-hash-table)) (define thread-start-conds (make-weak-key-hash-table)) @@ -180,7 +187,7 @@ (with-thread-mutex-cleanup (lambda () (mutex-lock! sm) - (threads:signal-condition-variable sc) + (condition-variable-signal! sc) (mutex-unlock! sm sc) (thunk)))) (lambda (key . args) @@ -191,9 +198,8 @@ (('srfi-34 obj) obj) (obj obj)))))))))))) (when name (hashq-set! object-names t name)) - (threads:wait-condition-variable sc (mutex-prim sm)) + (mutex-unlock! sm sc) (hashq-set! thread-start-conds t (cons sm sc)) - (mutex-unlock! sm) t))) (define (thread-name thread) @@ -216,7 +222,7 @@ ((smutex . scond) (hashq-remove! thread-start-conds thread) (mutex-lock! smutex) - (threads:signal-condition-variable scond) + (condition-variable-signal! scond) (mutex-unlock! smutex)) (#f #f)) thread) @@ -315,41 +321,30 @@ (srfi-34:raise (condition (&abandoned-mutex-exception)))))))) -(define (mutex-unlock! mutex . args) - (apply threads:unlock-mutex (mutex-prim mutex) args)) +(define mutex-unlock! + (case-lambda + ((mutex) + (threads:unlock-mutex (mutex-prim mutex))) + ((mutex cond) + (threads:unlock-mutex (mutex-prim mutex) + (condition-variable-prim cond))) + ((mutex cond timeout) + (threads:unlock-mutex (mutex-prim mutex) + (condition-variable-prim cond) + timeout)))) ;; CONDITION VARIABLES ;; These functions are all pass-thrus to the existing Guile implementations. (define* (make-condition-variable #:optional name) - (let ((m (threads:make-condition-variable))) - (when name (hashq-set! object-names m name)) - m)) - -(define (condition-variable-name condition-variable) - (hashq-ref object-names (check-arg-type threads:condition-variable? - condition-variable - "condition-variable-name"))) - -(define (condition-variable-specific condition-variable) - (hashq-ref object-specifics (check-arg-type threads:condition-variable? - condition-variable - "condition-variable-specific"))) - -(define (condition-variable-specific-set! condition-variable obj) - (hashq-set! object-specifics - (check-arg-type threads:condition-variable? - condition-variable - "condition-variable-specific-set!") - obj) - *unspecified*) + (%make-condition-variable (threads:make-condition-variable) name #f)) (define (condition-variable-signal! cond) - (threads:signal-condition-variable cond) + (threads:signal-condition-variable (condition-variable-prim cond)) *unspecified*) (define (condition-variable-broadcast! cond) - (threads:broadcast-condition-variable cond) + (threads:broadcast-condition-variable (condition-variable-prim cond)) *unspecified*) ;; TIME From bb4e955f0c26c8dc8a051028a7a145cb418bd155 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 4 Nov 2016 20:36:19 +0100 Subject: [PATCH 578/865] Update SRFI-18 documentation. * doc/ref/srfi-modules.texi (SRFI-18): Update documentation for disjoint mutexes and cond variables. --- doc/ref/srfi-modules.texi | 99 +++++++++++++++------------------------ 1 file changed, 39 insertions(+), 60 deletions(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index c9bde5e68..c307fcf9d 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -2060,14 +2060,12 @@ library. The functions and variables described here are provided by (use-modules (srfi srfi-18)) @end example -As a general rule, the data types and functions in this SRFI-18 -implementation are compatible with the types and functions in Guile's -core threading code. For example, mutexes created with the SRFI-18 -@code{make-mutex} function can be passed to the built-in Guile -function @code{lock-mutex} (@pxref{Mutexes and Condition Variables}), -and mutexes created with the built-in Guile function @code{make-mutex} -can be passed to the SRFI-18 function @code{mutex-lock!}. Cases in -which this does not hold true are noted in the following sections. +SRFI-18 defines facilities for threads, mutexes, condition variables, +time, and exception handling. Because these facilities are at a higher +level than Guile's primitives, they are implemented as a layer on top of +what Guile provides. In particular this means that a Guile mutex is not +a SRFI-18 mutex, and a Guile thread is not a SRFI-18 thread, and so on. +Guile provides a set of primitives and SRFI-18 is one of the systems built in terms of those primitives. @menu * SRFI-18 Threads:: Executing code @@ -2085,8 +2083,7 @@ Guile's built-in thread functions. First, a thread created by SRFI-18 @code{make-thread} begins in a blocked state and will not start execution until @code{thread-start!} is called on it. Second, SRFI-18 threads are constructed with a top-level exception handler that -captures any exceptions that are thrown on thread exit. In all other -regards, SRFI-18 threads are identical to normal Guile threads. +captures any exceptions that are thrown on thread exit. @defun current-thread Returns the thread that called this function. This is the same @@ -2179,41 +2176,28 @@ original exception can be retrieved using @node SRFI-18 Mutexes @subsubsection SRFI-18 Mutexes -The behavior of Guile's built-in mutexes is parameterized via a set of -flags passed to the @code{make-mutex} procedure in the core -(@pxref{Mutexes and Condition Variables}). To satisfy the requirements -for mutexes specified by SRFI-18, the @code{make-mutex} procedure -described below sets the following flags: -@itemize @bullet -@item -@code{recursive}: the mutex can be locked recursively -@item -@code{unchecked-unlock}: attempts to unlock a mutex that is already -unlocked will not raise an exception -@item -@code{allow-external-unlock}: the mutex can be unlocked by any thread, -not just the thread that locked it originally -@end itemize +SRFI-18 mutexes are disjoint from Guile's primitive mutexes. +@xref{Mutexes and Condition Variables}, for more on Guile's primitive +facility. @defun make-mutex [name] -Returns a new mutex, optionally assigning it the object name -@var{name}, which may be any Scheme object. The returned mutex will be -created with the configuration described above. Note that the name -@code{make-mutex} conflicts with Guile core function @code{make-mutex}. -Applications wanting to use both of these functions will need to refer -to them by different names. +Returns a new mutex, optionally assigning it the object name @var{name}, +which may be any Scheme object. The returned mutex will be created with +the configuration described above. @end defun @defun mutex-name mutex -Returns the name assigned to @var{mutex} at the time of its creation, -or @code{#f} if it was not given a name. +Returns the name assigned to @var{mutex} at the time of its creation, or +@code{#f} if it was not given a name. @end defun @defun mutex-specific mutex -@defunx mutex-specific-set! mutex obj -Get or set the ``object-specific'' property of @var{mutex}. In Guile's -implementation of SRFI-18, this value is stored as an object property, -and will be @code{#f} if not set. +Return the ``object-specific'' property of @var{mutex}, or @code{#f} if +none is set. +@end defun + +@defun mutex-specific-set! mutex obj +Set the ``object-specific'' property of @var{mutex}. @end defun @defun mutex-state mutex @@ -2221,8 +2205,8 @@ Returns information about the state of @var{mutex}. Possible values are: @itemize @bullet @item -thread @code{T}: the mutex is in the locked/owned state and thread T -is the owner of the mutex +thread @var{t}: the mutex is in the locked/owned state and thread +@var{t} is the owner of the mutex @item symbol @code{not-owned}: the mutex is in the locked/not-owned state @item @@ -2236,17 +2220,14 @@ unlocked/not-abandoned state @defun mutex-lock! mutex [timeout [thread]] Lock @var{mutex}, optionally specifying a time object @var{timeout} after which to abort the lock attempt and a thread @var{thread} giving -a new owner for @var{mutex} different than the current thread. This -procedure has the same behavior as the @code{lock-mutex} procedure in -the core library. +a new owner for @var{mutex} different than the current thread. @end defun @defun mutex-unlock! mutex [condition-variable [timeout]] Unlock @var{mutex}, optionally specifying a condition variable @var{condition-variable} on which to wait, either indefinitely or, optionally, until the time object @var{timeout} has passed, to be -signalled. This procedure has the same behavior as the -@code{unlock-mutex} procedure in the core library. +signalled. @end defun @@ -2255,20 +2236,20 @@ signalled. This procedure has the same behavior as the SRFI-18 does not specify a ``wait'' function for condition variables. Waiting on a condition variable can be simulated using the SRFI-18 -@code{mutex-unlock!} function described in the previous section, or -Guile's built-in @code{wait-condition-variable} procedure can be used. +@code{mutex-unlock!} function described in the previous section. + +SRFI-18 condition variables are disjoint from Guile's primitive +condition variables. @xref{Mutexes and Condition Variables}, for more +on Guile's primitive facility. @defun condition-variable? obj Returns @code{#t} if @var{obj} is a condition variable, @code{#f} -otherwise. This is the same procedure as the same-named built-in -procedure -(@pxref{Mutexes and Condition Variables, @code{condition-variable?}}). +otherwise. @end defun @defun make-condition-variable [name] Returns a new condition variable, optionally assigning it the object -name @var{name}, which may be any Scheme object. This procedure -replaces a procedure of the same name in the core library. +name @var{name}, which may be any Scheme object. @end defun @defun condition-variable-name condition-variable @@ -2277,21 +2258,19 @@ creation, or @code{#f} if it was not given a name. @end defun @defun condition-variable-specific condition-variable -@defunx condition-variable-specific-set! condition-variable obj -Get or set the ``object-specific'' property of -@var{condition-variable}. In Guile's implementation of SRFI-18, this -value is stored as an object property, and will be @code{#f} if not -set. +Return the ``object-specific'' property of @var{condition-variable}, or +@code{#f} if none is set. +@end defun + +@defun condition-variable-specific-set! condition-variable obj +Set the ``object-specific'' property of @var{condition-variable}. @end defun @defun condition-variable-signal! condition-variable @defunx condition-variable-broadcast! condition-variable Wake up one thread that is waiting for @var{condition-variable}, in the case of @code{condition-variable-signal!}, or all threads waiting -for it, in the case of @code{condition-variable-broadcast!}. The -behavior of these procedures is equivalent to that of the procedures -@code{signal-condition-variable} and -@code{broadcast-condition-variable} in the core library. +for it, in the case of @code{condition-variable-broadcast!}. @end defun From 3ce76c38cb3d041970c483635429743318938aa5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 4 Nov 2016 22:35:19 +0100 Subject: [PATCH 579/865] SRFI-18 threads disjoint from guile threads * doc/ref/srfi-modules.texi (SRFI-18 Threads): Update. * module/srfi/srfi-18.scm (): Add owner field. (): New data type. (make-thread): Adapt for boxed threads. (thread-start!, thread-terminate!): Likewise. (mutex-state): Adapt for boxed threads. (mutex-lock!, mutex-unlock!): Update owner field. --- doc/ref/srfi-modules.texi | 3 + module/srfi/srfi-18.scm | 142 ++++++++++++++++++++------------------ 2 files changed, 78 insertions(+), 67 deletions(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index c307fcf9d..1cada278a 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -2085,6 +2085,9 @@ execution until @code{thread-start!} is called on it. Second, SRFI-18 threads are constructed with a top-level exception handler that captures any exceptions that are thrown on thread exit. +SRFI-18 threads are disjoint from Guile's primitive threads. +@xref{Threads}, for more on Guile's primitive facility. + @defun current-thread Returns the thread that called this function. This is the same procedure as the same-named built-in procedure @code{current-thread} diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 69c03380b..d3a6a0909 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -80,10 +80,10 @@ terminated-thread-exception? uncaught-exception? uncaught-exception-reason) - #:re-export ((threads:current-thread . current-thread) - (threads:thread? . thread?) - (srfi-34:raise . raise)) + #:re-export ((srfi-34:raise . raise)) #:replace (current-time + current-thread + thread? make-thread make-mutex mutex? @@ -112,11 +112,12 @@ (reason uncaught-exception-reason)) (define-record-type - (%make-mutex prim name specific) + (%make-mutex prim name specific owner) mutex? (prim mutex-prim) (name mutex-name) - (specific mutex-specific mutex-specific-set!)) + (specific mutex-specific mutex-specific-set!) + (owner mutex-owner set-mutex-owner!)) (define-record-type (%make-condition-variable prim name specific) @@ -125,10 +126,16 @@ (name condition-variable-name) (specific condition-variable-specific condition-variable-specific-set!)) -(define object-names (make-weak-key-hash-table)) -(define object-specifics (make-weak-key-hash-table)) -(define thread-start-conds (make-weak-key-hash-table)) -(define thread->exception (make-object-property)) +(define-record-type + (%make-thread prim name specific start-conds exception) + thread? + (prim thread-prim set-thread-prim!) + (name thread-name) + (specific thread-specific thread-specific-set!) + (start-conds thread-start-conds set-thread-start-conds!) + (exception thread-exception set-thread-exception!)) + +(define current-thread (make-parameter (%make-thread #f #f #f #f #f))) (define thread-mutexes (make-parameter #f)) ;; EXCEPTIONS @@ -177,50 +184,37 @@ mutexes)))))) (define* (make-thread thunk #:optional name) - (let ((sm (make-mutex 'start-mutex)) - (sc (make-condition-variable 'start-condition-variable))) + (let* ((sm (make-mutex 'start-mutex)) + (sc (make-condition-variable 'start-condition-variable)) + (thread (%make-thread #f name #f (cons sm sc) #f))) (mutex-lock! sm) - (let ((t (threads:call-with-new-thread - (lambda () - (catch #t - (lambda () - (with-thread-mutex-cleanup + (let ((prim (threads:call-with-new-thread + (lambda () + (catch #t (lambda () - (mutex-lock! sm) - (condition-variable-signal! sc) - (mutex-unlock! sm sc) - (thunk)))) - (lambda (key . args) - (set! (thread->exception (threads:current-thread)) - (condition (&uncaught-exception - (reason - (match (cons key args) - (('srfi-34 obj) obj) - (obj obj)))))))))))) - (when name (hashq-set! object-names t name)) + (parameterize ((current-thread thread)) + (with-thread-mutex-cleanup + (lambda () + (mutex-lock! sm) + (condition-variable-signal! sc) + (mutex-unlock! sm sc) + (thunk))))) + (lambda (key . args) + (set-thread-exception! + thread + (condition (&uncaught-exception + (reason + (match (cons key args) + (('srfi-34 obj) obj) + (obj obj)))))))))))) + (set-thread-prim! thread prim) (mutex-unlock! sm sc) - (hashq-set! thread-start-conds t (cons sm sc)) - t))) - -(define (thread-name thread) - (hashq-ref object-names - (check-arg-type threads:thread? thread "thread-name"))) - -(define (thread-specific thread) - (hashq-ref object-specifics - (check-arg-type threads:thread? thread "thread-specific"))) - -(define (thread-specific-set! thread obj) - (hashq-set! object-specifics - (check-arg-type threads:thread? thread "thread-specific-set!") - obj) - *unspecified*) + thread))) (define (thread-start! thread) - (match (hashq-ref thread-start-conds - (check-arg-type threads:thread? thread "thread-start!")) + (match (thread-start-conds thread) ((smutex . scond) - (hashq-remove! thread-start-conds thread) + (set-thread-start-conds! thread #f) (mutex-lock! smutex) (condition-variable-signal! scond) (mutex-unlock! smutex)) @@ -267,27 +261,28 @@ ;; A unique value. (define %cancel-sentinel (list 'cancelled)) (define (thread-terminate! thread) - (threads:cancel-thread thread %cancel-sentinel) + (threads:cancel-thread (thread-prim thread) %cancel-sentinel) *unspecified*) ;; A unique value. (define %timeout-sentinel (list 1)) (define* (thread-join! thread #:optional (timeout %timeout-sentinel) (timeoutval %timeout-sentinel)) - (with-exception-handlers-here - (lambda () - (let ((v (if (eq? timeout %timeout-sentinel) - (threads:join-thread thread) - (threads:join-thread thread timeout %timeout-sentinel)))) - (cond - ((eq? v %timeout-sentinel) - (if (eq? timeoutval %timeout-sentinel) - (srfi-34:raise (condition (&join-timeout-exception))) - timeoutval)) - ((eq? v %cancel-sentinel) - (srfi-34:raise (condition (&terminated-thread-exception)))) - ((thread->exception thread) => srfi-34:raise) - (else v)))))) + (let ((t (thread-prim thread))) + (with-exception-handlers-here + (lambda () + (let* ((v (if (eq? timeout %timeout-sentinel) + (threads:join-thread t) + (threads:join-thread t timeout %timeout-sentinel)))) + (cond + ((eq? v %timeout-sentinel) + (if (eq? timeoutval %timeout-sentinel) + (srfi-34:raise (condition (&join-timeout-exception))) + timeoutval)) + ((eq? v %cancel-sentinel) + (srfi-34:raise (condition (&terminated-thread-exception)))) + ((thread-exception thread) => srfi-34:raise) + (else v))))))) ;; MUTEXES ;; These functions are all pass-thrus to the existing Guile implementations. @@ -297,38 +292,51 @@ 'allow-external-unlock 'recursive) name + #f #f)) (define (mutex-state mutex) (let* ((prim (mutex-prim mutex)) - (owner (threads:mutex-owner prim))) + (owner (mutex-owner mutex))) (if owner - (if (threads:thread-exited? owner) 'abandoned owner) + (if (and=> (thread-prim owner) threads:thread-exited?) + 'abandoned + owner) (if (> (threads:mutex-level prim) 0) 'not-owned 'not-abandoned)))) (define (abandon-mutex! mutex) #t) -(define (mutex-lock! mutex . args) +(define* (mutex-lock! mutex #:optional timeout (thread (current-thread))) (let ((mutexes (thread-mutexes))) (when mutexes (hashq-set! mutexes mutex #t))) (with-exception-handlers-here (lambda () (catch 'abandoned-mutex-error - (lambda () (apply threads:lock-mutex (mutex-prim mutex) args)) + (lambda () + (cond + ((threads:lock-mutex (mutex-prim mutex) timeout) + (set-mutex-owner! mutex thread) + #t) + (else #f))) (lambda (key . args) + (set-mutex-owner! mutex thread) (srfi-34:raise (condition (&abandoned-mutex-exception)))))))) (define mutex-unlock! (case-lambda ((mutex) - (threads:unlock-mutex (mutex-prim mutex))) + (set-mutex-owner! mutex #f) + (threads:unlock-mutex (mutex-prim mutex)) + #t) ((mutex cond) + (set-mutex-owner! mutex #f) (threads:unlock-mutex (mutex-prim mutex) (condition-variable-prim cond))) ((mutex cond timeout) + (set-mutex-owner! mutex #f) (threads:unlock-mutex (mutex-prim mutex) (condition-variable-prim cond) timeout)))) From ecfa0b50cec560ecd960d602d99b7443b07dffc2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 4 Nov 2016 23:32:26 +0100 Subject: [PATCH 580/865] Remove lock-mutex owner facility * libguile/threads.c (scm_lock_mutex_timed): Deprecate "owner" argument. (fat_mutex_lock): Remove owner argument. (fat_mutex_unlock): Don't pass owner to scm_lock_mutex_timed. * test-suite/tests/threads.test: Remove tests of mutex-owner. --- libguile/threads.c | 13 ++++++++----- test-suite/tests/threads.test | 13 +------------ 2 files changed, 9 insertions(+), 17 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index 022534808..79d0f8134 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -27,6 +27,7 @@ #include "libguile/bdw-gc.h" #include #include "libguile/_scm.h" +#include "libguile/deprecation.h" #include #include @@ -1165,11 +1166,11 @@ SCM_DEFINE (scm_make_recursive_mutex, "make-recursive-mutex", 0, 0, 0, SCM_SYMBOL (scm_abandoned_mutex_error_key, "abandoned-mutex-error"); static SCM -fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, SCM owner, int *ret) +fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, int *ret) { fat_mutex *m = SCM_MUTEX_DATA (mutex); - SCM new_owner = SCM_UNBNDP (owner) ? scm_current_thread() : owner; + SCM new_owner = scm_current_thread(); SCM err = SCM_BOOL_F; struct timeval current_time; @@ -1281,9 +1282,11 @@ SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 2, 0, } if (!SCM_UNBNDP (owner) && !scm_is_false (owner)) - SCM_VALIDATE_THREAD (3, owner); + scm_c_issue_deprecation_warning + ("The 'owner' argument to lock-mutex is deprecated. Use SRFI-18 " + "directly if you need this concept."); - exception = fat_mutex_lock (m, waittime, owner, &ret); + exception = fat_mutex_lock (m, waittime, &ret); if (!scm_is_false (exception)) scm_ithrow (SCM_CAR (exception), scm_list_1 (SCM_CDR (exception)), 1); return ret ? SCM_BOOL_T : SCM_BOOL_F; @@ -1418,7 +1421,7 @@ fat_mutex_unlock (SCM mutex, SCM cond, if (brk) { if (relock) - scm_lock_mutex_timed (mutex, SCM_UNDEFINED, owner); + scm_lock_mutex_timed (mutex, SCM_UNDEFINED, SCM_UNDEFINED); t->block_asyncs--; break; } diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test index f489d5958..ee6a505f9 100644 --- a/test-suite/tests/threads.test +++ b/test-suite/tests/threads.test @@ -382,18 +382,7 @@ (let ((m (make-mutex))) (not (mutex-owner m)))) - (pass-if "locking mutex on behalf of other thread" - (let* ((m (make-mutex)) - (t (begin-thread 'foo))) - (lock-mutex m #f t) - (eq? (mutex-owner m) t))) - - (pass-if "locking mutex with no owner" - (let ((m (make-mutex))) - (lock-mutex m #f #f) - (not (mutex-owner m)))) - - (pass-if "mutex with owner not retained (bug #27450)" + (pass-if "mutex with owner not retained (bug #27450)" (let ((g (make-guardian))) (g (let ((m (make-mutex))) (lock-mutex m) m)) From c6a8092b3f0fd3511a540174a1b7f1b46234118b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 5 Nov 2016 00:13:55 +0100 Subject: [PATCH 581/865] SRFI-18 manages own mutex "abandoned" state * module/srfi/srfi-18.scm (, with-thread-mutex-cleanup) (make-mutex, mutex-state, abandon-mutex!, mutex-lock!): Manage "abandoned" bit on Scheme side with no need for thread cleanup handler. --- module/srfi/srfi-18.scm | 41 ++++++++++++++++++++--------------------- 1 file changed, 20 insertions(+), 21 deletions(-) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index d3a6a0909..a19d5ba63 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -112,12 +112,13 @@ (reason uncaught-exception-reason)) (define-record-type - (%make-mutex prim name specific owner) + (%make-mutex prim name specific owner abandoned?) mutex? (prim mutex-prim) (name mutex-name) (specific mutex-specific mutex-specific-set!) - (owner mutex-owner set-mutex-owner!)) + (owner mutex-owner set-mutex-owner!) + (abandoned? mutex-abandoned? set-mutex-abandoned?!)) (define-record-type (%make-condition-variable prim name specific) @@ -179,7 +180,7 @@ (lambda () (let ((thread (current-thread))) (hash-for-each (lambda (mutex _) - (when (eq? (mutex-state mutex) thread) + (when (eq? (mutex-owner mutex) thread) (abandon-mutex! mutex))) mutexes)))))) @@ -293,19 +294,19 @@ 'recursive) name #f + #f #f)) (define (mutex-state mutex) - (let* ((prim (mutex-prim mutex)) - (owner (mutex-owner mutex))) - (if owner - (if (and=> (thread-prim owner) threads:thread-exited?) - 'abandoned - owner) - (if (> (threads:mutex-level prim) 0) 'not-owned 'not-abandoned)))) + (cond + ((mutex-abandoned? mutex) 'abandoned) + ((mutex-owner mutex)) + ((> (threads:mutex-level (mutex-prim mutex)) 0) 'not-owned) + (else 'not-abandoned))) (define (abandon-mutex! mutex) - #t) + (set-mutex-abandoned?! mutex #t) + (threads:unlock-mutex (mutex-prim mutex))) (define* (mutex-lock! mutex #:optional timeout (thread (current-thread))) (let ((mutexes (thread-mutexes))) @@ -313,17 +314,15 @@ (hashq-set! mutexes mutex #t))) (with-exception-handlers-here (lambda () - (catch 'abandoned-mutex-error - (lambda () - (cond - ((threads:lock-mutex (mutex-prim mutex) timeout) - (set-mutex-owner! mutex thread) - #t) - (else #f))) - (lambda (key . args) - (set-mutex-owner! mutex thread) + (cond + ((threads:lock-mutex (mutex-prim mutex) timeout) + (set-mutex-owner! mutex thread) + (when (mutex-abandoned? mutex) + (set-mutex-abandoned?! mutex #f) (srfi-34:raise - (condition (&abandoned-mutex-exception)))))))) + (condition (&abandoned-mutex-exception)))) + #t) + (else #f))))) (define mutex-unlock! (case-lambda From 857aa581a245f49946baa9b5ce25ab3fdb2f15af Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 5 Nov 2016 00:20:39 +0100 Subject: [PATCH 582/865] Remove thread-local weak mutex set * libguile/threads.h (scm_i_thread): * libguile/threads.c (guilify_self_1, do_thread_exit, fat_mutex_lock): Remove thread-local weak mutex set. --- libguile/threads.c | 76 +++------------------------------------------- libguile/threads.h | 1 - 2 files changed, 4 insertions(+), 73 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index 79d0f8134..76abe356d 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -411,7 +411,6 @@ guilify_self_1 (struct GC_stack_base *base) t.pthread = scm_i_pthread_self (); t.handle = SCM_BOOL_F; t.result = SCM_BOOL_F; - t.mutexes = SCM_EOL; t.held_mutex = NULL; t.join_queue = SCM_EOL; t.freelists = NULL; @@ -543,28 +542,6 @@ do_thread_exit (void *v) while (scm_is_true (unblock_from_queue (t->join_queue))) ; - while (!scm_is_null (t->mutexes)) - { - SCM mutex = scm_c_weak_vector_ref (scm_car (t->mutexes), 0); - - if (scm_is_true (mutex)) - { - fat_mutex *m = SCM_MUTEX_DATA (mutex); - - scm_i_pthread_mutex_lock (&m->lock); - - /* Check whether T owns MUTEX. This is usually the case, unless - T abandoned MUTEX; in that case, T is no longer its owner (see - `fat_mutex_lock') but MUTEX is still in `t->mutexes'. */ - if (scm_is_eq (m->owner, t->handle)) - unblock_from_queue (m->waiting); - - scm_i_pthread_mutex_unlock (&m->lock); - } - - t->mutexes = scm_cdr (t->mutexes); - } - scm_i_pthread_mutex_unlock (&t->admin_mutex); return NULL; @@ -1183,26 +1160,6 @@ fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, int *ret) { m->owner = new_owner; m->level++; - - if (SCM_I_IS_THREAD (new_owner)) - { - scm_i_thread *t = SCM_I_THREAD_DATA (new_owner); - - /* FIXME: The order in which `t->admin_mutex' and - `m->lock' are taken differs from that in - `on_thread_exit', potentially leading to deadlocks. */ - scm_i_pthread_mutex_lock (&t->admin_mutex); - - /* Only keep a weak reference to MUTEX so that it's not - retained when not referenced elsewhere (bug #27450). - The weak pair itself is eventually removed when MUTEX - is unlocked. Note that `t->mutexes' lists mutexes - currently held by T, so it should be small. */ - t->mutexes = scm_cons (scm_make_weak_vector (SCM_INUM1, mutex), - t->mutexes); - - scm_i_pthread_mutex_unlock (&t->admin_mutex); - } *ret = 1; break; } @@ -1330,25 +1287,6 @@ typedef struct { #define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x) #define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x)) -static void -remove_mutex_from_thread (SCM mutex, scm_i_thread *t) -{ - SCM walk, prev; - - for (prev = SCM_BOOL_F, walk = t->mutexes; scm_is_pair (walk); - walk = SCM_CDR (walk)) - { - if (scm_is_eq (mutex, scm_c_weak_vector_ref (SCM_CAR (walk), 0))) - { - if (scm_is_pair (prev)) - SCM_SETCDR (prev, SCM_CDR (walk)); - else - t->mutexes = SCM_CDR (walk); - break; - } - } -} - static int fat_mutex_unlock (SCM mutex, SCM cond, const scm_t_timespec *waittime, int relock) @@ -1391,11 +1329,8 @@ fat_mutex_unlock (SCM mutex, SCM cond, if (m->level > 0) m->level--; if (m->level == 0) - { - /* Change the owner of MUTEX. */ - remove_mutex_from_thread (mutex, t); - m->owner = unblock_from_queue (m->waiting); - } + /* Change the owner of MUTEX. */ + m->owner = unblock_from_queue (m->waiting); t->block_asyncs++; @@ -1439,11 +1374,8 @@ fat_mutex_unlock (SCM mutex, SCM cond, if (m->level > 0) m->level--; if (m->level == 0) - { - /* Change the owner of MUTEX. */ - remove_mutex_from_thread (mutex, t); - m->owner = unblock_from_queue (m->waiting); - } + /* Change the owner of MUTEX. */ + m->owner = unblock_from_queue (m->waiting); scm_i_pthread_mutex_unlock (&m->lock); ret = 1; diff --git a/libguile/threads.h b/libguile/threads.h index f6165a558..e88a7e5c1 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -63,7 +63,6 @@ typedef struct scm_i_thread { SCM join_queue; scm_i_pthread_mutex_t admin_mutex; - SCM mutexes; scm_i_pthread_mutex_t *held_mutex; SCM result; From a3d0a7da4d2a78a7bddbac7a93648835d8419e8f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 5 Nov 2016 00:22:15 +0100 Subject: [PATCH 583/865] Remove thread held pthread_mutex field * libguile/threads.h (scm_i_thread): * libguile/threads.c (guilify_self_1, on_thread_exit) (scm_pthread_cond_wait, scm_pthread_cond_timedwait): The thread-local held_mutex field is no longer needed, now that we cancel threads via interrupts instead of pthread_cancel. --- libguile/threads.c | 27 ++------------------------- libguile/threads.h | 1 - 2 files changed, 2 insertions(+), 26 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index 76abe356d..d15c4e76e 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -411,7 +411,6 @@ guilify_self_1 (struct GC_stack_base *base) t.pthread = scm_i_pthread_self (); t.handle = SCM_BOOL_F; t.result = SCM_BOOL_F; - t.held_mutex = NULL; t.join_queue = SCM_EOL; t.freelists = NULL; t.pointerless_freelists = NULL; @@ -568,14 +567,6 @@ on_thread_exit (void *v) it here. */ t->guile_mode = 0; - /* If this thread was cancelled while doing a cond wait, it will - still have a mutex locked, so we unlock it here. */ - if (t->held_mutex) - { - scm_i_pthread_mutex_unlock (t->held_mutex); - t->held_mutex = NULL; - } - /* Reinstate the current thread for purposes of scm_with_guile guile-mode cleanup handlers. Only really needed in the non-TLS case but it doesn't hurt to be consistent. */ @@ -1688,14 +1679,7 @@ scm_dynwind_pthread_mutex_lock (scm_i_pthread_mutex_t *mutex) int scm_pthread_cond_wait (scm_i_pthread_cond_t *cond, scm_i_pthread_mutex_t *mutex) { - int res; - scm_i_thread *t = SCM_I_CURRENT_THREAD; - - t->held_mutex = mutex; - res = scm_i_pthread_cond_wait (cond, mutex); - t->held_mutex = NULL; - - return res; + return scm_i_pthread_cond_wait (cond, mutex); } int @@ -1703,14 +1687,7 @@ scm_pthread_cond_timedwait (scm_i_pthread_cond_t *cond, scm_i_pthread_mutex_t *mutex, const scm_t_timespec *wt) { - int res; - scm_i_thread *t = SCM_I_CURRENT_THREAD; - - t->held_mutex = mutex; - res = scm_i_pthread_cond_timedwait (cond, mutex, wt); - t->held_mutex = NULL; - - return res; + return scm_i_pthread_cond_timedwait (cond, mutex, wt); } #endif diff --git a/libguile/threads.h b/libguile/threads.h index e88a7e5c1..0aef61d22 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -63,7 +63,6 @@ typedef struct scm_i_thread { SCM join_queue; scm_i_pthread_mutex_t admin_mutex; - scm_i_pthread_mutex_t *held_mutex; SCM result; int exited; From f1b7eaaa1a78f2a0b1be1f35ec583349322db02e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 5 Nov 2016 00:26:29 +0100 Subject: [PATCH 584/865] Remove fat mutex abandoned mutex error * libguile/threads.c (fat_mutex_lock): Remove abandoned mutex error, as SRFI-18 is responsible for this. * test-suite/tests/threads.test: Update test. --- libguile/threads.c | 11 ----------- test-suite/tests/threads.test | 13 ++++--------- 2 files changed, 4 insertions(+), 20 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index d15c4e76e..6263519a0 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1131,8 +1131,6 @@ SCM_DEFINE (scm_make_recursive_mutex, "make-recursive-mutex", 0, 0, 0, } #undef FUNC_NAME -SCM_SYMBOL (scm_abandoned_mutex_error_key, "abandoned-mutex-error"); - static SCM fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, int *ret) { @@ -1154,15 +1152,6 @@ fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, int *ret) *ret = 1; break; } - else if (SCM_I_IS_THREAD (m->owner) && scm_c_thread_exited_p (m->owner)) - { - m->owner = new_owner; - err = scm_cons (scm_abandoned_mutex_error_key, - scm_from_locale_string ("lock obtained on abandoned " - "mutex")); - *ret = 1; - break; - } else if (scm_is_eq (m->owner, new_owner)) { if (m->recursive) diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test index ee6a505f9..2156f61fc 100644 --- a/test-suite/tests/threads.test +++ b/test-suite/tests/threads.test @@ -436,15 +436,10 @@ (lock-mutex m) (lock-mutex m))) - (pass-if "locking abandoned mutex throws exception" - (let* ((m (make-mutex)) - (t (begin-thread (lock-mutex m))) - (success #f)) - (join-thread t) - (catch 'abandoned-mutex-error - (lambda () (lock-mutex m)) - (lambda key (set! success #t))) - success))))) + (pass-if "abandoned mutexes are dead" + (let* ((m (make-mutex))) + (join-thread (begin-thread (lock-mutex m))) + (not (lock-mutex m (+ (current-time) 0.1)))))))) ;; From b197a6a5afcb9a96a820005099bb226a2c760210 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 5 Nov 2016 09:27:30 +0100 Subject: [PATCH 585/865] Move more functionality to SRFI-18 mutex-unlock! * module/srfi/srfi-18.scm (mutex-unlock!): Implement the ignore-unlock-errors and wait-condition-variable behavior of mutex-unlock! directly, without relying on Guile. --- module/srfi/srfi-18.scm | 32 +++++++++++++++++--------------- 1 file changed, 17 insertions(+), 15 deletions(-) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index a19d5ba63..85ca91efb 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -324,21 +324,23 @@ #t) (else #f))))) -(define mutex-unlock! - (case-lambda - ((mutex) - (set-mutex-owner! mutex #f) - (threads:unlock-mutex (mutex-prim mutex)) - #t) - ((mutex cond) - (set-mutex-owner! mutex #f) - (threads:unlock-mutex (mutex-prim mutex) - (condition-variable-prim cond))) - ((mutex cond timeout) - (set-mutex-owner! mutex #f) - (threads:unlock-mutex (mutex-prim mutex) - (condition-variable-prim cond) - timeout)))) +(define %unlock-sentinel (list 'unlock)) +(define* (mutex-unlock! mutex #:optional (cond-var %unlock-sentinel) + (timeout %unlock-sentinel)) + (when (mutex-owner mutex) + (set-mutex-owner! mutex #f) + (cond + ((eq? cond-var %unlock-sentinel) + (threads:unlock-mutex (mutex-prim mutex))) + ((eq? timeout %unlock-sentinel) + (threads:wait-condition-variable (condition-variable-prim cond-var) + (mutex-prim mutex)) + (threads:unlock-mutex (mutex-prim mutex))) + ((threads:wait-condition-variable (condition-variable-prim cond-var) + (mutex-prim mutex) + timeout) + (threads:unlock-mutex (mutex-prim mutex))) + (else #f)))) ;; CONDITION VARIABLES ;; These functions are all pass-thrus to the existing Guile implementations. From b43f11469a859324d74fd9b7142b0f86e2f05d16 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 5 Nov 2016 09:40:43 +0100 Subject: [PATCH 586/865] SRFI-18 mutexes are not recursive * module/srfi/srfi-18.scm (make-mutex): Not recursive. --- module/srfi/srfi-18.scm | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 85ca91efb..4634623fe 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -286,16 +286,9 @@ (else v))))))) ;; MUTEXES -;; These functions are all pass-thrus to the existing Guile implementations. (define* (make-mutex #:optional name) - (%make-mutex (threads:make-mutex 'unchecked-unlock - 'allow-external-unlock - 'recursive) - name - #f - #f - #f)) + (%make-mutex (threads:make-mutex 'allow-external-unlock) name #f #f #f)) (define (mutex-state mutex) (cond From f1f68fffb159d390a21e98dae364b1a425e33eb4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 5 Nov 2016 10:08:01 +0100 Subject: [PATCH 587/865] Recursively locking a SRFI-18 mutex blocks * libguile/threads.c (fat_mutex_lock): allow-external-unlock mutexes can't be recursive, but a recursive lock attempt can be unblocked by an external thread, so these mutexes shouldn't throw an error on recursive lock attempts. * test-suite/tests/srfi-18.test: Add tests. --- libguile/threads.c | 2 +- test-suite/tests/srfi-18.test | 35 +++++++++++++++++++++++++++++++++++ 2 files changed, 36 insertions(+), 1 deletion(-) diff --git a/libguile/threads.c b/libguile/threads.c index 6263519a0..b62c1639a 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1152,7 +1152,7 @@ fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, int *ret) *ret = 1; break; } - else if (scm_is_eq (m->owner, new_owner)) + else if (scm_is_eq (m->owner, new_owner) && !m->allow_external_unlock) { if (m->recursive) { diff --git a/test-suite/tests/srfi-18.test b/test-suite/tests/srfi-18.test index ddd72dbab..a6e184c6f 100644 --- a/test-suite/tests/srfi-18.test +++ b/test-suite/tests/srfi-18.test @@ -302,6 +302,41 @@ (thread-join! t) (eq? (mutex-state m) 'not-abandoned))) + (pass-if "recursive lock waits" + (let* ((m (make-mutex 'mutex-unlock-2)) + (t (make-thread (lambda () + (mutex-lock! m) + (let ((now (time->seconds (current-time)))) + (mutex-lock! m (+ now 0.1))) + (mutex-unlock! m)) + 'mutex-unlock-2))) + (thread-start! t) + (thread-join! t) + (eq? (mutex-state m) 'not-abandoned))) + + (pass-if "recursive lock unblocked by second thread" + (let* ((m1 (make-mutex)) + (m2 (make-mutex)) + (c (make-condition-variable))) + (mutex-lock! m1) + (let ((t (make-thread (lambda () + (mutex-lock! m1) + (mutex-lock! m2) + (condition-variable-signal! c) + (mutex-unlock! m1) + (mutex-lock! m2) + (mutex-unlock! m2))))) + (thread-start! t) + (mutex-unlock! m1 c) + ;; At this point the thread signalled that it has both m1 and + ;; m2, and it will go to try to lock m2 again. We wait for it + ;; to block trying to acquire m2 by sleeping a little bit and + ;; then unblock it by unlocking m2 from here. + (usleep #e1e5) + (mutex-unlock! m2) + (thread-join! t) + (eq? (mutex-state m2) 'not-abandoned)))) + (pass-if "mutex unlock is true when condition is signalled" (let* ((m (make-mutex 'mutex-unlock-3)) (c (make-condition-variable 'mutex-unlock-3)) From c0916134ac052282ebd4353f2b9894e002cb4308 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 5 Nov 2016 10:13:48 +0100 Subject: [PATCH 588/865] Remove unchecked-unlock facility from Guile mutexes * libguile/threads.c (fat_mutex): Remove unchecked_unlock member. (make_fat_mutex): Adapt. (scm_make_mutex_with_flags): Remove unchecked-unlock flag. (scm_make_recursive_mutex): Likewise. (fat_mutex_unlock): Remove unchecked-unlock case. * test-suite/tests/threads.test: Remove unchecked-unlock test. --- libguile/threads.c | 23 +++++++---------------- test-suite/tests/threads.test | 6 +----- 2 files changed, 8 insertions(+), 21 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index b62c1639a..9d9b01a5e 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -516,7 +516,6 @@ typedef struct { int level; /* how much the owner owns us. <= 1 for non-recursive mutexes */ int recursive; /* allow recursive locking? */ - int unchecked_unlock; /* is it an error to unlock an unlocked mutex? */ int allow_external_unlock; /* is it an error to unlock a mutex that is not owned by the current thread? */ @@ -1065,7 +1064,7 @@ fat_mutex_print (SCM mx, SCM port, scm_print_state *pstate SCM_UNUSED) } static SCM -make_fat_mutex (int recursive, int unchecked_unlock, int external_unlock) +make_fat_mutex (int recursive, int external_unlock) { fat_mutex *m; SCM mx; @@ -1079,7 +1078,6 @@ make_fat_mutex (int recursive, int unchecked_unlock, int external_unlock) m->level = 0; m->recursive = recursive; - m->unchecked_unlock = unchecked_unlock; m->allow_external_unlock = external_unlock; m->waiting = SCM_EOL; @@ -1093,7 +1091,6 @@ SCM scm_make_mutex (void) return scm_make_mutex_with_flags (SCM_EOL); } -SCM_SYMBOL (unchecked_unlock_sym, "unchecked-unlock"); SCM_SYMBOL (allow_external_unlock_sym, "allow-external-unlock"); SCM_SYMBOL (recursive_sym, "recursive"); @@ -1102,15 +1099,13 @@ SCM_DEFINE (scm_make_mutex_with_flags, "make-mutex", 0, 0, 1, "Create a new mutex. ") #define FUNC_NAME s_scm_make_mutex_with_flags { - int unchecked_unlock = 0, external_unlock = 0, recursive = 0; + int external_unlock = 0, recursive = 0; SCM ptr = flags; while (! scm_is_null (ptr)) { SCM flag = SCM_CAR (ptr); - if (scm_is_eq (flag, unchecked_unlock_sym)) - unchecked_unlock = 1; - else if (scm_is_eq (flag, allow_external_unlock_sym)) + if (scm_is_eq (flag, allow_external_unlock_sym)) external_unlock = 1; else if (scm_is_eq (flag, recursive_sym)) recursive = 1; @@ -1118,7 +1113,7 @@ SCM_DEFINE (scm_make_mutex_with_flags, "make-mutex", 0, 0, 1, SCM_MISC_ERROR ("unsupported mutex option: ~a", scm_list_1 (flag)); ptr = SCM_CDR (ptr); } - return make_fat_mutex (recursive, unchecked_unlock, external_unlock); + return make_fat_mutex (recursive, external_unlock); } #undef FUNC_NAME @@ -1127,7 +1122,7 @@ SCM_DEFINE (scm_make_recursive_mutex, "make-recursive-mutex", 0, 0, 0, "Create a new recursive mutex. ") #define FUNC_NAME s_scm_make_recursive_mutex { - return make_fat_mutex (1, 0, 0); + return make_fat_mutex (1, 0); } #undef FUNC_NAME @@ -1285,12 +1280,8 @@ fat_mutex_unlock (SCM mutex, SCM cond, { if (m->level == 0) { - if (!m->unchecked_unlock) - { - scm_i_pthread_mutex_unlock (&m->lock); - scm_misc_error (NULL, "mutex not locked", SCM_EOL); - } - owner = t->handle; + scm_i_pthread_mutex_unlock (&m->lock); + scm_misc_error (NULL, "mutex not locked", SCM_EOL); } else if (!m->allow_external_unlock) { diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test index 2156f61fc..4b6aa2ad7 100644 --- a/test-suite/tests/threads.test +++ b/test-suite/tests/threads.test @@ -421,11 +421,7 @@ (with-test-prefix "mutex-behavior" - (pass-if "unchecked unlock" - (let* ((m (make-mutex 'unchecked-unlock))) - (unlock-mutex m))) - - (pass-if "allow external unlock" + (pass-if "allow external unlock" (let* ((m (make-mutex 'allow-external-unlock)) (t (begin-thread (lock-mutex m)))) (join-thread t) From 768246124164243059b0eeb772d3bb5bf1db0db9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 5 Nov 2016 11:14:17 +0100 Subject: [PATCH 589/865] Replace scm_make_mutex_with_flags * libguile/threads.c (enum fat_mutex_kind): New data type, replacing separate flags. (struct fat_mutex): Adapt. (make_fat_mutex): Fat mutexes can only be one of three kinds, not one of 4 kinds. (Recursive unowned mutexes are not a thing.) (scm_make_mutex): Adapt. (scm_make_mutex_with_kind): New function, replacing scm_make_mutex_with_flags. Still bound to make-mutex. (scm_make_recursive_mutex): Adapt. (fat_mutex_lock, fat_mutex_unlock): Adapt. * libguile/threads.h (scm_make_mutex_with_kind): New decl. * libguile/deprecated.h: * libguile/deprecated.c (scm_make_mutex_with_flags): Deprecate. --- libguile/deprecated.c | 22 +++++++++++++ libguile/deprecated.h | 4 +++ libguile/threads.c | 75 ++++++++++++++++++++++++++----------------- libguile/threads.h | 2 +- 4 files changed, 72 insertions(+), 31 deletions(-) diff --git a/libguile/deprecated.c b/libguile/deprecated.c index c8d353f89..fd671e9e5 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -678,6 +678,28 @@ scm_dynwind_critical_section (SCM mutex) } + + +SCM +scm_make_mutex_with_flags (SCM flags) +{ + SCM kind = SCM_UNDEFINED; + + scm_c_issue_deprecation_warning + ("'scm_make_mutex_with_flags' is deprecated. " + "Use 'scm_make_mutex_with_kind' instead."); + + if (!scm_is_null (flags)) + { + if (!scm_is_null (scm_cdr (flags))) + scm_misc_error (NULL, "too many mutex options: ~a", scm_list_1 (flags)); + kind = scm_car (flags); + } + + return scm_make_mutex_with_kind (kind); +} + + void diff --git a/libguile/deprecated.h b/libguile/deprecated.h index d8ce8166f..d20ff5b5d 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -238,6 +238,10 @@ SCM_DEPRECATED void scm_dynwind_critical_section (SCM mutex); +SCM_DEPRECATED SCM scm_make_mutex_with_flags (SCM flags); + + + void scm_i_init_deprecated (void); #endif diff --git a/libguile/threads.c b/libguile/threads.c index 9d9b01a5e..d44d3b19e 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -510,15 +510,31 @@ guilify_self_2 (SCM parent) debugging. */ +enum fat_mutex_kind { + /* A standard mutex can only be locked once. If you try to lock it + again from the thread that locked it to begin with (the "owner" + thread), it throws an error. It can only be unlocked from the + thread that locked it in the first place. */ + FAT_MUTEX_STANDARD, + /* A recursive mutex can be locked multiple times by its owner. It + then has to be unlocked the corresponding number of times, and like + standard mutexes can only be unlocked by the owner thread. */ + FAT_MUTEX_RECURSIVE, + /* An unowned mutex is like a standard mutex, except that it can be + unlocked by any thread. A corrolary of this behavior is that a + thread's attempt to lock a mutex that it already owns will block + instead of signalling an error, as it could be that some other + thread unlocks the mutex, allowing the owner thread to proceed. + This kind of mutex is a bit strange and is here for use by + SRFI-18. */ + FAT_MUTEX_UNOWNED +}; + typedef struct { scm_i_pthread_mutex_t lock; SCM owner; int level; /* how much the owner owns us. <= 1 for non-recursive mutexes */ - - int recursive; /* allow recursive locking? */ - int allow_external_unlock; /* is it an error to unlock a mutex that is not - owned by the current thread? */ - + enum fat_mutex_kind kind; SCM waiting; /* the threads waiting for this mutex. */ } fat_mutex; @@ -1064,7 +1080,7 @@ fat_mutex_print (SCM mx, SCM port, scm_print_state *pstate SCM_UNUSED) } static SCM -make_fat_mutex (int recursive, int external_unlock) +make_fat_mutex (enum fat_mutex_kind kind) { fat_mutex *m; SCM mx; @@ -1076,10 +1092,7 @@ make_fat_mutex (int recursive, int external_unlock) memcpy (&m->lock, &lock, sizeof (m->lock)); m->owner = SCM_BOOL_F; m->level = 0; - - m->recursive = recursive; - m->allow_external_unlock = external_unlock; - + m->kind = kind; m->waiting = SCM_EOL; SCM_NEWSMOB (mx, scm_tc16_mutex, (scm_t_bits) m); m->waiting = make_queue (); @@ -1088,32 +1101,34 @@ make_fat_mutex (int recursive, int external_unlock) SCM scm_make_mutex (void) { - return scm_make_mutex_with_flags (SCM_EOL); + return scm_make_mutex_with_kind (SCM_UNDEFINED); } SCM_SYMBOL (allow_external_unlock_sym, "allow-external-unlock"); SCM_SYMBOL (recursive_sym, "recursive"); -SCM_DEFINE (scm_make_mutex_with_flags, "make-mutex", 0, 0, 1, - (SCM flags), - "Create a new mutex. ") -#define FUNC_NAME s_scm_make_mutex_with_flags +SCM_DEFINE (scm_make_mutex_with_kind, "make-mutex", 0, 1, 0, + (SCM kind), + "Create a new mutex. If @var{kind} is not given, the mutex\n" + "will be a standard non-recursive mutex. Otherwise pass\n" + "@code{recursive} to make a recursive mutex, or\n" + "@code{allow-external-unlock} to make a non-recursive mutex\n" + "that can be unlocked from any thread.") +#define FUNC_NAME s_scm_make_mutex_with_kind { - int external_unlock = 0, recursive = 0; + enum fat_mutex_kind mkind = FAT_MUTEX_STANDARD; - SCM ptr = flags; - while (! scm_is_null (ptr)) + if (!SCM_UNBNDP (kind)) { - SCM flag = SCM_CAR (ptr); - if (scm_is_eq (flag, allow_external_unlock_sym)) - external_unlock = 1; - else if (scm_is_eq (flag, recursive_sym)) - recursive = 1; + if (scm_is_eq (kind, allow_external_unlock_sym)) + mkind = FAT_MUTEX_UNOWNED; + else if (scm_is_eq (kind, recursive_sym)) + mkind = FAT_MUTEX_RECURSIVE; else - SCM_MISC_ERROR ("unsupported mutex option: ~a", scm_list_1 (flag)); - ptr = SCM_CDR (ptr); + SCM_MISC_ERROR ("unsupported mutex kind: ~a", scm_list_1 (kind)); } - return make_fat_mutex (recursive, external_unlock); + + return make_fat_mutex (mkind); } #undef FUNC_NAME @@ -1122,7 +1137,7 @@ SCM_DEFINE (scm_make_recursive_mutex, "make-recursive-mutex", 0, 0, 0, "Create a new recursive mutex. ") #define FUNC_NAME s_scm_make_recursive_mutex { - return make_fat_mutex (1, 0); + return scm_make_mutex_with_kind (recursive_sym); } #undef FUNC_NAME @@ -1147,9 +1162,9 @@ fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, int *ret) *ret = 1; break; } - else if (scm_is_eq (m->owner, new_owner) && !m->allow_external_unlock) + else if (scm_is_eq (m->owner, new_owner) && m->kind != FAT_MUTEX_UNOWNED) { - if (m->recursive) + if (m->kind == FAT_MUTEX_RECURSIVE) { m->level++; *ret = 1; @@ -1283,7 +1298,7 @@ fat_mutex_unlock (SCM mutex, SCM cond, scm_i_pthread_mutex_unlock (&m->lock); scm_misc_error (NULL, "mutex not locked", SCM_EOL); } - else if (!m->allow_external_unlock) + else if (m->kind != FAT_MUTEX_UNOWNED) { scm_i_pthread_mutex_unlock (&m->lock); scm_misc_error (NULL, "mutex not locked by current thread", SCM_EOL); diff --git a/libguile/threads.h b/libguile/threads.h index 0aef61d22..821d27cda 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -150,7 +150,7 @@ SCM_API SCM scm_thread_p (SCM t); SCM_API SCM scm_make_mutex (void); SCM_API SCM scm_make_recursive_mutex (void); -SCM_API SCM scm_make_mutex_with_flags (SCM flags); +SCM_API SCM scm_make_mutex_with_kind (SCM kind); SCM_API SCM scm_lock_mutex (SCM m); SCM_API SCM scm_lock_mutex_timed (SCM m, SCM timeout, SCM owner); SCM_API void scm_dynwind_lock_mutex (SCM mutex); From 56dd476af7653b0c147c3416fd78e79f04ab44b1 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 5 Nov 2016 11:33:20 +0100 Subject: [PATCH 590/865] Back to simple unlock-mutex * libguile/threads.c (scm_unlock_mutex): Bind to unlock-mutex. * libguile/threads.h: Remove scm_unlock_mutex_timed. * libguile/deprecated.h: Add scm_unlock_mutex_timed. * libguile/deprecated.c (scm_unlock_mutex_timed): Deprecate. * test-suite/tests/threads.test: Update unlock-mutex tests to use wait-condition-variable if they would wait on a cond. --- libguile/deprecated.c | 15 +++++++++++++++ libguile/deprecated.h | 1 + libguile/threads.c | 35 +++++++---------------------------- libguile/threads.h | 1 - test-suite/tests/threads.test | 16 +++++++--------- 5 files changed, 30 insertions(+), 38 deletions(-) diff --git a/libguile/deprecated.c b/libguile/deprecated.c index fd671e9e5..d2e01f3b7 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -699,6 +699,21 @@ scm_make_mutex_with_flags (SCM flags) return scm_make_mutex_with_kind (kind); } +SCM +scm_unlock_mutex_timed (SCM mx, SCM cond, SCM timeout) +{ + scm_c_issue_deprecation_warning + ("'scm_unlock_mutex_timed' is deprecated. " + "Use just plain old 'scm_unlock_mutex' instead, or otherwise " + "'scm_wait_condition_variable' if you need to."); + + if (!SCM_UNBNDP (cond) && + scm_is_false (scm_timed_wait_condition_variable (cond, mx, timeout))) + return SCM_BOOL_F; + + return scm_unlock_mutex (mx); +} + diff --git a/libguile/deprecated.h b/libguile/deprecated.h index d20ff5b5d..5948fc512 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -239,6 +239,7 @@ SCM_DEPRECATED void scm_dynwind_critical_section (SCM mutex); SCM_DEPRECATED SCM scm_make_mutex_with_flags (SCM flags); +SCM_DEPRECATED SCM scm_unlock_mutex_timed (SCM mx, SCM cond, SCM timeout); diff --git a/libguile/threads.c b/libguile/threads.c index d44d3b19e..5497eb057 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1370,37 +1370,16 @@ fat_mutex_unlock (SCM mutex, SCM cond, return ret; } -SCM scm_unlock_mutex (SCM mx) +SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0, (SCM mx), + "Unlocks @var{mutex}. The calling thread must already hold\n" + "the lock on @var{mutex}, unless the mutex was created with\n" + "the @code{allow-external-unlock} option; otherwise an error\n" + "will be signalled.") +#define FUNC_NAME s_scm_unlock_mutex { - return scm_unlock_mutex_timed (mx, SCM_UNDEFINED, SCM_UNDEFINED); -} - -SCM_DEFINE (scm_unlock_mutex_timed, "unlock-mutex", 1, 2, 0, - (SCM mx, SCM cond, SCM timeout), -"Unlocks @var{mutex} if the calling thread owns the lock on " -"@var{mutex}. Calling unlock-mutex on a mutex not owned by the current " -"thread results in undefined behaviour. Once a mutex has been unlocked, " -"one thread blocked on @var{mutex} is awakened and grabs the mutex " -"lock. Every call to @code{lock-mutex} by this thread must be matched " -"with a call to @code{unlock-mutex}. Only the last call to " -"@code{unlock-mutex} will actually unlock the mutex. ") -#define FUNC_NAME s_scm_unlock_mutex_timed -{ - scm_t_timespec cwaittime, *waittime = NULL; - SCM_VALIDATE_MUTEX (1, mx); - if (! (SCM_UNBNDP (cond))) - { - SCM_VALIDATE_CONDVAR (2, cond); - if (! SCM_UNBNDP (timeout) && ! scm_is_false (timeout)) - { - to_timespec (timeout, &cwaittime); - waittime = &cwaittime; - } - } - - return fat_mutex_unlock (mx, cond, waittime, 0) ? SCM_BOOL_T : SCM_BOOL_F; + return scm_from_bool (fat_mutex_unlock (mx, SCM_UNDEFINED, NULL, 0)); } #undef FUNC_NAME diff --git a/libguile/threads.h b/libguile/threads.h index 821d27cda..1da7bbf4a 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -156,7 +156,6 @@ SCM_API SCM scm_lock_mutex_timed (SCM m, SCM timeout, SCM owner); SCM_API void scm_dynwind_lock_mutex (SCM mutex); SCM_API SCM scm_try_mutex (SCM m); SCM_API SCM scm_unlock_mutex (SCM m); -SCM_API SCM scm_unlock_mutex_timed (SCM m, SCM cond, SCM timeout); SCM_API SCM scm_mutex_p (SCM o); SCM_API SCM scm_mutex_locked_p (SCM m); SCM_API SCM scm_mutex_owner (SCM m); diff --git a/test-suite/tests/threads.test b/test-suite/tests/threads.test index 4b6aa2ad7..efdf36db2 100644 --- a/test-suite/tests/threads.test +++ b/test-suite/tests/threads.test @@ -250,7 +250,7 @@ (let ((m (make-mutex)) (c (make-condition-variable))) (lock-mutex m) - (not (unlock-mutex m c (current-time))))) + (not (wait-condition-variable c m (current-time))))) (pass-if "asyncs are still working 4" (asyncs-still-working?)) @@ -261,14 +261,12 @@ (c1 (make-condition-variable)) (c2 (make-condition-variable))) (lock-mutex m1) - (let ((t (begin-thread (begin (lock-mutex m1) - (signal-condition-variable c1) - (lock-mutex m2) - (unlock-mutex m1) - (unlock-mutex m2 - c2 - (+ (current-time) - 5)))))) + (let ((t (begin-thread + (lock-mutex m1) + (signal-condition-variable c1) + (lock-mutex m2) + (unlock-mutex m1) + (wait-condition-variable c2 m2 (+ (current-time) 5))))) (wait-condition-variable c1 m1) (unlock-mutex m1) (lock-mutex m2) From fc4df456a15a20bf3f8d381f8db9a37ab3b07d8c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 5 Nov 2016 11:51:02 +0100 Subject: [PATCH 591/865] Separate fat mutex unlock and wait operations * libguile/threads.c (fat_mutex_unlock, fat_mutex_wait): Separate wait from unlock. (scm_unlock_mutex, scm_timed_wait_condition_variable): Adapt. --- libguile/threads.c | 132 ++++++++++++++++++++++++--------------------- 1 file changed, 72 insertions(+), 60 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index 5497eb057..d7295bc9f 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1277,21 +1277,14 @@ typedef struct { #define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x) #define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x)) -static int -fat_mutex_unlock (SCM mutex, SCM cond, - const scm_t_timespec *waittime, int relock) +static void +fat_mutex_unlock (SCM mutex) { - SCM owner; fat_mutex *m = SCM_MUTEX_DATA (mutex); - fat_cond *c = NULL; - scm_i_thread *t = SCM_I_CURRENT_THREAD; - int err = 0, ret = 0; scm_i_scm_pthread_mutex_lock (&m->lock); - owner = m->owner; - - if (!scm_is_eq (owner, t->handle)) + if (!scm_is_eq (m->owner, SCM_I_CURRENT_THREAD->handle)) { if (m->level == 0) { @@ -1305,66 +1298,83 @@ fat_mutex_unlock (SCM mutex, SCM cond, } } - if (! (SCM_UNBNDP (cond))) + if (m->level > 0) + m->level--; + if (m->level == 0) + /* Change the owner of MUTEX. */ + m->owner = unblock_from_queue (m->waiting); + + scm_i_pthread_mutex_unlock (&m->lock); +} + +static int +fat_mutex_wait (SCM cond, SCM mutex, const scm_t_timespec *waittime) +{ + fat_cond *c = SCM_CONDVAR_DATA (cond); + fat_mutex *m = SCM_MUTEX_DATA (mutex); + scm_i_thread *t = SCM_I_CURRENT_THREAD; + int err = 0, ret = 0; + + scm_i_scm_pthread_mutex_lock (&m->lock); + + if (!scm_is_eq (m->owner, t->handle)) { - c = SCM_CONDVAR_DATA (cond); - while (1) + if (m->level == 0) + { + scm_i_pthread_mutex_unlock (&m->lock); + scm_misc_error (NULL, "mutex not locked", SCM_EOL); + } + else if (m->kind != FAT_MUTEX_UNOWNED) { - int brk = 0; - - if (m->level > 0) - m->level--; - if (m->level == 0) - /* Change the owner of MUTEX. */ - m->owner = unblock_from_queue (m->waiting); - - t->block_asyncs++; - - err = block_self (c->waiting, cond, &m->lock, waittime); scm_i_pthread_mutex_unlock (&m->lock); - - if (err == 0) - { - ret = 1; - brk = 1; - } - else if (err == ETIMEDOUT) - { - ret = 0; - brk = 1; - } - else if (err != EINTR) - { - errno = err; - scm_syserror (NULL); - } - - if (brk) - { - if (relock) - scm_lock_mutex_timed (mutex, SCM_UNDEFINED, SCM_UNDEFINED); - t->block_asyncs--; - break; - } - - t->block_asyncs--; - scm_async_tick (); - - scm_remember_upto_here_2 (cond, mutex); - - scm_i_scm_pthread_mutex_lock (&m->lock); + scm_misc_error (NULL, "mutex not locked by current thread", SCM_EOL); } } - else + + while (1) { + int brk = 0; + if (m->level > 0) - m->level--; + m->level--; if (m->level == 0) /* Change the owner of MUTEX. */ m->owner = unblock_from_queue (m->waiting); + t->block_asyncs++; + + err = block_self (c->waiting, cond, &m->lock, waittime); scm_i_pthread_mutex_unlock (&m->lock); - ret = 1; + + if (err == 0) + { + ret = 1; + brk = 1; + } + else if (err == ETIMEDOUT) + { + ret = 0; + brk = 1; + } + else if (err != EINTR) + { + errno = err; + scm_syserror (NULL); + } + + if (brk) + { + scm_lock_mutex (mutex); + t->block_asyncs--; + break; + } + + t->block_asyncs--; + scm_async_tick (); + + scm_remember_upto_here_2 (cond, mutex); + + scm_i_scm_pthread_mutex_lock (&m->lock); } return ret; @@ -1379,7 +1389,9 @@ SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0, (SCM mx), { SCM_VALIDATE_MUTEX (1, mx); - return scm_from_bool (fat_mutex_unlock (mx, SCM_UNDEFINED, NULL, 0)); + fat_mutex_unlock (mx); + + return SCM_BOOL_T; } #undef FUNC_NAME @@ -1480,7 +1492,7 @@ SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, waitptr = &waittime; } - return fat_mutex_unlock (mx, cv, waitptr, 1) ? SCM_BOOL_T : SCM_BOOL_F; + return scm_from_bool (fat_mutex_wait (cv, mx, waitptr)); } #undef FUNC_NAME From 8d907758a0a0d4e4a02ccb91e56ba6e42c6a747f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 5 Nov 2016 19:38:40 +0100 Subject: [PATCH 592/865] Update mutex documentation * doc/ref/api-scheduling.texi (Mutexes and Condition Variables): Add foreboding preface. --- doc/ref/api-scheduling.texi | 141 +++++++++++++++++++++++++++--------- 1 file changed, 106 insertions(+), 35 deletions(-) diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index 2fb7d15bf..9b6e44088 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -336,23 +336,105 @@ checking if the return value is @code{eq?} to @var{expected}. @cindex mutex @cindex condition variable -A mutex is a thread synchronization object, it can be used by threads -to control access to a shared resource. A mutex can be locked to -indicate a resource is in use, and other threads can then block on the -mutex to wait for the resource (or can just test and do something else -if not available). ``Mutex'' is short for ``mutual exclusion''. +Mutexes are low-level primitives used to coordinate concurrent access to +mutable data. Short for ``mutual exclusion'', the name ``mutex'' +indicates that only one thread at a time can acquire access to data that +is protected by a mutex -- threads are excluded from accessing data at +the same time. If one thread has locked a mutex, then another thread +attempting to lock that same mutex will wait until the first thread is +done. -There are two types of mutexes in Guile, ``standard'' and -``recursive''. They're created by @code{make-mutex} and -@code{make-recursive-mutex} respectively, the operation functions are -then common to both. +Mutexes can be used to build robust multi-threaded programs that take +advantage of multiple cores. However, they provide very low-level +functionality and are somewhat dangerous; usually you end up wanting to +acquire multiple mutexes at the same time to perform a multi-object +access, but this can easily lead to deadlocks if the program is not +carefully written. For example, if objects A and B are protected by +associated mutexes M and N, respectively, then to access both of them +then you need to acquire both mutexes. But what if one thread acquires +M first and then N, at the same time that another thread acquires N them +M? You can easily end up in a situation where one is waiting for the +other. -Note that for both types of mutex there's no protection against a -``deadly embrace''. For instance if one thread has locked mutex A and -is waiting on mutex B, but another thread owns B and is waiting on A, -then an endless wait will occur (in the current implementation). -Acquiring requisite mutexes in a fixed order (like always A before B) -in all threads is one way to avoid such problems. +There's no easy way around this problem on the language level. A +function A that uses mutexes does not necessarily compose nicely with a +function B that uses mutexes. For this reason we suggest using atomic +variables when you can (@pxref{Atomics}), as they do not have this problem. + +Still, if you as a programmer are responsible for a whole system, then +you can use mutexes as a primitive to provide safe concurrent +abstractions to your users. (For example, given all locks in a system, +if you establish an order such that M is consistently acquired before N, +you can avoid the ``deadly-embrace'' deadlock described above. The +problem is enumerating all mutexes and establishing this order from a +system perspective.) Guile gives you the low-level facilities to build +such systems. + +In Guile there are additional considerations beyond the usual ones in +other programming languages: non-local control flow and asynchronous +interrupts. What happens if you hold a mutex, but somehow you cause an +exception to be thrown? There is no one right answer. You might want +to keep the mutex locked to prevent any other code from ever entering +that critical section again. Or, your critical section might be fine if +you unlock the mutex ``on the way out'', via a catch handler or +@code{dynamic-wind}. @xref{Catch}, and @xref{Dynamic Wind}. + +But if you arrange to unlock the mutex when leaving a dynamic extent via +@code{dynamic-wind}, what to do if control re-enters that dynamic extent +via a continuation invocation? Surely re-entering the dynamic extent +without the lock is a bad idea, so there are two options on the table: +either prevent re-entry via @code{with-continuation-barrier} or similar, +or reacquiring the lock in the entry thunk of a @code{dynamic-wind}. + +You might think that because you don't use continuations, that you don't +have to think about this, and you might be right. If you control the +whole system, you can reason about continuation use globally. Or, if +you know all code that can be called in a dynamic extent, and none of +that code can call continuations, then you don't have to worry about +re-entry, and you might not have to worry about early exit either. + +However, do consider the possibility of asynchronous interrupts +(@pxref{Asyncs}). If the user interrupts your code interactively, that +can cause an exception; or your thread might be cancelled, which does +the same; or the user could be running your code under some pre-emptive +system that periodically causes lightweight task switching. (Guile does +not currently include such a system, but it's possible to implement as a +library.) Probably you also want to defer asynchronous interrupt +processing while you hold the mutex, and probably that also means that +you should not hold the mutex for very long. + +All of these additional Guile-specific considerations mean that from a +system perspective, you would do well to avoid these hazards if you can +by not requiring mutexes. Instead, work with immutable data that can be +shared between threads without hazards, or use persistent data +structures with atomic updates based on the atomic variable library +(@pxref{Atomics}). + +There are three types of mutexes in Guile: ``standard'', ``recursive'', +and ``unowned''. + +Calling @code{make-mutex} with no arguments makes a standard mutex. A +standard mutex can only be locked once. If you try to lock it again +from the thread that locked it to begin with (the "owner" thread), it +throws an error. It can only be unlocked from the thread that locked it +in the first place. + +Calling @code{make-mutex} with the symbol @code{recursive} as the +argument, or calling @code{make-recursive-mutex}, will give you a +recursive mutex. A recursive mutex can be locked multiple times by its +owner. It then has to be unlocked the corresponding number of times, +and like standard mutexes can only be unlocked by the owner thread. + +Finally, calling @code{make-mutex} with the symbol +@code{allow-external-unlock} creates an unowned mutex. An unowned mutex +is like a standard mutex, except that it can be unlocked by any thread. +A corrolary of this behavior is that a thread's attempt to lock a mutex +that it already owns will block instead of signalling an error, as it +could be that some other thread unlocks the mutex, allowing the owner +thread to proceed. This kind of mutex is a bit strange and is here for +use by SRFI-18. + +The mutex procedures in Guile can operate on all three kinds of mutexes. To use these facilities, load the @code{(ice-9 threads)} module. @@ -361,25 +443,14 @@ To use these facilities, load the @code{(ice-9 threads)} module. @end example @sp 1 -@deffn {Scheme Procedure} make-mutex flag @dots{} +@deffn {Scheme Procedure} make-mutex [kind] @deffnx {C Function} scm_make_mutex () -@deffnx {C Function} scm_make_mutex_with_flags (SCM flags) -Return a new mutex. It is initially unlocked. If @var{flag} @dots{} is -specified, it must be a list of symbols specifying configuration flags -for the newly-created mutex. The supported flags are: -@table @code -@item unchecked-unlock -Unless this flag is present, a call to `unlock-mutex' on the returned -mutex when it is already unlocked will cause an error to be signalled. - -@item allow-external-unlock -Allow the returned mutex to be unlocked by the calling thread even if -it was originally locked by a different thread. - -@item recursive -The returned mutex will be recursive. - -@end table +@deffnx {C Function} scm_make_mutex_with_kind (SCM kind) +Return a new mutex. It will be a standard non-recursive mutex, unless +the @code{recursive} symbol is passed as the optional @var{kind} +argument, in which case it will be recursive. It's also possible to +pass @code{unowned} for semantics tailored to SRFI-18's use case; see +above for details. @end deffn @deffn {Scheme Procedure} mutex? obj @@ -391,8 +462,8 @@ Return @code{#t} if @var{obj} is a mutex; otherwise, return @deffn {Scheme Procedure} make-recursive-mutex @deffnx {C Function} scm_make_recursive_mutex () Create a new recursive mutex. It is initially unlocked. Calling this -function is equivalent to calling `make-mutex' and specifying the -@code{recursive} flag. +function is equivalent to calling @code{make-mutex} with the +@code{recursive} kind. @end deffn @deffn {Scheme Procedure} lock-mutex mutex [timeout [owner]] From 03ffd726df81731a0b1738bf2bb4842ea730c680 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 5 Nov 2016 19:39:12 +0100 Subject: [PATCH 593/865] scm_timed_lock_mutex replaces scm_lock_mutex_timed * libguile/deprecated.h: * libguile/deprecated.c (scm_lock_mutex_timed): Deprecate. * libguile/threads.h: * libguile/threads.c (scm_timed_lock_mutex): New function. (scm_join_thread): Fix formatting. (scm_lock_mutex): Fix formatting and update to scm_timed_lock_mutex change. (scm_try_mutex): Update to scm_timed_lock_mutex. --- libguile/deprecated.c | 15 +++++++++++++++ libguile/deprecated.h | 1 + libguile/threads.c | 27 ++++++++++----------------- libguile/threads.h | 2 +- 4 files changed, 27 insertions(+), 18 deletions(-) diff --git a/libguile/deprecated.c b/libguile/deprecated.c index d2e01f3b7..6da604e42 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -699,6 +699,21 @@ scm_make_mutex_with_flags (SCM flags) return scm_make_mutex_with_kind (kind); } +SCM +scm_lock_mutex_timed (SCM m, SCM timeout, SCM owner) +{ + scm_c_issue_deprecation_warning + ("'scm_lock_mutex_timed' is deprecated. " + "Use 'scm_timed_lock_mutex' instead."); + + if (!SCM_UNBNDP (owner) && !scm_is_false (owner)) + scm_c_issue_deprecation_warning + ("The 'owner' argument to 'scm_lock_mutex_timed' is deprecated. " + "Use SRFI-18 directly if you need this concept."); + + return scm_timed_lock_mutex (m, timeout); +} + SCM scm_unlock_mutex_timed (SCM mx, SCM cond, SCM timeout) { diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 5948fc512..211266f6d 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -240,6 +240,7 @@ SCM_DEPRECATED void scm_dynwind_critical_section (SCM mutex); SCM_DEPRECATED SCM scm_make_mutex_with_flags (SCM flags); SCM_DEPRECATED SCM scm_unlock_mutex_timed (SCM mx, SCM cond, SCM timeout); +SCM_DEPRECATED SCM scm_lock_mutex_timed (SCM m, SCM timeout, SCM owner); diff --git a/libguile/threads.c b/libguile/threads.c index d7295bc9f..0da9de1ff 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -987,7 +987,8 @@ scm_cancel_thread (SCM thread) return SCM_UNSPECIFIED; } -SCM scm_join_thread (SCM thread) +SCM +scm_join_thread (SCM thread) { return scm_join_thread_timed (thread, SCM_UNDEFINED, SCM_UNDEFINED); } @@ -1201,20 +1202,17 @@ fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, int *ret) return err; } -SCM scm_lock_mutex (SCM mx) +SCM +scm_lock_mutex (SCM mx) { - return scm_lock_mutex_timed (mx, SCM_UNDEFINED, SCM_UNDEFINED); + return scm_timed_lock_mutex (mx, SCM_UNDEFINED); } -SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 2, 0, - (SCM m, SCM timeout, SCM owner), +SCM_DEFINE (scm_timed_lock_mutex, "lock-mutex", 1, 1, 0, + (SCM m, SCM timeout), "Lock mutex @var{m}. If the mutex is already locked, the calling\n" - "thread blocks until the mutex becomes available. The function\n" - "returns when the calling thread owns the lock on @var{m}.\n" - "Locking a mutex that a thread already owns will succeed right\n" - "away and will not block the thread. That is, Guile's mutexes\n" - "are @emph{recursive}.") -#define FUNC_NAME s_scm_lock_mutex_timed + "thread blocks until the mutex becomes available.") +#define FUNC_NAME s_scm_timed_lock_mutex { SCM exception; int ret = 0; @@ -1228,11 +1226,6 @@ SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 2, 0, waittime = &cwaittime; } - if (!SCM_UNBNDP (owner) && !scm_is_false (owner)) - scm_c_issue_deprecation_warning - ("The 'owner' argument to lock-mutex is deprecated. Use SRFI-18 " - "directly if you need this concept."); - exception = fat_mutex_lock (m, waittime, &ret); if (!scm_is_false (exception)) scm_ithrow (SCM_CAR (exception), scm_list_1 (SCM_CDR (exception)), 1); @@ -1264,7 +1257,7 @@ scm_dynwind_lock_mutex (SCM mutex) SCM scm_try_mutex (SCM mutex) { - return scm_lock_mutex_timed (mutex, SCM_INUM0, SCM_UNDEFINED); + return scm_timed_lock_mutex (mutex, SCM_INUM0); } /*** Fat condition variables */ diff --git a/libguile/threads.h b/libguile/threads.h index 1da7bbf4a..ce8148f4e 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -152,7 +152,7 @@ SCM_API SCM scm_make_mutex (void); SCM_API SCM scm_make_recursive_mutex (void); SCM_API SCM scm_make_mutex_with_kind (SCM kind); SCM_API SCM scm_lock_mutex (SCM m); -SCM_API SCM scm_lock_mutex_timed (SCM m, SCM timeout, SCM owner); +SCM_API SCM scm_timed_lock_mutex (SCM m, SCM timeout); SCM_API void scm_dynwind_lock_mutex (SCM mutex); SCM_API SCM scm_try_mutex (SCM m); SCM_API SCM scm_unlock_mutex (SCM m); From 16fe02aa159d6d3e97d82983631c03dcf7af2067 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 6 Nov 2016 18:11:25 +0100 Subject: [PATCH 594/865] Update documentation on mutexes * doc/ref/api-scheduling.texi (Mutexes and Condition Variables): Update. --- doc/ref/api-scheduling.texi | 64 +++++++++++-------------------------- 1 file changed, 19 insertions(+), 45 deletions(-) diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index 9b6e44088..c5015fb63 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -466,36 +466,28 @@ function is equivalent to calling @code{make-mutex} with the @code{recursive} kind. @end deffn -@deffn {Scheme Procedure} lock-mutex mutex [timeout [owner]] +@deffn {Scheme Procedure} lock-mutex mutex [timeout] @deffnx {C Function} scm_lock_mutex (mutex) -@deffnx {C Function} scm_lock_mutex_timed (mutex, timeout, owner) -Lock @var{mutex}. If the mutex is already locked, then block and -return only when @var{mutex} has been acquired. +@deffnx {C Function} scm_timed_lock_mutex (mutex, timeout) +Lock @var{mutex} and return @code{#t}. If the mutex is already locked, +then block and return only when @var{mutex} has been acquired. When @var{timeout} is given, it specifies a point in time where the waiting should be aborted. It can be either an integer as returned by @code{current-time} or a pair as returned by @code{gettimeofday}. When the waiting is aborted, @code{#f} is returned. -When @var{owner} is given, it specifies an owner for @var{mutex} other -than the calling thread. @var{owner} may also be @code{#f}, -indicating that the mutex should be locked but left unowned. - -For standard mutexes (@code{make-mutex}), and error is signalled if -the thread has itself already locked @var{mutex}. +For standard mutexes (@code{make-mutex}), an error is signalled if the +thread has itself already locked @var{mutex}. For a recursive mutex (@code{make-recursive-mutex}), if the thread has itself already locked @var{mutex}, then a further @code{lock-mutex} call increments the lock count. An additional @code{unlock-mutex} will be required to finally release. -If @var{mutex} was locked by a thread that exited before unlocking it, -the next attempt to lock @var{mutex} will succeed, but -@code{abandoned-mutex-error} will be signalled. - -When an async (@pxref{Asyncs}) is activated for a thread blocked in -@code{lock-mutex}, the wait is interrupted and the async is executed. -When the async returns, the wait resumes. +When an asynchronous interrupt (@pxref{Asyncs}) is scheduled for a +thread blocked in @code{lock-mutex}, Guile will interrupt the wait, run +the interrupts, and then resume the wait. @end deffn @deftypefn {C Function} void scm_dynwind_lock_mutex (SCM mutex) @@ -505,31 +497,18 @@ context is entered and to be unlocked when it is exited. @deffn {Scheme Procedure} try-mutex mx @deffnx {C Function} scm_try_mutex (mx) -Try to lock @var{mutex} as per @code{lock-mutex}. If @var{mutex} can -be acquired immediately then this is done and the return is @code{#t}. -If @var{mutex} is locked by some other thread then nothing is done and -the return is @code{#f}. +Try to lock @var{mutex} and return @code{#t} if successful, or @code{#f} +otherwise. This is like calling @code{lock-mutex} with an expired +timeout. @end deffn -@deffn {Scheme Procedure} unlock-mutex mutex [condvar [timeout]] +@deffn {Scheme Procedure} unlock-mutex mutex @deffnx {C Function} scm_unlock_mutex (mutex) -@deffnx {C Function} scm_unlock_mutex_timed (mutex, condvar, timeout) -Unlock @var{mutex}. An error is signalled if @var{mutex} is not locked -and was not created with the @code{unchecked-unlock} flag set, or if -@var{mutex} is locked by a thread other than the calling thread and was -not created with the @code{allow-external-unlock} flag set. +Unlock @var{mutex}. An error is signalled if @var{mutex} is not locked. -If @var{condvar} is given, it specifies a condition variable upon -which the calling thread will wait to be signalled before returning. -(This behavior is very similar to that of -@code{wait-condition-variable}, except that the mutex is left in an -unlocked state when the function returns.) - -When @var{timeout} is also given and not false, it specifies a point in -time where the waiting should be aborted. It can be either an integer -as returned by @code{current-time} or a pair as returned by -@code{gettimeofday}. When the waiting is aborted, @code{#f} is -returned. Otherwise the function returns @code{#t}. +``Standard'' and ``recursive'' mutexes can only be unlocked by the +thread that locked them; Guile detects this situation and signals an +error. ``Unowned'' mutexes can be unlocked by any thread. @end deffn @deffn {Scheme Procedure} mutex-owner mutex @@ -593,13 +572,8 @@ Wake up one thread that is waiting for @var{condvar}. Wake up all threads that are waiting for @var{condvar}. @end deffn -@sp 1 -The following are higher level operations on mutexes. These are -available from - -@example -(use-modules (ice-9 threads)) -@end example +Guile also includes some higher-level abstractions for working with +mutexes. @deffn macro with-mutex mutex body1 body2 @dots{} Lock @var{mutex}, evaluate the body @var{body1} @var{body2} @dots{}, From 2c0c6414bb030eb3b185d8da427330666815a6ce Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 6 Nov 2016 18:29:05 +0100 Subject: [PATCH 595/865] Minor editing in api-scheduling.texi * doc/ref/api-scheduling.texi: Fix a couple editing mistakes. --- doc/ref/api-scheduling.texi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index c5015fb63..1f5d17f09 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -384,7 +384,7 @@ But if you arrange to unlock the mutex when leaving a dynamic extent via via a continuation invocation? Surely re-entering the dynamic extent without the lock is a bad idea, so there are two options on the table: either prevent re-entry via @code{with-continuation-barrier} or similar, -or reacquiring the lock in the entry thunk of a @code{dynamic-wind}. +or reacquire the lock in the entry thunk of a @code{dynamic-wind}. You might think that because you don't use continuations, that you don't have to think about this, and you might be right. If you control the @@ -428,7 +428,7 @@ and like standard mutexes can only be unlocked by the owner thread. Finally, calling @code{make-mutex} with the symbol @code{allow-external-unlock} creates an unowned mutex. An unowned mutex is like a standard mutex, except that it can be unlocked by any thread. -A corrolary of this behavior is that a thread's attempt to lock a mutex +A corollary of this behavior is that a thread's attempt to lock a mutex that it already owns will block instead of signalling an error, as it could be that some other thread unlocks the mutex, allowing the owner thread to proceed. This kind of mutex is a bit strange and is here for From f8de9808ed6e8c16f20ba5abd803ecb437138a54 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 6 Nov 2016 19:00:29 +0100 Subject: [PATCH 596/865] Update NEWS. * NEWS: Update. --- NEWS | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) diff --git a/NEWS b/NEWS index 7233d2f3c..92217395f 100644 --- a/NEWS +++ b/NEWS @@ -21,6 +21,52 @@ break, however; we used the deprecation facility to signal a warning message while also providing these bindings in the root environment for the duration of the 2.2 series. +** SRFI-18 threads, mutexes, cond vars disjoint from Guile + +When we added support for the SRFI-18 threading library in Guile 2.0, we +did so in a way that made SRFI-18 mutexes the same as Guile mutexes. +This was a mistake. In Guile our goal is to provide basic, +well-thought-out, well-implemented, minimal primitives, on top of which +we can build a variety of opinionated frameworks. Incorporating SRFI-18 +functionality into core Guile caused us to bloat and slow down our core +threading primitives. Worse, they became very hard to describe; they +did many things, did them poorly, and all that they did was never +adequately specified. + +For all of these reasons we have returned to a situation where SRFI-18 +concepts are implemented only in the `(srfi srfi-18)' module. This +means that SRFI-18 threads are built on Guile threads, but aren't the +same as Guile threads; calling Guile `thread?' on a thread no longer +returns true. + +We realize this causes inconvenience to users who use both Guile +threading interfaces and SRFI-18 interfaces, and we lament the change -- +but we are better off now. We hope the newly revised "Scheduling" +section in the manual compensates for the headache. + +** Remove `lock-mutex' "owner" argument + +Mutex owners are a SRFI-18 concept; use SRFI-18 mutexes instead. +Relatedly, `scm_lock_mutex_timed' taking the owner argument is now +deprecated; use `scm_timed_lock_mutex' instead. + +** Remove `unlock-mutex' cond var and timeout arguments + +It used to be that `unlock-mutex' included `wait-condition-variable' +functionality. This has been deprecated; use SRFI-18 if you want this +behavior from `mutex-unlock!'. Relatedly, `scm_unlock_mutex_timed is +deprecated; use `scm_unlock_mutex' instead. + +** Removed `unchecked-unlock' mutex flag + +This flag was introduced for internal use by SRFI-18; use SRFI-18 +mutexes if you need this behaviour. + +** SRFI-18 mutexes no longer recursive + +Contrary to specification, SRFI-18 mutexes in Guile were recursive. +This is no longer the case. + ** Thread cleanup handlers removed The `set-thread-cleanup!' and `thread-cleanup' functions that were added @@ -51,6 +97,11 @@ make sure you're in a "scm_dynwind_begin (0)" and use scm_dynwind_pthread_mutex_lock instead, possibly also with scm_dynwind_block_asyncs. +** `scm_make_mutex_with_flags' deprecated + +Use `scm_make_mutex_with_kind' instead. See "Mutexes and Condition +Variables" in the manual, for more. + * Bug fixes ** cancel-thread uses asynchronous interrupts, not pthread_cancel From 8f1db9f2681e3859e4292563b96fecac200d1c08 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Thu, 17 Sep 2015 15:14:54 -0500 Subject: [PATCH 597/865] web: Add https support through gnutls. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Since importing gnutls directly would result in a dependency cycle, we load gnutls lazily. This uses code originally written for Guix by Ludovic Courtès. * module/web/client.scm: (%http-receive-buffer-size) (gnutls-module, ensure-gnutls, gnutls-ref, tls-wrap): New variables. (open-socket-for-uri): Wrap in tls when uri scheme is https. * doc/ref/web.texi (open-socket-for-uri): Document gnutls usage. --- doc/ref/web.texi | 6 +- module/web/client.scm | 162 ++++++++++++++++++++++++++++++++++++------ 2 files changed, 147 insertions(+), 21 deletions(-) diff --git a/doc/ref/web.texi b/doc/ref/web.texi index becdc28db..8ddb2073a 100644 --- a/doc/ref/web.texi +++ b/doc/ref/web.texi @@ -1422,7 +1422,11 @@ the lower-level HTTP, request, and response modules. @end example @deffn {Scheme Procedure} open-socket-for-uri uri -Return an open input/output port for a connection to URI. +Return an open input/output port for a connection to URI. Guile +dynamically loads gnutls for https support. +@xref{Guile Preparations, +how to install the GnuTLS bindings for Guile,, gnutls-guile, +GnuTLS-Guile}, for more information. @end deffn @deffn {Scheme Procedure} http-get uri arg... diff --git a/module/web/client.scm b/module/web/client.scm index f24a4d70a..042468c54 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -1,6 +1,6 @@ ;;; Web client -;; Copyright (C) 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2011, 2012, 2013, 2014, 2015, 2016 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 @@ -43,8 +43,11 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) + #:use-module ((rnrs io ports) + #:prefix rnrs-ports:) #:export (current-http-proxy open-socket-for-uri + open-connection-for-uri http-get http-get* http-head @@ -54,11 +57,104 @@ http-trace http-options)) +(define %http-receive-buffer-size + ;; Size of the HTTP receive buffer. + 65536) + +;; Autoload GnuTLS so that this module can be used even when GnuTLS is +;; not available. At compile time, this yields "possibly unbound +;; variable" warnings, but these are OK: we know that the variables will +;; be bound if we need them, because (guix download) adds GnuTLS as an +;; input in that case. + +;; XXX: Use this hack instead of #:autoload to avoid compilation errors. +;; See . +(module-autoload! (current-module) + '(gnutls) '(make-session connection-end/client)) + +(define gnutls-module + (delay + (catch 'misc-error + (lambda () + (let ((module (resolve-interface '(gnutls)))) + ;; In some 2.1/2.2 installations installed alongside Guile 2.0, gnutls + ;; can be imported but the bindings are broken as "unknown type". + ;; Here we check that gnutls-version is the right type (a procedure) + ;; to make sure the bindings are ok. + (if (procedure? (module-ref module 'gnutls-version)) + module + #f))) + (const #f)))) + +(define (ensure-gnutls) + (if (not (force gnutls-module)) + (throw 'gnutls-not-available "(gnutls) module not available"))) + (define current-http-proxy (make-parameter (let ((proxy (getenv "http_proxy"))) (and (not (equal? proxy "")) proxy)))) +(define (tls-wrap port server) + "Return PORT wrapped in a TLS connection to SERVER. SERVER must be a DNS +host name without trailing dot." + (define (log level str) + (format (current-error-port) + "gnutls: [~a|~a] ~a" (getpid) level str)) + + (ensure-gnutls) + + (let ((session (make-session connection-end/client))) + ;; Some servers such as 'cloud.github.com' require the client to support + ;; the 'SERVER NAME' extension. However, 'set-session-server-name!' is + ;; not available in older GnuTLS releases. See + ;; for details. + (if (module-defined? (force gnutls-module) + 'set-session-server-name!) + (set-session-server-name! session server-name-type/dns server) + (format (current-error-port) + "warning: TLS 'SERVER NAME' extension not supported~%")) + + (set-session-transport-fd! session (fileno port)) + (set-session-default-priority! session) + + ;; The "%COMPAT" bit allows us to work around firewall issues (info + ;; "(gnutls) Priority Strings"); see . + ;; Explicitly disable SSLv3, which is insecure: + ;; . + (set-session-priorities! session "NORMAL:%COMPAT:-VERS-SSL3.0") + + (set-session-credentials! session (make-certificate-credentials)) + + ;; Uncomment the following lines in case of debugging emergency. + ;;(set-log-level! 10) + ;;(set-log-procedure! log) + + (handshake session) + (let ((record (session-record-port session))) + (define (read! bv start count) + (define read-bv (get-bytevector-n record count)) + (if (eof-object? read-bv) + 0 ; read! returns 0 on eof-object + (let ((read-bv-len (bytevector-length read-bv))) + (bytevector-copy! read-bv 0 bv start read-bv-len) + read-bv-len))) + (define (write! bv start count) + (put-bytevector record bv start count) + count) + (define (get-position) + (rnrs-ports:port-position record)) + (define (set-position! new-position) + (rnrs-ports:set-port-position! record new-position)) + (define (close) + (unless (port-closed? port) + (close-port port)) + (unless (port-closed? record) + (close-port record))) + (make-custom-binary-input/output-port "gnutls wrapped port" read! write! + get-position set-position! + close)))) + (define (ensure-uri uri-or-string) (cond ((string? uri-or-string) (string->uri uri-or-string)) @@ -81,27 +177,53 @@ 0)) (lambda (ai1 ai2) (equal? (addrinfo:addr ai1) (addrinfo:addr ai2)))))) + (define https? + (eq? 'https (uri-scheme uri))) + (define (open-socket) + (let loop ((addresses addresses)) + (let* ((ai (car addresses)) + (s (with-fluids ((%default-port-encoding #f)) + ;; Restrict ourselves to TCP. + (socket (addrinfo:fam ai) SOCK_STREAM IPPROTO_IP)))) + (catch 'system-error + (lambda () + (connect s (addrinfo:addr ai)) - (let loop ((addresses addresses)) - (let* ((ai (car addresses)) - (s (with-fluids ((%default-port-encoding #f)) - ;; Restrict ourselves to TCP. - (socket (addrinfo:fam ai) SOCK_STREAM IPPROTO_IP)))) - (catch 'system-error - (lambda () - (connect s (addrinfo:addr ai)) + ;; Buffer input and output on this port. + (setvbuf s 'block) + ;; If we're using a proxy, make a note of that. + (when http-proxy (set-http-proxy-port?! s #t)) + s) + (lambda args + ;; Connection failed, so try one of the other addresses. + (close s) + (if (null? (cdr addresses)) + (apply throw args) + (loop (cdr addresses)))))))) - ;; Buffer input and output on this port. - (setvbuf s 'block) - ;; If we're using a proxy, make a note of that. - (when http-proxy (set-http-proxy-port?! s #t)) - s) - (lambda args - ;; Connection failed, so try one of the other addresses. - (close s) - (if (null? (cdr addresses)) - (apply throw args) - (loop (cdr addresses)))))))) + (let-syntax ((with-https-proxy + (syntax-rules () + ((_ exp) + ;; For HTTPS URIs, honor 'https_proxy', not 'http_proxy'. + ;; FIXME: Proxying is not supported for https. + (let ((thunk (lambda () exp))) + (if (and https? + current-http-proxy) + (parameterize ((current-http-proxy #f)) + (when (and=> (getenv "https_proxy") + (negate string-null?)) + (format (current-error-port) + "warning: 'https_proxy' is ignored~%")) + (thunk)) + (thunk))))))) + (with-https-proxy + (let ((s (open-socket))) + ;; Buffer input and output on this port. + (setvbuf s _IOFBF %http-receive-buffer-size) + + (if https? + (tls-wrap s (uri-host uri)) + s))))) (define (extend-request r k v . additional) (let ((r (set-field r (request-headers) From 6bdd9551157bb5010973cad8f5fcbd5361fad622 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Mon, 7 Nov 2016 12:13:17 -0600 Subject: [PATCH 598/865] doc: Adjust capitalization for "HTTPS" and "GnuTLS". * doc/ref/web.texi (open-socket-for-uri): Adjust capitalization. --- doc/ref/web.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/web.texi b/doc/ref/web.texi index 8ddb2073a..c0a7bdda6 100644 --- a/doc/ref/web.texi +++ b/doc/ref/web.texi @@ -1423,7 +1423,7 @@ the lower-level HTTP, request, and response modules. @deffn {Scheme Procedure} open-socket-for-uri uri Return an open input/output port for a connection to URI. Guile -dynamically loads gnutls for https support. +dynamically loads GnuTLS for HTTPS support. @xref{Guile Preparations, how to install the GnuTLS bindings for Guile,, gnutls-guile, GnuTLS-Guile}, for more information. From e7c658a61131c02612ffc69b80bd608614e3b29c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 8 Nov 2016 20:20:06 +0100 Subject: [PATCH 599/865] Internal threads refactor * libguile/threads.c: Inline "fat mutexes" and "fat conds" into their users. These are just Guile mutexes and Guile condition variables. --- libguile/threads.c | 434 ++++++++++++++++++++------------------------- 1 file changed, 193 insertions(+), 241 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index 0da9de1ff..43bf19ca8 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -502,44 +502,7 @@ guilify_self_2 (SCM parent) } -/*** Fat mutexes */ -/* We implement our own mutex type since we want them to be 'fair', we - want to do fancy things while waiting for them (like running - asyncs) and we might want to add things that are nice for - debugging. -*/ - -enum fat_mutex_kind { - /* A standard mutex can only be locked once. If you try to lock it - again from the thread that locked it to begin with (the "owner" - thread), it throws an error. It can only be unlocked from the - thread that locked it in the first place. */ - FAT_MUTEX_STANDARD, - /* A recursive mutex can be locked multiple times by its owner. It - then has to be unlocked the corresponding number of times, and like - standard mutexes can only be unlocked by the owner thread. */ - FAT_MUTEX_RECURSIVE, - /* An unowned mutex is like a standard mutex, except that it can be - unlocked by any thread. A corrolary of this behavior is that a - thread's attempt to lock a mutex that it already owns will block - instead of signalling an error, as it could be that some other - thread unlocks the mutex, allowing the owner thread to proceed. - This kind of mutex is a bit strange and is here for use by - SRFI-18. */ - FAT_MUTEX_UNOWNED -}; - -typedef struct { - scm_i_pthread_mutex_t lock; - SCM owner; - int level; /* how much the owner owns us. <= 1 for non-recursive mutexes */ - enum fat_mutex_kind kind; - SCM waiting; /* the threads waiting for this mutex. */ -} fat_mutex; - -#define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x) -#define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x)) /* Perform thread tear-down, in guile mode. */ @@ -1069,9 +1032,47 @@ SCM_DEFINE (scm_thread_p, "thread?", 1, 0, 0, } #undef FUNC_NAME +/*** Fat mutexes */ + +/* We implement our own mutex type since we want them to be 'fair', we + want to do fancy things while waiting for them (like running + asyncs) and we might want to add things that are nice for + debugging. +*/ + +enum fat_mutex_kind { + /* A standard mutex can only be locked once. If you try to lock it + again from the thread that locked it to begin with (the "owner" + thread), it throws an error. It can only be unlocked from the + thread that locked it in the first place. */ + FAT_MUTEX_STANDARD, + /* A recursive mutex can be locked multiple times by its owner. It + then has to be unlocked the corresponding number of times, and like + standard mutexes can only be unlocked by the owner thread. */ + FAT_MUTEX_RECURSIVE, + /* An unowned mutex is like a standard mutex, except that it can be + unlocked by any thread. A corrolary of this behavior is that a + thread's attempt to lock a mutex that it already owns will block + instead of signalling an error, as it could be that some other + thread unlocks the mutex, allowing the owner thread to proceed. + This kind of mutex is a bit strange and is here for use by + SRFI-18. */ + FAT_MUTEX_UNOWNED +}; + +typedef struct { + scm_i_pthread_mutex_t lock; + SCM owner; + int level; /* how much the owner owns us. <= 1 for non-recursive mutexes */ + enum fat_mutex_kind kind; + SCM waiting; /* the threads waiting for this mutex. */ +} fat_mutex; + +#define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x) +#define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x)) static int -fat_mutex_print (SCM mx, SCM port, scm_print_state *pstate SCM_UNUSED) +scm_mutex_print (SCM mx, SCM port, scm_print_state *pstate SCM_UNUSED) { fat_mutex *m = SCM_MUTEX_DATA (mx); scm_puts ("#lock, &lock, sizeof (m->lock)); - m->owner = SCM_BOOL_F; - m->level = 0; - m->kind = kind; - m->waiting = SCM_EOL; - SCM_NEWSMOB (mx, scm_tc16_mutex, (scm_t_bits) m); - m->waiting = make_queue (); - return mx; -} - -SCM scm_make_mutex (void) -{ - return scm_make_mutex_with_kind (SCM_UNDEFINED); -} - SCM_SYMBOL (allow_external_unlock_sym, "allow-external-unlock"); SCM_SYMBOL (recursive_sym, "recursive"); @@ -1118,6 +1094,8 @@ SCM_DEFINE (scm_make_mutex_with_kind, "make-mutex", 0, 1, 0, #define FUNC_NAME s_scm_make_mutex_with_kind { enum fat_mutex_kind mkind = FAT_MUTEX_STANDARD; + fat_mutex *m; + scm_i_pthread_mutex_t lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; if (!SCM_UNBNDP (kind)) { @@ -1129,10 +1107,25 @@ SCM_DEFINE (scm_make_mutex_with_kind, "make-mutex", 0, 1, 0, SCM_MISC_ERROR ("unsupported mutex kind: ~a", scm_list_1 (kind)); } - return make_fat_mutex (mkind); + m = scm_gc_malloc (sizeof (fat_mutex), "mutex"); + /* Because PTHREAD_MUTEX_INITIALIZER is static, it's plain old data, + and so we can just copy it. */ + memcpy (&m->lock, &lock, sizeof (m->lock)); + m->owner = SCM_BOOL_F; + m->level = 0; + m->kind = mkind; + m->waiting = make_queue (); + + return scm_new_smob (scm_tc16_mutex, (scm_t_bits) m); } #undef FUNC_NAME +SCM +scm_make_mutex (void) +{ + return scm_make_mutex_with_kind (SCM_UNDEFINED); +} + SCM_DEFINE (scm_make_recursive_mutex, "make-recursive-mutex", 0, 0, 0, (void), "Create a new recursive mutex. ") @@ -1142,15 +1135,31 @@ SCM_DEFINE (scm_make_recursive_mutex, "make-recursive-mutex", 0, 0, 0, } #undef FUNC_NAME -static SCM -fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, int *ret) +SCM +scm_lock_mutex (SCM mx) { - fat_mutex *m = SCM_MUTEX_DATA (mutex); - - SCM new_owner = scm_current_thread(); - SCM err = SCM_BOOL_F; + return scm_timed_lock_mutex (mx, SCM_UNDEFINED); +} +SCM_DEFINE (scm_timed_lock_mutex, "lock-mutex", 1, 1, 0, + (SCM mutex, SCM timeout), + "Lock mutex @var{mutex}. If the mutex is already locked, " + "the calling thread blocks until the mutex becomes available.") +#define FUNC_NAME s_scm_timed_lock_mutex +{ + scm_t_timespec cwaittime, *waittime = NULL; struct timeval current_time; + fat_mutex *m; + SCM new_owner = scm_current_thread(); + + SCM_VALIDATE_MUTEX (1, mutex); + m = SCM_MUTEX_DATA (mutex); + + if (! SCM_UNBNDP (timeout) && ! scm_is_false (timeout)) + { + to_timespec (timeout, &cwaittime); + waittime = &cwaittime; + } scm_i_scm_pthread_mutex_lock (&m->lock); @@ -1160,76 +1169,42 @@ fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, int *ret) { m->owner = new_owner; m->level++; - *ret = 1; - break; + scm_i_pthread_mutex_unlock (&m->lock); + return SCM_BOOL_T; } else if (scm_is_eq (m->owner, new_owner) && m->kind != FAT_MUTEX_UNOWNED) { if (m->kind == FAT_MUTEX_RECURSIVE) { m->level++; - *ret = 1; + scm_i_pthread_mutex_unlock (&m->lock); + return SCM_BOOL_T; } else { - err = scm_cons (scm_misc_error_key, - scm_from_locale_string ("mutex already locked " - "by thread")); - *ret = 0; + scm_i_pthread_mutex_unlock (&m->lock); + SCM_MISC_ERROR ("mutex already locked by thread", SCM_EOL); } - break; } else { - if (timeout != NULL) + if (waittime != NULL) { gettimeofday (¤t_time, NULL); - if (current_time.tv_sec > timeout->tv_sec || - (current_time.tv_sec == timeout->tv_sec && - current_time.tv_usec * 1000 > timeout->tv_nsec)) + if (current_time.tv_sec > waittime->tv_sec || + (current_time.tv_sec == waittime->tv_sec && + current_time.tv_usec * 1000 > waittime->tv_nsec)) { - *ret = 0; - break; + scm_i_pthread_mutex_unlock (&m->lock); + return SCM_BOOL_F; } } - block_self (m->waiting, mutex, &m->lock, timeout); + block_self (m->waiting, mutex, &m->lock, waittime); scm_i_pthread_mutex_unlock (&m->lock); SCM_TICK; scm_i_scm_pthread_mutex_lock (&m->lock); } } - scm_i_pthread_mutex_unlock (&m->lock); - return err; -} - -SCM -scm_lock_mutex (SCM mx) -{ - return scm_timed_lock_mutex (mx, SCM_UNDEFINED); -} - -SCM_DEFINE (scm_timed_lock_mutex, "lock-mutex", 1, 1, 0, - (SCM m, SCM timeout), - "Lock mutex @var{m}. If the mutex is already locked, the calling\n" - "thread blocks until the mutex becomes available.") -#define FUNC_NAME s_scm_timed_lock_mutex -{ - SCM exception; - int ret = 0; - scm_t_timespec cwaittime, *waittime = NULL; - - SCM_VALIDATE_MUTEX (1, m); - - if (! SCM_UNBNDP (timeout) && ! scm_is_false (timeout)) - { - to_timespec (timeout, &cwaittime); - waittime = &cwaittime; - } - - exception = fat_mutex_lock (m, waittime, &ret); - if (!scm_is_false (exception)) - scm_ithrow (SCM_CAR (exception), scm_list_1 (SCM_CDR (exception)), 1); - return ret ? SCM_BOOL_T : SCM_BOOL_F; } #undef FUNC_NAME @@ -1260,20 +1235,18 @@ scm_try_mutex (SCM mutex) return scm_timed_lock_mutex (mutex, SCM_INUM0); } -/*** Fat condition variables */ - -typedef struct { - scm_i_pthread_mutex_t lock; - SCM waiting; /* the threads waiting for this condition. */ -} fat_cond; - -#define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x) -#define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x)) - -static void -fat_mutex_unlock (SCM mutex) +SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0, (SCM mutex), + "Unlocks @var{mutex}. The calling thread must already hold\n" + "the lock on @var{mutex}, unless the mutex was created with\n" + "the @code{allow-external-unlock} option; otherwise an error\n" + "will be signalled.") +#define FUNC_NAME s_scm_unlock_mutex { - fat_mutex *m = SCM_MUTEX_DATA (mutex); + fat_mutex *m; + + SCM_VALIDATE_MUTEX (1, mutex); + + m = SCM_MUTEX_DATA (mutex); scm_i_scm_pthread_mutex_lock (&m->lock); @@ -1282,12 +1255,12 @@ fat_mutex_unlock (SCM mutex) if (m->level == 0) { scm_i_pthread_mutex_unlock (&m->lock); - scm_misc_error (NULL, "mutex not locked", SCM_EOL); + SCM_MISC_ERROR ("mutex not locked", SCM_EOL); } else if (m->kind != FAT_MUTEX_UNOWNED) { scm_i_pthread_mutex_unlock (&m->lock); - scm_misc_error (NULL, "mutex not locked by current thread", SCM_EOL); + SCM_MISC_ERROR ("mutex not locked by current thread", SCM_EOL); } } @@ -1298,91 +1271,6 @@ fat_mutex_unlock (SCM mutex) m->owner = unblock_from_queue (m->waiting); scm_i_pthread_mutex_unlock (&m->lock); -} - -static int -fat_mutex_wait (SCM cond, SCM mutex, const scm_t_timespec *waittime) -{ - fat_cond *c = SCM_CONDVAR_DATA (cond); - fat_mutex *m = SCM_MUTEX_DATA (mutex); - scm_i_thread *t = SCM_I_CURRENT_THREAD; - int err = 0, ret = 0; - - scm_i_scm_pthread_mutex_lock (&m->lock); - - if (!scm_is_eq (m->owner, t->handle)) - { - if (m->level == 0) - { - scm_i_pthread_mutex_unlock (&m->lock); - scm_misc_error (NULL, "mutex not locked", SCM_EOL); - } - else if (m->kind != FAT_MUTEX_UNOWNED) - { - scm_i_pthread_mutex_unlock (&m->lock); - scm_misc_error (NULL, "mutex not locked by current thread", SCM_EOL); - } - } - - while (1) - { - int brk = 0; - - if (m->level > 0) - m->level--; - if (m->level == 0) - /* Change the owner of MUTEX. */ - m->owner = unblock_from_queue (m->waiting); - - t->block_asyncs++; - - err = block_self (c->waiting, cond, &m->lock, waittime); - scm_i_pthread_mutex_unlock (&m->lock); - - if (err == 0) - { - ret = 1; - brk = 1; - } - else if (err == ETIMEDOUT) - { - ret = 0; - brk = 1; - } - else if (err != EINTR) - { - errno = err; - scm_syserror (NULL); - } - - if (brk) - { - scm_lock_mutex (mutex); - t->block_asyncs--; - break; - } - - t->block_asyncs--; - scm_async_tick (); - - scm_remember_upto_here_2 (cond, mutex); - - scm_i_scm_pthread_mutex_lock (&m->lock); - } - - return ret; -} - -SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0, (SCM mx), - "Unlocks @var{mutex}. The calling thread must already hold\n" - "the lock on @var{mutex}, unless the mutex was created with\n" - "the @code{allow-external-unlock} option; otherwise an error\n" - "will be signalled.") -#define FUNC_NAME s_scm_unlock_mutex -{ - SCM_VALIDATE_MUTEX (1, mx); - - fat_mutex_unlock (mx); return SCM_BOOL_T; } @@ -1435,6 +1323,16 @@ SCM_DEFINE (scm_mutex_locked_p, "mutex-locked?", 1, 0, 0, } #undef FUNC_NAME +/*** Fat condition variables */ + +typedef struct { + scm_i_pthread_mutex_t lock; + SCM waiting; /* the threads waiting for this condition. */ +} fat_cond; + +#define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x) +#define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x)) + static int fat_cond_print (SCM cv, SCM port, scm_print_state *pstate SCM_UNUSED) { @@ -1462,7 +1360,7 @@ SCM_DEFINE (scm_make_condition_variable, "make-condition-variable", 0, 0, 0, #undef FUNC_NAME SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, 0, - (SCM cv, SCM mx, SCM t), + (SCM cond, SCM mutex, SCM timeout), "Wait until condition variable @var{cv} has been signalled. While waiting, " "mutex @var{mx} is atomically unlocked (as with @code{unlock-mutex}) and " "is locked again when this function returns. When @var{t} is given, " @@ -1474,52 +1372,106 @@ SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, "is returned. ") #define FUNC_NAME s_scm_timed_wait_condition_variable { - scm_t_timespec waittime, *waitptr = NULL; + scm_t_timespec waittime_val, *waittime = NULL; + fat_cond *c; + fat_mutex *m; + scm_i_thread *t = SCM_I_CURRENT_THREAD; - SCM_VALIDATE_CONDVAR (1, cv); - SCM_VALIDATE_MUTEX (2, mx); + SCM_VALIDATE_CONDVAR (1, cond); + SCM_VALIDATE_MUTEX (2, mutex); - if (!SCM_UNBNDP (t)) + c = SCM_CONDVAR_DATA (cond); + m = SCM_MUTEX_DATA (mutex); + + if (!SCM_UNBNDP (timeout)) { - to_timespec (t, &waittime); - waitptr = &waittime; + to_timespec (timeout, &waittime_val); + waittime = &waittime_val; } - return scm_from_bool (fat_mutex_wait (cv, mx, waitptr)); + scm_i_scm_pthread_mutex_lock (&m->lock); + + if (!scm_is_eq (m->owner, t->handle)) + { + if (m->level == 0) + { + scm_i_pthread_mutex_unlock (&m->lock); + SCM_MISC_ERROR ("mutex not locked", SCM_EOL); + } + else if (m->kind != FAT_MUTEX_UNOWNED) + { + scm_i_pthread_mutex_unlock (&m->lock); + SCM_MISC_ERROR ("mutex not locked by current thread", SCM_EOL); + } + } + + while (1) + { + int err = 0; + + if (m->level > 0) + m->level--; + if (m->level == 0) + /* Change the owner of MUTEX. */ + m->owner = unblock_from_queue (m->waiting); + + t->block_asyncs++; + + err = block_self (c->waiting, cond, &m->lock, waittime); + scm_i_pthread_mutex_unlock (&m->lock); + + if (err == 0) + { + scm_lock_mutex (mutex); + t->block_asyncs--; + return SCM_BOOL_T; + } + else if (err == ETIMEDOUT) + { + scm_lock_mutex (mutex); + t->block_asyncs--; + return SCM_BOOL_F; + } + else if (err != EINTR) + { + errno = err; + /* FIXME: missing t->block_asyncs--; ??? */ + SCM_SYSERROR; + } + + t->block_asyncs--; + scm_async_tick (); + + scm_remember_upto_here_2 (cond, mutex); + + scm_i_scm_pthread_mutex_lock (&m->lock); + } } #undef FUNC_NAME -static void -fat_cond_signal (fat_cond *c) -{ - unblock_from_queue (c->waiting); -} - SCM_DEFINE (scm_signal_condition_variable, "signal-condition-variable", 1, 0, 0, (SCM cv), "Wake up one thread that is waiting for @var{cv}") #define FUNC_NAME s_scm_signal_condition_variable { + fat_cond *c; SCM_VALIDATE_CONDVAR (1, cv); - fat_cond_signal (SCM_CONDVAR_DATA (cv)); + c = SCM_CONDVAR_DATA (cv); + unblock_from_queue (c->waiting); return SCM_BOOL_T; } #undef FUNC_NAME -static void -fat_cond_broadcast (fat_cond *c) -{ - while (scm_is_true (unblock_from_queue (c->waiting))) - ; -} - SCM_DEFINE (scm_broadcast_condition_variable, "broadcast-condition-variable", 1, 0, 0, (SCM cv), "Wake up all threads that are waiting for @var{cv}. ") #define FUNC_NAME s_scm_broadcast_condition_variable { + fat_cond *c; SCM_VALIDATE_CONDVAR (1, cv); - fat_cond_broadcast (SCM_CONDVAR_DATA (cv)); + c = SCM_CONDVAR_DATA (cv); + while (scm_is_true (unblock_from_queue (c->waiting))) + ; return SCM_BOOL_T; } #undef FUNC_NAME @@ -1865,7 +1817,7 @@ scm_init_threads () scm_set_smob_print (scm_tc16_thread, thread_print); scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (fat_mutex)); - scm_set_smob_print (scm_tc16_mutex, fat_mutex_print); + scm_set_smob_print (scm_tc16_mutex, scm_mutex_print); scm_tc16_condvar = scm_make_smob_type ("condition-variable", sizeof (fat_cond)); From 7fd10d21c0a634c8a4278e7d2e4237cccebc9936 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 8 Nov 2016 20:23:20 +0100 Subject: [PATCH 600/865] Rename Guile's internal mutexes and condvars * libguile/threads.c: Rename fat_mutex to struct scm_mutex, and likewise for scm_cond. --- libguile/threads.c | 76 ++++++++++++++++++++++++---------------------- 1 file changed, 39 insertions(+), 37 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index 43bf19ca8..f000e9c1a 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1032,7 +1032,8 @@ SCM_DEFINE (scm_thread_p, "thread?", 1, 0, 0, } #undef FUNC_NAME -/*** Fat mutexes */ + + /* We implement our own mutex type since we want them to be 'fair', we want to do fancy things while waiting for them (like running @@ -1040,16 +1041,16 @@ SCM_DEFINE (scm_thread_p, "thread?", 1, 0, 0, debugging. */ -enum fat_mutex_kind { +enum scm_mutex_kind { /* A standard mutex can only be locked once. If you try to lock it again from the thread that locked it to begin with (the "owner" thread), it throws an error. It can only be unlocked from the thread that locked it in the first place. */ - FAT_MUTEX_STANDARD, + SCM_MUTEX_STANDARD, /* A recursive mutex can be locked multiple times by its owner. It then has to be unlocked the corresponding number of times, and like standard mutexes can only be unlocked by the owner thread. */ - FAT_MUTEX_RECURSIVE, + SCM_MUTEX_RECURSIVE, /* An unowned mutex is like a standard mutex, except that it can be unlocked by any thread. A corrolary of this behavior is that a thread's attempt to lock a mutex that it already owns will block @@ -1057,24 +1058,24 @@ enum fat_mutex_kind { thread unlocks the mutex, allowing the owner thread to proceed. This kind of mutex is a bit strange and is here for use by SRFI-18. */ - FAT_MUTEX_UNOWNED + SCM_MUTEX_UNOWNED }; -typedef struct { +struct scm_mutex { scm_i_pthread_mutex_t lock; SCM owner; int level; /* how much the owner owns us. <= 1 for non-recursive mutexes */ - enum fat_mutex_kind kind; + enum scm_mutex_kind kind; SCM waiting; /* the threads waiting for this mutex. */ -} fat_mutex; +}; #define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x) -#define SCM_MUTEX_DATA(x) ((fat_mutex *) SCM_SMOB_DATA (x)) +#define SCM_MUTEX_DATA(x) ((struct scm_mutex *) SCM_SMOB_DATA (x)) static int scm_mutex_print (SCM mx, SCM port, scm_print_state *pstate SCM_UNUSED) { - fat_mutex *m = SCM_MUTEX_DATA (mx); + struct scm_mutex *m = SCM_MUTEX_DATA (mx); scm_puts ("#", port); @@ -1093,21 +1094,21 @@ SCM_DEFINE (scm_make_mutex_with_kind, "make-mutex", 0, 1, 0, "that can be unlocked from any thread.") #define FUNC_NAME s_scm_make_mutex_with_kind { - enum fat_mutex_kind mkind = FAT_MUTEX_STANDARD; - fat_mutex *m; + enum scm_mutex_kind mkind = SCM_MUTEX_STANDARD; + struct scm_mutex *m; scm_i_pthread_mutex_t lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; if (!SCM_UNBNDP (kind)) { if (scm_is_eq (kind, allow_external_unlock_sym)) - mkind = FAT_MUTEX_UNOWNED; + mkind = SCM_MUTEX_UNOWNED; else if (scm_is_eq (kind, recursive_sym)) - mkind = FAT_MUTEX_RECURSIVE; + mkind = SCM_MUTEX_RECURSIVE; else SCM_MISC_ERROR ("unsupported mutex kind: ~a", scm_list_1 (kind)); } - m = scm_gc_malloc (sizeof (fat_mutex), "mutex"); + m = scm_gc_malloc (sizeof (struct scm_mutex), "mutex"); /* Because PTHREAD_MUTEX_INITIALIZER is static, it's plain old data, and so we can just copy it. */ memcpy (&m->lock, &lock, sizeof (m->lock)); @@ -1149,7 +1150,7 @@ SCM_DEFINE (scm_timed_lock_mutex, "lock-mutex", 1, 1, 0, { scm_t_timespec cwaittime, *waittime = NULL; struct timeval current_time; - fat_mutex *m; + struct scm_mutex *m; SCM new_owner = scm_current_thread(); SCM_VALIDATE_MUTEX (1, mutex); @@ -1172,9 +1173,9 @@ SCM_DEFINE (scm_timed_lock_mutex, "lock-mutex", 1, 1, 0, scm_i_pthread_mutex_unlock (&m->lock); return SCM_BOOL_T; } - else if (scm_is_eq (m->owner, new_owner) && m->kind != FAT_MUTEX_UNOWNED) + else if (scm_is_eq (m->owner, new_owner) && m->kind != SCM_MUTEX_UNOWNED) { - if (m->kind == FAT_MUTEX_RECURSIVE) + if (m->kind == SCM_MUTEX_RECURSIVE) { m->level++; scm_i_pthread_mutex_unlock (&m->lock); @@ -1242,7 +1243,7 @@ SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0, (SCM mutex), "will be signalled.") #define FUNC_NAME s_scm_unlock_mutex { - fat_mutex *m; + struct scm_mutex *m; SCM_VALIDATE_MUTEX (1, mutex); @@ -1257,7 +1258,7 @@ SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0, (SCM mutex), scm_i_pthread_mutex_unlock (&m->lock); SCM_MISC_ERROR ("mutex not locked", SCM_EOL); } - else if (m->kind != FAT_MUTEX_UNOWNED) + else if (m->kind != SCM_MUTEX_UNOWNED) { scm_i_pthread_mutex_unlock (&m->lock); SCM_MISC_ERROR ("mutex not locked by current thread", SCM_EOL); @@ -1291,7 +1292,7 @@ SCM_DEFINE (scm_mutex_owner, "mutex-owner", 1, 0, 0, #define FUNC_NAME s_scm_mutex_owner { SCM owner; - fat_mutex *m = NULL; + struct scm_mutex *m = NULL; SCM_VALIDATE_MUTEX (1, mx); m = SCM_MUTEX_DATA (mx); @@ -1323,20 +1324,21 @@ SCM_DEFINE (scm_mutex_locked_p, "mutex-locked?", 1, 0, 0, } #undef FUNC_NAME -/*** Fat condition variables */ -typedef struct { + + +struct scm_cond { scm_i_pthread_mutex_t lock; SCM waiting; /* the threads waiting for this condition. */ -} fat_cond; +}; #define SCM_CONDVARP(x) SCM_SMOB_PREDICATE (scm_tc16_condvar, x) -#define SCM_CONDVAR_DATA(x) ((fat_cond *) SCM_SMOB_DATA (x)) +#define SCM_CONDVAR_DATA(x) ((struct scm_cond *) SCM_SMOB_DATA (x)) static int -fat_cond_print (SCM cv, SCM port, scm_print_state *pstate SCM_UNUSED) +scm_cond_print (SCM cv, SCM port, scm_print_state *pstate SCM_UNUSED) { - fat_cond *c = SCM_CONDVAR_DATA (cv); + struct scm_cond *c = SCM_CONDVAR_DATA (cv); scm_puts ("#", port); @@ -1348,10 +1350,10 @@ SCM_DEFINE (scm_make_condition_variable, "make-condition-variable", 0, 0, 0, "Make a new condition variable.") #define FUNC_NAME s_scm_make_condition_variable { - fat_cond *c; + struct scm_cond *c; SCM cv; - c = scm_gc_malloc (sizeof (fat_cond), "condition variable"); + c = scm_gc_malloc (sizeof (struct scm_cond), "condition variable"); c->waiting = SCM_EOL; SCM_NEWSMOB (cv, scm_tc16_condvar, (scm_t_bits) c); c->waiting = make_queue (); @@ -1373,8 +1375,8 @@ SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, #define FUNC_NAME s_scm_timed_wait_condition_variable { scm_t_timespec waittime_val, *waittime = NULL; - fat_cond *c; - fat_mutex *m; + struct scm_cond *c; + struct scm_mutex *m; scm_i_thread *t = SCM_I_CURRENT_THREAD; SCM_VALIDATE_CONDVAR (1, cond); @@ -1398,7 +1400,7 @@ SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, scm_i_pthread_mutex_unlock (&m->lock); SCM_MISC_ERROR ("mutex not locked", SCM_EOL); } - else if (m->kind != FAT_MUTEX_UNOWNED) + else if (m->kind != SCM_MUTEX_UNOWNED) { scm_i_pthread_mutex_unlock (&m->lock); SCM_MISC_ERROR ("mutex not locked by current thread", SCM_EOL); @@ -1454,7 +1456,7 @@ SCM_DEFINE (scm_signal_condition_variable, "signal-condition-variable", 1, 0, 0, "Wake up one thread that is waiting for @var{cv}") #define FUNC_NAME s_scm_signal_condition_variable { - fat_cond *c; + struct scm_cond *c; SCM_VALIDATE_CONDVAR (1, cv); c = SCM_CONDVAR_DATA (cv); unblock_from_queue (c->waiting); @@ -1467,7 +1469,7 @@ SCM_DEFINE (scm_broadcast_condition_variable, "broadcast-condition-variable", 1, "Wake up all threads that are waiting for @var{cv}. ") #define FUNC_NAME s_scm_broadcast_condition_variable { - fat_cond *c; + struct scm_cond *c; SCM_VALIDATE_CONDVAR (1, cv); c = SCM_CONDVAR_DATA (cv); while (scm_is_true (unblock_from_queue (c->waiting))) @@ -1816,12 +1818,12 @@ scm_init_threads () scm_tc16_thread = scm_make_smob_type ("thread", sizeof (scm_i_thread)); scm_set_smob_print (scm_tc16_thread, thread_print); - scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (fat_mutex)); + scm_tc16_mutex = scm_make_smob_type ("mutex", sizeof (struct scm_mutex)); scm_set_smob_print (scm_tc16_mutex, scm_mutex_print); scm_tc16_condvar = scm_make_smob_type ("condition-variable", - sizeof (fat_cond)); - scm_set_smob_print (scm_tc16_condvar, fat_cond_print); + sizeof (struct scm_cond)); + scm_set_smob_print (scm_tc16_condvar, scm_cond_print); scm_i_default_dynamic_state = SCM_BOOL_F; guilify_self_2 (SCM_BOOL_F); From 4110e7bbb181786059a9d2b6ff010a99f69e5710 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 8 Nov 2016 20:37:38 +0100 Subject: [PATCH 601/865] Put mutex kind in SMOB flags * libguile/threads.c (struct scm_mutex, SCM_MUTEX_KIND, scm_make_mutex) (scm_timed_lock_mutex, scm_unlock_mutex) (scm_timed_wait_condition_variable): Mutex kind in SMOB flags. --- libguile/threads.c | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index f000e9c1a..1c8879644 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1065,12 +1065,12 @@ struct scm_mutex { scm_i_pthread_mutex_t lock; SCM owner; int level; /* how much the owner owns us. <= 1 for non-recursive mutexes */ - enum scm_mutex_kind kind; SCM waiting; /* the threads waiting for this mutex. */ }; -#define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x) -#define SCM_MUTEX_DATA(x) ((struct scm_mutex *) SCM_SMOB_DATA (x)) +#define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x) +#define SCM_MUTEX_DATA(x) ((struct scm_mutex *) SCM_SMOB_DATA (x)) +#define SCM_MUTEX_KIND(x) ((enum scm_mutex_kind) (SCM_SMOB_FLAGS (x) & 0x3)) static int scm_mutex_print (SCM mx, SCM port, scm_print_state *pstate SCM_UNUSED) @@ -1114,10 +1114,9 @@ SCM_DEFINE (scm_make_mutex_with_kind, "make-mutex", 0, 1, 0, memcpy (&m->lock, &lock, sizeof (m->lock)); m->owner = SCM_BOOL_F; m->level = 0; - m->kind = mkind; m->waiting = make_queue (); - return scm_new_smob (scm_tc16_mutex, (scm_t_bits) m); + return scm_new_smob (scm_tc16_mutex | (mkind << 16), (scm_t_bits) m); } #undef FUNC_NAME @@ -1173,9 +1172,10 @@ SCM_DEFINE (scm_timed_lock_mutex, "lock-mutex", 1, 1, 0, scm_i_pthread_mutex_unlock (&m->lock); return SCM_BOOL_T; } - else if (scm_is_eq (m->owner, new_owner) && m->kind != SCM_MUTEX_UNOWNED) + else if (scm_is_eq (m->owner, new_owner) && + SCM_MUTEX_KIND (mutex) != SCM_MUTEX_UNOWNED) { - if (m->kind == SCM_MUTEX_RECURSIVE) + if (SCM_MUTEX_KIND (mutex) == SCM_MUTEX_RECURSIVE) { m->level++; scm_i_pthread_mutex_unlock (&m->lock); @@ -1258,7 +1258,7 @@ SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0, (SCM mutex), scm_i_pthread_mutex_unlock (&m->lock); SCM_MISC_ERROR ("mutex not locked", SCM_EOL); } - else if (m->kind != SCM_MUTEX_UNOWNED) + else if (SCM_MUTEX_KIND (mutex) != SCM_MUTEX_UNOWNED) { scm_i_pthread_mutex_unlock (&m->lock); SCM_MISC_ERROR ("mutex not locked by current thread", SCM_EOL); @@ -1400,7 +1400,7 @@ SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, scm_i_pthread_mutex_unlock (&m->lock); SCM_MISC_ERROR ("mutex not locked", SCM_EOL); } - else if (m->kind != SCM_MUTEX_UNOWNED) + else if (SCM_MUTEX_KIND (mutex) != SCM_MUTEX_UNOWNED) { scm_i_pthread_mutex_unlock (&m->lock); SCM_MISC_ERROR ("mutex not locked by current thread", SCM_EOL); From 1ed9dea34aa8cb0cbae17200c31d1ac91a6a01de Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 13 Nov 2016 12:43:46 +0100 Subject: [PATCH 602/865] Unlocked mutexes don't have owners * libguile/threads.c (scm_unlock_mutex) (scm_timed_wait_condition_variable): Unlocked mutexes should never have owners. --- libguile/threads.c | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index 1c8879644..863c84f71 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1268,8 +1268,11 @@ SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0, (SCM mutex), if (m->level > 0) m->level--; if (m->level == 0) - /* Change the owner of MUTEX. */ - m->owner = unblock_from_queue (m->waiting); + /* Wake up one waiter. */ + { + m->owner = SCM_BOOL_F; + unblock_from_queue (m->waiting); + } scm_i_pthread_mutex_unlock (&m->lock); @@ -1414,8 +1417,11 @@ SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, if (m->level > 0) m->level--; if (m->level == 0) - /* Change the owner of MUTEX. */ - m->owner = unblock_from_queue (m->waiting); + { + m->owner = SCM_BOOL_F; + /* Wake up one waiter. */ + unblock_from_queue (m->waiting); + } t->block_asyncs++; From 6bb51193df3620d962df87caf8cfbf6a4256a540 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 13 Nov 2016 15:08:45 +0100 Subject: [PATCH 603/865] Refactor GC implications of thread sleep * libguile/async.c (struct scm_thread_wake_data): Move definition here. (scm_i_setup_sleep): Remove "sleep_object". Caller now responsible for scm_remember_upto_here_1 as appropriate. (scm_system_async_mark_for_thread): Remove scm_remember_upto_here_1 call. * libguile/async.h (scm_i_setup_sleep): Adapt prototype. * libguile/threads.h (struct scm_thread_wake_data): Remove definition. * libguile/threads.c (block_self): Remove sleep_object argument. (scm_join_thread_timed, scm_timed_lock_mutex) (scm_timed_wait_condition_variable, scm_std_select): Adapt. --- libguile/async.c | 12 ++++++------ libguile/async.h | 2 +- libguile/threads.c | 17 ++++++++--------- libguile/threads.h | 7 +------ 4 files changed, 16 insertions(+), 22 deletions(-) diff --git a/libguile/async.c b/libguile/async.c index b4a2c2ad2..174a87afb 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -75,15 +75,19 @@ scm_async_tick (void) } } +struct scm_thread_wake_data { + scm_i_pthread_mutex_t *mutex; + int fd; +}; + int scm_i_setup_sleep (scm_i_thread *t, - SCM sleep_object, scm_i_pthread_mutex_t *sleep_mutex, + scm_i_pthread_mutex_t *sleep_mutex, int sleep_fd) { struct scm_thread_wake_data *wake; wake = scm_gc_typed_calloc (struct scm_thread_wake_data); - wake->object = sleep_object; wake->mutex = sleep_mutex; wake->fd = sleep_fd; @@ -148,10 +152,6 @@ SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0, scm_i_pthread_cond_signal (&t->sleep_cond); scm_i_pthread_mutex_unlock (wake->mutex); - /* This is needed to protect wake->mutex. - */ - scm_remember_upto_here_1 (wake->object); - if (wake->fd >= 0) { char dummy = 0; diff --git a/libguile/async.h b/libguile/async.h index 2a57236ca..343cc2ae6 100644 --- a/libguile/async.h +++ b/libguile/async.h @@ -35,7 +35,7 @@ SCM_API void scm_switch (void); SCM_API SCM scm_system_async_mark (SCM a); SCM_API SCM scm_system_async_mark_for_thread (SCM a, SCM thread); SCM_INTERNAL int scm_i_setup_sleep (scm_i_thread *, - SCM obj, scm_i_pthread_mutex_t *m, + scm_i_pthread_mutex_t *m, int fd); SCM_INTERNAL void scm_i_reset_sleep (scm_i_thread *); SCM_API SCM scm_noop (SCM args); diff --git a/libguile/threads.c b/libguile/threads.c index 863c84f71..211e57ee2 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -290,9 +290,6 @@ thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) The caller of block_self must hold MUTEX. It will be atomically unlocked while sleeping, just as with scm_i_pthread_cond_wait. - SLEEP_OBJECT is an arbitrary SCM value that is kept alive as long - as MUTEX is needed. - When WAITTIME is not NULL, the sleep will be aborted at that time. The return value of block_self is an errno value. It will be zero @@ -304,14 +301,14 @@ thread_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) The system asyncs themselves are not executed by block_self. */ static int -block_self (SCM queue, SCM sleep_object, scm_i_pthread_mutex_t *mutex, +block_self (SCM queue, scm_i_pthread_mutex_t *mutex, const scm_t_timespec *waittime) { scm_i_thread *t = SCM_I_CURRENT_THREAD; SCM q_handle; int err; - if (scm_i_setup_sleep (t, sleep_object, mutex, -1)) + if (scm_i_setup_sleep (t, mutex, -1)) { scm_i_reset_sleep (t); err = EINTR; @@ -988,8 +985,9 @@ SCM_DEFINE (scm_join_thread_timed, "join-thread", 1, 2, 0, { while (1) { - int err = block_self (t->join_queue, thread, &t->admin_mutex, + int err = block_self (t->join_queue, &t->admin_mutex, timeout_ptr); + scm_remember_upto_here_1 (thread); if (err == 0) { if (t->exited) @@ -1200,7 +1198,8 @@ SCM_DEFINE (scm_timed_lock_mutex, "lock-mutex", 1, 1, 0, return SCM_BOOL_F; } } - block_self (m->waiting, mutex, &m->lock, waittime); + block_self (m->waiting, &m->lock, waittime); + scm_remember_upto_here_1 (mutex); scm_i_pthread_mutex_unlock (&m->lock); SCM_TICK; scm_i_scm_pthread_mutex_lock (&m->lock); @@ -1425,7 +1424,7 @@ SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, t->block_asyncs++; - err = block_self (c->waiting, cond, &m->lock, waittime); + err = block_self (c->waiting, &m->lock, waittime); scm_i_pthread_mutex_unlock (&m->lock); if (err == 0) @@ -1543,7 +1542,7 @@ scm_std_select (int nfds, readfds = &my_readfds; } - while (scm_i_setup_sleep (t, SCM_BOOL_F, NULL, t->sleep_pipe[1])) + while (scm_i_setup_sleep (t, NULL, t->sleep_pipe[1])) { scm_i_reset_sleep (t); SCM_TICK; diff --git a/libguile/threads.h b/libguile/threads.h index ce8148f4e..db52f16b7 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -47,12 +47,7 @@ SCM_API scm_t_bits scm_tc16_thread; SCM_API scm_t_bits scm_tc16_mutex; SCM_API scm_t_bits scm_tc16_condvar; -struct scm_thread_wake_data -{ - SCM object; - scm_i_pthread_mutex_t *mutex; - int fd; -}; +struct scm_thread_wake_data; typedef struct scm_i_thread { struct scm_i_thread *next_thread; From 950e728e7a85d79c30d7856d5abb09db5420b912 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 13 Nov 2016 15:16:20 +0100 Subject: [PATCH 604/865] Improve mutexes / condition variable implementation * libguile/threads.c (scm_timed_lock_mutex): Use "level" field only for recursive mutexes. (unlock_mutex, scm_unlock_mutex): Factor implementation back out of scm_unlock_mutex (doh?), but in such a way that can specialize against mutex type. (scm_mutex_level): Only look at level for recursive mutexes. (scm_mutex_locked_p): Look at owner field, not level field. (timed_wait, scm_timed_wait_condition_variable): Factor implementation out, as above with unlock-mutex. Specialize relocking of the Guile mutex. --- libguile/threads.c | 253 ++++++++++++++++++++++++++++++--------------- 1 file changed, 170 insertions(+), 83 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index 211e57ee2..fb20f1142 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1163,10 +1163,9 @@ SCM_DEFINE (scm_timed_lock_mutex, "lock-mutex", 1, 1, 0, while (1) { - if (m->level == 0) + if (scm_is_eq (m->owner, SCM_BOOL_F)) { m->owner = new_owner; - m->level++; scm_i_pthread_mutex_unlock (&m->lock); return SCM_BOOL_T; } @@ -1235,6 +1234,43 @@ scm_try_mutex (SCM mutex) return scm_timed_lock_mutex (mutex, SCM_INUM0); } +/* This function is static inline so that the compiler can specialize it + against the mutex kind. */ +static inline void +unlock_mutex (enum scm_mutex_kind kind, struct scm_mutex *m, + scm_i_thread *current_thread) +#define FUNC_NAME "unlock-mutex" +{ + scm_i_scm_pthread_mutex_lock (&m->lock); + + if (!scm_is_eq (m->owner, current_thread->handle)) + { + if (scm_is_eq (m->owner, SCM_BOOL_F)) + { + scm_i_pthread_mutex_unlock (&m->lock); + SCM_MISC_ERROR ("mutex not locked", SCM_EOL); + } + + if (kind != SCM_MUTEX_UNOWNED) + { + scm_i_pthread_mutex_unlock (&m->lock); + SCM_MISC_ERROR ("mutex not locked by current thread", SCM_EOL); + } + } + + if (kind == SCM_MUTEX_RECURSIVE && m->level > 0) + m->level--; + else + { + m->owner = SCM_BOOL_F; + /* Wake up one waiter. */ + unblock_from_queue (m->waiting); + } + + scm_i_pthread_mutex_unlock (&m->lock); +} +#undef FUNC_NAME + SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0, (SCM mutex), "Unlocks @var{mutex}. The calling thread must already hold\n" "the lock on @var{mutex}, unless the mutex was created with\n" @@ -1243,37 +1279,30 @@ SCM_DEFINE (scm_unlock_mutex, "unlock-mutex", 1, 0, 0, (SCM mutex), #define FUNC_NAME s_scm_unlock_mutex { struct scm_mutex *m; + scm_i_thread *t = SCM_I_CURRENT_THREAD; SCM_VALIDATE_MUTEX (1, mutex); m = SCM_MUTEX_DATA (mutex); - scm_i_scm_pthread_mutex_lock (&m->lock); - - if (!scm_is_eq (m->owner, SCM_I_CURRENT_THREAD->handle)) + /* Specialized unlock_mutex implementations according to the mutex + kind. */ + switch (SCM_MUTEX_KIND (mutex)) { - if (m->level == 0) - { - scm_i_pthread_mutex_unlock (&m->lock); - SCM_MISC_ERROR ("mutex not locked", SCM_EOL); - } - else if (SCM_MUTEX_KIND (mutex) != SCM_MUTEX_UNOWNED) - { - scm_i_pthread_mutex_unlock (&m->lock); - SCM_MISC_ERROR ("mutex not locked by current thread", SCM_EOL); - } + case SCM_MUTEX_STANDARD: + unlock_mutex (SCM_MUTEX_STANDARD, m, t); + break; + case SCM_MUTEX_RECURSIVE: + unlock_mutex (SCM_MUTEX_RECURSIVE, m, t); + break; + case SCM_MUTEX_UNOWNED: + unlock_mutex (SCM_MUTEX_UNOWNED, m, t); + break; + default: + abort (); } - if (m->level > 0) - m->level--; - if (m->level == 0) - /* Wake up one waiter. */ - { - m->owner = SCM_BOOL_F; - unblock_from_queue (m->waiting); - } - - scm_i_pthread_mutex_unlock (&m->lock); + scm_remember_upto_here_1 (mutex); return SCM_BOOL_T; } @@ -1312,7 +1341,12 @@ SCM_DEFINE (scm_mutex_level, "mutex-level", 1, 0, 0, #define FUNC_NAME s_scm_mutex_level { SCM_VALIDATE_MUTEX (1, mx); - return scm_from_int (SCM_MUTEX_DATA(mx)->level); + if (SCM_MUTEX_KIND (mx) == SCM_MUTEX_RECURSIVE) + return scm_from_int (SCM_MUTEX_DATA (mx)->level + 1); + else if (scm_is_eq (SCM_MUTEX_DATA (mx)->owner, SCM_BOOL_F)) + return SCM_INUM0; + else + return SCM_INUM1; } #undef FUNC_NAME @@ -1322,7 +1356,10 @@ SCM_DEFINE (scm_mutex_locked_p, "mutex-locked?", 1, 0, 0, #define FUNC_NAME s_scm_mutex_locked_p { SCM_VALIDATE_MUTEX (1, mx); - return SCM_MUTEX_DATA (mx)->level > 0 ? SCM_BOOL_T : SCM_BOOL_F; + if (scm_is_eq (SCM_MUTEX_DATA (mx)->owner, SCM_BOOL_F)) + return SCM_BOOL_F; + else + return SCM_BOOL_T; } #undef FUNC_NAME @@ -1363,6 +1400,95 @@ SCM_DEFINE (scm_make_condition_variable, "make-condition-variable", 0, 0, 0, } #undef FUNC_NAME +static inline SCM +timed_wait (enum scm_mutex_kind kind, struct scm_mutex *m, struct scm_cond *c, + scm_i_thread *current_thread, scm_t_timespec *waittime) +#define FUNC_NAME "wait-condition-variable" +{ + scm_i_scm_pthread_mutex_lock (&m->lock); + + if (!scm_is_eq (m->owner, current_thread->handle)) + { + if (scm_is_eq (m->owner, SCM_BOOL_F)) + { + scm_i_pthread_mutex_unlock (&m->lock); + SCM_MISC_ERROR ("mutex not locked", SCM_EOL); + } + + if (kind != SCM_MUTEX_UNOWNED) + { + scm_i_pthread_mutex_unlock (&m->lock); + SCM_MISC_ERROR ("mutex not locked by current thread", SCM_EOL); + } + } + + while (1) + { + int err = 0; + + /* Unlock the mutex. */ + if (kind == SCM_MUTEX_RECURSIVE && m->level > 0) + m->level--; + else + { + m->owner = SCM_BOOL_F; + /* Wake up one waiter. */ + unblock_from_queue (m->waiting); + } + + /* Wait for someone to signal the cond, a timeout, or an + interrupt. */ + err = block_self (c->waiting, &m->lock, waittime); + + /* We woke up for some reason. Reacquire the mutex before doing + anything else. */ + if (scm_is_eq (m->owner, SCM_BOOL_F)) + { + m->owner = current_thread->handle; + scm_i_pthread_mutex_unlock (&m->lock); + } + else if (kind == SCM_MUTEX_RECURSIVE && + scm_is_eq (m->owner, current_thread->handle)) + { + m->level++; + scm_i_pthread_mutex_unlock (&m->lock); + } + else + while (1) + { + block_self (m->waiting, &m->lock, waittime); + if (scm_is_eq (m->owner, SCM_BOOL_F)) + { + m->owner = current_thread->handle; + scm_i_pthread_mutex_unlock (&m->lock); + break; + } + scm_i_pthread_mutex_unlock (&m->lock); + scm_async_tick (); + scm_i_scm_pthread_mutex_lock (&m->lock); + } + + /* Now that we have the mutex again, handle the return value. */ + if (err == 0) + return SCM_BOOL_T; + else if (err == ETIMEDOUT) + return SCM_BOOL_F; + else if (err == EINTR) + { + scm_async_tick (); + scm_i_scm_pthread_mutex_lock (&m->lock); + continue; + } + else + { + /* Shouldn't happen. */ + errno = err; + SCM_SYSERROR; + } + } +} +#undef FUNC_NAME + SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, 0, (SCM cond, SCM mutex, SCM timeout), "Wait until condition variable @var{cv} has been signalled. While waiting, " @@ -1380,6 +1506,7 @@ SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, struct scm_cond *c; struct scm_mutex *m; scm_i_thread *t = SCM_I_CURRENT_THREAD; + SCM ret; SCM_VALIDATE_CONDVAR (1, cond); SCM_VALIDATE_MUTEX (2, mutex); @@ -1393,66 +1520,26 @@ SCM_DEFINE (scm_timed_wait_condition_variable, "wait-condition-variable", 2, 1, waittime = &waittime_val; } - scm_i_scm_pthread_mutex_lock (&m->lock); - - if (!scm_is_eq (m->owner, t->handle)) + /* Specialized timed_wait implementations according to the mutex + kind. */ + switch (SCM_MUTEX_KIND (mutex)) { - if (m->level == 0) - { - scm_i_pthread_mutex_unlock (&m->lock); - SCM_MISC_ERROR ("mutex not locked", SCM_EOL); - } - else if (SCM_MUTEX_KIND (mutex) != SCM_MUTEX_UNOWNED) - { - scm_i_pthread_mutex_unlock (&m->lock); - SCM_MISC_ERROR ("mutex not locked by current thread", SCM_EOL); - } + case SCM_MUTEX_STANDARD: + ret = timed_wait (SCM_MUTEX_STANDARD, m, c, t, waittime); + break; + case SCM_MUTEX_RECURSIVE: + ret = timed_wait (SCM_MUTEX_RECURSIVE, m, c, t, waittime); + break; + case SCM_MUTEX_UNOWNED: + ret = timed_wait (SCM_MUTEX_UNOWNED, m, c, t, waittime); + break; + default: + abort (); } - while (1) - { - int err = 0; + scm_remember_upto_here_2 (mutex, cond); - if (m->level > 0) - m->level--; - if (m->level == 0) - { - m->owner = SCM_BOOL_F; - /* Wake up one waiter. */ - unblock_from_queue (m->waiting); - } - - t->block_asyncs++; - - err = block_self (c->waiting, &m->lock, waittime); - scm_i_pthread_mutex_unlock (&m->lock); - - if (err == 0) - { - scm_lock_mutex (mutex); - t->block_asyncs--; - return SCM_BOOL_T; - } - else if (err == ETIMEDOUT) - { - scm_lock_mutex (mutex); - t->block_asyncs--; - return SCM_BOOL_F; - } - else if (err != EINTR) - { - errno = err; - /* FIXME: missing t->block_asyncs--; ??? */ - SCM_SYSERROR; - } - - t->block_asyncs--; - scm_async_tick (); - - scm_remember_upto_here_2 (cond, mutex); - - scm_i_scm_pthread_mutex_lock (&m->lock); - } + return ret; } #undef FUNC_NAME From e0f17417e681aa4591e41f7edb52c7684ca59aae Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 13 Nov 2016 15:47:21 +0100 Subject: [PATCH 605/865] Optimize lock-mutex * libguile/threads.c (lock_mutex, scm_timed_lock_mutex): As with unlock_mutex before, optimize by specializing to the mutex kind. Also, avoid lock thrashing after a return from block_self. --- libguile/threads.c | 130 +++++++++++++++++++++++++++++---------------- 1 file changed, 85 insertions(+), 45 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index fb20f1142..f4388ce0e 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1139,6 +1139,71 @@ scm_lock_mutex (SCM mx) return scm_timed_lock_mutex (mx, SCM_UNDEFINED); } +static inline SCM +lock_mutex (enum scm_mutex_kind kind, struct scm_mutex *m, + scm_i_thread *current_thread, scm_t_timespec *waittime) +#define FUNC_NAME "lock-mutex" +{ + scm_i_scm_pthread_mutex_lock (&m->lock); + + if (scm_is_eq (m->owner, SCM_BOOL_F)) + { + m->owner = current_thread->handle; + scm_i_pthread_mutex_unlock (&m->lock); + return SCM_BOOL_T; + } + else if (kind == SCM_MUTEX_RECURSIVE && + scm_is_eq (m->owner, current_thread->handle)) + { + m->level++; + scm_i_pthread_mutex_unlock (&m->lock); + return SCM_BOOL_T; + } + else if (kind == SCM_MUTEX_STANDARD && + scm_is_eq (m->owner, current_thread->handle)) + { + scm_i_pthread_mutex_unlock (&m->lock); + SCM_MISC_ERROR ("mutex already locked by thread", SCM_EOL); + } + else + while (1) + { + int err = block_self (m->waiting, &m->lock, waittime); + + if (err == 0) + { + if (scm_is_eq (m->owner, SCM_BOOL_F)) + { + m->owner = current_thread->handle; + scm_i_pthread_mutex_unlock (&m->lock); + return SCM_BOOL_T; + } + else + continue; + } + else if (err == ETIMEDOUT) + { + scm_i_pthread_mutex_unlock (&m->lock); + return SCM_BOOL_F; + } + else if (err == EINTR) + { + scm_i_pthread_mutex_unlock (&m->lock); + scm_async_tick (); + scm_i_scm_pthread_mutex_lock (&m->lock); + continue; + } + else + { + /* Shouldn't happen. */ + scm_i_pthread_mutex_unlock (&m->lock); + errno = err; + SCM_SYSERROR; + } + } +} +#undef FUNC_NAME + SCM_DEFINE (scm_timed_lock_mutex, "lock-mutex", 1, 1, 0, (SCM mutex, SCM timeout), "Lock mutex @var{mutex}. If the mutex is already locked, " @@ -1146,9 +1211,9 @@ SCM_DEFINE (scm_timed_lock_mutex, "lock-mutex", 1, 1, 0, #define FUNC_NAME s_scm_timed_lock_mutex { scm_t_timespec cwaittime, *waittime = NULL; - struct timeval current_time; struct scm_mutex *m; - SCM new_owner = scm_current_thread(); + scm_i_thread *t = SCM_I_CURRENT_THREAD; + SCM ret; SCM_VALIDATE_MUTEX (1, mutex); m = SCM_MUTEX_DATA (mutex); @@ -1159,51 +1224,26 @@ SCM_DEFINE (scm_timed_lock_mutex, "lock-mutex", 1, 1, 0, waittime = &cwaittime; } - scm_i_scm_pthread_mutex_lock (&m->lock); - - while (1) + /* Specialized lock_mutex implementations according to the mutex + kind. */ + switch (SCM_MUTEX_KIND (mutex)) { - if (scm_is_eq (m->owner, SCM_BOOL_F)) - { - m->owner = new_owner; - scm_i_pthread_mutex_unlock (&m->lock); - return SCM_BOOL_T; - } - else if (scm_is_eq (m->owner, new_owner) && - SCM_MUTEX_KIND (mutex) != SCM_MUTEX_UNOWNED) - { - if (SCM_MUTEX_KIND (mutex) == SCM_MUTEX_RECURSIVE) - { - m->level++; - scm_i_pthread_mutex_unlock (&m->lock); - return SCM_BOOL_T; - } - else - { - scm_i_pthread_mutex_unlock (&m->lock); - SCM_MISC_ERROR ("mutex already locked by thread", SCM_EOL); - } - } - else - { - if (waittime != NULL) - { - gettimeofday (¤t_time, NULL); - if (current_time.tv_sec > waittime->tv_sec || - (current_time.tv_sec == waittime->tv_sec && - current_time.tv_usec * 1000 > waittime->tv_nsec)) - { - scm_i_pthread_mutex_unlock (&m->lock); - return SCM_BOOL_F; - } - } - block_self (m->waiting, &m->lock, waittime); - scm_remember_upto_here_1 (mutex); - scm_i_pthread_mutex_unlock (&m->lock); - SCM_TICK; - scm_i_scm_pthread_mutex_lock (&m->lock); - } + case SCM_MUTEX_STANDARD: + ret = lock_mutex (SCM_MUTEX_STANDARD, m, t, waittime); + break; + case SCM_MUTEX_RECURSIVE: + ret = lock_mutex (SCM_MUTEX_RECURSIVE, m, t, waittime); + break; + case SCM_MUTEX_UNOWNED: + ret = lock_mutex (SCM_MUTEX_UNOWNED, m, t, waittime); + break; + default: + abort (); } + + scm_remember_upto_here_1 (mutex); + + return ret; } #undef FUNC_NAME From 9ac2c9942b75d3e891ae8eabc219b68bfdf61f9c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 13 Nov 2016 15:55:58 +0100 Subject: [PATCH 606/865] More comments in threads.c * libguile/threads.c (struct scm_mutex): Better comments. --- libguile/threads.c | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index f4388ce0e..262e2ed9d 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1061,9 +1061,13 @@ enum scm_mutex_kind { struct scm_mutex { scm_i_pthread_mutex_t lock; + /* The thread that owns this mutex, or #f if the mutex is unlocked. */ SCM owner; - int level; /* how much the owner owns us. <= 1 for non-recursive mutexes */ - SCM waiting; /* the threads waiting for this mutex. */ + /* Queue of threads waiting for this mutex. */ + SCM waiting; + /* For SCM_MUTEX_RECURSIVE (and only SCM_MUTEX_RECURSIVE), the + recursive lock count. The first lock does not count. */ + int level; }; #define SCM_MUTEXP(x) SCM_SMOB_PREDICATE (scm_tc16_mutex, x) From 3f23688f397722546861d04688c3eefb0c9c9149 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 13 Nov 2016 22:16:42 +0100 Subject: [PATCH 607/865] Fix crasher in scm_system_async_mark_for_thread * libguile/async.c (scm_system_async_mark_for_thread): Only signal the cond if there is a wait mutex. --- libguile/async.c | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/libguile/async.c b/libguile/async.c index 174a87afb..92ed2f4d6 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -148,9 +148,12 @@ SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0, sleep_mutex locked while setting t->sleep_mutex and will only unlock it again while waiting on sleep_cond. */ - scm_i_scm_pthread_mutex_lock (wake->mutex); - scm_i_pthread_cond_signal (&t->sleep_cond); - scm_i_pthread_mutex_unlock (wake->mutex); + if (wake->mutex) + { + scm_i_scm_pthread_mutex_lock (wake->mutex); + scm_i_pthread_cond_signal (&t->sleep_cond); + scm_i_pthread_mutex_unlock (wake->mutex); + } if (wake->fd >= 0) { From e447258c3f204de22c221ec153850db052acc437 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 14 Nov 2016 21:25:53 +0100 Subject: [PATCH 608/865] scm_spawn_thread uses call-with-new-thread * libguile/throw.h (scm_i_make_catch_body_closure) (scm_i_make_catch_handler_closure): Add scm_i_ prefix and make available for internal use. * libguile/throw.c: Adapt. * libguile/threads.c (scm_spawn_thread): Rewrite in terms of scm_call_with_new_thread. --- libguile/threads.c | 78 +++------------------------------------------- libguile/throw.c | 22 +++++++------ libguile/throw.h | 5 +++ 3 files changed, 22 insertions(+), 83 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index 262e2ed9d..97320571b 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -845,85 +845,17 @@ SCM_DEFINE (scm_sys_call_with_new_thread, "%call-with-new-thread", 1, 0, 0, } #undef FUNC_NAME -typedef struct { - SCM parent; - scm_t_catch_body body; - void *body_data; - scm_t_catch_handler handler; - void *handler_data; - SCM thread; - scm_i_pthread_mutex_t mutex; - scm_i_pthread_cond_t cond; -} spawn_data; - -static void * -really_spawn (void *d) -{ - spawn_data *data = (spawn_data *)d; - scm_t_catch_body body = data->body; - void *body_data = data->body_data; - scm_t_catch_handler handler = data->handler; - void *handler_data = data->handler_data; - scm_i_thread *t = SCM_I_CURRENT_THREAD; - - scm_i_scm_pthread_mutex_lock (&data->mutex); - data->thread = scm_current_thread (); - scm_i_pthread_cond_signal (&data->cond); - scm_i_pthread_mutex_unlock (&data->mutex); - - if (handler == NULL) - t->result = body (body_data); - else - t->result = scm_internal_catch (SCM_BOOL_T, - body, body_data, - handler, handler_data); - - return 0; -} - -static void * -spawn_thread (void *d) -{ - spawn_data *data = (spawn_data *)d; - scm_i_pthread_detach (scm_i_pthread_self ()); - scm_i_with_guile_and_parent (really_spawn, d, data->parent); - return NULL; -} - SCM scm_spawn_thread (scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data) { - spawn_data data; - scm_i_pthread_t id; - int err; + SCM body_closure, handler_closure; - data.parent = scm_current_dynamic_state (); - data.body = body; - data.body_data = body_data; - data.handler = handler; - data.handler_data = handler_data; - data.thread = SCM_BOOL_F; - scm_i_pthread_mutex_init (&data.mutex, NULL); - scm_i_pthread_cond_init (&data.cond, NULL); + body_closure = scm_i_make_catch_body_closure (body, body_data); + handler_closure = handler == NULL ? SCM_UNDEFINED : + scm_i_make_catch_handler_closure (handler, handler_data); - scm_i_scm_pthread_mutex_lock (&data.mutex); - err = scm_i_pthread_create (&id, NULL, spawn_thread, &data); - if (err) - { - scm_i_pthread_mutex_unlock (&data.mutex); - errno = err; - scm_syserror (NULL); - } - - while (scm_is_false (data.thread)) - scm_i_scm_pthread_cond_wait (&data.cond, &data.mutex); - - scm_i_pthread_mutex_unlock (&data.mutex); - - assert (SCM_I_IS_THREAD (data.thread)); - - return data.thread; + return scm_call_with_new_thread (body_closure, handler_closure); } SCM_DEFINE (scm_yield, "yield", 0, 0, 0, diff --git a/libguile/throw.c b/libguile/throw.c index 38fe149fa..45bab7a70 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -272,8 +272,8 @@ enum { CATCH_CLOSURE_HANDLER }; -static SCM -make_catch_body_closure (scm_t_catch_body body, void *body_data) +SCM +scm_i_make_catch_body_closure (scm_t_catch_body body, void *body_data) { SCM ret; SCM_NEWSMOB2 (ret, tc16_catch_closure, body, body_data); @@ -281,8 +281,9 @@ make_catch_body_closure (scm_t_catch_body body, void *body_data) return ret; } -static SCM -make_catch_handler_closure (scm_t_catch_handler handler, void *handler_data) +SCM +scm_i_make_catch_handler_closure (scm_t_catch_handler handler, + void *handler_data) { SCM ret; SCM_NEWSMOB2 (ret, tc16_catch_closure, handler, handler_data); @@ -359,11 +360,12 @@ scm_c_catch (SCM tag, { SCM sbody, shandler, spre_unwind_handler; - sbody = make_catch_body_closure (body, body_data); - shandler = make_catch_handler_closure (handler, handler_data); + sbody = scm_i_make_catch_body_closure (body, body_data); + shandler = scm_i_make_catch_handler_closure (handler, handler_data); if (pre_unwind_handler) - spre_unwind_handler = make_catch_handler_closure (pre_unwind_handler, - pre_unwind_handler_data); + spre_unwind_handler = + scm_i_make_catch_handler_closure (pre_unwind_handler, + pre_unwind_handler_data); else spre_unwind_handler = SCM_UNDEFINED; @@ -403,8 +405,8 @@ scm_c_with_throw_handler (SCM tag, "and adapt it (if necessary) to expect to be within the dynamic context\n" "of the throw."); - sbody = make_catch_body_closure (body, body_data); - shandler = make_catch_handler_closure (handler, handler_data); + sbody = scm_i_make_catch_body_closure (body, body_data); + shandler = scm_i_make_catch_handler_closure (handler, handler_data); return scm_with_throw_handler (tag, sbody, shandler); } diff --git a/libguile/throw.h b/libguile/throw.h index e2da73170..f2020a331 100644 --- a/libguile/throw.h +++ b/libguile/throw.h @@ -31,6 +31,11 @@ typedef SCM (*scm_t_catch_body) (void *data); typedef SCM (*scm_t_catch_handler) (void *data, SCM tag, SCM throw_args); +SCM_INTERNAL SCM scm_i_make_catch_body_closure (scm_t_catch_body body, + void *body_data); +SCM_INTERNAL SCM scm_i_make_catch_handler_closure (scm_t_catch_handler h, + void *handler_data); + SCM_API SCM scm_c_catch (SCM tag, scm_t_catch_body body, void *body_data, From a52144002911f217e03155336ce0980ac8b5b2af Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 14 Nov 2016 21:35:44 +0100 Subject: [PATCH 609/865] join-thread in Scheme * module/ice-9/threads.scm (join-thread): Implement in Scheme. (call-with-new-thread): Arrange to record values in a weak table and signal the join cond. (with-mutex): Move up definition; call-with-new-thread needs it. (How was this working before?) * libguile/threads.c (guilify_self_1, guilify_self_2, do_thread_exit): Remove join queue management. * libguile/threads.c (scm_join_thread, scm_join_thread_timed): Call out to Scheme. (scm_init_ice_9_threads): Capture join-thread var. --- libguile/threads.c | 87 +++++++--------------------------------- libguile/threads.h | 2 - module/ice-9/threads.scm | 70 +++++++++++++++++++++++++------- 3 files changed, 70 insertions(+), 89 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index 97320571b..2798be70f 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -408,7 +408,6 @@ guilify_self_1 (struct GC_stack_base *base) t.pthread = scm_i_pthread_self (); t.handle = SCM_BOOL_F; t.result = SCM_BOOL_F; - t.join_queue = SCM_EOL; t.freelists = NULL; t.pointerless_freelists = NULL; t.dynamic_state = SCM_BOOL_F; @@ -491,7 +490,6 @@ guilify_self_2 (SCM parent) t->dynstack.limit = t->dynstack.base + 16; t->dynstack.top = t->dynstack.base + SCM_DYNSTACK_HEADER_LEN; - t->join_queue = make_queue (); t->block_asyncs = 0; /* See note in finalizers.c:queue_finalizer_async(). */ @@ -509,13 +507,9 @@ do_thread_exit (void *v) scm_i_thread *t = (scm_i_thread *) v; scm_i_scm_pthread_mutex_lock (&t->admin_mutex); - t->exited = 1; close (t->sleep_pipe[0]); close (t->sleep_pipe[1]); - while (scm_is_true (unblock_from_queue (t->join_queue))) - ; - scm_i_pthread_mutex_unlock (&t->admin_mutex); return NULL; @@ -867,9 +861,6 @@ SCM_DEFINE (scm_yield, "yield", 0, 0, 0, } #undef FUNC_NAME -/* Some systems, notably Android, lack 'pthread_cancel'. Don't provide - 'cancel-thread' on these systems. */ - static SCM cancel_thread_var; SCM @@ -879,79 +870,26 @@ scm_cancel_thread (SCM thread) return SCM_UNSPECIFIED; } +static SCM join_thread_var; + SCM scm_join_thread (SCM thread) { - return scm_join_thread_timed (thread, SCM_UNDEFINED, SCM_UNDEFINED); + return scm_call_1 (scm_variable_ref (join_thread_var), thread); } -SCM_DEFINE (scm_join_thread_timed, "join-thread", 1, 2, 0, - (SCM thread, SCM timeout, SCM timeoutval), -"Suspend execution of the calling thread until the target @var{thread} " -"terminates, unless the target @var{thread} has already terminated. ") -#define FUNC_NAME s_scm_join_thread_timed +SCM +scm_join_thread_timed (SCM thread, SCM timeout, SCM timeoutval) { - scm_i_thread *t; - scm_t_timespec ctimeout, *timeout_ptr = NULL; - SCM res = SCM_BOOL_F; + SCM join_thread = scm_variable_ref (join_thread_var); - if (! (SCM_UNBNDP (timeoutval))) - res = timeoutval; - - SCM_VALIDATE_THREAD (1, thread); - if (scm_is_eq (scm_current_thread (), thread)) - SCM_MISC_ERROR ("cannot join the current thread", SCM_EOL); - - t = SCM_I_THREAD_DATA (thread); - scm_i_scm_pthread_mutex_lock (&t->admin_mutex); - - if (! SCM_UNBNDP (timeout)) - { - to_timespec (timeout, &ctimeout); - timeout_ptr = &ctimeout; - } - - if (t->exited) - res = t->result; + if (SCM_UNBNDP (timeout)) + return scm_call_1 (join_thread, thread); + else if (SCM_UNBNDP (timeoutval)) + return scm_call_2 (join_thread, thread, timeout); else - { - while (1) - { - int err = block_self (t->join_queue, &t->admin_mutex, - timeout_ptr); - scm_remember_upto_here_1 (thread); - if (err == 0) - { - if (t->exited) - { - res = t->result; - break; - } - } - else if (err == ETIMEDOUT) - break; - - scm_i_pthread_mutex_unlock (&t->admin_mutex); - SCM_TICK; - scm_i_scm_pthread_mutex_lock (&t->admin_mutex); - - /* Check for exit again, since we just released and - reacquired the admin mutex, before the next block_self - call (which would block forever if t has already - exited). */ - if (t->exited) - { - res = t->result; - break; - } - } - } - - scm_i_pthread_mutex_unlock (&t->admin_mutex); - - return res; + return scm_call_3 (join_thread, thread, timeout, timeoutval); } -#undef FUNC_NAME SCM_DEFINE (scm_thread_p, "thread?", 1, 0, 0, (SCM obj), @@ -1875,6 +1813,9 @@ scm_init_ice_9_threads (void *unused) cancel_thread_var = scm_module_variable (scm_current_module (), scm_from_latin1_symbol ("cancel-thread")); + join_thread_var = + scm_module_variable (scm_current_module (), + scm_from_latin1_symbol ("join-thread")); call_with_new_thread_var = scm_module_variable (scm_current_module (), scm_from_latin1_symbol ("call-with-new-thread")); diff --git a/libguile/threads.h b/libguile/threads.h index db52f16b7..986049c66 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -55,8 +55,6 @@ typedef struct scm_i_thread { SCM handle; scm_i_pthread_t pthread; - SCM join_queue; - scm_i_pthread_mutex_t admin_mutex; SCM result; diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm index 119334b46..ae6a97db9 100644 --- a/module/ice-9/threads.scm +++ b/module/ice-9/threads.scm @@ -85,6 +85,13 @@ +(define-syntax-rule (with-mutex m e0 e1 ...) + (let ((x m)) + (dynamic-wind + (lambda () (lock-mutex x)) + (lambda () (begin e0 e1 ...)) + (lambda () (unlock-mutex x))))) + (define cancel-tag (make-prompt-tag "cancel")) (define (cancel-thread thread . values) "Asynchronously interrupt the target @var{thread} and ask it to @@ -101,6 +108,9 @@ no-op." (error "thread cancellation failed, throwing error instead???")))) thread)) +(define thread-join-data (make-object-property)) +(define %thread-results (make-object-property)) + (define* (call-with-new-thread thunk #:optional handler) "Call @code{thunk} in a new thread and with a new dynamic state, returning a new thread object representing the thread. The procedure @@ -121,21 +131,60 @@ Once @var{thunk} or @var{handler} returns, the return value is made the (with-mutex mutex (%call-with-new-thread (lambda () - (call-with-prompt cancel-tag - (lambda () + (call-with-values + (lambda () + (with-continuation-barrier + (lambda () + (call-with-prompt cancel-tag + (lambda () + (lock-mutex mutex) + (set! thread (current-thread)) + (set! (thread-join-data thread) (cons cv mutex)) + (signal-condition-variable cv) + (unlock-mutex mutex) + (thunk)) + (lambda (k . args) + (apply values args)))))) + (lambda vals (lock-mutex mutex) - (set! thread (current-thread)) - (signal-condition-variable cv) + ;; Probably now you're wondering why we are going to use + ;; the cond variable as the key into the thread results + ;; object property. It's because there is a possibility + ;; that the thread object itself ends up as part of the + ;; result, and if that happens we create a cycle whereby + ;; the strong reference to a thread in the value of the + ;; weak-key hash table used by the object property prevents + ;; the thread from ever being collected. So instead we use + ;; the cv as the key. Weak-key hash tables, amirite? + (set! (%thread-results cv) vals) + (broadcast-condition-variable cv) (unlock-mutex mutex) - (thunk)) - (lambda (k . args) - (apply values args))))) + (apply values vals))))) (let lp () (unless thread (wait-condition-variable cv mutex) (lp)))) thread)) +(define* (join-thread thread #:optional timeout timeoutval) + "Suspend execution of the calling thread until the target @var{thread} +terminates, unless the target @var{thread} has already terminated." + (match (thread-join-data thread) + (#f (error "foreign thread cannot be joined" thread)) + ((cv . mutex) + (lock-mutex mutex) + (let lp () + (cond + ((%thread-results cv) + => (lambda (results) + (unlock-mutex mutex) + (apply values results))) + ((if timeout + (wait-condition-variable cv mutex timeout) + (wait-condition-variable cv mutex)) + (lp)) + (else timeoutval)))))) + (define* (try-mutex mutex) "Try to lock @var{mutex}. If the mutex is already locked, return @code{#f}. Otherwise lock the mutex and return @code{#t}." @@ -155,13 +204,6 @@ Once @var{thunk} or @var{handler} returns, the return value is made the (lambda () (proc arg ...)) %thread-handler)) -(define-syntax-rule (with-mutex m e0 e1 ...) - (let ((x m)) - (dynamic-wind - (lambda () (lock-mutex x)) - (lambda () (begin e0 e1 ...)) - (lambda () (unlock-mutex x))))) - (define monitor-mutex-table (make-hash-table)) (define monitor-mutex-table-mutex (make-mutex)) From fcb43488b39db6c2ad15c2dc7f7b53aa492021b4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 14 Nov 2016 21:57:46 +0100 Subject: [PATCH 610/865] Slim thread cleanup * libguile/threads.c (on_thread_exit): Clean up the cleanup. We no longer need to re-enter Guile mode, and some of the comments were incorrect. --- libguile/threads.c | 47 ++++------------------------------------------ 1 file changed, 4 insertions(+), 43 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index 2798be70f..4b6d43c69 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -499,55 +499,18 @@ guilify_self_2 (SCM parent) -/* Perform thread tear-down, in guile mode. - */ -static void * -do_thread_exit (void *v) -{ - scm_i_thread *t = (scm_i_thread *) v; - - scm_i_scm_pthread_mutex_lock (&t->admin_mutex); - t->exited = 1; - close (t->sleep_pipe[0]); - close (t->sleep_pipe[1]); - scm_i_pthread_mutex_unlock (&t->admin_mutex); - - return NULL; -} - -static void * -do_thread_exit_trampoline (struct GC_stack_base *sb, void *v) -{ - /* Won't hurt if we are already registered. */ -#if SCM_USE_PTHREAD_THREADS - GC_register_my_thread (sb); -#endif - - return scm_with_guile (do_thread_exit, v); -} - static void on_thread_exit (void *v) { /* This handler is executed in non-guile mode. */ scm_i_thread *t = (scm_i_thread *) v, **tp; - /* If we were canceled, we were unable to clear `t->guile_mode', so do - it here. */ - t->guile_mode = 0; + t->exited = 1; - /* Reinstate the current thread for purposes of scm_with_guile - guile-mode cleanup handlers. Only really needed in the non-TLS - case but it doesn't hurt to be consistent. */ - scm_i_pthread_setspecific (scm_i_thread_key, t); + close (t->sleep_pipe[0]); + close (t->sleep_pipe[1]); + t->sleep_pipe[0] = t->sleep_pipe[1] = -1; - /* Scheme-level thread finalizers and other cleanup needs to happen in - guile mode. */ - GC_call_with_stack_base (do_thread_exit_trampoline, t); - - /* Removing ourself from the list of all threads needs to happen in - non-guile mode since all SCM values on our stack become - unprotected once we are no longer in the list. */ scm_i_pthread_mutex_lock (&thread_admin_mutex); for (tp = &all_threads; *tp; tp = &(*tp)->next_thread) if (*tp == t) @@ -570,8 +533,6 @@ on_thread_exit (void *v) scm_i_pthread_mutex_unlock (&thread_admin_mutex); - scm_i_pthread_setspecific (scm_i_thread_key, NULL); - if (t->vp) { scm_i_vm_free_stack (t->vp); From ca74e3fae52dd23f8e8f12194d07041e207f68e7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 16 Nov 2016 22:37:54 +0100 Subject: [PATCH 611/865] Add handle-interrupts inst and compiler pass * libguile/vm-engine.c (vm_engine): Remove initial VM_HANDLE_INTERRUPTS call; surely our caller already handled interrupts. Add handle-interrupts opcode. * am/bootstrap.am (SOURCES): * module/Makefile.am (SOURCES): Add handle-interrupts.scm. * module/system/vm/assembler.scm (system): * module/language/cps/compile-bytecode.scm (compile-function): (lower-cps): Add handle-interrupts support. * module/language/cps/handle-interrupts.scm: New file. --- am/bootstrap.am | 1 + libguile/vm-engine.c | 13 +++-- module/Makefile.am | 1 + module/language/cps/compile-bytecode.scm | 6 ++- module/language/cps/handle-interrupts.scm | 58 +++++++++++++++++++++++ module/system/vm/assembler.scm | 1 + 6 files changed, 76 insertions(+), 4 deletions(-) create mode 100644 module/language/cps/handle-interrupts.scm diff --git a/am/bootstrap.am b/am/bootstrap.am index d5f25abfa..e0d4764f5 100644 --- a/am/bootstrap.am +++ b/am/bootstrap.am @@ -81,6 +81,7 @@ SOURCES = \ language/cps/dce.scm \ language/cps/effects-analysis.scm \ language/cps/elide-values.scm \ + language/cps/handle-interrupts.scm \ language/cps/licm.scm \ language/cps/peel-loops.scm \ language/cps/primitives.scm \ diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 4f66b9e7d..4de1971c2 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -511,8 +511,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, /* Load VM registers. */ CACHE_REGISTER (); - VM_HANDLE_INTERRUPTS; - /* Usually a call to the VM happens on application, with the boot continuation on the next frame. Sometimes it happens after a non-local exit however; in that case the VM state is all set up, @@ -3922,7 +3920,16 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (3); } - VM_DEFINE_OP (183, unused_183, NULL, NOP) + /* handle-interrupts _:24 + * + * Handle pending interrupts. + */ + VM_DEFINE_OP (183, handle_interrupts, "handle-interrupts", OP1 (X32)) + { + VM_HANDLE_INTERRUPTS; + NEXT (1); + } + VM_DEFINE_OP (184, unused_184, NULL, NOP) VM_DEFINE_OP (185, unused_185, NULL, NOP) VM_DEFINE_OP (186, unused_186, NULL, NOP) diff --git a/module/Makefile.am b/module/Makefile.am index 0d1f128f1..67f041d20 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -138,6 +138,7 @@ SOURCES = \ language/cps/dce.scm \ language/cps/effects-analysis.scm \ language/cps/elide-values.scm \ + language/cps/handle-interrupts.scm \ language/cps/intmap.scm \ language/cps/intset.scm \ language/cps/licm.scm \ diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 5157ecb70..5e56b406f 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -31,6 +31,7 @@ #:use-module (language cps slot-allocation) #:use-module (language cps utils) #:use-module (language cps closure-conversion) + #:use-module (language cps handle-interrupts) #:use-module (language cps optimize) #:use-module (language cps reify-primitives) #:use-module (language cps renumber) @@ -364,7 +365,9 @@ (($ $primcall 'unwind ()) (emit-unwind asm)) (($ $primcall 'atomic-box-set! (box val)) - (emit-atomic-box-set! asm (from-sp (slot box)) (from-sp (slot val)))))) + (emit-atomic-box-set! asm (from-sp (slot box)) (from-sp (slot val)))) + (($ $primcall 'handle-interrupts ()) + (emit-handle-interrupts asm)))) (define (compile-values label exp syms) (match exp @@ -580,6 +583,7 @@ (set! exp (convert-closures exp)) (set! exp (optimize-first-order-cps exp opts)) (set! exp (reify-primitives exp)) + (set! exp (add-handle-interrupts exp)) (renumber exp)) (define (compile-bytecode exp env opts) diff --git a/module/language/cps/handle-interrupts.scm b/module/language/cps/handle-interrupts.scm new file mode 100644 index 000000000..e686cebce --- /dev/null +++ b/module/language/cps/handle-interrupts.scm @@ -0,0 +1,58 @@ +;;; Continuation-passing style (CPS) intermediate language (IL) + +;; Copyright (C) 2016 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; A pass to add "handle-interrupts" primcalls before calls, loop +;;; back-edges, and returns. +;;; +;;; Code: + +(define-module (language cps handle-interrupts) + #:use-module (ice-9 match) + #:use-module (language cps) + #:use-module (language cps utils) + #:use-module (language cps with-cps) + #:use-module (language cps intmap) + #:use-module (language cps renumber) + #:export (add-handle-interrupts)) + +(define (add-handle-interrupts cps) + (define (visit-cont label cont cps) + (match cont + (($ $kargs names vars ($ $continue k src exp)) + (if (or (<= k label) + (match exp + (($ $call) #t) + (($ $callk) #t) + (($ $values) + (match (intmap-ref cps k) + (($ $ktail) #t) + (_ #f))) + (_ #f))) + (with-cps cps + (letk k* ($kargs () () ($continue k src ,exp))) + (setk label + ($kargs names vars + ($continue k* src + ($primcall 'handle-interrupts ()))))) + cps)) + (_ cps))) + (let ((cps (renumber cps))) + (with-fresh-name-state cps + (persistent-intmap (intmap-fold visit-cont cps cps))))) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index a2992b495..96c6a633b 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -221,6 +221,7 @@ emit-atomic-box-set! emit-atomic-box-swap! emit-atomic-box-compare-and-swap! + emit-handle-interrupts emit-text link-assembly)) From 4985ef13e68c83adf3e83f2c981205806ed9b621 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 17 Nov 2016 22:13:53 +0100 Subject: [PATCH 612/865] Explicit interrupt handling in VM * libguile/foreign.c (CODE, get_foreign_stub_code): Add explicit handle-interrupts and return-values calls, as foreign-call will fall through. * libguile/gsubr.c (A, B, C, AB, AC, BC, ABC, SUBR_STUB_CODE) (scm_i_primitive_call_ip): Same. * libguile/vm-engine.c (VM_HANDLE_INTERRUPTS): Inline into handle-interrupts. (RETURN_ONE_VALUE, RETURN_VALUE_LIST): Inline into callers, and fall through instead of returning. (BR_BINARY, BR_UNARY, BR_ARITHMETIC, BR_U64_ARITHMETIC): Remove conditional VM_HANDLE_INTERRUPTS, as the compiler already inserted the handle-interrupts calls if needed. (vm_engine): Remove VM_HANDLE_INTERRUPTS invocations except in the handle-interrupts instruction. --- libguile/foreign.c | 6 +- libguile/gsubr.c | 26 +++++++-- libguile/vm-engine.c | 133 ++++++++++++++----------------------------- 3 files changed, 70 insertions(+), 95 deletions(-) diff --git a/libguile/foreign.c b/libguile/foreign.c index 0992ef4d3..17a3eedb5 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -767,7 +767,9 @@ SCM_DEFINE (scm_pointer_to_procedure, "pointer->procedure", 3, 0, 0, #define CODE(nreq) \ SCM_PACK_OP_24 (assert_nargs_ee, nreq + 1), \ - SCM_PACK_OP_12_12 (foreign_call, 0, 1) + SCM_PACK_OP_12_12 (foreign_call, 0, 1), \ + SCM_PACK_OP_24 (handle_interrupts, 0), \ + SCM_PACK_OP_24 (return_values, 0) #define CODE_10(n) \ CODE (n + 0), CODE (n + 1), CODE (n + 2), CODE (n + 3), CODE (n + 4), \ @@ -789,7 +791,7 @@ get_foreign_stub_code (unsigned int nargs) scm_misc_error ("make-foreign-function", "args >= 100 currently unimplemented", SCM_EOL); - return &foreign_stub_code[nargs * 2]; + return &foreign_stub_code[nargs * 4]; } static SCM diff --git a/libguile/gsubr.c b/libguile/gsubr.c index b456b220a..e22d16363 100644 --- a/libguile/gsubr.c +++ b/libguile/gsubr.c @@ -75,6 +75,8 @@ #define A(nreq) \ SCM_PACK_OP_24 (assert_nargs_ee, nreq + 1), \ SCM_PACK_OP_24 (subr_call, 0), \ + SCM_PACK_OP_24 (handle_interrupts, 0), \ + SCM_PACK_OP_24 (return_values, 0), \ 0, \ 0 @@ -82,11 +84,15 @@ SCM_PACK_OP_24 (assert_nargs_le, nopt + 1), \ SCM_PACK_OP_24 (alloc_frame, nopt + 1), \ SCM_PACK_OP_24 (subr_call, 0), \ + SCM_PACK_OP_24 (handle_interrupts, 0), \ + SCM_PACK_OP_24 (return_values, 0), \ 0 #define C() \ SCM_PACK_OP_24 (bind_rest, 1), \ SCM_PACK_OP_24 (subr_call, 0), \ + SCM_PACK_OP_24 (handle_interrupts, 0), \ + SCM_PACK_OP_24 (return_values, 0), \ 0, \ 0 @@ -94,17 +100,23 @@ SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1), \ SCM_PACK_OP_24 (assert_nargs_le, nreq + nopt + 1), \ SCM_PACK_OP_24 (alloc_frame, nreq + nopt + 1), \ - SCM_PACK_OP_24 (subr_call, 0) + SCM_PACK_OP_24 (subr_call, 0), \ + SCM_PACK_OP_24 (handle_interrupts, 0), \ + SCM_PACK_OP_24 (return_values, 0) #define AC(nreq) \ SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1), \ SCM_PACK_OP_24 (bind_rest, nreq + 1), \ SCM_PACK_OP_24 (subr_call, 0), \ + SCM_PACK_OP_24 (handle_interrupts, 0), \ + SCM_PACK_OP_24 (return_values, 0), \ 0 #define BC(nopt) \ SCM_PACK_OP_24 (bind_rest, nopt + 1), \ SCM_PACK_OP_24 (subr_call, 0), \ + SCM_PACK_OP_24 (handle_interrupts, 0), \ + SCM_PACK_OP_24 (return_values, 0), \ 0, \ 0 @@ -112,6 +124,8 @@ SCM_PACK_OP_24 (assert_nargs_ge, nreq + 1), \ SCM_PACK_OP_24 (bind_rest, nreq + nopt + 1), \ SCM_PACK_OP_24 (subr_call, 0), \ + SCM_PACK_OP_24 (handle_interrupts, 0), \ + SCM_PACK_OP_24 (return_values, 0), \ 0 @@ -212,7 +226,7 @@ static const scm_t_uint32 subr_stub_code[] = { /* (nargs * nargs) + nopt + rest * (nargs + 1) */ #define SUBR_STUB_CODE(nreq,nopt,rest) \ &subr_stub_code[((nreq + nopt + rest) * (nreq + nopt + rest) \ - + nopt + rest * (nreq + nopt + rest + 1)) * 4] + + nopt + rest * (nreq + nopt + rest + 1)) * 6] static const scm_t_uint32* get_subr_stub_code (unsigned int nreq, unsigned int nopt, unsigned int rest) @@ -265,12 +279,16 @@ scm_i_primitive_code_p (const scm_t_uint32 *code) scm_t_uintptr scm_i_primitive_call_ip (SCM subr) { + size_t i; const scm_t_uint32 *code = SCM_PROGRAM_CODE (subr); - /* A stub is 4 32-bit words long, or 16 bytes. The call will be one + /* A stub is 6 32-bit words long, or 24 bytes. The call will be one instruction, in either the fourth, third, or second word. Return a byte offset from the entry. */ - return (scm_t_uintptr)(code + (code[3] ? 3 : code[2] ? 2 : 1)); + for (i = 1; i < 4; i++) + if ((code[i] & 0xff) == scm_op_subr_call) + return (scm_t_uintptr) (code + i); + abort (); } SCM diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 4de1971c2..ac8f32e49 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -127,22 +127,6 @@ #define ABORT_CONTINUATION_HOOK() \ RUN_HOOK0 (abort) -/* TODO: Invoke asyncs without trampolining out to C. That will let us - preempt computations via an asynchronous interrupt. */ -#define VM_HANDLE_INTERRUPTS \ - do \ - if (SCM_LIKELY (thread->block_asyncs == 0)) \ - { \ - SCM asyncs = scm_atomic_ref_scm (&thread->pending_asyncs); \ - if (SCM_UNLIKELY (!scm_is_null (asyncs))) \ - { \ - SYNC_IP (); \ - scm_async_tick (); \ - CACHE_SP (); \ - } \ - } \ - while (0) - @@ -282,38 +266,6 @@ #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o) #define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED)) -#define RETURN_ONE_VALUE(ret) \ - do { \ - SCM val = ret; \ - union scm_vm_stack_element *old_fp; \ - VM_HANDLE_INTERRUPTS; \ - ALLOC_FRAME (2); \ - old_fp = vp->fp; \ - ip = SCM_FRAME_RETURN_ADDRESS (old_fp); \ - vp->fp = SCM_FRAME_DYNAMIC_LINK (old_fp); \ - /* Clear frame. */ \ - old_fp[0].as_scm = SCM_BOOL_F; \ - old_fp[1].as_scm = SCM_BOOL_F; \ - /* Leave proc. */ \ - SP_SET (0, val); \ - POP_CONTINUATION_HOOK (old_fp); \ - NEXT (0); \ - } while (0) - -/* While we could generate the list-unrolling code here, it's fine for - now to just tail-call (apply values vals). */ -#define RETURN_VALUE_LIST(vals_) \ - do { \ - SCM vals = vals_; \ - VM_HANDLE_INTERRUPTS; \ - ALLOC_FRAME (3); \ - SP_SET (2, vm_builtin_apply); \ - SP_SET (1, vm_builtin_values); \ - SP_SET (0, vals); \ - ip = (scm_t_uint32 *) vm_builtin_apply_code; \ - goto op_tail_apply; \ - } while (0) - #define BR_NARGS(rel) \ scm_t_uint32 expected; \ UNPACK_24 (op, expected); \ @@ -334,8 +286,6 @@ { \ scm_t_int32 offset = ip[1]; \ offset >>= 8; /* Sign-extending shift. */ \ - if (offset <= 0) \ - VM_HANDLE_INTERRUPTS; \ NEXT (offset); \ } \ NEXT (2) @@ -351,8 +301,6 @@ { \ scm_t_int32 offset = ip[2]; \ offset >>= 8; /* Sign-extending shift. */ \ - if (offset <= 0) \ - VM_HANDLE_INTERRUPTS; \ NEXT (offset); \ } \ NEXT (3) @@ -373,8 +321,6 @@ { \ scm_t_int32 offset = ip[2]; \ offset >>= 8; /* Sign-extending shift. */ \ - if (offset <= 0) \ - VM_HANDLE_INTERRUPTS; \ NEXT (offset); \ } \ NEXT (3); \ @@ -389,8 +335,6 @@ { \ scm_t_int32 offset = ip[2]; \ offset >>= 8; /* Sign-extending shift. */ \ - if (offset <= 0) \ - VM_HANDLE_INTERRUPTS; \ NEXT (offset); \ } \ NEXT (3); \ @@ -409,8 +353,6 @@ { \ scm_t_int32 offset = ip[2]; \ offset >>= 8; /* Sign-extending shift. */ \ - if (offset <= 0) \ - VM_HANDLE_INTERRUPTS; \ NEXT (offset); \ } \ NEXT (3); \ @@ -587,8 +529,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_24 (op, proc); UNPACK_24 (ip[1], nlocals); - VM_HANDLE_INTERRUPTS; - PUSH_CONTINUATION_HOOK (); old_fp = vp->fp; @@ -628,8 +568,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_24 (ip[1], nlocals); label = ip[2]; - VM_HANDLE_INTERRUPTS; - PUSH_CONTINUATION_HOOK (); old_fp = vp->fp; @@ -658,8 +596,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_24 (op, nlocals); - VM_HANDLE_INTERRUPTS; - RESET_FRAME (nlocals); if (SCM_LIKELY (SCM_PROGRAM_P (FP_REF (0)))) @@ -685,8 +621,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_24 (op, nlocals); label = ip[1]; - VM_HANDLE_INTERRUPTS; - RESET_FRAME (nlocals); ip += label; @@ -709,8 +643,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_24 (op, from); - VM_HANDLE_INTERRUPTS; - VM_ASSERT (from > 0, abort ()); nlocals = FRAME_LOCALS_COUNT (); @@ -789,8 +721,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, union scm_vm_stack_element *old_fp; scm_t_uint32 nlocals; - VM_HANDLE_INTERRUPTS; - UNPACK_24 (op, nlocals); if (nlocals) RESET_FRAME (nlocals); @@ -831,10 +761,23 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, CACHE_SP (); if (SCM_UNLIKELY (SCM_VALUESP (ret))) - /* multiple values returned to continuation */ - RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0)); + { + SCM vals = scm_struct_ref (ret, SCM_INUM0); + long len = scm_ilength (vals); + ALLOC_FRAME (1 + len); + while (len--) + { + SP_SET (len, SCM_CAR (vals)); + vals = SCM_CDR (vals); + } + NEXT (1); + } else - RETURN_ONE_VALUE (ret); + { + ALLOC_FRAME (2); + SP_SET (0, ret); + NEXT (1); + } } /* foreign-call cif-idx:12 ptr-idx:12 @@ -864,10 +807,23 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, CACHE_SP (); if (SCM_UNLIKELY (SCM_VALUESP (ret))) - /* multiple values returned to continuation */ - RETURN_VALUE_LIST (scm_struct_ref (ret, SCM_INUM0)); + { + SCM vals = scm_struct_ref (ret, SCM_INUM0); + long len = scm_ilength (vals); + ALLOC_FRAME (1 + len); + while (len--) + { + SP_SET (len, SCM_CAR (vals)); + vals = SCM_CDR (vals); + } + NEXT (1); + } else - RETURN_ONE_VALUE (ret); + { + ALLOC_FRAME (2); + SP_SET (0, ret); + NEXT (1); + } } /* continuation-call contregs:24 @@ -936,8 +892,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, int i, list_idx, list_len, nlocals; SCM list; - VM_HANDLE_INTERRUPTS; - nlocals = FRAME_LOCALS_COUNT (); // At a minimum, there should be apply, f, and the list. VM_ASSERT (nlocals >= 3, abort ()); @@ -983,8 +937,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, scm_t_dynstack *dynstack; int first; - VM_HANDLE_INTERRUPTS; - SYNC_IP (); dynstack = scm_dynstack_capture_all (&thread->dynstack); vm_cont = scm_i_vm_capture_stack (vp->stack_top, @@ -1407,8 +1359,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, { scm_t_int32 offset = op; offset >>= 8; /* Sign-extending shift. */ - if (offset <= 0) - VM_HANDLE_INTERRUPTS; NEXT (offset); } @@ -3704,8 +3654,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, { \ scm_t_int32 offset = ip[2]; \ offset >>= 8; /* Sign-extending shift. */ \ - if (offset <= 0) \ - VM_HANDLE_INTERRUPTS; \ NEXT (offset); \ } \ NEXT (3); \ @@ -3720,8 +3668,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, { \ scm_t_int32 offset = ip[2]; \ offset >>= 8; /* Sign-extending shift. */ \ - if (offset <= 0) \ - VM_HANDLE_INTERRUPTS; \ NEXT (offset); \ } \ NEXT (3); \ @@ -3926,7 +3872,18 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, */ VM_DEFINE_OP (183, handle_interrupts, "handle-interrupts", OP1 (X32)) { - VM_HANDLE_INTERRUPTS; + /* TODO: Invoke asyncs without trampolining out to C. That will + let us preempt computations via an asynchronous interrupt. */ + if (SCM_LIKELY (thread->block_asyncs == 0)) + { + SCM asyncs = scm_atomic_ref_scm (&thread->pending_asyncs); + if (SCM_UNLIKELY (!scm_is_null (asyncs))) + { + SYNC_IP (); + scm_async_tick (); + CACHE_SP (); + } + } NEXT (1); } @@ -4045,8 +4002,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, #undef POP_CONTINUATION_HOOK #undef PUSH_CONTINUATION_HOOK #undef RETURN -#undef RETURN_ONE_VALUE -#undef RETURN_VALUE_LIST #undef RUN_HOOK #undef RUN_HOOK0 #undef RUN_HOOK1 From 705e3a83c85b51876f644a55a90863aafe0b6be6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 18 Nov 2016 21:14:56 +0100 Subject: [PATCH 613/865] Remove SCM_DEBUG_CELL_ACCESSES==1 Since the move to BDW-GC this option has not been useful. * libguile/__scm.h (SCM_DEBUG_CELL_ACCESSES): Remove default definition. * libguile/gc.h: Add comment about cells. (SCM_VALIDATE_CELL): Remove. I did a search on the internet and I found no external users. (SCM_CELL_WORD, SCM_CELL_OBJECT, SCM_SET_CELL_WORD) (SCM_SET_CELL_OBJECT, SCM_CELL_OBJECT_LOC): Remove SCM_VALIDATE_CELL uses. * libguile/gc.c (scm_debug_cell_accesses_p) (scm_expensive_debug_cell_accesses_p) (scm_debug_cells_gc_interval, scm_i_expensive_validation_check) (scm_assert_cell_valid): Remove bindings only available when SCM_DEBUG_CELL_ACCESSES was 1. * libguile/list.c (scm_list_n): Remove SCM_VALIDATE_CELL usage. --- libguile/__scm.h | 9 --- libguile/gc.c | 140 ++--------------------------------------------- libguile/gc.h | 54 ++++-------------- libguile/list.c | 4 -- 4 files changed, 16 insertions(+), 191 deletions(-) diff --git a/libguile/__scm.h b/libguile/__scm.h index 1ea4822a6..dde26be05 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -248,15 +248,6 @@ #define SCM_DEBUG 0 #endif -/* If SCM_DEBUG_CELL_ACCESSES is set to 1, cell accesses will perform - * exhaustive parameter checking: It will be verified that cell parameters - * actually point to a valid heap cell. Note: If this option is enabled, - * guile will run about ten times slower than normally. - */ -#ifndef SCM_DEBUG_CELL_ACCESSES -#define SCM_DEBUG_CELL_ACCESSES SCM_DEBUG -#endif - /* If SCM_DEBUG_PAIR_ACCESSES is set to 1, accesses to cons cells will be * exhaustively checked. Note: If this option is enabled, guile will run * slower than normally. diff --git a/libguile/gc.c b/libguile/gc.c index 6044753ce..4ef858c84 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -89,108 +89,6 @@ int scm_debug_cells_gc_interval = 0; static SCM scm_protects; -#if (SCM_DEBUG_CELL_ACCESSES == 1) - - -/* - - Assert that the given object is a valid reference to a valid cell. This - test involves to determine whether the object is a cell pointer, whether - this pointer actually points into a heap segment and whether the cell - pointed to is not a free cell. Further, additional garbage collections may - get executed after a user defined number of cell accesses. This helps to - find places in the C code where references are dropped for extremely short - periods. - -*/ -void -scm_i_expensive_validation_check (SCM cell) -{ - /* If desired, perform additional garbage collections after a user - * defined number of cell accesses. - */ - if (scm_debug_cells_gc_interval) - { - static unsigned int counter = 0; - - if (counter != 0) - { - --counter; - } - else - { - counter = scm_debug_cells_gc_interval; - scm_gc (); - } - } -} - -/* Whether cell validation is already running. */ -static int scm_i_cell_validation_already_running = 0; - -void -scm_assert_cell_valid (SCM cell) -{ - if (!scm_i_cell_validation_already_running && scm_debug_cell_accesses_p) - { - scm_i_cell_validation_already_running = 1; /* set to avoid recursion */ - - /* - During GC, no user-code should be run, and the guile core - should use non-protected accessors. - */ - if (scm_gc_running_p) - return; - - /* - Only scm_in_heap_p and rescanning the heap is wildly - expensive. - */ - if (scm_expensive_debug_cell_accesses_p) - scm_i_expensive_validation_check (cell); - - scm_i_cell_validation_already_running = 0; /* re-enable */ - } -} - - - -SCM_DEFINE (scm_set_debug_cell_accesses_x, "set-debug-cell-accesses!", 1, 0, 0, - (SCM flag), - "If @var{flag} is @code{#f}, cell access checking is disabled.\n" - "If @var{flag} is @code{#t}, cheap cell access checking is enabled,\n" - "but no additional calls to garbage collection are issued.\n" - "If @var{flag} is a number, strict cell access checking is enabled,\n" - "with an additional garbage collection after the given\n" - "number of cell accesses.\n" - "This procedure only exists when the compile-time flag\n" - "@code{SCM_DEBUG_CELL_ACCESSES} was set to 1.") -#define FUNC_NAME s_scm_set_debug_cell_accesses_x -{ - if (scm_is_false (flag)) - { - scm_debug_cell_accesses_p = 0; - } - else if (scm_is_eq (flag, SCM_BOOL_T)) - { - scm_debug_cells_gc_interval = 0; - scm_debug_cell_accesses_p = 1; - scm_expensive_debug_cell_accesses_p = 0; - } - else - { - scm_debug_cells_gc_interval = scm_to_signed_integer (flag, 0, INT_MAX); - scm_debug_cell_accesses_p = 1; - scm_expensive_debug_cell_accesses_p = 1; - } - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -#endif /* SCM_DEBUG_CELL_ACCESSES == 1 */ - - static int needs_gc_after_nonlocal_exit = 0; @@ -679,42 +577,12 @@ queue_after_gc_hook (void * hook_data SCM_UNUSED, void *fn_data SCM_UNUSED, void *data SCM_UNUSED) { - /* If cell access debugging is enabled, the user may choose to perform - * additional garbage collections after an arbitrary number of cell - * accesses. We don't want the scheme level after-gc-hook to be performed - * for each of these garbage collections for the following reason: The - * execution of the after-gc-hook causes cell accesses itself. Thus, if the - * after-gc-hook was performed with every gc, and if the gc was performed - * after a very small number of cell accesses, then the number of cell - * accesses during the execution of the after-gc-hook will suffice to cause - * the execution of the next gc. Then, guile would keep executing the - * after-gc-hook over and over again, and would never come to do other - * things. - * - * To overcome this problem, if cell access debugging with additional - * garbage collections is enabled, the after-gc-hook is never run by the - * garbage collecter. When running guile with cell access debugging and the - * execution of the after-gc-hook is desired, then it is necessary to run - * the hook explicitly from the user code. This has the effect, that from - * the scheme level point of view it seems that garbage collection is - * performed with a much lower frequency than it actually is. Obviously, - * this will not work for code that depends on a fixed one to one - * relationship between the execution counts of the C level garbage - * collection hooks and the execution count of the scheme level - * after-gc-hook. - */ + scm_i_thread *t = SCM_I_CURRENT_THREAD; -#if (SCM_DEBUG_CELL_ACCESSES == 1) - if (scm_debug_cells_gc_interval == 0) -#endif + if (scm_is_false (SCM_CDR (after_gc_async_cell))) { - scm_i_thread *t = SCM_I_CURRENT_THREAD; - - if (scm_is_false (SCM_CDR (after_gc_async_cell))) - { - SCM_SETCDR (after_gc_async_cell, t->pending_asyncs); - t->pending_asyncs = after_gc_async_cell; - } + SCM_SETCDR (after_gc_async_cell, t->pending_asyncs); + t->pending_asyncs = after_gc_async_cell; } return NULL; diff --git a/libguile/gc.h b/libguile/gc.h index 8b3ae79fd..734469929 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -30,6 +30,13 @@ #include "libguile/threads.h" +/* Before Guile 2.0, Guile had a custom garbage collector and memory + management system that largely worked in terms of "cells", two-word + heap-tagged objects. This is no longer the case, and the "cell" + concept is obsolete; the allocator can now make objects of any size. + Still, some old code uses "cell" to mean a two-word allocation, so + for that reason you'll see the word around Guile. */ + typedef struct scm_t_cell { SCM word_0; @@ -40,12 +47,6 @@ typedef struct scm_t_cell #define PTR2SCM(x) (SCM_PACK_POINTER (x)) #define SCM2PTR(x) ((scm_t_cell *) (SCM_UNPACK_POINTER (x))) -/* Low level cell data accessing macros. These macros should only be used - * from within code related to garbage collection issues, since they will - * never check the cells they are applied to - not even if guile is compiled - * in debug mode. In particular these macros will even work for free cells, - * which should never be encountered by user code. */ - #define SCM_GC_CELL_OBJECT(x, n) (((SCM *)SCM2PTR (x)) [n]) #define SCM_GC_CELL_WORD(x, n) (SCM_UNPACK (SCM_GC_CELL_OBJECT ((x), (n)))) @@ -55,49 +56,31 @@ typedef struct scm_t_cell #define SCM_GC_CELL_TYPE(x) (SCM_GC_CELL_OBJECT ((x), 0)) - -/* Except for the garbage collector, no part of guile should ever run over a - * free cell. Thus, if guile is compiled in debug mode the SCM_CELL_* and - * SCM_SET_CELL_* macros below report an error if they are applied to a free - * cell. Some other plausibility checks are also performed. However, if - * guile is not compiled in debug mode, there won't be any time penalty at all - * when using these macros. */ - -#if (SCM_DEBUG_CELL_ACCESSES == 1) -# define SCM_VALIDATE_CELL(cell, expr) (scm_assert_cell_valid (cell), (expr)) -#else -# define SCM_VALIDATE_CELL(cell, expr) (expr) -#endif - -#define SCM_CELL_WORD(x, n) \ - SCM_VALIDATE_CELL ((x), SCM_GC_CELL_WORD ((x), (n))) +#define SCM_CELL_WORD(x, n) SCM_GC_CELL_WORD ((x), (n)) #define SCM_CELL_WORD_0(x) SCM_CELL_WORD ((x), 0) #define SCM_CELL_WORD_1(x) SCM_CELL_WORD ((x), 1) #define SCM_CELL_WORD_2(x) SCM_CELL_WORD ((x), 2) #define SCM_CELL_WORD_3(x) SCM_CELL_WORD ((x), 3) -#define SCM_CELL_OBJECT(x, n) \ - SCM_VALIDATE_CELL ((x), SCM_GC_CELL_OBJECT ((x), (n))) +#define SCM_CELL_OBJECT(x, n) SCM_GC_CELL_OBJECT ((x), (n)) #define SCM_CELL_OBJECT_0(x) SCM_CELL_OBJECT ((x), 0) #define SCM_CELL_OBJECT_1(x) SCM_CELL_OBJECT ((x), 1) #define SCM_CELL_OBJECT_2(x) SCM_CELL_OBJECT ((x), 2) #define SCM_CELL_OBJECT_3(x) SCM_CELL_OBJECT ((x), 3) -#define SCM_SET_CELL_WORD(x, n, v) \ - SCM_VALIDATE_CELL ((x), SCM_GC_SET_CELL_WORD ((x), (n), (v))) +#define SCM_SET_CELL_WORD(x, n, v) SCM_GC_SET_CELL_WORD ((x), (n), (v)) #define SCM_SET_CELL_WORD_0(x, v) SCM_SET_CELL_WORD ((x), 0, (v)) #define SCM_SET_CELL_WORD_1(x, v) SCM_SET_CELL_WORD ((x), 1, (v)) #define SCM_SET_CELL_WORD_2(x, v) SCM_SET_CELL_WORD ((x), 2, (v)) #define SCM_SET_CELL_WORD_3(x, v) SCM_SET_CELL_WORD ((x), 3, (v)) -#define SCM_SET_CELL_OBJECT(x, n, v) \ - SCM_VALIDATE_CELL ((x), SCM_GC_SET_CELL_OBJECT ((x), (n), (v))) +#define SCM_SET_CELL_OBJECT(x, n, v) SCM_GC_SET_CELL_OBJECT ((x), (n), (v)) #define SCM_SET_CELL_OBJECT_0(x, v) SCM_SET_CELL_OBJECT ((x), 0, (v)) #define SCM_SET_CELL_OBJECT_1(x, v) SCM_SET_CELL_OBJECT ((x), 1, (v)) #define SCM_SET_CELL_OBJECT_2(x, v) SCM_SET_CELL_OBJECT ((x), 2, (v)) #define SCM_SET_CELL_OBJECT_3(x, v) SCM_SET_CELL_OBJECT ((x), 3, (v)) -#define SCM_CELL_OBJECT_LOC(x, n) (SCM_VALIDATE_CELL((x), &SCM_GC_CELL_OBJECT ((x), (n)))) +#define SCM_CELL_OBJECT_LOC(x, n) (&SCM_GC_CELL_OBJECT ((x), (n))) #define SCM_CARLOC(x) (SCM_CELL_OBJECT_LOC ((x), 0)) #define SCM_CDRLOC(x) (SCM_CELL_OBJECT_LOC ((x), 1)) @@ -105,15 +88,6 @@ typedef struct scm_t_cell #define SCM_SET_CELL_TYPE(x, t) SCM_SET_CELL_WORD_0 ((x), (t)) -#if (SCM_DEBUG_CELL_ACCESSES == 1) -/* Set this to != 0 if every cell that is accessed shall be checked: - */ -SCM_API int scm_debug_cell_accesses_p; -SCM_API int scm_expensive_debug_cell_accesses_p; -SCM_API int scm_debug_cells_gc_interval ; -SCM_API void scm_i_expensive_validation_check (SCM cell); -#endif - SCM_INTERNAL scm_i_pthread_mutex_t scm_i_gc_admin_mutex; #define scm_gc_running_p 0 @@ -138,10 +112,6 @@ SCM_API scm_t_c_hook scm_after_gc_c_hook; -#if (SCM_DEBUG_CELL_ACCESSES == 1) -SCM_API void scm_assert_cell_valid (SCM); -#endif - SCM_API SCM scm_set_debug_cell_accesses_x (SCM flag); diff --git a/libguile/list.c b/libguile/list.c index 27ac22f2b..e5036ed8d 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -89,10 +89,6 @@ scm_list_n (SCM elt, ...) va_start (foo, elt); while (! SCM_UNBNDP (elt)) { -#if (SCM_DEBUG_CELL_ACCESSES == 1) - if (SCM_HEAP_OBJECT_P (elt)) - SCM_VALIDATE_CELL(elt, 0); -#endif *pos = scm_cons (elt, SCM_EOL); pos = SCM_CDRLOC (*pos); elt = va_arg (foo, SCM); From 4ae49889317f31f664a161035e14ad534624dc50 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 18 Nov 2016 22:15:28 +0100 Subject: [PATCH 614/865] Refactor async handling to be FIFO * libguile/async.c (scm_i_async_push, scm_i_async_pop): New helpers. (scm_async_tick, scm_system_async_mark_for_thread): Use the new helpers. --- libguile/async.c | 102 +++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 85 insertions(+), 17 deletions(-) diff --git a/libguile/async.c b/libguile/async.c index 92ed2f4d6..9123ec7c1 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -52,27 +52,101 @@ * Each thread has a list of 'activated asyncs', which is a normal * Scheme list of procedures with zero arguments. When a thread * executes an scm_async_tick (), it will call all procedures on this - * list. + * list in the order they were added to the list. */ +static void +scm_i_async_push (scm_i_thread *t, SCM proc) +{ + SCM asyncs; + + /* The usual algorithm you'd use for atomics with GC would be + something like: + + repeat + l = get(asyncs); + until swap(l, cons(proc, l)) + + But this is a LIFO list of asyncs, and that's not so great. To + make it FIFO, you'd do: + + repeat + l = get(asyncs); + until swap(l, append(l, list(proc))) + + However, some parts of Guile need to add entries to the async list + from a context in which allocation is unsafe, for example right + before GC or from a signal handler. They do that by pre-allocating + a pair, then when the interrupt fires the code does a setcdr of + that pair to the t->pending_asyncs and atomically updates + t->pending_asyncs. So the append strategy doesn't work. + + Instead to preserve the FIFO behavior we atomically cut off the + tail of the asyncs every time we want to run an interrupt, then + disable that newly-severed tail by setting its cdr to #f. Not so + nice, but oh well. */ + asyncs = scm_atomic_ref_scm (&t->pending_asyncs); + do + { + /* Traverse the asyncs list atomically. */ + SCM walk; + for (walk = asyncs; + scm_is_pair (walk); + walk = scm_atomic_ref_scm (SCM_CDRLOC (walk))) + if (scm_is_eq (SCM_CAR (walk), proc)) + return; + } + while (!scm_atomic_compare_and_swap_scm (&t->pending_asyncs, &asyncs, + scm_cons (proc, asyncs))); +} + +/* Precondition: there are pending asyncs. */ +static SCM +scm_i_async_pop (scm_i_thread *t) +{ + while (1) + { + SCM asyncs, last_pair, penultimate_pair; + + last_pair = asyncs = scm_atomic_ref_scm (&t->pending_asyncs); + penultimate_pair = SCM_BOOL_F; + + /* Since we are the only writer to cdrs of pairs in ASYNCS, and these + pairs were given to us after an atomic update to t->pending_asyncs, + no need to use atomic ops to traverse the list. */ + while (scm_is_pair (SCM_CDR (last_pair))) + { + penultimate_pair = last_pair; + last_pair = SCM_CDR (last_pair); + } + + /* Sever the tail. */ + if (scm_is_false (penultimate_pair)) + { + if (!scm_atomic_compare_and_swap_scm (&t->pending_asyncs, &asyncs, + SCM_EOL)) + continue; + } + else + scm_atomic_set_scm (SCM_CDRLOC (penultimate_pair), SCM_EOL); + + /* Disable it. */ + scm_atomic_set_scm (SCM_CDRLOC (last_pair), SCM_BOOL_F); + + return SCM_CAR (last_pair); + } +} void scm_async_tick (void) { scm_i_thread *t = SCM_I_CURRENT_THREAD; - SCM asyncs; if (t->block_asyncs) return; - asyncs = scm_atomic_swap_scm (&t->pending_asyncs, SCM_EOL); - while (!scm_is_null (asyncs)) - { - SCM next = scm_cdr (asyncs); - scm_call_0 (scm_car (asyncs)); - scm_set_cdr_x (asyncs, SCM_BOOL_F); - asyncs = next; - } + while (!scm_is_null (scm_atomic_ref_scm (&t->pending_asyncs))) + scm_call_0 (scm_i_async_pop (t)); } struct scm_thread_wake_data { @@ -115,7 +189,6 @@ SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0, #define FUNC_NAME s_scm_system_async_mark_for_thread { scm_i_thread *t; - SCM asyncs; struct scm_thread_wake_data *wake; if (SCM_UNBNDP (thread)) @@ -128,12 +201,7 @@ SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0, t = SCM_I_THREAD_DATA (thread); } - asyncs = scm_atomic_ref_scm (&t->pending_asyncs); - do - if (scm_is_true (scm_c_memq (proc, asyncs))) - return SCM_UNSPECIFIED; - while (!scm_atomic_compare_and_swap_scm (&t->pending_asyncs, &asyncs, - scm_cons (proc, asyncs))); + scm_i_async_push (t, proc); /* At this point the async is enqueued. However if the thread is sleeping, we have to wake it up. */ From 08584310ee5fc254854ef98bb2c5f4da3063f9c9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 18 Nov 2016 23:04:57 +0100 Subject: [PATCH 615/865] Inline interrupts * libguile/async.c: * libguile/async.h (scm_i_async_push, scm_i_async_pop): Make internally available. * libguile/vm-engine.c (vm_engine): Invoke interrupts inline. Add return-from-interrupt instruction. * libguile/vm.c (vm_handle_interrupt_code): New "builtin". --- libguile/async.c | 4 +-- libguile/async.h | 3 +++ libguile/vm-engine.c | 62 ++++++++++++++++++++++++++++++++++---------- libguile/vm.c | 7 +++++ 4 files changed, 60 insertions(+), 16 deletions(-) diff --git a/libguile/async.c b/libguile/async.c index 9123ec7c1..b9dc78442 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -55,7 +55,7 @@ * list in the order they were added to the list. */ -static void +void scm_i_async_push (scm_i_thread *t, SCM proc) { SCM asyncs; @@ -101,7 +101,7 @@ scm_i_async_push (scm_i_thread *t, SCM proc) } /* Precondition: there are pending asyncs. */ -static SCM +SCM scm_i_async_pop (scm_i_thread *t) { while (1) diff --git a/libguile/async.h b/libguile/async.h index 343cc2ae6..1a40a83bd 100644 --- a/libguile/async.h +++ b/libguile/async.h @@ -46,6 +46,9 @@ SCM_API void *scm_c_call_with_unblocked_asyncs (void *(*p) (void *d), void *d); SCM_API void scm_dynwind_block_asyncs (void); SCM_API void scm_dynwind_unblock_asyncs (void); +SCM_INTERNAL void scm_i_async_push (scm_i_thread *t, SCM proc); +SCM_INTERNAL SCM scm_i_async_pop (scm_i_thread *t); + SCM_INTERNAL void scm_init_async (void); #endif /* SCM_ASYNC_H */ diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index ac8f32e49..cfb60f242 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -3872,22 +3872,56 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, */ VM_DEFINE_OP (183, handle_interrupts, "handle-interrupts", OP1 (X32)) { - /* TODO: Invoke asyncs without trampolining out to C. That will - let us preempt computations via an asynchronous interrupt. */ - if (SCM_LIKELY (thread->block_asyncs == 0)) - { - SCM asyncs = scm_atomic_ref_scm (&thread->pending_asyncs); - if (SCM_UNLIKELY (!scm_is_null (asyncs))) - { - SYNC_IP (); - scm_async_tick (); - CACHE_SP (); - } - } - NEXT (1); + if (SCM_LIKELY (scm_is_null + (scm_atomic_ref_scm (&thread->pending_asyncs)))) + NEXT (1); + + if (thread->block_asyncs > 0) + NEXT (1); + + { + union scm_vm_stack_element *old_fp; + size_t old_frame_size = FRAME_LOCALS_COUNT (); + SCM proc = scm_i_async_pop (thread); + + /* No PUSH_CONTINUATION_HOOK, as we can't usefully + POP_CONTINUATION_HOOK because there are no return values. */ + + /* Three slots: two for RA and dynamic link, one for proc. */ + ALLOC_FRAME (old_frame_size + 3); + + /* Set up a frame that will return right back to this + handle-interrupts opcode to handle any additional + interrupts. */ + old_fp = vp->fp; + vp->fp = SCM_FRAME_SLOT (old_fp, old_frame_size + 1); + SCM_FRAME_SET_DYNAMIC_LINK (vp->fp, old_fp); + SCM_FRAME_SET_RETURN_ADDRESS (vp->fp, ip); + + SP_SET (0, proc); + + ip = (scm_t_uint32 *) vm_handle_interrupt_code; + + APPLY_HOOK (); + + NEXT (0); + } + } + + /* return-from-interrupt _:24 + * + * Return from handling an interrupt, discarding any return values and + * stripping away the interrupt frame. + */ + VM_DEFINE_OP (184, return_from_interrupt, "return-from-interrupt", OP1 (X32)) + { + vp->sp = sp = SCM_FRAME_PREVIOUS_SP (vp->fp); + ip = SCM_FRAME_RETURN_ADDRESS (vp->fp); + vp->fp = SCM_FRAME_DYNAMIC_LINK (vp->fp); + + NEXT (0); } - VM_DEFINE_OP (184, unused_184, NULL, NOP) VM_DEFINE_OP (185, unused_185, NULL, NOP) VM_DEFINE_OP (186, unused_186, NULL, NOP) VM_DEFINE_OP (187, unused_187, NULL, NOP) diff --git a/libguile/vm.c b/libguile/vm.c index 86e1a0576..3c616205b 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -666,6 +666,13 @@ static const scm_t_uint32 vm_builtin_call_with_current_continuation_code[] = { SCM_PACK_OP_24 (call_cc, 0) }; +static const scm_t_uint32 vm_handle_interrupt_code[] = { + SCM_PACK_OP_24 (alloc_frame, 3), + SCM_PACK_OP_12_12 (mov, 0, 2), + SCM_PACK_OP_24 (call, 2), SCM_PACK_OP_ARG_8_24 (0, 1), + SCM_PACK_OP_24 (return_from_interrupt, 0) +}; + int scm_i_vm_is_boot_continuation_code (scm_t_uint32 *ip) From 1e925119969ea58396c79ab8e6c6c0130471eb22 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 19 Nov 2016 14:54:44 +0100 Subject: [PATCH 616/865] Add asyncs test * test-suite/tests/asyncs.test: New file. --- test-suite/tests/asyncs.test | 138 +++++++++++++++++++++++++++++++++++ 1 file changed, 138 insertions(+) create mode 100644 test-suite/tests/asyncs.test diff --git a/test-suite/tests/asyncs.test b/test-suite/tests/asyncs.test new file mode 100644 index 000000000..437927a81 --- /dev/null +++ b/test-suite/tests/asyncs.test @@ -0,0 +1,138 @@ +;;;; asyncs.test -*- mode: scheme; coding: utf-8; -*- +;;;; +;;;; Copyright (C) 2016 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-asyncs) + #:use-module (ice-9 control) + #:use-module (ice-9 q) + #:use-module (ice-9 atomic) + #:use-module (ice-9 threads) + #:use-module (test-suite lib)) + + +(with-test-prefix "interrupts" + (pass-if-equal "self-interruptable v1" 42 + (let/ec break + (let lp ((n 0)) + (when (= n 10) + (system-async-mark (lambda () (break 42)))) + (lp (1+ n))))) + + (pass-if-equal "self-interruptable v2" 42 + (let/ec break + (begin + (system-async-mark (lambda () (break 42))) + (let lp () (lp)))))) + +(define (with-sigprof-interrupts hz interrupt proc) + (let ((prev-handler #f) + (period-usecs (inexact->exact (round (/ 1e6 hz))))) + (define (profile-signal-handler _) (interrupt)) + (dynamic-wind + (lambda () + (set! prev-handler (car (sigaction SIGPROF profile-signal-handler))) + (setitimer ITIMER_PROF 0 period-usecs 0 period-usecs)) + proc + (lambda () + (setitimer ITIMER_PROF 0 0 0 0) + (sigaction SIGPROF prev-handler))))) + +(when (defined? 'setitimer) + (pass-if "preemption via sigprof" + ;; Use an atomic box as a compiler barrier. + (let* ((box (make-atomic-box 0)) + (preempt-tag (make-prompt-tag)) + (runqueue (make-q))) + (define (run-cothreads) + (unless (q-empty? runqueue) + (let ((k (deq! runqueue))) + (call-with-prompt preempt-tag + k + (lambda (k) (enq! runqueue k)))) + (run-cothreads))) + (enq! runqueue (lambda () + (let lp () + (let ((x (atomic-box-ref box))) + (unless (= x 100) + (when (even? x) + (atomic-box-set! box (1+ x))) + (lp)))))) + (enq! runqueue (lambda () + (let lp () + (let ((x (atomic-box-ref box))) + (unless (= x 100) + (when (odd? x) + (atomic-box-set! box (1+ x))) + (lp)))))) + (with-sigprof-interrupts + 1000 ; Hz + (lambda () + ;; Could throw an exception if the prompt is + ;; not active (i.e. interrupt happens + ;; outside running a cothread). Ignore in + ;; that case. + (false-if-exception (abort-to-prompt preempt-tag))) + run-cothreads) + (equal? (atomic-box-ref box) 100)))) + +(when (provided? 'threads) + (pass-if "preemption via external thread" + ;; Use an atomic box as a compiler barrier. + (let* ((box (make-atomic-box 0)) + (preempt-tag (make-prompt-tag)) + (runqueue (make-q))) + (define (run-cothreads) + (unless (q-empty? runqueue) + (let ((k (deq! runqueue))) + (call-with-prompt preempt-tag + k + (lambda (k) (enq! runqueue k)))) + (run-cothreads))) + (enq! runqueue (lambda () + (let lp () + (let ((x (atomic-box-ref box))) + (unless (= x 100) + (when (even? x) + (atomic-box-set! box (1+ x))) + (lp)))))) + (enq! runqueue (lambda () + (let lp () + (let ((x (atomic-box-ref box))) + (unless (= x 100) + (when (odd? x) + (atomic-box-set! box (1+ x))) + (lp)))))) + (let* ((main-thread (current-thread)) + (preempt-thread (call-with-new-thread + (lambda () + (let lp () + (unless (= (atomic-box-ref box) 100) + (usleep 1000) + (system-async-mark + (lambda () + ;; Could throw an exception if the + ;; prompt is not active + ;; (i.e. interrupt happens outside + ;; running a cothread). Ignore in + ;; that case. + (false-if-exception + (abort-to-prompt preempt-tag))) + main-thread) + (lp))))))) + (run-cothreads) + (join-thread preempt-thread) + (equal? (atomic-box-ref box) 100))))) From f927c70d4280a9644b9997108d67da2addb3eb65 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 21 Nov 2016 18:34:41 +0100 Subject: [PATCH 617/865] Update join-thread docs * doc/ref/api-scheduling.texi (Threads): Joining a foreign thread is an error. * NEWS: Update. --- NEWS | 9 ++++++++- doc/ref/api-scheduling.texi | 16 +++++++++------- 2 files changed, 17 insertions(+), 8 deletions(-) diff --git a/NEWS b/NEWS index 92217395f..05acbf125 100644 --- a/NEWS +++ b/NEWS @@ -54,7 +54,7 @@ deprecated; use `scm_timed_lock_mutex' instead. It used to be that `unlock-mutex' included `wait-condition-variable' functionality. This has been deprecated; use SRFI-18 if you want this -behavior from `mutex-unlock!'. Relatedly, `scm_unlock_mutex_timed is +behavior from `mutex-unlock!'. Relatedly, `scm_unlock_mutex_timed' is deprecated; use `scm_unlock_mutex' instead. ** Removed `unchecked-unlock' mutex flag @@ -73,6 +73,13 @@ The `set-thread-cleanup!' and `thread-cleanup' functions that were added in Guile 2.0 to support cleanup after thread cancellation are no longer needed, since threads can declare cleanup handlers via `dynamic-wind'. +** Only threads created by Guile are joinable + +`join-thread' used to work on "foreign" threads that were not created by +Guile itself, though their join value was always `#f'. This is no +longer the case; attempting to join a foreign thread will throw an +error. + * New deprecations ** Arbiters deprecated diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index 1f5d17f09..1087bfeec 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -88,13 +88,15 @@ Return @code{#t} ff @var{obj} is a thread; otherwise, return @deffn {Scheme Procedure} join-thread thread [timeout [timeoutval]] @deffnx {C Function} scm_join_thread (thread) @deffnx {C Function} scm_join_thread_timed (thread, timeout, timeoutval) -Wait for @var{thread} to terminate and return its exit value. Threads -that have not been created with @code{call-with-new-thread} or -@code{scm_spawn_thread} have an exit value of @code{#f}. When -@var{timeout} is given, it specifies a point in time where the waiting -should be aborted. It can be either an integer as returned by -@code{current-time} or a pair as returned by @code{gettimeofday}. -When the waiting is aborted, @var{timeoutval} is returned (if it is +Wait for @var{thread} to terminate and return its exit value. Only +threads that were created with @code{call-with-new-thread} or +@code{scm_spawn_thread} can be joinable; attempting to join a foreign +thread will raise an error. + +When @var{timeout} is given, it specifies a point in time where the +waiting should be aborted. It can be either an integer as returned by +@code{current-time} or a pair as returned by @code{gettimeofday}. When +the waiting is aborted, @var{timeoutval} is returned (if it is specified; @code{#f} is returned otherwise). @end deffn From dc2a5602648bfbaaa9e3271145adb55951daad26 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 21 Nov 2016 23:06:14 +0100 Subject: [PATCH 618/865] Deprecate dynamic roots * libguile/root.h: * libguile/root.c: Remove these files. * libguile/deprecated.h: * libguile/deprecated.c (scm_internal_cwdr, scm_call_with_dynamic_root) (scm_dynamic_root, scm_apply_with_dynamic_root): Deprecate. Remove all root.h usage, which was vestigial. * module/ice-9/serialize.scm: Use (current-thread) instead of (dynamic-root). --- NEWS | 6 ++ libguile.h | 1 - libguile/Makefile.am | 4 - libguile/array-map.c | 1 - libguile/arrays.c | 1 - libguile/async.c | 1 - libguile/async.h | 1 - libguile/continuations.c | 1 - libguile/debug.c | 1 - libguile/deprecated.c | 156 +++++++++++++++++++++++++++++ libguile/deprecated.h | 12 +++ libguile/eq.c | 1 - libguile/eval.c | 1 - libguile/feature.c | 1 - libguile/fluids.h | 1 - libguile/gc-malloc.c | 1 - libguile/gc.c | 1 - libguile/guardians.c | 1 - libguile/hashtab.c | 1 - libguile/hooks.c | 1 - libguile/init.c | 1 - libguile/keywords.c | 1 - libguile/load.c | 1 - libguile/numbers.c | 1 - libguile/objprop.c | 1 - libguile/ports.c | 1 - libguile/print.c | 1 - libguile/procprop.c | 1 - libguile/promises.c | 1 - libguile/rdelim.c | 1 - libguile/read.c | 1 - libguile/root.c | 200 ------------------------------------- libguile/root.h | 48 --------- libguile/rw.c | 1 - libguile/scmsigs.c | 1 - libguile/srcprop.c | 1 - libguile/stackchk.c | 1 - libguile/stacks.c | 1 - libguile/strings.c | 1 - libguile/strports.c | 1 - libguile/threads.c | 1 - libguile/threads.h | 1 - libguile/values.c | 1 - libguile/variable.c | 1 - libguile/vectors.c | 1 - libguile/vports.c | 1 - module/ice-9/serialize.scm | 10 +- 47 files changed, 179 insertions(+), 297 deletions(-) delete mode 100644 libguile/root.c delete mode 100644 libguile/root.h diff --git a/NEWS b/NEWS index 05acbf125..941f411f0 100644 --- a/NEWS +++ b/NEWS @@ -109,6 +109,12 @@ scm_dynwind_block_asyncs. Use `scm_make_mutex_with_kind' instead. See "Mutexes and Condition Variables" in the manual, for more. +** Dynamic roots deprecated + +This was a facility that predated threads, was unused as far as we can +tell, and was never documented. Still, a grep of your code for +dynamic-root or dynamic_root would not be amiss. + * Bug fixes ** cancel-thread uses asynchronous interrupts, not pthread_cancel diff --git a/libguile.h b/libguile.h index 0a1f0dcd6..3f7f0b791 100644 --- a/libguile.h +++ b/libguile.h @@ -88,7 +88,6 @@ extern "C" { #include "libguile/r6rs-ports.h" #include "libguile/random.h" #include "libguile/read.h" -#include "libguile/root.h" #include "libguile/scmsigs.h" #include "libguile/script.h" #include "libguile/simpos.h" diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 31cff7587..8bf9ddf59 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -192,7 +192,6 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ random.c \ rdelim.c \ read.c \ - root.c \ rw.c \ scmsigs.c \ script.c \ @@ -297,7 +296,6 @@ DOT_X_FILES = \ random.x \ rdelim.x \ read.x \ - root.x \ rw.x \ scmsigs.x \ script.x \ @@ -400,7 +398,6 @@ DOT_DOC_FILES = \ random.doc \ rdelim.doc \ read.doc \ - root.doc \ rw.doc \ scmsigs.doc \ script.doc \ @@ -644,7 +641,6 @@ modinclude_HEADERS = \ rdelim.h \ read.h \ regex-posix.h \ - root.h \ rw.h \ scmsigs.h \ script.h \ diff --git a/libguile/array-map.c b/libguile/array-map.c index 938f0a7b9..c028795a5 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -34,7 +34,6 @@ #include "libguile/eq.h" #include "libguile/eval.h" #include "libguile/feature.h" -#include "libguile/root.h" #include "libguile/vectors.h" #include "libguile/bitvectors.h" #include "libguile/srfi-4.h" diff --git a/libguile/arrays.c b/libguile/arrays.c index 52fe90a19..ea090d646 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -39,7 +39,6 @@ #include "libguile/eval.h" #include "libguile/fports.h" #include "libguile/feature.h" -#include "libguile/root.h" #include "libguile/strings.h" #include "libguile/srfi-13.h" #include "libguile/srfi-4.h" diff --git a/libguile/async.c b/libguile/async.c index b9dc78442..df8064107 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -27,7 +27,6 @@ #include "libguile/atomics-internal.h" #include "libguile/eval.h" #include "libguile/throw.h" -#include "libguile/root.h" #include "libguile/smob.h" #include "libguile/dynwind.h" #include "libguile/deprecation.h" diff --git a/libguile/async.h b/libguile/async.h index 1a40a83bd..c6d7202aa 100644 --- a/libguile/async.h +++ b/libguile/async.h @@ -25,7 +25,6 @@ #include "libguile/__scm.h" -#include "libguile/root.h" #include "libguile/threads.h" diff --git a/libguile/continuations.c b/libguile/continuations.c index 3e32749dc..5d146f4a1 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -30,7 +30,6 @@ #include "libguile/async.h" #include "libguile/debug.h" -#include "libguile/root.h" #include "libguile/stackchk.h" #include "libguile/smob.h" #include "libguile/ports.h" diff --git a/libguile/debug.c b/libguile/debug.c index dfc9bda30..c653cdf85 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -51,7 +51,6 @@ #include "libguile/dynwind.h" #include "libguile/modules.h" #include "libguile/ports.h" -#include "libguile/root.h" #include "libguile/fluids.h" #include "libguile/programs.h" #include "libguile/memoize.h" diff --git a/libguile/deprecated.c b/libguile/deprecated.c index 6da604e42..e94733806 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -730,6 +730,162 @@ scm_unlock_mutex_timed (SCM mx, SCM cond, SCM timeout) } + + +/* {call-with-dynamic-root} + * + * Suspending the current thread to evaluate a thunk on the + * same C stack but under a new root. + * + * Calls to call-with-dynamic-root return exactly once (unless + * the process is somehow exitted). */ + +/* cwdr fills out both of these structures, and then passes a pointer + to them through scm_internal_catch to the cwdr_body and + cwdr_handler functions, to tell them how to behave and to get + information back from them. + + A cwdr is a lot like a catch, except there is no tag (all + exceptions are caught), and the body procedure takes the arguments + passed to cwdr as A1 and ARGS. The handler is also special since + it is not directly run from scm_internal_catch. It is executed + outside the new dynamic root. */ + +struct cwdr_body_data { + /* Arguments to pass to the cwdr body function. */ + SCM a1, args; + + /* Scheme procedure to use as body of cwdr. */ + SCM body_proc; +}; + +struct cwdr_handler_data { + /* Do we need to run the handler? */ + int run_handler; + + /* The tag and args to pass it. */ + SCM tag, args; +}; + + +/* Invoke the body of a cwdr, assuming that the throw handler has + already been set up. DATA points to a struct set up by cwdr that + says what proc to call, and what args to apply it to. + + With a little thought, we could replace this with scm_body_thunk, + but I don't want to mess with that at the moment. */ +static SCM +cwdr_body (void *data) +{ + struct cwdr_body_data *c = (struct cwdr_body_data *) data; + + return scm_apply (c->body_proc, c->a1, c->args); +} + +/* Record the fact that the body of the cwdr has thrown. Record + enough information to invoke the handler later when the dynamic + root has been deestablished. */ + +static SCM +cwdr_handler (void *data, SCM tag, SCM args) +{ + struct cwdr_handler_data *c = (struct cwdr_handler_data *) data; + + c->run_handler = 1; + c->tag = tag; + c->args = args; + return SCM_UNSPECIFIED; +} + +SCM +scm_internal_cwdr (scm_t_catch_body body, void *body_data, + scm_t_catch_handler handler, void *handler_data, + SCM_STACKITEM *stack_start) +{ + struct cwdr_handler_data my_handler_data; + scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack; + SCM answer; + scm_t_dynstack *old_dynstack; + + /* Exit caller's dynamic state. + */ + old_dynstack = scm_dynstack_capture_all (dynstack); + scm_dynstack_unwind (dynstack, SCM_DYNSTACK_FIRST (dynstack)); + + scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE); + scm_dynwind_current_dynamic_state (scm_make_dynamic_state (SCM_UNDEFINED)); + + my_handler_data.run_handler = 0; + answer = scm_i_with_continuation_barrier (body, body_data, + cwdr_handler, &my_handler_data, + NULL, NULL); + + scm_dynwind_end (); + + /* Enter caller's dynamic state. + */ + scm_dynstack_wind (dynstack, SCM_DYNSTACK_FIRST (old_dynstack)); + + /* Now run the real handler iff the body did a throw. */ + if (my_handler_data.run_handler) + return handler (handler_data, my_handler_data.tag, my_handler_data.args); + else + return answer; +} + +/* The original CWDR for invoking Scheme code with a Scheme handler. */ + +static SCM +cwdr (SCM proc, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start) +{ + struct cwdr_body_data c; + + c.a1 = a1; + c.args = args; + c.body_proc = proc; + + return scm_internal_cwdr (cwdr_body, &c, + scm_handle_by_proc, &handler, + stack_start); +} + +SCM_DEFINE (scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0, + (SCM thunk, SCM handler), + "Call @var{thunk} with a new dynamic state and within\n" + "a continuation barrier. The @var{handler} catches all\n" + "otherwise uncaught throws and executes within the same\n" + "dynamic context as @var{thunk}.") +#define FUNC_NAME s_scm_call_with_dynamic_root +{ + SCM_STACKITEM stack_place; + scm_c_issue_deprecation_warning + ("call-with-dynamic-root is deprecated. There is no replacement."); + return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_dynamic_root, "dynamic-root", 0, 0, 0, + (), + "Return an object representing the current dynamic root.\n\n" + "These objects are only useful for comparison using @code{eq?}.\n") +#define FUNC_NAME s_scm_dynamic_root +{ + scm_c_issue_deprecation_warning + ("dynamic-root is deprecated. There is no replacement."); + return SCM_I_CURRENT_THREAD->continuation_root; +} +#undef FUNC_NAME + +SCM +scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler) +{ + SCM_STACKITEM stack_place; + scm_c_issue_deprecation_warning + ("scm_apply_with_dynamic_root is deprecated. There is no replacement."); + return cwdr (proc, a1, args, handler, &stack_place); +} + + void diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 211266f6d..782e84564 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -244,6 +244,18 @@ SCM_DEPRECATED SCM scm_lock_mutex_timed (SCM m, SCM timeout, SCM owner); +SCM_DEPRECATED SCM scm_internal_cwdr (scm_t_catch_body body, + void *body_data, + scm_t_catch_handler handler, + void *handler_data, + SCM_STACKITEM *stack_start); +SCM_DEPRECATED SCM scm_call_with_dynamic_root (SCM thunk, SCM handler); +SCM_DEPRECATED SCM scm_dynamic_root (void); +SCM_DEPRECATED SCM scm_apply_with_dynamic_root (SCM proc, SCM a1, + SCM args, SCM handler); + + + void scm_i_init_deprecated (void); #endif diff --git a/libguile/eq.c b/libguile/eq.c index 5a6f574d2..bbb061655 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -28,7 +28,6 @@ #include "libguile/stackchk.h" #include "libguile/strorder.h" #include "libguile/async.h" -#include "libguile/root.h" #include "libguile/smob.h" #include "libguile/arrays.h" #include "libguile/vectors.h" diff --git a/libguile/eval.c b/libguile/eval.c index a20572f01..87e6eacbf 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -51,7 +51,6 @@ #include "libguile/print.h" #include "libguile/procprop.h" #include "libguile/programs.h" -#include "libguile/root.h" #include "libguile/smob.h" #include "libguile/srcprop.h" #include "libguile/stackchk.h" diff --git a/libguile/feature.c b/libguile/feature.c index 9eb82ee7d..114d875a9 100644 --- a/libguile/feature.c +++ b/libguile/feature.c @@ -28,7 +28,6 @@ #endif #include "libguile/_scm.h" -#include "libguile/root.h" #include "libguile/strings.h" #include "libguile/validate.h" #include "libguile/fluids.h" diff --git a/libguile/fluids.h b/libguile/fluids.h index a550d9a34..2292e40e2 100644 --- a/libguile/fluids.h +++ b/libguile/fluids.h @@ -24,7 +24,6 @@ #include "libguile/__scm.h" -#include "libguile/root.h" #include "libguile/vectors.h" diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c index 894ca0668..586bf173d 100644 --- a/libguile/gc-malloc.c +++ b/libguile/gc-malloc.c @@ -43,7 +43,6 @@ extern unsigned long * __libc_ia64_register_backing_store_base; #include "libguile/arrays.h" #include "libguile/async.h" #include "libguile/ports.h" -#include "libguile/root.h" #include "libguile/strings.h" #include "libguile/vectors.h" #include "libguile/hashtab.h" diff --git a/libguile/gc.c b/libguile/gc.c index 4ef858c84..2b3bd36b0 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -45,7 +45,6 @@ extern unsigned long * __libc_ia64_register_backing_store_base; #include "libguile/arrays.h" #include "libguile/async.h" #include "libguile/ports.h" -#include "libguile/root.h" #include "libguile/simpos.h" #include "libguile/strings.h" #include "libguile/vectors.h" diff --git a/libguile/guardians.c b/libguile/guardians.c index 63b8ec0d5..cd4d9f3e2 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -54,7 +54,6 @@ #include "libguile/print.h" #include "libguile/smob.h" #include "libguile/validate.h" -#include "libguile/root.h" #include "libguile/hashtab.h" #include "libguile/deprecation.h" #include "libguile/eval.h" diff --git a/libguile/hashtab.c b/libguile/hashtab.c index 4b9874488..8920e08a6 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -31,7 +31,6 @@ #include "libguile/alist.h" #include "libguile/hash.h" #include "libguile/eval.h" -#include "libguile/root.h" #include "libguile/vectors.h" #include "libguile/ports.h" #include "libguile/bdw-gc.h" diff --git a/libguile/hooks.c b/libguile/hooks.c index 14335f879..2a953a9b7 100644 --- a/libguile/hooks.c +++ b/libguile/hooks.c @@ -28,7 +28,6 @@ #include "libguile/eval.h" #include "libguile/ports.h" #include "libguile/procprop.h" -#include "libguile/root.h" #include "libguile/smob.h" #include "libguile/strings.h" diff --git a/libguile/init.c b/libguile/init.c index 8b0813a1b..a8f690b62 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -412,7 +412,6 @@ scm_i_init_guile (void *base) scm_smob_prehistory (); scm_init_variable (); scm_init_continuations (); /* requires smob_prehistory */ - scm_init_root (); /* requires continuations */ scm_init_threads (); /* requires smob_prehistory */ scm_init_gsubr (); scm_init_procprop (); diff --git a/libguile/keywords.c b/libguile/keywords.c index cd9c9d8a8..2c6078942 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -29,7 +29,6 @@ #include "libguile/_scm.h" #include "libguile/async.h" #include "libguile/ports.h" -#include "libguile/root.h" #include "libguile/smob.h" #include "libguile/hashtab.h" diff --git a/libguile/load.c b/libguile/load.c index 7ad9a754d..7b8136af8 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -37,7 +37,6 @@ #include "libguile/loader.h" #include "libguile/modules.h" #include "libguile/read.h" -#include "libguile/root.h" #include "libguile/srfi-13.h" #include "libguile/strings.h" #include "libguile/throw.h" diff --git a/libguile/numbers.c b/libguile/numbers.c index d0f6e628d..bc930af3b 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -62,7 +62,6 @@ #include "libguile/_scm.h" #include "libguile/feature.h" #include "libguile/ports.h" -#include "libguile/root.h" #include "libguile/smob.h" #include "libguile/strings.h" #include "libguile/bdw-gc.h" diff --git a/libguile/objprop.c b/libguile/objprop.c index b45c9aa26..e9ddbe4d9 100644 --- a/libguile/objprop.c +++ b/libguile/objprop.c @@ -26,7 +26,6 @@ #include "libguile/async.h" #include "libguile/hashtab.h" #include "libguile/alist.h" -#include "libguile/root.h" #include "libguile/objprop.h" diff --git a/libguile/ports.c b/libguile/ports.c index 1209b439a..20319bc0b 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -51,7 +51,6 @@ #include "libguile/keywords.h" #include "libguile/hashtab.h" -#include "libguile/root.h" #include "libguile/strings.h" #include "libguile/mallocs.h" #include "libguile/validate.h" diff --git a/libguile/print.c b/libguile/print.c index 8161d6581..9669dcf06 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -44,7 +44,6 @@ #include "libguile/struct.h" #include "libguile/ports.h" #include "libguile/ports-internal.h" -#include "libguile/root.h" #include "libguile/strings.h" #include "libguile/strports.h" #include "libguile/vectors.h" diff --git a/libguile/procprop.c b/libguile/procprop.c index d45536062..ad56bd5ba 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -29,7 +29,6 @@ #include "libguile/procs.h" #include "libguile/gsubr.h" #include "libguile/smob.h" -#include "libguile/root.h" #include "libguile/vectors.h" #include "libguile/weak-table.h" #include "libguile/programs.h" diff --git a/libguile/promises.c b/libguile/promises.c index 3bbb489d2..3ed229443 100644 --- a/libguile/promises.c +++ b/libguile/promises.c @@ -49,7 +49,6 @@ #include "libguile/print.h" #include "libguile/procprop.h" #include "libguile/programs.h" -#include "libguile/root.h" #include "libguile/smob.h" #include "libguile/srcprop.h" #include "libguile/stackchk.h" diff --git a/libguile/rdelim.c b/libguile/rdelim.c index 9d1496795..80962bc5e 100644 --- a/libguile/rdelim.c +++ b/libguile/rdelim.c @@ -33,7 +33,6 @@ #include "libguile/modules.h" #include "libguile/ports.h" #include "libguile/rdelim.h" -#include "libguile/root.h" #include "libguile/strings.h" #include "libguile/strports.h" #include "libguile/validate.h" diff --git a/libguile/read.c b/libguile/read.c index f8205fbeb..c7da054b0 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -47,7 +47,6 @@ #include "libguile/ports.h" #include "libguile/ports-internal.h" #include "libguile/fports.h" -#include "libguile/root.h" #include "libguile/strings.h" #include "libguile/strports.h" #include "libguile/vectors.h" diff --git a/libguile/root.c b/libguile/root.c deleted file mode 100644 index c83da1c3c..000000000 --- a/libguile/root.c +++ /dev/null @@ -1,200 +0,0 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000, 2001, 2002, 2006, 2008, 2009, 2012 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 License - * as published by the Free Software Foundation; either version 3 of - * the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA - * 02110-1301 USA - */ - - - -#ifdef HAVE_CONFIG_H -# include -#endif - -#include -#include - -#include "libguile/_scm.h" -#include "libguile/stackchk.h" -#include "libguile/dynwind.h" -#include "libguile/eval.h" -#include "libguile/smob.h" -#include "libguile/pairs.h" -#include "libguile/throw.h" -#include "libguile/fluids.h" -#include "libguile/ports.h" - -#include "libguile/root.h" - - -/* {call-with-dynamic-root} - * - * Suspending the current thread to evaluate a thunk on the - * same C stack but under a new root. - * - * Calls to call-with-dynamic-root return exactly once (unless - * the process is somehow exitted). */ - -/* cwdr fills out both of these structures, and then passes a pointer - to them through scm_internal_catch to the cwdr_body and - cwdr_handler functions, to tell them how to behave and to get - information back from them. - - A cwdr is a lot like a catch, except there is no tag (all - exceptions are caught), and the body procedure takes the arguments - passed to cwdr as A1 and ARGS. The handler is also special since - it is not directly run from scm_internal_catch. It is executed - outside the new dynamic root. */ - -struct cwdr_body_data { - /* Arguments to pass to the cwdr body function. */ - SCM a1, args; - - /* Scheme procedure to use as body of cwdr. */ - SCM body_proc; -}; - -struct cwdr_handler_data { - /* Do we need to run the handler? */ - int run_handler; - - /* The tag and args to pass it. */ - SCM tag, args; -}; - - -/* Invoke the body of a cwdr, assuming that the throw handler has - already been set up. DATA points to a struct set up by cwdr that - says what proc to call, and what args to apply it to. - - With a little thought, we could replace this with scm_body_thunk, - but I don't want to mess with that at the moment. */ -static SCM -cwdr_body (void *data) -{ - struct cwdr_body_data *c = (struct cwdr_body_data *) data; - - return scm_apply (c->body_proc, c->a1, c->args); -} - -/* Record the fact that the body of the cwdr has thrown. Record - enough information to invoke the handler later when the dynamic - root has been deestablished. */ - -static SCM -cwdr_handler (void *data, SCM tag, SCM args) -{ - struct cwdr_handler_data *c = (struct cwdr_handler_data *) data; - - c->run_handler = 1; - c->tag = tag; - c->args = args; - return SCM_UNSPECIFIED; -} - -SCM -scm_internal_cwdr (scm_t_catch_body body, void *body_data, - scm_t_catch_handler handler, void *handler_data, - SCM_STACKITEM *stack_start) -{ - struct cwdr_handler_data my_handler_data; - scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack; - SCM answer; - scm_t_dynstack *old_dynstack; - - /* Exit caller's dynamic state. - */ - old_dynstack = scm_dynstack_capture_all (dynstack); - scm_dynstack_unwind (dynstack, SCM_DYNSTACK_FIRST (dynstack)); - - scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE); - scm_dynwind_current_dynamic_state (scm_make_dynamic_state (SCM_UNDEFINED)); - - my_handler_data.run_handler = 0; - answer = scm_i_with_continuation_barrier (body, body_data, - cwdr_handler, &my_handler_data, - NULL, NULL); - - scm_dynwind_end (); - - /* Enter caller's dynamic state. - */ - scm_dynstack_wind (dynstack, SCM_DYNSTACK_FIRST (old_dynstack)); - - /* Now run the real handler iff the body did a throw. */ - if (my_handler_data.run_handler) - return handler (handler_data, my_handler_data.tag, my_handler_data.args); - else - return answer; -} - -/* The original CWDR for invoking Scheme code with a Scheme handler. */ - -static SCM -cwdr (SCM proc, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start) -{ - struct cwdr_body_data c; - - c.a1 = a1; - c.args = args; - c.body_proc = proc; - - return scm_internal_cwdr (cwdr_body, &c, - scm_handle_by_proc, &handler, - stack_start); -} - -SCM_DEFINE (scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0, - (SCM thunk, SCM handler), - "Call @var{thunk} with a new dynamic state and within\n" - "a continuation barrier. The @var{handler} catches all\n" - "otherwise uncaught throws and executes within the same\n" - "dynamic context as @var{thunk}.") -#define FUNC_NAME s_scm_call_with_dynamic_root -{ - SCM_STACKITEM stack_place; - return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_dynamic_root, "dynamic-root", 0, 0, 0, - (), - "Return an object representing the current dynamic root.\n\n" - "These objects are only useful for comparison using @code{eq?}.\n") -#define FUNC_NAME s_scm_dynamic_root -{ - return SCM_I_CURRENT_THREAD->continuation_root; -} -#undef FUNC_NAME - -SCM -scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler) -{ - SCM_STACKITEM stack_place; - return cwdr (proc, a1, args, handler, &stack_place); -} - - - -void -scm_init_root () -{ -#include "libguile/root.x" -} - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ diff --git a/libguile/root.h b/libguile/root.h deleted file mode 100644 index 68ab5c7ce..000000000 --- a/libguile/root.h +++ /dev/null @@ -1,48 +0,0 @@ -/* classes: h_files */ - -#ifndef SCM_ROOT_H -#define SCM_ROOT_H - -/* Copyright (C) 1996,1998,2000,2001, 2002, 2006, 2008, 2009 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 License - * as published by the Free Software Foundation; either version 3 of - * the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA - * 02110-1301 USA - */ - - - -#include "libguile/__scm.h" -#include "libguile/debug.h" -#include "libguile/throw.h" - - - -SCM_API SCM scm_internal_cwdr (scm_t_catch_body body, - void *body_data, - scm_t_catch_handler handler, - void *handler_data, - SCM_STACKITEM *stack_start); -SCM_API SCM scm_call_with_dynamic_root (SCM thunk, SCM handler); -SCM_API SCM scm_dynamic_root (void); -SCM_API SCM scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler); -SCM_INTERNAL void scm_init_root (void); - -#endif /* SCM_ROOT_H */ - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ diff --git a/libguile/rw.c b/libguile/rw.c index 91941a4fb..16dee5802 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -30,7 +30,6 @@ #include "libguile/_scm.h" #include "libguile/fports.h" #include "libguile/ports.h" -#include "libguile/root.h" #include "libguile/rw.h" #include "libguile/strings.h" #include "libguile/validate.h" diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index d852e7101..da2c3d195 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -45,7 +45,6 @@ #include "libguile/async.h" #include "libguile/eval.h" -#include "libguile/root.h" #include "libguile/vectors.h" #include "libguile/threads.h" diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 963b2f881..9544f6857 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -33,7 +33,6 @@ #include "libguile/hashtab.h" #include "libguile/hash.h" #include "libguile/ports.h" -#include "libguile/root.h" #include "libguile/gc.h" #include "libguile/validate.h" diff --git a/libguile/stackchk.c b/libguile/stackchk.c index 146dac50f..96f72408d 100644 --- a/libguile/stackchk.c +++ b/libguile/stackchk.c @@ -24,7 +24,6 @@ #include "libguile/_scm.h" #include "libguile/ports.h" -#include "libguile/root.h" #include "libguile/threads.h" #include "libguile/dynwind.h" diff --git a/libguile/stacks.c b/libguile/stacks.c index 958103ad6..3d02d81f6 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -32,7 +32,6 @@ #include "libguile/macros.h" #include "libguile/procprop.h" #include "libguile/modules.h" -#include "libguile/root.h" #include "libguile/strings.h" #include "libguile/vm.h" /* to capture vm stacks */ #include "libguile/frames.h" /* vm frames */ diff --git a/libguile/strings.c b/libguile/strings.c index 232ddf90e..cdbc3587f 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -36,7 +36,6 @@ #include "libguile/_scm.h" #include "libguile/chars.h" -#include "libguile/root.h" #include "libguile/strings.h" #include "libguile/ports.h" #include "libguile/ports-internal.h" diff --git a/libguile/strports.c b/libguile/strports.c index e2bbe53ca..b12d6694a 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -33,7 +33,6 @@ #include "libguile/eval.h" #include "libguile/ports.h" #include "libguile/read.h" -#include "libguile/root.h" #include "libguile/strings.h" #include "libguile/modules.h" #include "libguile/validate.h" diff --git a/libguile/threads.c b/libguile/threads.c index 4b6d43c69..31a8cd48e 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -52,7 +52,6 @@ #include #include "libguile/validate.h" -#include "libguile/root.h" #include "libguile/eval.h" #include "libguile/async.h" #include "libguile/ports.h" diff --git a/libguile/threads.h b/libguile/threads.h index 986049c66..e8e56e71f 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -27,7 +27,6 @@ #include "libguile/__scm.h" #include "libguile/procs.h" #include "libguile/throw.h" -#include "libguile/root.h" #include "libguile/dynstack.h" #include "libguile/iselect.h" #include "libguile/continuations.h" diff --git a/libguile/values.c b/libguile/values.c index ef27cadd1..2b2ec3f51 100644 --- a/libguile/values.c +++ b/libguile/values.c @@ -26,7 +26,6 @@ #include "libguile/gc.h" #include "libguile/numbers.h" #include "libguile/ports.h" -#include "libguile/root.h" #include "libguile/strings.h" #include "libguile/struct.h" #include "libguile/validate.h" diff --git a/libguile/variable.c b/libguile/variable.c index b377b4140..c329bca1a 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -25,7 +25,6 @@ #include "libguile/_scm.h" #include "libguile/eq.h" #include "libguile/ports.h" -#include "libguile/root.h" #include "libguile/smob.h" #include "libguile/deprecation.h" diff --git a/libguile/vectors.c b/libguile/vectors.c index 5dab5454a..7ee7898c5 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -25,7 +25,6 @@ #include "libguile/_scm.h" #include "libguile/eq.h" -#include "libguile/root.h" #include "libguile/strings.h" #include "libguile/validate.h" diff --git a/libguile/vports.c b/libguile/vports.c index 0f3823bc2..29531cfb6 100644 --- a/libguile/vports.c +++ b/libguile/vports.c @@ -32,7 +32,6 @@ #include "libguile/ports.h" #include "libguile/ports-internal.h" #include "libguile/fports.h" -#include "libguile/root.h" #include "libguile/strings.h" #include "libguile/vectors.h" diff --git a/module/ice-9/serialize.scm b/module/ice-9/serialize.scm index 008a70a9e..340e56442 100644 --- a/module/ice-9/serialize.scm +++ b/module/ice-9/serialize.scm @@ -71,16 +71,16 @@ (lambda () (lock-mutex admin-mutex) (set! outer-owner owner) - (if (not (eqv? outer-owner (dynamic-root))) + (if (not (eqv? outer-owner (current-thread))) (begin (unlock-mutex admin-mutex) (lock-mutex serialization-mutex) - (set! owner (dynamic-root))) + (set! owner (current-thread))) (unlock-mutex admin-mutex))) thunk (lambda () (lock-mutex admin-mutex) - (if (not (eqv? outer-owner (dynamic-root))) + (if (not (eqv? outer-owner (current-thread))) (begin (set! owner #f) (unlock-mutex serialization-mutex))) @@ -95,7 +95,7 @@ (lambda () (lock-mutex admin-mutex) (set! outer-owner owner) - (if (eqv? outer-owner (dynamic-root)) + (if (eqv? outer-owner (current-thread)) (begin (set! owner #f) (unlock-mutex serialization-mutex))) @@ -103,7 +103,7 @@ thunk (lambda () (lock-mutex admin-mutex) - (if (eqv? outer-owner (dynamic-root)) + (if (eqv? outer-owner (current-thread)) (begin (unlock-mutex admin-mutex) (lock-mutex serialization-mutex) From 2b0ffb899bca6d78db06e212ab9f92ec22888405 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 22 Nov 2016 22:27:47 +0100 Subject: [PATCH 619/865] Add NEWS item about mutexes * NEWS: Add entry. --- NEWS | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/NEWS b/NEWS index 941f411f0..66fd2b03a 100644 --- a/NEWS +++ b/NEWS @@ -11,6 +11,13 @@ Changes in 2.1.5 (changes since the 2.1.4 alpha release): * Notable changes * New interfaces * Performance improvements +** Mutexes are now faster under contention + +Guile implements its own mutexes, so that threads that are trying to +acquire a mutex can be interrupted. These mutexes used to be quite +inefficient when many threads were trying to acquire them, causing many +spurious wakeups and contention. This has been fixed. + * Incompatible changes ** Threading facilities moved to (ice-9 threads) From 8b5f323330b0dcab0f48579a89a60f9a7cab1c64 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 22 Nov 2016 23:11:37 +0100 Subject: [PATCH 620/865] Merge api-{data,compound}.texi * doc/ref/api-compound.texi: Remove. * doc/ref/api-data.texi: Fold "Compound Data Types" and "Simple Data Types" into just "Data Types". The distinction didn't work. * doc/ref/guile.texi: * doc/ref/Makefile.am: * doc/ref/srfi-modules.texi: Adapt. --- doc/ref/Makefile.am | 1 - doc/ref/api-compound.texi | 4022 ----------------------------- doc/ref/api-data.texi | 4994 +++++++++++++++++++++++++++++++++---- doc/ref/guile.texi | 4 +- doc/ref/srfi-modules.texi | 4 +- 5 files changed, 4484 insertions(+), 4541 deletions(-) delete mode 100644 doc/ref/api-compound.texi diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index ada4f363b..05393cd96 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -75,7 +75,6 @@ guile_TEXINFOS = preface.texi \ r6rs.texi \ match.texi \ misc-modules.texi \ - api-compound.texi \ libguile-autoconf.texi \ autoconf-macros.texi \ tools.texi \ diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi deleted file mode 100644 index 8277b35cd..000000000 --- a/doc/ref/api-compound.texi +++ /dev/null @@ -1,4022 +0,0 @@ -@c -*-texinfo-*- -@c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, -@c 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. -@c See the file guile.texi for copying conditions. - -@node Compound Data Types -@section Compound Data Types - -This chapter describes Guile's compound data types. By @dfn{compound} -we mean that the primary purpose of these data types is to act as -containers for other kinds of data (including other compound objects). -For instance, a (non-uniform) vector with length 5 is a container that -can hold five arbitrary Scheme objects. - -The various kinds of container object differ from each other in how -their memory is allocated, how they are indexed, and how particular -values can be looked up within them. - -@menu -* Pairs:: Scheme's basic building block. -* Lists:: Special list functions supported by Guile. -* Vectors:: One-dimensional arrays of Scheme objects. -* Bit Vectors:: Vectors of bits. -* Arrays:: Matrices, etc. -* VLists:: Vector-like lists. -* Record Overview:: Walking through the maze of record APIs. -* SRFI-9 Records:: The standard, recommended record API. -* Records:: Guile's historical record API. -* Structures:: Low-level record representation. -* Dictionary Types:: About dictionary types in general. -* Association Lists:: List-based dictionaries. -* VHashes:: VList-based dictionaries. -* Hash Tables:: Table-based dictionaries. -@end menu - - -@node Pairs -@subsection Pairs -@tpindex Pairs - -Pairs are used to combine two Scheme objects into one compound object. -Hence the name: A pair stores a pair of objects. - -The data type @dfn{pair} is extremely important in Scheme, just like in -any other Lisp dialect. The reason is that pairs are not only used to -make two values available as one object, but that pairs are used for -constructing lists of values. Because lists are so important in Scheme, -they are described in a section of their own (@pxref{Lists}). - -Pairs can literally get entered in source code or at the REPL, in the -so-called @dfn{dotted list} syntax. This syntax consists of an opening -parentheses, the first element of the pair, a dot, the second element -and a closing parentheses. The following example shows how a pair -consisting of the two numbers 1 and 2, and a pair containing the symbols -@code{foo} and @code{bar} can be entered. It is very important to write -the whitespace before and after the dot, because otherwise the Scheme -parser would not be able to figure out where to split the tokens. - -@lisp -(1 . 2) -(foo . bar) -@end lisp - -But beware, if you want to try out these examples, you have to -@dfn{quote} the expressions. More information about quotation is -available in the section @ref{Expression Syntax}. The correct way -to try these examples is as follows. - -@lisp -'(1 . 2) -@result{} -(1 . 2) -'(foo . bar) -@result{} -(foo . bar) -@end lisp - -A new pair is made by calling the procedure @code{cons} with two -arguments. Then the argument values are stored into a newly allocated -pair, and the pair is returned. The name @code{cons} stands for -"construct". Use the procedure @code{pair?} to test whether a -given Scheme object is a pair or not. - -@rnindex cons -@deffn {Scheme Procedure} cons x y -@deffnx {C Function} scm_cons (x, y) -Return a newly allocated pair whose car is @var{x} and whose -cdr is @var{y}. The pair is guaranteed to be different (in the -sense of @code{eq?}) from every previously existing object. -@end deffn - -@rnindex pair? -@deffn {Scheme Procedure} pair? x -@deffnx {C Function} scm_pair_p (x) -Return @code{#t} if @var{x} is a pair; otherwise return -@code{#f}. -@end deffn - -@deftypefn {C Function} int scm_is_pair (SCM x) -Return 1 when @var{x} is a pair; otherwise return 0. -@end deftypefn - -The two parts of a pair are traditionally called @dfn{car} and -@dfn{cdr}. They can be retrieved with procedures of the same name -(@code{car} and @code{cdr}), and can be modified with the procedures -@code{set-car!} and @code{set-cdr!}. - -Since a very common operation in Scheme programs is to access the car of -a car of a pair, or the car of the cdr of a pair, etc., the procedures -called @code{caar}, @code{cadr} and so on are also predefined. However, -using these procedures is often detrimental to readability, and -error-prone. Thus, accessing the contents of a list is usually better -achieved using pattern matching techniques (@pxref{Pattern Matching}). - -@rnindex car -@rnindex cdr -@deffn {Scheme Procedure} car pair -@deffnx {Scheme Procedure} cdr pair -@deffnx {C Function} scm_car (pair) -@deffnx {C Function} scm_cdr (pair) -Return the car or the cdr of @var{pair}, respectively. -@end deffn - -@deftypefn {C Macro} SCM SCM_CAR (SCM pair) -@deftypefnx {C Macro} SCM SCM_CDR (SCM pair) -These two macros are the fastest way to access the car or cdr of a -pair; they can be thought of as compiling into a single memory -reference. - -These macros do no checking at all. The argument @var{pair} must be a -valid pair. -@end deftypefn - -@deffn {Scheme Procedure} cddr pair -@deffnx {Scheme Procedure} cdar pair -@deffnx {Scheme Procedure} cadr pair -@deffnx {Scheme Procedure} caar pair -@deffnx {Scheme Procedure} cdddr pair -@deffnx {Scheme Procedure} cddar pair -@deffnx {Scheme Procedure} cdadr pair -@deffnx {Scheme Procedure} cdaar pair -@deffnx {Scheme Procedure} caddr pair -@deffnx {Scheme Procedure} cadar pair -@deffnx {Scheme Procedure} caadr pair -@deffnx {Scheme Procedure} caaar pair -@deffnx {Scheme Procedure} cddddr pair -@deffnx {Scheme Procedure} cdddar pair -@deffnx {Scheme Procedure} cddadr pair -@deffnx {Scheme Procedure} cddaar pair -@deffnx {Scheme Procedure} cdaddr pair -@deffnx {Scheme Procedure} cdadar pair -@deffnx {Scheme Procedure} cdaadr pair -@deffnx {Scheme Procedure} cdaaar pair -@deffnx {Scheme Procedure} cadddr pair -@deffnx {Scheme Procedure} caddar pair -@deffnx {Scheme Procedure} cadadr pair -@deffnx {Scheme Procedure} cadaar pair -@deffnx {Scheme Procedure} caaddr pair -@deffnx {Scheme Procedure} caadar pair -@deffnx {Scheme Procedure} caaadr pair -@deffnx {Scheme Procedure} caaaar pair -@deffnx {C Function} scm_cddr (pair) -@deffnx {C Function} scm_cdar (pair) -@deffnx {C Function} scm_cadr (pair) -@deffnx {C Function} scm_caar (pair) -@deffnx {C Function} scm_cdddr (pair) -@deffnx {C Function} scm_cddar (pair) -@deffnx {C Function} scm_cdadr (pair) -@deffnx {C Function} scm_cdaar (pair) -@deffnx {C Function} scm_caddr (pair) -@deffnx {C Function} scm_cadar (pair) -@deffnx {C Function} scm_caadr (pair) -@deffnx {C Function} scm_caaar (pair) -@deffnx {C Function} scm_cddddr (pair) -@deffnx {C Function} scm_cdddar (pair) -@deffnx {C Function} scm_cddadr (pair) -@deffnx {C Function} scm_cddaar (pair) -@deffnx {C Function} scm_cdaddr (pair) -@deffnx {C Function} scm_cdadar (pair) -@deffnx {C Function} scm_cdaadr (pair) -@deffnx {C Function} scm_cdaaar (pair) -@deffnx {C Function} scm_cadddr (pair) -@deffnx {C Function} scm_caddar (pair) -@deffnx {C Function} scm_cadadr (pair) -@deffnx {C Function} scm_cadaar (pair) -@deffnx {C Function} scm_caaddr (pair) -@deffnx {C Function} scm_caadar (pair) -@deffnx {C Function} scm_caaadr (pair) -@deffnx {C Function} scm_caaaar (pair) -These procedures are compositions of @code{car} and @code{cdr}, where -for example @code{caddr} could be defined by - -@lisp -(define caddr (lambda (x) (car (cdr (cdr x))))) -@end lisp - -@code{cadr}, @code{caddr} and @code{cadddr} pick out the second, third -or fourth elements of a list, respectively. SRFI-1 provides the same -under the names @code{second}, @code{third} and @code{fourth} -(@pxref{SRFI-1 Selectors}). -@end deffn - -@rnindex set-car! -@deffn {Scheme Procedure} set-car! pair value -@deffnx {C Function} scm_set_car_x (pair, value) -Stores @var{value} in the car field of @var{pair}. The value returned -by @code{set-car!} is unspecified. -@end deffn - -@rnindex set-cdr! -@deffn {Scheme Procedure} set-cdr! pair value -@deffnx {C Function} scm_set_cdr_x (pair, value) -Stores @var{value} in the cdr field of @var{pair}. The value returned -by @code{set-cdr!} is unspecified. -@end deffn - - -@node Lists -@subsection Lists -@tpindex Lists - -A very important data type in Scheme---as well as in all other Lisp -dialects---is the data type @dfn{list}.@footnote{Strictly speaking, -Scheme does not have a real datatype @dfn{list}. Lists are made up of -@dfn{chained pairs}, and only exist by definition---a list is a chain -of pairs which looks like a list.} - -This is the short definition of what a list is: - -@itemize @bullet -@item -Either the empty list @code{()}, - -@item -or a pair which has a list in its cdr. -@end itemize - -@c FIXME::martin: Describe the pair chaining in more detail. - -@c FIXME::martin: What is a proper, what an improper list? -@c What is a circular list? - -@c FIXME::martin: Maybe steal some graphics from the Elisp reference -@c manual? - -@menu -* List Syntax:: Writing literal lists. -* List Predicates:: Testing lists. -* List Constructors:: Creating new lists. -* List Selection:: Selecting from lists, getting their length. -* Append/Reverse:: Appending and reversing lists. -* List Modification:: Modifying existing lists. -* List Searching:: Searching for list elements -* List Mapping:: Applying procedures to lists. -@end menu - -@node List Syntax -@subsubsection List Read Syntax - -The syntax for lists is an opening parentheses, then all the elements of -the list (separated by whitespace) and finally a closing -parentheses.@footnote{Note that there is no separation character between -the list elements, like a comma or a semicolon.}. - -@lisp -(1 2 3) ; @r{a list of the numbers 1, 2 and 3} -("foo" bar 3.1415) ; @r{a string, a symbol and a real number} -() ; @r{the empty list} -@end lisp - -The last example needs a bit more explanation. A list with no elements, -called the @dfn{empty list}, is special in some ways. It is used for -terminating lists by storing it into the cdr of the last pair that makes -up a list. An example will clear that up: - -@lisp -(car '(1)) -@result{} -1 -(cdr '(1)) -@result{} -() -@end lisp - -This example also shows that lists have to be quoted when written -(@pxref{Expression Syntax}), because they would otherwise be -mistakingly taken as procedure applications (@pxref{Simple -Invocation}). - - -@node List Predicates -@subsubsection List Predicates - -Often it is useful to test whether a given Scheme object is a list or -not. List-processing procedures could use this information to test -whether their input is valid, or they could do different things -depending on the datatype of their arguments. - -@rnindex list? -@deffn {Scheme Procedure} list? x -@deffnx {C Function} scm_list_p (x) -Return @code{#t} if @var{x} is a proper list, else @code{#f}. -@end deffn - -The predicate @code{null?} is often used in list-processing code to -tell whether a given list has run out of elements. That is, a loop -somehow deals with the elements of a list until the list satisfies -@code{null?}. Then, the algorithm terminates. - -@rnindex null? -@deffn {Scheme Procedure} null? x -@deffnx {C Function} scm_null_p (x) -Return @code{#t} if @var{x} is the empty list, else @code{#f}. -@end deffn - -@deftypefn {C Function} int scm_is_null (SCM x) -Return 1 when @var{x} is the empty list; otherwise return 0. -@end deftypefn - - -@node List Constructors -@subsubsection List Constructors - -This section describes the procedures for constructing new lists. -@code{list} simply returns a list where the elements are the arguments, -@code{cons*} is similar, but the last argument is stored in the cdr of -the last pair of the list. - -@c C Function scm_list(rest) used to be documented here, but it's a -@c no-op since it does nothing but return the list the caller must -@c have already created. -@c -@deffn {Scheme Procedure} list elem @dots{} -@deffnx {C Function} scm_list_1 (elem1) -@deffnx {C Function} scm_list_2 (elem1, elem2) -@deffnx {C Function} scm_list_3 (elem1, elem2, elem3) -@deffnx {C Function} scm_list_4 (elem1, elem2, elem3, elem4) -@deffnx {C Function} scm_list_5 (elem1, elem2, elem3, elem4, elem5) -@deffnx {C Function} scm_list_n (elem1, @dots{}, elemN, @nicode{SCM_UNDEFINED}) -@rnindex list -Return a new list containing elements @var{elem} @enddots{}. - -@code{scm_list_n} takes a variable number of arguments, terminated by -the special @code{SCM_UNDEFINED}. That final @code{SCM_UNDEFINED} is -not included in the list. None of @var{elem} @dots{} can -themselves be @code{SCM_UNDEFINED}, or @code{scm_list_n} will -terminate at that point. -@end deffn - -@c C Function scm_cons_star(arg1,rest) used to be documented here, -@c but it's not really a useful interface, since it expects the -@c caller to have already consed up all but the first argument -@c already. -@c -@deffn {Scheme Procedure} cons* arg1 arg2 @dots{} -Like @code{list}, but the last arg provides the tail of the -constructed list, returning @code{(cons @var{arg1} (cons -@var{arg2} (cons @dots{} @var{argn})))}. Requires at least one -argument. If given one argument, that argument is returned as -result. This function is called @code{list*} in some other -Schemes and in Common LISP. -@end deffn - -@deffn {Scheme Procedure} list-copy lst -@deffnx {C Function} scm_list_copy (lst) -Return a (newly-created) copy of @var{lst}. -@end deffn - -@deffn {Scheme Procedure} make-list n [init] -Create a list containing of @var{n} elements, where each element is -initialized to @var{init}. @var{init} defaults to the empty list -@code{()} if not given. -@end deffn - -Note that @code{list-copy} only makes a copy of the pairs which make up -the spine of the lists. The list elements are not copied, which means -that modifying the elements of the new list also modifies the elements -of the old list. On the other hand, applying procedures like -@code{set-cdr!} or @code{delv!} to the new list will not alter the old -list. If you also need to copy the list elements (making a deep copy), -use the procedure @code{copy-tree} (@pxref{Copying}). - -@node List Selection -@subsubsection List Selection - -These procedures are used to get some information about a list, or to -retrieve one or more elements of a list. - -@rnindex length -@deffn {Scheme Procedure} length lst -@deffnx {C Function} scm_length (lst) -Return the number of elements in list @var{lst}. -@end deffn - -@deffn {Scheme Procedure} last-pair lst -@deffnx {C Function} scm_last_pair (lst) -Return the last pair in @var{lst}, signalling an error if -@var{lst} is circular. -@end deffn - -@rnindex list-ref -@deffn {Scheme Procedure} list-ref list k -@deffnx {C Function} scm_list_ref (list, k) -Return the @var{k}th element from @var{list}. -@end deffn - -@rnindex list-tail -@deffn {Scheme Procedure} list-tail lst k -@deffnx {Scheme Procedure} list-cdr-ref lst k -@deffnx {C Function} scm_list_tail (lst, k) -Return the "tail" of @var{lst} beginning with its @var{k}th element. -The first element of the list is considered to be element 0. - -@code{list-tail} and @code{list-cdr-ref} are identical. It may help to -think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list, -or returning the results of cdring @var{k} times down @var{lst}. -@end deffn - -@deffn {Scheme Procedure} list-head lst k -@deffnx {C Function} scm_list_head (lst, k) -Copy the first @var{k} elements from @var{lst} into a new list, and -return it. -@end deffn - -@node Append/Reverse -@subsubsection Append and Reverse - -@code{append} and @code{append!} are used to concatenate two or more -lists in order to form a new list. @code{reverse} and @code{reverse!} -return lists with the same elements as their arguments, but in reverse -order. The procedure variants with an @code{!} directly modify the -pairs which form the list, whereas the other procedures create new -pairs. This is why you should be careful when using the side-effecting -variants. - -@rnindex append -@deffn {Scheme Procedure} append lst @dots{} obj -@deffnx {Scheme Procedure} append -@deffnx {Scheme Procedure} append! lst @dots{} obj -@deffnx {Scheme Procedure} append! -@deffnx {C Function} scm_append (lstlst) -@deffnx {C Function} scm_append_x (lstlst) -Return a list comprising all the elements of lists @var{lst} @dots{} -@var{obj}. If called with no arguments, return the empty list. - -@lisp -(append '(x) '(y)) @result{} (x y) -(append '(a) '(b c d)) @result{} (a b c d) -(append '(a (b)) '((c))) @result{} (a (b) (c)) -@end lisp - -The last argument @var{obj} may actually be any object; an improper -list results if the last argument is not a proper list. - -@lisp -(append '(a b) '(c . d)) @result{} (a b c . d) -(append '() 'a) @result{} a -@end lisp - -@code{append} doesn't modify the given lists, but the return may share -structure with the final @var{obj}. @code{append!} is permitted, but -not required, to modify the given lists to form its return. - -For @code{scm_append} and @code{scm_append_x}, @var{lstlst} is a list -of the list operands @var{lst} @dots{} @var{obj}. That @var{lstlst} -itself is not modified or used in the return. -@end deffn - -@rnindex reverse -@deffn {Scheme Procedure} reverse lst -@deffnx {Scheme Procedure} reverse! lst [newtail] -@deffnx {C Function} scm_reverse (lst) -@deffnx {C Function} scm_reverse_x (lst, newtail) -Return a list comprising the elements of @var{lst}, in reverse order. - -@code{reverse} constructs a new list. @code{reverse!} is permitted, but -not required, to modify @var{lst} in constructing its return. - -For @code{reverse!}, the optional @var{newtail} is appended to the -result. @var{newtail} isn't reversed, it simply becomes the list -tail. For @code{scm_reverse_x}, the @var{newtail} parameter is -mandatory, but can be @code{SCM_EOL} if no further tail is required. -@end deffn - -@node List Modification -@subsubsection List Modification - -The following procedures modify an existing list, either by changing -elements of the list, or by changing the list structure itself. - -@deffn {Scheme Procedure} list-set! list k val -@deffnx {C Function} scm_list_set_x (list, k, val) -Set the @var{k}th element of @var{list} to @var{val}. -@end deffn - -@deffn {Scheme Procedure} list-cdr-set! list k val -@deffnx {C Function} scm_list_cdr_set_x (list, k, val) -Set the @var{k}th cdr of @var{list} to @var{val}. -@end deffn - -@deffn {Scheme Procedure} delq item lst -@deffnx {C Function} scm_delq (item, lst) -Return a newly-created copy of @var{lst} with elements -@code{eq?} to @var{item} removed. This procedure mirrors -@code{memq}: @code{delq} compares elements of @var{lst} against -@var{item} with @code{eq?}. -@end deffn - -@deffn {Scheme Procedure} delv item lst -@deffnx {C Function} scm_delv (item, lst) -Return a newly-created copy of @var{lst} with elements -@code{eqv?} to @var{item} removed. This procedure mirrors -@code{memv}: @code{delv} compares elements of @var{lst} against -@var{item} with @code{eqv?}. -@end deffn - -@deffn {Scheme Procedure} delete item lst -@deffnx {C Function} scm_delete (item, lst) -Return a newly-created copy of @var{lst} with elements -@code{equal?} to @var{item} removed. This procedure mirrors -@code{member}: @code{delete} compares elements of @var{lst} -against @var{item} with @code{equal?}. - -See also SRFI-1 which has an extended @code{delete} (@ref{SRFI-1 -Deleting}), and also an @code{lset-difference} which can delete -multiple @var{item}s in one call (@ref{SRFI-1 Set Operations}). -@end deffn - -@deffn {Scheme Procedure} delq! item lst -@deffnx {Scheme Procedure} delv! item lst -@deffnx {Scheme Procedure} delete! item lst -@deffnx {C Function} scm_delq_x (item, lst) -@deffnx {C Function} scm_delv_x (item, lst) -@deffnx {C Function} scm_delete_x (item, lst) -These procedures are destructive versions of @code{delq}, @code{delv} -and @code{delete}: they modify the pointers in the existing @var{lst} -rather than creating a new list. Caveat evaluator: Like other -destructive list functions, these functions cannot modify the binding of -@var{lst}, and so cannot be used to delete the first element of -@var{lst} destructively. -@end deffn - -@deffn {Scheme Procedure} delq1! item lst -@deffnx {C Function} scm_delq1_x (item, lst) -Like @code{delq!}, but only deletes the first occurrence of -@var{item} from @var{lst}. Tests for equality using -@code{eq?}. See also @code{delv1!} and @code{delete1!}. -@end deffn - -@deffn {Scheme Procedure} delv1! item lst -@deffnx {C Function} scm_delv1_x (item, lst) -Like @code{delv!}, but only deletes the first occurrence of -@var{item} from @var{lst}. Tests for equality using -@code{eqv?}. See also @code{delq1!} and @code{delete1!}. -@end deffn - -@deffn {Scheme Procedure} delete1! item lst -@deffnx {C Function} scm_delete1_x (item, lst) -Like @code{delete!}, but only deletes the first occurrence of -@var{item} from @var{lst}. Tests for equality using -@code{equal?}. See also @code{delq1!} and @code{delv1!}. -@end deffn - -@deffn {Scheme Procedure} filter pred lst -@deffnx {Scheme Procedure} filter! pred lst -Return a list containing all elements from @var{lst} which satisfy the -predicate @var{pred}. The elements in the result list have the same -order as in @var{lst}. The order in which @var{pred} is applied to -the list elements is not specified. - -@code{filter} does not change @var{lst}, but the result may share a -tail with it. @code{filter!} may modify @var{lst} to construct its -return. -@end deffn - -@node List Searching -@subsubsection List Searching - -The following procedures search lists for particular elements. They use -different comparison predicates for comparing list elements with the -object to be searched. When they fail, they return @code{#f}, otherwise -they return the sublist whose car is equal to the search object, where -equality depends on the equality predicate used. - -@rnindex memq -@deffn {Scheme Procedure} memq x lst -@deffnx {C Function} scm_memq (x, lst) -Return the first sublist of @var{lst} whose car is @code{eq?} -to @var{x} where the sublists of @var{lst} are the non-empty -lists returned by @code{(list-tail @var{lst} @var{k})} for -@var{k} less than the length of @var{lst}. If @var{x} does not -occur in @var{lst}, then @code{#f} (not the empty list) is -returned. -@end deffn - -@rnindex memv -@deffn {Scheme Procedure} memv x lst -@deffnx {C Function} scm_memv (x, lst) -Return the first sublist of @var{lst} whose car is @code{eqv?} -to @var{x} where the sublists of @var{lst} are the non-empty -lists returned by @code{(list-tail @var{lst} @var{k})} for -@var{k} less than the length of @var{lst}. If @var{x} does not -occur in @var{lst}, then @code{#f} (not the empty list) is -returned. -@end deffn - -@rnindex member -@deffn {Scheme Procedure} member x lst -@deffnx {C Function} scm_member (x, lst) -Return the first sublist of @var{lst} whose car is -@code{equal?} to @var{x} where the sublists of @var{lst} are -the non-empty lists returned by @code{(list-tail @var{lst} -@var{k})} for @var{k} less than the length of @var{lst}. If -@var{x} does not occur in @var{lst}, then @code{#f} (not the -empty list) is returned. - -See also SRFI-1 which has an extended @code{member} function -(@ref{SRFI-1 Searching}). -@end deffn - - -@node List Mapping -@subsubsection List Mapping - -List processing is very convenient in Scheme because the process of -iterating over the elements of a list can be highly abstracted. The -procedures in this section are the most basic iterating procedures for -lists. They take a procedure and one or more lists as arguments, and -apply the procedure to each element of the list. They differ in their -return value. - -@rnindex map -@c begin (texi-doc-string "guile" "map") -@deffn {Scheme Procedure} map proc arg1 arg2 @dots{} -@deffnx {Scheme Procedure} map-in-order proc arg1 arg2 @dots{} -@deffnx {C Function} scm_map (proc, arg1, args) -Apply @var{proc} to each element of the list @var{arg1} (if only two -arguments are given), or to the corresponding elements of the argument -lists (if more than two arguments are given). The result(s) of the -procedure applications are saved and returned in a list. For -@code{map}, the order of procedure applications is not specified, -@code{map-in-order} applies the procedure from left to right to the list -elements. -@end deffn - -@rnindex for-each -@c begin (texi-doc-string "guile" "for-each") -@deffn {Scheme Procedure} for-each proc arg1 arg2 @dots{} -Like @code{map}, but the procedure is always applied from left to right, -and the result(s) of the procedure applications are thrown away. The -return value is not specified. -@end deffn - -See also SRFI-1 which extends these functions to take lists of unequal -lengths (@ref{SRFI-1 Fold and Map}). - -@node Vectors -@subsection Vectors -@tpindex Vectors - -Vectors are sequences of Scheme objects. Unlike lists, the length of a -vector, once the vector is created, cannot be changed. The advantage of -vectors over lists is that the time required to access one element of a vector -given its @dfn{position} (synonymous with @dfn{index}), a zero-origin number, -is constant, whereas lists have an access time linear to the position of the -accessed element in the list. - -Vectors can contain any kind of Scheme object; it is even possible to -have different types of objects in the same vector. For vectors -containing vectors, you may wish to use arrays, instead. Note, too, -that vectors are the special case of one dimensional non-uniform arrays -and that most array procedures operate happily on vectors -(@pxref{Arrays}). - -Also see @ref{SRFI-43}, for a comprehensive vector library. - -@menu -* Vector Syntax:: Read syntax for vectors. -* Vector Creation:: Dynamic vector creation and validation. -* Vector Accessors:: Accessing and modifying vector contents. -* Vector Accessing from C:: Ways to work with vectors from C. -* Uniform Numeric Vectors:: Vectors of unboxed numeric values. -@end menu - - -@node Vector Syntax -@subsubsection Read Syntax for Vectors - -Vectors can literally be entered in source code, just like strings, -characters or some of the other data types. The read syntax for vectors -is as follows: A sharp sign (@code{#}), followed by an opening -parentheses, all elements of the vector in their respective read syntax, -and finally a closing parentheses. Like strings, vectors do not have to -be quoted. - -The following are examples of the read syntax for vectors; where the -first vector only contains numbers and the second three different object -types: a string, a symbol and a number in hexadecimal notation. - -@lisp -#(1 2 3) -#("Hello" foo #xdeadbeef) -@end lisp - -@node Vector Creation -@subsubsection Dynamic Vector Creation and Validation - -Instead of creating a vector implicitly by using the read syntax just -described, you can create a vector dynamically by calling one of the -@code{vector} and @code{list->vector} primitives with the list of Scheme -values that you want to place into a vector. The size of the vector -thus created is determined implicitly by the number of arguments given. - -@rnindex vector -@rnindex list->vector -@deffn {Scheme Procedure} vector arg @dots{} -@deffnx {Scheme Procedure} list->vector l -@deffnx {C Function} scm_vector (l) -Return a newly allocated vector composed of the -given arguments. Analogous to @code{list}. - -@lisp -(vector 'a 'b 'c) @result{} #(a b c) -@end lisp -@end deffn - -The inverse operation is @code{vector->list}: - -@rnindex vector->list -@deffn {Scheme Procedure} vector->list v -@deffnx {C Function} scm_vector_to_list (v) -Return a newly allocated list composed of the elements of @var{v}. - -@lisp -(vector->list #(dah dah didah)) @result{} (dah dah didah) -(list->vector '(dididit dah)) @result{} #(dididit dah) -@end lisp -@end deffn - -To allocate a vector with an explicitly specified size, use -@code{make-vector}. With this primitive you can also specify an initial -value for the vector elements (the same value for all elements, that -is): - -@rnindex make-vector -@deffn {Scheme Procedure} make-vector len [fill] -@deffnx {C Function} scm_make_vector (len, fill) -Return a newly allocated vector of @var{len} elements. If a -second argument is given, then each position is initialized to -@var{fill}. Otherwise the initial contents of each position is -unspecified. -@end deffn - -@deftypefn {C Function} SCM scm_c_make_vector (size_t k, SCM fill) -Like @code{scm_make_vector}, but the length is given as a @code{size_t}. -@end deftypefn - -To check whether an arbitrary Scheme value @emph{is} a vector, use the -@code{vector?} primitive: - -@rnindex vector? -@deffn {Scheme Procedure} vector? obj -@deffnx {C Function} scm_vector_p (obj) -Return @code{#t} if @var{obj} is a vector, otherwise return -@code{#f}. -@end deffn - -@deftypefn {C Function} int scm_is_vector (SCM obj) -Return non-zero when @var{obj} is a vector, otherwise return -@code{zero}. -@end deftypefn - -@node Vector Accessors -@subsubsection Accessing and Modifying Vector Contents - -@code{vector-length} and @code{vector-ref} return information about a -given vector, respectively its size and the elements that are contained -in the vector. - -@rnindex vector-length -@deffn {Scheme Procedure} vector-length vector -@deffnx {C Function} scm_vector_length (vector) -Return the number of elements in @var{vector} as an exact integer. -@end deffn - -@deftypefn {C Function} size_t scm_c_vector_length (SCM vec) -Return the number of elements in @var{vec} as a @code{size_t}. -@end deftypefn - -@rnindex vector-ref -@deffn {Scheme Procedure} vector-ref vec k -@deffnx {C Function} scm_vector_ref (vec, k) -Return the contents of position @var{k} of @var{vec}. -@var{k} must be a valid index of @var{vec}. -@lisp -(vector-ref #(1 1 2 3 5 8 13 21) 5) @result{} 8 -(vector-ref #(1 1 2 3 5 8 13 21) - (let ((i (round (* 2 (acos -1))))) - (if (inexact? i) - (inexact->exact i) - i))) @result{} 13 -@end lisp -@end deffn - -@deftypefn {C Function} SCM scm_c_vector_ref (SCM vec, size_t k) -Return the contents of position @var{k} (a @code{size_t}) of -@var{vec}. -@end deftypefn - -A vector created by one of the dynamic vector constructor procedures -(@pxref{Vector Creation}) can be modified using the following -procedures. - -@emph{NOTE:} According to R5RS, it is an error to use any of these -procedures on a literally read vector, because such vectors should be -considered as constants. Currently, however, Guile does not detect this -error. - -@rnindex vector-set! -@deffn {Scheme Procedure} vector-set! vec k obj -@deffnx {C Function} scm_vector_set_x (vec, k, obj) -Store @var{obj} in position @var{k} of @var{vec}. -@var{k} must be a valid index of @var{vec}. -The value returned by @samp{vector-set!} is unspecified. -@lisp -(let ((vec (vector 0 '(2 2 2 2) "Anna"))) - (vector-set! vec 1 '("Sue" "Sue")) - vec) @result{} #(0 ("Sue" "Sue") "Anna") -@end lisp -@end deffn - -@deftypefn {C Function} void scm_c_vector_set_x (SCM vec, size_t k, SCM obj) -Store @var{obj} in position @var{k} (a @code{size_t}) of @var{vec}. -@end deftypefn - -@rnindex vector-fill! -@deffn {Scheme Procedure} vector-fill! vec fill -@deffnx {C Function} scm_vector_fill_x (vec, fill) -Store @var{fill} in every position of @var{vec}. The value -returned by @code{vector-fill!} is unspecified. -@end deffn - -@deffn {Scheme Procedure} vector-copy vec -@deffnx {C Function} scm_vector_copy (vec) -Return a copy of @var{vec}. -@end deffn - -@deffn {Scheme Procedure} vector-move-left! vec1 start1 end1 vec2 start2 -@deffnx {C Function} scm_vector_move_left_x (vec1, start1, end1, vec2, start2) -Copy elements from @var{vec1}, positions @var{start1} to @var{end1}, -to @var{vec2} starting at position @var{start2}. @var{start1} and -@var{start2} are inclusive indices; @var{end1} is exclusive. - -@code{vector-move-left!} copies elements in leftmost order. -Therefore, in the case where @var{vec1} and @var{vec2} refer to the -same vector, @code{vector-move-left!} is usually appropriate when -@var{start1} is greater than @var{start2}. -@end deffn - -@deffn {Scheme Procedure} vector-move-right! vec1 start1 end1 vec2 start2 -@deffnx {C Function} scm_vector_move_right_x (vec1, start1, end1, vec2, start2) -Copy elements from @var{vec1}, positions @var{start1} to @var{end1}, -to @var{vec2} starting at position @var{start2}. @var{start1} and -@var{start2} are inclusive indices; @var{end1} is exclusive. - -@code{vector-move-right!} copies elements in rightmost order. -Therefore, in the case where @var{vec1} and @var{vec2} refer to the -same vector, @code{vector-move-right!} is usually appropriate when -@var{start1} is less than @var{start2}. -@end deffn - -@node Vector Accessing from C -@subsubsection Vector Accessing from C - -A vector can be read and modified from C with the functions -@code{scm_c_vector_ref} and @code{scm_c_vector_set_x}, for example. In -addition to these functions, there are two more ways to access vectors -from C that might be more efficient in certain situations: you can -restrict yourself to @dfn{simple vectors} and then use the very fast -@emph{simple vector macros}; or you can use the very general framework -for accessing all kinds of arrays (@pxref{Accessing Arrays from C}), -which is more verbose, but can deal efficiently with all kinds of -vectors (and arrays). For vectors, you can use the -@code{scm_vector_elements} and @code{scm_vector_writable_elements} -functions as shortcuts. - -@deftypefn {C Function} int scm_is_simple_vector (SCM obj) -Return non-zero if @var{obj} is a simple vector, else return zero. A -simple vector is a vector that can be used with the @code{SCM_SIMPLE_*} -macros below. - -The following functions are guaranteed to return simple vectors: -@code{scm_make_vector}, @code{scm_c_make_vector}, @code{scm_vector}, -@code{scm_list_to_vector}. -@end deftypefn - -@deftypefn {C Macro} size_t SCM_SIMPLE_VECTOR_LENGTH (SCM vec) -Evaluates to the length of the simple vector @var{vec}. No type -checking is done. -@end deftypefn - -@deftypefn {C Macro} SCM SCM_SIMPLE_VECTOR_REF (SCM vec, size_t idx) -Evaluates to the element at position @var{idx} in the simple vector -@var{vec}. No type or range checking is done. -@end deftypefn - -@deftypefn {C Macro} void SCM_SIMPLE_VECTOR_SET (SCM vec, size_t idx, SCM val) -Sets the element at position @var{idx} in the simple vector -@var{vec} to @var{val}. No type or range checking is done. -@end deftypefn - -@deftypefn {C Function} {const SCM *} scm_vector_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp) -Acquire a handle for the vector @var{vec} and return a pointer to the -elements of it. This pointer can only be used to read the elements of -@var{vec}. When @var{vec} is not a vector, an error is signaled. The -handle must eventually be released with -@code{scm_array_handle_release}. - -The variables pointed to by @var{lenp} and @var{incp} are filled with -the number of elements of the vector and the increment (number of -elements) between successive elements, respectively. Successive -elements of @var{vec} need not be contiguous in their underlying -``root vector'' returned here; hence the increment is not necessarily -equal to 1 and may well be negative too (@pxref{Shared Arrays}). - -The following example shows the typical way to use this function. It -creates a list of all elements of @var{vec} (in reverse order). - -@example -scm_t_array_handle handle; -size_t i, len; -ssize_t inc; -const SCM *elt; -SCM list; - -elt = scm_vector_elements (vec, &handle, &len, &inc); -list = SCM_EOL; -for (i = 0; i < len; i++, elt += inc) - list = scm_cons (*elt, list); -scm_array_handle_release (&handle); -@end example - -@end deftypefn - -@deftypefn {C Function} {SCM *} scm_vector_writable_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp) -Like @code{scm_vector_elements} but the pointer can be used to modify -the vector. - -The following example shows the typical way to use this function. It -fills a vector with @code{#t}. - -@example -scm_t_array_handle handle; -size_t i, len; -ssize_t inc; -SCM *elt; - -elt = scm_vector_writable_elements (vec, &handle, &len, &inc); -for (i = 0; i < len; i++, elt += inc) - *elt = SCM_BOOL_T; -scm_array_handle_release (&handle); -@end example - -@end deftypefn - -@node Uniform Numeric Vectors -@subsubsection Uniform Numeric Vectors - -A uniform numeric vector is a vector whose elements are all of a single -numeric type. Guile offers uniform numeric vectors for signed and -unsigned 8-bit, 16-bit, 32-bit, and 64-bit integers, two sizes of -floating point values, and complex floating-point numbers of these two -sizes. @xref{SRFI-4}, for more information. - -For many purposes, bytevectors work just as well as uniform vectors, and have -the advantage that they integrate well with binary input and output. -@xref{Bytevectors}, for more information on bytevectors. - -@node Bit Vectors -@subsection Bit Vectors - -@noindent -Bit vectors are zero-origin, one-dimensional arrays of booleans. They -are displayed as a sequence of @code{0}s and @code{1}s prefixed by -@code{#*}, e.g., - -@example -(make-bitvector 8 #f) @result{} -#*00000000 -@end example - -Bit vectors are the special case of one dimensional bit arrays, and can -thus be used with the array procedures, @xref{Arrays}. - -@deffn {Scheme Procedure} bitvector? obj -@deffnx {C Function} scm_bitvector_p (obj) -Return @code{#t} when @var{obj} is a bitvector, else -return @code{#f}. -@end deffn - -@deftypefn {C Function} int scm_is_bitvector (SCM obj) -Return @code{1} when @var{obj} is a bitvector, else return @code{0}. -@end deftypefn - -@deffn {Scheme Procedure} make-bitvector len [fill] -@deffnx {C Function} scm_make_bitvector (len, fill) -Create a new bitvector of length @var{len} and -optionally initialize all elements to @var{fill}. -@end deffn - -@deftypefn {C Function} SCM scm_c_make_bitvector (size_t len, SCM fill) -Like @code{scm_make_bitvector}, but the length is given as a -@code{size_t}. -@end deftypefn - -@deffn {Scheme Procedure} bitvector bit @dots{} -@deffnx {C Function} scm_bitvector (bits) -Create a new bitvector with the arguments as elements. -@end deffn - -@deffn {Scheme Procedure} bitvector-length vec -@deffnx {C Function} scm_bitvector_length (vec) -Return the length of the bitvector @var{vec}. -@end deffn - -@deftypefn {C Function} size_t scm_c_bitvector_length (SCM vec) -Like @code{scm_bitvector_length}, but the length is returned as a -@code{size_t}. -@end deftypefn - -@deffn {Scheme Procedure} bitvector-ref vec idx -@deffnx {C Function} scm_bitvector_ref (vec, idx) -Return the element at index @var{idx} of the bitvector -@var{vec}. -@end deffn - -@deftypefn {C Function} SCM scm_c_bitvector_ref (SCM vec, size_t idx) -Return the element at index @var{idx} of the bitvector -@var{vec}. -@end deftypefn - -@deffn {Scheme Procedure} bitvector-set! vec idx val -@deffnx {C Function} scm_bitvector_set_x (vec, idx, val) -Set the element at index @var{idx} of the bitvector -@var{vec} when @var{val} is true, else clear it. -@end deffn - -@deftypefn {C Function} SCM scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val) -Set the element at index @var{idx} of the bitvector -@var{vec} when @var{val} is true, else clear it. -@end deftypefn - -@deffn {Scheme Procedure} bitvector-fill! vec val -@deffnx {C Function} scm_bitvector_fill_x (vec, val) -Set all elements of the bitvector -@var{vec} when @var{val} is true, else clear them. -@end deffn - -@deffn {Scheme Procedure} list->bitvector list -@deffnx {C Function} scm_list_to_bitvector (list) -Return a new bitvector initialized with the elements -of @var{list}. -@end deffn - -@deffn {Scheme Procedure} bitvector->list vec -@deffnx {C Function} scm_bitvector_to_list (vec) -Return a new list initialized with the elements -of the bitvector @var{vec}. -@end deffn - -@deffn {Scheme Procedure} bit-count bool bitvector -@deffnx {C Function} scm_bit_count (bool, bitvector) -Return a count of how many entries in @var{bitvector} are equal to -@var{bool}. For example, - -@example -(bit-count #f #*000111000) @result{} 6 -@end example -@end deffn - -@deffn {Scheme Procedure} bit-position bool bitvector start -@deffnx {C Function} scm_bit_position (bool, bitvector, start) -Return the index of the first occurrence of @var{bool} in -@var{bitvector}, starting from @var{start}. If there is no @var{bool} -entry between @var{start} and the end of @var{bitvector}, then return -@code{#f}. For example, - -@example -(bit-position #t #*000101 0) @result{} 3 -(bit-position #f #*0001111 3) @result{} #f -@end example -@end deffn - -@deffn {Scheme Procedure} bit-invert! bitvector -@deffnx {C Function} scm_bit_invert_x (bitvector) -Modify @var{bitvector} by replacing each element with its negation. -@end deffn - -@deffn {Scheme Procedure} bit-set*! bitvector uvec bool -@deffnx {C Function} scm_bit_set_star_x (bitvector, uvec, bool) -Set entries of @var{bitvector} to @var{bool}, with @var{uvec} -selecting the entries to change. The return value is unspecified. - -If @var{uvec} is a bit vector, then those entries where it has -@code{#t} are the ones in @var{bitvector} which are set to @var{bool}. -@var{uvec} and @var{bitvector} must be the same length. When -@var{bool} is @code{#t} it's like @var{uvec} is OR'ed into -@var{bitvector}. Or when @var{bool} is @code{#f} it can be seen as an -ANDNOT. - -@example -(define bv #*01000010) -(bit-set*! bv #*10010001 #t) -bv -@result{} #*11010011 -@end example - -If @var{uvec} is a uniform vector of unsigned long integers, then -they're indexes into @var{bitvector} which are set to @var{bool}. - -@example -(define bv #*01000010) -(bit-set*! bv #u(5 2 7) #t) -bv -@result{} #*01100111 -@end example -@end deffn - -@deffn {Scheme Procedure} bit-count* bitvector uvec bool -@deffnx {C Function} scm_bit_count_star (bitvector, uvec, bool) -Return a count of how many entries in @var{bitvector} are equal to -@var{bool}, with @var{uvec} selecting the entries to consider. - -@var{uvec} is interpreted in the same way as for @code{bit-set*!} -above. Namely, if @var{uvec} is a bit vector then entries which have -@code{#t} there are considered in @var{bitvector}. Or if @var{uvec} -is a uniform vector of unsigned long integers then it's the indexes in -@var{bitvector} to consider. - -For example, - -@example -(bit-count* #*01110111 #*11001101 #t) @result{} 3 -(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2 -@end example -@end deffn - -@deftypefn {C Function} {const scm_t_uint32 *} scm_bitvector_elements (SCM vec, scm_t_array_handle *handle, size_t *offp, size_t *lenp, ssize_t *incp) -Like @code{scm_vector_elements} (@pxref{Vector Accessing from C}), but -for bitvectors. The variable pointed to by @var{offp} is set to the -value returned by @code{scm_array_handle_bit_elements_offset}. See -@code{scm_array_handle_bit_elements} for how to use the returned -pointer and the offset. -@end deftypefn - -@deftypefn {C Function} {scm_t_uint32 *} scm_bitvector_writable_elements (SCM vec, scm_t_array_handle *handle, size_t *offp, size_t *lenp, ssize_t *incp) -Like @code{scm_bitvector_elements}, but the pointer is good for reading -and writing. -@end deftypefn - -@node Arrays -@subsection Arrays -@tpindex Arrays - -@dfn{Arrays} are a collection of cells organized into an arbitrary -number of dimensions. Each cell can be accessed in constant time by -supplying an index for each dimension. - -In the current implementation, an array uses a vector of some kind for -the actual storage of its elements. Any kind of vector will do, so you -can have arrays of uniform numeric values, arrays of characters, arrays -of bits, and of course, arrays of arbitrary Scheme values. For example, -arrays with an underlying @code{c64vector} might be nice for digital -signal processing, while arrays made from a @code{u8vector} might be -used to hold gray-scale images. - -The number of dimensions of an array is called its @dfn{rank}. Thus, -a matrix is an array of rank 2, while a vector has rank 1. When -accessing an array element, you have to specify one exact integer for -each dimension. These integers are called the @dfn{indices} of the -element. An array specifies the allowed range of indices for each -dimension via an inclusive lower and upper bound. These bounds can -well be negative, but the upper bound must be greater than or equal to -the lower bound minus one. When all lower bounds of an array are -zero, it is called a @dfn{zero-origin} array. - -Arrays can be of rank 0, which could be interpreted as a scalar. -Thus, a zero-rank array can store exactly one object and the list of -indices of this element is the empty list. - -Arrays contain zero elements when one of their dimensions has a zero -length. These empty arrays maintain information about their shape: a -matrix with zero columns and 3 rows is different from a matrix with 3 -columns and zero rows, which again is different from a vector of -length zero. - -The array procedures are all polymorphic, treating strings, uniform -numeric vectors, bytevectors, bit vectors and ordinary vectors as one -dimensional arrays. - -@menu -* Array Syntax:: -* Array Procedures:: -* Shared Arrays:: -* Accessing Arrays from C:: -@end menu - -@node Array Syntax -@subsubsection Array Syntax - -An array is displayed as @code{#} followed by its rank, followed by a -tag that describes the underlying vector, optionally followed by -information about its shape, and finally followed by the cells, -organized into dimensions using parentheses. - -In more words, the array tag is of the form - -@example - #<@@lower><:len><@@lower><:len>... -@end example - -where @code{} is a positive integer in decimal giving the rank of -the array. It is omitted when the rank is 1 and the array is non-shared -and has zero-origin (see below). For shared arrays and for a non-zero -origin, the rank is always printed even when it is 1 to distinguish -them from ordinary vectors. - -The @code{} part is the tag for a uniform numeric vector, like -@code{u8}, @code{s16}, etc, @code{b} for bitvectors, or @code{a} for -strings. It is empty for ordinary vectors. - -The @code{<@@lower>} part is a @samp{@@} character followed by a signed -integer in decimal giving the lower bound of a dimension. There is one -@code{<@@lower>} for each dimension. When all lower bounds are zero, -all @code{<@@lower>} parts are omitted. - -The @code{<:len>} part is a @samp{:} character followed by an unsigned -integer in decimal giving the length of a dimension. Like for the lower -bounds, there is one @code{<:len>} for each dimension, and the -@code{<:len>} part always follows the @code{<@@lower>} part for a -dimension. Lengths are only then printed when they can't be deduced -from the nested lists of elements of the array literal, which can happen -when at least one length is zero. - -As a special case, an array of rank 0 is printed as -@code{#0()}, where @code{} is the result of -printing the single element of the array. - -Thus, - -@table @code -@item #(1 2 3) -is an ordinary array of rank 1 with lower bound 0 in dimension 0. -(I.e., a regular vector.) - -@item #@@2(1 2 3) -is an ordinary array of rank 1 with lower bound 2 in dimension 0. - -@item #2((1 2 3) (4 5 6)) -is a non-uniform array of rank 2; a 2@cross{}3 matrix with index ranges 0..1 -and 0..2. - -@item #u32(0 1 2) -is a uniform u8 array of rank 1. - -@item #2u32@@2@@3((1 2) (2 3)) -is a uniform u32 array of rank 2 with index ranges 2..3 and 3..4. - -@item #2() -is a two-dimensional array with index ranges 0..-1 and 0..-1, i.e.@: -both dimensions have length zero. - -@item #2:0:2() -is a two-dimensional array with index ranges 0..-1 and 0..1, i.e.@: the -first dimension has length zero, but the second has length 2. - -@item #0(12) -is a rank-zero array with contents 12. - -@end table - -In addition, bytevectors are also arrays, but use a different syntax -(@pxref{Bytevectors}): - -@table @code - -@item #vu8(1 2 3) -is a 3-byte long bytevector, with contents 1, 2, 3. - -@end table - -@node Array Procedures -@subsubsection Array Procedures - -When an array is created, the range of each dimension must be -specified, e.g., to create a 2@cross{}3 array with a zero-based index: - -@example -(make-array 'ho 2 3) @result{} #2((ho ho ho) (ho ho ho)) -@end example - -The range of each dimension can also be given explicitly, e.g., another -way to create the same array: - -@example -(make-array 'ho '(0 1) '(0 2)) @result{} #2((ho ho ho) (ho ho ho)) -@end example - -The following procedures can be used with arrays (or vectors). An -argument shown as @var{idx}@dots{} means one parameter for each -dimension in the array. A @var{idxlist} argument means a list of such -values, one for each dimension. - - -@deffn {Scheme Procedure} array? obj -@deffnx {C Function} scm_array_p (obj, unused) -Return @code{#t} if the @var{obj} is an array, and @code{#f} if -not. - -The second argument to scm_array_p is there for historical reasons, -but it is not used. You should always pass @code{SCM_UNDEFINED} as -its value. -@end deffn - -@deffn {Scheme Procedure} typed-array? obj type -@deffnx {C Function} scm_typed_array_p (obj, type) -Return @code{#t} if the @var{obj} is an array of type @var{type}, and -@code{#f} if not. -@end deffn - -@deftypefn {C Function} int scm_is_array (SCM obj) -Return @code{1} if the @var{obj} is an array and @code{0} if not. -@end deftypefn - -@deftypefn {C Function} int scm_is_typed_array (SCM obj, SCM type) -Return @code{0} if the @var{obj} is an array of type @var{type}, and -@code{1} if not. -@end deftypefn - -@deffn {Scheme Procedure} make-array fill bound @dots{} -@deffnx {C Function} scm_make_array (fill, bounds) -Equivalent to @code{(make-typed-array #t @var{fill} @var{bound} ...)}. -@end deffn - -@deffn {Scheme Procedure} make-typed-array type fill bound @dots{} -@deffnx {C Function} scm_make_typed_array (type, fill, bounds) -Create and return an array that has as many dimensions as there are -@var{bound}s and (maybe) fill it with @var{fill}. - -The underlying storage vector is created according to @var{type}, -which must be a symbol whose name is the `vectag' of the array as -explained above, or @code{#t} for ordinary, non-specialized arrays. - -For example, using the symbol @code{f64} for @var{type} will create an -array that uses a @code{f64vector} for storing its elements, and -@code{a} will use a string. - -When @var{fill} is not the special @emph{unspecified} value, the new -array is filled with @var{fill}. Otherwise, the initial contents of -the array is unspecified. The special @emph{unspecified} value is -stored in the variable @code{*unspecified*} so that for example -@code{(make-typed-array 'u32 *unspecified* 4)} creates a uninitialized -@code{u32} vector of length 4. - -Each @var{bound} may be a positive non-zero integer @var{n}, in which -case the index for that dimension can range from 0 through @var{n}-1; or -an explicit index range specifier in the form @code{(LOWER UPPER)}, -where both @var{lower} and @var{upper} are integers, possibly less than -zero, and possibly the same number (however, @var{lower} cannot be -greater than @var{upper}). -@end deffn - -@deffn {Scheme Procedure} list->array dimspec list -Equivalent to @code{(list->typed-array #t @var{dimspec} -@var{list})}. -@end deffn - -@deffn {Scheme Procedure} list->typed-array type dimspec list -@deffnx {C Function} scm_list_to_typed_array (type, dimspec, list) -Return an array of the type indicated by @var{type} with elements the -same as those of @var{list}. - -The argument @var{dimspec} determines the number of dimensions of the -array and their lower bounds. When @var{dimspec} is an exact integer, -it gives the number of dimensions directly and all lower bounds are -zero. When it is a list of exact integers, then each element is the -lower index bound of a dimension, and there will be as many dimensions -as elements in the list. -@end deffn - -@deffn {Scheme Procedure} array-type array -@deffnx {C Function} scm_array_type (array) -Return the type of @var{array}. This is the `vectag' used for -printing @var{array} (or @code{#t} for ordinary arrays) and can be -used with @code{make-typed-array} to create an array of the same kind -as @var{array}. -@end deffn - -@deffn {Scheme Procedure} array-ref array idx @dots{} -@deffnx {C Function} scm_array_ref (array, idxlist) -Return the element at @code{(idx @dots{})} in @var{array}. - -@example -(define a (make-array 999 '(1 2) '(3 4))) -(array-ref a 2 4) @result{} 999 -@end example -@end deffn - -@deffn {Scheme Procedure} array-in-bounds? array idx @dots{} -@deffnx {C Function} scm_array_in_bounds_p (array, idxlist) -Return @code{#t} if the given indices would be acceptable to -@code{array-ref}. - -@example -(define a (make-array #f '(1 2) '(3 4))) -(array-in-bounds? a 2 3) @result{} #t -(array-in-bounds? a 0 0) @result{} #f -@end example -@end deffn - -@deffn {Scheme Procedure} array-set! array obj idx @dots{} -@deffnx {C Function} scm_array_set_x (array, obj, idxlist) -Set the element at @code{(idx @dots{})} in @var{array} to @var{obj}. -The return value is unspecified. - -@example -(define a (make-array #f '(0 1) '(0 1))) -(array-set! a #t 1 1) -a @result{} #2((#f #f) (#f #t)) -@end example -@end deffn - -@deffn {Scheme Procedure} array-shape array -@deffnx {Scheme Procedure} array-dimensions array -@deffnx {C Function} scm_array_dimensions (array) -Return a list of the bounds for each dimension of @var{array}. - -@code{array-shape} gives @code{(@var{lower} @var{upper})} for each -dimension. @code{array-dimensions} instead returns just -@math{@var{upper}+1} for dimensions with a 0 lower bound. Both are -suitable as input to @code{make-array}. - -For example, - -@example -(define a (make-array 'foo '(-1 3) 5)) -(array-shape a) @result{} ((-1 3) (0 4)) -(array-dimensions a) @result{} ((-1 3) 5) -@end example -@end deffn - -@deffn {Scheme Procedure} array-length array -@deffnx {C Function} scm_array_length (array) -@deffnx {C Function} size_t scm_c_array_length (array) -Return the length of an array: its first dimension. It is an error to -ask for the length of an array of rank 0. -@end deffn - -@deffn {Scheme Procedure} array-rank array -@deffnx {C Function} scm_array_rank (array) -Return the rank of @var{array}. -@end deffn - -@deftypefn {C Function} size_t scm_c_array_rank (SCM array) -Return the rank of @var{array} as a @code{size_t}. -@end deftypefn - -@deffn {Scheme Procedure} array->list array -@deffnx {C Function} scm_array_to_list (array) -Return a list consisting of all the elements, in order, of -@var{array}. -@end deffn - -@c FIXME: Describe how the order affects the copying (it matters for -@c shared arrays with the same underlying root vector, presumably). -@c -@deffn {Scheme Procedure} array-copy! src dst -@deffnx {Scheme Procedure} array-copy-in-order! src dst -@deffnx {C Function} scm_array_copy_x (src, dst) -Copy every element from vector or array @var{src} to the corresponding -element of @var{dst}. @var{dst} must have the same rank as @var{src}, -and be at least as large in each dimension. The return value is -unspecified. -@end deffn - -@deffn {Scheme Procedure} array-fill! array fill -@deffnx {C Function} scm_array_fill_x (array, fill) -Store @var{fill} in every element of @var{array}. The value returned -is unspecified. -@end deffn - -@c begin (texi-doc-string "guile" "array-equal?") -@deffn {Scheme Procedure} array-equal? array @dots{} -Return @code{#t} if all arguments are arrays with the same shape, the -same type, and have corresponding elements which are either -@code{equal?} or @code{array-equal?}. This function differs from -@code{equal?} (@pxref{Equality}) in that all arguments must be arrays. -@end deffn - -@c FIXME: array-map! accepts no source arrays at all, and in that -@c case makes calls "(proc)". Is that meant to be a documented -@c feature? -@c -@c FIXME: array-for-each doesn't say what happens if the sources have -@c different index ranges. The code currently iterates over the -@c indices of the first and expects the others to cover those. That -@c at least vaguely matches array-map!, but is it meant to be a -@c documented feature? - -@deffn {Scheme Procedure} array-map! dst proc src @dots{} -@deffnx {Scheme Procedure} array-map-in-order! dst proc src1 @dots{} srcN -@deffnx {C Function} scm_array_map_x (dst, proc, srclist) -Set each element of the @var{dst} array to values obtained from calls -to @var{proc}. The value returned is unspecified. - -Each call is @code{(@var{proc} @var{elem1} @dots{} @var{elemN})}, -where each @var{elem} is from the corresponding @var{src} array, at -the @var{dst} index. @code{array-map-in-order!} makes the calls in -row-major order, @code{array-map!} makes them in an unspecified order. - -The @var{src} arrays must have the same number of dimensions as -@var{dst}, and must have a range for each dimension which covers the -range in @var{dst}. This ensures all @var{dst} indices are valid in -each @var{src}. -@end deffn - -@deffn {Scheme Procedure} array-for-each proc src1 src2 @dots{} -@deffnx {C Function} scm_array_for_each (proc, src1, srclist) -Apply @var{proc} to each tuple of elements of @var{src1} @var{src2} -@dots{}, in row-major order. The value returned is unspecified. -@end deffn - -@deffn {Scheme Procedure} array-index-map! dst proc -@deffnx {C Function} scm_array_index_map_x (dst, proc) -Set each element of the @var{dst} array to values returned by calls to -@var{proc}. The value returned is unspecified. - -Each call is @code{(@var{proc} @var{i1} @dots{} @var{iN})}, where -@var{i1}@dots{}@var{iN} is the destination index, one parameter for -each dimension. The order in which the calls are made is unspecified. - -For example, to create a @m{4\times4, 4x4} matrix representing a -cyclic group, - -@tex -\advance\leftskip by 2\lispnarrowing { -$\left(\matrix{% -0 & 1 & 2 & 3 \cr -1 & 2 & 3 & 0 \cr -2 & 3 & 0 & 1 \cr -3 & 0 & 1 & 2 \cr -}\right)$} \par -@end tex -@ifnottex -@example - / 0 1 2 3 \ - | 1 2 3 0 | - | 2 3 0 1 | - \ 3 0 1 2 / -@end example -@end ifnottex - -@example -(define a (make-array #f 4 4)) -(array-index-map! a (lambda (i j) - (modulo (+ i j) 4))) -@end example -@end deffn - -@deffn {Scheme Procedure} uniform-array-read! ra [port_or_fd [start [end]]] -@deffnx {C Function} scm_uniform_array_read_x (ra, port_or_fd, start, end) -Attempt to read all elements of array @var{ra}, in lexicographic order, as -binary objects from @var{port_or_fd}. -If an end of file is encountered, -the objects up to that point are put into @var{ra} -(starting at the beginning) and the remainder of the array is -unchanged. - -The optional arguments @var{start} and @var{end} allow -a specified region of a vector (or linearized array) to be read, -leaving the remainder of the vector unchanged. - -@code{uniform-array-read!} returns the number of objects read. -@var{port_or_fd} may be omitted, in which case it defaults to the value -returned by @code{(current-input-port)}. -@end deffn - -@deffn {Scheme Procedure} uniform-array-write ra [port_or_fd [start [end]]] -@deffnx {C Function} scm_uniform_array_write (ra, port_or_fd, start, end) -Writes all elements of @var{ra} as binary objects to -@var{port_or_fd}. - -The optional arguments @var{start} -and @var{end} allow -a specified region of a vector (or linearized array) to be written. - -The number of objects actually written is returned. -@var{port_or_fd} may be -omitted, in which case it defaults to the value returned by -@code{(current-output-port)}. -@end deffn - -@node Shared Arrays -@subsubsection Shared Arrays - -@deffn {Scheme Procedure} make-shared-array oldarray mapfunc bound @dots{} -@deffnx {C Function} scm_make_shared_array (oldarray, mapfunc, boundlist) -Return a new array which shares the storage of @var{oldarray}. -Changes made through either affect the same underlying storage. The -@var{bound} @dots{} arguments are the shape of the new array, the same -as @code{make-array} (@pxref{Array Procedures}). - -@var{mapfunc} translates coordinates from the new array to the -@var{oldarray}. It's called as @code{(@var{mapfunc} newidx1 @dots{})} -with one parameter for each dimension of the new array, and should -return a list of indices for @var{oldarray}, one for each dimension of -@var{oldarray}. - -@var{mapfunc} must be affine linear, meaning that each @var{oldarray} -index must be formed by adding integer multiples (possibly negative) -of some or all of @var{newidx1} etc, plus a possible integer offset. -The multiples and offset must be the same in each call. - -@sp 1 -One good use for a shared array is to restrict the range of some -dimensions, so as to apply say @code{array-for-each} or -@code{array-fill!} to only part of an array. The plain @code{list} -function can be used for @var{mapfunc} in this case, making no changes -to the index values. For example, - -@example -(make-shared-array #2((a b c) (d e f) (g h i)) list 3 2) -@result{} #2((a b) (d e) (g h)) -@end example - -The new array can have fewer dimensions than @var{oldarray}, for -example to take a column from an array. - -@example -(make-shared-array #2((a b c) (d e f) (g h i)) - (lambda (i) (list i 2)) - '(0 2)) -@result{} #1(c f i) -@end example - -A diagonal can be taken by using the single new array index for both -row and column in the old array. For example, - -@example -(make-shared-array #2((a b c) (d e f) (g h i)) - (lambda (i) (list i i)) - '(0 2)) -@result{} #1(a e i) -@end example - -Dimensions can be increased by for instance considering portions of a -one dimensional array as rows in a two dimensional array. -(@code{array-contents} below can do the opposite, flattening an -array.) - -@example -(make-shared-array #1(a b c d e f g h i j k l) - (lambda (i j) (list (+ (* i 3) j))) - 4 3) -@result{} #2((a b c) (d e f) (g h i) (j k l)) -@end example - -By negating an index the order that elements appear can be reversed. -The following just reverses the column order, - -@example -(make-shared-array #2((a b c) (d e f) (g h i)) - (lambda (i j) (list i (- 2 j))) - 3 3) -@result{} #2((c b a) (f e d) (i h g)) -@end example - -A fixed offset on indexes allows for instance a change from a 0 based -to a 1 based array, - -@example -(define x #2((a b c) (d e f) (g h i))) -(define y (make-shared-array x - (lambda (i j) (list (1- i) (1- j))) - '(1 3) '(1 3))) -(array-ref x 0 0) @result{} a -(array-ref y 1 1) @result{} a -@end example - -A multiple on an index allows every Nth element of an array to be -taken. The following is every third element, - -@example -(make-shared-array #1(a b c d e f g h i j k l) - (lambda (i) (list (* i 3))) - 4) -@result{} #1(a d g j) -@end example - -The above examples can be combined to make weird and wonderful -selections from an array, but it's important to note that because -@var{mapfunc} must be affine linear, arbitrary permutations are not -possible. - -In the current implementation, @var{mapfunc} is not called for every -access to the new array but only on some sample points to establish a -base and stride for new array indices in @var{oldarray} data. A few -sample points are enough because @var{mapfunc} is linear. -@end deffn - -@deffn {Scheme Procedure} shared-array-increments array -@deffnx {C Function} scm_shared_array_increments (array) -For each dimension, return the distance between elements in the root vector. -@end deffn - -@deffn {Scheme Procedure} shared-array-offset array -@deffnx {C Function} scm_shared_array_offset (array) -Return the root vector index of the first element in the array. -@end deffn - -@deffn {Scheme Procedure} shared-array-root array -@deffnx {C Function} scm_shared_array_root (array) -Return the root vector of a shared array. -@end deffn - -@deffn {Scheme Procedure} array-contents array [strict] -@deffnx {C Function} scm_array_contents (array, strict) -If @var{array} may be @dfn{unrolled} into a one dimensional shared array -without changing their order (last subscript changing fastest), then -@code{array-contents} returns that shared array, otherwise it returns -@code{#f}. All arrays made by @code{make-array} and -@code{make-typed-array} may be unrolled, some arrays made by -@code{make-shared-array} may not be. - -If the optional argument @var{strict} is provided, a shared array will -be returned only if its elements are stored internally contiguous in -memory. -@end deffn - -@deffn {Scheme Procedure} transpose-array array dim1 dim2 @dots{} -@deffnx {C Function} scm_transpose_array (array, dimlist) -Return an array sharing contents with @var{array}, but with -dimensions arranged in a different order. There must be one -@var{dim} argument for each dimension of @var{array}. -@var{dim1}, @var{dim2}, @dots{} should be integers between 0 -and the rank of the array to be returned. Each integer in that -range must appear at least once in the argument list. - -The values of @var{dim1}, @var{dim2}, @dots{} correspond to -dimensions in the array to be returned, and their positions in the -argument list to dimensions of @var{array}. Several @var{dim}s -may have the same value, in which case the returned array will -have smaller rank than @var{array}. - -@lisp -(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d)) -(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d) -(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{} - #2((a 4) (b 5) (c 6)) -@end lisp -@end deffn - -@node Accessing Arrays from C -@subsubsection Accessing Arrays from C - -For interworking with external C code, Guile provides an API to allow C -code to access the elements of a Scheme array. In particular, for -uniform numeric arrays, the API exposes the underlying uniform data as a -C array of numbers of the relevant type. - -While pointers to the elements of an array are in use, the array itself -must be protected so that the pointer remains valid. Such a protected -array is said to be @dfn{reserved}. A reserved array can be read but -modifications to it that would cause the pointer to its elements to -become invalid are prevented. When you attempt such a modification, an -error is signalled. - -(This is similar to locking the array while it is in use, but without -the danger of a deadlock. In a multi-threaded program, you will need -additional synchronization to avoid modifying reserved arrays.) - -You must take care to always unreserve an array after reserving it, -even in the presence of non-local exits. If a non-local exit can -happen between these two calls, you should install a dynwind context -that releases the array when it is left (@pxref{Dynamic Wind}). - -In addition, array reserving and unreserving must be properly -paired. For instance, when reserving two or more arrays in a certain -order, you need to unreserve them in the opposite order. - -Once you have reserved an array and have retrieved the pointer to its -elements, you must figure out the layout of the elements in memory. -Guile allows slices to be taken out of arrays without actually making a -copy, such as making an alias for the diagonal of a matrix that can be -treated as a vector. Arrays that result from such an operation are not -stored contiguously in memory and when working with their elements -directly, you need to take this into account. - -The layout of array elements in memory can be defined via a -@emph{mapping function} that computes a scalar position from a vector of -indices. The scalar position then is the offset of the element with the -given indices from the start of the storage block of the array. - -In Guile, this mapping function is restricted to be @dfn{affine}: all -mapping functions of Guile arrays can be written as @code{p = b + -c[0]*i[0] + c[1]*i[1] + ... + c[n-1]*i[n-1]} where @code{i[k]} is the -@nicode{k}th index and @code{n} is the rank of the array. For -example, a matrix of size 3x3 would have @code{b == 0}, @code{c[0] == -3} and @code{c[1] == 1}. When you transpose this matrix (with -@code{transpose-array}, say), you will get an array whose mapping -function has @code{b == 0}, @code{c[0] == 1} and @code{c[1] == 3}. - -The function @code{scm_array_handle_dims} gives you (indirect) access to -the coefficients @code{c[k]}. - -@c XXX -Note that there are no functions for accessing the elements of a -character array yet. Once the string implementation of Guile has been -changed to use Unicode, we will provide them. - -@deftp {C Type} scm_t_array_handle -This is a structure type that holds all information necessary to manage -the reservation of arrays as explained above. Structures of this type -must be allocated on the stack and must only be accessed by the -functions listed below. -@end deftp - -@deftypefn {C Function} void scm_array_get_handle (SCM array, scm_t_array_handle *handle) -Reserve @var{array}, which must be an array, and prepare @var{handle} to -be used with the functions below. You must eventually call -@code{scm_array_handle_release} on @var{handle}, and do this in a -properly nested fashion, as explained above. The structure pointed to -by @var{handle} does not need to be initialized before calling this -function. -@end deftypefn - -@deftypefn {C Function} void scm_array_handle_release (scm_t_array_handle *handle) -End the array reservation represented by @var{handle}. After a call to -this function, @var{handle} might be used for another reservation. -@end deftypefn - -@deftypefn {C Function} size_t scm_array_handle_rank (scm_t_array_handle *handle) -Return the rank of the array represented by @var{handle}. -@end deftypefn - -@deftp {C Type} scm_t_array_dim -This structure type holds information about the layout of one dimension -of an array. It includes the following fields: - -@table @code -@item ssize_t lbnd -@itemx ssize_t ubnd -The lower and upper bounds (both inclusive) of the permissible index -range for the given dimension. Both values can be negative, but -@var{lbnd} is always less than or equal to @var{ubnd}. - -@item ssize_t inc -The distance from one element of this dimension to the next. Note, too, -that this can be negative. -@end table -@end deftp - -@deftypefn {C Function} {const scm_t_array_dim *} scm_array_handle_dims (scm_t_array_handle *handle) -Return a pointer to a C vector of information about the dimensions of -the array represented by @var{handle}. This pointer is valid as long as -the array remains reserved. As explained above, the -@code{scm_t_array_dim} structures returned by this function can be used -calculate the position of an element in the storage block of the array -from its indices. - -This position can then be used as an index into the C array pointer -returned by the various @code{scm_array_handle__elements} -functions, or with @code{scm_array_handle_ref} and -@code{scm_array_handle_set}. - -Here is how one can compute the position @var{pos} of an element given -its indices in the vector @var{indices}: - -@example -ssize_t indices[RANK]; -scm_t_array_dim *dims; -ssize_t pos; -size_t i; - -pos = 0; -for (i = 0; i < RANK; i++) - @{ - if (indices[i] < dims[i].lbnd || indices[i] > dims[i].ubnd) - out_of_range (); - pos += (indices[i] - dims[i].lbnd) * dims[i].inc; - @} -@end example -@end deftypefn - -@deftypefn {C Function} ssize_t scm_array_handle_pos (scm_t_array_handle *handle, SCM indices) -Compute the position corresponding to @var{indices}, a list of -indices. The position is computed as described above for -@code{scm_array_handle_dims}. The number of the indices and their -range is checked and an appropriate error is signalled for invalid -indices. -@end deftypefn - -@deftypefn {C Function} SCM scm_array_handle_ref (scm_t_array_handle *handle, ssize_t pos) -Return the element at position @var{pos} in the storage block of the -array represented by @var{handle}. Any kind of array is acceptable. No -range checking is done on @var{pos}. -@end deftypefn - -@deftypefn {C Function} void scm_array_handle_set (scm_t_array_handle *handle, ssize_t pos, SCM val) -Set the element at position @var{pos} in the storage block of the array -represented by @var{handle} to @var{val}. Any kind of array is -acceptable. No range checking is done on @var{pos}. An error is -signalled when the array can not store @var{val}. -@end deftypefn - -@deftypefn {C Function} {const SCM *} scm_array_handle_elements (scm_t_array_handle *handle) -Return a pointer to the elements of a ordinary array of general Scheme -values (i.e., a non-uniform array) for reading. This pointer is valid -as long as the array remains reserved. -@end deftypefn - -@deftypefn {C Function} {SCM *} scm_array_handle_writable_elements (scm_t_array_handle *handle) -Like @code{scm_array_handle_elements}, but the pointer is good for -reading and writing. -@end deftypefn - -@deftypefn {C Function} {const void *} scm_array_handle_uniform_elements (scm_t_array_handle *handle) -Return a pointer to the elements of a uniform numeric array for reading. -This pointer is valid as long as the array remains reserved. The size -of each element is given by @code{scm_array_handle_uniform_element_size}. -@end deftypefn - -@deftypefn {C Function} {void *} scm_array_handle_uniform_writable_elements (scm_t_array_handle *handle) -Like @code{scm_array_handle_uniform_elements}, but the pointer is good -reading and writing. -@end deftypefn - -@deftypefn {C Function} size_t scm_array_handle_uniform_element_size (scm_t_array_handle *handle) -Return the size of one element of the uniform numeric array represented -by @var{handle}. -@end deftypefn - -@deftypefn {C Function} {const scm_t_uint8 *} scm_array_handle_u8_elements (scm_t_array_handle *handle) -@deftypefnx {C Function} {const scm_t_int8 *} scm_array_handle_s8_elements (scm_t_array_handle *handle) -@deftypefnx {C Function} {const scm_t_uint16 *} scm_array_handle_u16_elements (scm_t_array_handle *handle) -@deftypefnx {C Function} {const scm_t_int16 *} scm_array_handle_s16_elements (scm_t_array_handle *handle) -@deftypefnx {C Function} {const scm_t_uint32 *} scm_array_handle_u32_elements (scm_t_array_handle *handle) -@deftypefnx {C Function} {const scm_t_int32 *} scm_array_handle_s32_elements (scm_t_array_handle *handle) -@deftypefnx {C Function} {const scm_t_uint64 *} scm_array_handle_u64_elements (scm_t_array_handle *handle) -@deftypefnx {C Function} {const scm_t_int64 *} scm_array_handle_s64_elements (scm_t_array_handle *handle) -@deftypefnx {C Function} {const float *} scm_array_handle_f32_elements (scm_t_array_handle *handle) -@deftypefnx {C Function} {const double *} scm_array_handle_f64_elements (scm_t_array_handle *handle) -@deftypefnx {C Function} {const float *} scm_array_handle_c32_elements (scm_t_array_handle *handle) -@deftypefnx {C Function} {const double *} scm_array_handle_c64_elements (scm_t_array_handle *handle) -Return a pointer to the elements of a uniform numeric array of the -indicated kind for reading. This pointer is valid as long as the array -remains reserved. - -The pointers for @code{c32} and @code{c64} uniform numeric arrays point -to pairs of floating point numbers. The even index holds the real part, -the odd index the imaginary part of the complex number. -@end deftypefn - -@deftypefn {C Function} {scm_t_uint8 *} scm_array_handle_u8_writable_elements (scm_t_array_handle *handle) -@deftypefnx {C Function} {scm_t_int8 *} scm_array_handle_s8_writable_elements (scm_t_array_handle *handle) -@deftypefnx {C Function} {scm_t_uint16 *} scm_array_handle_u16_writable_elements (scm_t_array_handle *handle) -@deftypefnx {C Function} {scm_t_int16 *} scm_array_handle_s16_writable_elements (scm_t_array_handle *handle) -@deftypefnx {C Function} {scm_t_uint32 *} scm_array_handle_u32_writable_elements (scm_t_array_handle *handle) -@deftypefnx {C Function} {scm_t_int32 *} scm_array_handle_s32_writable_elements (scm_t_array_handle *handle) -@deftypefnx {C Function} {scm_t_uint64 *} scm_array_handle_u64_writable_elements (scm_t_array_handle *handle) -@deftypefnx {C Function} {scm_t_int64 *} scm_array_handle_s64_writable_elements (scm_t_array_handle *handle) -@deftypefnx {C Function} {float *} scm_array_handle_f32_writable_elements (scm_t_array_handle *handle) -@deftypefnx {C Function} {double *} scm_array_handle_f64_writable_elements (scm_t_array_handle *handle) -@deftypefnx {C Function} {float *} scm_array_handle_c32_writable_elements (scm_t_array_handle *handle) -@deftypefnx {C Function} {double *} scm_array_handle_c64_writable_elements (scm_t_array_handle *handle) -Like @code{scm_array_handle__elements}, but the pointer is good -for reading and writing. -@end deftypefn - -@deftypefn {C Function} {const scm_t_uint32 *} scm_array_handle_bit_elements (scm_t_array_handle *handle) -Return a pointer to the words that store the bits of the represented -array, which must be a bit array. - -Unlike other arrays, bit arrays have an additional offset that must be -figured into index calculations. That offset is returned by -@code{scm_array_handle_bit_elements_offset}. - -To find a certain bit you first need to calculate its position as -explained above for @code{scm_array_handle_dims} and then add the -offset. This gives the absolute position of the bit, which is always a -non-negative integer. - -Each word of the bit array storage block contains exactly 32 bits, with -the least significant bit in that word having the lowest absolute -position number. The next word contains the next 32 bits. - -Thus, the following code can be used to access a bit whose position -according to @code{scm_array_handle_dims} is given in @var{pos}: - -@example -SCM bit_array; -scm_t_array_handle handle; -scm_t_uint32 *bits; -ssize_t pos; -size_t abs_pos; -size_t word_pos, mask; - -scm_array_get_handle (&bit_array, &handle); -bits = scm_array_handle_bit_elements (&handle); - -pos = ... -abs_pos = pos + scm_array_handle_bit_elements_offset (&handle); -word_pos = abs_pos / 32; -mask = 1L << (abs_pos % 32); - -if (bits[word_pos] & mask) - /* bit is set. */ - -scm_array_handle_release (&handle); -@end example - -@end deftypefn - -@deftypefn {C Function} {scm_t_uint32 *} scm_array_handle_bit_writable_elements (scm_t_array_handle *handle) -Like @code{scm_array_handle_bit_elements} but the pointer is good for -reading and writing. You must take care not to modify bits outside of -the allowed index range of the array, even for contiguous arrays. -@end deftypefn - -@node VLists -@subsection VLists - -@cindex vlist - -The @code{(ice-9 vlist)} module provides an implementation of the @dfn{VList} -data structure designed by Phil Bagwell in 2002. VLists are immutable lists, -which can contain any Scheme object. They improve on standard Scheme linked -lists in several areas: - -@itemize -@item -Random access has typically constant-time complexity. - -@item -Computing the length of a VList has time complexity logarithmic in the number of -elements. - -@item -VLists use less storage space than standard lists. - -@item -VList elements are stored in contiguous regions, which improves memory locality -and leads to more efficient use of hardware caches. -@end itemize - -The idea behind VLists is to store vlist elements in increasingly large -contiguous blocks (implemented as vectors here). These blocks are linked to one -another using a pointer to the next block and an offset within that block. The -size of these blocks form a geometric series with ratio -@code{block-growth-factor} (2 by default). - -The VList structure also serves as the basis for the @dfn{VList-based hash -lists} or ``vhashes'', an immutable dictionary type (@pxref{VHashes}). - -However, the current implementation in @code{(ice-9 vlist)} has several -noteworthy shortcomings: - -@itemize - -@item -It is @emph{not} thread-safe. Although operations on vlists are all -@dfn{referentially transparent} (i.e., purely functional), adding elements to a -vlist with @code{vlist-cons} mutates part of its internal structure, which makes -it non-thread-safe. This could be fixed, but it would slow down -@code{vlist-cons}. - -@item -@code{vlist-cons} always allocates at least as much memory as @code{cons}. -Again, Phil Bagwell describes how to fix it, but that would require tuning the -garbage collector in a way that may not be generally beneficial. - -@item -@code{vlist-cons} is a Scheme procedure compiled to bytecode, and it does not -compete with the straightforward C implementation of @code{cons}, and with the -fact that the VM has a special @code{cons} instruction. - -@end itemize - -We hope to address these in the future. - -The programming interface exported by @code{(ice-9 vlist)} is defined below. -Most of it is the same as SRFI-1 with an added @code{vlist-} prefix to function -names. - -@deffn {Scheme Procedure} vlist? obj -Return true if @var{obj} is a VList. -@end deffn - -@defvr {Scheme Variable} vlist-null -The empty VList. Note that it's possible to create an empty VList not -@code{eq?} to @code{vlist-null}; thus, callers should always use -@code{vlist-null?} when testing whether a VList is empty. -@end defvr - -@deffn {Scheme Procedure} vlist-null? vlist -Return true if @var{vlist} is empty. -@end deffn - -@deffn {Scheme Procedure} vlist-cons item vlist -Return a new vlist with @var{item} as its head and @var{vlist} as its tail. -@end deffn - -@deffn {Scheme Procedure} vlist-head vlist -Return the head of @var{vlist}. -@end deffn - -@deffn {Scheme Procedure} vlist-tail vlist -Return the tail of @var{vlist}. -@end deffn - -@defvr {Scheme Variable} block-growth-factor -A fluid that defines the growth factor of VList blocks, 2 by default. -@end defvr - -The functions below provide the usual set of higher-level list operations. - -@deffn {Scheme Procedure} vlist-fold proc init vlist -@deffnx {Scheme Procedure} vlist-fold-right proc init vlist -Fold over @var{vlist}, calling @var{proc} for each element, as for SRFI-1 -@code{fold} and @code{fold-right} (@pxref{SRFI-1, @code{fold}}). -@end deffn - -@deffn {Scheme Procedure} vlist-ref vlist index -Return the element at index @var{index} in @var{vlist}. This is typically a -constant-time operation. -@end deffn - -@deffn {Scheme Procedure} vlist-length vlist -Return the length of @var{vlist}. This is typically logarithmic in the number -of elements in @var{vlist}. -@end deffn - -@deffn {Scheme Procedure} vlist-reverse vlist -Return a new @var{vlist} whose content are those of @var{vlist} in reverse -order. -@end deffn - -@deffn {Scheme Procedure} vlist-map proc vlist -Map @var{proc} over the elements of @var{vlist} and return a new vlist. -@end deffn - -@deffn {Scheme Procedure} vlist-for-each proc vlist -Call @var{proc} on each element of @var{vlist}. The result is unspecified. -@end deffn - -@deffn {Scheme Procedure} vlist-drop vlist count -Return a new vlist that does not contain the @var{count} first elements of -@var{vlist}. This is typically a constant-time operation. -@end deffn - -@deffn {Scheme Procedure} vlist-take vlist count -Return a new vlist that contains only the @var{count} first elements of -@var{vlist}. -@end deffn - -@deffn {Scheme Procedure} vlist-filter pred vlist -Return a new vlist containing all the elements from @var{vlist} that satisfy -@var{pred}. -@end deffn - -@deffn {Scheme Procedure} vlist-delete x vlist [equal?] -Return a new vlist corresponding to @var{vlist} without the elements -@var{equal?} to @var{x}. -@end deffn - -@deffn {Scheme Procedure} vlist-unfold p f g seed [tail-gen] -@deffnx {Scheme Procedure} vlist-unfold-right p f g seed [tail] -Return a new vlist, as for SRFI-1 @code{unfold} and @code{unfold-right} -(@pxref{SRFI-1, @code{unfold}}). -@end deffn - -@deffn {Scheme Procedure} vlist-append vlist @dots{} -Append the given vlists and return the resulting vlist. -@end deffn - -@deffn {Scheme Procedure} list->vlist lst -Return a new vlist whose contents correspond to @var{lst}. -@end deffn - -@deffn {Scheme Procedure} vlist->list vlist -Return a new list whose contents match those of @var{vlist}. -@end deffn - -@node Record Overview -@subsection Record Overview - -@cindex record -@cindex structure - -@dfn{Records}, also called @dfn{structures}, are Scheme's primary -mechanism to define new disjoint types. A @dfn{record type} defines a -list of @dfn{fields} that instances of the type consist of. This is like -C's @code{struct}. - -Historically, Guile has offered several different ways to define record -types and to create records, offering different features, and making -different trade-offs. Over the years, each ``standard'' has also come -with its own new record interface, leading to a maze of record APIs. - -At the highest level is SRFI-9, a high-level record interface -implemented by most Scheme implementations (@pxref{SRFI-9 Records}). It -defines a simple and efficient syntactic abstraction of record types and -their associated type predicate, fields, and field accessors. SRFI-9 is -suitable for most uses, and this is the recommended way to create record -types in Guile. Similar high-level record APIs include SRFI-35 -(@pxref{SRFI-35}) and R6RS records (@pxref{rnrs records syntactic}). - -Then comes Guile's historical ``records'' API (@pxref{Records}). Record -types defined this way are first-class objects. Introspection -facilities are available, allowing users to query the list of fields or -the value of a specific field at run-time, without prior knowledge of -the type. - -Finally, the common denominator of these interfaces is Guile's -@dfn{structure} API (@pxref{Structures}). Guile's structures are the -low-level building block for all other record APIs. Application writers -will normally not need to use it. - -Records created with these APIs may all be pattern-matched using Guile's -standard pattern matcher (@pxref{Pattern Matching}). - - -@node SRFI-9 Records -@subsection SRFI-9 Records - -@cindex SRFI-9 -@cindex record - -SRFI-9 standardizes a syntax for defining new record types and creating -predicate, constructor, and field getter and setter functions. In Guile -this is the recommended option to create new record types (@pxref{Record -Overview}). It can be used with: - -@example -(use-modules (srfi srfi-9)) -@end example - -@deffn {Scheme Syntax} define-record-type type @* (constructor fieldname @dots{}) @* predicate @* (fieldname accessor [modifier]) @dots{} -@sp 1 -Create a new record type, and make various @code{define}s for using -it. This syntax can only occur at the top-level, not nested within -some other form. - -@var{type} is bound to the record type, which is as per the return -from the core @code{make-record-type}. @var{type} also provides the -name for the record, as per @code{record-type-name}. - -@var{constructor} is bound to a function to be called as -@code{(@var{constructor} fieldval @dots{})} to create a new record of -this type. The arguments are initial values for the fields, one -argument for each field, in the order they appear in the -@code{define-record-type} form. - -The @var{fieldname}s provide the names for the record fields, as per -the core @code{record-type-fields} etc, and are referred to in the -subsequent accessor/modifier forms. - -@var{predicate} is bound to a function to be called as -@code{(@var{predicate} obj)}. It returns @code{#t} or @code{#f} -according to whether @var{obj} is a record of this type. - -Each @var{accessor} is bound to a function to be called -@code{(@var{accessor} record)} to retrieve the respective field from a -@var{record}. Similarly each @var{modifier} is bound to a function to -be called @code{(@var{modifier} record val)} to set the respective -field in a @var{record}. -@end deffn - -@noindent -An example will illustrate typical usage, - -@example -(define-record-type - (make-employee name age salary) - employee? - (name employee-name) - (age employee-age set-employee-age!) - (salary employee-salary set-employee-salary!)) -@end example - -This creates a new employee data type, with name, age and salary -fields. Accessor functions are created for each field, but no -modifier function for the name (the intention in this example being -that it's established only when an employee object is created). These -can all then be used as for example, - -@example - @result{} #> - -(define fred (make-employee "Fred" 45 20000.00)) - -(employee? fred) @result{} #t -(employee-age fred) @result{} 45 -(set-employee-salary! fred 25000.00) ;; pay rise -@end example - -The functions created by @code{define-record-type} are ordinary -top-level @code{define}s. They can be redefined or @code{set!} as -desired, exported from a module, etc. - -@unnumberedsubsubsec Non-toplevel Record Definitions - -The SRFI-9 specification explicitly disallows record definitions in a -non-toplevel context, such as inside @code{lambda} body or inside a -@var{let} block. However, Guile's implementation does not enforce that -restriction. - -@unnumberedsubsubsec Custom Printers - -You may use @code{set-record-type-printer!} to customize the default printing -behavior of records. This is a Guile extension and is not part of SRFI-9. It -is located in the @nicode{(srfi srfi-9 gnu)} module. - -@deffn {Scheme Syntax} set-record-type-printer! type proc -Where @var{type} corresponds to the first argument of @code{define-record-type}, -and @var{proc} is a procedure accepting two arguments, the record to print, and -an output port. -@end deffn - -@noindent -This example prints the employee's name in brackets, for instance @code{[Fred]}. - -@example -(set-record-type-printer! - (lambda (record port) - (write-char #\[ port) - (display (employee-name record) port) - (write-char #\] port))) -@end example - -@unnumberedsubsubsec Functional ``Setters'' - -@cindex functional setters - -When writing code in a functional style, it is desirable to never alter -the contents of records. For such code, a simple way to return new -record instances based on existing ones is highly desirable. - -The @code{(srfi srfi-9 gnu)} module extends SRFI-9 with facilities to -return new record instances based on existing ones, only with one or -more field values changed---@dfn{functional setters}. First, the -@code{define-immutable-record-type} works like -@code{define-record-type}, except that fields are immutable and setters -are defined as functional setters. - -@deffn {Scheme Syntax} define-immutable-record-type type @* (constructor fieldname @dots{}) @* predicate @* (fieldname accessor [modifier]) @dots{} -Define @var{type} as a new record type, like @code{define-record-type}. -However, the record type is made @emph{immutable} (records may not be -mutated, even with @code{struct-set!}), and any @var{modifier} is -defined to be a functional setter---a procedure that returns a new -record instance with the specified field changed, and leaves the -original unchanged (see example below.) -@end deffn - -@noindent -In addition, the generic @code{set-field} and @code{set-fields} macros -may be applied to any SRFI-9 record. - -@deffn {Scheme Syntax} set-field record (field sub-fields ...) value -Return a new record of @var{record}'s type whose fields are equal to -the corresponding fields of @var{record} except for the one specified by -@var{field}. - -@var{field} must be the name of the getter corresponding to the field of -@var{record} being ``set''. Subsequent @var{sub-fields} must be record -getters designating sub-fields within that field value to be set (see -example below.) -@end deffn - -@deffn {Scheme Syntax} set-fields record ((field sub-fields ...) value) ... -Like @code{set-field}, but can be used to set more than one field at a -time. This expands to code that is more efficient than a series of -single @code{set-field} calls. -@end deffn - -To illustrate the use of functional setters, let's assume these two -record type definitions: - -@example -(define-record-type
- (address street city country) - address? - (street address-street) - (city address-city) - (country address-country)) - -(define-immutable-record-type - (person age email address) - person? - (age person-age set-person-age) - (email person-email set-person-email) - (address person-address set-person-address)) -@end example - -@noindent -First, note that the @code{} record type definition introduces -named functional setters. These may be used like this: - -@example -(define fsf-address - (address "Franklin Street" "Boston" "USA")) - -(define rms - (person 30 "rms@@gnu.org" fsf-address)) - -(and (equal? (set-person-age rms 60) - (person 60 "rms@@gnu.org" fsf-address)) - (= (person-age rms) 30)) -@result{} #t -@end example - -@noindent -Here, the original @code{} record, to which @var{rms} is bound, -is left unchanged. - -Now, suppose we want to change both the street and age of @var{rms}. -This can be achieved using @code{set-fields}: - -@example -(set-fields rms - ((person-age) 60) - ((person-address address-street) "Temple Place")) -@result{} #< age: 60 email: "rms@@gnu.org" - address: #<
street: "Temple Place" city: "Boston" country: "USA">> -@end example - -@noindent -Notice how the above changed two fields of @var{rms}, including the -@code{street} field of its @code{address} field, in a concise way. Also -note that @code{set-fields} works equally well for types defined with -just @code{define-record-type}. - -@node Records -@subsection Records - -A @dfn{record type} is a first class object representing a user-defined -data type. A @dfn{record} is an instance of a record type. - -Note that in many ways, this interface is too low-level for every-day -use. Most uses of records are better served by SRFI-9 records. -@xref{SRFI-9 Records}. - -@deffn {Scheme Procedure} record? obj -Return @code{#t} if @var{obj} is a record of any type and @code{#f} -otherwise. - -Note that @code{record?} may be true of any Scheme value; there is no -promise that records are disjoint with other Scheme types. -@end deffn - -@deffn {Scheme Procedure} make-record-type type-name field-names [print] -Create and return a new @dfn{record-type descriptor}. - -@var{type-name} is a string naming the type. Currently it's only used -in the printed representation of records, and in diagnostics. -@var{field-names} is a list of symbols naming the fields of a record -of the type. Duplicates are not allowed among these symbols. - -@example -(make-record-type "employee" '(name age salary)) -@end example - -The optional @var{print} argument is a function used by -@code{display}, @code{write}, etc, for printing a record of the new -type. It's called as @code{(@var{print} record port)} and should look -at @var{record} and write to @var{port}. -@end deffn - -@deffn {Scheme Procedure} record-constructor rtd [field-names] -Return a procedure for constructing new members of the type represented -by @var{rtd}. The returned procedure accepts exactly as many arguments -as there are symbols in the given list, @var{field-names}; these are -used, in order, as the initial values of those fields in a new record, -which is returned by the constructor procedure. The values of any -fields not named in that list are unspecified. The @var{field-names} -argument defaults to the list of field names in the call to -@code{make-record-type} that created the type represented by @var{rtd}; -if the @var{field-names} argument is provided, it is an error if it -contains any duplicates or any symbols not in the default list. -@end deffn - -@deffn {Scheme Procedure} record-predicate rtd -Return a procedure for testing membership in the type represented by -@var{rtd}. The returned procedure accepts exactly one argument and -returns a true value if the argument is a member of the indicated record -type; it returns a false value otherwise. -@end deffn - -@deffn {Scheme Procedure} record-accessor rtd field-name -Return a procedure for reading the value of a particular field of a -member of the type represented by @var{rtd}. The returned procedure -accepts exactly one argument which must be a record of the appropriate -type; it returns the current value of the field named by the symbol -@var{field-name} in that record. The symbol @var{field-name} must be a -member of the list of field-names in the call to @code{make-record-type} -that created the type represented by @var{rtd}. -@end deffn - -@deffn {Scheme Procedure} record-modifier rtd field-name -Return a procedure for writing the value of a particular field of a -member of the type represented by @var{rtd}. The returned procedure -accepts exactly two arguments: first, a record of the appropriate type, -and second, an arbitrary Scheme value; it modifies the field named by -the symbol @var{field-name} in that record to contain the given value. -The returned value of the modifier procedure is unspecified. The symbol -@var{field-name} must be a member of the list of field-names in the call -to @code{make-record-type} that created the type represented by -@var{rtd}. -@end deffn - -@deffn {Scheme Procedure} record-type-descriptor record -Return a record-type descriptor representing the type of the given -record. That is, for example, if the returned descriptor were passed to -@code{record-predicate}, the resulting predicate would return a true -value when passed the given record. Note that it is not necessarily the -case that the returned descriptor is the one that was passed to -@code{record-constructor} in the call that created the constructor -procedure that created the given record. -@end deffn - -@deffn {Scheme Procedure} record-type-name rtd -Return the type-name associated with the type represented by rtd. The -returned value is @code{eqv?} to the @var{type-name} argument given in -the call to @code{make-record-type} that created the type represented by -@var{rtd}. -@end deffn - -@deffn {Scheme Procedure} record-type-fields rtd -Return a list of the symbols naming the fields in members of the type -represented by @var{rtd}. The returned value is @code{equal?} to the -field-names argument given in the call to @code{make-record-type} that -created the type represented by @var{rtd}. -@end deffn - - -@node Structures -@subsection Structures -@tpindex Structures - -A @dfn{structure} is a first class data type which holds Scheme values -or C words in fields numbered 0 upwards. A @dfn{vtable} is a structure -that represents a structure type, giving field types and permissions, -and an optional print function for @code{write} etc. - -Structures are lower level than records (@pxref{Records}). Usually, -when you need to represent structured data, you just want to use -records. But sometimes you need to implement new kinds of structured -data abstractions, and for that purpose structures are useful. Indeed, -records in Guile are implemented with structures. - -@menu -* Vtables:: -* Structure Basics:: -* Vtable Contents:: -* Meta-Vtables:: -* Vtable Example:: -* Tail Arrays:: -@end menu - -@node Vtables -@subsubsection Vtables - -A vtable is a structure type, specifying its layout, and other -information. A vtable is actually itself a structure, but there's no -need to worry about that initially (@pxref{Vtable Contents}.) - -@deffn {Scheme Procedure} make-vtable fields [print] -Create a new vtable. - -@var{fields} is a string describing the fields in the structures to be -created. Each field is represented by two characters, a type letter -and a permissions letter, for example @code{"pw"}. The types are as -follows. - -@itemize @bullet{} -@item -@code{p} -- a Scheme value. ``p'' stands for ``protected'' meaning -it's protected against garbage collection. - -@item -@code{u} -- an arbitrary word of data (an @code{scm_t_bits}). At the -Scheme level it's read and written as an unsigned integer. ``u'' -stands for ``uninterpreted'' (it's not treated as a Scheme value), or -``unprotected'' (it's not marked during GC), or ``unsigned long'' (its -size), or all of these things. - -@item -@code{s} -- a self-reference. Such a field holds the @code{SCM} value -of the structure itself (a circular reference). This can be useful in -C code where you might have a pointer to the data array, and want to -get the Scheme @code{SCM} handle for the structure. In Scheme code it -has no use. -@end itemize - -The second letter for each field is a permission code, - -@itemize @bullet{} -@item -@code{w} -- writable, the field can be read and written. -@item -@code{r} -- read-only, the field can be read but not written. -@item -@code{o} -- opaque, the field can be neither read nor written at the -Scheme level. This can be used for fields which should only be used -from C code. -@end itemize - -Here are some examples. @xref{Tail Arrays}, for information on the -legacy tail array facility. - -@example -(make-vtable "pw") ;; one writable field -(make-vtable "prpw") ;; one read-only and one writable -(make-vtable "pwuwuw") ;; one scheme and two uninterpreted -@end example - -The optional @var{print} argument is a function called by -@code{display} and @code{write} (etc) to give a printed representation -of a structure created from this vtable. It's called -@code{(@var{print} struct port)} and should look at @var{struct} and -write to @var{port}. The default print merely gives a form like -@samp{#} with a pair of machine addresses. - -The following print function for example shows the two fields of its -structure. - -@example -(make-vtable "prpw" - (lambda (struct port) - (format port "#<~a and ~a>" - (struct-ref struct 0) - (struct-ref struct 1)))) -@end example -@end deffn - - -@node Structure Basics -@subsubsection Structure Basics - -This section describes the basic procedures for working with -structures. @code{make-struct} creates a structure, and -@code{struct-ref} and @code{struct-set!} access its fields. - -@deffn {Scheme Procedure} make-struct vtable tail-size init @dots{} -@deffnx {Scheme Procedure} make-struct/no-tail vtable init @dots{} -Create a new structure, with layout per the given @var{vtable} -(@pxref{Vtables}). - -The optional @var{init}@dots{} arguments are initial values for the -fields of the structure. This is the only way to -put values in read-only fields. If there are fewer @var{init} -arguments than fields then the defaults are @code{#f} for a Scheme -field (type @code{p}) or 0 for an uninterpreted field (type @code{u}). - -Structures also have the ability to allocate a variable number of -additional cells at the end, at their tails. However, this legacy -@dfn{tail array} facilty is confusing and inefficient, and so we do not -recommend it. @xref{Tail Arrays}, for more on the legacy tail array -interface. - -Type @code{s} self-reference fields, permission @code{o} opaque -fields, and the count field of a tail array are all ignored for the -@var{init} arguments, ie.@: an argument is not consumed by such a -field. An @code{s} is always set to the structure itself, an @code{o} -is always set to @code{#f} or 0 (with the intention that C code will -do something to it later), and the tail count is always the given -@var{tail-size}. - -For example, - -@example -(define v (make-vtable "prpwpw")) -(define s (make-struct v 0 123 "abc" 456)) -(struct-ref s 0) @result{} 123 -(struct-ref s 1) @result{} "abc" -@end example -@end deffn - -@deftypefn {C Function} SCM scm_make_struct (SCM vtable, SCM tail_size, SCM init_list) -@deftypefnx {C Function} SCM scm_c_make_struct (SCM vtable, SCM tail_size, SCM init, ...) -@deftypefnx {C Function} SCM scm_c_make_structv (SCM vtable, SCM tail_size, size_t n_inits, scm_t_bits init[]) -There are a few ways to make structures from C. @code{scm_make_struct} -takes a list, @code{scm_c_make_struct} takes variable arguments -terminated with SCM_UNDEFINED, and @code{scm_c_make_structv} takes a -packed array. -@end deftypefn - -@deffn {Scheme Procedure} struct? obj -@deffnx {C Function} scm_struct_p (obj) -Return @code{#t} if @var{obj} is a structure, or @code{#f} if not. -@end deffn - -@deffn {Scheme Procedure} struct-ref struct n -@deffnx {C Function} scm_struct_ref (struct, n) -Return the contents of field number @var{n} in @var{struct}. The -first field is number 0. - -An error is thrown if @var{n} is out of range, or if the field cannot -be read because it's @code{o} opaque. -@end deffn - -@deffn {Scheme Procedure} struct-set! struct n value -@deffnx {C Function} scm_struct_set_x (struct, n, value) -Set field number @var{n} in @var{struct} to @var{value}. The first -field is number 0. - -An error is thrown if @var{n} is out of range, or if the field cannot -be written because it's @code{r} read-only or @code{o} opaque. -@end deffn - -@deffn {Scheme Procedure} struct-vtable struct -@deffnx {C Function} scm_struct_vtable (struct) -Return the vtable that describes @var{struct}. - -The vtable is effectively the type of the structure. See @ref{Vtable -Contents}, for more on vtables. -@end deffn - - -@node Vtable Contents -@subsubsection Vtable Contents - -A vtable is itself a structure. It has a specific set of fields -describing various aspects of its @dfn{instances}: the structures -created from a vtable. Some of the fields are internal to Guile, some -of them are part of the public interface, and there may be additional -fields added on by the user. - -Every vtable has a field for the layout of their instances, a field for -the procedure used to print its instances, and a field for the name of -the vtable itself. Access to the layout and printer is exposed directly -via field indexes. Access to the vtable name is exposed via accessor -procedures. - -@defvr {Scheme Variable} vtable-index-layout -@defvrx {C Macro} scm_vtable_index_layout -The field number of the layout specification in a vtable. The layout -specification is a symbol like @code{pwpw} formed from the fields -string passed to @code{make-vtable}, or created by -@code{make-struct-layout} (@pxref{Meta-Vtables}). - -@example -(define v (make-vtable "pwpw" 0)) -(struct-ref v vtable-index-layout) @result{} pwpw -@end example - -This field is read-only, since the layout of structures using a vtable -cannot be changed. -@end defvr - -@defvr {Scheme Variable} vtable-index-printer -@defvrx {C Macro} scm_vtable_index_printer -The field number of the printer function. This field contains @code{#f} -if the default print function should be used. - -@example -(define (my-print-func struct port) - ...) -(define v (make-vtable "pwpw" my-print-func)) -(struct-ref v vtable-index-printer) @result{} my-print-func -@end example - -This field is writable, allowing the print function to be changed -dynamically. -@end defvr - -@deffn {Scheme Procedure} struct-vtable-name vtable -@deffnx {Scheme Procedure} set-struct-vtable-name! vtable name -@deffnx {C Function} scm_struct_vtable_name (vtable) -@deffnx {C Function} scm_set_struct_vtable_name_x (vtable, name) -Get or set the name of @var{vtable}. @var{name} is a symbol and is -used in the default print function when printing structures created -from @var{vtable}. - -@example -(define v (make-vtable "pw")) -(set-struct-vtable-name! v 'my-name) - -(define s (make-struct v 0)) -(display s) @print{} # -@end example -@end deffn - - -@node Meta-Vtables -@subsubsection Meta-Vtables - -As a structure, a vtable also has a vtable, which is also a structure. -Structures, their vtables, the vtables of the vtables, and so on form a -tree of structures. Making a new structure adds a leaf to the tree, and -if that structure is a vtable, it may be used to create other leaves. - -If you traverse up the tree of vtables, via calling -@code{struct-vtable}, eventually you reach a root which is the vtable of -itself: - -@example -scheme@@(guile-user)> (current-module) -$1 = # -scheme@@(guile-user)> (struct-vtable $1) -$2 = # -scheme@@(guile-user)> (struct-vtable $2) -$3 = #< 12c30a0> -scheme@@(guile-user)> (struct-vtable $3) -$4 = #< 12c3fa0> -scheme@@(guile-user)> (struct-vtable $4) -$5 = #< 12c3fa0> -scheme@@(guile-user)> -$6 = #< 12c3fa0> -@end example - -In this example, we can say that @code{$1} is an instance of @code{$2}, -@code{$2} is an instance of @code{$3}, @code{$3} is an instance of -@code{$4}, and @code{$4}, strangely enough, is an instance of itself. -The value bound to @code{$4} in this console session also bound to -@code{} in the default environment. - -@defvr {Scheme Variable} -A meta-vtable, useful for making new vtables. -@end defvr - -All of these values are structures. All but @code{$1} are vtables. As -@code{$2} is an instance of @code{$3}, and @code{$3} is a vtable, we can -say that @code{$3} is a @dfn{meta-vtable}: a vtable that can create -vtables. - -With this definition, we can specify more precisely what a vtable is: a -vtable is a structure made from a meta-vtable. Making a structure from -a meta-vtable runs some special checks to ensure that the first field of -the structure is a valid layout. Additionally, if these checks see that -the layout of the child vtable contains all the required fields of a -vtable, in the correct order, then the child vtable will also be a -meta-table, inheriting a magical bit from the parent. - -@deffn {Scheme Procedure} struct-vtable? obj -@deffnx {C Function} scm_struct_vtable_p (obj) -Return @code{#t} if @var{obj} is a vtable structure: an instance of a -meta-vtable. -@end deffn - -@code{} is a root of the vtable tree. (Normally there -is only one root in a given Guile process, but due to some legacy -interfaces there may be more than one.) - -The set of required fields of a vtable is the set of fields in the -@code{}, and is bound to @code{standard-vtable-fields} -in the default environment. It is possible to create a meta-vtable that -with additional fields in its layout, which can be used to create -vtables with additional data: - -@example -scheme@@(guile-user)> (struct-ref $3 vtable-index-layout) -$6 = pruhsruhpwphuhuhprprpw -scheme@@(guile-user)> (struct-ref $4 vtable-index-layout) -$7 = pruhsruhpwphuhuh -scheme@@(guile-user)> standard-vtable-fields -$8 = "pruhsruhpwphuhuh" -scheme@@(guile-user)> (struct-ref $2 vtable-offset-user) -$9 = module -@end example - -In this continuation of our earlier example, @code{$2} is a vtable that -has extra fields, because its vtable, @code{$3}, was made from a -meta-vtable with an extended layout. @code{vtable-offset-user} is a -convenient definition that indicates the number of fields in -@code{standard-vtable-fields}. - -@defvr {Scheme Variable} standard-vtable-fields -A string containing the ordered set of fields that a vtable must have. -@end defvr - -@defvr {Scheme Variable} vtable-offset-user -The first index in a vtable that is available for a user. -@end defvr - -@deffn {Scheme Procedure} make-struct-layout fields -@deffnx {C Function} scm_make_struct_layout (fields) -Return a structure layout symbol, from a @var{fields} string. -@var{fields} is as described under @code{make-vtable} -(@pxref{Vtables}). An invalid @var{fields} string is an error. -@end deffn - -With these definitions, one can define @code{make-vtable} in this way: - -@example -(define* (make-vtable fields #:optional printer) - (make-struct/no-tail - (make-struct-layout fields) - printer)) -@end example - - -@node Vtable Example -@subsubsection Vtable Example - -Let us bring these points together with an example. Consider a simple -object system with single inheritance. Objects will be normal -structures, and classes will be vtables with three extra class fields: -the name of the class, the parent class, and the list of fields. - -So, first we need a meta-vtable that allocates instances with these -extra class fields. - -@example -(define - (make-vtable - (string-append standard-vtable-fields "pwpwpw") - (lambda (x port) - (format port "< ~a>" (class-name x))))) - -(define (class? x) - (and (struct? x) - (eq? (struct-vtable x) ))) -@end example - -To make a structure with a specific meta-vtable, we will use -@code{make-struct/no-tail}, passing it the computed instance layout and -printer, as with @code{make-vtable}, and additionally the extra three -class fields. - -@example -(define (make-class name parent fields) - (let* ((fields (compute-fields parent fields)) - (layout (compute-layout fields))) - (make-struct/no-tail - layout - (lambda (x port) - (print-instance x port)) - name - parent - fields))) -@end example - -Instances will store their associated data in slots in the structure: as -many slots as there are fields. The @code{compute-layout} procedure -below can compute a layout, and @code{field-index} returns the slot -corresponding to a field. - -@example -(define-syntax-rule (define-accessor name n) - (define (name obj) - (struct-ref obj n))) - -;; Accessors for classes -(define-accessor class-name (+ vtable-offset-user 0)) -(define-accessor class-parent (+ vtable-offset-user 1)) -(define-accessor class-fields (+ vtable-offset-user 2)) - -(define (compute-fields parent fields) - (if parent - (append (class-fields parent) fields) - fields)) - -(define (compute-layout fields) - (make-struct-layout - (string-concatenate (make-list (length fields) "pw")))) - -(define (field-index class field) - (list-index (class-fields class) field)) - -(define (print-instance x port) - (format port "<~a" (class-name (struct-vtable x))) - (for-each (lambda (field idx) - (format port " ~a: ~a" field (struct-ref x idx))) - (class-fields (struct-vtable x)) - (iota (length (class-fields (struct-vtable x))))) - (format port ">")) -@end example - -So, at this point we can actually make a few classes: - -@example -(define-syntax-rule (define-class name parent field ...) - (define name (make-class 'name parent '(field ...)))) - -(define-class #f - width height) - -(define-class - x y) -@end example - -And finally, make an instance: - -@example -(make-struct/no-tail 400 300 10 20) -@result{} < width: 400 height: 300 x: 10 y: 20> -@end example - -And that's that. Note that there are many possible optimizations and -feature enhancements that can be made to this object system, and the -included GOOPS system does make most of them. For more simple use -cases, the records facility is usually sufficient. But sometimes you -need to make new kinds of data abstractions, and for that purpose, -structs are here. - -@node Tail Arrays -@subsubsection Tail Arrays - -Guile's structures have a facility whereby each instance of a vtable can -contain a variable-length tail array of values. The length of the tail -array is stored in the structure. This facility was originally intended -to allow C code to expose raw C structures with word-sized tail arrays -to Scheme. - -However, the tail array facility is confusing and doesn't work very -well. It is very rarely used, but it insinuates itself into all -invocations of @code{make-struct}. For this reason the clumsily-named -@code{make-struct/no-tail} procedure can actually be more elegant in -actual use, because it doesn't have a random @code{0} argument stuck in -the middle. - -Tail arrays also inhibit optimization by allowing instances to affect -their shapes. In the absence of tail arrays, all instances of a given -vtable have the same number and kinds of fields. This uniformity can be -exploited by the runtime and the optimizer. The presence of tail arrays -make some of these optimizations more difficult. - -Finally, the tail array facility is ad-hoc and does not compose with the -rest of Guile. If a Guile user wants an array with user-specified -length, it's best to use a vector. It is more clear in the code, and -the standard optimization techniques will do a good job with it. - -That said, we should mention some details about the interface. A vtable -that has tail array has upper-case permission descriptors: @code{W}, -@code{R} or @code{O}, correspoding to tail arrays of writable, -read-only, or opaque elements. A tail array permission descriptor may -only appear in the last element of a vtable layout. - -For exampple, @samp{pW} indicates a tail of writable Scheme-valued -fields. The @samp{pW} field itself holds the tail size, and the tail -fields come after it. - -@example -(define v (make-vtable "prpW")) ;; one fixed then a tail array -(define s (make-struct v 6 "fixed field" 'x 'y)) -(struct-ref s 0) @result{} "fixed field" -(struct-ref s 1) @result{} 2 ;; tail size -(struct-ref s 2) @result{} x ;; tail array ... -(struct-ref s 3) @result{} y -(struct-ref s 4) @result{} #f -@end example - - -@node Dictionary Types -@subsection Dictionary Types - -A @dfn{dictionary} object is a data structure used to index -information in a user-defined way. In standard Scheme, the main -aggregate data types are lists and vectors. Lists are not really -indexed at all, and vectors are indexed only by number -(e.g.@: @code{(vector-ref foo 5)}). Often you will find it useful -to index your data on some other type; for example, in a library -catalog you might want to look up a book by the name of its -author. Dictionaries are used to help you organize information in -such a way. - -An @dfn{association list} (or @dfn{alist} for short) is a list of -key-value pairs. Each pair represents a single quantity or -object; the @code{car} of the pair is a key which is used to -identify the object, and the @code{cdr} is the object's value. - -A @dfn{hash table} also permits you to index objects with -arbitrary keys, but in a way that makes looking up any one object -extremely fast. A well-designed hash system makes hash table -lookups almost as fast as conventional array or vector references. - -Alists are popular among Lisp programmers because they use only -the language's primitive operations (lists, @dfn{car}, @dfn{cdr} -and the equality primitives). No changes to the language core are -necessary. Therefore, with Scheme's built-in list manipulation -facilities, it is very convenient to handle data stored in an -association list. Also, alists are highly portable and can be -easily implemented on even the most minimal Lisp systems. - -However, alists are inefficient, especially for storing large -quantities of data. Because we want Guile to be useful for large -software systems as well as small ones, Guile provides a rich set -of tools for using either association lists or hash tables. - -@node Association Lists -@subsection Association Lists -@tpindex Association Lists -@tpindex Alist -@cindex association List -@cindex alist -@cindex database - -An association list is a conventional data structure that is often used -to implement simple key-value databases. It consists of a list of -entries in which each entry is a pair. The @dfn{key} of each entry is -the @code{car} of the pair and the @dfn{value} of each entry is the -@code{cdr}. - -@example -ASSOCIATION LIST ::= '( (KEY1 . VALUE1) - (KEY2 . VALUE2) - (KEY3 . VALUE3) - @dots{} - ) -@end example - -@noindent -Association lists are also known, for short, as @dfn{alists}. - -The structure of an association list is just one example of the infinite -number of possible structures that can be built using pairs and lists. -As such, the keys and values in an association list can be manipulated -using the general list structure procedures @code{cons}, @code{car}, -@code{cdr}, @code{set-car!}, @code{set-cdr!} and so on. However, -because association lists are so useful, Guile also provides specific -procedures for manipulating them. - -@menu -* Alist Key Equality:: -* Adding or Setting Alist Entries:: -* Retrieving Alist Entries:: -* Removing Alist Entries:: -* Sloppy Alist Functions:: -* Alist Example:: -@end menu - -@node Alist Key Equality -@subsubsection Alist Key Equality - -All of Guile's dedicated association list procedures, apart from -@code{acons}, come in three flavours, depending on the level of equality -that is required to decide whether an existing key in the association -list is the same as the key that the procedure call uses to identify the -required entry. - -@itemize @bullet -@item -Procedures with @dfn{assq} in their name use @code{eq?} to determine key -equality. - -@item -Procedures with @dfn{assv} in their name use @code{eqv?} to determine -key equality. - -@item -Procedures with @dfn{assoc} in their name use @code{equal?} to -determine key equality. -@end itemize - -@code{acons} is an exception because it is used to build association -lists which do not require their entries' keys to be unique. - -@node Adding or Setting Alist Entries -@subsubsection Adding or Setting Alist Entries - -@code{acons} adds a new entry to an association list and returns the -combined association list. The combined alist is formed by consing the -new entry onto the head of the alist specified in the @code{acons} -procedure call. So the specified alist is not modified, but its -contents become shared with the tail of the combined alist that -@code{acons} returns. - -In the most common usage of @code{acons}, a variable holding the -original association list is updated with the combined alist: - -@example -(set! address-list (acons name address address-list)) -@end example - -In such cases, it doesn't matter that the old and new values of -@code{address-list} share some of their contents, since the old value is -usually no longer independently accessible. - -Note that @code{acons} adds the specified new entry regardless of -whether the alist may already contain entries with keys that are, in -some sense, the same as that of the new entry. Thus @code{acons} is -ideal for building alists where there is no concept of key uniqueness. - -@example -(set! task-list (acons 3 "pay gas bill" '())) -task-list -@result{} -((3 . "pay gas bill")) - -(set! task-list (acons 3 "tidy bedroom" task-list)) -task-list -@result{} -((3 . "tidy bedroom") (3 . "pay gas bill")) -@end example - -@code{assq-set!}, @code{assv-set!} and @code{assoc-set!} are used to add -or replace an entry in an association list where there @emph{is} a -concept of key uniqueness. If the specified association list already -contains an entry whose key is the same as that specified in the -procedure call, the existing entry is replaced by the new one. -Otherwise, the new entry is consed onto the head of the old association -list to create the combined alist. In all cases, these procedures -return the combined alist. - -@code{assq-set!} and friends @emph{may} destructively modify the -structure of the old association list in such a way that an existing -variable is correctly updated without having to @code{set!} it to the -value returned: - -@example -address-list -@result{} -(("mary" . "34 Elm Road") ("james" . "16 Bow Street")) - -(assoc-set! address-list "james" "1a London Road") -@result{} -(("mary" . "34 Elm Road") ("james" . "1a London Road")) - -address-list -@result{} -(("mary" . "34 Elm Road") ("james" . "1a London Road")) -@end example - -Or they may not: - -@example -(assoc-set! address-list "bob" "11 Newington Avenue") -@result{} -(("bob" . "11 Newington Avenue") ("mary" . "34 Elm Road") - ("james" . "1a London Road")) - -address-list -@result{} -(("mary" . "34 Elm Road") ("james" . "1a London Road")) -@end example - -The only safe way to update an association list variable when adding or -replacing an entry like this is to @code{set!} the variable to the -returned value: - -@example -(set! address-list - (assoc-set! address-list "bob" "11 Newington Avenue")) -address-list -@result{} -(("bob" . "11 Newington Avenue") ("mary" . "34 Elm Road") - ("james" . "1a London Road")) -@end example - -Because of this slight inconvenience, you may find it more convenient to -use hash tables to store dictionary data. If your application will not -be modifying the contents of an alist very often, this may not make much -difference to you. - -If you need to keep the old value of an association list in a form -independent from the list that results from modification by -@code{acons}, @code{assq-set!}, @code{assv-set!} or @code{assoc-set!}, -use @code{list-copy} to copy the old association list before modifying -it. - -@deffn {Scheme Procedure} acons key value alist -@deffnx {C Function} scm_acons (key, value, alist) -Add a new key-value pair to @var{alist}. A new pair is -created whose car is @var{key} and whose cdr is @var{value}, and the -pair is consed onto @var{alist}, and the new list is returned. This -function is @emph{not} destructive; @var{alist} is not modified. -@end deffn - -@deffn {Scheme Procedure} assq-set! alist key val -@deffnx {Scheme Procedure} assv-set! alist key value -@deffnx {Scheme Procedure} assoc-set! alist key value -@deffnx {C Function} scm_assq_set_x (alist, key, val) -@deffnx {C Function} scm_assv_set_x (alist, key, val) -@deffnx {C Function} scm_assoc_set_x (alist, key, val) -Reassociate @var{key} in @var{alist} with @var{value}: find any existing -@var{alist} entry for @var{key} and associate it with the new -@var{value}. If @var{alist} does not contain an entry for @var{key}, -add a new one. Return the (possibly new) alist. - -These functions do not attempt to verify the structure of @var{alist}, -and so may cause unusual results if passed an object that is not an -association list. -@end deffn - -@node Retrieving Alist Entries -@subsubsection Retrieving Alist Entries -@rnindex assq -@rnindex assv -@rnindex assoc - -@code{assq}, @code{assv} and @code{assoc} find the entry in an alist -for a given key, and return the @code{(@var{key} . @var{value})} pair. -@code{assq-ref}, @code{assv-ref} and @code{assoc-ref} do a similar -lookup, but return just the @var{value}. - -@deffn {Scheme Procedure} assq key alist -@deffnx {Scheme Procedure} assv key alist -@deffnx {Scheme Procedure} assoc key alist -@deffnx {C Function} scm_assq (key, alist) -@deffnx {C Function} scm_assv (key, alist) -@deffnx {C Function} scm_assoc (key, alist) -Return the first entry in @var{alist} with the given @var{key}. The -return is the pair @code{(KEY . VALUE)} from @var{alist}. If there's -no matching entry the return is @code{#f}. - -@code{assq} compares keys with @code{eq?}, @code{assv} uses -@code{eqv?} and @code{assoc} uses @code{equal?}. See also SRFI-1 -which has an extended @code{assoc} (@ref{SRFI-1 Association Lists}). -@end deffn - -@deffn {Scheme Procedure} assq-ref alist key -@deffnx {Scheme Procedure} assv-ref alist key -@deffnx {Scheme Procedure} assoc-ref alist key -@deffnx {C Function} scm_assq_ref (alist, key) -@deffnx {C Function} scm_assv_ref (alist, key) -@deffnx {C Function} scm_assoc_ref (alist, key) -Return the value from the first entry in @var{alist} with the given -@var{key}, or @code{#f} if there's no such entry. - -@code{assq-ref} compares keys with @code{eq?}, @code{assv-ref} uses -@code{eqv?} and @code{assoc-ref} uses @code{equal?}. - -Notice these functions have the @var{key} argument last, like other -@code{-ref} functions, but this is opposite to what @code{assq} -etc above use. - -When the return is @code{#f} it can be either @var{key} not found, or -an entry which happens to have value @code{#f} in the @code{cdr}. Use -@code{assq} etc above if you need to differentiate these cases. -@end deffn - - -@node Removing Alist Entries -@subsubsection Removing Alist Entries - -To remove the element from an association list whose key matches a -specified key, use @code{assq-remove!}, @code{assv-remove!} or -@code{assoc-remove!} (depending, as usual, on the level of equality -required between the key that you specify and the keys in the -association list). - -As with @code{assq-set!} and friends, the specified alist may or may not -be modified destructively, and the only safe way to update a variable -containing the alist is to @code{set!} it to the value that -@code{assq-remove!} and friends return. - -@example -address-list -@result{} -(("bob" . "11 Newington Avenue") ("mary" . "34 Elm Road") - ("james" . "1a London Road")) - -(set! address-list (assoc-remove! address-list "mary")) -address-list -@result{} -(("bob" . "11 Newington Avenue") ("james" . "1a London Road")) -@end example - -Note that, when @code{assq/v/oc-remove!} is used to modify an -association list that has been constructed only using the corresponding -@code{assq/v/oc-set!}, there can be at most one matching entry in the -alist, so the question of multiple entries being removed in one go does -not arise. If @code{assq/v/oc-remove!} is applied to an association -list that has been constructed using @code{acons}, or an -@code{assq/v/oc-set!} with a different level of equality, or any mixture -of these, it removes only the first matching entry from the alist, even -if the alist might contain further matching entries. For example: - -@example -(define address-list '()) -(set! address-list (assq-set! address-list "mary" "11 Elm Street")) -(set! address-list (assq-set! address-list "mary" "57 Pine Drive")) -address-list -@result{} -(("mary" . "57 Pine Drive") ("mary" . "11 Elm Street")) - -(set! address-list (assoc-remove! address-list "mary")) -address-list -@result{} -(("mary" . "11 Elm Street")) -@end example - -In this example, the two instances of the string "mary" are not the same -when compared using @code{eq?}, so the two @code{assq-set!} calls add -two distinct entries to @code{address-list}. When compared using -@code{equal?}, both "mary"s in @code{address-list} are the same as the -"mary" in the @code{assoc-remove!} call, but @code{assoc-remove!} stops -after removing the first matching entry that it finds, and so one of the -"mary" entries is left in place. - -@deffn {Scheme Procedure} assq-remove! alist key -@deffnx {Scheme Procedure} assv-remove! alist key -@deffnx {Scheme Procedure} assoc-remove! alist key -@deffnx {C Function} scm_assq_remove_x (alist, key) -@deffnx {C Function} scm_assv_remove_x (alist, key) -@deffnx {C Function} scm_assoc_remove_x (alist, key) -Delete the first entry in @var{alist} associated with @var{key}, and return -the resulting alist. -@end deffn - -@node Sloppy Alist Functions -@subsubsection Sloppy Alist Functions - -@code{sloppy-assq}, @code{sloppy-assv} and @code{sloppy-assoc} behave -like the corresponding non-@code{sloppy-} procedures, except that they -return @code{#f} when the specified association list is not well-formed, -where the non-@code{sloppy-} versions would signal an error. - -Specifically, there are two conditions for which the non-@code{sloppy-} -procedures signal an error, which the @code{sloppy-} procedures handle -instead by returning @code{#f}. Firstly, if the specified alist as a -whole is not a proper list: - -@example -(assoc "mary" '((1 . 2) ("key" . "door") . "open sesame")) -@result{} -ERROR: In procedure assoc in expression (assoc "mary" (quote #)): -ERROR: Wrong type argument in position 2 (expecting - association list): ((1 . 2) ("key" . "door") . "open sesame") - -(sloppy-assoc "mary" '((1 . 2) ("key" . "door") . "open sesame")) -@result{} -#f -@end example - -@noindent -Secondly, if one of the entries in the specified alist is not a pair: - -@example -(assoc 2 '((1 . 1) 2 (3 . 9))) -@result{} -ERROR: In procedure assoc in expression (assoc 2 (quote #)): -ERROR: Wrong type argument in position 2 (expecting - association list): ((1 . 1) 2 (3 . 9)) - -(sloppy-assoc 2 '((1 . 1) 2 (3 . 9))) -@result{} -#f -@end example - -Unless you are explicitly working with badly formed association lists, -it is much safer to use the non-@code{sloppy-} procedures, because they -help to highlight coding and data errors that the @code{sloppy-} -versions would silently cover up. - -@deffn {Scheme Procedure} sloppy-assq key alist -@deffnx {C Function} scm_sloppy_assq (key, alist) -Behaves like @code{assq} but does not do any error checking. -Recommended only for use in Guile internals. -@end deffn - -@deffn {Scheme Procedure} sloppy-assv key alist -@deffnx {C Function} scm_sloppy_assv (key, alist) -Behaves like @code{assv} but does not do any error checking. -Recommended only for use in Guile internals. -@end deffn - -@deffn {Scheme Procedure} sloppy-assoc key alist -@deffnx {C Function} scm_sloppy_assoc (key, alist) -Behaves like @code{assoc} but does not do any error checking. -Recommended only for use in Guile internals. -@end deffn - -@node Alist Example -@subsubsection Alist Example - -Here is a longer example of how alists may be used in practice. - -@lisp -(define capitals '(("New York" . "Albany") - ("Oregon" . "Salem") - ("Florida" . "Miami"))) - -;; What's the capital of Oregon? -(assoc "Oregon" capitals) @result{} ("Oregon" . "Salem") -(assoc-ref capitals "Oregon") @result{} "Salem" - -;; We left out South Dakota. -(set! capitals - (assoc-set! capitals "South Dakota" "Pierre")) -capitals -@result{} (("South Dakota" . "Pierre") - ("New York" . "Albany") - ("Oregon" . "Salem") - ("Florida" . "Miami")) - -;; And we got Florida wrong. -(set! capitals - (assoc-set! capitals "Florida" "Tallahassee")) -capitals -@result{} (("South Dakota" . "Pierre") - ("New York" . "Albany") - ("Oregon" . "Salem") - ("Florida" . "Tallahassee")) - -;; After Oregon secedes, we can remove it. -(set! capitals - (assoc-remove! capitals "Oregon")) -capitals -@result{} (("South Dakota" . "Pierre") - ("New York" . "Albany") - ("Florida" . "Tallahassee")) -@end lisp - -@node VHashes -@subsection VList-Based Hash Lists or ``VHashes'' - -@cindex VList-based hash lists -@cindex VHash - -The @code{(ice-9 vlist)} module provides an implementation of @dfn{VList-based -hash lists} (@pxref{VLists}). VList-based hash lists, or @dfn{vhashes}, are an -immutable dictionary type similar to association lists that maps @dfn{keys} to -@dfn{values}. However, unlike association lists, accessing a value given its -key is typically a constant-time operation. - -The VHash programming interface of @code{(ice-9 vlist)} is mostly the same as -that of association lists found in SRFI-1, with procedure names prefixed by -@code{vhash-} instead of @code{alist-} (@pxref{SRFI-1 Association Lists}). - -In addition, vhashes can be manipulated using VList operations: - -@example -(vlist-head (vhash-consq 'a 1 vlist-null)) -@result{} (a . 1) - -(define vh1 (vhash-consq 'b 2 (vhash-consq 'a 1 vlist-null))) -(define vh2 (vhash-consq 'c 3 (vlist-tail vh1))) - -(vhash-assq 'a vh2) -@result{} (a . 1) -(vhash-assq 'b vh2) -@result{} #f -(vhash-assq 'c vh2) -@result{} (c . 3) -(vlist->list vh2) -@result{} ((c . 3) (a . 1)) -@end example - -However, keep in mind that procedures that construct new VLists -(@code{vlist-map}, @code{vlist-filter}, etc.) return raw VLists, not vhashes: - -@example -(define vh (alist->vhash '((a . 1) (b . 2) (c . 3)) hashq)) -(vhash-assq 'a vh) -@result{} (a . 1) - -(define vl - ;; This will create a raw vlist. - (vlist-filter (lambda (key+value) (odd? (cdr key+value))) vh)) -(vhash-assq 'a vl) -@result{} ERROR: Wrong type argument in position 2 - -(vlist->list vl) -@result{} ((a . 1) (c . 3)) -@end example - -@deffn {Scheme Procedure} vhash? obj -Return true if @var{obj} is a vhash. -@end deffn - -@deffn {Scheme Procedure} vhash-cons key value vhash [hash-proc] -@deffnx {Scheme Procedure} vhash-consq key value vhash -@deffnx {Scheme Procedure} vhash-consv key value vhash -Return a new hash list based on @var{vhash} where @var{key} is associated with -@var{value}, using @var{hash-proc} to compute the hash of @var{key}. -@var{vhash} must be either @code{vlist-null} or a vhash returned by a previous -call to @code{vhash-cons}. @var{hash-proc} defaults to @code{hash} (@pxref{Hash -Table Reference, @code{hash} procedure}). With @code{vhash-consq}, the -@code{hashq} hash function is used; with @code{vhash-consv} the @code{hashv} -hash function is used. - -All @code{vhash-cons} calls made to construct a vhash should use the same -@var{hash-proc}. Failing to do that, the result is undefined. -@end deffn - -@deffn {Scheme Procedure} vhash-assoc key vhash [equal? [hash-proc]] -@deffnx {Scheme Procedure} vhash-assq key vhash -@deffnx {Scheme Procedure} vhash-assv key vhash -Return the first key/value pair from @var{vhash} whose key is equal to @var{key} -according to the @var{equal?} equality predicate (which defaults to -@code{equal?}), and using @var{hash-proc} (which defaults to @code{hash}) to -compute the hash of @var{key}. The second form uses @code{eq?} as the equality -predicate and @code{hashq} as the hash function; the last form uses @code{eqv?} -and @code{hashv}. - -Note that it is important to consistently use the same hash function for -@var{hash-proc} as was passed to @code{vhash-cons}. Failing to do that, the -result is unpredictable. -@end deffn - -@deffn {Scheme Procedure} vhash-delete key vhash [equal? [hash-proc]] -@deffnx {Scheme Procedure} vhash-delq key vhash -@deffnx {Scheme Procedure} vhash-delv key vhash -Remove all associations from @var{vhash} with @var{key}, comparing keys with -@var{equal?} (which defaults to @code{equal?}), and computing the hash of -@var{key} using @var{hash-proc} (which defaults to @code{hash}). The second -form uses @code{eq?} as the equality predicate and @code{hashq} as the hash -function; the last one uses @code{eqv?} and @code{hashv}. - -Again the choice of @var{hash-proc} must be consistent with previous calls to -@code{vhash-cons}. -@end deffn - -@deffn {Scheme Procedure} vhash-fold proc init vhash -@deffnx {Scheme Procedure} vhash-fold-right proc init vhash -Fold over the key/value elements of @var{vhash} in the given direction, -with each call to @var{proc} having the form @code{(@var{proc} key value -result)}, where @var{result} is the result of the previous call to -@var{proc} and @var{init} the value of @var{result} for the first call -to @var{proc}. -@end deffn - -@deffn {Scheme Procedure} vhash-fold* proc init key vhash [equal? [hash]] -@deffnx {Scheme Procedure} vhash-foldq* proc init key vhash -@deffnx {Scheme Procedure} vhash-foldv* proc init key vhash -Fold over all the values associated with @var{key} in @var{vhash}, with each -call to @var{proc} having the form @code{(proc value result)}, where -@var{result} is the result of the previous call to @var{proc} and @var{init} the -value of @var{result} for the first call to @var{proc}. - -Keys in @var{vhash} are hashed using @var{hash} are compared using @var{equal?}. -The second form uses @code{eq?} as the equality predicate and @code{hashq} as -the hash function; the third one uses @code{eqv?} and @code{hashv}. - -Example: - -@example -(define vh - (alist->vhash '((a . 1) (a . 2) (z . 0) (a . 3)))) - -(vhash-fold* cons '() 'a vh) -@result{} (3 2 1) - -(vhash-fold* cons '() 'z vh) -@result{} (0) -@end example -@end deffn - -@deffn {Scheme Procedure} alist->vhash alist [hash-proc] -Return the vhash corresponding to @var{alist}, an association list, using -@var{hash-proc} to compute key hashes. When omitted, @var{hash-proc} defaults -to @code{hash}. -@end deffn - - -@node Hash Tables -@subsection Hash Tables -@tpindex Hash Tables - -Hash tables are dictionaries which offer similar functionality as -association lists: They provide a mapping from keys to values. The -difference is that association lists need time linear in the size of -elements when searching for entries, whereas hash tables can normally -search in constant time. The drawback is that hash tables require a -little bit more memory, and that you can not use the normal list -procedures (@pxref{Lists}) for working with them. - -@menu -* Hash Table Examples:: Demonstration of hash table usage. -* Hash Table Reference:: Hash table procedure descriptions. -@end menu - - -@node Hash Table Examples -@subsubsection Hash Table Examples - -For demonstration purposes, this section gives a few usage examples of -some hash table procedures, together with some explanation what they do. - -First we start by creating a new hash table with 31 slots, and -populate it with two key/value pairs. - -@lisp -(define h (make-hash-table 31)) - -;; This is an opaque object -h -@result{} -# - -;; Inserting into a hash table can be done with hashq-set! -(hashq-set! h 'foo "bar") -@result{} -"bar" - -(hashq-set! h 'braz "zonk") -@result{} -"zonk" - -;; Or with hash-create-handle! -(hashq-create-handle! h 'frob #f) -@result{} -(frob . #f) -@end lisp - -You can get the value for a given key with the procedure -@code{hashq-ref}, but the problem with this procedure is that you -cannot reliably determine whether a key does exists in the table. The -reason is that the procedure returns @code{#f} if the key is not in -the table, but it will return the same value if the key is in the -table and just happens to have the value @code{#f}, as you can see in -the following examples. - -@lisp -(hashq-ref h 'foo) -@result{} -"bar" - -(hashq-ref h 'frob) -@result{} -#f - -(hashq-ref h 'not-there) -@result{} -#f -@end lisp - -It is often better is to use the procedure @code{hashq-get-handle}, -which makes a distinction between the two cases. Just like @code{assq}, -this procedure returns a key/value-pair on success, and @code{#f} if the -key is not found. - -@lisp -(hashq-get-handle h 'foo) -@result{} -(foo . "bar") - -(hashq-get-handle h 'not-there) -@result{} -#f -@end lisp - -Interesting results can be computed by using @code{hash-fold} to work -through each element. This example will count the total number of -elements: - -@lisp -(hash-fold (lambda (key value seed) (+ 1 seed)) 0 h) -@result{} -3 -@end lisp - -The same thing can be done with the procedure @code{hash-count}, which -can also count the number of elements matching a particular predicate. -For example, count the number of elements with string values: - -@lisp -(hash-count (lambda (key value) (string? value)) h) -@result{} -2 -@end lisp - -Counting all the elements is a simple task using @code{const}: - -@lisp -(hash-count (const #t) h) -@result{} -3 -@end lisp - -@node Hash Table Reference -@subsubsection Hash Table Reference - -@c FIXME: Describe in broad terms what happens for resizing, and what -@c the initial size means for this. - -Like the association list functions, the hash table functions come in -several varieties, according to the equality test used for the keys. -Plain @code{hash-} functions use @code{equal?}, @code{hashq-} -functions use @code{eq?}, @code{hashv-} functions use @code{eqv?}, and -the @code{hashx-} functions use an application supplied test. - -A single @code{make-hash-table} creates a hash table suitable for use -with any set of functions, but it's imperative that just one set is -then used consistently, or results will be unpredictable. - -Hash tables are implemented as a vector indexed by a hash value formed -from the key, with an association list of key/value pairs for each -bucket in case distinct keys hash together. Direct access to the -pairs in those lists is provided by the @code{-handle-} functions. - -When the number of entries in a hash table goes above a threshold, the -vector is made larger and the entries are rehashed, to prevent the -bucket lists from becoming too long and slowing down accesses. When the -number of entries goes below a threshold, the vector is shrunk to save -space. - -For the @code{hashx-} ``extended'' routines, an application supplies a -@var{hash} function producing an integer index like @code{hashq} etc -below, and an @var{assoc} alist search function like @code{assq} etc -(@pxref{Retrieving Alist Entries}). Here's an example of such -functions implementing case-insensitive hashing of string keys, - -@example -(use-modules (srfi srfi-1) - (srfi srfi-13)) - -(define (my-hash str size) - (remainder (string-hash-ci str) size)) -(define (my-assoc str alist) - (find (lambda (pair) (string-ci=? str (car pair))) alist)) - -(define my-table (make-hash-table)) -(hashx-set! my-hash my-assoc my-table "foo" 123) - -(hashx-ref my-hash my-assoc my-table "FOO") -@result{} 123 -@end example - -In a @code{hashx-} @var{hash} function the aim is to spread keys -across the vector, so bucket lists don't become long. But the actual -values are arbitrary as long as they're in the range 0 to -@math{@var{size}-1}. Helpful functions for forming a hash value, in -addition to @code{hashq} etc below, include @code{symbol-hash} -(@pxref{Symbol Keys}), @code{string-hash} and @code{string-hash-ci} -(@pxref{String Comparison}), and @code{char-set-hash} -(@pxref{Character Set Predicates/Comparison}). - -@sp 1 -@deffn {Scheme Procedure} make-hash-table [size] -Create a new hash table object, with an optional minimum -vector @var{size}. - -When @var{size} is given, the table vector will still grow and shrink -automatically, as described above, but with @var{size} as a minimum. -If an application knows roughly how many entries the table will hold -then it can use @var{size} to avoid rehashing when initial entries are -added. -@end deffn - -@deffn {Scheme Procedure} alist->hash-table alist -@deffnx {Scheme Procedure} alist->hashq-table alist -@deffnx {Scheme Procedure} alist->hashv-table alist -@deffnx {Scheme Procedure} alist->hashx-table hash assoc alist -Convert @var{alist} into a hash table. When keys are repeated in -@var{alist}, the leftmost association takes precedence. - -@example -(use-modules (ice-9 hash-table)) -(alist->hash-table '((foo . 1) (bar . 2))) -@end example - -When converting to an extended hash table, custom @var{hash} and -@var{assoc} procedures must be provided. - -@example -(alist->hashx-table hash assoc '((foo . 1) (bar . 2))) -@end example - -@end deffn - -@deffn {Scheme Procedure} hash-table? obj -@deffnx {C Function} scm_hash_table_p (obj) -Return @code{#t} if @var{obj} is a abstract hash table object. -@end deffn - -@deffn {Scheme Procedure} hash-clear! table -@deffnx {C Function} scm_hash_clear_x (table) -Remove all items from @var{table} (without triggering a resize). -@end deffn - -@deffn {Scheme Procedure} hash-ref table key [dflt] -@deffnx {Scheme Procedure} hashq-ref table key [dflt] -@deffnx {Scheme Procedure} hashv-ref table key [dflt] -@deffnx {Scheme Procedure} hashx-ref hash assoc table key [dflt] -@deffnx {C Function} scm_hash_ref (table, key, dflt) -@deffnx {C Function} scm_hashq_ref (table, key, dflt) -@deffnx {C Function} scm_hashv_ref (table, key, dflt) -@deffnx {C Function} scm_hashx_ref (hash, assoc, table, key, dflt) -Lookup @var{key} in the given hash @var{table}, and return the -associated value. If @var{key} is not found, return @var{dflt}, or -@code{#f} if @var{dflt} is not given. -@end deffn - -@deffn {Scheme Procedure} hash-set! table key val -@deffnx {Scheme Procedure} hashq-set! table key val -@deffnx {Scheme Procedure} hashv-set! table key val -@deffnx {Scheme Procedure} hashx-set! hash assoc table key val -@deffnx {C Function} scm_hash_set_x (table, key, val) -@deffnx {C Function} scm_hashq_set_x (table, key, val) -@deffnx {C Function} scm_hashv_set_x (table, key, val) -@deffnx {C Function} scm_hashx_set_x (hash, assoc, table, key, val) -Associate @var{val} with @var{key} in the given hash @var{table}. If -@var{key} is already present then it's associated value is changed. -If it's not present then a new entry is created. -@end deffn - -@deffn {Scheme Procedure} hash-remove! table key -@deffnx {Scheme Procedure} hashq-remove! table key -@deffnx {Scheme Procedure} hashv-remove! table key -@deffnx {Scheme Procedure} hashx-remove! hash assoc table key -@deffnx {C Function} scm_hash_remove_x (table, key) -@deffnx {C Function} scm_hashq_remove_x (table, key) -@deffnx {C Function} scm_hashv_remove_x (table, key) -@deffnx {C Function} scm_hashx_remove_x (hash, assoc, table, key) -Remove any association for @var{key} in the given hash @var{table}. -If @var{key} is not in @var{table} then nothing is done. -@end deffn - -@deffn {Scheme Procedure} hash key size -@deffnx {Scheme Procedure} hashq key size -@deffnx {Scheme Procedure} hashv key size -@deffnx {C Function} scm_hash (key, size) -@deffnx {C Function} scm_hashq (key, size) -@deffnx {C Function} scm_hashv (key, size) -Return a hash value for @var{key}. This is a number in the range -@math{0} to @math{@var{size}-1}, which is suitable for use in a hash -table of the given @var{size}. - -Note that @code{hashq} and @code{hashv} may use internal addresses of -objects, so if an object is garbage collected and re-created it can -have a different hash value, even when the two are notionally -@code{eq?}. For instance with symbols, - -@example -(hashq 'something 123) @result{} 19 -(gc) -(hashq 'something 123) @result{} 62 -@end example - -In normal use this is not a problem, since an object entered into a -hash table won't be garbage collected until removed. It's only if -hashing calculations are somehow separated from normal references that -its lifetime needs to be considered. -@end deffn - -@deffn {Scheme Procedure} hash-get-handle table key -@deffnx {Scheme Procedure} hashq-get-handle table key -@deffnx {Scheme Procedure} hashv-get-handle table key -@deffnx {Scheme Procedure} hashx-get-handle hash assoc table key -@deffnx {C Function} scm_hash_get_handle (table, key) -@deffnx {C Function} scm_hashq_get_handle (table, key) -@deffnx {C Function} scm_hashv_get_handle (table, key) -@deffnx {C Function} scm_hashx_get_handle (hash, assoc, table, key) -Return the @code{(@var{key} . @var{value})} pair for @var{key} in the -given hash @var{table}, or @code{#f} if @var{key} is not in -@var{table}. -@end deffn - -@deffn {Scheme Procedure} hash-create-handle! table key init -@deffnx {Scheme Procedure} hashq-create-handle! table key init -@deffnx {Scheme Procedure} hashv-create-handle! table key init -@deffnx {Scheme Procedure} hashx-create-handle! hash assoc table key init -@deffnx {C Function} scm_hash_create_handle_x (table, key, init) -@deffnx {C Function} scm_hashq_create_handle_x (table, key, init) -@deffnx {C Function} scm_hashv_create_handle_x (table, key, init) -@deffnx {C Function} scm_hashx_create_handle_x (hash, assoc, table, key, init) -Return the @code{(@var{key} . @var{value})} pair for @var{key} in the -given hash @var{table}. If @var{key} is not in @var{table} then -create an entry for it with @var{init} as the value, and return that -pair. -@end deffn - -@deffn {Scheme Procedure} hash-map->list proc table -@deffnx {Scheme Procedure} hash-for-each proc table -@deffnx {C Function} scm_hash_map_to_list (proc, table) -@deffnx {C Function} scm_hash_for_each (proc, table) -Apply @var{proc} to the entries in the given hash @var{table}. Each -call is @code{(@var{proc} @var{key} @var{value})}. @code{hash-map->list} -returns a list of the results from these calls, @code{hash-for-each} -discards the results and returns an unspecified value. - -Calls are made over the table entries in an unspecified order, and for -@code{hash-map->list} the order of the values in the returned list is -unspecified. Results will be unpredictable if @var{table} is modified -while iterating. - -For example the following returns a new alist comprising all the -entries from @code{mytable}, in no particular order. - -@example -(hash-map->list cons mytable) -@end example -@end deffn - -@deffn {Scheme Procedure} hash-for-each-handle proc table -@deffnx {C Function} scm_hash_for_each_handle (proc, table) -Apply @var{proc} to the entries in the given hash @var{table}. Each -call is @code{(@var{proc} @var{handle})}, where @var{handle} is a -@code{(@var{key} . @var{value})} pair. Return an unspecified value. - -@code{hash-for-each-handle} differs from @code{hash-for-each} only in -the argument list of @var{proc}. -@end deffn - -@deffn {Scheme Procedure} hash-fold proc init table -@deffnx {C Function} scm_hash_fold (proc, init, table) -Accumulate a result by applying @var{proc} to the elements of the -given hash @var{table}. Each call is @code{(@var{proc} @var{key} -@var{value} @var{prior-result})}, where @var{key} and @var{value} are -from the @var{table} and @var{prior-result} is the return from the -previous @var{proc} call. For the first call, @var{prior-result} is -the given @var{init} value. - -Calls are made over the table entries in an unspecified order. -Results will be unpredictable if @var{table} is modified while -@code{hash-fold} is running. - -For example, the following returns a count of how many keys in -@code{mytable} are strings. - -@example -(hash-fold (lambda (key value prior) - (if (string? key) (1+ prior) prior)) - 0 mytable) -@end example -@end deffn - -@deffn {Scheme Procedure} hash-count pred table -@deffnx {C Function} scm_hash_count (pred, table) -Return the number of elements in the given hash @var{table} that cause -@code{(@var{pred} @var{key} @var{value})} to return true. To quickly -determine the total number of elements, use @code{(const #t)} for -@var{pred}. -@end deffn - -@c Local Variables: -@c TeX-master: "guile.texi" -@c End: diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 34e1ff64d..6862ef3ab 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -4,39 +4,13 @@ @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. -@node Simple Data Types -@section Simple Generic Data Types +@node Data Types +@section Data Types -This chapter describes those of Guile's simple data types which are -primarily used for their role as items of generic data. By -@dfn{simple} we mean data types that are not primarily used as -containers to hold other data --- i.e.@: pairs, lists, vectors and so on. -For the documentation of such @dfn{compound} data types, see -@ref{Compound Data Types}. - -@c One of the great strengths of Scheme is that there is no straightforward -@c distinction between ``data'' and ``functionality''. For example, -@c Guile's support for dynamic linking could be described: - -@c @itemize @bullet -@c @item -@c either in a ``data-centric'' way, as the behaviour and properties of the -@c ``dynamically linked object'' data type, and the operations that may be -@c applied to instances of this type - -@c @item -@c or in a ``functionality-centric'' way, as the set of procedures that -@c constitute Guile's support for dynamic linking, in the context of the -@c module system. -@c @end itemize - -@c The contents of this chapter are, therefore, a matter of judgment. By -@c @dfn{generic}, we mean to select those data types whose typical use as -@c @emph{data} in a wide variety of programming contexts is more important -@c than their use in the implementation of a particular piece of -@c @emph{functionality}. The last section of this chapter provides -@c references for all the data types that are documented not here but in a -@c ``functionality-centric'' way elsewhere in the manual. +Guile's data types form a powerful built-in library of representations +and functionality that you can apply to your problem domain. This +chapter surveys the data types built-in to Guile, from the simple to the +complex. @menu * Booleans:: True/false values. @@ -44,10 +18,24 @@ For the documentation of such @dfn{compound} data types, see * Characters:: Single characters. * Character Sets:: Sets of characters. * Strings:: Sequences of characters. -* Bytevectors:: Sequences of bytes. * Symbols:: Symbols. * Keywords:: Self-quoting, customizable display keywords. -* Other Types:: "Functionality-centric" data types. +* Pairs:: Scheme's basic building block. +* Lists:: Special list functions supported by Guile. +* Vectors:: One-dimensional arrays of Scheme objects. +* Bit Vectors:: Vectors of bits. +* Bytevectors:: Sequences of bytes. +* Arrays:: Multidimensional matrices. +* VLists:: Vector-like lists. +* Record Overview:: Walking through the maze of record APIs. +* SRFI-9 Records:: The standard, recommended record API. +* Records:: Guile's historical record API. +* Structures:: Low-level record representation. +* Dictionary Types:: About dictionary types in general. +* Association Lists:: List-based dictionaries. +* VHashes:: VList-based dictionaries. +* Hash Tables:: Table-based dictionaries. +* Other Types:: Other sections describe data types too. @end menu @@ -4579,476 +4567,6 @@ or @code{#f} if they are stored in an 8-bit buffer @end deffn -@node Bytevectors -@subsection Bytevectors - -@cindex bytevector -@cindex R6RS - -A @dfn{bytevector} is a raw bit string. The @code{(rnrs bytevectors)} -module provides the programming interface specified by the -@uref{http://www.r6rs.org/, Revised^6 Report on the Algorithmic Language -Scheme (R6RS)}. It contains procedures to manipulate bytevectors and -interpret their contents in a number of ways: bytevector contents can be -accessed as signed or unsigned integer of various sizes and endianness, -as IEEE-754 floating point numbers, or as strings. It is a useful tool -to encode and decode binary data. - -The R6RS (Section 4.3.4) specifies an external representation for -bytevectors, whereby the octets (integers in the range 0--255) contained -in the bytevector are represented as a list prefixed by @code{#vu8}: - -@lisp -#vu8(1 53 204) -@end lisp - -denotes a 3-byte bytevector containing the octets 1, 53, and 204. Like -string literals, booleans, etc., bytevectors are ``self-quoting'', i.e., -they do not need to be quoted: - -@lisp -#vu8(1 53 204) -@result{} #vu8(1 53 204) -@end lisp - -Bytevectors can be used with the binary input/output primitives -(@pxref{Binary I/O}). - -@menu -* Bytevector Endianness:: Dealing with byte order. -* Bytevector Manipulation:: Creating, copying, manipulating bytevectors. -* Bytevectors as Integers:: Interpreting bytes as integers. -* Bytevectors and Integer Lists:: Converting to/from an integer list. -* Bytevectors as Floats:: Interpreting bytes as real numbers. -* Bytevectors as Strings:: Interpreting bytes as Unicode strings. -* Bytevectors as Arrays:: Guile extension to the bytevector API. -* Bytevectors as Uniform Vectors:: Bytevectors and SRFI-4. -@end menu - -@node Bytevector Endianness -@subsubsection Endianness - -@cindex endianness -@cindex byte order -@cindex word order - -Some of the following procedures take an @var{endianness} parameter. -The @dfn{endianness} is defined as the order of bytes in multi-byte -numbers: numbers encoded in @dfn{big endian} have their most -significant bytes written first, whereas numbers encoded in -@dfn{little endian} have their least significant bytes -first@footnote{Big-endian and little-endian are the most common -``endiannesses'', but others do exist. For instance, the GNU MP -library allows @dfn{word order} to be specified independently of -@dfn{byte order} (@pxref{Integer Import and Export,,, gmp, The GNU -Multiple Precision Arithmetic Library Manual}).}. - -Little-endian is the native endianness of the IA32 architecture and -its derivatives, while big-endian is native to SPARC and PowerPC, -among others. The @code{native-endianness} procedure returns the -native endianness of the machine it runs on. - -@deffn {Scheme Procedure} native-endianness -@deffnx {C Function} scm_native_endianness () -Return a value denoting the native endianness of the host machine. -@end deffn - -@deffn {Scheme Macro} endianness symbol -Return an object denoting the endianness specified by @var{symbol}. If -@var{symbol} is neither @code{big} nor @code{little} then an error is -raised at expand-time. -@end deffn - -@defvr {C Variable} scm_endianness_big -@defvrx {C Variable} scm_endianness_little -The objects denoting big- and little-endianness, respectively. -@end defvr - - -@node Bytevector Manipulation -@subsubsection Manipulating Bytevectors - -Bytevectors can be created, copied, and analyzed with the following -procedures and C functions. - -@deffn {Scheme Procedure} make-bytevector len [fill] -@deffnx {C Function} scm_make_bytevector (len, fill) -@deffnx {C Function} scm_c_make_bytevector (size_t len) -Return a new bytevector of @var{len} bytes. Optionally, if @var{fill} -is given, fill it with @var{fill}; @var{fill} must be in the range -[-128,255]. -@end deffn - -@deffn {Scheme Procedure} bytevector? obj -@deffnx {C Function} scm_bytevector_p (obj) -Return true if @var{obj} is a bytevector. -@end deffn - -@deftypefn {C Function} int scm_is_bytevector (SCM obj) -Equivalent to @code{scm_is_true (scm_bytevector_p (obj))}. -@end deftypefn - -@deffn {Scheme Procedure} bytevector-length bv -@deffnx {C Function} scm_bytevector_length (bv) -Return the length in bytes of bytevector @var{bv}. -@end deffn - -@deftypefn {C Function} size_t scm_c_bytevector_length (SCM bv) -Likewise, return the length in bytes of bytevector @var{bv}. -@end deftypefn - -@deffn {Scheme Procedure} bytevector=? bv1 bv2 -@deffnx {C Function} scm_bytevector_eq_p (bv1, bv2) -Return is @var{bv1} equals to @var{bv2}---i.e., if they have the same -length and contents. -@end deffn - -@deffn {Scheme Procedure} bytevector-fill! bv fill -@deffnx {C Function} scm_bytevector_fill_x (bv, fill) -Fill bytevector @var{bv} with @var{fill}, a byte. -@end deffn - -@deffn {Scheme Procedure} bytevector-copy! source source-start target target-start len -@deffnx {C Function} scm_bytevector_copy_x (source, source_start, target, target_start, len) -Copy @var{len} bytes from @var{source} into @var{target}, starting -reading from @var{source-start} (a positive index within @var{source}) -and start writing at @var{target-start}. It is permitted for the -@var{source} and @var{target} regions to overlap. -@end deffn - -@deffn {Scheme Procedure} bytevector-copy bv -@deffnx {C Function} scm_bytevector_copy (bv) -Return a newly allocated copy of @var{bv}. -@end deffn - -@deftypefn {C Function} scm_t_uint8 scm_c_bytevector_ref (SCM bv, size_t index) -Return the byte at @var{index} in bytevector @var{bv}. -@end deftypefn - -@deftypefn {C Function} void scm_c_bytevector_set_x (SCM bv, size_t index, scm_t_uint8 value) -Set the byte at @var{index} in @var{bv} to @var{value}. -@end deftypefn - -Low-level C macros are available. They do not perform any -type-checking; as such they should be used with care. - -@deftypefn {C Macro} size_t SCM_BYTEVECTOR_LENGTH (bv) -Return the length in bytes of bytevector @var{bv}. -@end deftypefn - -@deftypefn {C Macro} {signed char *} SCM_BYTEVECTOR_CONTENTS (bv) -Return a pointer to the contents of bytevector @var{bv}. -@end deftypefn - - -@node Bytevectors as Integers -@subsubsection Interpreting Bytevector Contents as Integers - -The contents of a bytevector can be interpreted as a sequence of -integers of any given size, sign, and endianness. - -@lisp -(let ((bv (make-bytevector 4))) - (bytevector-u8-set! bv 0 #x12) - (bytevector-u8-set! bv 1 #x34) - (bytevector-u8-set! bv 2 #x56) - (bytevector-u8-set! bv 3 #x78) - - (map (lambda (number) - (number->string number 16)) - (list (bytevector-u8-ref bv 0) - (bytevector-u16-ref bv 0 (endianness big)) - (bytevector-u32-ref bv 0 (endianness little))))) - -@result{} ("12" "1234" "78563412") -@end lisp - -The most generic procedures to interpret bytevector contents as integers -are described below. - -@deffn {Scheme Procedure} bytevector-uint-ref bv index endianness size -@deffnx {C Function} scm_bytevector_uint_ref (bv, index, endianness, size) -Return the @var{size}-byte long unsigned integer at index @var{index} in -@var{bv}, decoded according to @var{endianness}. -@end deffn - -@deffn {Scheme Procedure} bytevector-sint-ref bv index endianness size -@deffnx {C Function} scm_bytevector_sint_ref (bv, index, endianness, size) -Return the @var{size}-byte long signed integer at index @var{index} in -@var{bv}, decoded according to @var{endianness}. -@end deffn - -@deffn {Scheme Procedure} bytevector-uint-set! bv index value endianness size -@deffnx {C Function} scm_bytevector_uint_set_x (bv, index, value, endianness, size) -Set the @var{size}-byte long unsigned integer at @var{index} to -@var{value}, encoded according to @var{endianness}. -@end deffn - -@deffn {Scheme Procedure} bytevector-sint-set! bv index value endianness size -@deffnx {C Function} scm_bytevector_sint_set_x (bv, index, value, endianness, size) -Set the @var{size}-byte long signed integer at @var{index} to -@var{value}, encoded according to @var{endianness}. -@end deffn - -The following procedures are similar to the ones above, but specialized -to a given integer size: - -@deffn {Scheme Procedure} bytevector-u8-ref bv index -@deffnx {Scheme Procedure} bytevector-s8-ref bv index -@deffnx {Scheme Procedure} bytevector-u16-ref bv index endianness -@deffnx {Scheme Procedure} bytevector-s16-ref bv index endianness -@deffnx {Scheme Procedure} bytevector-u32-ref bv index endianness -@deffnx {Scheme Procedure} bytevector-s32-ref bv index endianness -@deffnx {Scheme Procedure} bytevector-u64-ref bv index endianness -@deffnx {Scheme Procedure} bytevector-s64-ref bv index endianness -@deffnx {C Function} scm_bytevector_u8_ref (bv, index) -@deffnx {C Function} scm_bytevector_s8_ref (bv, index) -@deffnx {C Function} scm_bytevector_u16_ref (bv, index, endianness) -@deffnx {C Function} scm_bytevector_s16_ref (bv, index, endianness) -@deffnx {C Function} scm_bytevector_u32_ref (bv, index, endianness) -@deffnx {C Function} scm_bytevector_s32_ref (bv, index, endianness) -@deffnx {C Function} scm_bytevector_u64_ref (bv, index, endianness) -@deffnx {C Function} scm_bytevector_s64_ref (bv, index, endianness) -Return the unsigned @var{n}-bit (signed) integer (where @var{n} is 8, -16, 32 or 64) from @var{bv} at @var{index}, decoded according to -@var{endianness}. -@end deffn - -@deffn {Scheme Procedure} bytevector-u8-set! bv index value -@deffnx {Scheme Procedure} bytevector-s8-set! bv index value -@deffnx {Scheme Procedure} bytevector-u16-set! bv index value endianness -@deffnx {Scheme Procedure} bytevector-s16-set! bv index value endianness -@deffnx {Scheme Procedure} bytevector-u32-set! bv index value endianness -@deffnx {Scheme Procedure} bytevector-s32-set! bv index value endianness -@deffnx {Scheme Procedure} bytevector-u64-set! bv index value endianness -@deffnx {Scheme Procedure} bytevector-s64-set! bv index value endianness -@deffnx {C Function} scm_bytevector_u8_set_x (bv, index, value) -@deffnx {C Function} scm_bytevector_s8_set_x (bv, index, value) -@deffnx {C Function} scm_bytevector_u16_set_x (bv, index, value, endianness) -@deffnx {C Function} scm_bytevector_s16_set_x (bv, index, value, endianness) -@deffnx {C Function} scm_bytevector_u32_set_x (bv, index, value, endianness) -@deffnx {C Function} scm_bytevector_s32_set_x (bv, index, value, endianness) -@deffnx {C Function} scm_bytevector_u64_set_x (bv, index, value, endianness) -@deffnx {C Function} scm_bytevector_s64_set_x (bv, index, value, endianness) -Store @var{value} as an @var{n}-bit (signed) integer (where @var{n} is -8, 16, 32 or 64) in @var{bv} at @var{index}, encoded according to -@var{endianness}. -@end deffn - -Finally, a variant specialized for the host's endianness is available -for each of these functions (with the exception of the @code{u8} -accessors, for obvious reasons): - -@deffn {Scheme Procedure} bytevector-u16-native-ref bv index -@deffnx {Scheme Procedure} bytevector-s16-native-ref bv index -@deffnx {Scheme Procedure} bytevector-u32-native-ref bv index -@deffnx {Scheme Procedure} bytevector-s32-native-ref bv index -@deffnx {Scheme Procedure} bytevector-u64-native-ref bv index -@deffnx {Scheme Procedure} bytevector-s64-native-ref bv index -@deffnx {C Function} scm_bytevector_u16_native_ref (bv, index) -@deffnx {C Function} scm_bytevector_s16_native_ref (bv, index) -@deffnx {C Function} scm_bytevector_u32_native_ref (bv, index) -@deffnx {C Function} scm_bytevector_s32_native_ref (bv, index) -@deffnx {C Function} scm_bytevector_u64_native_ref (bv, index) -@deffnx {C Function} scm_bytevector_s64_native_ref (bv, index) -Return the unsigned @var{n}-bit (signed) integer (where @var{n} is 8, -16, 32 or 64) from @var{bv} at @var{index}, decoded according to the -host's native endianness. -@end deffn - -@deffn {Scheme Procedure} bytevector-u16-native-set! bv index value -@deffnx {Scheme Procedure} bytevector-s16-native-set! bv index value -@deffnx {Scheme Procedure} bytevector-u32-native-set! bv index value -@deffnx {Scheme Procedure} bytevector-s32-native-set! bv index value -@deffnx {Scheme Procedure} bytevector-u64-native-set! bv index value -@deffnx {Scheme Procedure} bytevector-s64-native-set! bv index value -@deffnx {C Function} scm_bytevector_u16_native_set_x (bv, index, value) -@deffnx {C Function} scm_bytevector_s16_native_set_x (bv, index, value) -@deffnx {C Function} scm_bytevector_u32_native_set_x (bv, index, value) -@deffnx {C Function} scm_bytevector_s32_native_set_x (bv, index, value) -@deffnx {C Function} scm_bytevector_u64_native_set_x (bv, index, value) -@deffnx {C Function} scm_bytevector_s64_native_set_x (bv, index, value) -Store @var{value} as an @var{n}-bit (signed) integer (where @var{n} is -8, 16, 32 or 64) in @var{bv} at @var{index}, encoded according to the -host's native endianness. -@end deffn - - -@node Bytevectors and Integer Lists -@subsubsection Converting Bytevectors to/from Integer Lists - -Bytevector contents can readily be converted to/from lists of signed or -unsigned integers: - -@lisp -(bytevector->sint-list (u8-list->bytevector (make-list 4 255)) - (endianness little) 2) -@result{} (-1 -1) -@end lisp - -@deffn {Scheme Procedure} bytevector->u8-list bv -@deffnx {C Function} scm_bytevector_to_u8_list (bv) -Return a newly allocated list of unsigned 8-bit integers from the -contents of @var{bv}. -@end deffn - -@deffn {Scheme Procedure} u8-list->bytevector lst -@deffnx {C Function} scm_u8_list_to_bytevector (lst) -Return a newly allocated bytevector consisting of the unsigned 8-bit -integers listed in @var{lst}. -@end deffn - -@deffn {Scheme Procedure} bytevector->uint-list bv endianness size -@deffnx {C Function} scm_bytevector_to_uint_list (bv, endianness, size) -Return a list of unsigned integers of @var{size} bytes representing the -contents of @var{bv}, decoded according to @var{endianness}. -@end deffn - -@deffn {Scheme Procedure} bytevector->sint-list bv endianness size -@deffnx {C Function} scm_bytevector_to_sint_list (bv, endianness, size) -Return a list of signed integers of @var{size} bytes representing the -contents of @var{bv}, decoded according to @var{endianness}. -@end deffn - -@deffn {Scheme Procedure} uint-list->bytevector lst endianness size -@deffnx {C Function} scm_uint_list_to_bytevector (lst, endianness, size) -Return a new bytevector containing the unsigned integers listed in -@var{lst} and encoded on @var{size} bytes according to @var{endianness}. -@end deffn - -@deffn {Scheme Procedure} sint-list->bytevector lst endianness size -@deffnx {C Function} scm_sint_list_to_bytevector (lst, endianness, size) -Return a new bytevector containing the signed integers listed in -@var{lst} and encoded on @var{size} bytes according to @var{endianness}. -@end deffn - -@node Bytevectors as Floats -@subsubsection Interpreting Bytevector Contents as Floating Point Numbers - -@cindex IEEE-754 floating point numbers - -Bytevector contents can also be accessed as IEEE-754 single- or -double-precision floating point numbers (respectively 32 and 64-bit -long) using the procedures described here. - -@deffn {Scheme Procedure} bytevector-ieee-single-ref bv index endianness -@deffnx {Scheme Procedure} bytevector-ieee-double-ref bv index endianness -@deffnx {C Function} scm_bytevector_ieee_single_ref (bv, index, endianness) -@deffnx {C Function} scm_bytevector_ieee_double_ref (bv, index, endianness) -Return the IEEE-754 single-precision floating point number from @var{bv} -at @var{index} according to @var{endianness}. -@end deffn - -@deffn {Scheme Procedure} bytevector-ieee-single-set! bv index value endianness -@deffnx {Scheme Procedure} bytevector-ieee-double-set! bv index value endianness -@deffnx {C Function} scm_bytevector_ieee_single_set_x (bv, index, value, endianness) -@deffnx {C Function} scm_bytevector_ieee_double_set_x (bv, index, value, endianness) -Store real number @var{value} in @var{bv} at @var{index} according to -@var{endianness}. -@end deffn - -Specialized procedures are also available: - -@deffn {Scheme Procedure} bytevector-ieee-single-native-ref bv index -@deffnx {Scheme Procedure} bytevector-ieee-double-native-ref bv index -@deffnx {C Function} scm_bytevector_ieee_single_native_ref (bv, index) -@deffnx {C Function} scm_bytevector_ieee_double_native_ref (bv, index) -Return the IEEE-754 single-precision floating point number from @var{bv} -at @var{index} according to the host's native endianness. -@end deffn - -@deffn {Scheme Procedure} bytevector-ieee-single-native-set! bv index value -@deffnx {Scheme Procedure} bytevector-ieee-double-native-set! bv index value -@deffnx {C Function} scm_bytevector_ieee_single_native_set_x (bv, index, value) -@deffnx {C Function} scm_bytevector_ieee_double_native_set_x (bv, index, value) -Store real number @var{value} in @var{bv} at @var{index} according to -the host's native endianness. -@end deffn - - -@node Bytevectors as Strings -@subsubsection Interpreting Bytevector Contents as Unicode Strings - -@cindex Unicode string encoding - -Bytevector contents can also be interpreted as Unicode strings encoded -in one of the most commonly available encoding formats. -@xref{Representing Strings as Bytes}, for a more generic interface. - -@lisp -(utf8->string (u8-list->bytevector '(99 97 102 101))) -@result{} "cafe" - -(string->utf8 "caf@'e") ;; SMALL LATIN LETTER E WITH ACUTE ACCENT -@result{} #vu8(99 97 102 195 169) -@end lisp - -@deftypefn {Scheme Procedure} {} string-utf8-length str -@deftypefnx {C function} SCM scm_string_utf8_length (str) -@deftypefnx {C function} size_t scm_c_string_utf8_length (str) -Return the number of bytes in the UTF-8 representation of @var{str}. -@end deftypefn - -@deffn {Scheme Procedure} string->utf8 str -@deffnx {Scheme Procedure} string->utf16 str [endianness] -@deffnx {Scheme Procedure} string->utf32 str [endianness] -@deffnx {C Function} scm_string_to_utf8 (str) -@deffnx {C Function} scm_string_to_utf16 (str, endianness) -@deffnx {C Function} scm_string_to_utf32 (str, endianness) -Return a newly allocated bytevector that contains the UTF-8, UTF-16, or -UTF-32 (aka. UCS-4) encoding of @var{str}. For UTF-16 and UTF-32, -@var{endianness} should be the symbol @code{big} or @code{little}; when omitted, -it defaults to big endian. -@end deffn - -@deffn {Scheme Procedure} utf8->string utf -@deffnx {Scheme Procedure} utf16->string utf [endianness] -@deffnx {Scheme Procedure} utf32->string utf [endianness] -@deffnx {C Function} scm_utf8_to_string (utf) -@deffnx {C Function} scm_utf16_to_string (utf, endianness) -@deffnx {C Function} scm_utf32_to_string (utf, endianness) -Return a newly allocated string that contains from the UTF-8-, UTF-16-, -or UTF-32-decoded contents of bytevector @var{utf}. For UTF-16 and UTF-32, -@var{endianness} should be the symbol @code{big} or @code{little}; when omitted, -it defaults to big endian. -@end deffn - -@node Bytevectors as Arrays -@subsubsection Accessing Bytevectors with the Array API - -As an extension to the R6RS, Guile allows bytevectors to be manipulated -with the @dfn{array} procedures (@pxref{Arrays}). When using these -APIs, bytes are accessed one at a time as 8-bit unsigned integers: - -@example -(define bv #vu8(0 1 2 3)) - -(array? bv) -@result{} #t - -(array-rank bv) -@result{} 1 - -(array-ref bv 2) -@result{} 2 - -;; Note the different argument order on array-set!. -(array-set! bv 77 2) -(array-ref bv 2) -@result{} 77 - -(array-type bv) -@result{} vu8 -@end example - - -@node Bytevectors as Uniform Vectors -@subsubsection Accessing Bytevectors with the SRFI-4 API - -Bytevectors may also be accessed with the SRFI-4 API. @xref{SRFI-4 and -Bytevectors}, for more information. - - @node Symbols @subsection Symbols @tpindex Symbols @@ -6043,26 +5561,4476 @@ void my_init () @end deftypefn -@node Other Types -@subsection ``Functionality-Centric'' Data Types +@node Pairs +@subsection Pairs +@tpindex Pairs -Procedures and macros are documented in their own sections: see -@ref{Procedures} and @ref{Macros}. +Pairs are used to combine two Scheme objects into one compound object. +Hence the name: A pair stores a pair of objects. + +The data type @dfn{pair} is extremely important in Scheme, just like in +any other Lisp dialect. The reason is that pairs are not only used to +make two values available as one object, but that pairs are used for +constructing lists of values. Because lists are so important in Scheme, +they are described in a section of their own (@pxref{Lists}). + +Pairs can literally get entered in source code or at the REPL, in the +so-called @dfn{dotted list} syntax. This syntax consists of an opening +parentheses, the first element of the pair, a dot, the second element +and a closing parentheses. The following example shows how a pair +consisting of the two numbers 1 and 2, and a pair containing the symbols +@code{foo} and @code{bar} can be entered. It is very important to write +the whitespace before and after the dot, because otherwise the Scheme +parser would not be able to figure out where to split the tokens. + +@lisp +(1 . 2) +(foo . bar) +@end lisp + +But beware, if you want to try out these examples, you have to +@dfn{quote} the expressions. More information about quotation is +available in the section @ref{Expression Syntax}. The correct way +to try these examples is as follows. + +@lisp +'(1 . 2) +@result{} +(1 . 2) +'(foo . bar) +@result{} +(foo . bar) +@end lisp + +A new pair is made by calling the procedure @code{cons} with two +arguments. Then the argument values are stored into a newly allocated +pair, and the pair is returned. The name @code{cons} stands for +"construct". Use the procedure @code{pair?} to test whether a +given Scheme object is a pair or not. + +@rnindex cons +@deffn {Scheme Procedure} cons x y +@deffnx {C Function} scm_cons (x, y) +Return a newly allocated pair whose car is @var{x} and whose +cdr is @var{y}. The pair is guaranteed to be different (in the +sense of @code{eq?}) from every previously existing object. +@end deffn + +@rnindex pair? +@deffn {Scheme Procedure} pair? x +@deffnx {C Function} scm_pair_p (x) +Return @code{#t} if @var{x} is a pair; otherwise return +@code{#f}. +@end deffn + +@deftypefn {C Function} int scm_is_pair (SCM x) +Return 1 when @var{x} is a pair; otherwise return 0. +@end deftypefn + +The two parts of a pair are traditionally called @dfn{car} and +@dfn{cdr}. They can be retrieved with procedures of the same name +(@code{car} and @code{cdr}), and can be modified with the procedures +@code{set-car!} and @code{set-cdr!}. + +Since a very common operation in Scheme programs is to access the car of +a car of a pair, or the car of the cdr of a pair, etc., the procedures +called @code{caar}, @code{cadr} and so on are also predefined. However, +using these procedures is often detrimental to readability, and +error-prone. Thus, accessing the contents of a list is usually better +achieved using pattern matching techniques (@pxref{Pattern Matching}). + +@rnindex car +@rnindex cdr +@deffn {Scheme Procedure} car pair +@deffnx {Scheme Procedure} cdr pair +@deffnx {C Function} scm_car (pair) +@deffnx {C Function} scm_cdr (pair) +Return the car or the cdr of @var{pair}, respectively. +@end deffn + +@deftypefn {C Macro} SCM SCM_CAR (SCM pair) +@deftypefnx {C Macro} SCM SCM_CDR (SCM pair) +These two macros are the fastest way to access the car or cdr of a +pair; they can be thought of as compiling into a single memory +reference. + +These macros do no checking at all. The argument @var{pair} must be a +valid pair. +@end deftypefn + +@deffn {Scheme Procedure} cddr pair +@deffnx {Scheme Procedure} cdar pair +@deffnx {Scheme Procedure} cadr pair +@deffnx {Scheme Procedure} caar pair +@deffnx {Scheme Procedure} cdddr pair +@deffnx {Scheme Procedure} cddar pair +@deffnx {Scheme Procedure} cdadr pair +@deffnx {Scheme Procedure} cdaar pair +@deffnx {Scheme Procedure} caddr pair +@deffnx {Scheme Procedure} cadar pair +@deffnx {Scheme Procedure} caadr pair +@deffnx {Scheme Procedure} caaar pair +@deffnx {Scheme Procedure} cddddr pair +@deffnx {Scheme Procedure} cdddar pair +@deffnx {Scheme Procedure} cddadr pair +@deffnx {Scheme Procedure} cddaar pair +@deffnx {Scheme Procedure} cdaddr pair +@deffnx {Scheme Procedure} cdadar pair +@deffnx {Scheme Procedure} cdaadr pair +@deffnx {Scheme Procedure} cdaaar pair +@deffnx {Scheme Procedure} cadddr pair +@deffnx {Scheme Procedure} caddar pair +@deffnx {Scheme Procedure} cadadr pair +@deffnx {Scheme Procedure} cadaar pair +@deffnx {Scheme Procedure} caaddr pair +@deffnx {Scheme Procedure} caadar pair +@deffnx {Scheme Procedure} caaadr pair +@deffnx {Scheme Procedure} caaaar pair +@deffnx {C Function} scm_cddr (pair) +@deffnx {C Function} scm_cdar (pair) +@deffnx {C Function} scm_cadr (pair) +@deffnx {C Function} scm_caar (pair) +@deffnx {C Function} scm_cdddr (pair) +@deffnx {C Function} scm_cddar (pair) +@deffnx {C Function} scm_cdadr (pair) +@deffnx {C Function} scm_cdaar (pair) +@deffnx {C Function} scm_caddr (pair) +@deffnx {C Function} scm_cadar (pair) +@deffnx {C Function} scm_caadr (pair) +@deffnx {C Function} scm_caaar (pair) +@deffnx {C Function} scm_cddddr (pair) +@deffnx {C Function} scm_cdddar (pair) +@deffnx {C Function} scm_cddadr (pair) +@deffnx {C Function} scm_cddaar (pair) +@deffnx {C Function} scm_cdaddr (pair) +@deffnx {C Function} scm_cdadar (pair) +@deffnx {C Function} scm_cdaadr (pair) +@deffnx {C Function} scm_cdaaar (pair) +@deffnx {C Function} scm_cadddr (pair) +@deffnx {C Function} scm_caddar (pair) +@deffnx {C Function} scm_cadadr (pair) +@deffnx {C Function} scm_cadaar (pair) +@deffnx {C Function} scm_caaddr (pair) +@deffnx {C Function} scm_caadar (pair) +@deffnx {C Function} scm_caaadr (pair) +@deffnx {C Function} scm_caaaar (pair) +These procedures are compositions of @code{car} and @code{cdr}, where +for example @code{caddr} could be defined by + +@lisp +(define caddr (lambda (x) (car (cdr (cdr x))))) +@end lisp + +@code{cadr}, @code{caddr} and @code{cadddr} pick out the second, third +or fourth elements of a list, respectively. SRFI-1 provides the same +under the names @code{second}, @code{third} and @code{fourth} +(@pxref{SRFI-1 Selectors}). +@end deffn + +@rnindex set-car! +@deffn {Scheme Procedure} set-car! pair value +@deffnx {C Function} scm_set_car_x (pair, value) +Stores @var{value} in the car field of @var{pair}. The value returned +by @code{set-car!} is unspecified. +@end deffn + +@rnindex set-cdr! +@deffn {Scheme Procedure} set-cdr! pair value +@deffnx {C Function} scm_set_cdr_x (pair, value) +Stores @var{value} in the cdr field of @var{pair}. The value returned +by @code{set-cdr!} is unspecified. +@end deffn + + +@node Lists +@subsection Lists +@tpindex Lists + +A very important data type in Scheme---as well as in all other Lisp +dialects---is the data type @dfn{list}.@footnote{Strictly speaking, +Scheme does not have a real datatype @dfn{list}. Lists are made up of +@dfn{chained pairs}, and only exist by definition---a list is a chain +of pairs which looks like a list.} + +This is the short definition of what a list is: + +@itemize @bullet +@item +Either the empty list @code{()}, + +@item +or a pair which has a list in its cdr. +@end itemize + +@c FIXME::martin: Describe the pair chaining in more detail. + +@c FIXME::martin: What is a proper, what an improper list? +@c What is a circular list? + +@c FIXME::martin: Maybe steal some graphics from the Elisp reference +@c manual? + +@menu +* List Syntax:: Writing literal lists. +* List Predicates:: Testing lists. +* List Constructors:: Creating new lists. +* List Selection:: Selecting from lists, getting their length. +* Append/Reverse:: Appending and reversing lists. +* List Modification:: Modifying existing lists. +* List Searching:: Searching for list elements +* List Mapping:: Applying procedures to lists. +@end menu + +@node List Syntax +@subsubsection List Read Syntax + +The syntax for lists is an opening parentheses, then all the elements of +the list (separated by whitespace) and finally a closing +parentheses.@footnote{Note that there is no separation character between +the list elements, like a comma or a semicolon.}. + +@lisp +(1 2 3) ; @r{a list of the numbers 1, 2 and 3} +("foo" bar 3.1415) ; @r{a string, a symbol and a real number} +() ; @r{the empty list} +@end lisp + +The last example needs a bit more explanation. A list with no elements, +called the @dfn{empty list}, is special in some ways. It is used for +terminating lists by storing it into the cdr of the last pair that makes +up a list. An example will clear that up: + +@lisp +(car '(1)) +@result{} +1 +(cdr '(1)) +@result{} +() +@end lisp + +This example also shows that lists have to be quoted when written +(@pxref{Expression Syntax}), because they would otherwise be +mistakingly taken as procedure applications (@pxref{Simple +Invocation}). + + +@node List Predicates +@subsubsection List Predicates + +Often it is useful to test whether a given Scheme object is a list or +not. List-processing procedures could use this information to test +whether their input is valid, or they could do different things +depending on the datatype of their arguments. + +@rnindex list? +@deffn {Scheme Procedure} list? x +@deffnx {C Function} scm_list_p (x) +Return @code{#t} if @var{x} is a proper list, else @code{#f}. +@end deffn + +The predicate @code{null?} is often used in list-processing code to +tell whether a given list has run out of elements. That is, a loop +somehow deals with the elements of a list until the list satisfies +@code{null?}. Then, the algorithm terminates. + +@rnindex null? +@deffn {Scheme Procedure} null? x +@deffnx {C Function} scm_null_p (x) +Return @code{#t} if @var{x} is the empty list, else @code{#f}. +@end deffn + +@deftypefn {C Function} int scm_is_null (SCM x) +Return 1 when @var{x} is the empty list; otherwise return 0. +@end deftypefn + + +@node List Constructors +@subsubsection List Constructors + +This section describes the procedures for constructing new lists. +@code{list} simply returns a list where the elements are the arguments, +@code{cons*} is similar, but the last argument is stored in the cdr of +the last pair of the list. + +@c C Function scm_list(rest) used to be documented here, but it's a +@c no-op since it does nothing but return the list the caller must +@c have already created. +@c +@deffn {Scheme Procedure} list elem @dots{} +@deffnx {C Function} scm_list_1 (elem1) +@deffnx {C Function} scm_list_2 (elem1, elem2) +@deffnx {C Function} scm_list_3 (elem1, elem2, elem3) +@deffnx {C Function} scm_list_4 (elem1, elem2, elem3, elem4) +@deffnx {C Function} scm_list_5 (elem1, elem2, elem3, elem4, elem5) +@deffnx {C Function} scm_list_n (elem1, @dots{}, elemN, @nicode{SCM_UNDEFINED}) +@rnindex list +Return a new list containing elements @var{elem} @enddots{}. + +@code{scm_list_n} takes a variable number of arguments, terminated by +the special @code{SCM_UNDEFINED}. That final @code{SCM_UNDEFINED} is +not included in the list. None of @var{elem} @dots{} can +themselves be @code{SCM_UNDEFINED}, or @code{scm_list_n} will +terminate at that point. +@end deffn + +@c C Function scm_cons_star(arg1,rest) used to be documented here, +@c but it's not really a useful interface, since it expects the +@c caller to have already consed up all but the first argument +@c already. +@c +@deffn {Scheme Procedure} cons* arg1 arg2 @dots{} +Like @code{list}, but the last arg provides the tail of the +constructed list, returning @code{(cons @var{arg1} (cons +@var{arg2} (cons @dots{} @var{argn})))}. Requires at least one +argument. If given one argument, that argument is returned as +result. This function is called @code{list*} in some other +Schemes and in Common LISP. +@end deffn + +@deffn {Scheme Procedure} list-copy lst +@deffnx {C Function} scm_list_copy (lst) +Return a (newly-created) copy of @var{lst}. +@end deffn + +@deffn {Scheme Procedure} make-list n [init] +Create a list containing of @var{n} elements, where each element is +initialized to @var{init}. @var{init} defaults to the empty list +@code{()} if not given. +@end deffn + +Note that @code{list-copy} only makes a copy of the pairs which make up +the spine of the lists. The list elements are not copied, which means +that modifying the elements of the new list also modifies the elements +of the old list. On the other hand, applying procedures like +@code{set-cdr!} or @code{delv!} to the new list will not alter the old +list. If you also need to copy the list elements (making a deep copy), +use the procedure @code{copy-tree} (@pxref{Copying}). + +@node List Selection +@subsubsection List Selection + +These procedures are used to get some information about a list, or to +retrieve one or more elements of a list. + +@rnindex length +@deffn {Scheme Procedure} length lst +@deffnx {C Function} scm_length (lst) +Return the number of elements in list @var{lst}. +@end deffn + +@deffn {Scheme Procedure} last-pair lst +@deffnx {C Function} scm_last_pair (lst) +Return the last pair in @var{lst}, signalling an error if +@var{lst} is circular. +@end deffn + +@rnindex list-ref +@deffn {Scheme Procedure} list-ref list k +@deffnx {C Function} scm_list_ref (list, k) +Return the @var{k}th element from @var{list}. +@end deffn + +@rnindex list-tail +@deffn {Scheme Procedure} list-tail lst k +@deffnx {Scheme Procedure} list-cdr-ref lst k +@deffnx {C Function} scm_list_tail (lst, k) +Return the "tail" of @var{lst} beginning with its @var{k}th element. +The first element of the list is considered to be element 0. + +@code{list-tail} and @code{list-cdr-ref} are identical. It may help to +think of @code{list-cdr-ref} as accessing the @var{k}th cdr of the list, +or returning the results of cdring @var{k} times down @var{lst}. +@end deffn + +@deffn {Scheme Procedure} list-head lst k +@deffnx {C Function} scm_list_head (lst, k) +Copy the first @var{k} elements from @var{lst} into a new list, and +return it. +@end deffn + +@node Append/Reverse +@subsubsection Append and Reverse + +@code{append} and @code{append!} are used to concatenate two or more +lists in order to form a new list. @code{reverse} and @code{reverse!} +return lists with the same elements as their arguments, but in reverse +order. The procedure variants with an @code{!} directly modify the +pairs which form the list, whereas the other procedures create new +pairs. This is why you should be careful when using the side-effecting +variants. + +@rnindex append +@deffn {Scheme Procedure} append lst @dots{} obj +@deffnx {Scheme Procedure} append +@deffnx {Scheme Procedure} append! lst @dots{} obj +@deffnx {Scheme Procedure} append! +@deffnx {C Function} scm_append (lstlst) +@deffnx {C Function} scm_append_x (lstlst) +Return a list comprising all the elements of lists @var{lst} @dots{} +@var{obj}. If called with no arguments, return the empty list. + +@lisp +(append '(x) '(y)) @result{} (x y) +(append '(a) '(b c d)) @result{} (a b c d) +(append '(a (b)) '((c))) @result{} (a (b) (c)) +@end lisp + +The last argument @var{obj} may actually be any object; an improper +list results if the last argument is not a proper list. + +@lisp +(append '(a b) '(c . d)) @result{} (a b c . d) +(append '() 'a) @result{} a +@end lisp + +@code{append} doesn't modify the given lists, but the return may share +structure with the final @var{obj}. @code{append!} is permitted, but +not required, to modify the given lists to form its return. + +For @code{scm_append} and @code{scm_append_x}, @var{lstlst} is a list +of the list operands @var{lst} @dots{} @var{obj}. That @var{lstlst} +itself is not modified or used in the return. +@end deffn + +@rnindex reverse +@deffn {Scheme Procedure} reverse lst +@deffnx {Scheme Procedure} reverse! lst [newtail] +@deffnx {C Function} scm_reverse (lst) +@deffnx {C Function} scm_reverse_x (lst, newtail) +Return a list comprising the elements of @var{lst}, in reverse order. + +@code{reverse} constructs a new list. @code{reverse!} is permitted, but +not required, to modify @var{lst} in constructing its return. + +For @code{reverse!}, the optional @var{newtail} is appended to the +result. @var{newtail} isn't reversed, it simply becomes the list +tail. For @code{scm_reverse_x}, the @var{newtail} parameter is +mandatory, but can be @code{SCM_EOL} if no further tail is required. +@end deffn + +@node List Modification +@subsubsection List Modification + +The following procedures modify an existing list, either by changing +elements of the list, or by changing the list structure itself. + +@deffn {Scheme Procedure} list-set! list k val +@deffnx {C Function} scm_list_set_x (list, k, val) +Set the @var{k}th element of @var{list} to @var{val}. +@end deffn + +@deffn {Scheme Procedure} list-cdr-set! list k val +@deffnx {C Function} scm_list_cdr_set_x (list, k, val) +Set the @var{k}th cdr of @var{list} to @var{val}. +@end deffn + +@deffn {Scheme Procedure} delq item lst +@deffnx {C Function} scm_delq (item, lst) +Return a newly-created copy of @var{lst} with elements +@code{eq?} to @var{item} removed. This procedure mirrors +@code{memq}: @code{delq} compares elements of @var{lst} against +@var{item} with @code{eq?}. +@end deffn + +@deffn {Scheme Procedure} delv item lst +@deffnx {C Function} scm_delv (item, lst) +Return a newly-created copy of @var{lst} with elements +@code{eqv?} to @var{item} removed. This procedure mirrors +@code{memv}: @code{delv} compares elements of @var{lst} against +@var{item} with @code{eqv?}. +@end deffn + +@deffn {Scheme Procedure} delete item lst +@deffnx {C Function} scm_delete (item, lst) +Return a newly-created copy of @var{lst} with elements +@code{equal?} to @var{item} removed. This procedure mirrors +@code{member}: @code{delete} compares elements of @var{lst} +against @var{item} with @code{equal?}. + +See also SRFI-1 which has an extended @code{delete} (@ref{SRFI-1 +Deleting}), and also an @code{lset-difference} which can delete +multiple @var{item}s in one call (@ref{SRFI-1 Set Operations}). +@end deffn + +@deffn {Scheme Procedure} delq! item lst +@deffnx {Scheme Procedure} delv! item lst +@deffnx {Scheme Procedure} delete! item lst +@deffnx {C Function} scm_delq_x (item, lst) +@deffnx {C Function} scm_delv_x (item, lst) +@deffnx {C Function} scm_delete_x (item, lst) +These procedures are destructive versions of @code{delq}, @code{delv} +and @code{delete}: they modify the pointers in the existing @var{lst} +rather than creating a new list. Caveat evaluator: Like other +destructive list functions, these functions cannot modify the binding of +@var{lst}, and so cannot be used to delete the first element of +@var{lst} destructively. +@end deffn + +@deffn {Scheme Procedure} delq1! item lst +@deffnx {C Function} scm_delq1_x (item, lst) +Like @code{delq!}, but only deletes the first occurrence of +@var{item} from @var{lst}. Tests for equality using +@code{eq?}. See also @code{delv1!} and @code{delete1!}. +@end deffn + +@deffn {Scheme Procedure} delv1! item lst +@deffnx {C Function} scm_delv1_x (item, lst) +Like @code{delv!}, but only deletes the first occurrence of +@var{item} from @var{lst}. Tests for equality using +@code{eqv?}. See also @code{delq1!} and @code{delete1!}. +@end deffn + +@deffn {Scheme Procedure} delete1! item lst +@deffnx {C Function} scm_delete1_x (item, lst) +Like @code{delete!}, but only deletes the first occurrence of +@var{item} from @var{lst}. Tests for equality using +@code{equal?}. See also @code{delq1!} and @code{delv1!}. +@end deffn + +@deffn {Scheme Procedure} filter pred lst +@deffnx {Scheme Procedure} filter! pred lst +Return a list containing all elements from @var{lst} which satisfy the +predicate @var{pred}. The elements in the result list have the same +order as in @var{lst}. The order in which @var{pred} is applied to +the list elements is not specified. + +@code{filter} does not change @var{lst}, but the result may share a +tail with it. @code{filter!} may modify @var{lst} to construct its +return. +@end deffn + +@node List Searching +@subsubsection List Searching + +The following procedures search lists for particular elements. They use +different comparison predicates for comparing list elements with the +object to be searched. When they fail, they return @code{#f}, otherwise +they return the sublist whose car is equal to the search object, where +equality depends on the equality predicate used. + +@rnindex memq +@deffn {Scheme Procedure} memq x lst +@deffnx {C Function} scm_memq (x, lst) +Return the first sublist of @var{lst} whose car is @code{eq?} +to @var{x} where the sublists of @var{lst} are the non-empty +lists returned by @code{(list-tail @var{lst} @var{k})} for +@var{k} less than the length of @var{lst}. If @var{x} does not +occur in @var{lst}, then @code{#f} (not the empty list) is +returned. +@end deffn + +@rnindex memv +@deffn {Scheme Procedure} memv x lst +@deffnx {C Function} scm_memv (x, lst) +Return the first sublist of @var{lst} whose car is @code{eqv?} +to @var{x} where the sublists of @var{lst} are the non-empty +lists returned by @code{(list-tail @var{lst} @var{k})} for +@var{k} less than the length of @var{lst}. If @var{x} does not +occur in @var{lst}, then @code{#f} (not the empty list) is +returned. +@end deffn + +@rnindex member +@deffn {Scheme Procedure} member x lst +@deffnx {C Function} scm_member (x, lst) +Return the first sublist of @var{lst} whose car is +@code{equal?} to @var{x} where the sublists of @var{lst} are +the non-empty lists returned by @code{(list-tail @var{lst} +@var{k})} for @var{k} less than the length of @var{lst}. If +@var{x} does not occur in @var{lst}, then @code{#f} (not the +empty list) is returned. + +See also SRFI-1 which has an extended @code{member} function +(@ref{SRFI-1 Searching}). +@end deffn + + +@node List Mapping +@subsubsection List Mapping + +List processing is very convenient in Scheme because the process of +iterating over the elements of a list can be highly abstracted. The +procedures in this section are the most basic iterating procedures for +lists. They take a procedure and one or more lists as arguments, and +apply the procedure to each element of the list. They differ in their +return value. + +@rnindex map +@c begin (texi-doc-string "guile" "map") +@deffn {Scheme Procedure} map proc arg1 arg2 @dots{} +@deffnx {Scheme Procedure} map-in-order proc arg1 arg2 @dots{} +@deffnx {C Function} scm_map (proc, arg1, args) +Apply @var{proc} to each element of the list @var{arg1} (if only two +arguments are given), or to the corresponding elements of the argument +lists (if more than two arguments are given). The result(s) of the +procedure applications are saved and returned in a list. For +@code{map}, the order of procedure applications is not specified, +@code{map-in-order} applies the procedure from left to right to the list +elements. +@end deffn + +@rnindex for-each +@c begin (texi-doc-string "guile" "for-each") +@deffn {Scheme Procedure} for-each proc arg1 arg2 @dots{} +Like @code{map}, but the procedure is always applied from left to right, +and the result(s) of the procedure applications are thrown away. The +return value is not specified. +@end deffn + +See also SRFI-1 which extends these functions to take lists of unequal +lengths (@ref{SRFI-1 Fold and Map}). + +@node Vectors +@subsection Vectors +@tpindex Vectors + +Vectors are sequences of Scheme objects. Unlike lists, the length of a +vector, once the vector is created, cannot be changed. The advantage of +vectors over lists is that the time required to access one element of a vector +given its @dfn{position} (synonymous with @dfn{index}), a zero-origin number, +is constant, whereas lists have an access time linear to the position of the +accessed element in the list. + +Vectors can contain any kind of Scheme object; it is even possible to +have different types of objects in the same vector. For vectors +containing vectors, you may wish to use arrays, instead. Note, too, +that vectors are the special case of one dimensional non-uniform arrays +and that most array procedures operate happily on vectors +(@pxref{Arrays}). + +Also see @ref{SRFI-43}, for a comprehensive vector library. + +@menu +* Vector Syntax:: Read syntax for vectors. +* Vector Creation:: Dynamic vector creation and validation. +* Vector Accessors:: Accessing and modifying vector contents. +* Vector Accessing from C:: Ways to work with vectors from C. +* Uniform Numeric Vectors:: Vectors of unboxed numeric values. +@end menu + + +@node Vector Syntax +@subsubsection Read Syntax for Vectors + +Vectors can literally be entered in source code, just like strings, +characters or some of the other data types. The read syntax for vectors +is as follows: A sharp sign (@code{#}), followed by an opening +parentheses, all elements of the vector in their respective read syntax, +and finally a closing parentheses. Like strings, vectors do not have to +be quoted. + +The following are examples of the read syntax for vectors; where the +first vector only contains numbers and the second three different object +types: a string, a symbol and a number in hexadecimal notation. + +@lisp +#(1 2 3) +#("Hello" foo #xdeadbeef) +@end lisp + +@node Vector Creation +@subsubsection Dynamic Vector Creation and Validation + +Instead of creating a vector implicitly by using the read syntax just +described, you can create a vector dynamically by calling one of the +@code{vector} and @code{list->vector} primitives with the list of Scheme +values that you want to place into a vector. The size of the vector +thus created is determined implicitly by the number of arguments given. + +@rnindex vector +@rnindex list->vector +@deffn {Scheme Procedure} vector arg @dots{} +@deffnx {Scheme Procedure} list->vector l +@deffnx {C Function} scm_vector (l) +Return a newly allocated vector composed of the +given arguments. Analogous to @code{list}. + +@lisp +(vector 'a 'b 'c) @result{} #(a b c) +@end lisp +@end deffn + +The inverse operation is @code{vector->list}: + +@rnindex vector->list +@deffn {Scheme Procedure} vector->list v +@deffnx {C Function} scm_vector_to_list (v) +Return a newly allocated list composed of the elements of @var{v}. + +@lisp +(vector->list #(dah dah didah)) @result{} (dah dah didah) +(list->vector '(dididit dah)) @result{} #(dididit dah) +@end lisp +@end deffn + +To allocate a vector with an explicitly specified size, use +@code{make-vector}. With this primitive you can also specify an initial +value for the vector elements (the same value for all elements, that +is): + +@rnindex make-vector +@deffn {Scheme Procedure} make-vector len [fill] +@deffnx {C Function} scm_make_vector (len, fill) +Return a newly allocated vector of @var{len} elements. If a +second argument is given, then each position is initialized to +@var{fill}. Otherwise the initial contents of each position is +unspecified. +@end deffn + +@deftypefn {C Function} SCM scm_c_make_vector (size_t k, SCM fill) +Like @code{scm_make_vector}, but the length is given as a @code{size_t}. +@end deftypefn + +To check whether an arbitrary Scheme value @emph{is} a vector, use the +@code{vector?} primitive: + +@rnindex vector? +@deffn {Scheme Procedure} vector? obj +@deffnx {C Function} scm_vector_p (obj) +Return @code{#t} if @var{obj} is a vector, otherwise return +@code{#f}. +@end deffn + +@deftypefn {C Function} int scm_is_vector (SCM obj) +Return non-zero when @var{obj} is a vector, otherwise return +@code{zero}. +@end deftypefn + +@node Vector Accessors +@subsubsection Accessing and Modifying Vector Contents + +@code{vector-length} and @code{vector-ref} return information about a +given vector, respectively its size and the elements that are contained +in the vector. + +@rnindex vector-length +@deffn {Scheme Procedure} vector-length vector +@deffnx {C Function} scm_vector_length (vector) +Return the number of elements in @var{vector} as an exact integer. +@end deffn + +@deftypefn {C Function} size_t scm_c_vector_length (SCM vec) +Return the number of elements in @var{vec} as a @code{size_t}. +@end deftypefn + +@rnindex vector-ref +@deffn {Scheme Procedure} vector-ref vec k +@deffnx {C Function} scm_vector_ref (vec, k) +Return the contents of position @var{k} of @var{vec}. +@var{k} must be a valid index of @var{vec}. +@lisp +(vector-ref #(1 1 2 3 5 8 13 21) 5) @result{} 8 +(vector-ref #(1 1 2 3 5 8 13 21) + (let ((i (round (* 2 (acos -1))))) + (if (inexact? i) + (inexact->exact i) + i))) @result{} 13 +@end lisp +@end deffn + +@deftypefn {C Function} SCM scm_c_vector_ref (SCM vec, size_t k) +Return the contents of position @var{k} (a @code{size_t}) of +@var{vec}. +@end deftypefn + +A vector created by one of the dynamic vector constructor procedures +(@pxref{Vector Creation}) can be modified using the following +procedures. + +@emph{NOTE:} According to R5RS, it is an error to use any of these +procedures on a literally read vector, because such vectors should be +considered as constants. Currently, however, Guile does not detect this +error. + +@rnindex vector-set! +@deffn {Scheme Procedure} vector-set! vec k obj +@deffnx {C Function} scm_vector_set_x (vec, k, obj) +Store @var{obj} in position @var{k} of @var{vec}. +@var{k} must be a valid index of @var{vec}. +The value returned by @samp{vector-set!} is unspecified. +@lisp +(let ((vec (vector 0 '(2 2 2 2) "Anna"))) + (vector-set! vec 1 '("Sue" "Sue")) + vec) @result{} #(0 ("Sue" "Sue") "Anna") +@end lisp +@end deffn + +@deftypefn {C Function} void scm_c_vector_set_x (SCM vec, size_t k, SCM obj) +Store @var{obj} in position @var{k} (a @code{size_t}) of @var{vec}. +@end deftypefn + +@rnindex vector-fill! +@deffn {Scheme Procedure} vector-fill! vec fill +@deffnx {C Function} scm_vector_fill_x (vec, fill) +Store @var{fill} in every position of @var{vec}. The value +returned by @code{vector-fill!} is unspecified. +@end deffn + +@deffn {Scheme Procedure} vector-copy vec +@deffnx {C Function} scm_vector_copy (vec) +Return a copy of @var{vec}. +@end deffn + +@deffn {Scheme Procedure} vector-move-left! vec1 start1 end1 vec2 start2 +@deffnx {C Function} scm_vector_move_left_x (vec1, start1, end1, vec2, start2) +Copy elements from @var{vec1}, positions @var{start1} to @var{end1}, +to @var{vec2} starting at position @var{start2}. @var{start1} and +@var{start2} are inclusive indices; @var{end1} is exclusive. + +@code{vector-move-left!} copies elements in leftmost order. +Therefore, in the case where @var{vec1} and @var{vec2} refer to the +same vector, @code{vector-move-left!} is usually appropriate when +@var{start1} is greater than @var{start2}. +@end deffn + +@deffn {Scheme Procedure} vector-move-right! vec1 start1 end1 vec2 start2 +@deffnx {C Function} scm_vector_move_right_x (vec1, start1, end1, vec2, start2) +Copy elements from @var{vec1}, positions @var{start1} to @var{end1}, +to @var{vec2} starting at position @var{start2}. @var{start1} and +@var{start2} are inclusive indices; @var{end1} is exclusive. + +@code{vector-move-right!} copies elements in rightmost order. +Therefore, in the case where @var{vec1} and @var{vec2} refer to the +same vector, @code{vector-move-right!} is usually appropriate when +@var{start1} is less than @var{start2}. +@end deffn + +@node Vector Accessing from C +@subsubsection Vector Accessing from C + +A vector can be read and modified from C with the functions +@code{scm_c_vector_ref} and @code{scm_c_vector_set_x}, for example. In +addition to these functions, there are two more ways to access vectors +from C that might be more efficient in certain situations: you can +restrict yourself to @dfn{simple vectors} and then use the very fast +@emph{simple vector macros}; or you can use the very general framework +for accessing all kinds of arrays (@pxref{Accessing Arrays from C}), +which is more verbose, but can deal efficiently with all kinds of +vectors (and arrays). For vectors, you can use the +@code{scm_vector_elements} and @code{scm_vector_writable_elements} +functions as shortcuts. + +@deftypefn {C Function} int scm_is_simple_vector (SCM obj) +Return non-zero if @var{obj} is a simple vector, else return zero. A +simple vector is a vector that can be used with the @code{SCM_SIMPLE_*} +macros below. + +The following functions are guaranteed to return simple vectors: +@code{scm_make_vector}, @code{scm_c_make_vector}, @code{scm_vector}, +@code{scm_list_to_vector}. +@end deftypefn + +@deftypefn {C Macro} size_t SCM_SIMPLE_VECTOR_LENGTH (SCM vec) +Evaluates to the length of the simple vector @var{vec}. No type +checking is done. +@end deftypefn + +@deftypefn {C Macro} SCM SCM_SIMPLE_VECTOR_REF (SCM vec, size_t idx) +Evaluates to the element at position @var{idx} in the simple vector +@var{vec}. No type or range checking is done. +@end deftypefn + +@deftypefn {C Macro} void SCM_SIMPLE_VECTOR_SET (SCM vec, size_t idx, SCM val) +Sets the element at position @var{idx} in the simple vector +@var{vec} to @var{val}. No type or range checking is done. +@end deftypefn + +@deftypefn {C Function} {const SCM *} scm_vector_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp) +Acquire a handle for the vector @var{vec} and return a pointer to the +elements of it. This pointer can only be used to read the elements of +@var{vec}. When @var{vec} is not a vector, an error is signaled. The +handle must eventually be released with +@code{scm_array_handle_release}. + +The variables pointed to by @var{lenp} and @var{incp} are filled with +the number of elements of the vector and the increment (number of +elements) between successive elements, respectively. Successive +elements of @var{vec} need not be contiguous in their underlying +``root vector'' returned here; hence the increment is not necessarily +equal to 1 and may well be negative too (@pxref{Shared Arrays}). + +The following example shows the typical way to use this function. It +creates a list of all elements of @var{vec} (in reverse order). + +@example +scm_t_array_handle handle; +size_t i, len; +ssize_t inc; +const SCM *elt; +SCM list; + +elt = scm_vector_elements (vec, &handle, &len, &inc); +list = SCM_EOL; +for (i = 0; i < len; i++, elt += inc) + list = scm_cons (*elt, list); +scm_array_handle_release (&handle); +@end example + +@end deftypefn + +@deftypefn {C Function} {SCM *} scm_vector_writable_elements (SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp) +Like @code{scm_vector_elements} but the pointer can be used to modify +the vector. + +The following example shows the typical way to use this function. It +fills a vector with @code{#t}. + +@example +scm_t_array_handle handle; +size_t i, len; +ssize_t inc; +SCM *elt; + +elt = scm_vector_writable_elements (vec, &handle, &len, &inc); +for (i = 0; i < len; i++, elt += inc) + *elt = SCM_BOOL_T; +scm_array_handle_release (&handle); +@end example + +@end deftypefn + +@node Uniform Numeric Vectors +@subsubsection Uniform Numeric Vectors + +A uniform numeric vector is a vector whose elements are all of a single +numeric type. Guile offers uniform numeric vectors for signed and +unsigned 8-bit, 16-bit, 32-bit, and 64-bit integers, two sizes of +floating point values, and complex floating-point numbers of these two +sizes. @xref{SRFI-4}, for more information. + +For many purposes, bytevectors work just as well as uniform vectors, and have +the advantage that they integrate well with binary input and output. +@xref{Bytevectors}, for more information on bytevectors. + +@node Bit Vectors +@subsection Bit Vectors + +@noindent +Bit vectors are zero-origin, one-dimensional arrays of booleans. They +are displayed as a sequence of @code{0}s and @code{1}s prefixed by +@code{#*}, e.g., + +@example +(make-bitvector 8 #f) @result{} +#*00000000 +@end example + +Bit vectors are the special case of one dimensional bit arrays, and can +thus be used with the array procedures, @xref{Arrays}. + +@deffn {Scheme Procedure} bitvector? obj +@deffnx {C Function} scm_bitvector_p (obj) +Return @code{#t} when @var{obj} is a bitvector, else +return @code{#f}. +@end deffn + +@deftypefn {C Function} int scm_is_bitvector (SCM obj) +Return @code{1} when @var{obj} is a bitvector, else return @code{0}. +@end deftypefn + +@deffn {Scheme Procedure} make-bitvector len [fill] +@deffnx {C Function} scm_make_bitvector (len, fill) +Create a new bitvector of length @var{len} and +optionally initialize all elements to @var{fill}. +@end deffn + +@deftypefn {C Function} SCM scm_c_make_bitvector (size_t len, SCM fill) +Like @code{scm_make_bitvector}, but the length is given as a +@code{size_t}. +@end deftypefn + +@deffn {Scheme Procedure} bitvector bit @dots{} +@deffnx {C Function} scm_bitvector (bits) +Create a new bitvector with the arguments as elements. +@end deffn + +@deffn {Scheme Procedure} bitvector-length vec +@deffnx {C Function} scm_bitvector_length (vec) +Return the length of the bitvector @var{vec}. +@end deffn + +@deftypefn {C Function} size_t scm_c_bitvector_length (SCM vec) +Like @code{scm_bitvector_length}, but the length is returned as a +@code{size_t}. +@end deftypefn + +@deffn {Scheme Procedure} bitvector-ref vec idx +@deffnx {C Function} scm_bitvector_ref (vec, idx) +Return the element at index @var{idx} of the bitvector +@var{vec}. +@end deffn + +@deftypefn {C Function} SCM scm_c_bitvector_ref (SCM vec, size_t idx) +Return the element at index @var{idx} of the bitvector +@var{vec}. +@end deftypefn + +@deffn {Scheme Procedure} bitvector-set! vec idx val +@deffnx {C Function} scm_bitvector_set_x (vec, idx, val) +Set the element at index @var{idx} of the bitvector +@var{vec} when @var{val} is true, else clear it. +@end deffn + +@deftypefn {C Function} SCM scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val) +Set the element at index @var{idx} of the bitvector +@var{vec} when @var{val} is true, else clear it. +@end deftypefn + +@deffn {Scheme Procedure} bitvector-fill! vec val +@deffnx {C Function} scm_bitvector_fill_x (vec, val) +Set all elements of the bitvector +@var{vec} when @var{val} is true, else clear them. +@end deffn + +@deffn {Scheme Procedure} list->bitvector list +@deffnx {C Function} scm_list_to_bitvector (list) +Return a new bitvector initialized with the elements +of @var{list}. +@end deffn + +@deffn {Scheme Procedure} bitvector->list vec +@deffnx {C Function} scm_bitvector_to_list (vec) +Return a new list initialized with the elements +of the bitvector @var{vec}. +@end deffn + +@deffn {Scheme Procedure} bit-count bool bitvector +@deffnx {C Function} scm_bit_count (bool, bitvector) +Return a count of how many entries in @var{bitvector} are equal to +@var{bool}. For example, + +@example +(bit-count #f #*000111000) @result{} 6 +@end example +@end deffn + +@deffn {Scheme Procedure} bit-position bool bitvector start +@deffnx {C Function} scm_bit_position (bool, bitvector, start) +Return the index of the first occurrence of @var{bool} in +@var{bitvector}, starting from @var{start}. If there is no @var{bool} +entry between @var{start} and the end of @var{bitvector}, then return +@code{#f}. For example, + +@example +(bit-position #t #*000101 0) @result{} 3 +(bit-position #f #*0001111 3) @result{} #f +@end example +@end deffn + +@deffn {Scheme Procedure} bit-invert! bitvector +@deffnx {C Function} scm_bit_invert_x (bitvector) +Modify @var{bitvector} by replacing each element with its negation. +@end deffn + +@deffn {Scheme Procedure} bit-set*! bitvector uvec bool +@deffnx {C Function} scm_bit_set_star_x (bitvector, uvec, bool) +Set entries of @var{bitvector} to @var{bool}, with @var{uvec} +selecting the entries to change. The return value is unspecified. + +If @var{uvec} is a bit vector, then those entries where it has +@code{#t} are the ones in @var{bitvector} which are set to @var{bool}. +@var{uvec} and @var{bitvector} must be the same length. When +@var{bool} is @code{#t} it's like @var{uvec} is OR'ed into +@var{bitvector}. Or when @var{bool} is @code{#f} it can be seen as an +ANDNOT. + +@example +(define bv #*01000010) +(bit-set*! bv #*10010001 #t) +bv +@result{} #*11010011 +@end example + +If @var{uvec} is a uniform vector of unsigned long integers, then +they're indexes into @var{bitvector} which are set to @var{bool}. + +@example +(define bv #*01000010) +(bit-set*! bv #u(5 2 7) #t) +bv +@result{} #*01100111 +@end example +@end deffn + +@deffn {Scheme Procedure} bit-count* bitvector uvec bool +@deffnx {C Function} scm_bit_count_star (bitvector, uvec, bool) +Return a count of how many entries in @var{bitvector} are equal to +@var{bool}, with @var{uvec} selecting the entries to consider. + +@var{uvec} is interpreted in the same way as for @code{bit-set*!} +above. Namely, if @var{uvec} is a bit vector then entries which have +@code{#t} there are considered in @var{bitvector}. Or if @var{uvec} +is a uniform vector of unsigned long integers then it's the indexes in +@var{bitvector} to consider. + +For example, + +@example +(bit-count* #*01110111 #*11001101 #t) @result{} 3 +(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2 +@end example +@end deffn + +@deftypefn {C Function} {const scm_t_uint32 *} scm_bitvector_elements (SCM vec, scm_t_array_handle *handle, size_t *offp, size_t *lenp, ssize_t *incp) +Like @code{scm_vector_elements} (@pxref{Vector Accessing from C}), but +for bitvectors. The variable pointed to by @var{offp} is set to the +value returned by @code{scm_array_handle_bit_elements_offset}. See +@code{scm_array_handle_bit_elements} for how to use the returned +pointer and the offset. +@end deftypefn + +@deftypefn {C Function} {scm_t_uint32 *} scm_bitvector_writable_elements (SCM vec, scm_t_array_handle *handle, size_t *offp, size_t *lenp, ssize_t *incp) +Like @code{scm_bitvector_elements}, but the pointer is good for reading +and writing. +@end deftypefn + +@node Bytevectors +@subsection Bytevectors + +@cindex bytevector +@cindex R6RS + +A @dfn{bytevector} is a raw bit string. The @code{(rnrs bytevectors)} +module provides the programming interface specified by the +@uref{http://www.r6rs.org/, Revised^6 Report on the Algorithmic Language +Scheme (R6RS)}. It contains procedures to manipulate bytevectors and +interpret their contents in a number of ways: bytevector contents can be +accessed as signed or unsigned integer of various sizes and endianness, +as IEEE-754 floating point numbers, or as strings. It is a useful tool +to encode and decode binary data. + +The R6RS (Section 4.3.4) specifies an external representation for +bytevectors, whereby the octets (integers in the range 0--255) contained +in the bytevector are represented as a list prefixed by @code{#vu8}: + +@lisp +#vu8(1 53 204) +@end lisp + +denotes a 3-byte bytevector containing the octets 1, 53, and 204. Like +string literals, booleans, etc., bytevectors are ``self-quoting'', i.e., +they do not need to be quoted: + +@lisp +#vu8(1 53 204) +@result{} #vu8(1 53 204) +@end lisp + +Bytevectors can be used with the binary input/output primitives +(@pxref{Binary I/O}). + +@menu +* Bytevector Endianness:: Dealing with byte order. +* Bytevector Manipulation:: Creating, copying, manipulating bytevectors. +* Bytevectors as Integers:: Interpreting bytes as integers. +* Bytevectors and Integer Lists:: Converting to/from an integer list. +* Bytevectors as Floats:: Interpreting bytes as real numbers. +* Bytevectors as Strings:: Interpreting bytes as Unicode strings. +* Bytevectors as Arrays:: Guile extension to the bytevector API. +* Bytevectors as Uniform Vectors:: Bytevectors and SRFI-4. +@end menu + +@node Bytevector Endianness +@subsubsection Endianness + +@cindex endianness +@cindex byte order +@cindex word order + +Some of the following procedures take an @var{endianness} parameter. +The @dfn{endianness} is defined as the order of bytes in multi-byte +numbers: numbers encoded in @dfn{big endian} have their most +significant bytes written first, whereas numbers encoded in +@dfn{little endian} have their least significant bytes +first@footnote{Big-endian and little-endian are the most common +``endiannesses'', but others do exist. For instance, the GNU MP +library allows @dfn{word order} to be specified independently of +@dfn{byte order} (@pxref{Integer Import and Export,,, gmp, The GNU +Multiple Precision Arithmetic Library Manual}).}. + +Little-endian is the native endianness of the IA32 architecture and +its derivatives, while big-endian is native to SPARC and PowerPC, +among others. The @code{native-endianness} procedure returns the +native endianness of the machine it runs on. + +@deffn {Scheme Procedure} native-endianness +@deffnx {C Function} scm_native_endianness () +Return a value denoting the native endianness of the host machine. +@end deffn + +@deffn {Scheme Macro} endianness symbol +Return an object denoting the endianness specified by @var{symbol}. If +@var{symbol} is neither @code{big} nor @code{little} then an error is +raised at expand-time. +@end deffn + +@defvr {C Variable} scm_endianness_big +@defvrx {C Variable} scm_endianness_little +The objects denoting big- and little-endianness, respectively. +@end defvr + + +@node Bytevector Manipulation +@subsubsection Manipulating Bytevectors + +Bytevectors can be created, copied, and analyzed with the following +procedures and C functions. + +@deffn {Scheme Procedure} make-bytevector len [fill] +@deffnx {C Function} scm_make_bytevector (len, fill) +@deffnx {C Function} scm_c_make_bytevector (size_t len) +Return a new bytevector of @var{len} bytes. Optionally, if @var{fill} +is given, fill it with @var{fill}; @var{fill} must be in the range +[-128,255]. +@end deffn + +@deffn {Scheme Procedure} bytevector? obj +@deffnx {C Function} scm_bytevector_p (obj) +Return true if @var{obj} is a bytevector. +@end deffn + +@deftypefn {C Function} int scm_is_bytevector (SCM obj) +Equivalent to @code{scm_is_true (scm_bytevector_p (obj))}. +@end deftypefn + +@deffn {Scheme Procedure} bytevector-length bv +@deffnx {C Function} scm_bytevector_length (bv) +Return the length in bytes of bytevector @var{bv}. +@end deffn + +@deftypefn {C Function} size_t scm_c_bytevector_length (SCM bv) +Likewise, return the length in bytes of bytevector @var{bv}. +@end deftypefn + +@deffn {Scheme Procedure} bytevector=? bv1 bv2 +@deffnx {C Function} scm_bytevector_eq_p (bv1, bv2) +Return is @var{bv1} equals to @var{bv2}---i.e., if they have the same +length and contents. +@end deffn + +@deffn {Scheme Procedure} bytevector-fill! bv fill +@deffnx {C Function} scm_bytevector_fill_x (bv, fill) +Fill bytevector @var{bv} with @var{fill}, a byte. +@end deffn + +@deffn {Scheme Procedure} bytevector-copy! source source-start target target-start len +@deffnx {C Function} scm_bytevector_copy_x (source, source_start, target, target_start, len) +Copy @var{len} bytes from @var{source} into @var{target}, starting +reading from @var{source-start} (a positive index within @var{source}) +and start writing at @var{target-start}. It is permitted for the +@var{source} and @var{target} regions to overlap. +@end deffn + +@deffn {Scheme Procedure} bytevector-copy bv +@deffnx {C Function} scm_bytevector_copy (bv) +Return a newly allocated copy of @var{bv}. +@end deffn + +@deftypefn {C Function} scm_t_uint8 scm_c_bytevector_ref (SCM bv, size_t index) +Return the byte at @var{index} in bytevector @var{bv}. +@end deftypefn + +@deftypefn {C Function} void scm_c_bytevector_set_x (SCM bv, size_t index, scm_t_uint8 value) +Set the byte at @var{index} in @var{bv} to @var{value}. +@end deftypefn + +Low-level C macros are available. They do not perform any +type-checking; as such they should be used with care. + +@deftypefn {C Macro} size_t SCM_BYTEVECTOR_LENGTH (bv) +Return the length in bytes of bytevector @var{bv}. +@end deftypefn + +@deftypefn {C Macro} {signed char *} SCM_BYTEVECTOR_CONTENTS (bv) +Return a pointer to the contents of bytevector @var{bv}. +@end deftypefn + + +@node Bytevectors as Integers +@subsubsection Interpreting Bytevector Contents as Integers + +The contents of a bytevector can be interpreted as a sequence of +integers of any given size, sign, and endianness. + +@lisp +(let ((bv (make-bytevector 4))) + (bytevector-u8-set! bv 0 #x12) + (bytevector-u8-set! bv 1 #x34) + (bytevector-u8-set! bv 2 #x56) + (bytevector-u8-set! bv 3 #x78) + + (map (lambda (number) + (number->string number 16)) + (list (bytevector-u8-ref bv 0) + (bytevector-u16-ref bv 0 (endianness big)) + (bytevector-u32-ref bv 0 (endianness little))))) + +@result{} ("12" "1234" "78563412") +@end lisp + +The most generic procedures to interpret bytevector contents as integers +are described below. + +@deffn {Scheme Procedure} bytevector-uint-ref bv index endianness size +@deffnx {C Function} scm_bytevector_uint_ref (bv, index, endianness, size) +Return the @var{size}-byte long unsigned integer at index @var{index} in +@var{bv}, decoded according to @var{endianness}. +@end deffn + +@deffn {Scheme Procedure} bytevector-sint-ref bv index endianness size +@deffnx {C Function} scm_bytevector_sint_ref (bv, index, endianness, size) +Return the @var{size}-byte long signed integer at index @var{index} in +@var{bv}, decoded according to @var{endianness}. +@end deffn + +@deffn {Scheme Procedure} bytevector-uint-set! bv index value endianness size +@deffnx {C Function} scm_bytevector_uint_set_x (bv, index, value, endianness, size) +Set the @var{size}-byte long unsigned integer at @var{index} to +@var{value}, encoded according to @var{endianness}. +@end deffn + +@deffn {Scheme Procedure} bytevector-sint-set! bv index value endianness size +@deffnx {C Function} scm_bytevector_sint_set_x (bv, index, value, endianness, size) +Set the @var{size}-byte long signed integer at @var{index} to +@var{value}, encoded according to @var{endianness}. +@end deffn + +The following procedures are similar to the ones above, but specialized +to a given integer size: + +@deffn {Scheme Procedure} bytevector-u8-ref bv index +@deffnx {Scheme Procedure} bytevector-s8-ref bv index +@deffnx {Scheme Procedure} bytevector-u16-ref bv index endianness +@deffnx {Scheme Procedure} bytevector-s16-ref bv index endianness +@deffnx {Scheme Procedure} bytevector-u32-ref bv index endianness +@deffnx {Scheme Procedure} bytevector-s32-ref bv index endianness +@deffnx {Scheme Procedure} bytevector-u64-ref bv index endianness +@deffnx {Scheme Procedure} bytevector-s64-ref bv index endianness +@deffnx {C Function} scm_bytevector_u8_ref (bv, index) +@deffnx {C Function} scm_bytevector_s8_ref (bv, index) +@deffnx {C Function} scm_bytevector_u16_ref (bv, index, endianness) +@deffnx {C Function} scm_bytevector_s16_ref (bv, index, endianness) +@deffnx {C Function} scm_bytevector_u32_ref (bv, index, endianness) +@deffnx {C Function} scm_bytevector_s32_ref (bv, index, endianness) +@deffnx {C Function} scm_bytevector_u64_ref (bv, index, endianness) +@deffnx {C Function} scm_bytevector_s64_ref (bv, index, endianness) +Return the unsigned @var{n}-bit (signed) integer (where @var{n} is 8, +16, 32 or 64) from @var{bv} at @var{index}, decoded according to +@var{endianness}. +@end deffn + +@deffn {Scheme Procedure} bytevector-u8-set! bv index value +@deffnx {Scheme Procedure} bytevector-s8-set! bv index value +@deffnx {Scheme Procedure} bytevector-u16-set! bv index value endianness +@deffnx {Scheme Procedure} bytevector-s16-set! bv index value endianness +@deffnx {Scheme Procedure} bytevector-u32-set! bv index value endianness +@deffnx {Scheme Procedure} bytevector-s32-set! bv index value endianness +@deffnx {Scheme Procedure} bytevector-u64-set! bv index value endianness +@deffnx {Scheme Procedure} bytevector-s64-set! bv index value endianness +@deffnx {C Function} scm_bytevector_u8_set_x (bv, index, value) +@deffnx {C Function} scm_bytevector_s8_set_x (bv, index, value) +@deffnx {C Function} scm_bytevector_u16_set_x (bv, index, value, endianness) +@deffnx {C Function} scm_bytevector_s16_set_x (bv, index, value, endianness) +@deffnx {C Function} scm_bytevector_u32_set_x (bv, index, value, endianness) +@deffnx {C Function} scm_bytevector_s32_set_x (bv, index, value, endianness) +@deffnx {C Function} scm_bytevector_u64_set_x (bv, index, value, endianness) +@deffnx {C Function} scm_bytevector_s64_set_x (bv, index, value, endianness) +Store @var{value} as an @var{n}-bit (signed) integer (where @var{n} is +8, 16, 32 or 64) in @var{bv} at @var{index}, encoded according to +@var{endianness}. +@end deffn + +Finally, a variant specialized for the host's endianness is available +for each of these functions (with the exception of the @code{u8} +accessors, for obvious reasons): + +@deffn {Scheme Procedure} bytevector-u16-native-ref bv index +@deffnx {Scheme Procedure} bytevector-s16-native-ref bv index +@deffnx {Scheme Procedure} bytevector-u32-native-ref bv index +@deffnx {Scheme Procedure} bytevector-s32-native-ref bv index +@deffnx {Scheme Procedure} bytevector-u64-native-ref bv index +@deffnx {Scheme Procedure} bytevector-s64-native-ref bv index +@deffnx {C Function} scm_bytevector_u16_native_ref (bv, index) +@deffnx {C Function} scm_bytevector_s16_native_ref (bv, index) +@deffnx {C Function} scm_bytevector_u32_native_ref (bv, index) +@deffnx {C Function} scm_bytevector_s32_native_ref (bv, index) +@deffnx {C Function} scm_bytevector_u64_native_ref (bv, index) +@deffnx {C Function} scm_bytevector_s64_native_ref (bv, index) +Return the unsigned @var{n}-bit (signed) integer (where @var{n} is 8, +16, 32 or 64) from @var{bv} at @var{index}, decoded according to the +host's native endianness. +@end deffn + +@deffn {Scheme Procedure} bytevector-u16-native-set! bv index value +@deffnx {Scheme Procedure} bytevector-s16-native-set! bv index value +@deffnx {Scheme Procedure} bytevector-u32-native-set! bv index value +@deffnx {Scheme Procedure} bytevector-s32-native-set! bv index value +@deffnx {Scheme Procedure} bytevector-u64-native-set! bv index value +@deffnx {Scheme Procedure} bytevector-s64-native-set! bv index value +@deffnx {C Function} scm_bytevector_u16_native_set_x (bv, index, value) +@deffnx {C Function} scm_bytevector_s16_native_set_x (bv, index, value) +@deffnx {C Function} scm_bytevector_u32_native_set_x (bv, index, value) +@deffnx {C Function} scm_bytevector_s32_native_set_x (bv, index, value) +@deffnx {C Function} scm_bytevector_u64_native_set_x (bv, index, value) +@deffnx {C Function} scm_bytevector_s64_native_set_x (bv, index, value) +Store @var{value} as an @var{n}-bit (signed) integer (where @var{n} is +8, 16, 32 or 64) in @var{bv} at @var{index}, encoded according to the +host's native endianness. +@end deffn + + +@node Bytevectors and Integer Lists +@subsubsection Converting Bytevectors to/from Integer Lists + +Bytevector contents can readily be converted to/from lists of signed or +unsigned integers: + +@lisp +(bytevector->sint-list (u8-list->bytevector (make-list 4 255)) + (endianness little) 2) +@result{} (-1 -1) +@end lisp + +@deffn {Scheme Procedure} bytevector->u8-list bv +@deffnx {C Function} scm_bytevector_to_u8_list (bv) +Return a newly allocated list of unsigned 8-bit integers from the +contents of @var{bv}. +@end deffn + +@deffn {Scheme Procedure} u8-list->bytevector lst +@deffnx {C Function} scm_u8_list_to_bytevector (lst) +Return a newly allocated bytevector consisting of the unsigned 8-bit +integers listed in @var{lst}. +@end deffn + +@deffn {Scheme Procedure} bytevector->uint-list bv endianness size +@deffnx {C Function} scm_bytevector_to_uint_list (bv, endianness, size) +Return a list of unsigned integers of @var{size} bytes representing the +contents of @var{bv}, decoded according to @var{endianness}. +@end deffn + +@deffn {Scheme Procedure} bytevector->sint-list bv endianness size +@deffnx {C Function} scm_bytevector_to_sint_list (bv, endianness, size) +Return a list of signed integers of @var{size} bytes representing the +contents of @var{bv}, decoded according to @var{endianness}. +@end deffn + +@deffn {Scheme Procedure} uint-list->bytevector lst endianness size +@deffnx {C Function} scm_uint_list_to_bytevector (lst, endianness, size) +Return a new bytevector containing the unsigned integers listed in +@var{lst} and encoded on @var{size} bytes according to @var{endianness}. +@end deffn + +@deffn {Scheme Procedure} sint-list->bytevector lst endianness size +@deffnx {C Function} scm_sint_list_to_bytevector (lst, endianness, size) +Return a new bytevector containing the signed integers listed in +@var{lst} and encoded on @var{size} bytes according to @var{endianness}. +@end deffn + +@node Bytevectors as Floats +@subsubsection Interpreting Bytevector Contents as Floating Point Numbers + +@cindex IEEE-754 floating point numbers + +Bytevector contents can also be accessed as IEEE-754 single- or +double-precision floating point numbers (respectively 32 and 64-bit +long) using the procedures described here. + +@deffn {Scheme Procedure} bytevector-ieee-single-ref bv index endianness +@deffnx {Scheme Procedure} bytevector-ieee-double-ref bv index endianness +@deffnx {C Function} scm_bytevector_ieee_single_ref (bv, index, endianness) +@deffnx {C Function} scm_bytevector_ieee_double_ref (bv, index, endianness) +Return the IEEE-754 single-precision floating point number from @var{bv} +at @var{index} according to @var{endianness}. +@end deffn + +@deffn {Scheme Procedure} bytevector-ieee-single-set! bv index value endianness +@deffnx {Scheme Procedure} bytevector-ieee-double-set! bv index value endianness +@deffnx {C Function} scm_bytevector_ieee_single_set_x (bv, index, value, endianness) +@deffnx {C Function} scm_bytevector_ieee_double_set_x (bv, index, value, endianness) +Store real number @var{value} in @var{bv} at @var{index} according to +@var{endianness}. +@end deffn + +Specialized procedures are also available: + +@deffn {Scheme Procedure} bytevector-ieee-single-native-ref bv index +@deffnx {Scheme Procedure} bytevector-ieee-double-native-ref bv index +@deffnx {C Function} scm_bytevector_ieee_single_native_ref (bv, index) +@deffnx {C Function} scm_bytevector_ieee_double_native_ref (bv, index) +Return the IEEE-754 single-precision floating point number from @var{bv} +at @var{index} according to the host's native endianness. +@end deffn + +@deffn {Scheme Procedure} bytevector-ieee-single-native-set! bv index value +@deffnx {Scheme Procedure} bytevector-ieee-double-native-set! bv index value +@deffnx {C Function} scm_bytevector_ieee_single_native_set_x (bv, index, value) +@deffnx {C Function} scm_bytevector_ieee_double_native_set_x (bv, index, value) +Store real number @var{value} in @var{bv} at @var{index} according to +the host's native endianness. +@end deffn + + +@node Bytevectors as Strings +@subsubsection Interpreting Bytevector Contents as Unicode Strings + +@cindex Unicode string encoding + +Bytevector contents can also be interpreted as Unicode strings encoded +in one of the most commonly available encoding formats. +@xref{Representing Strings as Bytes}, for a more generic interface. + +@lisp +(utf8->string (u8-list->bytevector '(99 97 102 101))) +@result{} "cafe" + +(string->utf8 "caf@'e") ;; SMALL LATIN LETTER E WITH ACUTE ACCENT +@result{} #vu8(99 97 102 195 169) +@end lisp + +@deftypefn {Scheme Procedure} {} string-utf8-length str +@deftypefnx {C function} SCM scm_string_utf8_length (str) +@deftypefnx {C function} size_t scm_c_string_utf8_length (str) +Return the number of bytes in the UTF-8 representation of @var{str}. +@end deftypefn + +@deffn {Scheme Procedure} string->utf8 str +@deffnx {Scheme Procedure} string->utf16 str [endianness] +@deffnx {Scheme Procedure} string->utf32 str [endianness] +@deffnx {C Function} scm_string_to_utf8 (str) +@deffnx {C Function} scm_string_to_utf16 (str, endianness) +@deffnx {C Function} scm_string_to_utf32 (str, endianness) +Return a newly allocated bytevector that contains the UTF-8, UTF-16, or +UTF-32 (aka. UCS-4) encoding of @var{str}. For UTF-16 and UTF-32, +@var{endianness} should be the symbol @code{big} or @code{little}; when omitted, +it defaults to big endian. +@end deffn + +@deffn {Scheme Procedure} utf8->string utf +@deffnx {Scheme Procedure} utf16->string utf [endianness] +@deffnx {Scheme Procedure} utf32->string utf [endianness] +@deffnx {C Function} scm_utf8_to_string (utf) +@deffnx {C Function} scm_utf16_to_string (utf, endianness) +@deffnx {C Function} scm_utf32_to_string (utf, endianness) +Return a newly allocated string that contains from the UTF-8-, UTF-16-, +or UTF-32-decoded contents of bytevector @var{utf}. For UTF-16 and UTF-32, +@var{endianness} should be the symbol @code{big} or @code{little}; when omitted, +it defaults to big endian. +@end deffn + +@node Bytevectors as Arrays +@subsubsection Accessing Bytevectors with the Array API + +As an extension to the R6RS, Guile allows bytevectors to be manipulated +with the @dfn{array} procedures (@pxref{Arrays}). When using these +APIs, bytes are accessed one at a time as 8-bit unsigned integers: + +@example +(define bv #vu8(0 1 2 3)) + +(array? bv) +@result{} #t + +(array-rank bv) +@result{} 1 + +(array-ref bv 2) +@result{} 2 + +;; Note the different argument order on array-set!. +(array-set! bv 77 2) +(array-ref bv 2) +@result{} 77 + +(array-type bv) +@result{} vu8 +@end example + + +@node Bytevectors as Uniform Vectors +@subsubsection Accessing Bytevectors with the SRFI-4 API + +Bytevectors may also be accessed with the SRFI-4 API. @xref{SRFI-4 and +Bytevectors}, for more information. + + +@node Arrays +@subsection Arrays +@tpindex Arrays + +@dfn{Arrays} are a collection of cells organized into an arbitrary +number of dimensions. Each cell can be accessed in constant time by +supplying an index for each dimension. + +In the current implementation, an array uses a vector of some kind for +the actual storage of its elements. Any kind of vector will do, so you +can have arrays of uniform numeric values, arrays of characters, arrays +of bits, and of course, arrays of arbitrary Scheme values. For example, +arrays with an underlying @code{c64vector} might be nice for digital +signal processing, while arrays made from a @code{u8vector} might be +used to hold gray-scale images. + +The number of dimensions of an array is called its @dfn{rank}. Thus, +a matrix is an array of rank 2, while a vector has rank 1. When +accessing an array element, you have to specify one exact integer for +each dimension. These integers are called the @dfn{indices} of the +element. An array specifies the allowed range of indices for each +dimension via an inclusive lower and upper bound. These bounds can +well be negative, but the upper bound must be greater than or equal to +the lower bound minus one. When all lower bounds of an array are +zero, it is called a @dfn{zero-origin} array. + +Arrays can be of rank 0, which could be interpreted as a scalar. +Thus, a zero-rank array can store exactly one object and the list of +indices of this element is the empty list. + +Arrays contain zero elements when one of their dimensions has a zero +length. These empty arrays maintain information about their shape: a +matrix with zero columns and 3 rows is different from a matrix with 3 +columns and zero rows, which again is different from a vector of +length zero. + +The array procedures are all polymorphic, treating strings, uniform +numeric vectors, bytevectors, bit vectors and ordinary vectors as one +dimensional arrays. + +@menu +* Array Syntax:: +* Array Procedures:: +* Shared Arrays:: +* Accessing Arrays from C:: +@end menu + +@node Array Syntax +@subsubsection Array Syntax + +An array is displayed as @code{#} followed by its rank, followed by a +tag that describes the underlying vector, optionally followed by +information about its shape, and finally followed by the cells, +organized into dimensions using parentheses. + +In more words, the array tag is of the form + +@example + #<@@lower><:len><@@lower><:len>... +@end example + +where @code{} is a positive integer in decimal giving the rank of +the array. It is omitted when the rank is 1 and the array is non-shared +and has zero-origin (see below). For shared arrays and for a non-zero +origin, the rank is always printed even when it is 1 to distinguish +them from ordinary vectors. + +The @code{} part is the tag for a uniform numeric vector, like +@code{u8}, @code{s16}, etc, @code{b} for bitvectors, or @code{a} for +strings. It is empty for ordinary vectors. + +The @code{<@@lower>} part is a @samp{@@} character followed by a signed +integer in decimal giving the lower bound of a dimension. There is one +@code{<@@lower>} for each dimension. When all lower bounds are zero, +all @code{<@@lower>} parts are omitted. + +The @code{<:len>} part is a @samp{:} character followed by an unsigned +integer in decimal giving the length of a dimension. Like for the lower +bounds, there is one @code{<:len>} for each dimension, and the +@code{<:len>} part always follows the @code{<@@lower>} part for a +dimension. Lengths are only then printed when they can't be deduced +from the nested lists of elements of the array literal, which can happen +when at least one length is zero. + +As a special case, an array of rank 0 is printed as +@code{#0()}, where @code{} is the result of +printing the single element of the array. + +Thus, + +@table @code +@item #(1 2 3) +is an ordinary array of rank 1 with lower bound 0 in dimension 0. +(I.e., a regular vector.) + +@item #@@2(1 2 3) +is an ordinary array of rank 1 with lower bound 2 in dimension 0. + +@item #2((1 2 3) (4 5 6)) +is a non-uniform array of rank 2; a 2@cross{}3 matrix with index ranges 0..1 +and 0..2. + +@item #u32(0 1 2) +is a uniform u8 array of rank 1. + +@item #2u32@@2@@3((1 2) (2 3)) +is a uniform u32 array of rank 2 with index ranges 2..3 and 3..4. + +@item #2() +is a two-dimensional array with index ranges 0..-1 and 0..-1, i.e.@: +both dimensions have length zero. + +@item #2:0:2() +is a two-dimensional array with index ranges 0..-1 and 0..1, i.e.@: the +first dimension has length zero, but the second has length 2. + +@item #0(12) +is a rank-zero array with contents 12. + +@end table + +In addition, bytevectors are also arrays, but use a different syntax +(@pxref{Bytevectors}): + +@table @code + +@item #vu8(1 2 3) +is a 3-byte long bytevector, with contents 1, 2, 3. + +@end table + +@node Array Procedures +@subsubsection Array Procedures + +When an array is created, the range of each dimension must be +specified, e.g., to create a 2@cross{}3 array with a zero-based index: + +@example +(make-array 'ho 2 3) @result{} #2((ho ho ho) (ho ho ho)) +@end example + +The range of each dimension can also be given explicitly, e.g., another +way to create the same array: + +@example +(make-array 'ho '(0 1) '(0 2)) @result{} #2((ho ho ho) (ho ho ho)) +@end example + +The following procedures can be used with arrays (or vectors). An +argument shown as @var{idx}@dots{} means one parameter for each +dimension in the array. A @var{idxlist} argument means a list of such +values, one for each dimension. + + +@deffn {Scheme Procedure} array? obj +@deffnx {C Function} scm_array_p (obj, unused) +Return @code{#t} if the @var{obj} is an array, and @code{#f} if +not. + +The second argument to scm_array_p is there for historical reasons, +but it is not used. You should always pass @code{SCM_UNDEFINED} as +its value. +@end deffn + +@deffn {Scheme Procedure} typed-array? obj type +@deffnx {C Function} scm_typed_array_p (obj, type) +Return @code{#t} if the @var{obj} is an array of type @var{type}, and +@code{#f} if not. +@end deffn + +@deftypefn {C Function} int scm_is_array (SCM obj) +Return @code{1} if the @var{obj} is an array and @code{0} if not. +@end deftypefn + +@deftypefn {C Function} int scm_is_typed_array (SCM obj, SCM type) +Return @code{0} if the @var{obj} is an array of type @var{type}, and +@code{1} if not. +@end deftypefn + +@deffn {Scheme Procedure} make-array fill bound @dots{} +@deffnx {C Function} scm_make_array (fill, bounds) +Equivalent to @code{(make-typed-array #t @var{fill} @var{bound} ...)}. +@end deffn + +@deffn {Scheme Procedure} make-typed-array type fill bound @dots{} +@deffnx {C Function} scm_make_typed_array (type, fill, bounds) +Create and return an array that has as many dimensions as there are +@var{bound}s and (maybe) fill it with @var{fill}. + +The underlying storage vector is created according to @var{type}, +which must be a symbol whose name is the `vectag' of the array as +explained above, or @code{#t} for ordinary, non-specialized arrays. + +For example, using the symbol @code{f64} for @var{type} will create an +array that uses a @code{f64vector} for storing its elements, and +@code{a} will use a string. + +When @var{fill} is not the special @emph{unspecified} value, the new +array is filled with @var{fill}. Otherwise, the initial contents of +the array is unspecified. The special @emph{unspecified} value is +stored in the variable @code{*unspecified*} so that for example +@code{(make-typed-array 'u32 *unspecified* 4)} creates a uninitialized +@code{u32} vector of length 4. + +Each @var{bound} may be a positive non-zero integer @var{n}, in which +case the index for that dimension can range from 0 through @var{n}-1; or +an explicit index range specifier in the form @code{(LOWER UPPER)}, +where both @var{lower} and @var{upper} are integers, possibly less than +zero, and possibly the same number (however, @var{lower} cannot be +greater than @var{upper}). +@end deffn + +@deffn {Scheme Procedure} list->array dimspec list +Equivalent to @code{(list->typed-array #t @var{dimspec} +@var{list})}. +@end deffn + +@deffn {Scheme Procedure} list->typed-array type dimspec list +@deffnx {C Function} scm_list_to_typed_array (type, dimspec, list) +Return an array of the type indicated by @var{type} with elements the +same as those of @var{list}. + +The argument @var{dimspec} determines the number of dimensions of the +array and their lower bounds. When @var{dimspec} is an exact integer, +it gives the number of dimensions directly and all lower bounds are +zero. When it is a list of exact integers, then each element is the +lower index bound of a dimension, and there will be as many dimensions +as elements in the list. +@end deffn + +@deffn {Scheme Procedure} array-type array +@deffnx {C Function} scm_array_type (array) +Return the type of @var{array}. This is the `vectag' used for +printing @var{array} (or @code{#t} for ordinary arrays) and can be +used with @code{make-typed-array} to create an array of the same kind +as @var{array}. +@end deffn + +@deffn {Scheme Procedure} array-ref array idx @dots{} +@deffnx {C Function} scm_array_ref (array, idxlist) +Return the element at @code{(idx @dots{})} in @var{array}. + +@example +(define a (make-array 999 '(1 2) '(3 4))) +(array-ref a 2 4) @result{} 999 +@end example +@end deffn + +@deffn {Scheme Procedure} array-in-bounds? array idx @dots{} +@deffnx {C Function} scm_array_in_bounds_p (array, idxlist) +Return @code{#t} if the given indices would be acceptable to +@code{array-ref}. + +@example +(define a (make-array #f '(1 2) '(3 4))) +(array-in-bounds? a 2 3) @result{} #t +(array-in-bounds? a 0 0) @result{} #f +@end example +@end deffn + +@deffn {Scheme Procedure} array-set! array obj idx @dots{} +@deffnx {C Function} scm_array_set_x (array, obj, idxlist) +Set the element at @code{(idx @dots{})} in @var{array} to @var{obj}. +The return value is unspecified. + +@example +(define a (make-array #f '(0 1) '(0 1))) +(array-set! a #t 1 1) +a @result{} #2((#f #f) (#f #t)) +@end example +@end deffn + +@deffn {Scheme Procedure} array-shape array +@deffnx {Scheme Procedure} array-dimensions array +@deffnx {C Function} scm_array_dimensions (array) +Return a list of the bounds for each dimension of @var{array}. + +@code{array-shape} gives @code{(@var{lower} @var{upper})} for each +dimension. @code{array-dimensions} instead returns just +@math{@var{upper}+1} for dimensions with a 0 lower bound. Both are +suitable as input to @code{make-array}. + +For example, + +@example +(define a (make-array 'foo '(-1 3) 5)) +(array-shape a) @result{} ((-1 3) (0 4)) +(array-dimensions a) @result{} ((-1 3) 5) +@end example +@end deffn + +@deffn {Scheme Procedure} array-length array +@deffnx {C Function} scm_array_length (array) +@deffnx {C Function} size_t scm_c_array_length (array) +Return the length of an array: its first dimension. It is an error to +ask for the length of an array of rank 0. +@end deffn + +@deffn {Scheme Procedure} array-rank array +@deffnx {C Function} scm_array_rank (array) +Return the rank of @var{array}. +@end deffn + +@deftypefn {C Function} size_t scm_c_array_rank (SCM array) +Return the rank of @var{array} as a @code{size_t}. +@end deftypefn + +@deffn {Scheme Procedure} array->list array +@deffnx {C Function} scm_array_to_list (array) +Return a list consisting of all the elements, in order, of +@var{array}. +@end deffn + +@c FIXME: Describe how the order affects the copying (it matters for +@c shared arrays with the same underlying root vector, presumably). +@c +@deffn {Scheme Procedure} array-copy! src dst +@deffnx {Scheme Procedure} array-copy-in-order! src dst +@deffnx {C Function} scm_array_copy_x (src, dst) +Copy every element from vector or array @var{src} to the corresponding +element of @var{dst}. @var{dst} must have the same rank as @var{src}, +and be at least as large in each dimension. The return value is +unspecified. +@end deffn + +@deffn {Scheme Procedure} array-fill! array fill +@deffnx {C Function} scm_array_fill_x (array, fill) +Store @var{fill} in every element of @var{array}. The value returned +is unspecified. +@end deffn + +@c begin (texi-doc-string "guile" "array-equal?") +@deffn {Scheme Procedure} array-equal? array @dots{} +Return @code{#t} if all arguments are arrays with the same shape, the +same type, and have corresponding elements which are either +@code{equal?} or @code{array-equal?}. This function differs from +@code{equal?} (@pxref{Equality}) in that all arguments must be arrays. +@end deffn + +@c FIXME: array-map! accepts no source arrays at all, and in that +@c case makes calls "(proc)". Is that meant to be a documented +@c feature? +@c +@c FIXME: array-for-each doesn't say what happens if the sources have +@c different index ranges. The code currently iterates over the +@c indices of the first and expects the others to cover those. That +@c at least vaguely matches array-map!, but is it meant to be a +@c documented feature? + +@deffn {Scheme Procedure} array-map! dst proc src @dots{} +@deffnx {Scheme Procedure} array-map-in-order! dst proc src1 @dots{} srcN +@deffnx {C Function} scm_array_map_x (dst, proc, srclist) +Set each element of the @var{dst} array to values obtained from calls +to @var{proc}. The value returned is unspecified. + +Each call is @code{(@var{proc} @var{elem1} @dots{} @var{elemN})}, +where each @var{elem} is from the corresponding @var{src} array, at +the @var{dst} index. @code{array-map-in-order!} makes the calls in +row-major order, @code{array-map!} makes them in an unspecified order. + +The @var{src} arrays must have the same number of dimensions as +@var{dst}, and must have a range for each dimension which covers the +range in @var{dst}. This ensures all @var{dst} indices are valid in +each @var{src}. +@end deffn + +@deffn {Scheme Procedure} array-for-each proc src1 src2 @dots{} +@deffnx {C Function} scm_array_for_each (proc, src1, srclist) +Apply @var{proc} to each tuple of elements of @var{src1} @var{src2} +@dots{}, in row-major order. The value returned is unspecified. +@end deffn + +@deffn {Scheme Procedure} array-index-map! dst proc +@deffnx {C Function} scm_array_index_map_x (dst, proc) +Set each element of the @var{dst} array to values returned by calls to +@var{proc}. The value returned is unspecified. + +Each call is @code{(@var{proc} @var{i1} @dots{} @var{iN})}, where +@var{i1}@dots{}@var{iN} is the destination index, one parameter for +each dimension. The order in which the calls are made is unspecified. + +For example, to create a @m{4\times4, 4x4} matrix representing a +cyclic group, + +@tex +\advance\leftskip by 2\lispnarrowing { +$\left(\matrix{% +0 & 1 & 2 & 3 \cr +1 & 2 & 3 & 0 \cr +2 & 3 & 0 & 1 \cr +3 & 0 & 1 & 2 \cr +}\right)$} \par +@end tex +@ifnottex +@example + / 0 1 2 3 \ + | 1 2 3 0 | + | 2 3 0 1 | + \ 3 0 1 2 / +@end example +@end ifnottex + +@example +(define a (make-array #f 4 4)) +(array-index-map! a (lambda (i j) + (modulo (+ i j) 4))) +@end example +@end deffn + +@deffn {Scheme Procedure} uniform-array-read! ra [port_or_fd [start [end]]] +@deffnx {C Function} scm_uniform_array_read_x (ra, port_or_fd, start, end) +Attempt to read all elements of array @var{ra}, in lexicographic order, as +binary objects from @var{port_or_fd}. +If an end of file is encountered, +the objects up to that point are put into @var{ra} +(starting at the beginning) and the remainder of the array is +unchanged. + +The optional arguments @var{start} and @var{end} allow +a specified region of a vector (or linearized array) to be read, +leaving the remainder of the vector unchanged. + +@code{uniform-array-read!} returns the number of objects read. +@var{port_or_fd} may be omitted, in which case it defaults to the value +returned by @code{(current-input-port)}. +@end deffn + +@deffn {Scheme Procedure} uniform-array-write ra [port_or_fd [start [end]]] +@deffnx {C Function} scm_uniform_array_write (ra, port_or_fd, start, end) +Writes all elements of @var{ra} as binary objects to +@var{port_or_fd}. + +The optional arguments @var{start} +and @var{end} allow +a specified region of a vector (or linearized array) to be written. + +The number of objects actually written is returned. +@var{port_or_fd} may be +omitted, in which case it defaults to the value returned by +@code{(current-output-port)}. +@end deffn + +@node Shared Arrays +@subsubsection Shared Arrays + +@deffn {Scheme Procedure} make-shared-array oldarray mapfunc bound @dots{} +@deffnx {C Function} scm_make_shared_array (oldarray, mapfunc, boundlist) +Return a new array which shares the storage of @var{oldarray}. +Changes made through either affect the same underlying storage. The +@var{bound} @dots{} arguments are the shape of the new array, the same +as @code{make-array} (@pxref{Array Procedures}). + +@var{mapfunc} translates coordinates from the new array to the +@var{oldarray}. It's called as @code{(@var{mapfunc} newidx1 @dots{})} +with one parameter for each dimension of the new array, and should +return a list of indices for @var{oldarray}, one for each dimension of +@var{oldarray}. + +@var{mapfunc} must be affine linear, meaning that each @var{oldarray} +index must be formed by adding integer multiples (possibly negative) +of some or all of @var{newidx1} etc, plus a possible integer offset. +The multiples and offset must be the same in each call. + +@sp 1 +One good use for a shared array is to restrict the range of some +dimensions, so as to apply say @code{array-for-each} or +@code{array-fill!} to only part of an array. The plain @code{list} +function can be used for @var{mapfunc} in this case, making no changes +to the index values. For example, + +@example +(make-shared-array #2((a b c) (d e f) (g h i)) list 3 2) +@result{} #2((a b) (d e) (g h)) +@end example + +The new array can have fewer dimensions than @var{oldarray}, for +example to take a column from an array. + +@example +(make-shared-array #2((a b c) (d e f) (g h i)) + (lambda (i) (list i 2)) + '(0 2)) +@result{} #1(c f i) +@end example + +A diagonal can be taken by using the single new array index for both +row and column in the old array. For example, + +@example +(make-shared-array #2((a b c) (d e f) (g h i)) + (lambda (i) (list i i)) + '(0 2)) +@result{} #1(a e i) +@end example + +Dimensions can be increased by for instance considering portions of a +one dimensional array as rows in a two dimensional array. +(@code{array-contents} below can do the opposite, flattening an +array.) + +@example +(make-shared-array #1(a b c d e f g h i j k l) + (lambda (i j) (list (+ (* i 3) j))) + 4 3) +@result{} #2((a b c) (d e f) (g h i) (j k l)) +@end example + +By negating an index the order that elements appear can be reversed. +The following just reverses the column order, + +@example +(make-shared-array #2((a b c) (d e f) (g h i)) + (lambda (i j) (list i (- 2 j))) + 3 3) +@result{} #2((c b a) (f e d) (i h g)) +@end example + +A fixed offset on indexes allows for instance a change from a 0 based +to a 1 based array, + +@example +(define x #2((a b c) (d e f) (g h i))) +(define y (make-shared-array x + (lambda (i j) (list (1- i) (1- j))) + '(1 3) '(1 3))) +(array-ref x 0 0) @result{} a +(array-ref y 1 1) @result{} a +@end example + +A multiple on an index allows every Nth element of an array to be +taken. The following is every third element, + +@example +(make-shared-array #1(a b c d e f g h i j k l) + (lambda (i) (list (* i 3))) + 4) +@result{} #1(a d g j) +@end example + +The above examples can be combined to make weird and wonderful +selections from an array, but it's important to note that because +@var{mapfunc} must be affine linear, arbitrary permutations are not +possible. + +In the current implementation, @var{mapfunc} is not called for every +access to the new array but only on some sample points to establish a +base and stride for new array indices in @var{oldarray} data. A few +sample points are enough because @var{mapfunc} is linear. +@end deffn + +@deffn {Scheme Procedure} shared-array-increments array +@deffnx {C Function} scm_shared_array_increments (array) +For each dimension, return the distance between elements in the root vector. +@end deffn + +@deffn {Scheme Procedure} shared-array-offset array +@deffnx {C Function} scm_shared_array_offset (array) +Return the root vector index of the first element in the array. +@end deffn + +@deffn {Scheme Procedure} shared-array-root array +@deffnx {C Function} scm_shared_array_root (array) +Return the root vector of a shared array. +@end deffn + +@deffn {Scheme Procedure} array-contents array [strict] +@deffnx {C Function} scm_array_contents (array, strict) +If @var{array} may be @dfn{unrolled} into a one dimensional shared array +without changing their order (last subscript changing fastest), then +@code{array-contents} returns that shared array, otherwise it returns +@code{#f}. All arrays made by @code{make-array} and +@code{make-typed-array} may be unrolled, some arrays made by +@code{make-shared-array} may not be. + +If the optional argument @var{strict} is provided, a shared array will +be returned only if its elements are stored internally contiguous in +memory. +@end deffn + +@deffn {Scheme Procedure} transpose-array array dim1 dim2 @dots{} +@deffnx {C Function} scm_transpose_array (array, dimlist) +Return an array sharing contents with @var{array}, but with +dimensions arranged in a different order. There must be one +@var{dim} argument for each dimension of @var{array}. +@var{dim1}, @var{dim2}, @dots{} should be integers between 0 +and the rank of the array to be returned. Each integer in that +range must appear at least once in the argument list. + +The values of @var{dim1}, @var{dim2}, @dots{} correspond to +dimensions in the array to be returned, and their positions in the +argument list to dimensions of @var{array}. Several @var{dim}s +may have the same value, in which case the returned array will +have smaller rank than @var{array}. + +@lisp +(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d)) +(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d) +(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{} + #2((a 4) (b 5) (c 6)) +@end lisp +@end deffn + +@node Accessing Arrays from C +@subsubsection Accessing Arrays from C + +For interworking with external C code, Guile provides an API to allow C +code to access the elements of a Scheme array. In particular, for +uniform numeric arrays, the API exposes the underlying uniform data as a +C array of numbers of the relevant type. + +While pointers to the elements of an array are in use, the array itself +must be protected so that the pointer remains valid. Such a protected +array is said to be @dfn{reserved}. A reserved array can be read but +modifications to it that would cause the pointer to its elements to +become invalid are prevented. When you attempt such a modification, an +error is signalled. + +(This is similar to locking the array while it is in use, but without +the danger of a deadlock. In a multi-threaded program, you will need +additional synchronization to avoid modifying reserved arrays.) + +You must take care to always unreserve an array after reserving it, +even in the presence of non-local exits. If a non-local exit can +happen between these two calls, you should install a dynwind context +that releases the array when it is left (@pxref{Dynamic Wind}). + +In addition, array reserving and unreserving must be properly +paired. For instance, when reserving two or more arrays in a certain +order, you need to unreserve them in the opposite order. + +Once you have reserved an array and have retrieved the pointer to its +elements, you must figure out the layout of the elements in memory. +Guile allows slices to be taken out of arrays without actually making a +copy, such as making an alias for the diagonal of a matrix that can be +treated as a vector. Arrays that result from such an operation are not +stored contiguously in memory and when working with their elements +directly, you need to take this into account. + +The layout of array elements in memory can be defined via a +@emph{mapping function} that computes a scalar position from a vector of +indices. The scalar position then is the offset of the element with the +given indices from the start of the storage block of the array. + +In Guile, this mapping function is restricted to be @dfn{affine}: all +mapping functions of Guile arrays can be written as @code{p = b + +c[0]*i[0] + c[1]*i[1] + ... + c[n-1]*i[n-1]} where @code{i[k]} is the +@nicode{k}th index and @code{n} is the rank of the array. For +example, a matrix of size 3x3 would have @code{b == 0}, @code{c[0] == +3} and @code{c[1] == 1}. When you transpose this matrix (with +@code{transpose-array}, say), you will get an array whose mapping +function has @code{b == 0}, @code{c[0] == 1} and @code{c[1] == 3}. + +The function @code{scm_array_handle_dims} gives you (indirect) access to +the coefficients @code{c[k]}. + +@c XXX +Note that there are no functions for accessing the elements of a +character array yet. Once the string implementation of Guile has been +changed to use Unicode, we will provide them. + +@deftp {C Type} scm_t_array_handle +This is a structure type that holds all information necessary to manage +the reservation of arrays as explained above. Structures of this type +must be allocated on the stack and must only be accessed by the +functions listed below. +@end deftp + +@deftypefn {C Function} void scm_array_get_handle (SCM array, scm_t_array_handle *handle) +Reserve @var{array}, which must be an array, and prepare @var{handle} to +be used with the functions below. You must eventually call +@code{scm_array_handle_release} on @var{handle}, and do this in a +properly nested fashion, as explained above. The structure pointed to +by @var{handle} does not need to be initialized before calling this +function. +@end deftypefn + +@deftypefn {C Function} void scm_array_handle_release (scm_t_array_handle *handle) +End the array reservation represented by @var{handle}. After a call to +this function, @var{handle} might be used for another reservation. +@end deftypefn + +@deftypefn {C Function} size_t scm_array_handle_rank (scm_t_array_handle *handle) +Return the rank of the array represented by @var{handle}. +@end deftypefn + +@deftp {C Type} scm_t_array_dim +This structure type holds information about the layout of one dimension +of an array. It includes the following fields: + +@table @code +@item ssize_t lbnd +@itemx ssize_t ubnd +The lower and upper bounds (both inclusive) of the permissible index +range for the given dimension. Both values can be negative, but +@var{lbnd} is always less than or equal to @var{ubnd}. + +@item ssize_t inc +The distance from one element of this dimension to the next. Note, too, +that this can be negative. +@end table +@end deftp + +@deftypefn {C Function} {const scm_t_array_dim *} scm_array_handle_dims (scm_t_array_handle *handle) +Return a pointer to a C vector of information about the dimensions of +the array represented by @var{handle}. This pointer is valid as long as +the array remains reserved. As explained above, the +@code{scm_t_array_dim} structures returned by this function can be used +calculate the position of an element in the storage block of the array +from its indices. + +This position can then be used as an index into the C array pointer +returned by the various @code{scm_array_handle__elements} +functions, or with @code{scm_array_handle_ref} and +@code{scm_array_handle_set}. + +Here is how one can compute the position @var{pos} of an element given +its indices in the vector @var{indices}: + +@example +ssize_t indices[RANK]; +scm_t_array_dim *dims; +ssize_t pos; +size_t i; + +pos = 0; +for (i = 0; i < RANK; i++) + @{ + if (indices[i] < dims[i].lbnd || indices[i] > dims[i].ubnd) + out_of_range (); + pos += (indices[i] - dims[i].lbnd) * dims[i].inc; + @} +@end example +@end deftypefn + +@deftypefn {C Function} ssize_t scm_array_handle_pos (scm_t_array_handle *handle, SCM indices) +Compute the position corresponding to @var{indices}, a list of +indices. The position is computed as described above for +@code{scm_array_handle_dims}. The number of the indices and their +range is checked and an appropriate error is signalled for invalid +indices. +@end deftypefn + +@deftypefn {C Function} SCM scm_array_handle_ref (scm_t_array_handle *handle, ssize_t pos) +Return the element at position @var{pos} in the storage block of the +array represented by @var{handle}. Any kind of array is acceptable. No +range checking is done on @var{pos}. +@end deftypefn + +@deftypefn {C Function} void scm_array_handle_set (scm_t_array_handle *handle, ssize_t pos, SCM val) +Set the element at position @var{pos} in the storage block of the array +represented by @var{handle} to @var{val}. Any kind of array is +acceptable. No range checking is done on @var{pos}. An error is +signalled when the array can not store @var{val}. +@end deftypefn + +@deftypefn {C Function} {const SCM *} scm_array_handle_elements (scm_t_array_handle *handle) +Return a pointer to the elements of a ordinary array of general Scheme +values (i.e., a non-uniform array) for reading. This pointer is valid +as long as the array remains reserved. +@end deftypefn + +@deftypefn {C Function} {SCM *} scm_array_handle_writable_elements (scm_t_array_handle *handle) +Like @code{scm_array_handle_elements}, but the pointer is good for +reading and writing. +@end deftypefn + +@deftypefn {C Function} {const void *} scm_array_handle_uniform_elements (scm_t_array_handle *handle) +Return a pointer to the elements of a uniform numeric array for reading. +This pointer is valid as long as the array remains reserved. The size +of each element is given by @code{scm_array_handle_uniform_element_size}. +@end deftypefn + +@deftypefn {C Function} {void *} scm_array_handle_uniform_writable_elements (scm_t_array_handle *handle) +Like @code{scm_array_handle_uniform_elements}, but the pointer is good +reading and writing. +@end deftypefn + +@deftypefn {C Function} size_t scm_array_handle_uniform_element_size (scm_t_array_handle *handle) +Return the size of one element of the uniform numeric array represented +by @var{handle}. +@end deftypefn + +@deftypefn {C Function} {const scm_t_uint8 *} scm_array_handle_u8_elements (scm_t_array_handle *handle) +@deftypefnx {C Function} {const scm_t_int8 *} scm_array_handle_s8_elements (scm_t_array_handle *handle) +@deftypefnx {C Function} {const scm_t_uint16 *} scm_array_handle_u16_elements (scm_t_array_handle *handle) +@deftypefnx {C Function} {const scm_t_int16 *} scm_array_handle_s16_elements (scm_t_array_handle *handle) +@deftypefnx {C Function} {const scm_t_uint32 *} scm_array_handle_u32_elements (scm_t_array_handle *handle) +@deftypefnx {C Function} {const scm_t_int32 *} scm_array_handle_s32_elements (scm_t_array_handle *handle) +@deftypefnx {C Function} {const scm_t_uint64 *} scm_array_handle_u64_elements (scm_t_array_handle *handle) +@deftypefnx {C Function} {const scm_t_int64 *} scm_array_handle_s64_elements (scm_t_array_handle *handle) +@deftypefnx {C Function} {const float *} scm_array_handle_f32_elements (scm_t_array_handle *handle) +@deftypefnx {C Function} {const double *} scm_array_handle_f64_elements (scm_t_array_handle *handle) +@deftypefnx {C Function} {const float *} scm_array_handle_c32_elements (scm_t_array_handle *handle) +@deftypefnx {C Function} {const double *} scm_array_handle_c64_elements (scm_t_array_handle *handle) +Return a pointer to the elements of a uniform numeric array of the +indicated kind for reading. This pointer is valid as long as the array +remains reserved. + +The pointers for @code{c32} and @code{c64} uniform numeric arrays point +to pairs of floating point numbers. The even index holds the real part, +the odd index the imaginary part of the complex number. +@end deftypefn + +@deftypefn {C Function} {scm_t_uint8 *} scm_array_handle_u8_writable_elements (scm_t_array_handle *handle) +@deftypefnx {C Function} {scm_t_int8 *} scm_array_handle_s8_writable_elements (scm_t_array_handle *handle) +@deftypefnx {C Function} {scm_t_uint16 *} scm_array_handle_u16_writable_elements (scm_t_array_handle *handle) +@deftypefnx {C Function} {scm_t_int16 *} scm_array_handle_s16_writable_elements (scm_t_array_handle *handle) +@deftypefnx {C Function} {scm_t_uint32 *} scm_array_handle_u32_writable_elements (scm_t_array_handle *handle) +@deftypefnx {C Function} {scm_t_int32 *} scm_array_handle_s32_writable_elements (scm_t_array_handle *handle) +@deftypefnx {C Function} {scm_t_uint64 *} scm_array_handle_u64_writable_elements (scm_t_array_handle *handle) +@deftypefnx {C Function} {scm_t_int64 *} scm_array_handle_s64_writable_elements (scm_t_array_handle *handle) +@deftypefnx {C Function} {float *} scm_array_handle_f32_writable_elements (scm_t_array_handle *handle) +@deftypefnx {C Function} {double *} scm_array_handle_f64_writable_elements (scm_t_array_handle *handle) +@deftypefnx {C Function} {float *} scm_array_handle_c32_writable_elements (scm_t_array_handle *handle) +@deftypefnx {C Function} {double *} scm_array_handle_c64_writable_elements (scm_t_array_handle *handle) +Like @code{scm_array_handle__elements}, but the pointer is good +for reading and writing. +@end deftypefn + +@deftypefn {C Function} {const scm_t_uint32 *} scm_array_handle_bit_elements (scm_t_array_handle *handle) +Return a pointer to the words that store the bits of the represented +array, which must be a bit array. + +Unlike other arrays, bit arrays have an additional offset that must be +figured into index calculations. That offset is returned by +@code{scm_array_handle_bit_elements_offset}. + +To find a certain bit you first need to calculate its position as +explained above for @code{scm_array_handle_dims} and then add the +offset. This gives the absolute position of the bit, which is always a +non-negative integer. + +Each word of the bit array storage block contains exactly 32 bits, with +the least significant bit in that word having the lowest absolute +position number. The next word contains the next 32 bits. + +Thus, the following code can be used to access a bit whose position +according to @code{scm_array_handle_dims} is given in @var{pos}: + +@example +SCM bit_array; +scm_t_array_handle handle; +scm_t_uint32 *bits; +ssize_t pos; +size_t abs_pos; +size_t word_pos, mask; + +scm_array_get_handle (&bit_array, &handle); +bits = scm_array_handle_bit_elements (&handle); + +pos = ... +abs_pos = pos + scm_array_handle_bit_elements_offset (&handle); +word_pos = abs_pos / 32; +mask = 1L << (abs_pos % 32); + +if (bits[word_pos] & mask) + /* bit is set. */ + +scm_array_handle_release (&handle); +@end example + +@end deftypefn + +@deftypefn {C Function} {scm_t_uint32 *} scm_array_handle_bit_writable_elements (scm_t_array_handle *handle) +Like @code{scm_array_handle_bit_elements} but the pointer is good for +reading and writing. You must take care not to modify bits outside of +the allowed index range of the array, even for contiguous arrays. +@end deftypefn + +@node VLists +@subsection VLists + +@cindex vlist + +The @code{(ice-9 vlist)} module provides an implementation of the @dfn{VList} +data structure designed by Phil Bagwell in 2002. VLists are immutable lists, +which can contain any Scheme object. They improve on standard Scheme linked +lists in several areas: + +@itemize +@item +Random access has typically constant-time complexity. + +@item +Computing the length of a VList has time complexity logarithmic in the number of +elements. + +@item +VLists use less storage space than standard lists. + +@item +VList elements are stored in contiguous regions, which improves memory locality +and leads to more efficient use of hardware caches. +@end itemize + +The idea behind VLists is to store vlist elements in increasingly large +contiguous blocks (implemented as vectors here). These blocks are linked to one +another using a pointer to the next block and an offset within that block. The +size of these blocks form a geometric series with ratio +@code{block-growth-factor} (2 by default). + +The VList structure also serves as the basis for the @dfn{VList-based hash +lists} or ``vhashes'', an immutable dictionary type (@pxref{VHashes}). + +However, the current implementation in @code{(ice-9 vlist)} has several +noteworthy shortcomings: + +@itemize + +@item +It is @emph{not} thread-safe. Although operations on vlists are all +@dfn{referentially transparent} (i.e., purely functional), adding elements to a +vlist with @code{vlist-cons} mutates part of its internal structure, which makes +it non-thread-safe. This could be fixed, but it would slow down +@code{vlist-cons}. + +@item +@code{vlist-cons} always allocates at least as much memory as @code{cons}. +Again, Phil Bagwell describes how to fix it, but that would require tuning the +garbage collector in a way that may not be generally beneficial. + +@item +@code{vlist-cons} is a Scheme procedure compiled to bytecode, and it does not +compete with the straightforward C implementation of @code{cons}, and with the +fact that the VM has a special @code{cons} instruction. + +@end itemize + +We hope to address these in the future. + +The programming interface exported by @code{(ice-9 vlist)} is defined below. +Most of it is the same as SRFI-1 with an added @code{vlist-} prefix to function +names. + +@deffn {Scheme Procedure} vlist? obj +Return true if @var{obj} is a VList. +@end deffn + +@defvr {Scheme Variable} vlist-null +The empty VList. Note that it's possible to create an empty VList not +@code{eq?} to @code{vlist-null}; thus, callers should always use +@code{vlist-null?} when testing whether a VList is empty. +@end defvr + +@deffn {Scheme Procedure} vlist-null? vlist +Return true if @var{vlist} is empty. +@end deffn + +@deffn {Scheme Procedure} vlist-cons item vlist +Return a new vlist with @var{item} as its head and @var{vlist} as its tail. +@end deffn + +@deffn {Scheme Procedure} vlist-head vlist +Return the head of @var{vlist}. +@end deffn + +@deffn {Scheme Procedure} vlist-tail vlist +Return the tail of @var{vlist}. +@end deffn + +@defvr {Scheme Variable} block-growth-factor +A fluid that defines the growth factor of VList blocks, 2 by default. +@end defvr + +The functions below provide the usual set of higher-level list operations. + +@deffn {Scheme Procedure} vlist-fold proc init vlist +@deffnx {Scheme Procedure} vlist-fold-right proc init vlist +Fold over @var{vlist}, calling @var{proc} for each element, as for SRFI-1 +@code{fold} and @code{fold-right} (@pxref{SRFI-1, @code{fold}}). +@end deffn + +@deffn {Scheme Procedure} vlist-ref vlist index +Return the element at index @var{index} in @var{vlist}. This is typically a +constant-time operation. +@end deffn + +@deffn {Scheme Procedure} vlist-length vlist +Return the length of @var{vlist}. This is typically logarithmic in the number +of elements in @var{vlist}. +@end deffn + +@deffn {Scheme Procedure} vlist-reverse vlist +Return a new @var{vlist} whose content are those of @var{vlist} in reverse +order. +@end deffn + +@deffn {Scheme Procedure} vlist-map proc vlist +Map @var{proc} over the elements of @var{vlist} and return a new vlist. +@end deffn + +@deffn {Scheme Procedure} vlist-for-each proc vlist +Call @var{proc} on each element of @var{vlist}. The result is unspecified. +@end deffn + +@deffn {Scheme Procedure} vlist-drop vlist count +Return a new vlist that does not contain the @var{count} first elements of +@var{vlist}. This is typically a constant-time operation. +@end deffn + +@deffn {Scheme Procedure} vlist-take vlist count +Return a new vlist that contains only the @var{count} first elements of +@var{vlist}. +@end deffn + +@deffn {Scheme Procedure} vlist-filter pred vlist +Return a new vlist containing all the elements from @var{vlist} that satisfy +@var{pred}. +@end deffn + +@deffn {Scheme Procedure} vlist-delete x vlist [equal?] +Return a new vlist corresponding to @var{vlist} without the elements +@var{equal?} to @var{x}. +@end deffn + +@deffn {Scheme Procedure} vlist-unfold p f g seed [tail-gen] +@deffnx {Scheme Procedure} vlist-unfold-right p f g seed [tail] +Return a new vlist, as for SRFI-1 @code{unfold} and @code{unfold-right} +(@pxref{SRFI-1, @code{unfold}}). +@end deffn + +@deffn {Scheme Procedure} vlist-append vlist @dots{} +Append the given vlists and return the resulting vlist. +@end deffn + +@deffn {Scheme Procedure} list->vlist lst +Return a new vlist whose contents correspond to @var{lst}. +@end deffn + +@deffn {Scheme Procedure} vlist->list vlist +Return a new list whose contents match those of @var{vlist}. +@end deffn + +@node Record Overview +@subsection Record Overview + +@cindex record +@cindex structure + +@dfn{Records}, also called @dfn{structures}, are Scheme's primary +mechanism to define new disjoint types. A @dfn{record type} defines a +list of @dfn{fields} that instances of the type consist of. This is like +C's @code{struct}. + +Historically, Guile has offered several different ways to define record +types and to create records, offering different features, and making +different trade-offs. Over the years, each ``standard'' has also come +with its own new record interface, leading to a maze of record APIs. + +At the highest level is SRFI-9, a high-level record interface +implemented by most Scheme implementations (@pxref{SRFI-9 Records}). It +defines a simple and efficient syntactic abstraction of record types and +their associated type predicate, fields, and field accessors. SRFI-9 is +suitable for most uses, and this is the recommended way to create record +types in Guile. Similar high-level record APIs include SRFI-35 +(@pxref{SRFI-35}) and R6RS records (@pxref{rnrs records syntactic}). + +Then comes Guile's historical ``records'' API (@pxref{Records}). Record +types defined this way are first-class objects. Introspection +facilities are available, allowing users to query the list of fields or +the value of a specific field at run-time, without prior knowledge of +the type. + +Finally, the common denominator of these interfaces is Guile's +@dfn{structure} API (@pxref{Structures}). Guile's structures are the +low-level building block for all other record APIs. Application writers +will normally not need to use it. + +Records created with these APIs may all be pattern-matched using Guile's +standard pattern matcher (@pxref{Pattern Matching}). + + +@node SRFI-9 Records +@subsection SRFI-9 Records + +@cindex SRFI-9 +@cindex record + +SRFI-9 standardizes a syntax for defining new record types and creating +predicate, constructor, and field getter and setter functions. In Guile +this is the recommended option to create new record types (@pxref{Record +Overview}). It can be used with: + +@example +(use-modules (srfi srfi-9)) +@end example + +@deffn {Scheme Syntax} define-record-type type @* (constructor fieldname @dots{}) @* predicate @* (fieldname accessor [modifier]) @dots{} +@sp 1 +Create a new record type, and make various @code{define}s for using +it. This syntax can only occur at the top-level, not nested within +some other form. + +@var{type} is bound to the record type, which is as per the return +from the core @code{make-record-type}. @var{type} also provides the +name for the record, as per @code{record-type-name}. + +@var{constructor} is bound to a function to be called as +@code{(@var{constructor} fieldval @dots{})} to create a new record of +this type. The arguments are initial values for the fields, one +argument for each field, in the order they appear in the +@code{define-record-type} form. + +The @var{fieldname}s provide the names for the record fields, as per +the core @code{record-type-fields} etc, and are referred to in the +subsequent accessor/modifier forms. + +@var{predicate} is bound to a function to be called as +@code{(@var{predicate} obj)}. It returns @code{#t} or @code{#f} +according to whether @var{obj} is a record of this type. + +Each @var{accessor} is bound to a function to be called +@code{(@var{accessor} record)} to retrieve the respective field from a +@var{record}. Similarly each @var{modifier} is bound to a function to +be called @code{(@var{modifier} record val)} to set the respective +field in a @var{record}. +@end deffn + +@noindent +An example will illustrate typical usage, + +@example +(define-record-type + (make-employee name age salary) + employee? + (name employee-name) + (age employee-age set-employee-age!) + (salary employee-salary set-employee-salary!)) +@end example + +This creates a new employee data type, with name, age and salary +fields. Accessor functions are created for each field, but no +modifier function for the name (the intention in this example being +that it's established only when an employee object is created). These +can all then be used as for example, + +@example + @result{} #> + +(define fred (make-employee "Fred" 45 20000.00)) + +(employee? fred) @result{} #t +(employee-age fred) @result{} 45 +(set-employee-salary! fred 25000.00) ;; pay rise +@end example + +The functions created by @code{define-record-type} are ordinary +top-level @code{define}s. They can be redefined or @code{set!} as +desired, exported from a module, etc. + +@unnumberedsubsubsec Non-toplevel Record Definitions + +The SRFI-9 specification explicitly disallows record definitions in a +non-toplevel context, such as inside @code{lambda} body or inside a +@var{let} block. However, Guile's implementation does not enforce that +restriction. + +@unnumberedsubsubsec Custom Printers + +You may use @code{set-record-type-printer!} to customize the default printing +behavior of records. This is a Guile extension and is not part of SRFI-9. It +is located in the @nicode{(srfi srfi-9 gnu)} module. + +@deffn {Scheme Syntax} set-record-type-printer! type proc +Where @var{type} corresponds to the first argument of @code{define-record-type}, +and @var{proc} is a procedure accepting two arguments, the record to print, and +an output port. +@end deffn + +@noindent +This example prints the employee's name in brackets, for instance @code{[Fred]}. + +@example +(set-record-type-printer! + (lambda (record port) + (write-char #\[ port) + (display (employee-name record) port) + (write-char #\] port))) +@end example + +@unnumberedsubsubsec Functional ``Setters'' + +@cindex functional setters + +When writing code in a functional style, it is desirable to never alter +the contents of records. For such code, a simple way to return new +record instances based on existing ones is highly desirable. + +The @code{(srfi srfi-9 gnu)} module extends SRFI-9 with facilities to +return new record instances based on existing ones, only with one or +more field values changed---@dfn{functional setters}. First, the +@code{define-immutable-record-type} works like +@code{define-record-type}, except that fields are immutable and setters +are defined as functional setters. + +@deffn {Scheme Syntax} define-immutable-record-type type @* (constructor fieldname @dots{}) @* predicate @* (fieldname accessor [modifier]) @dots{} +Define @var{type} as a new record type, like @code{define-record-type}. +However, the record type is made @emph{immutable} (records may not be +mutated, even with @code{struct-set!}), and any @var{modifier} is +defined to be a functional setter---a procedure that returns a new +record instance with the specified field changed, and leaves the +original unchanged (see example below.) +@end deffn + +@noindent +In addition, the generic @code{set-field} and @code{set-fields} macros +may be applied to any SRFI-9 record. + +@deffn {Scheme Syntax} set-field record (field sub-fields ...) value +Return a new record of @var{record}'s type whose fields are equal to +the corresponding fields of @var{record} except for the one specified by +@var{field}. + +@var{field} must be the name of the getter corresponding to the field of +@var{record} being ``set''. Subsequent @var{sub-fields} must be record +getters designating sub-fields within that field value to be set (see +example below.) +@end deffn + +@deffn {Scheme Syntax} set-fields record ((field sub-fields ...) value) ... +Like @code{set-field}, but can be used to set more than one field at a +time. This expands to code that is more efficient than a series of +single @code{set-field} calls. +@end deffn + +To illustrate the use of functional setters, let's assume these two +record type definitions: + +@example +(define-record-type
+ (address street city country) + address? + (street address-street) + (city address-city) + (country address-country)) + +(define-immutable-record-type + (person age email address) + person? + (age person-age set-person-age) + (email person-email set-person-email) + (address person-address set-person-address)) +@end example + +@noindent +First, note that the @code{} record type definition introduces +named functional setters. These may be used like this: + +@example +(define fsf-address + (address "Franklin Street" "Boston" "USA")) + +(define rms + (person 30 "rms@@gnu.org" fsf-address)) + +(and (equal? (set-person-age rms 60) + (person 60 "rms@@gnu.org" fsf-address)) + (= (person-age rms) 30)) +@result{} #t +@end example + +@noindent +Here, the original @code{} record, to which @var{rms} is bound, +is left unchanged. + +Now, suppose we want to change both the street and age of @var{rms}. +This can be achieved using @code{set-fields}: + +@example +(set-fields rms + ((person-age) 60) + ((person-address address-street) "Temple Place")) +@result{} #< age: 60 email: "rms@@gnu.org" + address: #<
street: "Temple Place" city: "Boston" country: "USA">> +@end example + +@noindent +Notice how the above changed two fields of @var{rms}, including the +@code{street} field of its @code{address} field, in a concise way. Also +note that @code{set-fields} works equally well for types defined with +just @code{define-record-type}. + +@node Records +@subsection Records + +A @dfn{record type} is a first class object representing a user-defined +data type. A @dfn{record} is an instance of a record type. + +Note that in many ways, this interface is too low-level for every-day +use. Most uses of records are better served by SRFI-9 records. +@xref{SRFI-9 Records}. + +@deffn {Scheme Procedure} record? obj +Return @code{#t} if @var{obj} is a record of any type and @code{#f} +otherwise. + +Note that @code{record?} may be true of any Scheme value; there is no +promise that records are disjoint with other Scheme types. +@end deffn + +@deffn {Scheme Procedure} make-record-type type-name field-names [print] +Create and return a new @dfn{record-type descriptor}. + +@var{type-name} is a string naming the type. Currently it's only used +in the printed representation of records, and in diagnostics. +@var{field-names} is a list of symbols naming the fields of a record +of the type. Duplicates are not allowed among these symbols. + +@example +(make-record-type "employee" '(name age salary)) +@end example + +The optional @var{print} argument is a function used by +@code{display}, @code{write}, etc, for printing a record of the new +type. It's called as @code{(@var{print} record port)} and should look +at @var{record} and write to @var{port}. +@end deffn + +@deffn {Scheme Procedure} record-constructor rtd [field-names] +Return a procedure for constructing new members of the type represented +by @var{rtd}. The returned procedure accepts exactly as many arguments +as there are symbols in the given list, @var{field-names}; these are +used, in order, as the initial values of those fields in a new record, +which is returned by the constructor procedure. The values of any +fields not named in that list are unspecified. The @var{field-names} +argument defaults to the list of field names in the call to +@code{make-record-type} that created the type represented by @var{rtd}; +if the @var{field-names} argument is provided, it is an error if it +contains any duplicates or any symbols not in the default list. +@end deffn + +@deffn {Scheme Procedure} record-predicate rtd +Return a procedure for testing membership in the type represented by +@var{rtd}. The returned procedure accepts exactly one argument and +returns a true value if the argument is a member of the indicated record +type; it returns a false value otherwise. +@end deffn + +@deffn {Scheme Procedure} record-accessor rtd field-name +Return a procedure for reading the value of a particular field of a +member of the type represented by @var{rtd}. The returned procedure +accepts exactly one argument which must be a record of the appropriate +type; it returns the current value of the field named by the symbol +@var{field-name} in that record. The symbol @var{field-name} must be a +member of the list of field-names in the call to @code{make-record-type} +that created the type represented by @var{rtd}. +@end deffn + +@deffn {Scheme Procedure} record-modifier rtd field-name +Return a procedure for writing the value of a particular field of a +member of the type represented by @var{rtd}. The returned procedure +accepts exactly two arguments: first, a record of the appropriate type, +and second, an arbitrary Scheme value; it modifies the field named by +the symbol @var{field-name} in that record to contain the given value. +The returned value of the modifier procedure is unspecified. The symbol +@var{field-name} must be a member of the list of field-names in the call +to @code{make-record-type} that created the type represented by +@var{rtd}. +@end deffn + +@deffn {Scheme Procedure} record-type-descriptor record +Return a record-type descriptor representing the type of the given +record. That is, for example, if the returned descriptor were passed to +@code{record-predicate}, the resulting predicate would return a true +value when passed the given record. Note that it is not necessarily the +case that the returned descriptor is the one that was passed to +@code{record-constructor} in the call that created the constructor +procedure that created the given record. +@end deffn + +@deffn {Scheme Procedure} record-type-name rtd +Return the type-name associated with the type represented by rtd. The +returned value is @code{eqv?} to the @var{type-name} argument given in +the call to @code{make-record-type} that created the type represented by +@var{rtd}. +@end deffn + +@deffn {Scheme Procedure} record-type-fields rtd +Return a list of the symbols naming the fields in members of the type +represented by @var{rtd}. The returned value is @code{equal?} to the +field-names argument given in the call to @code{make-record-type} that +created the type represented by @var{rtd}. +@end deffn + + +@node Structures +@subsection Structures +@tpindex Structures + +A @dfn{structure} is a first class data type which holds Scheme values +or C words in fields numbered 0 upwards. A @dfn{vtable} is a structure +that represents a structure type, giving field types and permissions, +and an optional print function for @code{write} etc. + +Structures are lower level than records (@pxref{Records}). Usually, +when you need to represent structured data, you just want to use +records. But sometimes you need to implement new kinds of structured +data abstractions, and for that purpose structures are useful. Indeed, +records in Guile are implemented with structures. + +@menu +* Vtables:: +* Structure Basics:: +* Vtable Contents:: +* Meta-Vtables:: +* Vtable Example:: +* Tail Arrays:: +@end menu + +@node Vtables +@subsubsection Vtables + +A vtable is a structure type, specifying its layout, and other +information. A vtable is actually itself a structure, but there's no +need to worry about that initially (@pxref{Vtable Contents}.) + +@deffn {Scheme Procedure} make-vtable fields [print] +Create a new vtable. + +@var{fields} is a string describing the fields in the structures to be +created. Each field is represented by two characters, a type letter +and a permissions letter, for example @code{"pw"}. The types are as +follows. + +@itemize @bullet{} +@item +@code{p} -- a Scheme value. ``p'' stands for ``protected'' meaning +it's protected against garbage collection. + +@item +@code{u} -- an arbitrary word of data (an @code{scm_t_bits}). At the +Scheme level it's read and written as an unsigned integer. ``u'' +stands for ``uninterpreted'' (it's not treated as a Scheme value), or +``unprotected'' (it's not marked during GC), or ``unsigned long'' (its +size), or all of these things. + +@item +@code{s} -- a self-reference. Such a field holds the @code{SCM} value +of the structure itself (a circular reference). This can be useful in +C code where you might have a pointer to the data array, and want to +get the Scheme @code{SCM} handle for the structure. In Scheme code it +has no use. +@end itemize + +The second letter for each field is a permission code, + +@itemize @bullet{} +@item +@code{w} -- writable, the field can be read and written. +@item +@code{r} -- read-only, the field can be read but not written. +@item +@code{o} -- opaque, the field can be neither read nor written at the +Scheme level. This can be used for fields which should only be used +from C code. +@end itemize + +Here are some examples. @xref{Tail Arrays}, for information on the +legacy tail array facility. + +@example +(make-vtable "pw") ;; one writable field +(make-vtable "prpw") ;; one read-only and one writable +(make-vtable "pwuwuw") ;; one scheme and two uninterpreted +@end example + +The optional @var{print} argument is a function called by +@code{display} and @code{write} (etc) to give a printed representation +of a structure created from this vtable. It's called +@code{(@var{print} struct port)} and should look at @var{struct} and +write to @var{port}. The default print merely gives a form like +@samp{#} with a pair of machine addresses. + +The following print function for example shows the two fields of its +structure. + +@example +(make-vtable "prpw" + (lambda (struct port) + (format port "#<~a and ~a>" + (struct-ref struct 0) + (struct-ref struct 1)))) +@end example +@end deffn + + +@node Structure Basics +@subsubsection Structure Basics + +This section describes the basic procedures for working with +structures. @code{make-struct} creates a structure, and +@code{struct-ref} and @code{struct-set!} access its fields. + +@deffn {Scheme Procedure} make-struct vtable tail-size init @dots{} +@deffnx {Scheme Procedure} make-struct/no-tail vtable init @dots{} +Create a new structure, with layout per the given @var{vtable} +(@pxref{Vtables}). + +The optional @var{init}@dots{} arguments are initial values for the +fields of the structure. This is the only way to +put values in read-only fields. If there are fewer @var{init} +arguments than fields then the defaults are @code{#f} for a Scheme +field (type @code{p}) or 0 for an uninterpreted field (type @code{u}). + +Structures also have the ability to allocate a variable number of +additional cells at the end, at their tails. However, this legacy +@dfn{tail array} facilty is confusing and inefficient, and so we do not +recommend it. @xref{Tail Arrays}, for more on the legacy tail array +interface. + +Type @code{s} self-reference fields, permission @code{o} opaque +fields, and the count field of a tail array are all ignored for the +@var{init} arguments, ie.@: an argument is not consumed by such a +field. An @code{s} is always set to the structure itself, an @code{o} +is always set to @code{#f} or 0 (with the intention that C code will +do something to it later), and the tail count is always the given +@var{tail-size}. + +For example, + +@example +(define v (make-vtable "prpwpw")) +(define s (make-struct v 0 123 "abc" 456)) +(struct-ref s 0) @result{} 123 +(struct-ref s 1) @result{} "abc" +@end example +@end deffn + +@deftypefn {C Function} SCM scm_make_struct (SCM vtable, SCM tail_size, SCM init_list) +@deftypefnx {C Function} SCM scm_c_make_struct (SCM vtable, SCM tail_size, SCM init, ...) +@deftypefnx {C Function} SCM scm_c_make_structv (SCM vtable, SCM tail_size, size_t n_inits, scm_t_bits init[]) +There are a few ways to make structures from C. @code{scm_make_struct} +takes a list, @code{scm_c_make_struct} takes variable arguments +terminated with SCM_UNDEFINED, and @code{scm_c_make_structv} takes a +packed array. +@end deftypefn + +@deffn {Scheme Procedure} struct? obj +@deffnx {C Function} scm_struct_p (obj) +Return @code{#t} if @var{obj} is a structure, or @code{#f} if not. +@end deffn + +@deffn {Scheme Procedure} struct-ref struct n +@deffnx {C Function} scm_struct_ref (struct, n) +Return the contents of field number @var{n} in @var{struct}. The +first field is number 0. + +An error is thrown if @var{n} is out of range, or if the field cannot +be read because it's @code{o} opaque. +@end deffn + +@deffn {Scheme Procedure} struct-set! struct n value +@deffnx {C Function} scm_struct_set_x (struct, n, value) +Set field number @var{n} in @var{struct} to @var{value}. The first +field is number 0. + +An error is thrown if @var{n} is out of range, or if the field cannot +be written because it's @code{r} read-only or @code{o} opaque. +@end deffn + +@deffn {Scheme Procedure} struct-vtable struct +@deffnx {C Function} scm_struct_vtable (struct) +Return the vtable that describes @var{struct}. + +The vtable is effectively the type of the structure. See @ref{Vtable +Contents}, for more on vtables. +@end deffn + + +@node Vtable Contents +@subsubsection Vtable Contents + +A vtable is itself a structure. It has a specific set of fields +describing various aspects of its @dfn{instances}: the structures +created from a vtable. Some of the fields are internal to Guile, some +of them are part of the public interface, and there may be additional +fields added on by the user. + +Every vtable has a field for the layout of their instances, a field for +the procedure used to print its instances, and a field for the name of +the vtable itself. Access to the layout and printer is exposed directly +via field indexes. Access to the vtable name is exposed via accessor +procedures. + +@defvr {Scheme Variable} vtable-index-layout +@defvrx {C Macro} scm_vtable_index_layout +The field number of the layout specification in a vtable. The layout +specification is a symbol like @code{pwpw} formed from the fields +string passed to @code{make-vtable}, or created by +@code{make-struct-layout} (@pxref{Meta-Vtables}). + +@example +(define v (make-vtable "pwpw" 0)) +(struct-ref v vtable-index-layout) @result{} pwpw +@end example + +This field is read-only, since the layout of structures using a vtable +cannot be changed. +@end defvr + +@defvr {Scheme Variable} vtable-index-printer +@defvrx {C Macro} scm_vtable_index_printer +The field number of the printer function. This field contains @code{#f} +if the default print function should be used. + +@example +(define (my-print-func struct port) + ...) +(define v (make-vtable "pwpw" my-print-func)) +(struct-ref v vtable-index-printer) @result{} my-print-func +@end example + +This field is writable, allowing the print function to be changed +dynamically. +@end defvr + +@deffn {Scheme Procedure} struct-vtable-name vtable +@deffnx {Scheme Procedure} set-struct-vtable-name! vtable name +@deffnx {C Function} scm_struct_vtable_name (vtable) +@deffnx {C Function} scm_set_struct_vtable_name_x (vtable, name) +Get or set the name of @var{vtable}. @var{name} is a symbol and is +used in the default print function when printing structures created +from @var{vtable}. + +@example +(define v (make-vtable "pw")) +(set-struct-vtable-name! v 'my-name) + +(define s (make-struct v 0)) +(display s) @print{} # +@end example +@end deffn + + +@node Meta-Vtables +@subsubsection Meta-Vtables + +As a structure, a vtable also has a vtable, which is also a structure. +Structures, their vtables, the vtables of the vtables, and so on form a +tree of structures. Making a new structure adds a leaf to the tree, and +if that structure is a vtable, it may be used to create other leaves. + +If you traverse up the tree of vtables, via calling +@code{struct-vtable}, eventually you reach a root which is the vtable of +itself: + +@example +scheme@@(guile-user)> (current-module) +$1 = # +scheme@@(guile-user)> (struct-vtable $1) +$2 = # +scheme@@(guile-user)> (struct-vtable $2) +$3 = #< 12c30a0> +scheme@@(guile-user)> (struct-vtable $3) +$4 = #< 12c3fa0> +scheme@@(guile-user)> (struct-vtable $4) +$5 = #< 12c3fa0> +scheme@@(guile-user)> +$6 = #< 12c3fa0> +@end example + +In this example, we can say that @code{$1} is an instance of @code{$2}, +@code{$2} is an instance of @code{$3}, @code{$3} is an instance of +@code{$4}, and @code{$4}, strangely enough, is an instance of itself. +The value bound to @code{$4} in this console session also bound to +@code{} in the default environment. + +@defvr {Scheme Variable} +A meta-vtable, useful for making new vtables. +@end defvr + +All of these values are structures. All but @code{$1} are vtables. As +@code{$2} is an instance of @code{$3}, and @code{$3} is a vtable, we can +say that @code{$3} is a @dfn{meta-vtable}: a vtable that can create +vtables. + +With this definition, we can specify more precisely what a vtable is: a +vtable is a structure made from a meta-vtable. Making a structure from +a meta-vtable runs some special checks to ensure that the first field of +the structure is a valid layout. Additionally, if these checks see that +the layout of the child vtable contains all the required fields of a +vtable, in the correct order, then the child vtable will also be a +meta-table, inheriting a magical bit from the parent. + +@deffn {Scheme Procedure} struct-vtable? obj +@deffnx {C Function} scm_struct_vtable_p (obj) +Return @code{#t} if @var{obj} is a vtable structure: an instance of a +meta-vtable. +@end deffn + +@code{} is a root of the vtable tree. (Normally there +is only one root in a given Guile process, but due to some legacy +interfaces there may be more than one.) + +The set of required fields of a vtable is the set of fields in the +@code{}, and is bound to @code{standard-vtable-fields} +in the default environment. It is possible to create a meta-vtable that +with additional fields in its layout, which can be used to create +vtables with additional data: + +@example +scheme@@(guile-user)> (struct-ref $3 vtable-index-layout) +$6 = pruhsruhpwphuhuhprprpw +scheme@@(guile-user)> (struct-ref $4 vtable-index-layout) +$7 = pruhsruhpwphuhuh +scheme@@(guile-user)> standard-vtable-fields +$8 = "pruhsruhpwphuhuh" +scheme@@(guile-user)> (struct-ref $2 vtable-offset-user) +$9 = module +@end example + +In this continuation of our earlier example, @code{$2} is a vtable that +has extra fields, because its vtable, @code{$3}, was made from a +meta-vtable with an extended layout. @code{vtable-offset-user} is a +convenient definition that indicates the number of fields in +@code{standard-vtable-fields}. + +@defvr {Scheme Variable} standard-vtable-fields +A string containing the ordered set of fields that a vtable must have. +@end defvr + +@defvr {Scheme Variable} vtable-offset-user +The first index in a vtable that is available for a user. +@end defvr + +@deffn {Scheme Procedure} make-struct-layout fields +@deffnx {C Function} scm_make_struct_layout (fields) +Return a structure layout symbol, from a @var{fields} string. +@var{fields} is as described under @code{make-vtable} +(@pxref{Vtables}). An invalid @var{fields} string is an error. +@end deffn + +With these definitions, one can define @code{make-vtable} in this way: + +@example +(define* (make-vtable fields #:optional printer) + (make-struct/no-tail + (make-struct-layout fields) + printer)) +@end example + + +@node Vtable Example +@subsubsection Vtable Example + +Let us bring these points together with an example. Consider a simple +object system with single inheritance. Objects will be normal +structures, and classes will be vtables with three extra class fields: +the name of the class, the parent class, and the list of fields. + +So, first we need a meta-vtable that allocates instances with these +extra class fields. + +@example +(define + (make-vtable + (string-append standard-vtable-fields "pwpwpw") + (lambda (x port) + (format port "< ~a>" (class-name x))))) + +(define (class? x) + (and (struct? x) + (eq? (struct-vtable x) ))) +@end example + +To make a structure with a specific meta-vtable, we will use +@code{make-struct/no-tail}, passing it the computed instance layout and +printer, as with @code{make-vtable}, and additionally the extra three +class fields. + +@example +(define (make-class name parent fields) + (let* ((fields (compute-fields parent fields)) + (layout (compute-layout fields))) + (make-struct/no-tail + layout + (lambda (x port) + (print-instance x port)) + name + parent + fields))) +@end example + +Instances will store their associated data in slots in the structure: as +many slots as there are fields. The @code{compute-layout} procedure +below can compute a layout, and @code{field-index} returns the slot +corresponding to a field. + +@example +(define-syntax-rule (define-accessor name n) + (define (name obj) + (struct-ref obj n))) + +;; Accessors for classes +(define-accessor class-name (+ vtable-offset-user 0)) +(define-accessor class-parent (+ vtable-offset-user 1)) +(define-accessor class-fields (+ vtable-offset-user 2)) + +(define (compute-fields parent fields) + (if parent + (append (class-fields parent) fields) + fields)) + +(define (compute-layout fields) + (make-struct-layout + (string-concatenate (make-list (length fields) "pw")))) + +(define (field-index class field) + (list-index (class-fields class) field)) + +(define (print-instance x port) + (format port "<~a" (class-name (struct-vtable x))) + (for-each (lambda (field idx) + (format port " ~a: ~a" field (struct-ref x idx))) + (class-fields (struct-vtable x)) + (iota (length (class-fields (struct-vtable x))))) + (format port ">")) +@end example + +So, at this point we can actually make a few classes: + +@example +(define-syntax-rule (define-class name parent field ...) + (define name (make-class 'name parent '(field ...)))) + +(define-class #f + width height) + +(define-class + x y) +@end example + +And finally, make an instance: + +@example +(make-struct/no-tail 400 300 10 20) +@result{} < width: 400 height: 300 x: 10 y: 20> +@end example + +And that's that. Note that there are many possible optimizations and +feature enhancements that can be made to this object system, and the +included GOOPS system does make most of them. For more simple use +cases, the records facility is usually sufficient. But sometimes you +need to make new kinds of data abstractions, and for that purpose, +structs are here. + +@node Tail Arrays +@subsubsection Tail Arrays + +Guile's structures have a facility whereby each instance of a vtable can +contain a variable-length tail array of values. The length of the tail +array is stored in the structure. This facility was originally intended +to allow C code to expose raw C structures with word-sized tail arrays +to Scheme. + +However, the tail array facility is confusing and doesn't work very +well. It is very rarely used, but it insinuates itself into all +invocations of @code{make-struct}. For this reason the clumsily-named +@code{make-struct/no-tail} procedure can actually be more elegant in +actual use, because it doesn't have a random @code{0} argument stuck in +the middle. + +Tail arrays also inhibit optimization by allowing instances to affect +their shapes. In the absence of tail arrays, all instances of a given +vtable have the same number and kinds of fields. This uniformity can be +exploited by the runtime and the optimizer. The presence of tail arrays +make some of these optimizations more difficult. + +Finally, the tail array facility is ad-hoc and does not compose with the +rest of Guile. If a Guile user wants an array with user-specified +length, it's best to use a vector. It is more clear in the code, and +the standard optimization techniques will do a good job with it. + +That said, we should mention some details about the interface. A vtable +that has tail array has upper-case permission descriptors: @code{W}, +@code{R} or @code{O}, correspoding to tail arrays of writable, +read-only, or opaque elements. A tail array permission descriptor may +only appear in the last element of a vtable layout. + +For exampple, @samp{pW} indicates a tail of writable Scheme-valued +fields. The @samp{pW} field itself holds the tail size, and the tail +fields come after it. + +@example +(define v (make-vtable "prpW")) ;; one fixed then a tail array +(define s (make-struct v 6 "fixed field" 'x 'y)) +(struct-ref s 0) @result{} "fixed field" +(struct-ref s 1) @result{} 2 ;; tail size +(struct-ref s 2) @result{} x ;; tail array ... +(struct-ref s 3) @result{} y +(struct-ref s 4) @result{} #f +@end example + + +@node Dictionary Types +@subsection Dictionary Types + +A @dfn{dictionary} object is a data structure used to index +information in a user-defined way. In standard Scheme, the main +aggregate data types are lists and vectors. Lists are not really +indexed at all, and vectors are indexed only by number +(e.g.@: @code{(vector-ref foo 5)}). Often you will find it useful +to index your data on some other type; for example, in a library +catalog you might want to look up a book by the name of its +author. Dictionaries are used to help you organize information in +such a way. + +An @dfn{association list} (or @dfn{alist} for short) is a list of +key-value pairs. Each pair represents a single quantity or +object; the @code{car} of the pair is a key which is used to +identify the object, and the @code{cdr} is the object's value. + +A @dfn{hash table} also permits you to index objects with +arbitrary keys, but in a way that makes looking up any one object +extremely fast. A well-designed hash system makes hash table +lookups almost as fast as conventional array or vector references. + +Alists are popular among Lisp programmers because they use only +the language's primitive operations (lists, @dfn{car}, @dfn{cdr} +and the equality primitives). No changes to the language core are +necessary. Therefore, with Scheme's built-in list manipulation +facilities, it is very convenient to handle data stored in an +association list. Also, alists are highly portable and can be +easily implemented on even the most minimal Lisp systems. + +However, alists are inefficient, especially for storing large +quantities of data. Because we want Guile to be useful for large +software systems as well as small ones, Guile provides a rich set +of tools for using either association lists or hash tables. + +@node Association Lists +@subsection Association Lists +@tpindex Association Lists +@tpindex Alist +@cindex association List +@cindex alist +@cindex database + +An association list is a conventional data structure that is often used +to implement simple key-value databases. It consists of a list of +entries in which each entry is a pair. The @dfn{key} of each entry is +the @code{car} of the pair and the @dfn{value} of each entry is the +@code{cdr}. + +@example +ASSOCIATION LIST ::= '( (KEY1 . VALUE1) + (KEY2 . VALUE2) + (KEY3 . VALUE3) + @dots{} + ) +@end example + +@noindent +Association lists are also known, for short, as @dfn{alists}. + +The structure of an association list is just one example of the infinite +number of possible structures that can be built using pairs and lists. +As such, the keys and values in an association list can be manipulated +using the general list structure procedures @code{cons}, @code{car}, +@code{cdr}, @code{set-car!}, @code{set-cdr!} and so on. However, +because association lists are so useful, Guile also provides specific +procedures for manipulating them. + +@menu +* Alist Key Equality:: +* Adding or Setting Alist Entries:: +* Retrieving Alist Entries:: +* Removing Alist Entries:: +* Sloppy Alist Functions:: +* Alist Example:: +@end menu + +@node Alist Key Equality +@subsubsection Alist Key Equality + +All of Guile's dedicated association list procedures, apart from +@code{acons}, come in three flavours, depending on the level of equality +that is required to decide whether an existing key in the association +list is the same as the key that the procedure call uses to identify the +required entry. + +@itemize @bullet +@item +Procedures with @dfn{assq} in their name use @code{eq?} to determine key +equality. + +@item +Procedures with @dfn{assv} in their name use @code{eqv?} to determine +key equality. + +@item +Procedures with @dfn{assoc} in their name use @code{equal?} to +determine key equality. +@end itemize + +@code{acons} is an exception because it is used to build association +lists which do not require their entries' keys to be unique. + +@node Adding or Setting Alist Entries +@subsubsection Adding or Setting Alist Entries + +@code{acons} adds a new entry to an association list and returns the +combined association list. The combined alist is formed by consing the +new entry onto the head of the alist specified in the @code{acons} +procedure call. So the specified alist is not modified, but its +contents become shared with the tail of the combined alist that +@code{acons} returns. + +In the most common usage of @code{acons}, a variable holding the +original association list is updated with the combined alist: + +@example +(set! address-list (acons name address address-list)) +@end example + +In such cases, it doesn't matter that the old and new values of +@code{address-list} share some of their contents, since the old value is +usually no longer independently accessible. + +Note that @code{acons} adds the specified new entry regardless of +whether the alist may already contain entries with keys that are, in +some sense, the same as that of the new entry. Thus @code{acons} is +ideal for building alists where there is no concept of key uniqueness. + +@example +(set! task-list (acons 3 "pay gas bill" '())) +task-list +@result{} +((3 . "pay gas bill")) + +(set! task-list (acons 3 "tidy bedroom" task-list)) +task-list +@result{} +((3 . "tidy bedroom") (3 . "pay gas bill")) +@end example + +@code{assq-set!}, @code{assv-set!} and @code{assoc-set!} are used to add +or replace an entry in an association list where there @emph{is} a +concept of key uniqueness. If the specified association list already +contains an entry whose key is the same as that specified in the +procedure call, the existing entry is replaced by the new one. +Otherwise, the new entry is consed onto the head of the old association +list to create the combined alist. In all cases, these procedures +return the combined alist. + +@code{assq-set!} and friends @emph{may} destructively modify the +structure of the old association list in such a way that an existing +variable is correctly updated without having to @code{set!} it to the +value returned: + +@example +address-list +@result{} +(("mary" . "34 Elm Road") ("james" . "16 Bow Street")) + +(assoc-set! address-list "james" "1a London Road") +@result{} +(("mary" . "34 Elm Road") ("james" . "1a London Road")) + +address-list +@result{} +(("mary" . "34 Elm Road") ("james" . "1a London Road")) +@end example + +Or they may not: + +@example +(assoc-set! address-list "bob" "11 Newington Avenue") +@result{} +(("bob" . "11 Newington Avenue") ("mary" . "34 Elm Road") + ("james" . "1a London Road")) + +address-list +@result{} +(("mary" . "34 Elm Road") ("james" . "1a London Road")) +@end example + +The only safe way to update an association list variable when adding or +replacing an entry like this is to @code{set!} the variable to the +returned value: + +@example +(set! address-list + (assoc-set! address-list "bob" "11 Newington Avenue")) +address-list +@result{} +(("bob" . "11 Newington Avenue") ("mary" . "34 Elm Road") + ("james" . "1a London Road")) +@end example + +Because of this slight inconvenience, you may find it more convenient to +use hash tables to store dictionary data. If your application will not +be modifying the contents of an alist very often, this may not make much +difference to you. + +If you need to keep the old value of an association list in a form +independent from the list that results from modification by +@code{acons}, @code{assq-set!}, @code{assv-set!} or @code{assoc-set!}, +use @code{list-copy} to copy the old association list before modifying +it. + +@deffn {Scheme Procedure} acons key value alist +@deffnx {C Function} scm_acons (key, value, alist) +Add a new key-value pair to @var{alist}. A new pair is +created whose car is @var{key} and whose cdr is @var{value}, and the +pair is consed onto @var{alist}, and the new list is returned. This +function is @emph{not} destructive; @var{alist} is not modified. +@end deffn + +@deffn {Scheme Procedure} assq-set! alist key val +@deffnx {Scheme Procedure} assv-set! alist key value +@deffnx {Scheme Procedure} assoc-set! alist key value +@deffnx {C Function} scm_assq_set_x (alist, key, val) +@deffnx {C Function} scm_assv_set_x (alist, key, val) +@deffnx {C Function} scm_assoc_set_x (alist, key, val) +Reassociate @var{key} in @var{alist} with @var{value}: find any existing +@var{alist} entry for @var{key} and associate it with the new +@var{value}. If @var{alist} does not contain an entry for @var{key}, +add a new one. Return the (possibly new) alist. + +These functions do not attempt to verify the structure of @var{alist}, +and so may cause unusual results if passed an object that is not an +association list. +@end deffn + +@node Retrieving Alist Entries +@subsubsection Retrieving Alist Entries +@rnindex assq +@rnindex assv +@rnindex assoc + +@code{assq}, @code{assv} and @code{assoc} find the entry in an alist +for a given key, and return the @code{(@var{key} . @var{value})} pair. +@code{assq-ref}, @code{assv-ref} and @code{assoc-ref} do a similar +lookup, but return just the @var{value}. + +@deffn {Scheme Procedure} assq key alist +@deffnx {Scheme Procedure} assv key alist +@deffnx {Scheme Procedure} assoc key alist +@deffnx {C Function} scm_assq (key, alist) +@deffnx {C Function} scm_assv (key, alist) +@deffnx {C Function} scm_assoc (key, alist) +Return the first entry in @var{alist} with the given @var{key}. The +return is the pair @code{(KEY . VALUE)} from @var{alist}. If there's +no matching entry the return is @code{#f}. + +@code{assq} compares keys with @code{eq?}, @code{assv} uses +@code{eqv?} and @code{assoc} uses @code{equal?}. See also SRFI-1 +which has an extended @code{assoc} (@ref{SRFI-1 Association Lists}). +@end deffn + +@deffn {Scheme Procedure} assq-ref alist key +@deffnx {Scheme Procedure} assv-ref alist key +@deffnx {Scheme Procedure} assoc-ref alist key +@deffnx {C Function} scm_assq_ref (alist, key) +@deffnx {C Function} scm_assv_ref (alist, key) +@deffnx {C Function} scm_assoc_ref (alist, key) +Return the value from the first entry in @var{alist} with the given +@var{key}, or @code{#f} if there's no such entry. + +@code{assq-ref} compares keys with @code{eq?}, @code{assv-ref} uses +@code{eqv?} and @code{assoc-ref} uses @code{equal?}. + +Notice these functions have the @var{key} argument last, like other +@code{-ref} functions, but this is opposite to what @code{assq} +etc above use. + +When the return is @code{#f} it can be either @var{key} not found, or +an entry which happens to have value @code{#f} in the @code{cdr}. Use +@code{assq} etc above if you need to differentiate these cases. +@end deffn + + +@node Removing Alist Entries +@subsubsection Removing Alist Entries + +To remove the element from an association list whose key matches a +specified key, use @code{assq-remove!}, @code{assv-remove!} or +@code{assoc-remove!} (depending, as usual, on the level of equality +required between the key that you specify and the keys in the +association list). + +As with @code{assq-set!} and friends, the specified alist may or may not +be modified destructively, and the only safe way to update a variable +containing the alist is to @code{set!} it to the value that +@code{assq-remove!} and friends return. + +@example +address-list +@result{} +(("bob" . "11 Newington Avenue") ("mary" . "34 Elm Road") + ("james" . "1a London Road")) + +(set! address-list (assoc-remove! address-list "mary")) +address-list +@result{} +(("bob" . "11 Newington Avenue") ("james" . "1a London Road")) +@end example + +Note that, when @code{assq/v/oc-remove!} is used to modify an +association list that has been constructed only using the corresponding +@code{assq/v/oc-set!}, there can be at most one matching entry in the +alist, so the question of multiple entries being removed in one go does +not arise. If @code{assq/v/oc-remove!} is applied to an association +list that has been constructed using @code{acons}, or an +@code{assq/v/oc-set!} with a different level of equality, or any mixture +of these, it removes only the first matching entry from the alist, even +if the alist might contain further matching entries. For example: + +@example +(define address-list '()) +(set! address-list (assq-set! address-list "mary" "11 Elm Street")) +(set! address-list (assq-set! address-list "mary" "57 Pine Drive")) +address-list +@result{} +(("mary" . "57 Pine Drive") ("mary" . "11 Elm Street")) + +(set! address-list (assoc-remove! address-list "mary")) +address-list +@result{} +(("mary" . "11 Elm Street")) +@end example + +In this example, the two instances of the string "mary" are not the same +when compared using @code{eq?}, so the two @code{assq-set!} calls add +two distinct entries to @code{address-list}. When compared using +@code{equal?}, both "mary"s in @code{address-list} are the same as the +"mary" in the @code{assoc-remove!} call, but @code{assoc-remove!} stops +after removing the first matching entry that it finds, and so one of the +"mary" entries is left in place. + +@deffn {Scheme Procedure} assq-remove! alist key +@deffnx {Scheme Procedure} assv-remove! alist key +@deffnx {Scheme Procedure} assoc-remove! alist key +@deffnx {C Function} scm_assq_remove_x (alist, key) +@deffnx {C Function} scm_assv_remove_x (alist, key) +@deffnx {C Function} scm_assoc_remove_x (alist, key) +Delete the first entry in @var{alist} associated with @var{key}, and return +the resulting alist. +@end deffn + +@node Sloppy Alist Functions +@subsubsection Sloppy Alist Functions + +@code{sloppy-assq}, @code{sloppy-assv} and @code{sloppy-assoc} behave +like the corresponding non-@code{sloppy-} procedures, except that they +return @code{#f} when the specified association list is not well-formed, +where the non-@code{sloppy-} versions would signal an error. + +Specifically, there are two conditions for which the non-@code{sloppy-} +procedures signal an error, which the @code{sloppy-} procedures handle +instead by returning @code{#f}. Firstly, if the specified alist as a +whole is not a proper list: + +@example +(assoc "mary" '((1 . 2) ("key" . "door") . "open sesame")) +@result{} +ERROR: In procedure assoc in expression (assoc "mary" (quote #)): +ERROR: Wrong type argument in position 2 (expecting + association list): ((1 . 2) ("key" . "door") . "open sesame") + +(sloppy-assoc "mary" '((1 . 2) ("key" . "door") . "open sesame")) +@result{} +#f +@end example + +@noindent +Secondly, if one of the entries in the specified alist is not a pair: + +@example +(assoc 2 '((1 . 1) 2 (3 . 9))) +@result{} +ERROR: In procedure assoc in expression (assoc 2 (quote #)): +ERROR: Wrong type argument in position 2 (expecting + association list): ((1 . 1) 2 (3 . 9)) + +(sloppy-assoc 2 '((1 . 1) 2 (3 . 9))) +@result{} +#f +@end example + +Unless you are explicitly working with badly formed association lists, +it is much safer to use the non-@code{sloppy-} procedures, because they +help to highlight coding and data errors that the @code{sloppy-} +versions would silently cover up. + +@deffn {Scheme Procedure} sloppy-assq key alist +@deffnx {C Function} scm_sloppy_assq (key, alist) +Behaves like @code{assq} but does not do any error checking. +Recommended only for use in Guile internals. +@end deffn + +@deffn {Scheme Procedure} sloppy-assv key alist +@deffnx {C Function} scm_sloppy_assv (key, alist) +Behaves like @code{assv} but does not do any error checking. +Recommended only for use in Guile internals. +@end deffn + +@deffn {Scheme Procedure} sloppy-assoc key alist +@deffnx {C Function} scm_sloppy_assoc (key, alist) +Behaves like @code{assoc} but does not do any error checking. +Recommended only for use in Guile internals. +@end deffn + +@node Alist Example +@subsubsection Alist Example + +Here is a longer example of how alists may be used in practice. + +@lisp +(define capitals '(("New York" . "Albany") + ("Oregon" . "Salem") + ("Florida" . "Miami"))) + +;; What's the capital of Oregon? +(assoc "Oregon" capitals) @result{} ("Oregon" . "Salem") +(assoc-ref capitals "Oregon") @result{} "Salem" + +;; We left out South Dakota. +(set! capitals + (assoc-set! capitals "South Dakota" "Pierre")) +capitals +@result{} (("South Dakota" . "Pierre") + ("New York" . "Albany") + ("Oregon" . "Salem") + ("Florida" . "Miami")) + +;; And we got Florida wrong. +(set! capitals + (assoc-set! capitals "Florida" "Tallahassee")) +capitals +@result{} (("South Dakota" . "Pierre") + ("New York" . "Albany") + ("Oregon" . "Salem") + ("Florida" . "Tallahassee")) + +;; After Oregon secedes, we can remove it. +(set! capitals + (assoc-remove! capitals "Oregon")) +capitals +@result{} (("South Dakota" . "Pierre") + ("New York" . "Albany") + ("Florida" . "Tallahassee")) +@end lisp + +@node VHashes +@subsection VList-Based Hash Lists or ``VHashes'' + +@cindex VList-based hash lists +@cindex VHash + +The @code{(ice-9 vlist)} module provides an implementation of @dfn{VList-based +hash lists} (@pxref{VLists}). VList-based hash lists, or @dfn{vhashes}, are an +immutable dictionary type similar to association lists that maps @dfn{keys} to +@dfn{values}. However, unlike association lists, accessing a value given its +key is typically a constant-time operation. + +The VHash programming interface of @code{(ice-9 vlist)} is mostly the same as +that of association lists found in SRFI-1, with procedure names prefixed by +@code{vhash-} instead of @code{alist-} (@pxref{SRFI-1 Association Lists}). + +In addition, vhashes can be manipulated using VList operations: + +@example +(vlist-head (vhash-consq 'a 1 vlist-null)) +@result{} (a . 1) + +(define vh1 (vhash-consq 'b 2 (vhash-consq 'a 1 vlist-null))) +(define vh2 (vhash-consq 'c 3 (vlist-tail vh1))) + +(vhash-assq 'a vh2) +@result{} (a . 1) +(vhash-assq 'b vh2) +@result{} #f +(vhash-assq 'c vh2) +@result{} (c . 3) +(vlist->list vh2) +@result{} ((c . 3) (a . 1)) +@end example + +However, keep in mind that procedures that construct new VLists +(@code{vlist-map}, @code{vlist-filter}, etc.) return raw VLists, not vhashes: + +@example +(define vh (alist->vhash '((a . 1) (b . 2) (c . 3)) hashq)) +(vhash-assq 'a vh) +@result{} (a . 1) + +(define vl + ;; This will create a raw vlist. + (vlist-filter (lambda (key+value) (odd? (cdr key+value))) vh)) +(vhash-assq 'a vl) +@result{} ERROR: Wrong type argument in position 2 + +(vlist->list vl) +@result{} ((a . 1) (c . 3)) +@end example + +@deffn {Scheme Procedure} vhash? obj +Return true if @var{obj} is a vhash. +@end deffn + +@deffn {Scheme Procedure} vhash-cons key value vhash [hash-proc] +@deffnx {Scheme Procedure} vhash-consq key value vhash +@deffnx {Scheme Procedure} vhash-consv key value vhash +Return a new hash list based on @var{vhash} where @var{key} is associated with +@var{value}, using @var{hash-proc} to compute the hash of @var{key}. +@var{vhash} must be either @code{vlist-null} or a vhash returned by a previous +call to @code{vhash-cons}. @var{hash-proc} defaults to @code{hash} (@pxref{Hash +Table Reference, @code{hash} procedure}). With @code{vhash-consq}, the +@code{hashq} hash function is used; with @code{vhash-consv} the @code{hashv} +hash function is used. + +All @code{vhash-cons} calls made to construct a vhash should use the same +@var{hash-proc}. Failing to do that, the result is undefined. +@end deffn + +@deffn {Scheme Procedure} vhash-assoc key vhash [equal? [hash-proc]] +@deffnx {Scheme Procedure} vhash-assq key vhash +@deffnx {Scheme Procedure} vhash-assv key vhash +Return the first key/value pair from @var{vhash} whose key is equal to @var{key} +according to the @var{equal?} equality predicate (which defaults to +@code{equal?}), and using @var{hash-proc} (which defaults to @code{hash}) to +compute the hash of @var{key}. The second form uses @code{eq?} as the equality +predicate and @code{hashq} as the hash function; the last form uses @code{eqv?} +and @code{hashv}. + +Note that it is important to consistently use the same hash function for +@var{hash-proc} as was passed to @code{vhash-cons}. Failing to do that, the +result is unpredictable. +@end deffn + +@deffn {Scheme Procedure} vhash-delete key vhash [equal? [hash-proc]] +@deffnx {Scheme Procedure} vhash-delq key vhash +@deffnx {Scheme Procedure} vhash-delv key vhash +Remove all associations from @var{vhash} with @var{key}, comparing keys with +@var{equal?} (which defaults to @code{equal?}), and computing the hash of +@var{key} using @var{hash-proc} (which defaults to @code{hash}). The second +form uses @code{eq?} as the equality predicate and @code{hashq} as the hash +function; the last one uses @code{eqv?} and @code{hashv}. + +Again the choice of @var{hash-proc} must be consistent with previous calls to +@code{vhash-cons}. +@end deffn + +@deffn {Scheme Procedure} vhash-fold proc init vhash +@deffnx {Scheme Procedure} vhash-fold-right proc init vhash +Fold over the key/value elements of @var{vhash} in the given direction, +with each call to @var{proc} having the form @code{(@var{proc} key value +result)}, where @var{result} is the result of the previous call to +@var{proc} and @var{init} the value of @var{result} for the first call +to @var{proc}. +@end deffn + +@deffn {Scheme Procedure} vhash-fold* proc init key vhash [equal? [hash]] +@deffnx {Scheme Procedure} vhash-foldq* proc init key vhash +@deffnx {Scheme Procedure} vhash-foldv* proc init key vhash +Fold over all the values associated with @var{key} in @var{vhash}, with each +call to @var{proc} having the form @code{(proc value result)}, where +@var{result} is the result of the previous call to @var{proc} and @var{init} the +value of @var{result} for the first call to @var{proc}. + +Keys in @var{vhash} are hashed using @var{hash} are compared using @var{equal?}. +The second form uses @code{eq?} as the equality predicate and @code{hashq} as +the hash function; the third one uses @code{eqv?} and @code{hashv}. + +Example: + +@example +(define vh + (alist->vhash '((a . 1) (a . 2) (z . 0) (a . 3)))) + +(vhash-fold* cons '() 'a vh) +@result{} (3 2 1) + +(vhash-fold* cons '() 'z vh) +@result{} (0) +@end example +@end deffn + +@deffn {Scheme Procedure} alist->vhash alist [hash-proc] +Return the vhash corresponding to @var{alist}, an association list, using +@var{hash-proc} to compute key hashes. When omitted, @var{hash-proc} defaults +to @code{hash}. +@end deffn + + +@node Hash Tables +@subsection Hash Tables +@tpindex Hash Tables + +Hash tables are dictionaries which offer similar functionality as +association lists: They provide a mapping from keys to values. The +difference is that association lists need time linear in the size of +elements when searching for entries, whereas hash tables can normally +search in constant time. The drawback is that hash tables require a +little bit more memory, and that you can not use the normal list +procedures (@pxref{Lists}) for working with them. + +@menu +* Hash Table Examples:: Demonstration of hash table usage. +* Hash Table Reference:: Hash table procedure descriptions. +@end menu + + +@node Hash Table Examples +@subsubsection Hash Table Examples + +For demonstration purposes, this section gives a few usage examples of +some hash table procedures, together with some explanation what they do. + +First we start by creating a new hash table with 31 slots, and +populate it with two key/value pairs. + +@lisp +(define h (make-hash-table 31)) + +;; This is an opaque object +h +@result{} +# + +;; Inserting into a hash table can be done with hashq-set! +(hashq-set! h 'foo "bar") +@result{} +"bar" + +(hashq-set! h 'braz "zonk") +@result{} +"zonk" + +;; Or with hash-create-handle! +(hashq-create-handle! h 'frob #f) +@result{} +(frob . #f) +@end lisp + +You can get the value for a given key with the procedure +@code{hashq-ref}, but the problem with this procedure is that you +cannot reliably determine whether a key does exists in the table. The +reason is that the procedure returns @code{#f} if the key is not in +the table, but it will return the same value if the key is in the +table and just happens to have the value @code{#f}, as you can see in +the following examples. + +@lisp +(hashq-ref h 'foo) +@result{} +"bar" + +(hashq-ref h 'frob) +@result{} +#f + +(hashq-ref h 'not-there) +@result{} +#f +@end lisp + +It is often better is to use the procedure @code{hashq-get-handle}, +which makes a distinction between the two cases. Just like @code{assq}, +this procedure returns a key/value-pair on success, and @code{#f} if the +key is not found. + +@lisp +(hashq-get-handle h 'foo) +@result{} +(foo . "bar") + +(hashq-get-handle h 'not-there) +@result{} +#f +@end lisp + +Interesting results can be computed by using @code{hash-fold} to work +through each element. This example will count the total number of +elements: + +@lisp +(hash-fold (lambda (key value seed) (+ 1 seed)) 0 h) +@result{} +3 +@end lisp + +The same thing can be done with the procedure @code{hash-count}, which +can also count the number of elements matching a particular predicate. +For example, count the number of elements with string values: + +@lisp +(hash-count (lambda (key value) (string? value)) h) +@result{} +2 +@end lisp + +Counting all the elements is a simple task using @code{const}: + +@lisp +(hash-count (const #t) h) +@result{} +3 +@end lisp + +@node Hash Table Reference +@subsubsection Hash Table Reference + +@c FIXME: Describe in broad terms what happens for resizing, and what +@c the initial size means for this. + +Like the association list functions, the hash table functions come in +several varieties, according to the equality test used for the keys. +Plain @code{hash-} functions use @code{equal?}, @code{hashq-} +functions use @code{eq?}, @code{hashv-} functions use @code{eqv?}, and +the @code{hashx-} functions use an application supplied test. + +A single @code{make-hash-table} creates a hash table suitable for use +with any set of functions, but it's imperative that just one set is +then used consistently, or results will be unpredictable. + +Hash tables are implemented as a vector indexed by a hash value formed +from the key, with an association list of key/value pairs for each +bucket in case distinct keys hash together. Direct access to the +pairs in those lists is provided by the @code{-handle-} functions. + +When the number of entries in a hash table goes above a threshold, the +vector is made larger and the entries are rehashed, to prevent the +bucket lists from becoming too long and slowing down accesses. When the +number of entries goes below a threshold, the vector is shrunk to save +space. + +For the @code{hashx-} ``extended'' routines, an application supplies a +@var{hash} function producing an integer index like @code{hashq} etc +below, and an @var{assoc} alist search function like @code{assq} etc +(@pxref{Retrieving Alist Entries}). Here's an example of such +functions implementing case-insensitive hashing of string keys, + +@example +(use-modules (srfi srfi-1) + (srfi srfi-13)) + +(define (my-hash str size) + (remainder (string-hash-ci str) size)) +(define (my-assoc str alist) + (find (lambda (pair) (string-ci=? str (car pair))) alist)) + +(define my-table (make-hash-table)) +(hashx-set! my-hash my-assoc my-table "foo" 123) + +(hashx-ref my-hash my-assoc my-table "FOO") +@result{} 123 +@end example + +In a @code{hashx-} @var{hash} function the aim is to spread keys +across the vector, so bucket lists don't become long. But the actual +values are arbitrary as long as they're in the range 0 to +@math{@var{size}-1}. Helpful functions for forming a hash value, in +addition to @code{hashq} etc below, include @code{symbol-hash} +(@pxref{Symbol Keys}), @code{string-hash} and @code{string-hash-ci} +(@pxref{String Comparison}), and @code{char-set-hash} +(@pxref{Character Set Predicates/Comparison}). + +@sp 1 +@deffn {Scheme Procedure} make-hash-table [size] +Create a new hash table object, with an optional minimum +vector @var{size}. + +When @var{size} is given, the table vector will still grow and shrink +automatically, as described above, but with @var{size} as a minimum. +If an application knows roughly how many entries the table will hold +then it can use @var{size} to avoid rehashing when initial entries are +added. +@end deffn + +@deffn {Scheme Procedure} alist->hash-table alist +@deffnx {Scheme Procedure} alist->hashq-table alist +@deffnx {Scheme Procedure} alist->hashv-table alist +@deffnx {Scheme Procedure} alist->hashx-table hash assoc alist +Convert @var{alist} into a hash table. When keys are repeated in +@var{alist}, the leftmost association takes precedence. + +@example +(use-modules (ice-9 hash-table)) +(alist->hash-table '((foo . 1) (bar . 2))) +@end example + +When converting to an extended hash table, custom @var{hash} and +@var{assoc} procedures must be provided. + +@example +(alist->hashx-table hash assoc '((foo . 1) (bar . 2))) +@end example + +@end deffn + +@deffn {Scheme Procedure} hash-table? obj +@deffnx {C Function} scm_hash_table_p (obj) +Return @code{#t} if @var{obj} is a abstract hash table object. +@end deffn + +@deffn {Scheme Procedure} hash-clear! table +@deffnx {C Function} scm_hash_clear_x (table) +Remove all items from @var{table} (without triggering a resize). +@end deffn + +@deffn {Scheme Procedure} hash-ref table key [dflt] +@deffnx {Scheme Procedure} hashq-ref table key [dflt] +@deffnx {Scheme Procedure} hashv-ref table key [dflt] +@deffnx {Scheme Procedure} hashx-ref hash assoc table key [dflt] +@deffnx {C Function} scm_hash_ref (table, key, dflt) +@deffnx {C Function} scm_hashq_ref (table, key, dflt) +@deffnx {C Function} scm_hashv_ref (table, key, dflt) +@deffnx {C Function} scm_hashx_ref (hash, assoc, table, key, dflt) +Lookup @var{key} in the given hash @var{table}, and return the +associated value. If @var{key} is not found, return @var{dflt}, or +@code{#f} if @var{dflt} is not given. +@end deffn + +@deffn {Scheme Procedure} hash-set! table key val +@deffnx {Scheme Procedure} hashq-set! table key val +@deffnx {Scheme Procedure} hashv-set! table key val +@deffnx {Scheme Procedure} hashx-set! hash assoc table key val +@deffnx {C Function} scm_hash_set_x (table, key, val) +@deffnx {C Function} scm_hashq_set_x (table, key, val) +@deffnx {C Function} scm_hashv_set_x (table, key, val) +@deffnx {C Function} scm_hashx_set_x (hash, assoc, table, key, val) +Associate @var{val} with @var{key} in the given hash @var{table}. If +@var{key} is already present then it's associated value is changed. +If it's not present then a new entry is created. +@end deffn + +@deffn {Scheme Procedure} hash-remove! table key +@deffnx {Scheme Procedure} hashq-remove! table key +@deffnx {Scheme Procedure} hashv-remove! table key +@deffnx {Scheme Procedure} hashx-remove! hash assoc table key +@deffnx {C Function} scm_hash_remove_x (table, key) +@deffnx {C Function} scm_hashq_remove_x (table, key) +@deffnx {C Function} scm_hashv_remove_x (table, key) +@deffnx {C Function} scm_hashx_remove_x (hash, assoc, table, key) +Remove any association for @var{key} in the given hash @var{table}. +If @var{key} is not in @var{table} then nothing is done. +@end deffn + +@deffn {Scheme Procedure} hash key size +@deffnx {Scheme Procedure} hashq key size +@deffnx {Scheme Procedure} hashv key size +@deffnx {C Function} scm_hash (key, size) +@deffnx {C Function} scm_hashq (key, size) +@deffnx {C Function} scm_hashv (key, size) +Return a hash value for @var{key}. This is a number in the range +@math{0} to @math{@var{size}-1}, which is suitable for use in a hash +table of the given @var{size}. + +Note that @code{hashq} and @code{hashv} may use internal addresses of +objects, so if an object is garbage collected and re-created it can +have a different hash value, even when the two are notionally +@code{eq?}. For instance with symbols, + +@example +(hashq 'something 123) @result{} 19 +(gc) +(hashq 'something 123) @result{} 62 +@end example + +In normal use this is not a problem, since an object entered into a +hash table won't be garbage collected until removed. It's only if +hashing calculations are somehow separated from normal references that +its lifetime needs to be considered. +@end deffn + +@deffn {Scheme Procedure} hash-get-handle table key +@deffnx {Scheme Procedure} hashq-get-handle table key +@deffnx {Scheme Procedure} hashv-get-handle table key +@deffnx {Scheme Procedure} hashx-get-handle hash assoc table key +@deffnx {C Function} scm_hash_get_handle (table, key) +@deffnx {C Function} scm_hashq_get_handle (table, key) +@deffnx {C Function} scm_hashv_get_handle (table, key) +@deffnx {C Function} scm_hashx_get_handle (hash, assoc, table, key) +Return the @code{(@var{key} . @var{value})} pair for @var{key} in the +given hash @var{table}, or @code{#f} if @var{key} is not in +@var{table}. +@end deffn + +@deffn {Scheme Procedure} hash-create-handle! table key init +@deffnx {Scheme Procedure} hashq-create-handle! table key init +@deffnx {Scheme Procedure} hashv-create-handle! table key init +@deffnx {Scheme Procedure} hashx-create-handle! hash assoc table key init +@deffnx {C Function} scm_hash_create_handle_x (table, key, init) +@deffnx {C Function} scm_hashq_create_handle_x (table, key, init) +@deffnx {C Function} scm_hashv_create_handle_x (table, key, init) +@deffnx {C Function} scm_hashx_create_handle_x (hash, assoc, table, key, init) +Return the @code{(@var{key} . @var{value})} pair for @var{key} in the +given hash @var{table}. If @var{key} is not in @var{table} then +create an entry for it with @var{init} as the value, and return that +pair. +@end deffn + +@deffn {Scheme Procedure} hash-map->list proc table +@deffnx {Scheme Procedure} hash-for-each proc table +@deffnx {C Function} scm_hash_map_to_list (proc, table) +@deffnx {C Function} scm_hash_for_each (proc, table) +Apply @var{proc} to the entries in the given hash @var{table}. Each +call is @code{(@var{proc} @var{key} @var{value})}. @code{hash-map->list} +returns a list of the results from these calls, @code{hash-for-each} +discards the results and returns an unspecified value. + +Calls are made over the table entries in an unspecified order, and for +@code{hash-map->list} the order of the values in the returned list is +unspecified. Results will be unpredictable if @var{table} is modified +while iterating. + +For example the following returns a new alist comprising all the +entries from @code{mytable}, in no particular order. + +@example +(hash-map->list cons mytable) +@end example +@end deffn + +@deffn {Scheme Procedure} hash-for-each-handle proc table +@deffnx {C Function} scm_hash_for_each_handle (proc, table) +Apply @var{proc} to the entries in the given hash @var{table}. Each +call is @code{(@var{proc} @var{handle})}, where @var{handle} is a +@code{(@var{key} . @var{value})} pair. Return an unspecified value. + +@code{hash-for-each-handle} differs from @code{hash-for-each} only in +the argument list of @var{proc}. +@end deffn + +@deffn {Scheme Procedure} hash-fold proc init table +@deffnx {C Function} scm_hash_fold (proc, init, table) +Accumulate a result by applying @var{proc} to the elements of the +given hash @var{table}. Each call is @code{(@var{proc} @var{key} +@var{value} @var{prior-result})}, where @var{key} and @var{value} are +from the @var{table} and @var{prior-result} is the return from the +previous @var{proc} call. For the first call, @var{prior-result} is +the given @var{init} value. + +Calls are made over the table entries in an unspecified order. +Results will be unpredictable if @var{table} is modified while +@code{hash-fold} is running. + +For example, the following returns a count of how many keys in +@code{mytable} are strings. + +@example +(hash-fold (lambda (key value prior) + (if (string? key) (1+ prior) prior)) + 0 mytable) +@end example +@end deffn + +@deffn {Scheme Procedure} hash-count pred table +@deffnx {C Function} scm_hash_count (pred, table) +Return the number of elements in the given hash @var{table} that cause +@code{(@var{pred} @var{key} @var{value})} to return true. To quickly +determine the total number of elements, use @code{(const #t)} for +@var{pred}. +@end deffn + +@node Other Types +@subsection Other Types + +Procedures are documented in their own section. @xref{Procedures}. Variable objects are documented as part of the description of Guile's module system: see @ref{Variables}. -Asyncs, dynamic roots and fluids are described in the section on -scheduling: see @ref{Scheduling}. - -Hooks are documented in the section on general utility functions: see -@ref{Hooks}. +@xref{Scheduling}, for discussion of threads, mutexes, and so on. Ports are described in the section on I/O: see @ref{Input and Output}. Regular expressions are described in their own section: see @ref{Regular Expressions}. +There are quite a number of additional data types documented in this +manual; if you feel a link is missing here, please file a bug. + @c Local Variables: @c TeX-master: "guile.texi" @c End: diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index 0ab536b27..4bc3b74d8 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -297,8 +297,7 @@ available through both Scheme and C interfaces. * The SCM Type:: The fundamental data type for C code. * Initialization:: Initializing Guile. * Snarfing Macros:: Macros for snarfing initialization actions. -* Simple Data Types:: Numbers, strings, booleans and so on. -* Compound Data Types:: Data types for holding other data. +* Data Types:: Representing values in Guile. * Foreign Objects:: Defining new data types in C. * Smobs:: Use foreign objects instead. * Procedures:: Procedures. @@ -328,7 +327,6 @@ available through both Scheme and C interfaces. @include api-init.texi @include api-snarf.texi @include api-data.texi -@include api-compound.texi @include api-foreign-objects.texi @include api-smobs.texi @include api-procedures.texi diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 1cada278a..f71294436 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -1823,8 +1823,8 @@ procedures easier. It is documented in @xref{Multiple Values}. This SRFI is a syntax for defining new record types and creating predicate, constructor, and field getter and setter functions. It is -documented in the ``Compound Data Types'' section of the manual -(@pxref{SRFI-9 Records}). +documented in the ``Data Types'' section of the manual (@pxref{SRFI-9 +Records}). @node SRFI-10 From d236d4d33fdab83127a4d72c2b561649a5c46b6c Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Thu, 12 Feb 2015 13:02:24 +0100 Subject: [PATCH 621/865] Fix compilation of rank 0 typed array literals * module/system/vm/assembler.scm (simple-uniform-vector?): array-length fails for rank 0 arrays; fix the shape condition. * test-suite/tests/arrays.test: Test reading of #0f64(x) in compilation context. --- module/system/vm/assembler.scm | 4 +++- test-suite/tests/arrays.test | 8 +++++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 96c6a633b..5b89b049b 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -1001,7 +1001,9 @@ immediate, and @code{#f} otherwise." (define (simple-uniform-vector? obj) (and (array? obj) (symbol? (array-type obj)) - (equal? (array-shape obj) (list (list 0 (1- (array-length obj))))))) + (match (array-shape obj) + (((0 n)) #t) + (else #f)))) (define (statically-allocatable? x) "Return @code{#t} if a non-immediate constant can be allocated diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test index e76c699e9..20cb78b0e 100644 --- a/test-suite/tests/arrays.test +++ b/test-suite/tests/arrays.test @@ -204,7 +204,13 @@ (with-test-prefix/c&e "array-equal?" (pass-if "#s16(...)" - (array-equal? #s16(1 2 3) #s16(1 2 3)))) + (array-equal? #s16(1 2 3) #s16(1 2 3))) + + (pass-if "#0f64(...)" + (array-equal? #0f64(99) (make-typed-array 'f64 99))) + + (pass-if "#0(...)" + (array-equal? #0(99) (make-array 99)))) ;;; ;;; make-shared-array From 4e766795b2412f42a9c71441e6cc0b36d8a4c5dc Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Mon, 9 Feb 2015 12:11:52 +0100 Subject: [PATCH 622/865] Avoid unneeded internal use of array handles * libguile/arrays.c (scm_shared_array_root): Adopt uniform check order. (scm_shared_array_offset, scm_shared_array_increments): Use the array fields directly just as scm_shared_array_root does. (scm_c_array_rank): Moved from libguile/generalized-arrays.c. Don't use array handles, but follow the same type check sequence as the other array functions (shared-array-root, etc). (scm_array_rank): Moved from libguile/generalized-arrays.h. * libguile/arrays.h: Move prototypes here. * test-suite/tests/arrays.test: Tests for shared-array-offset, shared-array-increments. --- libguile/arrays.c | 65 ++++++++++++++++++++---------- libguile/arrays.h | 3 ++ libguile/generalized-arrays.c | 21 ---------- libguile/generalized-arrays.h | 3 -- test-suite/tests/arrays.test | 76 +++++++++++++++++++++++++++++------ 5 files changed, 109 insertions(+), 59 deletions(-) diff --git a/libguile/arrays.c b/libguile/arrays.c index ea090d646..b8307d528 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -63,6 +63,27 @@ (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16))) +size_t +scm_c_array_rank (SCM array) +{ + if (SCM_I_ARRAYP (array)) + return SCM_I_ARRAY_NDIM (array); + else if (scm_is_array (array)) + return 1; + else + scm_wrong_type_arg_msg ("array-rank", SCM_ARG1, array, "array"); +} + +SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0, + (SCM array), + "Return the number of dimensions of the array @var{array.}\n") +#define FUNC_NAME s_scm_array_rank +{ + return scm_from_size_t (scm_c_array_rank (array)); +} +#undef FUNC_NAME + + SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0, (SCM ra), "Return the root vector of a shared array.") @@ -70,10 +91,10 @@ SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0, { if (SCM_I_ARRAYP (ra)) return SCM_I_ARRAY_V (ra); - else if (!scm_is_array (ra)) - scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array"); - else + else if (scm_is_array (ra)) return ra; + else + scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array"); } #undef FUNC_NAME @@ -83,13 +104,12 @@ SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0, "Return the root vector index of the first element in the array.") #define FUNC_NAME s_scm_shared_array_offset { - scm_t_array_handle handle; - SCM res; - - scm_array_get_handle (ra, &handle); - res = scm_from_size_t (handle.base); - scm_array_handle_release (&handle); - return res; + if (SCM_I_ARRAYP (ra)) + return scm_from_size_t (SCM_I_ARRAY_BASE (ra)); + else if (scm_is_array (ra)) + return scm_from_size_t (0); + else + scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array"); } #undef FUNC_NAME @@ -99,18 +119,19 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0, "For each dimension, return the distance between elements in the root vector.") #define FUNC_NAME s_scm_shared_array_increments { - scm_t_array_handle handle; - SCM res = SCM_EOL; - size_t k; - scm_t_array_dim *s; - - scm_array_get_handle (ra, &handle); - k = scm_array_handle_rank (&handle); - s = scm_array_handle_dims (&handle); - while (k--) - res = scm_cons (scm_from_ssize_t (s[k].inc), res); - scm_array_handle_release (&handle); - return res; + if (SCM_I_ARRAYP (ra)) + { + size_t k = SCM_I_ARRAY_NDIM (ra); + SCM res = SCM_EOL; + scm_t_array_dim *dims = SCM_I_ARRAY_DIMS (ra); + while (k--) + res = scm_cons (scm_from_ssize_t (dims[k].inc), res); + return res; + } + else if (scm_is_array (ra)) + return scm_list_1 (scm_from_ssize_t (1)); + else + scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array"); } #undef FUNC_NAME diff --git a/libguile/arrays.h b/libguile/arrays.h index 5f4059792..a5cd43dc2 100644 --- a/libguile/arrays.h +++ b/libguile/arrays.h @@ -52,6 +52,9 @@ SCM_API SCM scm_array_contents (SCM ra, SCM strict); SCM_API SCM scm_list_to_array (SCM ndim, SCM lst); SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst); +SCM_API size_t scm_c_array_rank (SCM ra); +SCM_API SCM scm_array_rank (SCM ra); + /* internal. */ #define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0) diff --git a/libguile/generalized-arrays.c b/libguile/generalized-arrays.c index 9a001eb3c..fdbdb4aff 100644 --- a/libguile/generalized-arrays.c +++ b/libguile/generalized-arrays.c @@ -104,27 +104,6 @@ SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0, } #undef FUNC_NAME -size_t -scm_c_array_rank (SCM array) -{ - scm_t_array_handle handle; - size_t res; - - scm_array_get_handle (array, &handle); - res = scm_array_handle_rank (&handle); - scm_array_handle_release (&handle); - return res; -} - -SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0, - (SCM array), - "Return the number of dimensions of the array @var{array.}\n") -#define FUNC_NAME s_scm_array_rank -{ - return scm_from_size_t (scm_c_array_rank (array)); -} -#undef FUNC_NAME - size_t scm_c_array_length (SCM array) diff --git a/libguile/generalized-arrays.h b/libguile/generalized-arrays.h index dfdb8bd03..cfa69051b 100644 --- a/libguile/generalized-arrays.h +++ b/libguile/generalized-arrays.h @@ -41,9 +41,6 @@ SCM_INTERNAL SCM scm_array_p_2 (SCM); SCM_API int scm_is_typed_array (SCM obj, SCM type); SCM_API SCM scm_typed_array_p (SCM v, SCM type); -SCM_API size_t scm_c_array_rank (SCM ra); -SCM_API SCM scm_array_rank (SCM ra); - SCM_API size_t scm_c_array_length (SCM ra); SCM_API SCM scm_array_length (SCM ra); diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test index 20cb78b0e..4e26f4c43 100644 --- a/test-suite/tests/arrays.test +++ b/test-suite/tests/arrays.test @@ -23,9 +23,13 @@ #:use-module (srfi srfi-4) #:use-module (srfi srfi-4 gnu)) -;;; -;;; array? -;;; +(define (array-row a i) + (make-shared-array a (lambda (j) (list i j)) + (cadr (array-dimensions a)))) + +(define (array-col a j) + (make-shared-array a (lambda (i) (list i j)) + (car (array-dimensions a)))) (define exception:wrong-num-indices (cons 'misc-error "^wrong number of indices.*")) @@ -33,6 +37,15 @@ (define exception:length-non-negative (cons 'read-error ".*array length must be non-negative.*")) +(define exception:wrong-type-arg + (cons #t "Wrong type")) + +(define exception:mapping-out-of-range + (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array + +;;; +;;; array? +;;; (with-test-prefix "array?" @@ -216,9 +229,6 @@ ;;; make-shared-array ;;; -(define exception:mapping-out-of-range - (cons 'misc-error "^mapping out of range")) ;; per scm_make_shared_array - (with-test-prefix/c&e "make-shared-array" ;; this failed in guile 1.8.0 @@ -397,14 +407,58 @@ (b (make-shared-array a amap2 2 2))) (eq? (shared-array-root a) (shared-array-root b) (array-contents a))))) +;;; +;;; shared-array-offset +;;; + +(with-test-prefix/c&e "shared-array-offset" + + (pass-if "plain vector" + (zero? (shared-array-offset (make-vector 4 0)))) + + (pass-if "plain array rank 2" + (zero? (shared-array-offset (make-array 0 4 4)))) + + (pass-if "row of rank-2 array, I" + (= 0 (shared-array-offset (array-row (make-array 0 5 3) 0)))) + + (pass-if "row of rank-2 array, II" + (= 4 (shared-array-offset (array-row (make-array 0 6 4) 1)))) + + (pass-if "col of rank-2 array, I" + (= 0 (shared-array-offset (array-col (make-array 0 5 3) 0)))) + + (pass-if "col of rank-2 array, II" + (= 1 (shared-array-offset (array-col (make-array 0 6 4) 1))))) + + +;;; +;;; shared-array-increments +;;; + +(with-test-prefix/c&e "shared-array-increments" + + (pass-if "plain vector" + (equal? '(1) (shared-array-increments (make-vector 4 0)))) + + (pass-if "plain array rank 2" + (equal? '(4 1) (shared-array-increments (make-array 0 3 4)))) + + (pass-if "plain array rank 3" + (equal? '(20 5 1) (shared-array-increments (make-array 0 3 4 5)))) + + (pass-if "row of rank-2 array" + (equal? '(1) (shared-array-increments (array-row (make-array 0 5 3) 0)))) + + (pass-if "col of rank-2 array" + (equal? '(3) (shared-array-increments (array-col (make-array 0 5 3) 0))))) + + ;;; ;;; transpose-array ;;; ; see strings.test. -(define exception:wrong-type-arg - (cons #t "Wrong type")) - (with-test-prefix/c&e "transpose-array" (pass-if-exception "non array argument" exception:wrong-type-arg @@ -815,10 +869,6 @@ ;;; slices as generalized vectors ;;; -(define (array-row a i) - (make-shared-array a (lambda (j) (list i j)) - (cadr (array-dimensions a)))) - (with-test-prefix/c&e "generalized vector slices" (pass-if (equal? (array-row #2u32((0 1) (2 3)) 1) #u32(2 3))) From 85ac9cce0aa0d50274377244cf73c8776fb36db6 Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Wed, 11 Feb 2015 12:58:01 +0100 Subject: [PATCH 623/865] Reuse SCM_BYTEVECTOR_TYPED_LENGTH in scm_array_get_handle * libguile/bytevectors.h (SCM_BYTEVECTOR_TYPE_SIZE, SCM_BYTEVECTOR_TYPED_LENGTH): Moved from libguile/bytevectors.c. * libguile/array-handle.c (scm_array_get_handle): Reuse SCM_BYTEVECTOR_TYPED_LENGTH. --- libguile/array-handle.c | 6 ++---- libguile/bytevectors.c | 5 ----- libguile/bytevectors.h | 5 +++++ 3 files changed, 7 insertions(+), 9 deletions(-) diff --git a/libguile/array-handle.c b/libguile/array-handle.c index 2252ecc9a..3595266ff 100644 --- a/libguile/array-handle.c +++ b/libguile/array-handle.c @@ -185,15 +185,13 @@ scm_array_get_handle (SCM array, scm_t_array_handle *h) break; case scm_tc7_bytevector: { - size_t byte_length, length, element_byte_size; + size_t length; scm_t_array_element_type element_type; scm_t_vector_ref vref; scm_t_vector_set vset; - byte_length = scm_c_bytevector_length (array); element_type = SCM_BYTEVECTOR_ELEMENT_TYPE (array); - element_byte_size = scm_i_array_element_type_sizes[element_type] / 8; - length = byte_length / element_byte_size; + length = SCM_BYTEVECTOR_TYPED_LENGTH (array); switch (element_type) { diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index e426ae3a7..cf247dcd4 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -192,11 +192,6 @@ #define SCM_BYTEVECTOR_SET_PARENT(_bv, _parent) \ SCM_SET_CELL_OBJECT_3 ((_bv), (_parent)) -#define SCM_BYTEVECTOR_TYPE_SIZE(var) \ - (scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8) -#define SCM_BYTEVECTOR_TYPED_LENGTH(var) \ - (SCM_BYTEVECTOR_LENGTH (var) / SCM_BYTEVECTOR_TYPE_SIZE (var)) - /* The empty bytevector. */ SCM scm_null_bytevector = SCM_UNSPECIFIED; diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h index a5eeaea0c..af4ac1c34 100644 --- a/libguile/bytevectors.h +++ b/libguile/bytevectors.h @@ -129,6 +129,11 @@ SCM_API SCM scm_utf32_to_string (SCM, SCM); #define SCM_BYTEVECTOR_CONTIGUOUS_P(_bv) \ (SCM_BYTEVECTOR_FLAGS (_bv) >> 8UL) +#define SCM_BYTEVECTOR_TYPE_SIZE(var) \ + (scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8) +#define SCM_BYTEVECTOR_TYPED_LENGTH(var) \ + (SCM_BYTEVECTOR_LENGTH (var) / SCM_BYTEVECTOR_TYPE_SIZE (var)) + /* Hint that is passed to `scm_gc_malloc ()' and friends. */ #define SCM_GC_BYTEVECTOR "bytevector" From 09850ffc27be9852e74d35ed086d41acd0b373c0 Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Fri, 13 Feb 2015 16:45:21 +0100 Subject: [PATCH 624/865] Remove deprecated array functions * libguile/array-map.c (scm_array_fill_int, scm_array_fill_int, scm_ra_eqp, scm_ra_lessp scm_ra_leqp, scm_ra_grp, scm_ra_greqp, scm_ra_sum, scm_ra_difference, scm_ra_product, scm_ra_divide, scm_array_identity): Remove deprecated functions. * libguile/array-map.h: Remove declaration of deprecated functions. * libguile/generalized-vectors.h, libguile/generalized-vectors.c (scm_is_generalized_vector, scm_c_generalized_vector_length, scm_c_generalized_vector_ref, scm_c_generalized_vector_set_x): These functions were deprecated in 2.0.9. Remove. * doc/ref/api-compound.texi: Remove uniform-array-read!, uniform-array-write from the manual. These procedures where removed in fc7bd367ab4b5027a7f80686b1e229c62e43c90b (2011-05-12). --- libguile/array-map.c | 261 --------------------------------- libguile/array-map.h | 16 -- libguile/generalized-vectors.c | 31 ---- libguile/generalized-vectors.h | 4 - 4 files changed, 312 deletions(-) diff --git a/libguile/array-map.c b/libguile/array-map.c index c028795a5..df42d4b90 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -306,267 +306,6 @@ SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0, #undef FUNC_NAME -#if SCM_ENABLE_DEPRECATED == 1 - -/* to be used as cproc in scm_ramapc to fill an array dimension with - "fill". */ -int -scm_array_fill_int (SCM ra, SCM fill, SCM ignore SCM_UNUSED) -{ - unsigned long i; - unsigned long n = SCM_I_ARRAY_DIMS (ra)->ubnd - SCM_I_ARRAY_DIMS (ra)->lbnd + 1; - long inc = SCM_I_ARRAY_DIMS (ra)->inc; - unsigned long base = SCM_I_ARRAY_BASE (ra); - - ra = SCM_I_ARRAY_V (ra); - - for (i = base; n--; i += inc) - ASET (ra, i, fill); - - return 1; -} - -/* Functions callable by ARRAY-MAP! */ - -int -scm_ra_eqp (SCM ra0, SCM ras) -{ - SCM ra1 = SCM_CAR (ras), ra2 = SCM_CAR (SCM_CDR (ras)); - scm_t_array_handle ra0_handle; - scm_t_array_dim *ra0_dims; - size_t n; - ssize_t inc0; - size_t i0 = 0; - unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2); - long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; - long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_I_ARRAY_V (ra1); - ra2 = SCM_I_ARRAY_V (ra2); - - scm_array_get_handle (ra0, &ra0_handle); - ra0_dims = scm_array_handle_dims (&ra0_handle); - n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1; - inc0 = ra0_dims[0].inc; - - { - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0))) - if (!scm_is_eq (AREF (ra1, i1), AREF (ra2, i2))) - scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F); - } - - scm_array_handle_release (&ra0_handle); - return 1; -} - -/* opt 0 means <, nonzero means >= */ - -static int -ra_compare (SCM ra0, SCM ra1, SCM ra2, int opt) -{ - scm_t_array_handle ra0_handle; - scm_t_array_dim *ra0_dims; - size_t n; - ssize_t inc0; - size_t i0 = 0; - unsigned long i1 = SCM_I_ARRAY_BASE (ra1), i2 = SCM_I_ARRAY_BASE (ra2); - long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; - long inc2 = SCM_I_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_I_ARRAY_V (ra1); - ra2 = SCM_I_ARRAY_V (ra2); - - scm_array_get_handle (ra0, &ra0_handle); - ra0_dims = scm_array_handle_dims (&ra0_handle); - n = ra0_dims[0].ubnd - ra0_dims[0].lbnd + 1; - inc0 = ra0_dims[0].inc; - - { - for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if (scm_is_true (scm_array_handle_ref (&ra0_handle, i0))) - if (opt ? - scm_is_true (scm_less_p (AREF (ra1, i1), AREF (ra2, i2))) : - scm_is_false (scm_less_p (AREF (ra1, i1), AREF (ra2, i2)))) - scm_array_handle_set (&ra0_handle, i0, SCM_BOOL_F); - } - - scm_array_handle_release (&ra0_handle); - return 1; -} - - - -int -scm_ra_lessp (SCM ra0, SCM ras) -{ - return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 0); -} - - -int -scm_ra_leqp (SCM ra0, SCM ras) -{ - return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 1); -} - - -int -scm_ra_grp (SCM ra0, SCM ras) -{ - return ra_compare (ra0, SCM_CAR (SCM_CDR (ras)), SCM_CAR (ras), 0); -} - - -int -scm_ra_greqp (SCM ra0, SCM ras) -{ - return ra_compare (ra0, SCM_CAR (ras), SCM_CAR (SCM_CDR (ras)), 1); -} - - -int -scm_ra_sum (SCM ra0, SCM ras) -{ - long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1; - unsigned long i0 = SCM_I_ARRAY_BASE (ra0); - long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; - ra0 = SCM_I_ARRAY_V (ra0); - if (!scm_is_null(ras)) - { - SCM ra1 = SCM_CAR (ras); - unsigned long i1 = SCM_I_ARRAY_BASE (ra1); - long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_I_ARRAY_V (ra1); - switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) - { - default: - { - for (; n-- > 0; i0 += inc0, i1 += inc1) - ASET (ra0, i0, scm_sum (AREF(ra0, i0), AREF(ra1, i1))); - break; - } - } - } - return 1; -} - - - -int -scm_ra_difference (SCM ra0, SCM ras) -{ - long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1; - unsigned long i0 = SCM_I_ARRAY_BASE (ra0); - long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; - ra0 = SCM_I_ARRAY_V (ra0); - if (scm_is_null (ras)) - { - switch (SCM_TYP7 (ra0)) - { - default: - { - for (; n-- > 0; i0 += inc0) - ASET (ra0, i0, scm_difference (AREF(ra0, i0), SCM_UNDEFINED)); - break; - } - } - } - else - { - SCM ra1 = SCM_CAR (ras); - unsigned long i1 = SCM_I_ARRAY_BASE (ra1); - long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_I_ARRAY_V (ra1); - switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) - { - default: - { - for (; n-- > 0; i0 += inc0, i1 += inc1) - ASET (ra0, i0, scm_difference (AREF (ra0, i0), AREF (ra1, i1))); - break; - } - } - } - return 1; -} - - - -int -scm_ra_product (SCM ra0, SCM ras) -{ - long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1; - unsigned long i0 = SCM_I_ARRAY_BASE (ra0); - long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; - ra0 = SCM_I_ARRAY_V (ra0); - if (!scm_is_null (ras)) - { - SCM ra1 = SCM_CAR (ras); - unsigned long i1 = SCM_I_ARRAY_BASE (ra1); - long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_I_ARRAY_V (ra1); - switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) - { - default: - { - for (; n-- > 0; i0 += inc0, i1 += inc1) - ASET (ra0, i0, scm_product (AREF (ra0, i0), AREF (ra1, i1))); - } - } - } - return 1; -} - - -int -scm_ra_divide (SCM ra0, SCM ras) -{ - long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1; - unsigned long i0 = SCM_I_ARRAY_BASE (ra0); - long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; - ra0 = SCM_I_ARRAY_V (ra0); - if (scm_is_null (ras)) - { - switch (SCM_TYP7 (ra0)) - { - default: - { - for (; n-- > 0; i0 += inc0) - ASET (ra0, i0, scm_divide (AREF (ra0, i0), SCM_UNDEFINED)); - break; - } - } - } - else - { - SCM ra1 = SCM_CAR (ras); - unsigned long i1 = SCM_I_ARRAY_BASE (ra1); - long inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_I_ARRAY_V (ra1); - switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) - { - default: - { - for (; n-- > 0; i0 += inc0, i1 += inc1) - { - SCM res = scm_divide (AREF (ra0, i0), AREF (ra1, i1)); - ASET (ra0, i0, res); - } - break; - } - } - } - return 1; -} - - -int -scm_array_identity (SCM dst, SCM src) -{ - return racp (SCM_CAR (src), scm_cons (dst, SCM_EOL)); -} - -#endif /* SCM_ENABLE_DEPRECATED */ - static int ramap (SCM ra0, SCM proc, SCM ras) { diff --git a/libguile/array-map.h b/libguile/array-map.h index b0592d818..e7431b176 100644 --- a/libguile/array-map.h +++ b/libguile/array-map.h @@ -39,22 +39,6 @@ SCM_API SCM scm_array_index_map_x (SCM ra, SCM proc); SCM_API SCM scm_array_equal_p (SCM ra0, SCM ra1); SCM_INTERNAL void scm_init_array_map (void); -#if SCM_ENABLE_DEPRECATED == 1 - -SCM_DEPRECATED int scm_array_fill_int (SCM ra, SCM fill, SCM ignore); -SCM_DEPRECATED int scm_ra_eqp (SCM ra0, SCM ras); -SCM_DEPRECATED int scm_ra_lessp (SCM ra0, SCM ras); -SCM_DEPRECATED int scm_ra_leqp (SCM ra0, SCM ras); -SCM_DEPRECATED int scm_ra_grp (SCM ra0, SCM ras); -SCM_DEPRECATED int scm_ra_greqp (SCM ra0, SCM ras); -SCM_DEPRECATED int scm_ra_sum (SCM ra0, SCM ras); -SCM_DEPRECATED int scm_ra_difference (SCM ra0, SCM ras); -SCM_DEPRECATED int scm_ra_product (SCM ra0, SCM ras); -SCM_DEPRECATED int scm_ra_divide (SCM ra0, SCM ras); -SCM_DEPRECATED int scm_array_identity (SCM src, SCM dst); - -#endif /* SCM_ENABLE_DEPRECATED == 1 */ - #endif /* SCM_ARRAY_MAP_H */ /* diff --git a/libguile/generalized-vectors.c b/libguile/generalized-vectors.c index fc493bc80..0fe8b897c 100644 --- a/libguile/generalized-vectors.c +++ b/libguile/generalized-vectors.c @@ -69,19 +69,6 @@ SCM_DEFINE (scm_make_generalized_vector, "make-generalized-vector", 2, 1, 0, } #undef FUNC_NAME -int -scm_is_generalized_vector (SCM obj) -{ - int ret = 0; - if (scm_is_array (obj)) - { - scm_t_array_handle h; - scm_array_get_handle (obj, &h); - ret = scm_array_handle_rank (&h) == 1; - scm_array_handle_release (&h); - } - return ret; -} #define SCM_VALIDATE_VECTOR_WITH_HANDLE(pos, val, handle) \ scm_generalized_vector_get_handle (val, handle) @@ -98,24 +85,6 @@ scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h) } } -size_t -scm_c_generalized_vector_length (SCM v) -{ - return scm_c_array_length (v); -} - -SCM -scm_c_generalized_vector_ref (SCM v, ssize_t idx) -{ - return scm_c_array_ref_1 (v, idx); -} - -void -scm_c_generalized_vector_set_x (SCM v, ssize_t idx, SCM val) -{ - scm_c_array_set_1_x (v, val, idx); -} - void scm_init_generalized_vectors () { diff --git a/libguile/generalized-vectors.h b/libguile/generalized-vectors.h index 876537ae0..77d62726f 100644 --- a/libguile/generalized-vectors.h +++ b/libguile/generalized-vectors.h @@ -30,10 +30,6 @@ /* Generalized vectors */ -SCM_API int scm_is_generalized_vector (SCM obj); -SCM_API size_t scm_c_generalized_vector_length (SCM v); -SCM_API SCM scm_c_generalized_vector_ref (SCM v, ssize_t idx); -SCM_API void scm_c_generalized_vector_set_x (SCM v, ssize_t idx, SCM val); SCM_API void scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h); From fa40c288caca1b1fe7630621bd5c55574514588a Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Tue, 12 Jul 2016 18:43:03 +0200 Subject: [PATCH 625/865] Support typed arrays in some sort functions * libguile/sort.c (sort!, sort, restricted-vector-sort!, sorted?): Support arrays of rank 1, whatever the type. * libguile/quicksort.i.c: Fix accessors to handle typed arrays. * test-suite/tests/sort.test: Test also with typed arrays. --- libguile/quicksort.i.c | 45 ++++++------- libguile/sort.c | 127 +++++++++++++++++++++++++------------ test-suite/tests/sort.test | 32 +++++++++- 3 files changed, 138 insertions(+), 66 deletions(-) diff --git a/libguile/quicksort.i.c b/libguile/quicksort.i.c index 4e39f827a..cf1742efa 100644 --- a/libguile/quicksort.i.c +++ b/libguile/quicksort.i.c @@ -11,7 +11,7 @@ version but doesn't consume extra memory. */ -#define SWAP(a, b) do { const SCM _tmp = a; a = b; b = _tmp; } while (0) +#define SWAP(a, b) do { const SCM _tmp = GET(a); SET(a, GET(b)); SET(b, _tmp); } while (0) /* Order using quicksort. This implementation incorporates four @@ -54,8 +54,7 @@ #define STACK_NOT_EMPTY (stack < top) static void -NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM - SCM less) +NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less) { /* Stack node declarations used to store unfulfilled partition obligations. */ typedef struct { @@ -65,8 +64,6 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM static const char s_buggy_less[] = "buggy less predicate used when sorting"; -#define ELT(i) base_ptr[(i)*INC] - if (nr_elems == 0) /* Avoid lossage with unsigned arithmetic below. */ return; @@ -93,17 +90,17 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM SCM_TICK; - if (scm_is_true (scm_call_2 (less, ELT(mid), ELT(lo)))) - SWAP (ELT(mid), ELT(lo)); - if (scm_is_true (scm_call_2 (less, ELT(hi), ELT(mid)))) - SWAP (ELT(mid), ELT(hi)); + if (scm_is_true (scm_call_2 (less, GET(mid), GET(lo)))) + SWAP (mid, lo); + if (scm_is_true (scm_call_2 (less, GET(hi), GET(mid)))) + SWAP (mid, hi); else goto jump_over; - if (scm_is_true (scm_call_2 (less, ELT(mid), ELT(lo)))) - SWAP (ELT(mid), ELT(lo)); + if (scm_is_true (scm_call_2 (less, GET(mid), GET(lo)))) + SWAP (mid, lo); jump_over:; - pivot = ELT(mid); + pivot = GET(mid); left = lo + 1; right = hi - 1; @@ -112,7 +109,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM that this algorithm runs much faster than others. */ do { - while (scm_is_true (scm_call_2 (less, ELT(left), pivot))) + while (scm_is_true (scm_call_2 (less, GET(left), pivot))) { left += 1; /* The comparison predicate may be buggy */ @@ -120,7 +117,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM scm_misc_error (NULL, s_buggy_less, SCM_EOL); } - while (scm_is_true (scm_call_2 (less, pivot, ELT(right)))) + while (scm_is_true (scm_call_2 (less, pivot, GET(right)))) { right -= 1; /* The comparison predicate may be buggy */ @@ -130,7 +127,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM if (left < right) { - SWAP (ELT(left), ELT(right)); + SWAP (left, right); left += 1; right -= 1; } @@ -192,11 +189,11 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM and the operation speeds up insertion sort's inner loop. */ for (run = tmp + 1; run <= thresh; run += 1) - if (scm_is_true (scm_call_2 (less, ELT(run), ELT(tmp)))) + if (scm_is_true (scm_call_2 (less, GET(run), GET(tmp)))) tmp = run; if (tmp != 0) - SWAP (ELT(tmp), ELT(0)); + SWAP (tmp, 0); /* Insertion sort, running from left-hand-side up to right-hand-side. */ @@ -206,7 +203,7 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM SCM_TICK; tmp = run - 1; - while (scm_is_true (scm_call_2 (less, ELT(run), ELT(tmp)))) + while (scm_is_true (scm_call_2 (less, GET(run), GET(tmp)))) { /* The comparison predicate may be buggy */ if (tmp == 0) @@ -218,12 +215,12 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM tmp += 1; if (tmp != run) { - SCM to_insert = ELT(run); + SCM to_insert = GET(run); size_t hi, lo; for (hi = lo = run; --lo >= tmp; hi = lo) - ELT(hi) = ELT(lo); - ELT(hi) = to_insert; + SET(hi, GET(lo)); + SET(hi, to_insert); } } } @@ -235,9 +232,9 @@ NAME (SCM *const base_ptr, size_t nr_elems, INC_PARAM #undef PUSH #undef POP #undef STACK_NOT_EMPTY -#undef ELT +#undef GET +#undef SET #undef NAME #undef INC_PARAM -#undef INC - +#undef VEC_PARAM diff --git a/libguile/sort.c b/libguile/sort.c index 9373fb892..8c20d3453 100644 --- a/libguile/sort.c +++ b/libguile/sort.c @@ -51,21 +51,23 @@ #include "libguile/validate.h" #include "libguile/sort.h" -/* We have two quicksort variants: one for contigous vectors and one - for vectors with arbitrary increments between elements. Note that - increments can be negative. +/* We have two quicksort variants: one for SCM (#t) arrays and one for + typed arrays. */ -#define NAME quicksort1 -#define INC_PARAM /* empty */ -#define INC 1 -#include "libguile/quicksort.i.c" - #define NAME quicksort #define INC_PARAM ssize_t inc, -#define INC inc +#define VEC_PARAM SCM * ra, +#define GET(i) ra[(i)*inc] +#define SET(i, val) ra[(i)*inc] = val #include "libguile/quicksort.i.c" +#define NAME quicksorta +#define INC_PARAM +#define VEC_PARAM scm_t_array_handle * const ra, +#define GET(i) scm_array_handle_ref (ra, scm_array_handle_pos_1 (ra, i)) +#define SET(i, val) scm_array_handle_set (ra, scm_array_handle_pos_1 (ra, i), val) +#include "libguile/quicksort.i.c" SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0, (SCM vec, SCM less, SCM startpos, SCM endpos), @@ -76,22 +78,39 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0, "is not specified.") #define FUNC_NAME s_scm_restricted_vector_sort_x { - size_t vlen, spos, len; - ssize_t vinc; + ssize_t spos = scm_to_ssize_t (startpos); + size_t epos = scm_to_ssize_t (endpos); + scm_t_array_handle handle; - SCM *velts; + scm_t_array_dim const * dims; + scm_array_get_handle (vec, &handle); + dims = scm_array_handle_dims (&handle); - velts = scm_vector_writable_elements (vec, &handle, &vlen, &vinc); - spos = scm_to_unsigned_integer (startpos, 0, vlen); - len = scm_to_unsigned_integer (endpos, spos, vlen) - spos; + if (scm_array_handle_rank(&handle) != 1) + { + scm_array_handle_release (&handle); + scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", vec, SCM_EOL); + } + if (spos < dims[0].lbnd) + { + scm_array_handle_release (&handle); + scm_error (scm_out_of_range_key, FUNC_NAME, "startpos out of range", + vec, scm_list_1(startpos)); + } + if (epos > dims[0].ubnd+1) + { + scm_array_handle_release (&handle); + scm_error (scm_out_of_range_key, FUNC_NAME, "endpos out of range", + vec, scm_list_1(endpos)); + } - if (vinc == 1) - quicksort1 (velts + spos*vinc, len, less); + if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM) + quicksort (scm_array_handle_writable_elements (&handle) + (spos-dims[0].lbnd) * dims[0].inc, + epos-spos, dims[0].inc, less); else - quicksort (velts + spos*vinc, len, vinc, less); + quicksorta (&handle, epos-spos, less); scm_array_handle_release (&handle); - return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -140,29 +159,49 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0, } else { - scm_t_array_handle handle; - size_t i, len; - ssize_t inc; - const SCM *elts; SCM result = SCM_BOOL_T; + ssize_t i, end; + scm_t_array_handle handle; + scm_t_array_dim const * dims; + scm_array_get_handle (items, &handle); + dims = scm_array_handle_dims (&handle); - elts = scm_vector_elements (items, &handle, &len, &inc); + if (scm_array_handle_rank(&handle) != 1) + { + scm_array_handle_release (&handle); + scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", items, SCM_EOL); + } - for (i = 1; i < len; i++, elts += inc) - { - if (scm_is_true (scm_call_2 (less, elts[inc], elts[0]))) - { - result = SCM_BOOL_F; - break; - } - } + if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM) + { + ssize_t inc = dims[0].inc; + const SCM *elts = scm_array_handle_elements (&handle); + for (i = dims[0].lbnd+1, end = dims[0].ubnd+1; i < end; ++i, elts += inc) + { + if (scm_is_true (scm_call_2 (less, elts[inc], elts[0]))) + { + result = SCM_BOOL_F; + break; + } + } + } + else + { + for (i = dims[0].lbnd+1, end = dims[0].ubnd+1; i < end; ++i) + { + if (scm_is_true (scm_call_2 (less, + scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i)), + scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i-1))))) + { + result = SCM_BOOL_F; + break; + } + } + } scm_array_handle_release (&handle); - return result; } - - return SCM_BOOL_F; } #undef FUNC_NAME @@ -404,7 +443,14 @@ SCM_DEFINE (scm_sort, "sort", 2, 0, 0, if (scm_is_pair (items)) return scm_sort_x (scm_list_copy (items), less); else if (scm_is_array (items) && scm_c_array_rank (items) == 1) - return scm_sort_x (scm_vector_copy (items), less); + { + SCM copy; + if (scm_c_array_rank (items) != 1) + scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", items, SCM_EOL); + copy = scm_make_typed_array (scm_array_type (items), SCM_UNSPECIFIED, scm_array_dimensions (items)); + scm_array_copy_x (items, copy); + return scm_sort_x (copy, less); + } else SCM_WRONG_TYPE_ARG (1, items); } @@ -498,10 +544,11 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0, vec_elts = scm_vector_writable_elements (items, &vec_handle, &len, &inc); - if (len == 0) { - scm_array_handle_release (&vec_handle); - return items; - } + if (len == 0) + { + scm_array_handle_release (&vec_handle); + return items; + } temp = scm_c_make_vector (len, SCM_UNDEFINED); temp_elts = scm_vector_writable_elements (temp, &temp_handle, diff --git a/test-suite/tests/sort.test b/test-suite/tests/sort.test index 9209b539f..249f890ec 100644 --- a/test-suite/tests/sort.test +++ b/test-suite/tests/sort.test @@ -31,22 +31,51 @@ exception:wrong-num-args (sort '(1 2) (lambda (x y z) z))) - (pass-if "sort!" + (pass-if "sort of vector" + (let* ((v (randomize-vector! (make-vector 1000) 1000)) + (w (vector-copy v))) + (and (sorted? (sort v <) <) + (equal? w v)))) + + (pass-if "sort of typed array" + (let* ((v (randomize-vector! (make-typed-array 'f64 *unspecified* 99) 99)) + (w (make-typed-array 'f64 *unspecified* 99))) + (array-copy! v w) + (and (sorted? (sort v <) <) + (equal? w v)))) + + (pass-if "sort! of vector" (let ((v (randomize-vector! (make-vector 1000) 1000))) (sorted? (sort! v <) <))) + (pass-if "sort! of typed array" + (let ((v (randomize-vector! (make-typed-array 'f64 *unspecified* 99) 99))) + (sorted? (sort! v <) <))) + (pass-if "sort! of non-contigous vector" (let* ((a (make-array 0 1000 3)) (v (make-shared-array a (lambda (i) (list i 0)) 1000))) (randomize-vector! v 1000) (sorted? (sort! v <) <))) + (pass-if "sort! of non-contigous typed array" + (let* ((a (make-typed-array 'f64 0 99 3)) + (v (make-shared-array a (lambda (i) (list i 0)) 99))) + (randomize-vector! v 99) + (sorted? (sort! v <) <))) + (pass-if "sort! of negative-increment vector" (let* ((a (make-array 0 1000 3)) (v (make-shared-array a (lambda (i) (list (- 999 i) 0)) 1000))) (randomize-vector! v 1000) (sorted? (sort! v <) <))) + (pass-if "sort! of negative-increment typed array" + (let* ((a (make-typed-array 'f64 0 99 3)) + (v (make-shared-array a (lambda (i) (list (- 98 i) 0)) 99))) + (randomize-vector! v 99) + (sorted? (sort! v <) <))) + (pass-if "stable-sort!" (let ((v (randomize-vector! (make-vector 1000) 1000))) (sorted? (stable-sort! v <) <))) @@ -79,4 +108,3 @@ ;; behavior (integer underflow) leading to crashes. (pass-if "empty vector" (equal? '#() (stable-sort '#() <)))) - From 31e9f8b974073e690f1ba6c60e18ed474de004a1 Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Fri, 13 Feb 2015 18:42:27 +0100 Subject: [PATCH 626/865] Speed up for multi-arg cases of scm_ramap functions This patch results in a 20%-40% speedup in the > 1 argument cases of the following microbenchmarks: (define A (make-shared-array #0(1) (const '()) #e1e7)) ; 1, 2, 3 arguments. (define a 0) ,time (array-for-each (lambda (b) (set! a (+ a b))) A) (define a 0) ,time (array-for-each (lambda (b c) (set! a (+ a b c))) A A) (define a 0) ,time (array-for-each (lambda (b c d) (set! a (+ a b c d))) A A A) (define A (make-shared-array (make-array 1) (const '()) #e1e7)) (define B (make-shared-array #0(1) (const '()) #e1e7)) ; 1, 2, 3 arguments. ,time (array-map! A + B) ,time (array-map! A + B B) ,time (array-map! A + B B B) * libguile/array-map.c (scm_ramap): Note on cproc arguments. (rafill): Assume that dst's lbnd is 0. (racp): Assume that src's lbnd is 0. (ramap): Assume that ra0's lbnd is 0. When there're more than two arguments, compute the array handles before the loop. Allocate the arg list once and reuse it in the loop. (rafe): Do as in ramap(), when there's more than one argument. (AREF, ASET): Remove. --- libguile/array-map.c | 136 ++++++++++++++++++++---------------- libguile/array-map.h | 2 +- test-suite/tests/ramap.test | 4 +- 3 files changed, 77 insertions(+), 65 deletions(-) diff --git a/libguile/array-map.c b/libguile/array-map.c index df42d4b90..e3af729c8 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -1,5 +1,5 @@ /* Copyright (C) 1996, 1998, 2000, 2001, 2004, 2005, 2006, 2008, 2009, - * 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. + * 2010, 2011, 2012, 2013, 2014, 2015 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 License @@ -46,18 +46,6 @@ /* The WHAT argument for `scm_gc_malloc ()' et al. */ static const char vi_gc_hint[] = "array-indices"; -static SCM -AREF (SCM v, size_t pos) -{ - return scm_c_array_ref_1 (v, pos); -} - -static void -ASET (SCM v, size_t pos, SCM val) -{ - scm_c_array_set_1_x (v, val, pos); -} - static SCM make1array (SCM v, ssize_t inc) { @@ -98,6 +86,10 @@ cindk (SCM ra, ssize_t *ve, int kend) #define LBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].lbnd #define UBND(ra, k) SCM_I_ARRAY_DIMS (ra)[k].ubnd + +/* scm_ramapc() always calls cproc with rank-1 arrays created by + make1array. cproc (rafe, ramap, rafill, racp) can assume that the + dims[0].lbnd of these arrays is always 0. */ int scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what) { @@ -166,7 +158,7 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what) scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0)); va1 = make1array (ra1, 1); - if (LBND (ra0, 0) < LBND (va1, 0) || UBND (ra0, 0) > UBND (va1, 0)) + if (LBND (ra0, 0) < 0 /* LBND (va1, 0) */ || UBND (ra0, 0) > UBND (va1, 0)) scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0)); } *plva = scm_cons (va1, SCM_EOL); @@ -223,14 +215,12 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what) static int rafill (SCM dst, SCM fill) { + size_t n = SCM_I_ARRAY_DIMS (dst)->ubnd + 1; + size_t i = SCM_I_ARRAY_BASE (dst); + ssize_t inc = SCM_I_ARRAY_DIMS (dst)->inc; scm_t_array_handle h; - size_t n, i; - ssize_t inc; - scm_array_get_handle (SCM_I_ARRAY_V (dst), &h); - i = SCM_I_ARRAY_BASE (dst); - inc = SCM_I_ARRAY_DIMS (dst)->inc; - n = (SCM_I_ARRAY_DIMS (dst)->ubnd - SCM_I_ARRAY_DIMS (dst)->lbnd + 1); dst = SCM_I_ARRAY_V (dst); + scm_array_get_handle (dst, &h); for (; n-- > 0; i += inc) h.vset (h.vector, i, fill); @@ -254,19 +244,17 @@ SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0, static int racp (SCM src, SCM dst) { - scm_t_array_handle h_s, h_d; - size_t n, i_s, i_d; + size_t i_s, i_d, n; ssize_t inc_s, inc_d; - + scm_t_array_handle h_s, h_d; dst = SCM_CAR (dst); i_s = SCM_I_ARRAY_BASE (src); i_d = SCM_I_ARRAY_BASE (dst); + n = (SCM_I_ARRAY_DIMS (src)->ubnd + 1); inc_s = SCM_I_ARRAY_DIMS (src)->inc; inc_d = SCM_I_ARRAY_DIMS (dst)->inc; - n = (SCM_I_ARRAY_DIMS (src)->ubnd - SCM_I_ARRAY_DIMS (src)->lbnd + 1); src = SCM_I_ARRAY_V (src); dst = SCM_I_ARRAY_V (dst); - scm_array_get_handle (src, &h_s); scm_array_get_handle (dst, &h_d); @@ -309,44 +297,56 @@ SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0, static int ramap (SCM ra0, SCM proc, SCM ras) { + size_t i0 = SCM_I_ARRAY_BASE (ra0); + ssize_t inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; + size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd + 1; scm_t_array_handle h0; - size_t n, i0; - ssize_t i, inc0; - i0 = SCM_I_ARRAY_BASE (ra0); - inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; - i = SCM_I_ARRAY_DIMS (ra0)->lbnd; - n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1; ra0 = SCM_I_ARRAY_V (ra0); scm_array_get_handle (ra0, &h0); + if (scm_is_null (ras)) for (; n--; i0 += inc0) h0.vset (h0.vector, i0, scm_call_0 (proc)); else { SCM ra1 = SCM_CAR (ras); + size_t i1 = SCM_I_ARRAY_BASE (ra1); + ssize_t inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; scm_t_array_handle h1; - size_t i1; - ssize_t inc1; - i1 = SCM_I_ARRAY_BASE (ra1); - inc1 = SCM_I_ARRAY_DIMS (ra1)->inc; - ras = SCM_CDR (ras); ra1 = SCM_I_ARRAY_V (ra1); scm_array_get_handle (ra1, &h1); + ras = SCM_CDR (ras); if (scm_is_null (ras)) for (; n--; i0 += inc0, i1 += inc1) h0.vset (h0.vector, i0, scm_call_1 (proc, h1.vref (h1.vector, i1))); else { - ras = scm_vector (ras); - for (; n--; i0 += inc0, i1 += inc1, ++i) + scm_t_array_handle *hs; + size_t restn = scm_ilength (ras); + + SCM args = SCM_EOL; + SCM *p = &args; + SCM **sa = scm_gc_malloc (sizeof(SCM *) * restn, vi_gc_hint); + for (size_t k = 0; k < restn; ++k) { - SCM args = SCM_EOL; - unsigned long k; - for (k = scm_c_vector_length (ras); k--;) - args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args); - h0.vset (h0.vector, i0, - scm_apply_1 (proc, h1.vref (h1.vector, i1), args)); + *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL); + sa[k] = SCM_CARLOC (*p); + p = SCM_CDRLOC (*p); } + + hs = scm_gc_malloc (sizeof(scm_t_array_handle) * restn, vi_gc_hint); + for (size_t k = 0; k < restn; ++k, ras = scm_cdr (ras)) + scm_array_get_handle (scm_car (ras), hs+k); + + for (ssize_t i = 0; n--; i0 += inc0, i1 += inc1, ++i) + { + for (size_t k = 0; k < restn; ++k) + *(sa[k]) = scm_array_handle_ref (hs+k, i*hs[k].dims[0].inc); + h0.vset (h0.vector, i0, scm_apply_1 (proc, h1.vref (h1.vector, i1), args)); + } + + for (size_t k = 0; k < restn; ++k) + scm_array_handle_release (hs+k); } scm_array_handle_release (&h1); } @@ -383,30 +383,44 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1, static int rafe (SCM ra0, SCM proc, SCM ras) { - ssize_t i = SCM_I_ARRAY_DIMS (ra0)->lbnd; - size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd - i + 1; - + size_t i0 = SCM_I_ARRAY_BASE (ra0); + ssize_t inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; + size_t n = SCM_I_ARRAY_DIMS (ra0)->ubnd + 1; scm_t_array_handle h0; - size_t i0; - ssize_t inc0; - i0 = SCM_I_ARRAY_BASE (ra0); - inc0 = SCM_I_ARRAY_DIMS (ra0)->inc; ra0 = SCM_I_ARRAY_V (ra0); scm_array_get_handle (ra0, &h0); + if (scm_is_null (ras)) for (; n--; i0 += inc0) scm_call_1 (proc, h0.vref (h0.vector, i0)); else { - ras = scm_vector (ras); - for (; n--; i0 += inc0, ++i) + scm_t_array_handle *hs; + size_t restn = scm_ilength (ras); + + SCM args = SCM_EOL; + SCM *p = &args; + SCM **sa = scm_gc_malloc (sizeof(SCM *) * restn, vi_gc_hint); + for (size_t k = 0; k < restn; ++k) { - SCM args = SCM_EOL; - unsigned long k; - for (k = scm_c_vector_length (ras); k--;) - args = scm_cons (AREF (scm_c_vector_ref (ras, k), i), args); + *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL); + sa[k] = SCM_CARLOC (*p); + p = SCM_CDRLOC (*p); + } + + hs = scm_gc_malloc (sizeof(scm_t_array_handle) * restn, vi_gc_hint); + for (size_t k = 0; k < restn; ++k, ras = scm_cdr (ras)) + scm_array_get_handle (scm_car (ras), hs+k); + + for (ssize_t i = 0; n--; i0 += inc0, ++i) + { + for (size_t k = 0; k < restn; ++k) + *(sa[k]) = scm_array_handle_ref (hs+k, i*hs[k].dims[0].inc); scm_apply_1 (proc, h0.vref (h0.vector, i0), args); } + + for (size_t k = 0; k < restn; ++k) + scm_array_handle_release (hs+k); } scm_array_handle_release (&h0); return 1; @@ -444,15 +458,12 @@ static void array_index_map_n (SCM ra, SCM proc) { scm_t_array_handle h; - size_t i; int k, kmax = SCM_I_ARRAY_NDIM (ra) - 1; - ssize_t *vi; - SCM **si; SCM args = SCM_EOL; SCM *p = &args; - vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * (kmax + 1), vi_gc_hint); - si = scm_gc_malloc_pointerless (sizeof(SCM *) * (kmax + 1), vi_gc_hint); + ssize_t *vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * (kmax + 1), vi_gc_hint); + SCM **si = scm_gc_malloc_pointerless (sizeof(SCM *) * (kmax + 1), vi_gc_hint); for (k = 0; k <= kmax; k++) { @@ -470,6 +481,7 @@ array_index_map_n (SCM ra, SCM proc) { if (k == kmax) { + size_t i; vi[kmax] = SCM_I_ARRAY_DIMS (ra)[kmax].lbnd; i = cindk (ra, vi, kmax+1); for (; vi[kmax] <= SCM_I_ARRAY_DIMS (ra)[kmax].ubnd; ++vi[kmax]) diff --git a/libguile/array-map.h b/libguile/array-map.h index e7431b176..cb18a628a 100644 --- a/libguile/array-map.h +++ b/libguile/array-map.h @@ -4,7 +4,7 @@ #define SCM_ARRAY_MAP_H /* Copyright (C) 1995, 1996, 1997, 2000, 2006, 2008, 2009, 2010, - * 2011, 2013 Free Software Foundation, Inc. + * 2011, 2013, 2015 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 License diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test index c8eaf96eb..bd8a434bd 100644 --- a/test-suite/tests/ramap.test +++ b/test-suite/tests/ramap.test @@ -453,11 +453,11 @@ (with-test-prefix "3 sources" (pass-if-equal "noncompact arrays 1" - '((3 3 3) (2 2 2)) + '((3 1 3) (2 0 2)) (let* ((a #2((0 1) (2 3))) (l '()) (rec (lambda args (set! l (cons args l))))) - (array-for-each rec (array-row a 1) (array-row a 1) (array-row a 1)) + (array-for-each rec (array-row a 1) (array-row a 0) (array-row a 1)) l)) (pass-if-equal "noncompact arrays 2" From cd7fee8e657cf21ca5013fd90fd5043105e6a907 Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Wed, 9 Dec 2015 13:10:48 +0100 Subject: [PATCH 627/865] Special case for array-map! with three arguments Benchmark: (define type #t) (define A (make-typed-array 's32 0 10000 1000)) (define B (make-typed-array 's32 0 10000 1000)) (define C (make-typed-array 's32 0 10000 1000)) before: scheme@(guile-user)> ,time (array-map! C + A B) ;; 0.792653s real time, 0.790970s run time. 0.000000s spent in GC. after: scheme@(guile-user)> ,time (array-map! C + A B) ;; 0.598513s real time, 0.597146s run time. 0.000000s spent in GC. * libguile/array-map.c (ramap): Add special case with 3 arguments. --- libguile/array-map.c | 64 +++++++++++++++++++++++++++----------------- 1 file changed, 40 insertions(+), 24 deletions(-) diff --git a/libguile/array-map.c b/libguile/array-map.c index e3af729c8..1f00c92fa 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -321,32 +321,48 @@ ramap (SCM ra0, SCM proc, SCM ras) h0.vset (h0.vector, i0, scm_call_1 (proc, h1.vref (h1.vector, i1))); else { - scm_t_array_handle *hs; - size_t restn = scm_ilength (ras); - - SCM args = SCM_EOL; - SCM *p = &args; - SCM **sa = scm_gc_malloc (sizeof(SCM *) * restn, vi_gc_hint); - for (size_t k = 0; k < restn; ++k) + SCM ra2 = SCM_CAR (ras); + size_t i2 = SCM_I_ARRAY_BASE (ra2); + ssize_t inc2 = SCM_I_ARRAY_DIMS (ra2)->inc; + scm_t_array_handle h2; + ra2 = SCM_I_ARRAY_V (ra2); + scm_array_get_handle (ra2, &h2); + ras = SCM_CDR (ras); + if (scm_is_null (ras)) + for (; n--; i0 += inc0, i1 += inc1, i2 += inc2) + h0.vset (h0.vector, i0, scm_call_2 (proc, h1.vref (h1.vector, i1), h2.vref (h2.vector, i2))); + else { - *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL); - sa[k] = SCM_CARLOC (*p); - p = SCM_CDRLOC (*p); + scm_t_array_handle *hs; + size_t restn = scm_ilength (ras); + SCM args = SCM_EOL; + SCM *p = &args; + SCM **sa = scm_gc_malloc (sizeof(SCM *) * restn, vi_gc_hint); + size_t k; + ssize_t i; + + for (k = 0; k < restn; ++k) + { + *p = scm_cons (SCM_UNSPECIFIED, SCM_EOL); + sa[k] = SCM_CARLOC (*p); + p = SCM_CDRLOC (*p); + } + + hs = scm_gc_malloc (sizeof(scm_t_array_handle) * restn, vi_gc_hint); + for (k = 0; k < restn; ++k, ras = scm_cdr (ras)) + scm_array_get_handle (scm_car (ras), hs+k); + + for (i = 0; n--; i0 += inc0, i1 += inc1, i2 += inc2, ++i) + { + for (k = 0; k < restn; ++k) + *(sa[k]) = scm_array_handle_ref (hs+k, i*hs[k].dims[0].inc); + h0.vset (h0.vector, i0, scm_apply_2 (proc, h1.vref (h1.vector, i1), h2.vref (h2.vector, i2), args)); + } + + for (k = 0; k < restn; ++k) + scm_array_handle_release (hs+k); } - - hs = scm_gc_malloc (sizeof(scm_t_array_handle) * restn, vi_gc_hint); - for (size_t k = 0; k < restn; ++k, ras = scm_cdr (ras)) - scm_array_get_handle (scm_car (ras), hs+k); - - for (ssize_t i = 0; n--; i0 += inc0, i1 += inc1, ++i) - { - for (size_t k = 0; k < restn; ++k) - *(sa[k]) = scm_array_handle_ref (hs+k, i*hs[k].dims[0].inc); - h0.vset (h0.vector, i0, scm_apply_1 (proc, h1.vref (h1.vector, i1), args)); - } - - for (size_t k = 0; k < restn; ++k) - scm_array_handle_release (hs+k); + scm_array_handle_release (&h2); } scm_array_handle_release (&h1); } From 7b6d854cf1b9e4bc5c85497fc0709210978e5a32 Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Wed, 25 Feb 2015 09:47:40 +0100 Subject: [PATCH 628/865] Do not use array handles in scm_vector * libguile/vectors.c (scm_vector): Use SCM_I_VECTOR_WELTS on new vector instead of generic scm_vector_elements; cf. scm_vector_copy(). (scm_vector_elements): Forward to scm_vector_writable_elements(). (scm_vector_writable_elements): Remove special error message for weak vector arg. * libguile/generalized-vectors.c (SCM_VALIDATE_VECTOR_WITH_HANDLE): Remove unused macro. * libguile/array-handle.c (scm_array_handle_elements): Forward to scm_array_handle_writable_elements(). --- libguile/array-handle.c | 4 +--- libguile/generalized-vectors.c | 5 ----- libguile/vectors.c | 19 ++++--------------- 3 files changed, 5 insertions(+), 23 deletions(-) diff --git a/libguile/array-handle.c b/libguile/array-handle.c index 3595266ff..89277d9d6 100644 --- a/libguile/array-handle.c +++ b/libguile/array-handle.c @@ -320,9 +320,7 @@ scm_array_handle_release (scm_t_array_handle *h) const SCM * scm_array_handle_elements (scm_t_array_handle *h) { - if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM) - scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array"); - return ((const SCM*)h->elements) + h->base; + return scm_array_handle_writable_elements (h); } SCM * diff --git a/libguile/generalized-vectors.c b/libguile/generalized-vectors.c index 0fe8b897c..276b9d865 100644 --- a/libguile/generalized-vectors.c +++ b/libguile/generalized-vectors.c @@ -69,11 +69,6 @@ SCM_DEFINE (scm_make_generalized_vector, "make-generalized-vector", 2, 1, 0, } #undef FUNC_NAME - -#define SCM_VALIDATE_VECTOR_WITH_HANDLE(pos, val, handle) \ - scm_generalized_vector_get_handle (val, handle) - - void scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h) { diff --git a/libguile/vectors.c b/libguile/vectors.c index 7ee7898c5..b9613c50f 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -58,23 +58,15 @@ const SCM * scm_vector_elements (SCM vec, scm_t_array_handle *h, size_t *lenp, ssize_t *incp) { - if (SCM_I_WVECTP (vec)) - scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector"); - - scm_generalized_vector_get_handle (vec, h); - if (lenp) - { - scm_t_array_dim *dim = scm_array_handle_dims (h); - *lenp = dim->ubnd - dim->lbnd + 1; - *incp = dim->inc; - } - return scm_array_handle_elements (h); + /* guard against weak vectors in the next call */ + return scm_vector_writable_elements (vec, h, lenp, incp); } SCM * scm_vector_writable_elements (SCM vec, scm_t_array_handle *h, size_t *lenp, ssize_t *incp) { + /* it's unsafe to access the memory of a weak vector */ if (SCM_I_WVECTP (vec)) scm_wrong_type_arg_msg (NULL, 0, vec, "non-weak vector"); @@ -140,12 +132,11 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1, SCM res; SCM *data; long i, len; - scm_t_array_handle handle; SCM_VALIDATE_LIST_COPYLEN (1, l, len); res = scm_c_make_vector (len, SCM_UNSPECIFIED); - data = scm_vector_writable_elements (res, &handle, NULL, NULL); + data = SCM_I_VECTOR_WELTS (res); i = 0; while (scm_is_pair (l) && i < len) { @@ -154,8 +145,6 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1, i += 1; } - scm_array_handle_release (&handle); - return res; } #undef FUNC_NAME From d1435ea6bdaa3c56d7f025f13d1e7d78c4d9b748 Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Wed, 11 Feb 2015 16:44:21 +0100 Subject: [PATCH 629/865] New functions array-from, array-from*, array-amend! * libguile/arrays.h (scm_array_from, scm_array_from_s, scm_array_amend_x): New declarations. * libguile/arrays.c (scm_array_from, scm_array_from_s, scm_array_amend_x): New functions, export as array-from, array-from*, array-amend!. * test-suite/tests/arrays.test: Tests for array-from, array-from*, array-amend!. Replace with-test-prefix/c&e with with-test-prefix where the array read syntax isn't used. --- libguile/arrays.c | 173 ++++++++++++++++++++++++++++++++++- libguile/arrays.h | 6 ++ test-suite/tests/arrays.test | 115 ++++++++++++++++++++++- 3 files changed, 290 insertions(+), 4 deletions(-) diff --git a/libguile/arrays.c b/libguile/arrays.c index b8307d528..395bb6723 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -28,7 +28,6 @@ #include #include #include -#include #include "verify.h" @@ -474,6 +473,178 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, #undef FUNC_NAME +static void +array_from_pos (scm_t_array_handle *handle, size_t *ndim, size_t *k, SCM *i, ssize_t *pos, + scm_t_array_dim **s, char const * FUNC_NAME, SCM error_args) +{ + *s = scm_array_handle_dims (handle); + *k = *ndim = scm_array_handle_rank (handle); + for (; *k>0 && scm_is_pair (*i); --*k, ++*s, *i=scm_cdr (*i)) + { + ssize_t ik = scm_to_ssize_t (scm_car (*i)); + if (ik<(*s)->lbnd || ik>(*s)->ubnd) + { + scm_array_handle_release (handle); + scm_misc_error (FUNC_NAME, "indices out of range", error_args); + } + *pos += (ik-(*s)->lbnd) * (*s)->inc; + } +} + +static void +array_from_get_o (scm_t_array_handle *handle, size_t k, scm_t_array_dim *s, ssize_t pos, + SCM *o) +{ + scm_t_array_dim * os; + *o = scm_i_make_array (k); + SCM_I_ARRAY_SET_V (*o, handle->vector); + SCM_I_ARRAY_SET_BASE (*o, pos + handle->base); + os = SCM_I_ARRAY_DIMS (*o); + for (; k>0; --k, ++s, ++os) + { + os->ubnd = s->ubnd; + os->lbnd = s->lbnd; + os->inc = s->inc; + } +} + +SCM_DEFINE (scm_array_from_s, "array-from*", 1, 0, 1, + (SCM ra, SCM indices), + "Return the array slice @var{ra}[@var{indices} ..., ...]\n" + "The rank of @var{ra} must equal to the number of indices or larger.\n\n" + "See also @code{array-ref}, @code{array-from}, @code{array-amend!}.\n\n" + "@code{array-from*} may return a rank-0 array. For example:\n" + "@lisp\n" + "(array-from* #2((1 2 3) (4 5 6)) 1 1) @result{} #0(5)\n" + "(array-from* #2((1 2 3) (4 5 6)) 1) @result{} #(4 5 6)\n" + "(array-from* #2((1 2 3) (4 5 6))) @result{} #2((1 2 3) (4 5 6))\n" + "(array-from* #0(5) @result{} #0(5).\n" + "@end lisp") +#define FUNC_NAME s_scm_array_from_s +{ + SCM o, i = indices; + size_t ndim, k; + ssize_t pos = 0; + scm_t_array_handle handle; + scm_t_array_dim *s; + scm_array_get_handle (ra, &handle); + array_from_pos (&handle, &ndim, &k, &i, &pos, &s, FUNC_NAME, scm_list_2 (ra, indices)); + if (k==ndim) + o = ra; + else if (scm_is_null (i)) + { + array_from_get_o(&handle, k, s, pos, &o); + } + else + { + scm_array_handle_release (&handle); + scm_misc_error(FUNC_NAME, "too many indices", scm_list_2 (ra, indices)); + } + scm_array_handle_release (&handle); + return o; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_array_from, "array-from", 1, 0, 1, + (SCM ra, SCM indices), + "Return the element at the @code{(@var{indices} ...)} position\n" + "in array @var{ra}, or the array slice @var{ra}[@var{indices} ..., ...]\n" + "if the rank of @var{ra} is larger than the number of indices.\n\n" + "See also @code{array-ref}, @code{array-from*}, @code{array-amend!}.\n\n" + "@code{array-from} never returns a rank 0 array. For example:\n" + "@lisp\n" + "(array-from #2((1 2 3) (4 5 6)) 1 1) @result{} 5\n" + "(array-from #2((1 2 3) (4 5 6)) 1) @result{} #(4 5 6)\n" + "(array-from #2((1 2 3) (4 5 6))) @result{} #2((1 2 3) (4 5 6))\n" + "(array-from #0(5) @result{} 5.\n" + "@end lisp") +#define FUNC_NAME s_scm_array_from +{ + SCM o, i = indices; + size_t ndim, k; + ssize_t pos = 0; + scm_t_array_handle handle; + scm_t_array_dim *s; + scm_array_get_handle (ra, &handle); + array_from_pos (&handle, &ndim, &k, &i, &pos, &s, FUNC_NAME, scm_list_2 (ra, indices)); + if (k>0) + { + if (k==ndim) + o = ra; + else + array_from_get_o(&handle, k, s, pos, &o); + } + else if (scm_is_null(i)) + o = scm_array_handle_ref (&handle, pos); + else + { + scm_array_handle_release (&handle); + scm_misc_error(FUNC_NAME, "too many indices", scm_list_2 (ra, indices)); + } + scm_array_handle_release (&handle); + return o; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_array_amend_x, "array-amend!", 2, 0, 1, + (SCM ra, SCM b, SCM indices), + "Set the array slice @var{ra}[@var{indices} ..., ...] to @var{b}\n." + "Equivalent to @code{(array-copy! @var{b} (apply array-from @var{ra} @var{indices}))}\n" + "if the number of indices is smaller than the rank of @var{ra}; otherwise\n" + "equivalent to @code{(apply array-set! @var{ra} @var{b} @var{indices})}.\n" + "This function returns the modified array @var{ra}.\n\n" + "See also @code{array-ref}, @code{array-from}, @code{array-from*}.\n\n" + "For example:\n" + "@lisp\n" + "(define A (list->array 2 '((1 2 3) (4 5 6))))\n" + "(array-amend! A #0(99) 1 1) @result{} #2((1 2 3) (4 #0(99) 6))\n" + "(array-amend! A 99 1 1) @result{} #2((1 2 3) (4 99 6))\n" + "(array-amend! A #(a b c) 0) @result{} #2((a b c) (4 99 6))\n" + "(array-amend! A #2((x y z) (9 8 7))) @result{} #2((x y z) (9 8 7))\n\n" + "(define B (make-array 0))\n" + "(array-amend! B 15) @result{} #0(15)\n" + "@end lisp") +#define FUNC_NAME s_scm_array_amend_x +{ + SCM o, i = indices; + size_t ndim, k; + ssize_t pos = 0; + scm_t_array_handle handle; + scm_t_array_dim *s; + scm_array_get_handle (ra, &handle); + array_from_pos (&handle, &ndim, &k, &i, &pos, &s, FUNC_NAME, scm_list_3 (ra, b, indices)); + if (k>0) + { + if (k==ndim) + o = ra; + else + array_from_get_o(&handle, k, s, pos, &o); + scm_array_handle_release(&handle); + /* an error is still possible here if o and b don't match. */ + /* FIXME copying like this wastes the handle, and the bounds matching + behavior of array-copy! is not strict. */ + scm_array_copy_x(b, o); + } + else if (scm_is_null(i)) + { + scm_array_handle_set (&handle, pos, b); /* ra may be non-ARRAYP */ + scm_array_handle_release (&handle); + } + else + { + scm_array_handle_release (&handle); + scm_misc_error(FUNC_NAME, "too many indices", scm_list_3 (ra, b, indices)); + } + return ra; +} +#undef FUNC_NAME + + +#undef ARRAY_FROM_GET_O + + /* args are RA . DIMS */ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, (SCM ra, SCM args), diff --git a/libguile/arrays.h b/libguile/arrays.h index a5cd43dc2..977d30760 100644 --- a/libguile/arrays.h +++ b/libguile/arrays.h @@ -43,12 +43,18 @@ SCM_API SCM scm_make_typed_array (SCM type, SCM fill, SCM bounds); SCM_API SCM scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes, size_t byte_len); + SCM_API SCM scm_shared_array_root (SCM ra); SCM_API SCM scm_shared_array_offset (SCM ra); SCM_API SCM scm_shared_array_increments (SCM ra); + SCM_API SCM scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims); SCM_API SCM scm_transpose_array (SCM ra, SCM args); SCM_API SCM scm_array_contents (SCM ra, SCM strict); +SCM_API SCM scm_array_from_s (SCM ra, SCM indices); +SCM_API SCM scm_array_from (SCM ra, SCM indices); +SCM_API SCM scm_array_amend_x (SCM ra, SCM b, SCM indices); + SCM_API SCM scm_list_to_array (SCM ndim, SCM lst); SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst); diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test index 4e26f4c43..57c5cef3e 100644 --- a/test-suite/tests/arrays.test +++ b/test-suite/tests/arrays.test @@ -296,6 +296,115 @@ (and (eqv? 5 (array-ref s2 1)) (eqv? 8 (array-ref s2 2)))))) + +;;; +;;; array-from* +;;; + +(with-test-prefix/c&e "array-from*" + + (pass-if "vector I" + (let ((v (vector 1 2 3))) + (array-fill! (array-from* v 1) 'a) + (array-equal? v #(1 a 3)))) + + (pass-if "vector II" + (let ((v (vector 1 2 3))) + (array-copy! #(a b c) (array-from* v)) + (array-equal? v #(a b c)))) + + (pass-if "array I" + (let ((a (list->array 2 '((1 2 3) (4 5 6))))) + (array-fill! (array-from* a 1 1) 'a) + (array-equal? a #2((1 2 3) (4 a 6))))) + + (pass-if "array II" + (let ((a (list->array 2 '((1 2 3) (4 5 6))))) + (array-copy! #(a b c) (array-from* a 1)) + (array-equal? a #2((1 2 3) (a b c))))) + + (pass-if "array III" + (let ((a (list->array 2 '((1 2 3) (4 5 6))))) + (array-copy! #2((a b c) (x y z)) (array-from* a)) + (array-equal? a #2((a b c) (x y z))))) + + (pass-if "rank 0 array" + (let ((a (make-array 77))) + (array-fill! (array-from* a) 'a) + (array-equal? a #0(a))))) + + +;;; +;;; array-from +;;; + +(with-test-prefix/c&e "array-from" + + (pass-if "vector I" + (let ((v (vector 1 2 3))) + (equal? 2 (array-from v 1)))) + + (pass-if "vector II" + (let ((v (vector 1 2 3))) + (array-copy! #(a b c) (array-from v)) + (array-equal? v #(a b c)))) + + (pass-if "array I" + (let ((a (list->array 2 '((1 2 3) (4 5 6))))) + (equal? 5 (array-from a 1 1)))) + + (pass-if "array II" + (let ((a (list->array 2 '((1 2 3) (4 5 6))))) + (array-copy! #(a b c) (array-from a 1)) + (array-equal? a #2((1 2 3) (a b c))))) + + (pass-if "array III" + (let ((a (list->array 2 '((1 2 3) (4 5 6))))) + (array-copy! #2((a b c) (x y z)) (array-from a)) + (array-equal? a #2((a b c) (x y z))))) + + (pass-if "rank 0 array" + (let ((a (make-array 77))) + (equal? (array-from a) 77)))) + + +;;; +;;; array-amend! +;;; + +(with-test-prefix/c&e "array-amend!" + + (pass-if "vector I" + (let ((v (vector 1 2 3))) + (and (eq? v (array-amend! v 'x 1)) + (array-equal? v #(1 x 3))))) + + (pass-if "vector II" + (let ((v (vector 1 2 3))) + (and (eq? v (array-amend! (array-from v) #(a b c))) + (array-equal? v #(a b c))))) + + (pass-if "array I" + (let ((a (list->array 2 '((1 2 3) (4 5 6))))) + (and (eq? a (array-amend! a 'x 1 1)) + (array-equal? a #2((1 2 3) (4 x 6)))))) + + (pass-if "array II" + (let ((a (list->array 2 '((1 2 3) (4 5 6))))) + (and (eq? a (array-amend! a #(a b c) 1)) + (array-equal? a #2((1 2 3) (a b c)))))) + + (pass-if "array III" + (let ((a (list->array 2 '((1 2 3) (4 5 6))))) + (and (eq? a (array-amend! a #2((a b c) (x y z)))) + (array-equal? a #2((a b c) (x y z)))))) + + (pass-if "rank 0 array" + (let ((a (make-array 77))) + (and (eq? a (array-amend! a 99)) + (array-equal? a #0(99)))))) + + ;;; ;;; array-contents ;;; @@ -436,7 +545,7 @@ ;;; shared-array-increments ;;; -(with-test-prefix/c&e "shared-array-increments" +(with-test-prefix "shared-array-increments" (pass-if "plain vector" (equal? '(1) (shared-array-increments (make-vector 4 0)))) @@ -595,7 +704,7 @@ ;;; array-in-bounds? ;;; -(with-test-prefix/c&e "array-in-bounds?" +(with-test-prefix "array-in-bounds?" (pass-if (let ((a (make-array #f '(425 425)))) (eq? #f (array-in-bounds? a 0))))) @@ -606,7 +715,7 @@ (with-test-prefix "array-type" - (with-test-prefix/c&e "on make-foo-vector" + (with-test-prefix "on make-foo-vector" (pass-if "bool" (eq? 'b (array-type (make-bitvector 1)))) From 7ef9d0ac2bd7af119212d659e94906ae9aa93a8f Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Tue, 8 Sep 2015 16:57:30 +0200 Subject: [PATCH 630/865] New functions (array-for-each-cell, array-for-each-cell-in-order) * libguile/array-map.c (scm_i_array_rebase, scm_array_for_each_cell): New functions. Export scm_array_for_each_cell() as (array-for-each-cell). (array-for-each-cell-in-order): Define additional export. * libguile/array-map.h (scm_i_array_rebase, scm_array_for_each_cell): Add prototypes. * test-suite/tests/array-map.test: Renamed from test-suite/tests/ramap.test, fix module name. Add tests for (array-for-each-cell). * test-suite/Makefile.am: Apply rename array-map.test -> ramap.test. --- libguile/array-map.c | 260 +++++++++++++++++- libguile/array-map.h | 4 + test-suite/Makefile.am | 2 +- .../tests/{ramap.test => array-map.test} | 35 ++- 4 files changed, 296 insertions(+), 5 deletions(-) rename test-suite/tests/{ramap.test => array-map.test} (94%) diff --git a/libguile/array-map.c b/libguile/array-map.c index 1f00c92fa..19e85c369 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -41,7 +41,7 @@ #include "libguile/validate.h" #include "libguile/array-map.h" - +#include /* The WHAT argument for `scm_gc_malloc ()' et al. */ static const char vi_gc_hint[] = "array-indices"; @@ -628,7 +628,8 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1, return SCM_BOOL_T; while (!scm_is_null (rest)) - { if (scm_is_false (scm_array_equal_p (ra0, ra1))) + { + if (scm_is_false (scm_array_equal_p (ra0, ra1))) return SCM_BOOL_F; ra0 = ra1; ra1 = scm_car (rest); @@ -639,6 +640,261 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1, #undef FUNC_NAME +/* Copy array descriptor with different base. */ +SCM +scm_i_array_rebase (SCM a, size_t base) +{ + size_t ndim = SCM_I_ARRAY_NDIM (a); + SCM b = scm_words (((scm_t_bits) ndim << 17) + scm_tc7_array, 3 + ndim*3); + SCM_I_ARRAY_SET_V (b, SCM_I_ARRAY_V (a)); +/* FIXME do check base */ + SCM_I_ARRAY_SET_BASE (b, base); + memcpy (SCM_I_ARRAY_DIMS (b), SCM_I_ARRAY_DIMS (a), sizeof (scm_t_array_dim)*ndim); + return b; +} + +static inline size_t padtoptr(size_t d) { return (d + (sizeof (void *) - 1)) & ~(sizeof (void *) - 1); } + +SCM_DEFINE (scm_array_for_each_cell, "array-for-each-cell", 2, 0, 1, + (SCM frame_rank, SCM op, SCM args), + "Apply @var{op} to each of the cells of rank rank(@var{arg})-@var{frame_rank}\n" + "of the arrays @var{args}, in unspecified order. The first\n" + "@var{frame_rank} dimensions of each @var{arg} must match.\n" + "Rank-0 cells are passed as rank-0 arrays.\n\n" + "The value returned is unspecified.\n\n" + "For example:\n" + "@lisp\n" + ";; Sort the rows of rank-2 array A.\n\n" + "(array-for-each-cell 1 (lambda (x) (sort! x <)) a)\n" + "\n" + ";; Compute the arguments of the (x y) vectors in the rows of rank-2\n" + ";; array XYS and store them in rank-1 array ANGLES. Inside OP,\n" + ";; XY is a rank-1 (2-1) array, and ANGLE is a rank-0 (1-1) array.\n\n" + "(array-for-each-cell 1 \n" + " (lambda (xy angle)\n" + " (array-set! angle (atan (array-ref xy 1) (array-ref xy 0))))\n" + " xys angles)\n" + "@end lisp") +#define FUNC_NAME s_scm_array_for_each_cell +{ + int const N = scm_ilength (args); + int const frank = scm_to_int (frame_rank); + int ocd; + ssize_t step; + SCM dargs_ = SCM_EOL; + char const * msg; + scm_t_array_dim * ais; + int n, k; + ssize_t z; + + /* to be allocated inside the pool */ + scm_t_array_handle * ah; + SCM * args_; + scm_t_array_dim ** as; + int * rank; + + ssize_t * s; + SCM * ai; + SCM ** dargs; + ssize_t * i; + + int * order; + size_t * base; + + /* size the pool */ + char * pool; + char * pool0; + size_t pool_size = 0; + pool_size += padtoptr(N*sizeof (scm_t_array_handle)); + pool_size += padtoptr(N*sizeof (SCM)); + pool_size += padtoptr(N*sizeof (scm_t_array_dim *)); + pool_size += padtoptr(N*sizeof (int)); + + pool_size += padtoptr(frank*sizeof (ssize_t)); + pool_size += padtoptr(N*sizeof (SCM)); + pool_size += padtoptr(N*sizeof (SCM *)); + pool_size += padtoptr(frank*sizeof (ssize_t)); + + pool_size += padtoptr(frank*sizeof (int)); + pool_size += padtoptr(N*sizeof (size_t)); + pool = scm_gc_malloc (pool_size, "pool"); + + /* place the items in the pool */ +#define AFIC_ALLOC_ADVANCE(pool, count, type, name) \ + name = (void *)pool; \ + pool += padtoptr(count*sizeof (type)); + + pool0 = pool; + AFIC_ALLOC_ADVANCE (pool, N, scm_t_array_handle, ah); + AFIC_ALLOC_ADVANCE (pool, N, SCM, args_); + AFIC_ALLOC_ADVANCE (pool, N, scm_t_array_dim *, as); + AFIC_ALLOC_ADVANCE (pool, N, int, rank); + + AFIC_ALLOC_ADVANCE (pool, frank, ssize_t, s); + AFIC_ALLOC_ADVANCE (pool, N, SCM, ai); + AFIC_ALLOC_ADVANCE (pool, N, SCM *, dargs); + AFIC_ALLOC_ADVANCE (pool, frank, ssize_t, i); + + AFIC_ALLOC_ADVANCE (pool, frank, int, order); + AFIC_ALLOC_ADVANCE (pool, N, size_t, base); + assert((pool0+pool_size==pool) && "internal error"); +#undef AFIC_ALLOC_ADVANCE + + for (n=0; scm_is_pair(args); args=scm_cdr(args), ++n) + { + args_[n] = scm_car(args); + scm_array_get_handle(args_[n], ah+n); + as[n] = scm_array_handle_dims(ah+n); + rank[n] = scm_array_handle_rank(ah+n); + } + /* checks */ + msg = NULL; + if (frank<0) + msg = "bad frame rank"; + else + { + for (n=0; n!=N; ++n) + { + if (rank[n]array 2 '((9 1 3) (7 8 2))))) + (array-for-each-cell 1 (lambda (a) (sort! a <)) a) + a)) + + (pass-if-equal "2 arguments frame rank 1" + #f64(8 -1) + (let* ((x (list->typed-array 'f64 2 '((9 1) (7 8)))) + (y (f64vector 99 99))) + (array-for-each-cell 1 (lambda (y x) (array-set! y (- (array-ref x 0) (array-ref x 1)))) y x) + y)) + + (pass-if-equal "regression: zero-sized frame loop without unrolling" + 99 + (let* ((x 99) + (o (make-array 0. 0 3 2))) + (array-for-each-cell 2 + (lambda (o a0 a1) + (set! x 0)) + o + (make-shared-array (make-array 1. 0 1) (const '(0 0)) 0 3) + (make-array 2. 0 3)) + x))) From 0bd7562c961223cd70e772bac8b7ae21b34f1aed Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Wed, 23 Nov 2016 11:26:22 +0100 Subject: [PATCH 631/865] Document new array functions, with provisional names * doc/ref/api-data.texi: New section 'Arrays as arrays of arrays'. Document array-from, array-from*, array-amend!, array-for-each-cell, array-for-each-cell-in-order. --- doc/ref/api-data.texi | 165 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 165 insertions(+) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 6862ef3ab..58e9f435f 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -7199,6 +7199,7 @@ dimensional arrays. * Array Syntax:: * Array Procedures:: * Shared Arrays:: +* Arrays as arrays of arrays:: * Accessing Arrays from C:: @end menu @@ -7757,6 +7758,170 @@ have smaller rank than @var{array}. @end lisp @end deffn +@node Arrays as arrays of arrays +@subsubsection Arrays as arrays of arrays + +The functions in this section allow you to treat an array of rank +@math{n} as an array of lower rank @math{n-k} where the elements are +themselves arrays (`cells') of rank @math{k}. This replicates some of +the functionality of `enclosed arrays', a feature of old Guile that was +removed before @w{version 2.0}. However, these functions do not require +a special type and operate on any array. + +When we operate on an array in this way, we speak of the first @math{k} +dimensions of the array as the @math{k}-`frame' of the array, while the +last @math{n-k} dimensions are the dimensions of the +@math{n-k}-`cell'. For example, a 2D-array (a matrix) can be seen as a +1D array of rows. In this case, the rows are the 1-cells of the array. + +@deffn {Scheme Procedure} array-from array idx @dots{} +@deffnx {C Function} scm_array_from (array, idxlist) +If the length of @var{idxlist} equals the rank @math{n} of +@var{array}, return the element at @code{(idx @dots{})}, just like +@code{(array-ref array idx @dots{})}. If, however, the length @math{k} +of @var{idxlist} is shorter than @math{n}, then return the shared +@math{(n-k)}-rank cell of @var{array} given by @var{idxlist}. + +For example: + +@lisp +(array-from #2((a b) (c d)) 0) @result{} #(a b) +(array-from #2((a b) (c d)) 1) @result{} #(c d) +(array-from #2((a b) (c d)) 1 1) @result{} d +(array-from #2((a b) (c d))) @result{} #2((a b) (c d)) +@end lisp + +@code{(apply array-from array indices)} is equivalent to + +@lisp +(let ((len (length indices))) + (if (= (array-rank a) len) + (apply array-ref a indices) + (apply make-shared-array a + (lambda t (append indices t)) + (drop (array-dimensions a) len)))) +@end lisp + +The name `from' comes from the J language. +@end deffn + +@deffn {Scheme Procedure} array-from* array idx @dots{} +@deffnx {C Function} scm_array_from_s (array, idxlist) +Like @code{(array-from array idx @dots{})}, but return a 0-rank shared +array if the length of @var{idxlist} matches the rank of +@var{array}. This can be useful when using @var{ARRAY} as a place to +write into. + +Compare: + +@lisp +(array-from #2((a b) (c d)) 1 1) @result{} d +(array-from* #2((a b) (c d)) 1) @result{} #0(d) +(define a (make-array 'a 2 2)) +(array-fill! (array-from* a 1 1) 'b) +a @result{} #2((a a) (a b)). +(array-fill! (array-from a 1 1) 'b) @result{} error: not an array +@end lisp + +@code{(apply array-from* array indices)} is equivalent to + +@lisp +(apply make-shared-array a + (lambda t (append indices t)) + (drop (array-dimensions a) (length indices))) +@end lisp +@end deffn + + +@deffn {Scheme Procedure} array-amend! array x idx @dots{} +@deffnx {C Function} scm_array_amend_x (array, x, idxlist) +If the length of @var{idxlist} equals the rank @math{n} of +@var{array}, set the element at @code{(idx @dots{})} of @var{array} to +@var{x}, just like @code{(array-set! array x idx @dots{})}. If, +however, the length @math{k} of @var{idxlist} is shorter than +@math{n}, then copy the @math{(n-k)}-rank array @var{x} +into the @math{(n-k)}-cell of @var{array} given by +@var{idxlist}. In this case, the last @math{(n-k)} dimensions of +@var{array} and the dimensions of @var{x} must match exactly. + +This function returns the modified @var{array}. + +For example: + +@lisp +(array-amend! (make-array 'a 2 2) b 1 1) @result{} #2((a a) (a b)) +(array-amend! (make-array 'a 2 2) #(x y) 1) @result{} #2((a a) (x y)) +@end lisp + +Note that @code{array-amend!} will expect elements, not arrays, when the +destination has rank 0. One can work around this using +@code{array-from*} instead. + +@lisp +(array-amend! (make-array 'a 2 2) #0(b) 1 1) @result{} #2((a a) (a #0(b))) +(let ((a (make-array 'a 2 2))) (array-copy! #0(b) (array-from* a 1 1)) a) @result{} #2((a a) (a b)) +@end lisp + +@code{(apply array-amend! array x indices)} is equivalent to + +@lisp +(let ((len (length indices))) + (if (= (array-rank array) len) + (apply array-set! array x indices) + (array-copy! x (apply array-from array indices))) + array) +@end lisp + +The name `amend' comes from the J language. +@end deffn + + +@deffn {Scheme Procedure} array-for-each-cell frame-rank op x @dots{} +@deffnx {C Function} scm_array_for_each_cell (array, frame_rank, op, xlist) +Each @var{x} must be an array of rank ≥ @var{frame-rank}, and +the first @var{frame-rank} dimensions of each @var{x} must all be the +same. @var{array-for-each-cell} calls @var{op} with each set of +(rank(@var{x}) - @var{frame-rank})-cells from @var{x}, in unspecified order. + +@var{array-for-each-cell} allows you to loop over cells of any rank +without having to carry an index list or construct slices manually. The +cells passed to @var{op} are shared arrays of @var{X} so it is possible +to write to them. + +This function returns an unspecified value. + +For example, to sort the rows of rank-2 array @code{a}: + +@lisp +(array-for-each-cell 1 (lambda (x) (sort! x <)) a) +@end lisp + +As another example, let @code{a} be a rank-2 array where each row is a 2-vector @math{(x,y)}. +Let's compute the arguments of these vectors and store them in rank-1 array @code{b}. +@lisp +(array-for-each-cell 1 + (lambda (a b) + (array-set! b (atan (array-ref a 1) (array-ref a 0)))) + a b) +@end lisp + +@code{(apply array-for-each-cell frame-rank op x)} is functionally +equivalent to + +@lisp +(let ((frame (take (array-dimensions (car x)) frank))) + (unless (every (lambda (x) + (equal? frame (take (array-dimensions x) frank))) + (cdr x)) + (error)) + (array-index-map! + (apply make-shared-array (make-array #t) (const '()) frame) + (lambda i (apply op (map (lambda (x) (apply array-from* x i)) x))))) +@end lisp + +@end deffn + + @node Accessing Arrays from C @subsubsection Accessing Arrays from C From fa4a22971a122e30e6b167bfe7ac209d02ffafc4 Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Fri, 18 Nov 2016 16:23:05 +0100 Subject: [PATCH 632/865] Deprecate scm_from_contiguous_array scm_from_contiguous_array() was undocumented, unused within Guile, and can be replaced by make-array + array-copy! without requiring contiguity and without loss of performance. * libguile/arrays.c (scm_array_contents): Do not rely on SCM_I_ARRAY_CONTP. * test-suite/tests/arrays.test: Test array-contents with 0-rank array. * libguile/arrays.h: Declare scm_i_shap2ra(), SCM_SET_ARRAY_CONTIGUOUS_FLAG, SCM_CLR_ARRAY_CONTIGUOUS_FLAG so that scm_from_contiguous_array() can keep using them. * libguile/deprecated.c (scm_from_contiguous_array): Move here from arrays.c. * libguile/deprecated.h (scm_from_contiguous_array): Deprecate. * NEWS: Add deprecation notice. --- libguile/arrays.c | 91 ++++++++++++------------------------ libguile/arrays.h | 10 ++-- libguile/deprecated.c | 40 ++++++++++++++++ libguile/deprecated.h | 10 ++++ test-suite/tests/arrays.test | 6 +++ 5 files changed, 93 insertions(+), 64 deletions(-) diff --git a/libguile/arrays.c b/libguile/arrays.c index 395bb6723..b17c415c2 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -56,12 +56,6 @@ #include "libguile/uniform.h" -#define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \ - (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | (SCM_I_ARRAY_FLAG_CONTIGUOUS << 16))) -#define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \ - (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16))) - - size_t scm_c_array_rank (SCM array) { @@ -155,7 +149,7 @@ static char s_bad_spec[] = "Bad scm_array dimension"; /* Increments will still need to be set. */ -static SCM +SCM scm_i_shap2ra (SCM args) { scm_t_array_dim *s; @@ -289,41 +283,6 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes, } #undef FUNC_NAME -SCM -scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len) -#define FUNC_NAME "scm_from_contiguous_array" -{ - size_t k, rlen = 1; - scm_t_array_dim *s; - SCM ra; - scm_t_array_handle h; - - ra = scm_i_shap2ra (bounds); - SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); - s = SCM_I_ARRAY_DIMS (ra); - k = SCM_I_ARRAY_NDIM (ra); - - while (k--) - { - s[k].inc = rlen; - SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1); - rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; - } - if (rlen != len) - SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL); - - SCM_I_ARRAY_SET_V (ra, scm_c_make_vector (rlen, SCM_UNDEFINED)); - scm_array_get_handle (ra, &h); - memcpy (h.writable_elements, elts, rlen * sizeof(SCM)); - scm_array_handle_release (&h); - - if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra)) - if (0 == s->lbnd) - return SCM_I_ARRAY_V (ra); - return ra; -} -#undef FUNC_NAME - SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1, (SCM fill, SCM bounds), "Create and return an array.") @@ -333,6 +292,7 @@ SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1, } #undef FUNC_NAME +/* see scm_from_contiguous_array */ static void scm_i_ra_set_contp (SCM ra) { @@ -757,31 +717,38 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, "@code{make-array} and @code{make-uniform-array} may be unrolled,\n" "some arrays made by @code{make-shared-array} may not be. If\n" "the optional argument @var{strict} is provided, a shared array\n" - "will be returned only if its elements are stored internally\n" - "contiguous in memory.") + "will be returned only if its elements are stored contiguously\n" + "in memory.") #define FUNC_NAME s_scm_array_contents { - if (!scm_is_array (ra)) - scm_wrong_type_arg_msg (NULL, 0, ra, "array"); - else if (SCM_I_ARRAYP (ra)) + if (SCM_I_ARRAYP (ra)) { SCM v; - size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1; - if (!SCM_I_ARRAY_CONTP (ra)) - return SCM_BOOL_F; - for (k = 0; k < ndim; k++) - len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1; + size_t ndim = SCM_I_ARRAY_NDIM (ra); + scm_t_array_dim *s = SCM_I_ARRAY_DIMS (ra); + size_t k = ndim; + size_t len = 1; + + if (k) + { + ssize_t last_inc = s[k - 1].inc; + while (k--) + { + if (len*last_inc != s[k].inc) + return SCM_BOOL_F; + len *= (s[k].ubnd - s[k].lbnd + 1); + } + } + if (!SCM_UNBNDP (strict) && scm_is_true (strict)) { - if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc)) + if (ndim && (1 != s[ndim - 1].inc)) return SCM_BOOL_F; - if (scm_is_bitvector (SCM_I_ARRAY_V (ra))) - { - if (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) || - SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT || - len % SCM_LONG_BIT) - return SCM_BOOL_F; - } + if (scm_is_bitvector (SCM_I_ARRAY_V (ra)) + && (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) || + SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT || + len % SCM_LONG_BIT)) + return SCM_BOOL_F; } v = SCM_I_ARRAY_V (ra); @@ -798,8 +765,10 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, return sra; } } - else + else if (scm_is_array (ra)) return ra; + else + scm_wrong_type_arg_msg (NULL, 0, ra, "array"); } #undef FUNC_NAME diff --git a/libguile/arrays.h b/libguile/arrays.h index 977d30760..37eea69bd 100644 --- a/libguile/arrays.h +++ b/libguile/arrays.h @@ -37,8 +37,6 @@ /** Arrays */ SCM_API SCM scm_make_array (SCM fill, SCM bounds); -SCM_API SCM scm_from_contiguous_array (SCM bounds, const SCM *elts, - size_t len); SCM_API SCM scm_make_typed_array (SCM type, SCM fill, SCM bounds); SCM_API SCM scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes, @@ -63,7 +61,12 @@ SCM_API SCM scm_array_rank (SCM ra); /* internal. */ -#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0) +/* see scm_from_contiguous_array for these three */ +#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0) +#define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \ + (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | (SCM_I_ARRAY_FLAG_CONTIGUOUS << 16))) +#define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \ + (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16))) #define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_tc7_array, a) #define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x)>>17)) @@ -78,6 +81,7 @@ SCM_API SCM scm_array_rank (SCM ra); SCM_INTERNAL SCM scm_i_make_array (int ndim); SCM_INTERNAL int scm_i_print_array (SCM array, SCM port, scm_print_state *pstate); +SCM_INTERNAL SCM scm_i_shap2ra (SCM args); SCM_INTERNAL void scm_init_arrays (void); diff --git a/libguile/deprecated.c b/libguile/deprecated.c index e94733806..0ea4b5e20 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -729,6 +729,46 @@ scm_unlock_mutex_timed (SCM mx, SCM cond, SCM timeout) return scm_unlock_mutex (mx); } + + +SCM +scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len) +#define FUNC_NAME "scm_from_contiguous_array" +{ + size_t k, rlen = 1; + scm_t_array_dim *s; + SCM ra; + scm_t_array_handle h; + + scm_c_issue_deprecation_warning + ("`scm_from_contiguous_array' is deprecated. Use make-array and array-copy!\n" + "instead.\n"); + + ra = scm_i_shap2ra (bounds); + SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); + s = SCM_I_ARRAY_DIMS (ra); + k = SCM_I_ARRAY_NDIM (ra); + + while (k--) + { + s[k].inc = rlen; + SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1); + rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc; + } + if (rlen != len) + SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL); + + SCM_I_ARRAY_SET_V (ra, scm_c_make_vector (rlen, SCM_UNDEFINED)); + scm_array_get_handle (ra, &h); + memcpy (h.writable_elements, elts, rlen * sizeof(SCM)); + scm_array_handle_release (&h); + + if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra)) + if (0 == s->lbnd) + return SCM_I_ARRAY_V (ra); + return ra; +} +#undef FUNC_NAME diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 782e84564..69f9e1ef0 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -256,6 +256,16 @@ SCM_DEPRECATED SCM scm_apply_with_dynamic_root (SCM proc, SCM a1, +/* Deprecated 2016-11-18. Never documented. Unnecessary, since + array-copy! already unrolls and does it in more general cases. */ +/* With this also remove SCM_I_ARRAY_FLAG_CONTIGUOUS, + SCM_SET_ARRAY_CONTIGUOUS_FLAG, SCM_CLR_ARRAY_CONTIGUOUS_FLAG, + scm_i_ra_set_contp, and uses thereof. */ +SCM_DEPRECATED SCM scm_from_contiguous_array (SCM bounds, const SCM *elts, + size_t len); + + + void scm_i_init_deprecated (void); #endif diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test index 57c5cef3e..4c943dd41 100644 --- a/test-suite/tests/arrays.test +++ b/test-suite/tests/arrays.test @@ -413,6 +413,12 @@ (with-test-prefix/c&e "array-contents" + (pass-if "0-rank array" + (let ((a (make-vector 1 77))) + (and + (eq? a (array-contents (make-shared-array a (const '(0))))) + (eq? a (array-contents (make-shared-array a (const '(0))) #t))))) + (pass-if "simple vector" (let* ((a (make-array 0 4))) (eq? a (array-contents a)))) From 0dcca77754302e8bad4af82113d952ef243271bd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 26 Nov 2016 15:17:07 +0100 Subject: [PATCH 633/865] Remove special support for fluids in GDB interface * module/system/base/types.scm (inferior-fluid?, inferior-fluid-number) (): Remove. Fluids won't have numbers in the future. (cell->object): Adapt. * test-suite/tests/types.test ("opaque objects"): Update. --- module/system/base/types.scm | 22 ++-------------------- test-suite/tests/types.test | 7 ++----- 2 files changed, 4 insertions(+), 25 deletions(-) diff --git a/module/system/base/types.scm b/module/system/base/types.scm index cf3c7c9d2..652c9223f 100644 --- a/module/system/base/types.scm +++ b/module/system/base/types.scm @@ -42,9 +42,6 @@ inferior-object-sub-kind inferior-object-address - inferior-fluid? - inferior-fluid-number - inferior-struct? inferior-struct-name inferior-struct-fields @@ -311,21 +308,6 @@ the matching bits, possibly with bitwise operations to extract it from BITS." (set-record-type-printer! print-inferior-struct) -;; Fluids. -(define-record-type - (inferior-fluid number value) - inferior-fluid? - (number inferior-fluid-number) - (value inferior-fluid-value)) - -(set-record-type-printer! - (lambda (fluid port) - (match fluid - (($ number) - (format port "#" - number - (object-address fluid)))))) - ;; Object type to represent complex objects from the inferior process that ;; cannot be really converted to usable Scheme objects in the current ;; process. @@ -459,8 +441,8 @@ using BACKEND." vector))) (((_ & #x7f = %tc7-wvect)) (inferior-object 'weak-vector address)) ; TODO: show elements - ((((n << 8) || %tc7-fluid) init-value) - (inferior-fluid n #f)) ; TODO: show current value + (((_ & #x7f = %tc7-fluid) init-value) + (inferior-object 'fluid address)) (((_ & #x7f = %tc7-dynamic-state)) (inferior-object 'dynamic-state address)) ((((flags+type << 8) || %tc7-port)) diff --git a/test-suite/tests/types.test b/test-suite/tests/types.test index 15dc3f84f..446aff541 100644 --- a/test-suite/tests/types.test +++ b/test-suite/tests/types.test @@ -108,11 +108,8 @@ ((make-doubly-weak-hash-table) weak-table _) (#2((1 2 3) (4 5 6)) array _) (#*00000110 bitvector _) - ((expt 2 70) bignum _)) - - (pass-if "fluid" - (let ((fluid (make-fluid))) - (inferior-fluid? (scm->object (object-address fluid)))))) + ((expt 2 70) bignum _) + ((make-fluid) fluid _))) (define-record-type (some-struct x y z) From 5a3bc32c9968a929158c2089b1bd65f922429f02 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 26 Nov 2016 16:07:30 +0100 Subject: [PATCH 634/865] Fix scm_weak_table_refq for undefined default * libguile/weak-table.c (scm_weak_table_refq): No need to default weak table result to #f; just use whatever was passed in. --- libguile/weak-table.c | 3 --- 1 file changed, 3 deletions(-) diff --git a/libguile/weak-table.c b/libguile/weak-table.c index cd7d8c86a..f6f8dd68b 100644 --- a/libguile/weak-table.c +++ b/libguile/weak-table.c @@ -912,9 +912,6 @@ assq_predicate (SCM x, SCM y, void *closure) SCM scm_weak_table_refq (SCM table, SCM key, SCM dflt) { - if (SCM_UNBNDP (dflt)) - dflt = SCM_BOOL_F; - return scm_c_weak_table_ref (table, scm_ihashq (key, -1), assq_predicate, SCM_UNPACK_POINTER (key), dflt); From 668153dbb61040dc0f2d44e6653d4f7ed6e7c407 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 26 Nov 2016 16:30:57 +0100 Subject: [PATCH 635/865] Add weak-table fast path for update * libguile/weak-table.c (weak_table_put_x): If the key is the same and the table is weak-key, avoid re-setting disappearing links. --- libguile/weak-table.c | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/libguile/weak-table.c b/libguile/weak-table.c index f6f8dd68b..1bb513b17 100644 --- a/libguile/weak-table.c +++ b/libguile/weak-table.c @@ -686,6 +686,16 @@ weak_table_put_x (scm_t_weak_table *table, unsigned long hash, } } + /* Fast path for updated values for existing entries of weak-key + tables. */ + if (table->kind == SCM_WEAK_TABLE_KIND_KEY && + entries[k].hash == hash && + entries[k].key == SCM_UNPACK (key)) + { + entries[k].value = SCM_UNPACK (value); + return; + } + if (entries[k].hash) unregister_disappearing_links (&entries[k], table->kind); else From 7b6b86f25564dc67a3a2538d0ee47f25e00e6833 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 27 Nov 2016 20:56:59 +0100 Subject: [PATCH 636/865] Ensure autoconf doesn't downgrade us to C99 * configure.ac: Add -std=gnu11 if the compiler is GCC (or clang). This prevents AC_PROG_CC_C99 from downgrading us by adding -std=gnu99. Fixes regression whereby we were always using the fallback implementation of atomics. --- configure.ac | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/configure.ac b/configure.ac index 435bc4e28..db0511d9d 100644 --- a/configure.ac +++ b/configure.ac @@ -66,6 +66,18 @@ AC_LIBTOOL_WIN32_DLL AC_PROG_INSTALL AC_PROG_CC + +# Sadly, there is no released version of Autoconf with a nice +# C11-ensuring macro. This should work for gcc/clang within the last 5 +# years though. +AC_MSG_CHECKING([how to enable C11 support]) +if test "$GCC" = yes; then + AC_MSG_RESULT([-std=gnu11]) + CC="$CC -std=gnu11" +else + AC_MSG_RESULT([assuming $CC supports C11 by default]) +fi + gl_EARLY AC_PROG_CPP AC_PROG_SED From 8bd5dae8c372ffd5bd1866720acbddc2aa77cb65 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 27 Nov 2016 21:54:14 +0100 Subject: [PATCH 637/865] Compile fluid-set! to VM opcode * libguile/vm-engine.c (fluid-set!): Fix name of opcode to correspond with name of Tree-IL primitive. Fixes compilation of fluid-set! to actually use the fluid-set! opcode. * doc/ref/vm.texi (Dynamic Environment Instructions): Update. * module/language/cps/compile-bytecode.scm (compile-function): Add fluid-set! case. * module/system/vm/assembler.scm: Update export name for emit-fluid-set!. --- doc/ref/vm.texi | 2 +- libguile/vm-engine.c | 2 +- module/language/cps/compile-bytecode.scm | 2 ++ module/system/vm/assembler.scm | 2 +- 4 files changed, 5 insertions(+), 3 deletions(-) diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index e870f7391..60bce9ed3 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -1196,7 +1196,7 @@ balanced with @code{pop-fluid}. Reference the fluid in @var{src}, and place the value in @var{dst}. @end deftypefn -@deftypefn Instruction {} fluid-set s12:@var{fluid} s12:@var{val} +@deftypefn Instruction {} fluid-set! s12:@var{fluid} s12:@var{val} Set the value of the fluid in @var{dst} to the value in @var{src}. @end deftypefn diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index cfb60f242..03cca8d44 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -2196,7 +2196,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, * * Set the value of the fluid in DST to the value in SRC. */ - VM_DEFINE_OP (75, fluid_set, "fluid-set", OP1 (X8_S12_S12)) + VM_DEFINE_OP (75, fluid_set, "fluid-set!", OP1 (X8_S12_S12)) { scm_t_uint16 a, b; size_t num; diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 5e56b406f..7755b1e67 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -364,6 +364,8 @@ (from-sp (slot val)))) (($ $primcall 'unwind ()) (emit-unwind asm)) + (($ $primcall 'fluid-set! (fluid value)) + (emit-fluid-set! asm (from-sp (slot fluid)) (from-sp (slot value)))) (($ $primcall 'atomic-box-set! (box val)) (emit-atomic-box-set! asm (from-sp (slot box)) (from-sp (slot val)))) (($ $primcall 'handle-interrupts ()) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 5b89b049b..a3d7839f5 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -124,7 +124,7 @@ emit-pop-fluid emit-current-thread emit-fluid-ref - emit-fluid-set + emit-fluid-set! emit-string-length emit-string-ref emit-string->number From a9dc553893dcd26f047afecc8dc84d30c9bdcde6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 30 Nov 2016 22:56:54 +0100 Subject: [PATCH 638/865] Fix two wait-condition-variable race conditions * libguile/threads.c (timed_wait): When looping to reacquire mutex, check if mutex owner after dropping mutex to run asyncs when the reacquire is interrupted. Also for asyncs that interrupted the initial wait, just return #t directly, and allow the caller to loop. Fixes a deadlock in which a thread could have pending asyncs after dropping a mutex and which prevent it from going to wait on a cond, but then the broadcast comes while nobody is waiting and the mutex is dropped, then after reacquiring the mutex when we go to wait again, we wait forever. The correct thing to do is after reacquiring the mutex, to allow the application to check if waiting is appropriate. --- libguile/threads.c | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index 31a8cd48e..28f6cf4ea 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1316,13 +1316,8 @@ timed_wait (enum scm_mutex_kind kind, struct scm_mutex *m, struct scm_cond *c, /* We woke up for some reason. Reacquire the mutex before doing anything else. */ - if (scm_is_eq (m->owner, SCM_BOOL_F)) - { - m->owner = current_thread->handle; - scm_i_pthread_mutex_unlock (&m->lock); - } - else if (kind == SCM_MUTEX_RECURSIVE && - scm_is_eq (m->owner, current_thread->handle)) + if (kind == SCM_MUTEX_RECURSIVE && + scm_is_eq (m->owner, current_thread->handle)) { m->level++; scm_i_pthread_mutex_unlock (&m->lock); @@ -1330,6 +1325,12 @@ timed_wait (enum scm_mutex_kind kind, struct scm_mutex *m, struct scm_cond *c, else while (1) { + if (scm_is_eq (m->owner, SCM_BOOL_F)) + { + m->owner = current_thread->handle; + scm_i_pthread_mutex_unlock (&m->lock); + break; + } block_self (m->waiting, &m->lock, waittime); if (scm_is_eq (m->owner, SCM_BOOL_F)) { @@ -1348,11 +1349,8 @@ timed_wait (enum scm_mutex_kind kind, struct scm_mutex *m, struct scm_cond *c, else if (err == ETIMEDOUT) return SCM_BOOL_F; else if (err == EINTR) - { - scm_async_tick (); - scm_i_scm_pthread_mutex_lock (&m->lock); - continue; - } + /* Let caller run scm_async_tick() and loop. */ + return SCM_BOOL_T; else { /* Shouldn't happen. */ From aa84489d18320df086e08554554d6f3b92c45893 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 27 Nov 2016 21:33:30 +0100 Subject: [PATCH 639/865] Reimplement dynamic states There are two goals: one, to use less memory per dynamic state in order to allow millions of dynamic states to be allocated in light-weight threading scenarios. The second goal is to prevent dynamic states from being actively mutated in two threads at once. This second goal does mean that dynamic states object that escape into scheme are now copies that won't receive further updates; an incompatible change, but one which we hope doesn't affect anyone. * libguile/cache-internal.h: New file. * libguile/fluids.c (is_dynamic_state, get_dynamic_state) (save_dynamic_state, restore_dynamic_state, add_entry) (copy_value_table): New functions. (scm_i_fluid_print, scm_i_dynamic_state_print): Move up. (new_fluid): No need for a number. (scm_fluid_p: scm_is_fluid): Inline IS_FLUID uses. (fluid_set_x, fluid_ref): Adapt to dynamic state changes. (scm_fluid_set_x, scm_fluid_unset_x): Call fluid_set_x. (scm_swap_fluid): Rewrite in terms of fluid_ref and fluid_set. (swap_fluid): Use internal fluid_set_x. (scm_i_make_initial_dynamic_state): Adapt to dynamic state representation change. (scm_dynamic_state_p, scm_is_dynamic_state): Use new accessors. (scm_current_dynamic_state): Use make_dynamic_state. (scm_dynwind_current_dynamic_state): Use new accessor. * libguile/fluids.h: Remove internal definitions. Add new struct definition. * libguile/threads.h (scm_i_thread): Use scm_t_dynamic_state for dynamic state. * libguile/threads.c (guilify_self_1, guilify_self_2): (scm_i_init_thread_for_guile, scm_init_guile): (scm_call_with_new_thread): (scm_init_threads, scm_init_threads_default_dynamic_state): Adapt to scm_i_thread change. (scm_i_with_guile, with_guile): Remove "and parent" suffix. (scm_i_reset_fluid): Remove unneeded function. * doc/ref/api-scheduling.texi (Fluids and Dynamic States): Remove scm_make_dynamic_state docs. Update current-dynamic-state docs. * libguile/vm-engine.c (vm_engine): Update fluid-ref and fluid-set! inlined fast paths for dynamic state changes. * libguile/vm.c (vm_error_unbound_fluid): Remove now-unused function. * NEWS: Update. * module/ice-9/deprecated.scm (make-dynamic-state): New definition. * libguile/deprecated.h: * libguile/deprecated.c (scm_make_dynamic_state): Move here. * libguile/__scm.h (scm_t_dynamic_state): New typedef. * libguile/dynstack.h: * libguile/dynstack.c (scm_dynstack_push_fluid): (scm_dynstack_unwind_fluid): Take raw dynstate in these internal functions. * libguile/throw.c (catch): Adapt to dynstack changes. --- NEWS | 17 ++ doc/ref/api-scheduling.texi | 34 ++-- libguile/Makefile.am | 1 + libguile/__scm.h | 4 + libguile/cache-internal.h | 111 ++++++++++ libguile/deprecated.c | 14 +- libguile/deprecated.h | 4 + libguile/dynstack.c | 5 +- libguile/dynstack.h | 10 +- libguile/fluids.c | 395 +++++++++++++++++++----------------- libguile/fluids.h | 25 +-- libguile/threads.c | 69 +++---- libguile/threads.h | 3 +- libguile/throw.c | 2 +- libguile/vm-engine.c | 55 +++-- libguile/vm.c | 11 +- module/ice-9/deprecated.scm | 13 ++ 17 files changed, 463 insertions(+), 310 deletions(-) create mode 100644 libguile/cache-internal.h diff --git a/NEWS b/NEWS index 66fd2b03a..809f5ac63 100644 --- a/NEWS +++ b/NEWS @@ -87,6 +87,18 @@ Guile itself, though their join value was always `#f'. This is no longer the case; attempting to join a foreign thread will throw an error. +** Dynamic states capture values, not locations + +Dynamic states used to capture the locations of fluid-value +associations. Capturing the current dynamic state then setting a fluid +would result in a mutation of that captured state. Now capturing a +dynamic state simply captures the current values, and calling +`with-dynamic-state' copies those values into the Guile virtual machine +instead of aliasing them in a way that could allow them to be mutated in +place. This change allows Guile's fluid variables to be thread-safe. +To capture the locations of a dynamic state, use partial continuations +instead. + * New deprecations ** Arbiters deprecated @@ -122,6 +134,11 @@ This was a facility that predated threads, was unused as far as we can tell, and was never documented. Still, a grep of your code for dynamic-root or dynamic_root would not be amiss. +** `make-dynamic-state' deprecated + +Use `current-dynamic-state' to get an immutable copy of the current +fluid-value associations. + * Bug fixes ** cancel-thread uses asynchronous interrupts, not pthread_cancel diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index 1087bfeec..615e8b637 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -673,17 +673,22 @@ delivery of an async causes this function to be interrupted. A @emph{fluid} is an object that can store one value per @emph{dynamic state}. Each thread has a current dynamic state, and when accessing a fluid, this current dynamic state is used to provide the actual value. -In this way, fluids can be used for thread local storage, but they are -in fact more flexible: dynamic states are objects of their own and can -be made current for more than one thread at the same time, or only be -made current temporarily, for example. +In this way, fluids can be used for thread local storage. Additionally, +the set of current fluid values can be captured by a dynamic state and +reinstated in some other dynamic extent, possibly in another thread +even. -Fluids can also be used to simulate the desirable effects of -dynamically scoped variables. Dynamically scoped variables are useful -when you want to set a variable to a value during some dynamic extent -in the execution of your program and have them revert to their -original value when the control flow is outside of this dynamic -extent. See the description of @code{with-fluids} below for details. +Fluids are a building block for implementing dynamically scoped +variables. Dynamically scoped variables are useful when you want to set +a variable to a value during some dynamic extent in the execution of +your program and have them revert to their original value when the +control flow is outside of this dynamic extent. See the description of +@code{with-fluids} below for details. + +Guile uses fluids to implement parameters (@pxref{Parameters}). Usually +you just want to use parameters directly. However it can be useful to +know what a fluid is and how it works, so that's what this section is +about. New fluids are created with @code{make-fluid} and @code{fluid?} is used for testing whether an object is actually a fluid. The values @@ -788,12 +793,6 @@ value whenever the dynwind context is entered or left. The backup value is initialized with the @var{val} argument. @end deftypefn -@deffn {Scheme Procedure} make-dynamic-state [parent] -@deffnx {C Function} scm_make_dynamic_state (parent) -Return a copy of the dynamic state object @var{parent} -or of the current dynamic state when @var{parent} is omitted. -@end deffn - @deffn {Scheme Procedure} dynamic-state? obj @deffnx {C Function} scm_dynamic_state_p (obj) Return @code{#t} if @var{obj} is a dynamic state object; @@ -807,7 +806,8 @@ return zero otherwise. @deffn {Scheme Procedure} current-dynamic-state @deffnx {C Function} scm_current_dynamic_state () -Return the current dynamic state object. +Return a snapshot of the current fluid-value associations as a fresh +dynamic state object. @end deffn @deffn {Scheme Procedure} set-current-dynamic-state state diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 8bf9ddf59..c36a7e5ef 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -505,6 +505,7 @@ noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \ srfi-14.i.c \ quicksort.i.c \ atomics-internal.h \ + cache-internal.h \ posix-w32.h \ private-options.h ports-internal.h diff --git a/libguile/__scm.h b/libguile/__scm.h index dde26be05..62ceeeb9c 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -412,6 +412,10 @@ typedef void *scm_t_subr; +typedef struct scm_dynamic_state scm_t_dynamic_state; + + + /* scm_i_jmp_buf * * The corresponding SCM_I_SETJMP and SCM_I_LONGJMP are defined in the diff --git a/libguile/cache-internal.h b/libguile/cache-internal.h new file mode 100644 index 000000000..fc1e3c139 --- /dev/null +++ b/libguile/cache-internal.h @@ -0,0 +1,111 @@ +#ifndef SCM_CACHE_INTERNAL_H +#define SCM_CACHE_INTERNAL_H + +/* Copyright (C) 2016 + * 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 License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + + + + +#include + +#include "libguile/__scm.h" +#include "libguile/gc.h" +#include "libguile/hash.h" +#include "libguile/threads.h" + + +/* A simple cache with 8 entries. The cache entries are stored in a + sorted vector. */ +struct scm_cache_entry +{ + scm_t_bits key; + scm_t_bits value; +}; + +#define SCM_CACHE_SIZE 8 + +struct scm_cache +{ + scm_t_bits eviction_cookie; + struct scm_cache_entry entries[SCM_CACHE_SIZE]; +}; + +static inline struct scm_cache* +scm_make_cache (void) +{ + struct scm_cache *ret = scm_gc_typed_calloc (struct scm_cache); + ret->eviction_cookie = (scm_t_bits) ret; + return ret; +} + +static inline int +scm_cache_full_p (struct scm_cache *cache) +{ + return cache->entries[0].key != 0; +} + +static inline void +scm_cache_evict_1 (struct scm_cache *cache, struct scm_cache_entry *evicted) +{ + size_t idx; + cache->eviction_cookie = scm_ihashq (SCM_PACK (cache->eviction_cookie), -1); + idx = cache->eviction_cookie & (SCM_CACHE_SIZE - 1); + memcpy (evicted, cache->entries + idx, sizeof (*evicted)); + memmove (cache->entries + 1, + cache->entries, + sizeof (cache->entries[0]) * idx); + cache->entries[0].key = 0; + cache->entries[0].value = 0; +} + +static inline struct scm_cache_entry* +scm_cache_lookup (struct scm_cache *cache, SCM k) +{ + scm_t_bits k_bits = SCM_UNPACK (k); + struct scm_cache_entry *entry = cache->entries; + /* Unrolled binary search, compiled to branchless cmp + cmov chain. */ + if (entry[4].key <= k_bits) entry += 4; + if (entry[2].key <= k_bits) entry += 2; + if (entry[1].key <= k_bits) entry += 1; + return entry; +} + +static inline void +scm_cache_insert (struct scm_cache *cache, SCM k, SCM v, + struct scm_cache_entry *evicted) +{ + struct scm_cache_entry *entry; + + if (scm_cache_full_p (cache)) + scm_cache_evict_1 (cache, evicted); + entry = scm_cache_lookup (cache, k); + if (entry->key == SCM_UNPACK (k)) + { + entry->value = SCM_UNPACK (v); + return; + } + memmove (cache->entries, + cache->entries + 1, + (entry - cache->entries) * sizeof (*entry)); + entry->key = SCM_UNPACK (k); + entry->value = SCM_UNPACK (v); +} + +#endif /* SCM_CACHE_INTERNAL_H */ diff --git a/libguile/deprecated.c b/libguile/deprecated.c index 0ea4b5e20..c3d4935d0 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -853,7 +853,7 @@ scm_internal_cwdr (scm_t_catch_body body, void *body_data, scm_dynstack_unwind (dynstack, SCM_DYNSTACK_FIRST (dynstack)); scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE); - scm_dynwind_current_dynamic_state (scm_make_dynamic_state (SCM_UNDEFINED)); + scm_dynwind_current_dynamic_state (scm_current_dynamic_state ()); my_handler_data.run_handler = 0; answer = scm_i_with_continuation_barrier (body, body_data, @@ -926,6 +926,18 @@ scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler) } + + +SCM +scm_make_dynamic_state (SCM parent) +{ + scm_c_issue_deprecation_warning + ("scm_make_dynamic_state is deprecated. Dynamic states are " + "now immutable; just use the parent directly."); + return SCM_UNBNDP (parent) ? scm_current_dynamic_state () : parent; +} + + void diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 69f9e1ef0..b1e455a89 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -256,6 +256,10 @@ SCM_DEPRECATED SCM scm_apply_with_dynamic_root (SCM proc, SCM a1, +SCM_DEPRECATED SCM scm_make_dynamic_state (SCM parent); + + + /* Deprecated 2016-11-18. Never documented. Unnecessary, since array-copy! already unrolls and does it in more general cases. */ /* With this also remove SCM_I_ARRAY_FLAG_CONTIGUOUS, diff --git a/libguile/dynstack.c b/libguile/dynstack.c index bda1a16b5..7fb858391 100644 --- a/libguile/dynstack.c +++ b/libguile/dynstack.c @@ -163,7 +163,7 @@ scm_dynstack_push_unwinder (scm_t_dynstack *dynstack, binding. */ void scm_dynstack_push_fluid (scm_t_dynstack *dynstack, SCM fluid, SCM value, - SCM dynamic_state) + scm_t_dynamic_state *dynamic_state) { scm_t_bits *words; SCM value_box; @@ -525,7 +525,8 @@ scm_dynstack_unwind_frame (scm_t_dynstack *dynstack) /* This function must not allocate. */ void -scm_dynstack_unwind_fluid (scm_t_dynstack *dynstack, SCM dynamic_state) +scm_dynstack_unwind_fluid (scm_t_dynstack *dynstack, + scm_t_dynamic_state *dynamic_state) { scm_t_bits tag, *words; size_t len; diff --git a/libguile/dynstack.h b/libguile/dynstack.h index 853f0684d..592e7c819 100644 --- a/libguile/dynstack.h +++ b/libguile/dynstack.h @@ -147,9 +147,9 @@ SCM_INTERNAL void scm_dynstack_push_rewinder (scm_t_dynstack *, SCM_INTERNAL void scm_dynstack_push_unwinder (scm_t_dynstack *, scm_t_dynstack_winder_flags, scm_t_guard, void *); -SCM_INTERNAL void scm_dynstack_push_fluid (scm_t_dynstack *, - SCM fluid, SCM value, - SCM dynamic_state); +SCM_INTERNAL void scm_dynstack_push_fluid ( + scm_t_dynstack *, SCM fluid, SCM value, + scm_t_dynamic_state *dynamic_state); SCM_INTERNAL void scm_dynstack_push_prompt (scm_t_dynstack *, scm_t_dynstack_prompt_flags, SCM key, @@ -186,8 +186,8 @@ SCM_INTERNAL scm_t_bits* scm_dynstack_unwind_fork (scm_t_dynstack *, scm_t_dynstack *); SCM_INTERNAL void scm_dynstack_unwind_frame (scm_t_dynstack *); -SCM_INTERNAL void scm_dynstack_unwind_fluid (scm_t_dynstack *dynstack, - SCM dynamic_state); +SCM_INTERNAL void scm_dynstack_unwind_fluid + (scm_t_dynstack *dynstack, scm_t_dynamic_state *dynamic_state); SCM_INTERNAL scm_t_bits* scm_dynstack_find_prompt (scm_t_dynstack *, SCM, scm_t_dynstack_prompt_flags *, diff --git a/libguile/fluids.c b/libguile/fluids.c index 5ff92a884..72c75952d 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -25,6 +25,8 @@ #include #include "libguile/_scm.h" +#include "libguile/atomics-internal.h" +#include "libguile/cache-internal.h" #include "libguile/print.h" #include "libguile/dynwind.h" #include "libguile/fluids.h" @@ -35,52 +37,138 @@ #include "libguile/validate.h" #include "libguile/bdw-gc.h" -/* Number of additional slots to allocate when ALLOCATED_FLUIDS is full. */ -#define FLUID_GROW 128 +/* A dynamic state associates fluids with values. There are two + representations of a dynamic state in Guile: the active + representation that is part of each thread, and a frozen + representation that can live in Scheme land as a value. -/* Vector of allocated fluids indexed by fluid numbers. Access is protected by - FLUID_ADMIN_MUTEX. */ -static void **allocated_fluids = NULL; -static size_t allocated_fluids_len = 0; + The active dynamic state has two parts: a locals cache, and a values + table. The locals cache stores fluid values that have been recently + referenced or set. If a value isn't in the locals cache, Guile then + looks for it in the values table, which is a weak-key hash table. + Otherwise Guile falls back to the default value of the fluid. In any + case, the value is recorded in the locals cache. Likewise setting a + fluid's value simply inserts that association into the locals cache. -static scm_i_pthread_mutex_t fluid_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; + The locals cache is not large, so adding an entry to it might evict + some other entry. In that case the entry gets flushed to the values + table. -#define IS_FLUID(x) SCM_FLUID_P (x) -#define FLUID_NUM(x) SCM_I_FLUID_NUM (x) + The values table begins as being inherited from the parent dynamic + state, and represents a capture of the fluid values at a point in + time. A dynamic state records when its values table might be + referenced by other dynamic states. If it is aliased, then any + update to that table has to start by making a fresh local copy to + work on. -#define IS_DYNAMIC_STATE(x) SCM_I_DYNAMIC_STATE_P (x) -#define DYNAMIC_STATE_FLUIDS(x) SCM_I_DYNAMIC_STATE_FLUIDS (x) -#define SET_DYNAMIC_STATE_FLUIDS(x, y) SCM_SET_CELL_WORD_1 ((x), (SCM_UNPACK (y))) + There are two interesting constraints on dynamic states, besides + speed. One is that they should hold onto their fluid-value + associations weakly: they shouldn't keep fluids alive indefinitely, + and if a fluid goes away, its value should become collectible too. + This is why the values table is a weak table; it makes access + somewhat slower, but this is mitigated by the cache. The cache + itself holds onto fluids and values strongly, but if there are more + than 8 fluids in use by a dynamic state, this won't be a problem. + + The other interesting constraint is memory usage: you don't want a + program with M fluids and N dynamic states to consume N*M memory. + Guile associates each thread with a dynamic state, which itself isn't + that bad as there are relatively few threads in a program. The + problem comes in with "fibers", lightweight user-space threads that + can be allocated in the millions. Here you want new fibers to + inherit the dynamic state from the fiber that created them, but you + really need to limit memory overheads. For reference, in late 2016, + non-dynamic-state memory overhead per fiber in one user-space library + is around 500 bytes, in a simple "all fibers try to send a message on + one channel" test case. + + For this reason the frozen representation of dynamic states is the + probably-shared values table at the end of a list of fluid-value + pairs, representing entries from the locals cache that differ from + the values table. This keeps per-dynamic-state memory usage in + check. A family of fibers that uses the same 3 or 4 fluids probably + won't ever have to allocate a new values table. Ideally the values + table could share more state, as in an immutable weak array-mapped + hash trie or something, but we don't have such a data structure. */ + +static inline int +is_dynamic_state (SCM x) +{ + return SCM_HAS_TYP7 (x, scm_tc7_dynamic_state); +} + +static inline SCM +get_dynamic_state (SCM dynamic_state) +{ + return SCM_CELL_OBJECT_1 (dynamic_state); +} + +static inline void +restore_dynamic_state (SCM saved, scm_t_dynamic_state *state) +{ + int slot; + for (slot = SCM_CACHE_SIZE - 1; slot >= 0; slot--) + { + struct scm_cache_entry *entry = &state->cache.entries[slot]; + if (scm_is_pair (saved)) + { + entry->key = SCM_UNPACK (SCM_CAAR (saved)); + entry->value = SCM_UNPACK (SCM_CDAR (saved)); + saved = scm_cdr (saved); + } + else + entry->key = entry->value = 0; + } + state->values = saved; + state->has_aliased_values = 1; +} + +static inline SCM +save_dynamic_state (scm_t_dynamic_state *state) +{ + int slot; + SCM saved = state->values; + for (slot = 0; slot < SCM_CACHE_SIZE; slot++) + { + struct scm_cache_entry *entry = &state->cache.entries[slot]; + SCM key = SCM_PACK (entry->key); + SCM value = SCM_PACK (entry->value); + if (entry->key && + !scm_is_eq (scm_weak_table_refq (state->values, key, SCM_UNDEFINED), + value)) + { + if (state->has_aliased_values) + saved = scm_acons (key, value, saved); + else + scm_weak_table_putq_x (state->values, key, value); + } + } + state->has_aliased_values = 1; + return saved; +} + +static SCM +add_entry (void *data, SCM k, SCM v, SCM result) +{ + scm_weak_table_putq_x (result, k, v); + return result; +} + +static SCM +copy_value_table (SCM tab) +{ + SCM ret = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY); + return scm_c_weak_table_fold (add_entry, NULL, ret, tab); +} -/* Grow STATE so that it can hold up to ALLOCATED_FLUIDS_LEN fluids. This may - be more than necessary since ALLOCATED_FLUIDS is sparse and the current - thread may not access all the fluids anyway. Memory usage could be improved - by using a 2-level array as is done in glibc for pthread keys (TODO). */ -static void -grow_dynamic_state (SCM state) -{ - SCM new_fluids; - SCM old_fluids = DYNAMIC_STATE_FLUIDS (state); - size_t i, len, old_len = SCM_SIMPLE_VECTOR_LENGTH (old_fluids); - - /* Assume the assignment below is atomic. */ - len = allocated_fluids_len; - - new_fluids = scm_c_make_vector (len, SCM_UNDEFINED); - - for (i = 0; i < old_len; i++) - SCM_SIMPLE_VECTOR_SET (new_fluids, i, - SCM_SIMPLE_VECTOR_REF (old_fluids, i)); - SET_DYNAMIC_STATE_FLUIDS (state, new_fluids); -} void scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { scm_puts ("#', port); } @@ -92,75 +180,15 @@ scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED scm_putc ('>', port); } + -/* Return a new fluid. */ + +#define SCM_I_FLUID_DEFAULT(x) (SCM_CELL_OBJECT_1 (x)) + static SCM new_fluid (SCM init) { - SCM fluid; - size_t trial, n; - - /* Fluids hold the type tag and the fluid number in the first word, - and the default value in the second word. */ - fluid = scm_cell (scm_tc7_fluid, SCM_UNPACK (init)); - SCM_SET_CELL_TYPE (fluid, scm_tc7_fluid); - - scm_dynwind_begin (0); - scm_i_dynwind_pthread_mutex_lock (&fluid_admin_mutex); - - for (trial = 0; trial < 2; trial++) - { - /* Look for a free fluid number. */ - for (n = 0; n < allocated_fluids_len; n++) - /* TODO: Use `__sync_bool_compare_and_swap' where available. */ - if (allocated_fluids[n] == NULL) - break; - - if (trial == 0 && n >= allocated_fluids_len && allocated_fluids_len) - /* All fluid numbers are in use. Run a GC and retry. Explicitly - running the GC is costly and bad-style. We only do this because - dynamic state fluid vectors would grow unreasonably if fluid numbers - weren't reused. */ - scm_i_gc ("fluids"); - } - - if (n >= allocated_fluids_len) - { - /* Grow the vector of allocated fluids. */ - void **new_allocated_fluids = - scm_gc_malloc_pointerless ((allocated_fluids_len + FLUID_GROW) - * sizeof (*allocated_fluids), - "allocated fluids"); - - /* Copy over old values and initialize rest. GC can not run - during these two operations since there is no safe point in - them. */ - memcpy (new_allocated_fluids, allocated_fluids, - allocated_fluids_len * sizeof (*allocated_fluids)); - memset (new_allocated_fluids + allocated_fluids_len, 0, - FLUID_GROW * sizeof (*allocated_fluids)); - n = allocated_fluids_len; - - /* Update the vector of allocated fluids. Dynamic states will - eventually be lazily grown to accomodate the new value of - ALLOCATED_FLUIDS_LEN in `fluid-ref' and `fluid-set!'. */ - allocated_fluids = new_allocated_fluids; - allocated_fluids_len += FLUID_GROW; - } - - allocated_fluids[n] = SCM_UNPACK_POINTER (fluid); - SCM_SET_CELL_WORD_0 (fluid, (scm_tc7_fluid | (n << 8))); - - GC_GENERAL_REGISTER_DISAPPEARING_LINK (&allocated_fluids[n], - SCM2PTR (fluid)); - - scm_dynwind_end (); - - /* Now null out values. We could (and probably should) do this when - the fluid is collected instead of now. */ - scm_i_reset_fluid (n); - - return fluid; + return scm_cell (scm_tc7_fluid, SCM_UNPACK (init)); } SCM @@ -200,36 +228,72 @@ SCM_DEFINE (scm_fluid_p, "fluid?", 1, 0, 0, "@code{#f}.") #define FUNC_NAME s_scm_fluid_p { - return scm_from_bool (IS_FLUID (obj)); + return scm_from_bool (SCM_FLUID_P (obj)); } #undef FUNC_NAME int scm_is_fluid (SCM obj) { - return IS_FLUID (obj); + return SCM_FLUID_P (obj); } -/* Does not check type of `fluid'! */ -static SCM -fluid_ref (SCM fluid) +static void +fluid_set_x (scm_t_dynamic_state *dynamic_state, SCM fluid, SCM value) { - SCM ret; - SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state); + struct scm_cache_entry *entry; + struct scm_cache_entry evicted = { 0, 0 }; - if (SCM_UNLIKELY (FLUID_NUM (fluid) >= SCM_SIMPLE_VECTOR_LENGTH (fluids))) + entry = scm_cache_lookup (&dynamic_state->cache, fluid); + if (scm_is_eq (SCM_PACK (entry->key), fluid)) { - /* Lazily grow the current thread's dynamic state. */ - grow_dynamic_state (SCM_I_CURRENT_THREAD->dynamic_state); - - fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state); + entry->value = SCM_UNPACK (value); + return; } - ret = SCM_SIMPLE_VECTOR_REF (fluids, FLUID_NUM (fluid)); - if (SCM_UNBNDP (ret)) - return SCM_I_FLUID_DEFAULT (fluid); + scm_cache_insert (&dynamic_state->cache, fluid, value, &evicted); + + if (evicted.key != 0) + { + fluid = SCM_PACK (evicted.key); + value = SCM_PACK (evicted.value); + + if (dynamic_state->has_aliased_values) + { + if (scm_is_eq (scm_weak_table_refq (dynamic_state->values, + fluid, SCM_UNDEFINED), + value)) + return; + dynamic_state->values = copy_value_table (dynamic_state->values); + dynamic_state->has_aliased_values = 0; + } + + scm_weak_table_putq_x (dynamic_state->values, fluid, value); + } +} + +/* Return value can be SCM_UNDEFINED; caller checks. */ +static SCM +fluid_ref (scm_t_dynamic_state *dynamic_state, SCM fluid) +{ + SCM val; + struct scm_cache_entry *entry; + + entry = scm_cache_lookup (&dynamic_state->cache, fluid); + if (scm_is_eq (SCM_PACK (entry->key), fluid)) + val = SCM_PACK (entry->value); else - return ret; + { + val = scm_weak_table_refq (dynamic_state->values, fluid, SCM_UNDEFINED); + + if (SCM_UNBNDP (val)) + val = SCM_I_FLUID_DEFAULT (fluid); + + /* Cache this lookup. */ + fluid_set_x (dynamic_state, fluid, val); + } + + return val; } SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0, @@ -239,13 +303,12 @@ SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0, "@code{#f}.") #define FUNC_NAME s_scm_fluid_ref { - SCM val; + SCM ret; SCM_VALIDATE_FLUID (1, fluid); - val = fluid_ref (fluid); - if (SCM_UNBNDP (val)) - SCM_MISC_ERROR ("unbound fluid: ~S", - scm_list_1 (fluid)); - return val; + ret = fluid_ref (SCM_I_CURRENT_THREAD->dynamic_state, fluid); + if (SCM_UNBNDP (ret)) + scm_misc_error ("fluid-ref", "unbound fluid: ~S", scm_list_1 (fluid)); + return ret; } #undef FUNC_NAME @@ -254,19 +317,8 @@ SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0, "Set the value associated with @var{fluid} in the current dynamic root.") #define FUNC_NAME s_scm_fluid_set_x { - SCM fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state); - SCM_VALIDATE_FLUID (1, fluid); - - if (SCM_UNLIKELY (FLUID_NUM (fluid) >= SCM_SIMPLE_VECTOR_LENGTH (fluids))) - { - /* Lazily grow the current thread's dynamic state. */ - grow_dynamic_state (SCM_I_CURRENT_THREAD->dynamic_state); - - fluids = DYNAMIC_STATE_FLUIDS (SCM_I_CURRENT_THREAD->dynamic_state); - } - - SCM_SIMPLE_VECTOR_SET (fluids, FLUID_NUM (fluid), value); + fluid_set_x (SCM_I_CURRENT_THREAD->dynamic_state, fluid, value); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -278,8 +330,10 @@ SCM_DEFINE (scm_fluid_unset_x, "fluid-unset!", 1, 0, 0, { /* FIXME: really unset the default value, too? The current test suite demands it, but I would prefer not to. */ + SCM_VALIDATE_FLUID (1, fluid); SCM_SET_CELL_OBJECT_1 (fluid, SCM_UNDEFINED); - return scm_fluid_set_x (fluid, SCM_UNDEFINED); + fluid_set_x (SCM_I_CURRENT_THREAD->dynamic_state, fluid, SCM_UNDEFINED); + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -291,7 +345,7 @@ SCM_DEFINE (scm_fluid_bound_p, "fluid-bound?", 1, 0, 0, { SCM val; SCM_VALIDATE_FLUID (1, fluid); - val = fluid_ref (fluid); + val = fluid_ref (SCM_I_CURRENT_THREAD->dynamic_state, fluid); return scm_from_bool (! (SCM_UNBNDP (val))); } #undef FUNC_NAME @@ -303,26 +357,11 @@ apply_thunk (void *thunk) } void -scm_swap_fluid (SCM fluid, SCM value_box, SCM dynstate) +scm_swap_fluid (SCM fluid, SCM value_box, scm_t_dynamic_state *dynstate) { - SCM fluid_vector, tmp; - size_t fluid_num; - - fluid_num = FLUID_NUM (fluid); - - fluid_vector = DYNAMIC_STATE_FLUIDS (dynstate); - - if (SCM_UNLIKELY (fluid_num >= SCM_SIMPLE_VECTOR_LENGTH (fluid_vector))) - { - /* Lazily grow the current thread's dynamic state. */ - grow_dynamic_state (dynstate); - - fluid_vector = DYNAMIC_STATE_FLUIDS (dynstate); - } - - tmp = SCM_SIMPLE_VECTOR_REF (fluid_vector, fluid_num); - SCM_SIMPLE_VECTOR_SET (fluid_vector, fluid_num, SCM_VARIABLE_REF (value_box)); - SCM_VARIABLE_SET (value_box, tmp); + SCM val = fluid_ref (dynstate, fluid); + fluid_set_x (dynstate, fluid, SCM_VARIABLE_REF (value_box)); + SCM_VARIABLE_SET (value_box, val); } SCM_DEFINE (scm_with_fluids, "with-fluids*", 3, 0, 0, @@ -395,9 +434,10 @@ scm_c_with_fluid (SCM fluid, SCM value, SCM (*cproc) (), void *cdata) static void swap_fluid (SCM data) { + scm_t_dynamic_state *dynstate = SCM_I_CURRENT_THREAD->dynamic_state; SCM f = SCM_CAR (data); - SCM t = fluid_ref (f); - scm_fluid_set_x (f, SCM_CDR (data)); + SCM t = fluid_ref (dynstate, f); + fluid_set_x (dynstate, f, SCM_CDR (data)); SCM_SETCDR (data, t); } @@ -410,51 +450,38 @@ scm_dynwind_fluid (SCM fluid, SCM value) } SCM -scm_i_make_initial_dynamic_state () +scm_i_make_initial_dynamic_state (void) { - SCM fluids = scm_c_make_vector (allocated_fluids_len, SCM_BOOL_F); - return scm_cell (scm_tc7_dynamic_state, SCM_UNPACK (fluids)); + return scm_cell (scm_tc7_dynamic_state, + SCM_UNPACK (scm_c_make_weak_table + (0, SCM_WEAK_TABLE_KIND_KEY))); } -SCM_DEFINE (scm_make_dynamic_state, "make-dynamic-state", 0, 1, 0, - (SCM parent), - "Return a copy of the dynamic state object @var{parent}\n" - "or of the current dynamic state when @var{parent} is omitted.") -#define FUNC_NAME s_scm_make_dynamic_state -{ - SCM fluids; - - if (SCM_UNBNDP (parent)) - parent = scm_current_dynamic_state (); - - SCM_ASSERT (IS_DYNAMIC_STATE (parent), parent, SCM_ARG1, FUNC_NAME); - fluids = scm_vector_copy (DYNAMIC_STATE_FLUIDS (parent)); - return scm_cell (scm_tc7_dynamic_state, SCM_UNPACK (fluids)); -} -#undef FUNC_NAME - SCM_DEFINE (scm_dynamic_state_p, "dynamic-state?", 1, 0, 0, (SCM obj), "Return @code{#t} if @var{obj} is a dynamic state object;\n" "return @code{#f} otherwise") #define FUNC_NAME s_scm_dynamic_state_p { - return scm_from_bool (IS_DYNAMIC_STATE (obj)); + return scm_from_bool (is_dynamic_state (obj)); } #undef FUNC_NAME int scm_is_dynamic_state (SCM obj) { - return IS_DYNAMIC_STATE (obj); + return is_dynamic_state (obj); } SCM_DEFINE (scm_current_dynamic_state, "current-dynamic-state", 0, 0, 0, (), - "Return the current dynamic state object.") + "Return a snapshot of the current fluid-value associations\n" + "as a fresh dynamic state object.") #define FUNC_NAME s_scm_current_dynamic_state { - return SCM_I_CURRENT_THREAD->dynamic_state; + struct scm_dynamic_state *state = SCM_I_CURRENT_THREAD->dynamic_state; + return scm_cell (scm_tc7_dynamic_state, + SCM_UNPACK (save_dynamic_state (state))); } #undef FUNC_NAME @@ -465,9 +492,9 @@ SCM_DEFINE (scm_set_current_dynamic_state, "set-current-dynamic-state", 1,0,0, #define FUNC_NAME s_scm_set_current_dynamic_state { scm_i_thread *t = SCM_I_CURRENT_THREAD; - SCM old = t->dynamic_state; - SCM_ASSERT (IS_DYNAMIC_STATE (state), state, SCM_ARG1, FUNC_NAME); - t->dynamic_state = state; + SCM old = scm_current_dynamic_state (); + SCM_ASSERT (is_dynamic_state (state), state, SCM_ARG1, FUNC_NAME); + restore_dynamic_state (get_dynamic_state (state), t->dynamic_state); return old; } #undef FUNC_NAME @@ -482,7 +509,7 @@ void scm_dynwind_current_dynamic_state (SCM state) { SCM loc = scm_cons (state, SCM_EOL); - SCM_ASSERT (IS_DYNAMIC_STATE (state), state, SCM_ARG1, NULL); + SCM_ASSERT (is_dynamic_state (state), state, SCM_ARG1, NULL); scm_dynwind_rewind_handler_with_scm (swap_dynamic_state, loc, SCM_F_WIND_EXPLICITLY); scm_dynwind_unwind_handler_with_scm (swap_dynamic_state, loc, diff --git a/libguile/fluids.h b/libguile/fluids.h index 2292e40e2..8031c0d48 100644 --- a/libguile/fluids.h +++ b/libguile/fluids.h @@ -35,17 +35,19 @@ code. When a new dynamic state is constructed, it inherits the values from its parent. Because each thread executes with its own dynamic state, you can use fluids for thread local storage. - - Each fluid is identified by a small integer. This integer is used to - index a vector that holds the values of all fluids. A dynamic state - consists of this vector, wrapped in an object so that the vector can - grow. */ #define SCM_FLUID_P(x) (SCM_HAS_TYP7 (x, scm_tc7_fluid)) + #ifdef BUILDING_LIBGUILE -#define SCM_I_FLUID_NUM(x) ((size_t)(SCM_CELL_WORD_0 (x) >> 8)) -#define SCM_I_FLUID_DEFAULT(x) (SCM_CELL_OBJECT_1 (x)) +# include + +struct scm_dynamic_state +{ + SCM values; + uint8_t has_aliased_values; + struct scm_cache cache; +}; #endif SCM_API SCM scm_make_fluid (void); @@ -58,7 +60,8 @@ SCM_API SCM scm_fluid_set_x (SCM fluid, SCM value); SCM_API SCM scm_fluid_unset_x (SCM fluid); SCM_API SCM scm_fluid_bound_p (SCM fluid); -SCM_INTERNAL void scm_swap_fluid (SCM fluid, SCM value_box, SCM dynamic_state); +SCM_INTERNAL void scm_swap_fluid (SCM fluid, SCM value_box, + scm_t_dynamic_state *dynamic_state); SCM_API SCM scm_c_with_fluids (SCM fluids, SCM vals, SCM (*cproc)(void *), void *cdata); @@ -69,12 +72,6 @@ SCM_API SCM scm_with_fluid (SCM fluid, SCM val, SCM thunk); SCM_API void scm_dynwind_fluid (SCM fluid, SCM value); -#ifdef BUILDING_LIBGUILE -#define SCM_I_DYNAMIC_STATE_P(x) (SCM_HAS_TYP7 (x, scm_tc7_dynamic_state)) -#define SCM_I_DYNAMIC_STATE_FLUIDS(x) SCM_PACK (SCM_CELL_WORD_1 (x)) -#endif - -SCM_API SCM scm_make_dynamic_state (SCM parent); SCM_API SCM scm_dynamic_state_p (SCM obj); SCM_API int scm_is_dynamic_state (SCM obj); SCM_API SCM scm_current_dynamic_state (void); diff --git a/libguile/threads.c b/libguile/threads.c index 28f6cf4ea..91b18b43a 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -372,25 +372,7 @@ static scm_i_pthread_mutex_t thread_admin_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZE static scm_i_thread *all_threads = NULL; static int thread_count; -static SCM scm_i_default_dynamic_state; - -/* Run when a fluid is collected. */ -void -scm_i_reset_fluid (size_t n) -{ - scm_i_thread *t; - - scm_i_pthread_mutex_lock (&thread_admin_mutex); - for (t = all_threads; t; t = t->next_thread) - if (SCM_I_DYNAMIC_STATE_P (t->dynamic_state)) - { - SCM v = SCM_I_DYNAMIC_STATE_FLUIDS (t->dynamic_state); - - if (n < SCM_SIMPLE_VECTOR_LENGTH (v)) - SCM_SIMPLE_VECTOR_SET (v, n, SCM_UNDEFINED); - } - scm_i_pthread_mutex_unlock (&thread_admin_mutex); -} +static SCM default_dynamic_state; /* Perform first stage of thread initialisation, in non-guile mode. */ @@ -409,7 +391,7 @@ guilify_self_1 (struct GC_stack_base *base) t.result = SCM_BOOL_F; t.freelists = NULL; t.pointerless_freelists = NULL; - t.dynamic_state = SCM_BOOL_F; + t.dynamic_state = NULL; t.dynstack.base = NULL; t.dynstack.top = NULL; t.dynstack.limit = NULL; @@ -463,7 +445,7 @@ guilify_self_1 (struct GC_stack_base *base) /* Perform second stage of thread initialisation, in guile mode. */ static void -guilify_self_2 (SCM parent) +guilify_self_2 (SCM dynamic_state) { scm_i_thread *t = SCM_I_CURRENT_THREAD; @@ -480,10 +462,8 @@ guilify_self_2 (SCM parent) t->pointerless_freelists = scm_gc_malloc (size, "atomic freelists"); } - if (scm_is_true (parent)) - t->dynamic_state = scm_make_dynamic_state (parent); - else - t->dynamic_state = scm_i_make_initial_dynamic_state (); + t->dynamic_state = scm_gc_typed_calloc (scm_t_dynamic_state); + scm_set_current_dynamic_state (dynamic_state); t->dynstack.base = scm_gc_malloc (16 * sizeof (scm_t_bits), "dynstack"); t->dynstack.limit = t->dynstack.base + 16; @@ -557,8 +537,7 @@ init_thread_key (void) BASE is the stack base to use with GC. - PARENT is the dynamic state to use as the parent, ot SCM_BOOL_F in - which case the default dynamic state is used. + DYNAMIC_STATE is the set of fluid values to start with. Returns zero when the thread was known to guile already; otherwise return 1. @@ -569,7 +548,8 @@ init_thread_key (void) be sure. New threads are put into guile mode implicitly. */ static int -scm_i_init_thread_for_guile (struct GC_stack_base *base, SCM parent) +scm_i_init_thread_for_guile (struct GC_stack_base *base, + SCM dynamic_state) { scm_i_pthread_once (&init_thread_key_once, init_thread_key); @@ -612,7 +592,7 @@ scm_i_init_thread_for_guile (struct GC_stack_base *base, SCM parent) #endif guilify_self_1 (base); - guilify_self_2 (parent); + guilify_self_2 (dynamic_state); } return 1; } @@ -624,8 +604,7 @@ scm_init_guile () struct GC_stack_base stack_base; if (GC_get_stack_base (&stack_base) == GC_SUCCESS) - scm_i_init_thread_for_guile (&stack_base, - scm_i_default_dynamic_state); + scm_i_init_thread_for_guile (&stack_base, default_dynamic_state); else { fprintf (stderr, "Failed to get stack base for current thread.\n"); @@ -637,7 +616,7 @@ struct with_guile_args { GC_fn_type func; void *data; - SCM parent; + SCM dynamic_state; }; static void * @@ -649,14 +628,14 @@ with_guile_trampoline (void *data) } static void * -with_guile_and_parent (struct GC_stack_base *base, void *data) +with_guile (struct GC_stack_base *base, void *data) { void *res; int new_thread; scm_i_thread *t; struct with_guile_args *args = data; - new_thread = scm_i_init_thread_for_guile (base, args->parent); + new_thread = scm_i_init_thread_for_guile (base, args->dynamic_state); t = SCM_I_CURRENT_THREAD; if (new_thread) { @@ -698,22 +677,21 @@ with_guile_and_parent (struct GC_stack_base *base, void *data) } static void * -scm_i_with_guile_and_parent (void *(*func)(void *), void *data, SCM parent) +scm_i_with_guile (void *(*func)(void *), void *data, SCM dynamic_state) { struct with_guile_args args; args.func = func; args.data = data; - args.parent = parent; + args.dynamic_state = dynamic_state; - return GC_call_with_stack_base (with_guile_and_parent, &args); + return GC_call_with_stack_base (with_guile, &args); } void * scm_with_guile (void *(*func)(void *), void *data) { - return scm_i_with_guile_and_parent (func, data, - scm_i_default_dynamic_state); + return scm_i_with_guile (func, data, default_dynamic_state); } void * @@ -753,7 +731,7 @@ scm_call_with_new_thread (SCM thunk, SCM handler) } typedef struct { - SCM parent; + SCM dynamic_state; SCM thunk; } launch_data; @@ -769,7 +747,7 @@ launch_thread (void *d) { launch_data *data = (launch_data *)d; scm_i_pthread_detach (scm_i_pthread_self ()); - scm_i_with_guile_and_parent (really_launch, d, data->parent); + scm_i_with_guile (really_launch, d, data->dynamic_state); return NULL; } @@ -786,7 +764,7 @@ SCM_DEFINE (scm_sys_call_with_new_thread, "%call-with-new-thread", 1, 0, 0, GC_collect_a_little (); data = scm_gc_typed_calloc (launch_data); - data->parent = scm_current_dynamic_state (); + data->dynamic_state = scm_current_dynamic_state (); data->thunk = thunk; err = scm_i_pthread_create (&id, NULL, launch_thread, data); if (err) @@ -1792,8 +1770,8 @@ scm_init_threads () sizeof (struct scm_cond)); scm_set_smob_print (scm_tc16_condvar, scm_cond_print); - scm_i_default_dynamic_state = SCM_BOOL_F; - guilify_self_2 (SCM_BOOL_F); + default_dynamic_state = SCM_BOOL_F; + guilify_self_2 (scm_i_make_initial_dynamic_state ()); threads_initialized_p = 1; scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, @@ -1804,8 +1782,7 @@ scm_init_threads () void scm_init_threads_default_dynamic_state () { - SCM state = scm_make_dynamic_state (scm_current_dynamic_state ()); - scm_i_default_dynamic_state = state; + default_dynamic_state = scm_current_dynamic_state (); } diff --git a/libguile/threads.h b/libguile/threads.h index e8e56e71f..e09a2ef3a 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -72,7 +72,7 @@ typedef struct scm_i_thread { /* Other thread local things. */ - SCM dynamic_state; + scm_t_dynamic_state *dynamic_state; /* The dynamic stack. */ scm_t_dynstack dynstack; @@ -126,7 +126,6 @@ SCM_API SCM scm_spawn_thread (scm_t_catch_body body, void *body_data, SCM_API void *scm_without_guile (void *(*func)(void *), void *data); SCM_API void *scm_with_guile (void *(*func)(void *), void *data); -SCM_INTERNAL void scm_i_reset_fluid (size_t); SCM_INTERNAL void scm_threads_prehistory (void *); SCM_INTERNAL void scm_init_threads (void); SCM_INTERNAL void scm_init_threads_default_dynamic_state (void); diff --git a/libguile/throw.c b/libguile/throw.c index 45bab7a70..a6a95bab1 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -76,7 +76,7 @@ catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler) SCM eh, prompt_tag; SCM res; scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack; - SCM dynamic_state = SCM_I_CURRENT_THREAD->dynamic_state; + scm_t_dynamic_state *dynamic_state = SCM_I_CURRENT_THREAD->dynamic_state; scm_i_jmp_buf registers; scm_t_ptrdiff saved_stack_depth; diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 03cca8d44..1ee21642f 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -403,7 +403,7 @@ #define VM_VALIDATE_BYTEVECTOR(x, proc) \ VM_VALIDATE (x, SCM_BYTEVECTOR_P, proc, bytevector) #define VM_VALIDATE_CHAR(x, proc) \ - VM_VALIDATE (x, SCM_CHARP, proc, char); + VM_VALIDATE (x, SCM_CHARP, proc, char) #define VM_VALIDATE_PAIR(x, proc) \ VM_VALIDATE (x, scm_is_pair, proc, pair) #define VM_VALIDATE_STRING(obj, proc) \ @@ -2166,30 +2166,26 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, VM_DEFINE_OP (74, fluid_ref, "fluid-ref", OP1 (X8_S12_S12) | OP_DST) { scm_t_uint16 dst, src; - size_t num; - SCM fluid, fluids; + SCM fluid; + struct scm_cache_entry *entry; UNPACK_12_12 (op, dst, src); fluid = SP_REF (src); - fluids = SCM_I_DYNAMIC_STATE_FLUIDS (thread->dynamic_state); - if (SCM_UNLIKELY (!SCM_FLUID_P (fluid)) - || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids))) + + /* If we find FLUID in the cache, then it is indeed a fluid. */ + entry = scm_cache_lookup (&thread->dynamic_state->cache, fluid); + if (SCM_LIKELY (scm_is_eq (SCM_PACK (entry->key), fluid) + && !SCM_UNBNDP (SCM_PACK (entry->value)))) { - /* Punt dynstate expansion and error handling to the C proc. */ - SYNC_IP (); - SP_SET (dst, scm_fluid_ref (fluid)); + SP_SET (dst, SCM_PACK (entry->value)); + NEXT (1); } else { - SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num); - if (scm_is_eq (val, SCM_UNDEFINED)) - val = SCM_I_FLUID_DEFAULT (fluid); - VM_ASSERT (!scm_is_eq (val, SCM_UNDEFINED), - vm_error_unbound_fluid (fluid)); - SP_SET (dst, val); + SYNC_IP (); + SP_SET (dst, scm_fluid_ref (fluid)); + NEXT (1); } - - NEXT (1); } /* fluid-set fluid:12 val:12 @@ -2199,23 +2195,26 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, VM_DEFINE_OP (75, fluid_set, "fluid-set!", OP1 (X8_S12_S12)) { scm_t_uint16 a, b; - size_t num; - SCM fluid, fluids; + SCM fluid, value; + struct scm_cache_entry *entry; UNPACK_12_12 (op, a, b); fluid = SP_REF (a); - fluids = SCM_I_DYNAMIC_STATE_FLUIDS (thread->dynamic_state); - if (SCM_UNLIKELY (!SCM_FLUID_P (fluid)) - || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids))) + value = SP_REF (b); + + /* If we find FLUID in the cache, then it is indeed a fluid. */ + entry = scm_cache_lookup (&thread->dynamic_state->cache, fluid); + if (SCM_LIKELY (scm_is_eq (SCM_PACK (entry->key), fluid))) { - /* Punt dynstate expansion and error handling to the C proc. */ - SYNC_IP (); - scm_fluid_set_x (fluid, SP_REF (b)); + entry->value = SCM_UNPACK (value); + NEXT (1); } else - SCM_SIMPLE_VECTOR_SET (fluids, num, SP_REF (b)); - - NEXT (1); + { + SYNC_IP (); + scm_fluid_set_x (fluid, value); + NEXT (1); + } } diff --git a/libguile/vm.c b/libguile/vm.c index 3c616205b..cc7bbf158 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -37,7 +37,7 @@ #include "libguile/_scm.h" #include "libguile/atomic.h" #include "libguile/atomics-internal.h" -#include "libguile/control.h" +#include "libguile/cache-internal.h" #include "libguile/control.h" #include "libguile/frames.h" #include "libguile/gc-inline.h" @@ -434,7 +434,6 @@ vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont, size_t nargs, static void vm_error (const char *msg, SCM arg) SCM_NORETURN; static void vm_error_bad_instruction (scm_t_uint32 inst) SCM_NORETURN SCM_NOINLINE; static void vm_error_unbound (SCM sym) SCM_NORETURN SCM_NOINLINE; -static void vm_error_unbound_fluid (SCM fluid) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_variable (const char *func_name, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN SCM_NOINLINE; @@ -479,14 +478,6 @@ vm_error_unbound (SCM sym) scm_list_1 (sym), SCM_BOOL_F); } -static void -vm_error_unbound_fluid (SCM fluid) -{ - scm_error_scm (scm_misc_error_key, SCM_BOOL_F, - scm_from_latin1_string ("Unbound fluid: ~s"), - scm_list_1 (fluid), SCM_BOOL_F); -} - static void vm_error_not_a_variable (const char *func_name, SCM x) { diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm index 52b3d634b..2f41686ac 100644 --- a/module/ice-9/deprecated.scm +++ b/module/ice-9/deprecated.scm @@ -78,3 +78,16 @@ thread-exited? total-processor-count current-processor-count) + +(define-public make-dynamic-state + (case-lambda + (() + (issue-deprecation-warning + "`(make-dynamic-state)' is deprecated; use `(current-dynamic-state)' +instead.") + (current-dynamic-state)) + ((parent) + (issue-deprecation-warning + "`(make-dynamic-state PARENT)' is deprecated; now that reified +dynamic state objects are themselves copies, just use PARENT directly.") + parent))) From 7184c176b40db274a92ae14eed1f7d71a0c26e8b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 5 Dec 2016 22:48:49 +0100 Subject: [PATCH 640/865] with-dynamic-state compiler and VM support * libguile/dynstack.h (SCM_DYNSTACK_TYPE_DYNAMIC_STATE): * libguile/dynstack.c (DYNAMIC_STATE_WORDS, DYNAMIC_STATE_STATE_BOX): (scm_dynstack_push_dynamic_state): (scm_dynstack_unwind_dynamic_state): New definitions. (scm_dynstack_unwind_1, scm_dynstack_wind_1): Add with-dynamic-state cases. * libguile/memoize.c (push_dynamic_state, pop_dynamic_state) (do_push_dynamic_state, do_pop_dynamic_state): New definitions. (memoize, scm_init_memoize): Handle push-dynamic-state and pop-dynamic-state. * libguile/vm-engine.c (push-dynamic-state, pop-dynamic-state): New opcodes. * module/ice-9/boot-9.scm (with-dynamic-state): New definition in Scheme so that the push-dynamic-state and pop-dynamic-state always run in the VM. * module/language/cps/compile-bytecode.scm (compile-function): * module/language/cps/effects-analysis.scm: * module/language/cps/types.scm: * module/language/tree-il/effects.scm (make-effects-analyzer): * module/language/tree-il/peval.scm (peval): * module/language/tree-il/primitives.scm (*interesting-primitive-names*): * module/system/vm/assembler.scm: Add support for with-dynamic-state to the compiler. * test-suite/tests/fluids.test ("dynamic states"): Add basic tests. * doc/ref/vm.texi (Dynamic Environment Instructions): Update. --- doc/ref/vm.texi | 23 +++++++ libguile/dynstack.c | 51 ++++++++++++++++ libguile/dynstack.h | 5 ++ libguile/memoize.c | 32 ++++++++++ libguile/vm-engine.c | 31 +++++++++- module/ice-9/boot-9.scm | 9 +++ module/language/cps/compile-bytecode.scm | 4 ++ module/language/cps/effects-analysis.scm | 4 +- module/language/cps/types.scm | 4 +- module/language/tree-il/effects.scm | 8 +++ module/language/tree-il/peval.scm | 13 ++++ module/language/tree-il/primitives.scm | 2 +- module/system/vm/assembler.scm | 2 + test-suite/tests/fluids.test | 77 ++++++++++++++++++++++++ 14 files changed, 260 insertions(+), 5 deletions(-) diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 60bce9ed3..1abbbce15 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -1204,6 +1204,18 @@ Set the value of the fluid in @var{dst} to the value in @var{src}. Write the value of the current thread to @var{dst}. @end deftypefn +@deftypefn Instruction {} push-dynamic-state s24:@var{state} +Save the current set of fluid bindings on the dynamic stack and instate +the bindings from @var{state} instead. @xref{Fluids and Dynamic +States}. +@end deftypefn + +@deftypefn Instruction {} pop-dynamic-state x24:@var{_} +Restore a saved set of fluid bindings from the dynamic stack. +@code{push-dynamic-state} should always be balanced with +@code{pop-dynamic-state}. +@end deftypefn + @node Miscellaneous Instructions @subsubsection Miscellaneous Instructions @@ -1237,6 +1249,17 @@ Pop the stack pointer by @var{count} words, discarding any values that were stored there. @end deftypefn +@deftypefn Instruction {} handle-interrupts x24:@var{_} +Handle pending asynchronous interrupts (asyncs). @xref{Asyncs}. The +compiler inserts @code{handle-interrupts} instructions before any call, +return, or loop back-edge. +@end deftypefn + +@deftypefn Instruction {} return-from-interrupt x24:@var{_} +A special instruction to return from a call and also pop off the stack +frame from the call. Used when returning from asynchronous interrupts. +@end deftypefn + @node Inlined Scheme Instructions @subsubsection Inlined Scheme Instructions diff --git a/libguile/dynstack.c b/libguile/dynstack.c index 7fb858391..ff57c430d 100644 --- a/libguile/dynstack.c +++ b/libguile/dynstack.c @@ -53,6 +53,9 @@ #define WITH_FLUID_FLUID(top) (SCM_PACK ((top)[0])) #define WITH_FLUID_VALUE_BOX(top) (SCM_PACK ((top)[1])) +#define DYNAMIC_STATE_WORDS 1 +#define DYNAMIC_STATE_STATE_BOX(top) (SCM_PACK ((top)[0])) + @@ -230,6 +233,22 @@ dynstack_pop (scm_t_dynstack *dynstack, scm_t_bits **words) return tag; } +void +scm_dynstack_push_dynamic_state (scm_t_dynstack *dynstack, SCM state, + scm_t_dynamic_state *dynamic_state) +{ + scm_t_bits *words; + SCM state_box; + + if (SCM_UNLIKELY (scm_is_false (scm_dynamic_state_p (state)))) + scm_wrong_type_arg ("with-dynamic-state", 0, state); + + state_box = scm_make_variable (scm_set_current_dynamic_state (state)); + words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_DYNAMIC_STATE, 0, + DYNAMIC_STATE_WORDS); + words[0] = SCM_UNPACK (state_box); +} + void scm_dynstack_pop (scm_t_dynstack *dynstack) { @@ -305,6 +324,12 @@ scm_dynstack_wind_1 (scm_t_dynstack *dynstack, scm_t_bits *item) scm_call_0 (DYNWIND_ENTER (item)); break; + case SCM_DYNSTACK_TYPE_DYNAMIC_STATE: + scm_variable_set_x (DYNAMIC_STATE_STATE_BOX (item), + scm_set_current_dynamic_state + (scm_variable_ref (DYNAMIC_STATE_STATE_BOX (item)))); + break; + case SCM_DYNSTACK_TYPE_NONE: default: abort (); @@ -362,6 +387,13 @@ scm_dynstack_unwind_1 (scm_t_dynstack *dynstack) } break; + case SCM_DYNSTACK_TYPE_DYNAMIC_STATE: + scm_variable_set_x (DYNAMIC_STATE_STATE_BOX (words), + scm_set_current_dynamic_state + (scm_variable_ref (DYNAMIC_STATE_STATE_BOX (words)))); + clear_scm_t_bits (words, DYNAMIC_STATE_WORDS); + break; + case SCM_DYNSTACK_TYPE_NONE: default: abort (); @@ -542,6 +574,25 @@ scm_dynstack_unwind_fluid (scm_t_dynstack *dynstack, clear_scm_t_bits (words, len); } +void +scm_dynstack_unwind_dynamic_state (scm_t_dynstack *dynstack, + scm_t_dynamic_state *dynamic_state) +{ + scm_t_bits tag, *words; + size_t len; + + tag = dynstack_pop (dynstack, &words); + len = SCM_DYNSTACK_TAG_LEN (tag); + + assert (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_DYNAMIC_STATE); + assert (len == DYNAMIC_STATE_WORDS); + + scm_variable_set_x (DYNAMIC_STATE_STATE_BOX (words), + scm_set_current_dynamic_state + (scm_variable_ref (DYNAMIC_STATE_STATE_BOX (words)))); + clear_scm_t_bits (words, len); +} + /* Local Variables: diff --git a/libguile/dynstack.h b/libguile/dynstack.h index 592e7c819..9d91fb667 100644 --- a/libguile/dynstack.h +++ b/libguile/dynstack.h @@ -81,6 +81,7 @@ typedef enum { SCM_DYNSTACK_TYPE_WITH_FLUID, SCM_DYNSTACK_TYPE_PROMPT, SCM_DYNSTACK_TYPE_DYNWIND, + SCM_DYNSTACK_TYPE_DYNAMIC_STATE, } scm_t_dynstack_item_type; #define SCM_DYNSTACK_TAG_TYPE_MASK 0xf @@ -150,6 +151,8 @@ SCM_INTERNAL void scm_dynstack_push_unwinder (scm_t_dynstack *, SCM_INTERNAL void scm_dynstack_push_fluid ( scm_t_dynstack *, SCM fluid, SCM value, scm_t_dynamic_state *dynamic_state); +SCM_INTERNAL void scm_dynstack_push_dynamic_state (scm_t_dynstack *, SCM, + scm_t_dynamic_state *); SCM_INTERNAL void scm_dynstack_push_prompt (scm_t_dynstack *, scm_t_dynstack_prompt_flags, SCM key, @@ -188,6 +191,8 @@ SCM_INTERNAL scm_t_bits* scm_dynstack_unwind_fork (scm_t_dynstack *, SCM_INTERNAL void scm_dynstack_unwind_frame (scm_t_dynstack *); SCM_INTERNAL void scm_dynstack_unwind_fluid (scm_t_dynstack *dynstack, scm_t_dynamic_state *dynamic_state); +SCM_INTERNAL void scm_dynstack_unwind_dynamic_state + (scm_t_dynstack *dynstack, scm_t_dynamic_state *dynamic_state); SCM_INTERNAL scm_t_bits* scm_dynstack_find_prompt (scm_t_dynstack *, SCM, scm_t_dynstack_prompt_flags *, diff --git a/libguile/memoize.c b/libguile/memoize.c index 1267d4771..58abeb110 100644 --- a/libguile/memoize.c +++ b/libguile/memoize.c @@ -68,6 +68,8 @@ static SCM wind; static SCM unwind; static SCM push_fluid; static SCM pop_fluid; +static SCM push_dynamic_state; +static SCM pop_dynamic_state; static SCM do_wind (SCM in, SCM out) @@ -100,6 +102,24 @@ do_pop_fluid (void) return SCM_UNSPECIFIED; } +static SCM +do_push_dynamic_state (SCM state) +{ + scm_i_thread *thread = SCM_I_CURRENT_THREAD; + scm_dynstack_push_dynamic_state (&thread->dynstack, state, + thread->dynamic_state); + return SCM_UNSPECIFIED; +} + +static SCM +do_pop_dynamic_state (void) +{ + scm_i_thread *thread = SCM_I_CURRENT_THREAD; + scm_dynstack_unwind_dynamic_state (&thread->dynstack, + thread->dynamic_state); + return SCM_UNSPECIFIED; +} + @@ -482,6 +502,14 @@ memoize (SCM exp, SCM env) else if (nargs == 0 && scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), SCM_EOL); + else if (nargs == 1 + && scm_is_eq (name, + scm_from_latin1_symbol ("push-dynamic-state"))) + return MAKMEMO_CALL (MAKMEMO_QUOTE (push_dynamic_state), args); + else if (nargs == 0 + && scm_is_eq (name, + scm_from_latin1_symbol ("pop-dynamic-state"))) + return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_dynamic_state), SCM_EOL); else if (scm_is_eq (scm_current_module (), scm_the_root_module ())) return MAKMEMO_CALL (maybe_makmemo_capture_module (MAKMEMO_BOX_REF @@ -869,6 +897,10 @@ scm_init_memoize () unwind = scm_c_make_gsubr ("unwind", 0, 0, 0, do_unwind); push_fluid = scm_c_make_gsubr ("push-fluid", 2, 0, 0, do_push_fluid); pop_fluid = scm_c_make_gsubr ("pop-fluid", 0, 0, 0, do_pop_fluid); + push_dynamic_state = scm_c_make_gsubr ("push-dynamic_state", 1, 0, 0, + do_push_dynamic_state); + pop_dynamic_state = scm_c_make_gsubr ("pop-dynamic_state", 0, 0, 0, + do_pop_dynamic_state); list_of_guile = scm_list_1 (scm_from_latin1_symbol ("guile")); } diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 1ee21642f..44068458e 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -3921,8 +3921,35 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (0); } - VM_DEFINE_OP (185, unused_185, NULL, NOP) - VM_DEFINE_OP (186, unused_186, NULL, NOP) + /* push-dynamic-state state:24 + * + * Save the current fluid bindings on the dynamic stack, and use STATE + * instead. + */ + VM_DEFINE_OP (185, push_dynamic_state, "push-dynamic-state", OP1 (X8_S24)) + { + scm_t_uint32 state; + + UNPACK_24 (op, state); + + SYNC_IP (); + scm_dynstack_push_dynamic_state (&thread->dynstack, SP_REF (state), + thread->dynamic_state); + NEXT (1); + } + + /* pop-dynamic-state _:24 + * + * Restore the saved fluid bindings from the dynamic stack. + */ + VM_DEFINE_OP (186, pop_dynamic_state, "pop-dynamic-state", OP1 (X32)) + { + SYNC_IP (); + scm_dynstack_unwind_dynamic_state (&thread->dynstack, + thread->dynamic_state); + NEXT (1); + } + VM_DEFINE_OP (187, unused_187, NULL, NOP) VM_DEFINE_OP (188, unused_188, NULL, NOP) VM_DEFINE_OP (189, unused_189, NULL, NOP) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 7f620979d..802ca7735 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -154,6 +154,15 @@ a-cont ((@@ primitive pop-fluid)) (apply values vals)))) +(define (with-dynamic-state state thunk) + "Call @var{proc} while @var{state} is the current dynamic state object. +@var{thunk} must be a procedure of no arguments." + ((@@ primitive push-dynamic-state) state) + (call-with-values thunk + (lambda vals + ((@@ primitive pop-dynamic-state)) + (apply values vals)))) + ;;; {Simple Debugging Tools} diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 7755b1e67..db5b8fa70 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -330,6 +330,10 @@ (emit-push-fluid asm (from-sp (slot fluid)) (from-sp (slot val)))) (($ $primcall 'pop-fluid ()) (emit-pop-fluid asm)) + (($ $primcall 'push-dynamic-state (state)) + (emit-push-dynamic-state asm (from-sp (slot state)))) + (($ $primcall 'pop-dynamic-state ()) + (emit-pop-dynamic-state asm)) (($ $primcall 'wind (winder unwinder)) (emit-wind asm (from-sp (slot winder)) (from-sp (slot unwinder)))) (($ $primcall 'bv-u8-set! (bv idx val)) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 38c0bab7e..9ce65853d 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -287,7 +287,9 @@ is or might be a read or a write to the same location as A." ((fluid-ref f) (&read-object &fluid) &type-check) ((fluid-set! f v) (&write-object &fluid) &type-check) ((push-fluid f v) (&write-object &fluid) &type-check) - ((pop-fluid) (&write-object &fluid) &type-check)) + ((pop-fluid) (&write-object &fluid)) + ((push-dynamic-state state) (&write-object &fluid) &type-check) + ((pop-dynamic-state) (&write-object &fluid))) ;; Threads. Calls cause &all-effects, which reflects the fact that any ;; call can capture a partial continuation and reinstate it on another diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index e8f53bb3f..c7e42117c 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -558,7 +558,9 @@ minimum, and maximum." ((fluid-ref (&fluid 1)) &all-types) ((fluid-set! (&fluid 0 1) &all-types)) ((push-fluid (&fluid 0 1) &all-types)) - ((pop-fluid))) + ((pop-fluid)) + ((push-dynamic-state &all-types)) + ((pop-dynamic-state))) diff --git a/module/language/tree-il/effects.scm b/module/language/tree-il/effects.scm index 68bb8a8a4..a133e3269 100644 --- a/module/language/tree-il/effects.scm +++ b/module/language/tree-il/effects.scm @@ -360,6 +360,14 @@ of an expression." (($ _ 'pop-fluid ()) (logior (cause &fluid))) + (($ _ 'push-dynamic-state (state)) + (logior (compute-effects state) + (cause &type-check) + (cause &fluid))) + + (($ _ 'pop-dynamic-state ()) + (logior (cause &fluid))) + (($ _ 'car (x)) (logior (compute-effects x) (cause &type-check) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 07004a349..993fa0ad6 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -1219,6 +1219,19 @@ top-level bindings from ENV and return the resulting expression." (make-call src thunk '()) (make-primcall src 'pop-fluid '())))))))) + (($ src 'with-dynamic-state (state thunk)) + (for-tail + (with-temporaries + src (list state thunk) 1 constant-expression? + (match-lambda + ((state thunk) + (make-seq src + (make-primcall src 'push-dynamic-state (list state)) + (make-begin0 src + (make-call src thunk '()) + (make-primcall src 'pop-dynamic-state + '())))))))) + (($ src 'values exps) (cond ((null? exps) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index be613c714..90c1d2d1a 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -84,7 +84,7 @@ current-module define! - current-thread fluid-ref fluid-set! with-fluid* + current-thread fluid-ref fluid-set! with-fluid* with-dynamic-state call-with-prompt abort-to-prompt* abort-to-prompt diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index a3d7839f5..2c6bf816a 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -122,6 +122,8 @@ emit-unwind emit-push-fluid emit-pop-fluid + emit-push-dynamic-state + emit-pop-dynamic-state emit-current-thread emit-fluid-ref emit-fluid-set! diff --git a/test-suite/tests/fluids.test b/test-suite/tests/fluids.test index ce7e62578..c043d94d3 100644 --- a/test-suite/tests/fluids.test +++ b/test-suite/tests/fluids.test @@ -184,3 +184,80 @@ (catch #t (lambda () (fluid-ref fluid)) (lambda (key . args) #t))))) + +(with-test-prefix "dynamic states" + (pass-if "basics" + (dynamic-state? (current-dynamic-state))) + + (pass-if "with a fluid (basic)" + (let ((fluid (make-fluid #f)) + (state (current-dynamic-state))) + (with-dynamic-state + state + (lambda () + (eqv? (fluid-ref fluid) #f))))) + + (pass-if "with a fluid (set outer)" + (let ((fluid (make-fluid #f)) + (state (current-dynamic-state))) + (fluid-set! fluid #t) + (and (with-dynamic-state + state + (lambda () + (eqv? (fluid-ref fluid) #f))) + (eqv? (fluid-ref fluid) #t)))) + + (pass-if "with a fluid (set inner)" + (let ((fluid (make-fluid #f)) + (state (current-dynamic-state))) + (and (with-dynamic-state + state + (lambda () + (fluid-set! fluid #t) + (eqv? (fluid-ref fluid) #t))) + (eqv? (fluid-ref fluid) #f)))) + + (pass-if "dynstate captured (1)" + (let ((fluid (make-fluid #f)) + (state (current-dynamic-state)) + (tag (make-prompt-tag "hey"))) + (let ((k (call-with-prompt tag + (lambda () + (with-dynamic-state + state + (lambda () + (abort-to-prompt tag) + (fluid-ref fluid)))) + (lambda (k) k)))) + (eqv? (k) #f)))) + + (pass-if "dynstate captured (2)" + (let ((fluid (make-fluid #f)) + (state (current-dynamic-state)) + (tag (make-prompt-tag "hey"))) + (let ((k (call-with-prompt tag + (lambda () + (with-dynamic-state + state + (lambda () + (abort-to-prompt tag) + (fluid-ref fluid)))) + (lambda (k) k)))) + (fluid-set! fluid #t) + (eqv? (k) #f)))) + + (pass-if "dynstate captured (3)" + (let ((fluid (make-fluid #f)) + (state (current-dynamic-state)) + (tag (make-prompt-tag "hey"))) + (let ((k (call-with-prompt tag + (lambda () + (with-dynamic-state + state + (lambda () + (fluid-set! fluid #t) + (abort-to-prompt tag) + (fluid-ref fluid)))) + (lambda (k) k)))) + (and (eqv? (fluid-ref fluid) #f) + (eqv? (k) #t)))))) From f94ea26a972daa2ee01d4612be0b48a2f4300b1c Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Tue, 6 Dec 2016 13:39:56 -0600 Subject: [PATCH 641/865] Fix small typo in suspendable-ports documentation. * doc/ref/api-io.texi (Non-Blocking I/O): Fix example to call use-modules rather than use-module. --- doc/ref/api-io.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 9facb38e0..9bd78d229 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -1768,7 +1768,7 @@ parallel implementation of port operations. To use this implementation, do the following: @example -(use-module (ice-9 suspendable-ports)) +(use-modules (ice-9 suspendable-ports)) (install-suspendable-ports!) @end example From 500e4a83e462b6d59daf9e680fa11139455d5812 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 6 Dec 2016 21:09:53 +0100 Subject: [PATCH 642/865] Move fluids, parameters docs nearer to dynamic-wind * doc/ref/api-control.texi: * doc/ref/api-scheduling.texi: Move fluids and parameters docs. --- doc/ref/api-control.texi | 297 ++++++++++++++++++++++++++++++++++++ doc/ref/api-scheduling.texi | 297 ------------------------------------ 2 files changed, 297 insertions(+), 297 deletions(-) diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index 5847b25de..8b20e3e45 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.texi @@ -21,6 +21,8 @@ flow of Scheme affects C code. * Exceptions:: Throwing and catching exceptions. * Error Reporting:: Procedures for signaling errors. * Dynamic Wind:: Dealing with non-local entrance/exit. +* Fluids and Dynamic States:: Dynamic scope building blocks. +* Parameters:: A dynamic scope facility. * Handling Errors:: How to handle errors in C code. * Continuation Barriers:: Protection from non-local control flow. @end menu @@ -1658,6 +1660,301 @@ context is exited, whether normally or non-locally. @end deftypefn +@node Fluids and Dynamic States +@subsection Fluids and Dynamic States + +@cindex fluids + +A @emph{fluid} is an object that can store one value per @emph{dynamic +state}. Each thread has a current dynamic state, and when accessing a +fluid, this current dynamic state is used to provide the actual value. +In this way, fluids can be used for thread local storage. Additionally, +the set of current fluid values can be captured by a dynamic state and +reinstated in some other dynamic extent, possibly in another thread +even. + +Fluids are a building block for implementing dynamically scoped +variables. Dynamically scoped variables are useful when you want to set +a variable to a value during some dynamic extent in the execution of +your program and have them revert to their original value when the +control flow is outside of this dynamic extent. See the description of +@code{with-fluids} below for details. + +Guile uses fluids to implement parameters (@pxref{Parameters}). Usually +you just want to use parameters directly. However it can be useful to +know what a fluid is and how it works, so that's what this section is +about. + +New fluids are created with @code{make-fluid} and @code{fluid?} is +used for testing whether an object is actually a fluid. The values +stored in a fluid can be accessed with @code{fluid-ref} and +@code{fluid-set!}. + +@deffn {Scheme Procedure} make-fluid [dflt] +@deffnx {C Function} scm_make_fluid () +@deffnx {C Function} scm_make_fluid_with_default (dflt) +Return a newly created fluid, whose initial value is @var{dflt}, or +@code{#f} if @var{dflt} is not given. +Fluids are objects that can hold one +value per dynamic state. That is, modifications to this value are +only visible to code that executes with the same dynamic state as +the modifying code. When a new dynamic state is constructed, it +inherits the values from its parent. Because each thread normally executes +with its own dynamic state, you can use fluids for thread local storage. +@end deffn + +@deffn {Scheme Procedure} make-unbound-fluid +@deffnx {C Function} scm_make_unbound_fluid () +Return a new fluid that is initially unbound (instead of being +implicitly bound to some definite value). +@end deffn + +@deffn {Scheme Procedure} fluid? obj +@deffnx {C Function} scm_fluid_p (obj) +Return @code{#t} if @var{obj} is a fluid; otherwise, return +@code{#f}. +@end deffn + +@deffn {Scheme Procedure} fluid-ref fluid +@deffnx {C Function} scm_fluid_ref (fluid) +Return the value associated with @var{fluid} in the current +dynamic root. If @var{fluid} has not been set, then return +its default value. Calling @code{fluid-ref} on an unbound fluid produces +a runtime error. +@end deffn + +@deffn {Scheme Procedure} fluid-set! fluid value +@deffnx {C Function} scm_fluid_set_x (fluid, value) +Set the value associated with @var{fluid} in the current dynamic root. +@end deffn + +@deffn {Scheme Procedure} fluid-unset! fluid +@deffnx {C Function} scm_fluid_unset_x (fluid) +Disassociate the given fluid from any value, making it unbound. +@end deffn + +@deffn {Scheme Procedure} fluid-bound? fluid +@deffnx {C Function} scm_fluid_bound_p (fluid) +Returns @code{#t} if the given fluid is bound to a value, otherwise +@code{#f}. +@end deffn + +@code{with-fluids*} temporarily changes the values of one or more fluids, +so that the given procedure and each procedure called by it access the +given values. After the procedure returns, the old values are restored. + +@deffn {Scheme Procedure} with-fluid* fluid value thunk +@deffnx {C Function} scm_with_fluid (fluid, value, thunk) +Set @var{fluid} to @var{value} temporarily, and call @var{thunk}. +@var{thunk} must be a procedure with no argument. +@end deffn + +@deffn {Scheme Procedure} with-fluids* fluids values thunk +@deffnx {C Function} scm_with_fluids (fluids, values, thunk) +Set @var{fluids} to @var{values} temporary, and call @var{thunk}. +@var{fluids} must be a list of fluids and @var{values} must be the +same number of their values to be applied. Each substitution is done +in the order given. @var{thunk} must be a procedure with no argument. +It is called inside a @code{dynamic-wind} and the fluids are +set/restored when control enter or leaves the established dynamic +extent. +@end deffn + +@deffn {Scheme Macro} with-fluids ((fluid value) @dots{}) body1 body2 @dots{} +Execute body @var{body1} @var{body2} @dots{} while each @var{fluid} is +set to the corresponding @var{value}. Both @var{fluid} and @var{value} +are evaluated and @var{fluid} must yield a fluid. The body is executed +inside a @code{dynamic-wind} and the fluids are set/restored when +control enter or leaves the established dynamic extent. +@end deffn + +@deftypefn {C Function} SCM scm_c_with_fluids (SCM fluids, SCM vals, SCM (*cproc)(void *), void *data) +@deftypefnx {C Function} SCM scm_c_with_fluid (SCM fluid, SCM val, SCM (*cproc)(void *), void *data) +The function @code{scm_c_with_fluids} is like @code{scm_with_fluids} +except that it takes a C function to call instead of a Scheme thunk. + +The function @code{scm_c_with_fluid} is similar but only allows one +fluid to be set instead of a list. +@end deftypefn + +@deftypefn {C Function} void scm_dynwind_fluid (SCM fluid, SCM val) +This function must be used inside a pair of calls to +@code{scm_dynwind_begin} and @code{scm_dynwind_end} (@pxref{Dynamic +Wind}). During the dynwind context, the fluid @var{fluid} is set to +@var{val}. + +More precisely, the value of the fluid is swapped with a `backup' +value whenever the dynwind context is entered or left. The backup +value is initialized with the @var{val} argument. +@end deftypefn + +@deffn {Scheme Procedure} dynamic-state? obj +@deffnx {C Function} scm_dynamic_state_p (obj) +Return @code{#t} if @var{obj} is a dynamic state object; +return @code{#f} otherwise. +@end deffn + +@deftypefn {C Procedure} int scm_is_dynamic_state (SCM obj) +Return non-zero if @var{obj} is a dynamic state object; +return zero otherwise. +@end deftypefn + +@deffn {Scheme Procedure} current-dynamic-state +@deffnx {C Function} scm_current_dynamic_state () +Return a snapshot of the current fluid-value associations as a fresh +dynamic state object. +@end deffn + +@deffn {Scheme Procedure} set-current-dynamic-state state +@deffnx {C Function} scm_set_current_dynamic_state (state) +Set the current dynamic state object to @var{state} +and return the previous current dynamic state object. +@end deffn + +@deffn {Scheme Procedure} with-dynamic-state state proc +@deffnx {C Function} scm_with_dynamic_state (state, proc) +Call @var{proc} while @var{state} is the current dynamic +state object. +@end deffn + +@deftypefn {C Procedure} void scm_dynwind_current_dynamic_state (SCM state) +Set the current dynamic state to @var{state} for the current dynwind +context. +@end deftypefn + +@deftypefn {C Procedure} {void *} scm_c_with_dynamic_state (SCM state, void *(*func)(void *), void *data) +Like @code{scm_with_dynamic_state}, but call @var{func} with +@var{data}. +@end deftypefn + +@node Parameters +@subsection Parameters + +@cindex SRFI-39 +@cindex parameter object +@tindex Parameter + +A parameter object is a procedure. Calling it with no arguments returns +its value. Calling it with one argument sets the value. + +@example +(define my-param (make-parameter 123)) +(my-param) @result{} 123 +(my-param 456) +(my-param) @result{} 456 +@end example + +The @code{parameterize} special form establishes new locations for +parameters, those new locations having effect within the dynamic scope +of the @code{parameterize} body. Leaving restores the previous +locations. Re-entering (through a saved continuation) will again use +the new locations. + +@example +(parameterize ((my-param 789)) + (my-param)) @result{} 789 +(my-param) @result{} 456 +@end example + +Parameters are like dynamically bound variables in other Lisp dialects. +They allow an application to establish parameter settings (as the name +suggests) just for the execution of a particular bit of code, restoring +when done. Examples of such parameters might be case-sensitivity for a +search, or a prompt for user input. + +Global variables are not as good as parameter objects for this sort of +thing. Changes to them are visible to all threads, but in Guile +parameter object locations are per-thread, thereby truly limiting the +effect of @code{parameterize} to just its dynamic execution. + +Passing arguments to functions is thread-safe, but that soon becomes +tedious when there's more than a few or when they need to pass down +through several layers of calls before reaching the point they should +affect. And introducing a new setting to existing code is often easier +with a parameter object than adding arguments. + +@deffn {Scheme Procedure} make-parameter init [converter] +Return a new parameter object, with initial value @var{init}. + +If a @var{converter} is given, then a call @code{(@var{converter} +val)} is made for each value set, its return is the value stored. +Such a call is made for the @var{init} initial value too. + +A @var{converter} allows values to be validated, or put into a +canonical form. For example, + +@example +(define my-param (make-parameter 123 + (lambda (val) + (if (not (number? val)) + (error "must be a number")) + (inexact->exact val)))) +(my-param 0.75) +(my-param) @result{} 3/4 +@end example +@end deffn + +@deffn {library syntax} parameterize ((param value) @dots{}) body1 body2 @dots{} +Establish a new dynamic scope with the given @var{param}s bound to new +locations and set to the given @var{value}s. @var{body1} @var{body2} +@dots{} is evaluated in that environment. The value returned is that of +last body form. + +Each @var{param} is an expression which is evaluated to get the +parameter object. Often this will just be the name of a variable +holding the object, but it can be anything that evaluates to a +parameter. + +The @var{param} expressions and @var{value} expressions are all +evaluated before establishing the new dynamic bindings, and they're +evaluated in an unspecified order. + +For example, + +@example +(define prompt (make-parameter "Type something: ")) +(define (get-input) + (display (prompt)) + ...) + +(parameterize ((prompt "Type a number: ")) + (get-input) + ...) +@end example +@end deffn + +Parameter objects are implemented using fluids (@pxref{Fluids and +Dynamic States}), so each dynamic state has its own parameter +locations. That includes the separate locations when outside any +@code{parameterize} form. When a parameter is created it gets a +separate initial location in each dynamic state, all initialized to the +given @var{init} value. + +New code should probably just use parameters instead of fluids, because +the interface is better. But for migrating old code or otherwise +providing interoperability, Guile provides the @code{fluid->parameter} +procedure: + +@deffn {Scheme Procedure} fluid->parameter fluid [conv] +Make a parameter that wraps a fluid. + +The value of the parameter will be the same as the value of the fluid. +If the parameter is rebound in some dynamic extent, perhaps via +@code{parameterize}, the new value will be run through the optional +@var{conv} procedure, as with any parameter. Note that unlike +@code{make-parameter}, @var{conv} is not applied to the initial value. +@end deffn + +As alluded to above, because each thread usually has a separate dynamic +state, each thread has its own locations behind parameter objects, and +changes in one thread are not visible to any other. When a new dynamic +state or thread is created, the values of parameters in the originating +context are copied, into new locations. + +@cindex SRFI-39 +Guile's parameters conform to SRFI-39 (@pxref{SRFI-39}). + + @node Handling Errors @subsection How to Handle Errors diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index 615e8b637..7ab621018 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -13,8 +13,6 @@ * Atomics:: Atomic references. * Mutexes and Condition Variables:: Synchronization primitives. * Blocking:: How to block properly in guile mode. -* Fluids and Dynamic States:: Thread-local variables, etc. -* Parameters:: Dynamic scoping in Scheme. * Futures:: Fine-grain parallelism. * Parallel Forms:: Parallel execution of forms. @end menu @@ -665,301 +663,6 @@ delivery of an async causes this function to be interrupted. @end deftypefn -@node Fluids and Dynamic States -@subsection Fluids and Dynamic States - -@cindex fluids - -A @emph{fluid} is an object that can store one value per @emph{dynamic -state}. Each thread has a current dynamic state, and when accessing a -fluid, this current dynamic state is used to provide the actual value. -In this way, fluids can be used for thread local storage. Additionally, -the set of current fluid values can be captured by a dynamic state and -reinstated in some other dynamic extent, possibly in another thread -even. - -Fluids are a building block for implementing dynamically scoped -variables. Dynamically scoped variables are useful when you want to set -a variable to a value during some dynamic extent in the execution of -your program and have them revert to their original value when the -control flow is outside of this dynamic extent. See the description of -@code{with-fluids} below for details. - -Guile uses fluids to implement parameters (@pxref{Parameters}). Usually -you just want to use parameters directly. However it can be useful to -know what a fluid is and how it works, so that's what this section is -about. - -New fluids are created with @code{make-fluid} and @code{fluid?} is -used for testing whether an object is actually a fluid. The values -stored in a fluid can be accessed with @code{fluid-ref} and -@code{fluid-set!}. - -@deffn {Scheme Procedure} make-fluid [dflt] -@deffnx {C Function} scm_make_fluid () -@deffnx {C Function} scm_make_fluid_with_default (dflt) -Return a newly created fluid, whose initial value is @var{dflt}, or -@code{#f} if @var{dflt} is not given. -Fluids are objects that can hold one -value per dynamic state. That is, modifications to this value are -only visible to code that executes with the same dynamic state as -the modifying code. When a new dynamic state is constructed, it -inherits the values from its parent. Because each thread normally executes -with its own dynamic state, you can use fluids for thread local storage. -@end deffn - -@deffn {Scheme Procedure} make-unbound-fluid -@deffnx {C Function} scm_make_unbound_fluid () -Return a new fluid that is initially unbound (instead of being -implicitly bound to some definite value). -@end deffn - -@deffn {Scheme Procedure} fluid? obj -@deffnx {C Function} scm_fluid_p (obj) -Return @code{#t} if @var{obj} is a fluid; otherwise, return -@code{#f}. -@end deffn - -@deffn {Scheme Procedure} fluid-ref fluid -@deffnx {C Function} scm_fluid_ref (fluid) -Return the value associated with @var{fluid} in the current -dynamic root. If @var{fluid} has not been set, then return -its default value. Calling @code{fluid-ref} on an unbound fluid produces -a runtime error. -@end deffn - -@deffn {Scheme Procedure} fluid-set! fluid value -@deffnx {C Function} scm_fluid_set_x (fluid, value) -Set the value associated with @var{fluid} in the current dynamic root. -@end deffn - -@deffn {Scheme Procedure} fluid-unset! fluid -@deffnx {C Function} scm_fluid_unset_x (fluid) -Disassociate the given fluid from any value, making it unbound. -@end deffn - -@deffn {Scheme Procedure} fluid-bound? fluid -@deffnx {C Function} scm_fluid_bound_p (fluid) -Returns @code{#t} if the given fluid is bound to a value, otherwise -@code{#f}. -@end deffn - -@code{with-fluids*} temporarily changes the values of one or more fluids, -so that the given procedure and each procedure called by it access the -given values. After the procedure returns, the old values are restored. - -@deffn {Scheme Procedure} with-fluid* fluid value thunk -@deffnx {C Function} scm_with_fluid (fluid, value, thunk) -Set @var{fluid} to @var{value} temporarily, and call @var{thunk}. -@var{thunk} must be a procedure with no argument. -@end deffn - -@deffn {Scheme Procedure} with-fluids* fluids values thunk -@deffnx {C Function} scm_with_fluids (fluids, values, thunk) -Set @var{fluids} to @var{values} temporary, and call @var{thunk}. -@var{fluids} must be a list of fluids and @var{values} must be the -same number of their values to be applied. Each substitution is done -in the order given. @var{thunk} must be a procedure with no argument. -It is called inside a @code{dynamic-wind} and the fluids are -set/restored when control enter or leaves the established dynamic -extent. -@end deffn - -@deffn {Scheme Macro} with-fluids ((fluid value) @dots{}) body1 body2 @dots{} -Execute body @var{body1} @var{body2} @dots{} while each @var{fluid} is -set to the corresponding @var{value}. Both @var{fluid} and @var{value} -are evaluated and @var{fluid} must yield a fluid. The body is executed -inside a @code{dynamic-wind} and the fluids are set/restored when -control enter or leaves the established dynamic extent. -@end deffn - -@deftypefn {C Function} SCM scm_c_with_fluids (SCM fluids, SCM vals, SCM (*cproc)(void *), void *data) -@deftypefnx {C Function} SCM scm_c_with_fluid (SCM fluid, SCM val, SCM (*cproc)(void *), void *data) -The function @code{scm_c_with_fluids} is like @code{scm_with_fluids} -except that it takes a C function to call instead of a Scheme thunk. - -The function @code{scm_c_with_fluid} is similar but only allows one -fluid to be set instead of a list. -@end deftypefn - -@deftypefn {C Function} void scm_dynwind_fluid (SCM fluid, SCM val) -This function must be used inside a pair of calls to -@code{scm_dynwind_begin} and @code{scm_dynwind_end} (@pxref{Dynamic -Wind}). During the dynwind context, the fluid @var{fluid} is set to -@var{val}. - -More precisely, the value of the fluid is swapped with a `backup' -value whenever the dynwind context is entered or left. The backup -value is initialized with the @var{val} argument. -@end deftypefn - -@deffn {Scheme Procedure} dynamic-state? obj -@deffnx {C Function} scm_dynamic_state_p (obj) -Return @code{#t} if @var{obj} is a dynamic state object; -return @code{#f} otherwise. -@end deffn - -@deftypefn {C Procedure} int scm_is_dynamic_state (SCM obj) -Return non-zero if @var{obj} is a dynamic state object; -return zero otherwise. -@end deftypefn - -@deffn {Scheme Procedure} current-dynamic-state -@deffnx {C Function} scm_current_dynamic_state () -Return a snapshot of the current fluid-value associations as a fresh -dynamic state object. -@end deffn - -@deffn {Scheme Procedure} set-current-dynamic-state state -@deffnx {C Function} scm_set_current_dynamic_state (state) -Set the current dynamic state object to @var{state} -and return the previous current dynamic state object. -@end deffn - -@deffn {Scheme Procedure} with-dynamic-state state proc -@deffnx {C Function} scm_with_dynamic_state (state, proc) -Call @var{proc} while @var{state} is the current dynamic -state object. -@end deffn - -@deftypefn {C Procedure} void scm_dynwind_current_dynamic_state (SCM state) -Set the current dynamic state to @var{state} for the current dynwind -context. -@end deftypefn - -@deftypefn {C Procedure} {void *} scm_c_with_dynamic_state (SCM state, void *(*func)(void *), void *data) -Like @code{scm_with_dynamic_state}, but call @var{func} with -@var{data}. -@end deftypefn - -@node Parameters -@subsection Parameters - -@cindex SRFI-39 -@cindex parameter object -@tindex Parameter - -A parameter object is a procedure. Calling it with no arguments returns -its value. Calling it with one argument sets the value. - -@example -(define my-param (make-parameter 123)) -(my-param) @result{} 123 -(my-param 456) -(my-param) @result{} 456 -@end example - -The @code{parameterize} special form establishes new locations for -parameters, those new locations having effect within the dynamic scope -of the @code{parameterize} body. Leaving restores the previous -locations. Re-entering (through a saved continuation) will again use -the new locations. - -@example -(parameterize ((my-param 789)) - (my-param)) @result{} 789 -(my-param) @result{} 456 -@end example - -Parameters are like dynamically bound variables in other Lisp dialects. -They allow an application to establish parameter settings (as the name -suggests) just for the execution of a particular bit of code, restoring -when done. Examples of such parameters might be case-sensitivity for a -search, or a prompt for user input. - -Global variables are not as good as parameter objects for this sort of -thing. Changes to them are visible to all threads, but in Guile -parameter object locations are per-thread, thereby truly limiting the -effect of @code{parameterize} to just its dynamic execution. - -Passing arguments to functions is thread-safe, but that soon becomes -tedious when there's more than a few or when they need to pass down -through several layers of calls before reaching the point they should -affect. And introducing a new setting to existing code is often easier -with a parameter object than adding arguments. - -@deffn {Scheme Procedure} make-parameter init [converter] -Return a new parameter object, with initial value @var{init}. - -If a @var{converter} is given, then a call @code{(@var{converter} -val)} is made for each value set, its return is the value stored. -Such a call is made for the @var{init} initial value too. - -A @var{converter} allows values to be validated, or put into a -canonical form. For example, - -@example -(define my-param (make-parameter 123 - (lambda (val) - (if (not (number? val)) - (error "must be a number")) - (inexact->exact val)))) -(my-param 0.75) -(my-param) @result{} 3/4 -@end example -@end deffn - -@deffn {library syntax} parameterize ((param value) @dots{}) body1 body2 @dots{} -Establish a new dynamic scope with the given @var{param}s bound to new -locations and set to the given @var{value}s. @var{body1} @var{body2} -@dots{} is evaluated in that environment. The value returned is that of -last body form. - -Each @var{param} is an expression which is evaluated to get the -parameter object. Often this will just be the name of a variable -holding the object, but it can be anything that evaluates to a -parameter. - -The @var{param} expressions and @var{value} expressions are all -evaluated before establishing the new dynamic bindings, and they're -evaluated in an unspecified order. - -For example, - -@example -(define prompt (make-parameter "Type something: ")) -(define (get-input) - (display (prompt)) - ...) - -(parameterize ((prompt "Type a number: ")) - (get-input) - ...) -@end example -@end deffn - -Parameter objects are implemented using fluids (@pxref{Fluids and -Dynamic States}), so each dynamic state has its own parameter -locations. That includes the separate locations when outside any -@code{parameterize} form. When a parameter is created it gets a -separate initial location in each dynamic state, all initialized to the -given @var{init} value. - -New code should probably just use parameters instead of fluids, because -the interface is better. But for migrating old code or otherwise -providing interoperability, Guile provides the @code{fluid->parameter} -procedure: - -@deffn {Scheme Procedure} fluid->parameter fluid [conv] -Make a parameter that wraps a fluid. - -The value of the parameter will be the same as the value of the fluid. -If the parameter is rebound in some dynamic extent, perhaps via -@code{parameterize}, the new value will be run through the optional -@var{conv} procedure, as with any parameter. Note that unlike -@code{make-parameter}, @var{conv} is not applied to the initial value. -@end deffn - -As alluded to above, because each thread usually has a separate dynamic -state, each thread has its own locations behind parameter objects, and -changes in one thread are not visible to any other. When a new dynamic -state or thread is created, the values of parameters in the originating -context are copied, into new locations. - -@cindex SRFI-39 -Guile's parameters conform to SRFI-39 (@pxref{SRFI-39}). - - @node Futures @subsection Futures @cindex futures From 842ba2fe3329e19f28d0770cec2ff3616b1fa1da Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 6 Dec 2016 21:31:30 +0100 Subject: [PATCH 643/865] Update fluids / dynstate docs * doc/ref/api-control.texi (Fluids and Dynamic States): Update documentation. --- doc/ref/api-control.texi | 51 ++++++++++++++++++++++++++-------------- 1 file changed, 34 insertions(+), 17 deletions(-) diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index 8b20e3e45..4fe753774 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.texi @@ -1665,26 +1665,36 @@ context is exited, whether normally or non-locally. @cindex fluids -A @emph{fluid} is an object that can store one value per @emph{dynamic -state}. Each thread has a current dynamic state, and when accessing a -fluid, this current dynamic state is used to provide the actual value. -In this way, fluids can be used for thread local storage. Additionally, -the set of current fluid values can be captured by a dynamic state and -reinstated in some other dynamic extent, possibly in another thread -even. +A @emph{fluid} is a variable whose value is associated with the dynamic +extent of a function call. In the same way that an operating system +runs a process with a given set of current input and output ports (or +file descriptors), in Guile you can arrange to call a function while +binding a fluid to a particular value. That association between fluid +and value will exist during the dynamic extent of the function call. -Fluids are a building block for implementing dynamically scoped -variables. Dynamically scoped variables are useful when you want to set -a variable to a value during some dynamic extent in the execution of -your program and have them revert to their original value when the +Fluids are a therefore a building block for implementing dynamically +scoped variables. Dynamically scoped variables are useful when you want +to set a variable to a value during some dynamic extent in the execution +of your program and have them revert to their original value when the control flow is outside of this dynamic extent. See the description of -@code{with-fluids} below for details. +@code{with-fluids} below for details. This association between fluids, +values, and dynamic extents is robust to multiple entries (as when a +captured continuation is invoked more than once) and early exits (for +example, when throwing exceptions). Guile uses fluids to implement parameters (@pxref{Parameters}). Usually you just want to use parameters directly. However it can be useful to know what a fluid is and how it works, so that's what this section is about. +The current set of fluid-value associations can be captured in a +@emph{dynamic state} object. A dynamic extent is simply that: a +snapshot of the current fluid-value associations. Guile users can +capture the current dynamic state with @code{current-dynamic-state} and +restore it later via @code{with-dynamic-state} or similar procedures. +This facility is especially useful when implementing lightweight +thread-like abstractions. + New fluids are created with @code{make-fluid} and @code{fluid?} is used for testing whether an object is actually a fluid. The values stored in a fluid can be accessed with @code{fluid-ref} and @@ -1807,19 +1817,26 @@ dynamic state object. @deffn {Scheme Procedure} set-current-dynamic-state state @deffnx {C Function} scm_set_current_dynamic_state (state) -Set the current dynamic state object to @var{state} -and return the previous current dynamic state object. +Restore the saved fluid-value associations from @var{state}, replacing +the current fluid-value associations. Return the current fluid-value +associatoins as a dynamic state object, as in +@code{current-dynamic-state}. @end deffn @deffn {Scheme Procedure} with-dynamic-state state proc @deffnx {C Function} scm_with_dynamic_state (state, proc) -Call @var{proc} while @var{state} is the current dynamic -state object. +Call @var{proc} while the fluid bindings from @var{state} have been made +current, saving the current fluid bindings. When control leaves the +invocation of @var{proc}, restore the saved bindings, saving instead the +fluid bindings from inside the call. If control later re-enters +@var{proc}, restore those saved bindings, saving the current bindings, +and so on. @end deffn @deftypefn {C Procedure} void scm_dynwind_current_dynamic_state (SCM state) Set the current dynamic state to @var{state} for the current dynwind -context. +context. Like @code{with-dynamic-state}, but in terms of Guile's +``dynwind'' C API. @end deftypefn @deftypefn {C Procedure} {void *} scm_c_with_dynamic_state (SCM state, void *(*func)(void *), void *data) From a5f3868e2fe4ee6f403fad5019f172658a2611a5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 6 Dec 2016 21:38:58 +0100 Subject: [PATCH 644/865] Minor parameters doc change * doc/ref/api-control.texi (Parameters): Make the opening a bit less abrupt. --- doc/ref/api-control.texi | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index 4fe753774..f0ded98a2 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.texi @@ -1851,8 +1851,11 @@ Like @code{scm_with_dynamic_state}, but call @var{func} with @cindex parameter object @tindex Parameter -A parameter object is a procedure. Calling it with no arguments returns -its value. Calling it with one argument sets the value. +Parameters are Guile's facility for dynamically bound variables. + +On the most basic level, a parameter object is a procedure. Calling it +with no arguments returns its value. Calling it with one argument sets +the value. @example (define my-param (make-parameter 123)) @@ -1862,7 +1865,7 @@ its value. Calling it with one argument sets the value. @end example The @code{parameterize} special form establishes new locations for -parameters, those new locations having effect within the dynamic scope +parameters, those new locations having effect within the dynamic extent of the @code{parameterize} body. Leaving restores the previous locations. Re-entering (through a saved continuation) will again use the new locations. @@ -1887,8 +1890,8 @@ effect of @code{parameterize} to just its dynamic execution. Passing arguments to functions is thread-safe, but that soon becomes tedious when there's more than a few or when they need to pass down through several layers of calls before reaching the point they should -affect. And introducing a new setting to existing code is often easier -with a parameter object than adding arguments. +affect. Introducing a new setting to existing code is often easier with +a parameter object than adding arguments. @deffn {Scheme Procedure} make-parameter init [converter] Return a new parameter object, with initial value @var{init}. From ed19bb63a4c528b65c14dbf6b3595a9aa83bb49d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 6 Dec 2016 22:00:39 +0100 Subject: [PATCH 645/865] Add thread-local variables manual section. * doc/ref/api-scheduling.texi (Thread Local Variables): New subsection. --- doc/ref/api-scheduling.texi | 49 +++++++++++++++++++++++++++++++++++++ 1 file changed, 49 insertions(+) diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index 7ab621018..86a1ad27c 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -9,6 +9,7 @@ @menu * Threads:: Multiple threads of execution. +* Thread Local Variables:: Guile doesn't really have these. * Asyncs:: Asynchronous interrupts. * Atomics:: Atomic references. * Mutexes and Condition Variables:: Synchronization primitives. @@ -164,6 +165,54 @@ information. @end deffn +@node Thread Local Variables +@subsection Thread-Local Variables + +Sometimes you want to establish a variable binding that is only valid +for a given thread: a ``thread-local variable''. Guile doesn't really +have this facility, but what it does have can work well for most use +cases we know about. + +You would think that fluids or parameters would be Guile's answer for +thread-local variables, since establishing a new fluid binding doesn't +affect bindings in other threads. @xref{Fluids and Dynamic States}, or +@xref{Parameters}. However, new threads inherit the fluid bindings that +were in place in their creator threads. In this way, a binding +established using a fluid (or a parameter) in a thread can escape to +other threads, which might not be what you want. Or, it might escape +via explicit reification via @code{current-dynamic-state}. + +Of course, this dynamic scoping might be exactly what you want; that's +why fluids and parameters work this way, and is what you want for for +many common parameters such as the current input and output ports, the +current locale conversion parameters, and the like. Perhaps this is the +case for most parameters, even. If your use case for thread-local +bindings comes from a desire to isolate a binding from its setting in +unrelated threads, then fluids and parameters apply nicely. + +On the other hand, if your use case is to prevent concurrent access to a +value from multiple threads, then using fluids or parameters is not +appropriate. In this case, our current suggestion is to use weak hash +tables or object properties whose keys are thread objects. For example: + +@example +(define (get-my-sensitive-data-structure) + ...) + +(define %thread-local (make-weak-key-hash-table)) + +(define (current-thread-local) + (or (hashq-ref %thread-local (current-thread)) + (let ((val (get-my-sensitive-data-structure))) + (hashq-set! %thread-local (current-thread) val) + val))) +@end example + +It's not a terribly nice facility and perhaps we should have a better +answer, like Racket's ``non-preserved thread cells''. Your input is +very welcome; we look forward to hearing from your experience. + + @node Asyncs @subsection Asynchronous Interrupts From 8e20a991a9e585ff04697cf418752c8bb70b3a34 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 6 Dec 2016 22:33:38 +0100 Subject: [PATCH 646/865] Update NEWS. * NEWS: Update. --- NEWS | 25 ++++++++++++++++++++++--- 1 file changed, 22 insertions(+), 3 deletions(-) diff --git a/NEWS b/NEWS index 809f5ac63..9a364cc46 100644 --- a/NEWS +++ b/NEWS @@ -9,7 +9,26 @@ Please send Guile bug reports to bug-guile@gnu.org. Changes in 2.1.5 (changes since the 2.1.4 alpha release): * Notable changes -* New interfaces +** Lightweight pre-emptive threading primitives + +The compiler now inserts special "handle-interrupts" opcodes before each +call, return, and loop back-edge. This allows the user to interrupt any +computation and to accurately profile code using interrupts. It used to +be that interrupts were run by calling a C function from the VM; now +interrupt thunks are run directly from the VM. This allows interrupts +to save a delimited continuation and, if the continuation was +established from the same VM invocation (the usual restriction), that +continuation can then be resumed. In this way users can implement +lightweight pre-emptive threading facilities. + +** with-dynamic-state in VM + +Similarly, `with-dynamic-state' no longer recurses out of the VM, +allowing captured delimited continuations that include a +`with-dynamic-state' invocation to be resumed. This is a precondition +to allow lightweight threading libraries to establish a dynamic state +per thread. + * Performance improvements ** Mutexes are now faster under contention @@ -96,8 +115,8 @@ dynamic state simply captures the current values, and calling `with-dynamic-state' copies those values into the Guile virtual machine instead of aliasing them in a way that could allow them to be mutated in place. This change allows Guile's fluid variables to be thread-safe. -To capture the locations of a dynamic state, use partial continuations -instead. +To capture the locations of a dynamic state, capture a +`with-dynamic-state' invocation using partial continuations instead. * New deprecations ** Arbiters deprecated From 7ff3d3834d7d1c0cf7887468187fb5ee200fbdc0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 6 Dec 2016 23:02:28 +0100 Subject: [PATCH 647/865] Use readdir instead of readdir_r * libguile/filesys.c: * configure.ac: Remove readdir_r / readdir64_r checks and usage. glibc's impls are thread-safe, the _r variants are squirrely and now deprecated in glibc, and it is expected that POSIX will mandate that readdir{,64} be thread-safe already. See https://sourceware.org/ml/libc-alpha/2016-02/msg00093.html. --- configure.ac | 2 +- libguile/filesys.c | 75 +++++++--------------------------------------- 2 files changed, 12 insertions(+), 65 deletions(-) diff --git a/configure.ac b/configure.ac index db0511d9d..ab4f1f711 100644 --- a/configure.ac +++ b/configure.ac @@ -773,7 +773,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h]) AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \ fesetround ftime ftruncate fchown fchmod getcwd geteuid getsid \ gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mknod nice \ - readdir_r readdir64_r readlink rename rmdir setegid seteuid \ + readlink rename rmdir setegid seteuid \ setlocale setuid setgid setpgid setsid sigaction siginterrupt stat64 \ strptime symlink sync sysconf tcgetpgrp tcsetpgrp uname waitpid \ strdup system usleep atexit on_exit chown link fcntl ttyname getpwent \ diff --git a/libguile/filesys.c b/libguile/filesys.c index 0bc366953..cccb39787 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -26,9 +26,6 @@ /* See stime.c for comments on why _POSIX_C_SOURCE is not always defined. */ #define _LARGEFILE64_SOURCE /* ask for stat64 etc */ -#ifdef __hpux -#define _POSIX_C_SOURCE 199506L /* for readdir_r */ -#endif #ifdef HAVE_CONFIG_H # include @@ -1723,12 +1720,6 @@ SCM_DEFINE (scm_opendir, "opendir", 1, 0, 0, #undef FUNC_NAME -/* FIXME: The glibc manual has a portability note that readdir_r may not - null-terminate its return string. The circumstances outlined for this - are not clear, nor is it clear what should be done about it. Lets use - NAMLEN and worry about what else should be done if/when someone can - figure it out. */ - SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0, (SCM port), "Return (as a string) the next directory entry from the directory stream\n" @@ -1736,70 +1727,26 @@ SCM_DEFINE (scm_readdir, "readdir", 1, 0, 0, "end of file object is returned.") #define FUNC_NAME s_scm_readdir { + SCM ret; struct dirent_or_dirent64 *rdent; SCM_VALIDATE_DIR (1, port); if (!SCM_DIR_OPEN_P (port)) SCM_MISC_ERROR ("Directory ~S is not open.", scm_list_1 (port)); -#if HAVE_READDIR_R - /* As noted in the glibc manual, on various systems (such as Solaris) - the d_name[] field is only 1 char and you're expected to size the - dirent buffer for readdir_r based on NAME_MAX. The MAX expressions - below effectively give either sizeof(d_name) or NAME_MAX+1, - whichever is bigger. + scm_dynwind_begin (0); + scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex); - On solaris 10 there's no NAME_MAX constant, it's necessary to use - pathconf(). We prefer NAME_MAX though, since it should be a constant - and will therefore save a system call. We also prefer it since dirfd() - is not available everywhere. + errno = 0; + SCM_SYSCALL (rdent = readdir_or_readdir64 ((DIR *) SCM_SMOB_DATA_1 (port))); + if (errno != 0) + SCM_SYSERROR; - An alternative to dirfd() would be to open() the directory and then use - fdopendir(), if the latter is available. That'd let us hold the fd - somewhere in the smob, or just the dirent size calculated once. */ - { - struct dirent_or_dirent64 de; /* just for sizeof */ - DIR *ds = (DIR *) SCM_SMOB_DATA_1 (port); -#ifdef NAME_MAX - char buf [MAX (sizeof (de), - sizeof (de) - sizeof (de.d_name) + NAME_MAX + 1)]; -#else - char *buf; - long name_max = fpathconf (dirfd (ds), _PC_NAME_MAX); - if (name_max == -1) - SCM_SYSERROR; - buf = alloca (MAX (sizeof (de), - sizeof (de) - sizeof (de.d_name) + name_max + 1)); -#endif + ret = (rdent ? scm_from_locale_stringn (rdent->d_name, NAMLEN (rdent)) + : SCM_EOF_VAL); - errno = 0; - SCM_SYSCALL (readdir_r_or_readdir64_r (ds, (struct dirent_or_dirent64 *) buf, &rdent)); - if (errno != 0) - SCM_SYSERROR; - if (! rdent) - return SCM_EOF_VAL; - - return (rdent ? scm_from_locale_stringn (rdent->d_name, NAMLEN (rdent)) - : SCM_EOF_VAL); - } -#else - { - SCM ret; - scm_dynwind_begin (0); - scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex); - - errno = 0; - SCM_SYSCALL (rdent = readdir_or_readdir64 ((DIR *) SCM_SMOB_DATA_1 (port))); - if (errno != 0) - SCM_SYSERROR; - - ret = (rdent ? scm_from_locale_stringn (rdent->d_name, NAMLEN (rdent)) - : SCM_EOF_VAL); - - scm_dynwind_end (); - return ret; - } -#endif + scm_dynwind_end (); + return ret; } #undef FUNC_NAME From b0ccf4dd4afab30c27a93cd8a84e67309cda723f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 6 Dec 2016 23:26:06 +0100 Subject: [PATCH 648/865] Refine check for when atomics are available. * configure.ac: * libguile/atomics-internal.h: Use HAVE_STDATOMIC_H to know when to use atomics. --- configure.ac | 1 + libguile/atomics-internal.h | 8 +++----- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/configure.ac b/configure.ac index ab4f1f711..020151911 100644 --- a/configure.ac +++ b/configure.ac @@ -326,6 +326,7 @@ AC_SUBST([SCM_I_GSC_T_PTRDIFF]) AC_CHECK_HEADERS([stdint.h]) AC_CHECK_HEADERS([inttypes.h]) +AC_CHECK_HEADERS([stdatomic.h]) AC_CHECK_SIZEOF(intmax_t) diff --git a/libguile/atomics-internal.h b/libguile/atomics-internal.h index 9074d8cc3..f2d17e102 100644 --- a/libguile/atomics-internal.h +++ b/libguile/atomics-internal.h @@ -28,9 +28,7 @@ -#define HAVE_C11_ATOMICS (__STDC_VERSION__ >= 201112L && !defined(__STDC_NO_ATOMICS__)) - -#if HAVE_C11_ATOMICS +#ifdef HAVE_STDATOMIC_H #include static inline uint32_t @@ -74,7 +72,7 @@ scm_atomic_compare_and_swap_scm (SCM *loc, SCM *expected, SCM desired) { return atomic_compare_exchange_weak (loc, expected, desired); } -#else /* HAVE_C11_ATOMICS */ +#else /* HAVE_STDATOMIC_H */ /* Fallback implementation using locks. */ #include "libguile/threads.h" @@ -171,6 +169,6 @@ scm_atomic_compare_and_swap_scm (SCM *loc, SCM *expected, SCM desired) return ret; } -#endif /* HAVE_C11_ATOMICS */ +#endif /* HAVE_STDATOMIC_H */ #endif /* SCM_ATOMICS_INTERNAL_H */ From bb87578041a453b20f5a28dec3214a9e79a43f4b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 7 Dec 2016 20:01:00 +0100 Subject: [PATCH 649/865] Fix --without-threads * libguile/dynl.c: * libguile/gc.c: * libguile/keywords.c: * libguile/scmsigs.c: * libguile/stime.c: Use scm_i_dynamic_link instead of scm_dynamic_link so that things compile in without-threads configurations. --- libguile/dynl.c | 6 +++--- libguile/gc.c | 4 ++-- libguile/keywords.c | 2 +- libguile/scmsigs.c | 2 +- libguile/stime.c | 4 ++-- 5 files changed, 9 insertions(+), 9 deletions(-) diff --git a/libguile/dynl.c b/libguile/dynl.c index b1c9fb3a7..b9497b1b3 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -253,7 +253,7 @@ SCM_DEFINE (scm_dynamic_link, "dynamic-link", 0, 1, 0, char *file; scm_dynwind_begin (0); - scm_dynwind_pthread_mutex_lock (<dl_lock); + scm_i_dynwind_pthread_mutex_lock (<dl_lock); if (SCM_UNBNDP (filename)) file = NULL; @@ -298,7 +298,7 @@ SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0, SCM_VALIDATE_SMOB (SCM_ARG1, dobj, dynamic_obj); scm_dynwind_begin (0); - scm_dynwind_pthread_mutex_lock (<dl_lock); + scm_i_dynwind_pthread_mutex_lock (<dl_lock); if (DYNL_HANDLE (dobj) == NULL) { SCM_MISC_ERROR ("Already unlinked: ~S", scm_list_1 (dobj)); } else { @@ -335,7 +335,7 @@ SCM_DEFINE (scm_dynamic_pointer, "dynamic-pointer", 2, 0, 0, char *chars; scm_dynwind_begin (0); - scm_dynwind_pthread_mutex_lock (<dl_lock); + scm_i_dynwind_pthread_mutex_lock (<dl_lock); chars = scm_to_locale_string (name); scm_dynwind_free (chars); val = sysdep_dynl_value (chars, DYNL_HANDLE (dobj), FUNC_NAME); diff --git a/libguile/gc.c b/libguile/gc.c index 2b3bd36b0..648c678d6 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -401,7 +401,7 @@ scm_gc_protect_object (SCM obj) SCM handle; scm_dynwind_begin (0); - scm_dynwind_pthread_mutex_lock (&gc_protect_lock); + scm_i_dynwind_pthread_mutex_lock (&gc_protect_lock); handle = scm_hashq_create_handle_x (scm_protects, obj, scm_from_int (0)); SCM_SETCDR (handle, scm_sum (SCM_CDR (handle), scm_from_int (1))); @@ -423,7 +423,7 @@ scm_gc_unprotect_object (SCM obj) SCM handle; scm_dynwind_begin (0); - scm_dynwind_pthread_mutex_lock (&gc_protect_lock); + scm_i_dynwind_pthread_mutex_lock (&gc_protect_lock); handle = scm_hashq_get_handle (scm_protects, obj); if (scm_is_false (handle)) diff --git a/libguile/keywords.c b/libguile/keywords.c index 2c6078942..0ead33692 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -63,7 +63,7 @@ SCM_DEFINE (scm_symbol_to_keyword, "symbol->keyword", 1, 0, 0, SCM_ASSERT_TYPE (scm_is_symbol (symbol), symbol, 0, NULL, "symbol"); scm_dynwind_begin (0); - scm_dynwind_pthread_mutex_lock (&scm_i_misc_mutex); + scm_i_dynwind_pthread_mutex_lock (&scm_i_misc_mutex); /* Note: `scm_cell' and `scm_hashq_set_x' can raise an out-of-memory error. */ keyword = scm_hashq_ref (keyword_obarray, symbol, SCM_BOOL_F); diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index da2c3d195..36143afc4 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -336,7 +336,7 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0, scm_i_ensure_signal_delivery_thread (); scm_dynwind_begin (0); - scm_dynwind_pthread_mutex_lock (&signal_handler_lock); + scm_i_dynwind_pthread_mutex_lock (&signal_handler_lock); scm_dynwind_block_asyncs (); old_handler = SCM_SIMPLE_VECTOR_REF (*signal_handlers, csig); diff --git a/libguile/stime.c b/libguile/stime.c index f5b700056..4f3576682 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -393,7 +393,7 @@ SCM_DEFINE (scm_localtime, "localtime", 1, 1, 0, /* Mutual exclusion is essential since a) setzone may install a temporary environment b) localtime uses a static buffer. */ scm_dynwind_begin (0); - scm_dynwind_pthread_mutex_lock (&tz_lock); + scm_i_dynwind_pthread_mutex_lock (&tz_lock); oldenv = setzone (zone, SCM_ARG2, FUNC_NAME); #ifdef LOCALTIME_CACHE @@ -553,7 +553,7 @@ SCM_DEFINE (scm_mktime, "mktime", 1, 1, 0, scm_dynwind_free ((char *)lt.tm_zone); #endif - scm_dynwind_pthread_mutex_lock (&tz_lock); + scm_i_dynwind_pthread_mutex_lock (&tz_lock); oldenv = setzone (zone, SCM_ARG2, FUNC_NAME); #ifdef LOCALTIME_CACHE From bf4a97898beac167e8b4f565ce4c7540bed24685 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 6 Dec 2016 23:28:31 +0100 Subject: [PATCH 650/865] Bump version to 2.1.5. * GUILE-VERSION (GUILE_MICRO_VERSION): Bump. --- GUILE-VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index b287f64e5..056cbdecd 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -3,7 +3,7 @@ # Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'. GUILE_MAJOR_VERSION=2 GUILE_MINOR_VERSION=1 -GUILE_MICRO_VERSION=4 +GUILE_MICRO_VERSION=5 GUILE_EFFECTIVE_VERSION=2.2 From 6dd87f4d8c764360c8d22c03f65603ea8b8c9e78 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 12 Dec 2016 20:55:08 +0100 Subject: [PATCH 651/865] Add suspendable-continuation? * doc/ref/api-control.texi (Prompt Primitives): Document suspendable-continuation?. * libguile/control.c (scm_suspendable_continuation_p): New procedure. (scm_init_ice_9_control): New extension procedure, defines suspendable-continuation?. (scm_init_control): Register scm_init_ice_9_control. * libguile/eval.c (eval): * libguile/throw.c (catch): * libguile/continuations.c (scm_i_make_continuation): Restore resumable prompt cookie after continuation invocation. * libguile/vm.c (scm_call_n): Arrange to set resumable_prompt_cookie during invocation of VM. * libguile/vm.h (struct scm_vm): Add resumable_prompt_cookie member. * module/ice-9/control.scm: Export suspendable-continuation?. * test-suite/tests/control.test ("suspendable-continuation?"): New test. --- doc/ref/api-control.texi | 27 +++++++++++++++++++++++++++ libguile/continuations.c | 3 +++ libguile/control.c | 25 +++++++++++++++++++++++++ libguile/eval.c | 3 +++ libguile/throw.c | 3 +++ libguile/vm.c | 13 ++++++++++--- libguile/vm.h | 1 + module/ice-9/control.scm | 6 +++++- test-suite/tests/control.test | 27 +++++++++++++++++++++++++++ 9 files changed, 104 insertions(+), 4 deletions(-) diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index f0ded98a2..73fbe3607 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.texi @@ -628,6 +628,33 @@ This is equivalent to @code{(call/ec (lambda (@var{k}) @var{body} @dots{}))}. @end deffn +Additionally there is another helper primitive exported by @code{(ice-9 +control)}, so load up that module for @code{suspendable-continuation?}: + +@example +(use-modules (ice-9 control)) +@end example + +@deffn {Scheme Procedure} suspendable-continuation? tag +Return @code{#t} if a call to @code{abort-to-prompt} with the prompt tag +@var{tag} would produce a delimited continuation that could be resumed +later. + +Almost all continuations have this property. The exception is where +some code between the @code{call-with-prompt} and the +@code{abort-to-prompt} recursed through C for some reason, the +@code{abort-to-prompt} will succeed but any attempt to resume the +continuation (by calling it) would fail. This is because composing a +saved continuation with the current continuation involves relocating the +stack frames that were saved from the old stack onto a (possibly) new +position on the new stack, and Guile can only do this for stack frames +that it created for Scheme code, not stack frames created by the C +compiler. It's a bit gnarly but if you stick with Scheme, you won't +have any problem. + +If no prompt is found with the given tag, this procedure just returns +@code{#f}. +@end deffn @node Shift and Reset @subsubsection Shift, Reset, and All That diff --git a/libguile/continuations.c b/libguile/continuations.c index 5d146f4a1..3eb31a0f9 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -121,6 +121,7 @@ scm_i_make_continuation (int *first, struct scm_vm *vp, SCM vm_cont) SCM cont; scm_t_contregs *continuation; long stack_size; + const void *saved_cookie; SCM_STACKITEM * src; SCM_FLUSH_REGISTER_WINDOWS; @@ -138,6 +139,7 @@ scm_i_make_continuation (int *first, struct scm_vm *vp, SCM vm_cont) memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size); continuation->vp = vp; continuation->vm_cont = vm_cont; + saved_cookie = vp->resumable_prompt_cookie; SCM_NEWSMOB (cont, tc16_continuation, continuation); @@ -161,6 +163,7 @@ scm_i_make_continuation (int *first, struct scm_vm *vp, SCM vm_cont) } else { + vp->resumable_prompt_cookie = saved_cookie; scm_gc_after_nonlocal_exit (); return SCM_UNDEFINED; } diff --git a/libguile/control.c b/libguile/control.c index c0bc62ddb..6691d551f 100644 --- a/libguile/control.c +++ b/libguile/control.c @@ -205,10 +205,35 @@ SCM_DEFINE (scm_abort_to_prompt_star, "abort-to-prompt*", 2, 0, 0, } #undef FUNC_NAME +static SCM +scm_suspendable_continuation_p (SCM tag) +{ + scm_t_dynstack_prompt_flags flags; + scm_i_thread *thread = SCM_I_CURRENT_THREAD; + scm_i_jmp_buf *registers; + + if (scm_dynstack_find_prompt (&thread->dynstack, tag, &flags, + NULL, NULL, NULL, ®isters)) + return scm_from_bool (registers == thread->vp->resumable_prompt_cookie); + + return SCM_BOOL_F; +} + +static void +scm_init_ice_9_control (void *unused) +{ + scm_c_define_gsubr ("suspendable-continuation?", 1, 0, 0, + scm_suspendable_continuation_p); +} + void scm_init_control (void) { #include "libguile/control.x" + + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_ice_9_control", scm_init_ice_9_control, + NULL); } /* diff --git a/libguile/eval.c b/libguile/eval.c index 87e6eacbf..93788ebfc 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -425,6 +425,7 @@ eval (SCM x, SCM env) struct scm_vm *vp; SCM k, handler, res; scm_i_jmp_buf registers; + const void *prev_cookie; scm_t_ptrdiff saved_stack_depth; k = EVAL1 (CAR (mx), env); @@ -442,9 +443,11 @@ eval (SCM x, SCM env) vp->ip, ®isters); + prev_cookie = vp->resumable_prompt_cookie; if (SCM_I_SETJMP (registers)) { /* The prompt exited nonlocally. */ + vp->resumable_prompt_cookie = prev_cookie; scm_gc_after_nonlocal_exit (); proc = handler; args = scm_i_prompt_pop_abort_args_x (vp, saved_stack_depth); diff --git a/libguile/throw.c b/libguile/throw.c index a6a95bab1..c3a46161b 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -78,6 +78,7 @@ catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler) scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack; scm_t_dynamic_state *dynamic_state = SCM_I_CURRENT_THREAD->dynamic_state; scm_i_jmp_buf registers; + const void *prev_cookie; scm_t_ptrdiff saved_stack_depth; if (!scm_is_eq (tag, SCM_BOOL_T) && !scm_is_symbol (tag)) @@ -102,6 +103,7 @@ catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler) scm_c_vector_set_x (eh, 3, pre_unwind_handler); vp = scm_the_vm (); + prev_cookie = vp->resumable_prompt_cookie; saved_stack_depth = vp->stack_top - vp->sp; /* Push the prompt and exception handler onto the dynamic stack. */ @@ -120,6 +122,7 @@ catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler) /* A non-local return. */ SCM args; + vp->resumable_prompt_cookie = prev_cookie; scm_gc_after_nonlocal_exit (); /* FIXME: We know where the args will be on the stack; we could diff --git a/libguile/vm.c b/libguile/vm.c index cc7bbf158..194f989ad 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -1234,8 +1234,11 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs) { scm_i_jmp_buf registers; - int resume = SCM_I_SETJMP (registers); - + int resume; + const void *prev_cookie = vp->resumable_prompt_cookie; + SCM ret; + + resume = SCM_I_SETJMP (registers); if (SCM_UNLIKELY (resume)) { scm_gc_after_nonlocal_exit (); @@ -1243,7 +1246,11 @@ scm_call_n (SCM proc, SCM *argv, size_t nargs) vm_dispatch_abort_hook (vp); } - return vm_engines[vp->engine](thread, vp, ®isters, resume); + vp->resumable_prompt_cookie = ®isters; + ret = vm_engines[vp->engine](thread, vp, ®isters, resume); + vp->resumable_prompt_cookie = prev_cookie; + + return ret; } } diff --git a/libguile/vm.h b/libguile/vm.h index 2ca4f2ab4..b26f7f406 100644 --- a/libguile/vm.h +++ b/libguile/vm.h @@ -47,6 +47,7 @@ struct scm_vm { union scm_vm_stack_element *stack_top; /* highest address in allocated stack */ SCM overflow_handler_stack; /* alist of max-stack-size -> thunk */ SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */ + const void *resumable_prompt_cookie; /* opaque cookie */ int engine; /* which vm engine we're using */ }; diff --git a/module/ice-9/control.scm b/module/ice-9/control.scm index 3eb71a483..edd184659 100644 --- a/module/ice-9/control.scm +++ b/module/ice-9/control.scm @@ -23,7 +23,11 @@ default-prompt-tag make-prompt-tag) #:export (% abort shift reset shift* reset* call-with-escape-continuation call/ec - let-escape-continuation let/ec)) + let-escape-continuation let/ec + suspendable-continuation?)) + +(load-extension (string-append "libguile-" (effective-version)) + "scm_init_ice_9_control") (define (abort . args) (apply abort-to-prompt (default-prompt-tag) args)) diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test index 52ce6b138..4ca8ed8cd 100644 --- a/test-suite/tests/control.test +++ b/test-suite/tests/control.test @@ -410,3 +410,30 @@ (cons (car xs) (k (cdr xs)))))))) (reset* (lambda () (visit xs)))) (traverse '(1 2 3 4 5)))))) + +(with-test-prefix "suspendable-continuation?" + (let ((tag (make-prompt-tag))) + (pass-if "escape-only" + (call-with-prompt tag + (lambda () + (suspendable-continuation? tag)) + (lambda _ (error "unreachable")))) + (pass-if "full" + (call-with-prompt tag + (lambda () + (suspendable-continuation? tag)) + (lambda (k) (error "unreachable" k)))) + (pass-if "escape-only with barrier" + (call-with-prompt tag + (lambda () + (with-continuation-barrier + (lambda () + (not (suspendable-continuation? tag))))) + (lambda _ (error "unreachable")))) + (pass-if "full with barrier" + (call-with-prompt tag + (lambda () + (with-continuation-barrier + (lambda () + (not (suspendable-continuation? tag))))) + (lambda (k) (error "unreachable" k)))))) From 37551e40b8fd2708a43759904d347a5281675d85 Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Thu, 8 Dec 2016 17:40:12 +0100 Subject: [PATCH 652/865] Make scm_gc_warn_proc() write directly to stderr This avoids a deadlock due to the lookup of cur_warnport_fluid while an allocation is ongoing. * libguile/gc.c (scm_gc_warn_proc): Write the warning directly to stderr. --- libguile/gc.c | 34 +++------------------------------- 1 file changed, 3 insertions(+), 31 deletions(-) diff --git a/libguile/gc.c b/libguile/gc.c index 648c678d6..4478128c6 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -105,37 +105,9 @@ scm_oom_fn (size_t nbytes) static void scm_gc_warn_proc (char *fmt, GC_word arg) { - SCM port; - FILE *stream = NULL; - - port = scm_current_warning_port (); - if (!SCM_OPPORTP (port)) - return; - - if (SCM_FPORTP (port)) - { - int fd; - scm_force_output (port); - if (!SCM_OPPORTP (port)) - return; - fd = dup (SCM_FPORT_FDES (port)); - if (fd == -1) - perror ("Failed to dup warning port fd"); - else - { - stream = fdopen (fd, "a"); - if (!stream) - { - perror ("Failed to open stream for warning port"); - close (fd); - } - } - } - - fprintf (stream ? stream : stderr, fmt, arg); - - if (stream) - fclose (stream); + /* avoid scm_current_warning_port() b/c the GC lock is already taken + and the fluid ref might require it */ + fprintf (stderr, fmt, arg); } void From 2660c0b3c86bf76fab465c200a5ca20fb37cf811 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 14 Dec 2016 17:14:15 +0100 Subject: [PATCH 653/865] Fix bug in compute-significant-bits for phi predecessors * module/language/cps/specialize-numbers.scm (compute-significant-bits): Always revisit predecessors after first visit. Avoids situation where predecessor of an unvisited phi var could default to 0 significant bits and never be revisited. Fixes (format #f "~2f" 9.9). --- module/language/cps/specialize-numbers.scm | 26 +++++++++++++--------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm index d9fe76cac..8ce32453b 100644 --- a/module/language/cps/specialize-numbers.scm +++ b/module/language/cps/specialize-numbers.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2015 Free Software Foundation, Inc. +;; Copyright (C) 2015, 2016 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 @@ -197,15 +197,18 @@ BITS indicating the significant bits needed for a variable. BITS may be #f to indicate all bits, or a non-negative integer indicating a bitmask." (let ((preds (invert-graph (compute-successors cps kfun)))) - (let lp ((worklist (intmap-keys preds)) (out empty-intmap)) + (let lp ((worklist (intmap-keys preds)) (visited empty-intset) + (out empty-intmap)) (match (intset-prev worklist) (#f out) (label - (let ((worklist (intset-remove worklist label))) + (let ((worklist (intset-remove worklist label)) + (visited* (intset-add visited label))) (define (continue out*) - (if (eq? out out*) - (lp worklist out) - (lp (intset-union worklist (intmap-ref preds label)) out*))) + (if (and (eq? out out*) (eq? visited visited*)) + (lp worklist visited out) + (lp (intset-union worklist (intmap-ref preds label)) + visited* out*))) (define (add-def out var) (intmap-add out var 0 sigbits-union)) (define (add-defs out vars) @@ -233,11 +236,12 @@ BITS indicating the significant bits needed for a variable. BITS may be (($ $values args) (match (intmap-ref cps k) (($ $kargs _ vars) - (fold (lambda (arg var out) - (intmap-add out arg (intmap-ref out var - (lambda (_) 0)) - sigbits-union)) - out args vars)) + (if (intset-ref visited k) + (fold (lambda (arg var out) + (intmap-add out arg (intmap-ref out var) + sigbits-union)) + out args vars) + out)) (($ $ktail) (add-unknown-uses out args)))) (($ $call proc args) From 546eb479b1fc7e3143b05aaeec16175d1cea0e08 Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Thu, 15 Dec 2016 12:47:08 +0100 Subject: [PATCH 654/865] Test format ~f with width parameters * test-suite/tests/format.test: Additional tests for ~f. --- test-suite/tests/format.test | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/test-suite/tests/format.test b/test-suite/tests/format.test index cc31942cc..e7b7afde8 100644 --- a/test-suite/tests/format.test +++ b/test-suite/tests/format.test @@ -108,6 +108,15 @@ (pass-if "3/2" (string=? "1.5" (format #f "~f" 3/2))) + + (pass-if "~2f" + (string=? "10." (format #f "~2f" 9.9))) + + (pass-if "~2,1f" + (string=? "9.9" (format #f "~2,1f" 9.9))) + + (pass-if "~2,2f" + (string=? "9.90" (format #f "~2,2f" 9.9))) ;; in guile prior to 1.6.9 and 1.8.1, leading zeros were incorrectly ;; stripped, moving the decimal point and giving "25.0" here From a396e14cb139eba37eeeea44e745bfc57bd1f37d Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 5 Jan 2016 16:30:41 -0500 Subject: [PATCH 655/865] FFI: Add support for functions that set 'errno'. Implements wishlist item . Requested by Frank Terbeck . Based on a proposed patch by Nala Ginrut . Patch ported to 2.2 by Andy Wingo . * libguile/foreign.c (cif_to_procedure): Add 'with_errno' argument. If true, truncate result to only one return value. (scm_i_foreign_call): Separate the arguments. Always return errno. (pointer_to_procedure): New static function. (scm_pointer_to_procedure_with_errno): New C API function, implemented in terms of 'pointer_to_procedure'. (scm_pointer_to_procedure): Reimplement in terms of 'pointer_to_procedure', no longer bound to "pointer->procedure". See below. (scm_i_pointer_to_procedure): New C function bound to "pointer->procedure" which now accepts the optional #:return-errno? keyword argument, implemented in terms of 'pointer_to_procedure'. (k_return_errno): New keyword #:return-errno?. * libguile/foreign.h (scm_pointer_to_procedure_with_errno): Add prototype. * doc/ref/api-foreign.texi (Dynamic FFI): Adjust documentation. * libguile/vm-engine.c (foreign-call): Return two values. --- doc/ref/api-foreign.texi | 15 +++-- libguile/foreign.c | 122 +++++++++++++++++++++++++-------------- libguile/foreign.h | 7 ++- libguile/vm-engine.c | 29 +++------- 4 files changed, 101 insertions(+), 72 deletions(-) diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi index 76614f021..527902209 100644 --- a/doc/ref/api-foreign.texi +++ b/doc/ref/api-foreign.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2008, -@c 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +@c Copyright (C) 1996, 1997, 2000-2004, 2007-2014, 2016 +@c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Foreign Function Interface @@ -813,8 +813,11 @@ tightly packed structs and unions by hand. See the code for Of course, the land of C is not all nouns and no verbs: there are functions too, and Guile allows you to call them. -@deffn {Scheme Procedure} pointer->procedure return_type func_ptr arg_types -@deffnx {C Procedure} scm_pointer_to_procedure (return_type, func_ptr, arg_types) +@deffn {Scheme Procedure} pointer->procedure return_type func_ptr arg_types @ + [#:return-errno?=#f] +@deffnx {C Function} scm_pointer_to_procedure (return_type, func_ptr, arg_types) +@deffnx {C Function} scm_pointer_to_procedure_with_errno (return_type, func_ptr, arg_types) + Make a foreign function. Given the foreign void pointer @var{func_ptr}, its argument and @@ -825,6 +828,10 @@ and return appropriate values. @var{arg_types} should be a list of foreign types. @code{return_type} should be a foreign type. @xref{Foreign Types}, for more information on foreign types. + +If @var{return-errno?} is true, or when calling +@code{scm_pointer_to_procedure_with_errno}, the returned procedure will +return two values, with @code{errno} as the second value. @end deffn Here is a better definition of @code{(math bessel)}: diff --git a/libguile/foreign.c b/libguile/foreign.c index 17a3eedb5..17af10180 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2010-2013 Free Software Foundation, Inc. +/* Copyright (C) 2010-2016 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 License @@ -26,6 +26,7 @@ #include #include #include +#include #include "libguile/_scm.h" #include "libguile/bytevectors.h" @@ -75,7 +76,7 @@ null_pointer_error (const char *func_name) } -static SCM cif_to_procedure (SCM cif, SCM func_ptr); +static SCM cif_to_procedure (SCM cif, SCM func_ptr, int with_errno); static SCM pointer_weak_refs = SCM_BOOL_F; @@ -740,16 +741,10 @@ make_cif (SCM return_type, SCM arg_types, const char *caller) } #undef FUNC_NAME -SCM_DEFINE (scm_pointer_to_procedure, "pointer->procedure", 3, 0, 0, - (SCM return_type, SCM func_ptr, SCM arg_types), - "Make a foreign function.\n\n" - "Given the foreign void pointer @var{func_ptr}, its argument and\n" - "return types @var{arg_types} and @var{return_type}, return a\n" - "procedure that will pass arguments to the foreign function\n" - "and return appropriate values.\n\n" - "@var{arg_types} should be a list of foreign types.\n" - "@code{return_type} should be a foreign type.") -#define FUNC_NAME s_scm_pointer_to_procedure +static SCM +pointer_to_procedure (SCM return_type, SCM func_ptr, SCM arg_types, + int with_errno) +#define FUNC_NAME "pointer->procedure" { ffi_cif *cif; @@ -757,45 +752,81 @@ SCM_DEFINE (scm_pointer_to_procedure, "pointer->procedure", 3, 0, 0, cif = make_cif (return_type, arg_types, FUNC_NAME); - return cif_to_procedure (scm_from_pointer (cif, NULL), func_ptr); + return cif_to_procedure (scm_from_pointer (cif, NULL), func_ptr, + with_errno); +} +#undef FUNC_NAME + +SCM +scm_pointer_to_procedure (SCM return_type, SCM func_ptr, SCM arg_types) +{ + return pointer_to_procedure (return_type, func_ptr, arg_types, 0); +} + +SCM +scm_pointer_to_procedure_with_errno (SCM return_type, SCM func_ptr, + SCM arg_types) +{ + return pointer_to_procedure (return_type, func_ptr, arg_types, 1); +} + +SCM_KEYWORD (k_return_errno, "return-errno?"); + +SCM_INTERNAL SCM scm_i_pointer_to_procedure (SCM, SCM, SCM, SCM); +SCM_DEFINE (scm_i_pointer_to_procedure, "pointer->procedure", 3, 0, 1, + (SCM return_type, SCM func_ptr, SCM arg_types, SCM keyword_args), + "Make a foreign function.\n\n" + "Given the foreign void pointer @var{func_ptr}, its argument and\n" + "return types @var{arg_types} and @var{return_type}, return a\n" + "procedure that will pass arguments to the foreign function\n" + "and return appropriate values.\n\n" + "@var{arg_types} should be a list of foreign types.\n" + "@code{return_type} should be a foreign type.\n" + "If the @code{#:return-errno?} keyword argument is provided and\n" + "its value is true, then the returned procedure will return two\n" + "values, with @code{errno} as the second value.") +#define FUNC_NAME s_scm_i_pointer_to_procedure +{ + SCM return_errno = SCM_BOOL_F; + + scm_c_bind_keyword_arguments (FUNC_NAME, keyword_args, 0, + k_return_errno, &return_errno, + SCM_UNDEFINED); + + return pointer_to_procedure (return_type, func_ptr, arg_types, + scm_to_bool (return_errno)); } #undef FUNC_NAME -/* We support calling foreign functions with up to 100 arguments. */ - -#define CODE(nreq) \ - SCM_PACK_OP_24 (assert_nargs_ee, nreq + 1), \ - SCM_PACK_OP_12_12 (foreign_call, 0, 1), \ - SCM_PACK_OP_24 (handle_interrupts, 0), \ - SCM_PACK_OP_24 (return_values, 0) - -#define CODE_10(n) \ - CODE (n + 0), CODE (n + 1), CODE (n + 2), CODE (n + 3), CODE (n + 4), \ - CODE (n + 5), CODE (n + 6), CODE (n + 7), CODE (n + 8), CODE (n + 9) - -static const scm_t_uint32 foreign_stub_code[] = - { - CODE_10 (0), CODE_10 (10), CODE_10 (20), CODE_10 (30), CODE_10 (40), - CODE_10 (50), CODE_10 (60), CODE_10 (70), CODE_10 (80), CODE_10 (90) - }; - -#undef CODE -#undef CODE_10 - static const scm_t_uint32 * -get_foreign_stub_code (unsigned int nargs) +get_foreign_stub_code (unsigned int nargs, int with_errno) { - if (nargs >= 100) - scm_misc_error ("make-foreign-function", "args >= 100 currently unimplemented", - SCM_EOL); + size_t i; + size_t code_len = with_errno ? 4 : 5; + scm_t_uint32 *code; - return &foreign_stub_code[nargs * 4]; + code = scm_gc_malloc_pointerless (code_len * sizeof (scm_t_uint32), + "foreign code"); + + if (nargs >= (1 << 24) + 1) + scm_misc_error ("make-foreign-function", "too many arguments: ~a", + scm_list_1 (scm_from_uint (nargs))); + + i = 0; + code[i++] = SCM_PACK_OP_24 (assert_nargs_ee, nargs + 1); + code[i++] = SCM_PACK_OP_12_12 (foreign_call, 0, 1); + code[i++] = SCM_PACK_OP_24 (handle_interrupts, 0); + if (!with_errno) + code[i++] = SCM_PACK_OP_24 (reset_frame, 2); + code[i++] = SCM_PACK_OP_24 (return_values, 0); + + return code; } static SCM -cif_to_procedure (SCM cif, SCM func_ptr) +cif_to_procedure (SCM cif, SCM func_ptr, int with_errno) { ffi_cif *c_cif; SCM ret; @@ -805,7 +836,7 @@ cif_to_procedure (SCM cif, SCM func_ptr) c_cif = (ffi_cif *) SCM_POINTER_VALUE (cif); ret = scm_words (scm_tc7_program | (nfree << 16) | flags, nfree + 2); - SCM_SET_CELL_WORD_1 (ret, get_foreign_stub_code (c_cif->nargs)); + SCM_SET_CELL_WORD_1 (ret, get_foreign_stub_code (c_cif->nargs, with_errno)); SCM_PROGRAM_FREE_VARIABLE_SET (ret, 0, cif); SCM_PROGRAM_FREE_VARIABLE_SET (ret, 1, func_ptr); @@ -960,7 +991,8 @@ pack (const ffi_type * type, const void *loc, int return_value_p) SCM -scm_i_foreign_call (SCM foreign, const union scm_vm_stack_element *argv) +scm_i_foreign_call (SCM cif_scm, SCM pointer_scm, int *errno_ret, + const union scm_vm_stack_element *argv) { /* FOREIGN is the pair that cif_to_procedure set as the 0th element of the objtable. */ @@ -973,8 +1005,8 @@ scm_i_foreign_call (SCM foreign, const union scm_vm_stack_element *argv) size_t arg_size; scm_t_ptrdiff off; - cif = SCM_POINTER_VALUE (SCM_CAR (foreign)); - func = SCM_POINTER_VALUE (SCM_CDR (foreign)); + cif = SCM_POINTER_VALUE (cif_scm); + func = SCM_POINTER_VALUE (pointer_scm); /* Argument pointers. */ args = alloca (sizeof (void *) * cif->nargs); @@ -1010,7 +1042,9 @@ scm_i_foreign_call (SCM foreign, const union scm_vm_stack_element *argv) max (sizeof (void *), cif->rtype->alignment)); /* off we go! */ + errno = 0; ffi_call (cif, func, rvalue, args); + *errno_ret = errno; return pack (cif->rtype, rvalue, 1); } diff --git a/libguile/foreign.h b/libguile/foreign.h index 4c1a19f1f..a0c09cc0f 100644 --- a/libguile/foreign.h +++ b/libguile/foreign.h @@ -1,7 +1,7 @@ #ifndef SCM_FOREIGN_H #define SCM_FOREIGN_H -/* Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +/* Copyright (C) 2010, 2011, 2012, 2013, 2016 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 License @@ -97,9 +97,12 @@ union scm_vm_stack_element; SCM_API SCM scm_pointer_to_procedure (SCM return_type, SCM func_ptr, SCM arg_types); +SCM_API SCM scm_pointer_to_procedure_with_errno (SCM return_type, SCM func_ptr, + SCM arg_types); SCM_API SCM scm_procedure_to_pointer (SCM return_type, SCM func_ptr, SCM arg_types); -SCM_INTERNAL SCM scm_i_foreign_call (SCM foreign, +SCM_INTERNAL SCM scm_i_foreign_call (SCM cif_scm, SCM pointer_scm, + int *errno_ret, const union scm_vm_stack_element *argv); diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 44068458e..195237ab4 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -791,6 +791,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, VM_DEFINE_OP (11, foreign_call, "foreign-call", OP1 (X8_C12_C12)) { scm_t_uint16 cif_idx, ptr_idx; + int err = 0; SCM closure, cif, pointer, ret; UNPACK_12_12 (op, cif_idx, ptr_idx); @@ -800,30 +801,14 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, pointer = SCM_PROGRAM_FREE_VARIABLE_REF (closure, ptr_idx); SYNC_IP (); - - // FIXME: separate args - ret = scm_i_foreign_call (scm_inline_cons (thread, cif, pointer), sp); - + ret = scm_i_foreign_call (cif, pointer, &err, sp); CACHE_SP (); - if (SCM_UNLIKELY (SCM_VALUESP (ret))) - { - SCM vals = scm_struct_ref (ret, SCM_INUM0); - long len = scm_ilength (vals); - ALLOC_FRAME (1 + len); - while (len--) - { - SP_SET (len, SCM_CAR (vals)); - vals = SCM_CDR (vals); - } - NEXT (1); - } - else - { - ALLOC_FRAME (2); - SP_SET (0, ret); - NEXT (1); - } + ALLOC_FRAME (3); + SP_SET (1, ret); + SP_SET (0, scm_from_int (err)); + + NEXT (1); } /* continuation-call contregs:24 From 0ce8a9a5e01d3a12d83fea85968e1abb602c9298 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 18 Dec 2016 23:00:07 +0100 Subject: [PATCH 656/865] Improve handle-interrupts placement * module/language/cps/handle-interrupts.scm (compute-safepoints): New function. (add-handle-interrupts): Add safepoints at backedge targets, not backedges. Gives better register allocation, loop rotation, and code size. --- module/language/cps/handle-interrupts.scm | 53 ++++++++++++++--------- 1 file changed, 32 insertions(+), 21 deletions(-) diff --git a/module/language/cps/handle-interrupts.scm b/module/language/cps/handle-interrupts.scm index e686cebce..55d25f28a 100644 --- a/module/language/cps/handle-interrupts.scm +++ b/module/language/cps/handle-interrupts.scm @@ -29,30 +29,41 @@ #:use-module (language cps utils) #:use-module (language cps with-cps) #:use-module (language cps intmap) + #:use-module (language cps intset) #:use-module (language cps renumber) #:export (add-handle-interrupts)) -(define (add-handle-interrupts cps) - (define (visit-cont label cont cps) +(define (compute-safepoints cps) + (define (visit-cont label cont safepoints) (match cont (($ $kargs names vars ($ $continue k src exp)) - (if (or (<= k label) - (match exp - (($ $call) #t) - (($ $callk) #t) - (($ $values) - (match (intmap-ref cps k) - (($ $ktail) #t) - (_ #f))) - (_ #f))) - (with-cps cps - (letk k* ($kargs () () ($continue k src ,exp))) - (setk label - ($kargs names vars - ($continue k* src - ($primcall 'handle-interrupts ()))))) - cps)) - (_ cps))) - (let ((cps (renumber cps))) + (let ((safepoints (if (<= k label) + (intset-add! safepoints k) + safepoints))) + (if (match exp + (($ $call) #t) + (($ $callk) #t) + (($ $values) + (match (intmap-ref cps k) + (($ $ktail) #t) + (_ #f))) + (_ #f)) + (intset-add! safepoints label) + safepoints))) + (_ safepoints))) + (persistent-intset (intmap-fold visit-cont cps empty-intset))) + +(define (add-handle-interrupts cps) + (define (add-safepoint label cps) + (match (intmap-ref cps label) + (($ $kargs names vars ($ $continue k src exp)) + (with-cps cps + (letk k* ($kargs () () ($continue k src ,exp))) + (setk label + ($kargs names vars + ($continue k* src + ($primcall 'handle-interrupts ())))))))) + (let* ((cps (renumber cps)) + (safepoints (compute-safepoints cps))) (with-fresh-name-state cps - (persistent-intmap (intmap-fold visit-cont cps cps))))) + (persistent-intmap (intset-fold add-safepoint safepoints cps))))) From a0656ad4cf976b3845e9b9663a90b46b4cf9fc5a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 29 Dec 2016 18:46:16 +0100 Subject: [PATCH 657/865] New interfaces to help wait on fd/cond * libguile/async.h: * libguile/async.c (struct scm_thread_wake_data): Include the cond to signal. Be a union and include a tag. (scm_i_prepare_to_wait): Rename from scm_i_setup_sleep and take wake data directly. Also call scm_i_wait_finished as appropriate. (scm_i_wait_finished): Rename from scm_i_reset_sleep. (scm_i_prepare_to_wait_on_fd, scm_c_prepare_to_wait_on_fd): (scm_i_prepare_to_wait_on_cond, scm_c_prepare_to_wait_on_cond): New functions. (scm_c_wait_finished): New function. (scm_system_async_mark_for_thread): Adapt to wake data change. * libguile/threads.c (block_self, scm_std_select): Adapt to async interface changes. * doc/ref/api-scheduling.texi (Asyncs): Doc new public interfaces. --- doc/ref/api-scheduling.texi | 32 ++++++++++++ libguile/async.c | 100 +++++++++++++++++++++++++++--------- libguile/async.h | 18 +++++-- libguile/threads.c | 48 ++++++++--------- 4 files changed, 142 insertions(+), 56 deletions(-) diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index 86a1ad27c..bf85a6411 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -306,6 +306,38 @@ one level. This function must be used inside a pair of calls to Wind}). @end deftypefn +Sometimes you want to interrupt a thread that might be waiting for +something to happen, for example on a file descriptor or a condition +variable. In that case you can inform Guile of how to interrupt that +wait using the following procedures: + +@deftypefn {C Function} int scm_c_prepare_to_wait_on_fd (int fd) +Inform Guile that the current thread is about to sleep, and that if an +asynchronous interrupt is signalled on this thread, Guile should wake up +the thread by writing a zero byte to @var{fd}. Returns zero if the +prepare succeeded, or nonzero if the thread already has a pending async +and that it should avoid waiting. +@end deftypefn + +@deftypefn {C Function} int scm_c_prepare_to_wait_on_cond (scm_i_pthread_mutex_t *mutex, scm_i_pthread_cond_t *cond) +Inform Guile that the current thread is about to sleep, and that if an +asynchronous interrupt is signalled on this thread, Guile should wake up +the thread by acquiring @var{mutex} and signalling @var{cond}. The +caller must already hold @var{mutex} and only drop it as part of the +@code{pthread_cond_wait} call. Returns zero if the prepare succeeded, +or nonzero if the thread already has a pending async and that it should +avoid waiting. +@end deftypefn + +@deftypefn {C Function} void scm_c_wait_finished (void) +Inform Guile that the current thread has finished waiting, and that +asynchronous interrupts no longer need any special wakeup action; the +current thread will periodically poll its internal queue instead. +@end deftypefn + +Guile's own interface to @code{sleep}, @code{wait-condition-variable}, +@code{select}, and so on all call the above routines as appropriate. + Finally, note that threads can also be interrupted via POSIX signals. @xref{Signals}. As an implementation detail, signal handlers will effectively call @code{system-async-mark} in a signal-safe way, diff --git a/libguile/async.c b/libguile/async.c index df8064107..7b3ccb850 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -149,32 +149,83 @@ scm_async_tick (void) } struct scm_thread_wake_data { - scm_i_pthread_mutex_t *mutex; - int fd; + enum { WAIT_FD, WAIT_COND } kind; + union { + struct { + int fd; + } wait_fd; + struct { + scm_i_pthread_mutex_t *mutex; + scm_i_pthread_cond_t *cond; + } wait_cond; + } data; }; int -scm_i_setup_sleep (scm_i_thread *t, - scm_i_pthread_mutex_t *sleep_mutex, - int sleep_fd) +scm_i_prepare_to_wait (scm_i_thread *t, + struct scm_thread_wake_data *wake) { - struct scm_thread_wake_data *wake; - - wake = scm_gc_typed_calloc (struct scm_thread_wake_data); - wake->mutex = sleep_mutex; - wake->fd = sleep_fd; - scm_atomic_set_pointer ((void **)&t->wake, wake); - return !scm_is_null (scm_atomic_ref_scm (&t->pending_asyncs)); + /* If no interrupt was registered in the meantime, then any future + wakeup will signal the FD or cond var. */ + if (scm_is_null (scm_atomic_ref_scm (&t->pending_asyncs))) + return 0; + + /* Otherwise clear the wake pointer and indicate that the caller + should handle interrupts directly. */ + scm_i_wait_finished (t); + return 1; } void -scm_i_reset_sleep (scm_i_thread *t) +scm_i_wait_finished (scm_i_thread *t) { scm_atomic_set_pointer ((void **)&t->wake, NULL); } +int +scm_i_prepare_to_wait_on_fd (scm_i_thread *t, int fd) +{ + struct scm_thread_wake_data *wake; + wake = scm_gc_typed_calloc (struct scm_thread_wake_data); + wake->kind = WAIT_FD; + wake->data.wait_fd.fd = fd; + return scm_i_prepare_to_wait (t, wake); +} + +int +scm_c_prepare_to_wait_on_fd (int fd) +{ + return scm_i_prepare_to_wait_on_fd (SCM_I_CURRENT_THREAD, fd); +} + +int +scm_i_prepare_to_wait_on_cond (scm_i_thread *t, + scm_i_pthread_mutex_t *m, + scm_i_pthread_cond_t *c) +{ + struct scm_thread_wake_data *wake; + wake = scm_gc_typed_calloc (struct scm_thread_wake_data); + wake->kind = WAIT_COND; + wake->data.wait_cond.mutex = m; + wake->data.wait_cond.cond = c; + return scm_i_prepare_to_wait (t, wake); +} + +int +scm_c_prepare_to_wait_on_cond (scm_i_pthread_mutex_t *m, + scm_i_pthread_cond_t *c) +{ + return scm_i_prepare_to_wait_on_cond (SCM_I_CURRENT_THREAD, m, c); +} + +void +scm_c_wait_finished (void) +{ + scm_i_wait_finished (SCM_I_CURRENT_THREAD); +} + SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0, (SCM proc, SCM thread), "Mark @var{proc} (a procedure with zero arguments) for future execution\n" @@ -210,19 +261,18 @@ SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0, might even be in the next, unrelated sleep. Interrupting it anyway does no harm, however. - The important thing to prevent here is to signal sleep_cond - before T waits on it. This can not happen since T has - sleep_mutex locked while setting t->sleep_mutex and will only - unlock it again while waiting on sleep_cond. + The important thing to prevent here is to signal the cond + before T waits on it. This can not happen since T has its + mutex locked while preparing the wait and will only unlock it + again while waiting on the cond. */ - if (wake->mutex) + if (wake->kind == WAIT_COND) { - scm_i_scm_pthread_mutex_lock (wake->mutex); - scm_i_pthread_cond_signal (&t->sleep_cond); - scm_i_pthread_mutex_unlock (wake->mutex); + scm_i_scm_pthread_mutex_lock (wake->data.wait_cond.mutex); + scm_i_pthread_cond_signal (wake->data.wait_cond.cond); + scm_i_pthread_mutex_unlock (wake->data.wait_cond.mutex); } - - if (wake->fd >= 0) + else if (wake->kind == WAIT_FD) { char dummy = 0; @@ -231,8 +281,10 @@ SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0, not yet have started sleeping, but this is no problem either since the data written to a pipe will not be lost, unlike a condition variable signal. */ - full_write (wake->fd, &dummy, 1); + full_write (wake->data.wait_fd.fd, &dummy, 1); } + else + abort (); } return SCM_UNSPECIFIED; diff --git a/libguile/async.h b/libguile/async.h index c6d7202aa..2bca16df9 100644 --- a/libguile/async.h +++ b/libguile/async.h @@ -33,10 +33,12 @@ SCM_API void scm_async_tick (void); SCM_API void scm_switch (void); SCM_API SCM scm_system_async_mark (SCM a); SCM_API SCM scm_system_async_mark_for_thread (SCM a, SCM thread); -SCM_INTERNAL int scm_i_setup_sleep (scm_i_thread *, - scm_i_pthread_mutex_t *m, - int fd); -SCM_INTERNAL void scm_i_reset_sleep (scm_i_thread *); + +SCM_API int scm_c_prepare_to_wait_on_fd (int fd); +SCM_API int scm_c_prepare_to_wait_on_cond (scm_i_pthread_mutex_t *m, + scm_i_pthread_cond_t *c); +SCM_API void scm_c_wait_finished (void); + SCM_API SCM scm_noop (SCM args); SCM_API SCM scm_call_with_blocked_asyncs (SCM proc); SCM_API SCM scm_call_with_unblocked_asyncs (SCM proc); @@ -45,6 +47,14 @@ SCM_API void *scm_c_call_with_unblocked_asyncs (void *(*p) (void *d), void *d); SCM_API void scm_dynwind_block_asyncs (void); SCM_API void scm_dynwind_unblock_asyncs (void); +SCM_INTERNAL int scm_i_prepare_to_wait (scm_i_thread *, + struct scm_thread_wake_data *); +SCM_INTERNAL void scm_i_wait_finished (scm_i_thread *); +SCM_INTERNAL int scm_i_prepare_to_wait_on_fd (scm_i_thread *, int); +SCM_INTERNAL int scm_i_prepare_to_wait_on_cond (scm_i_thread *, + scm_i_pthread_mutex_t *, + scm_i_pthread_cond_t *); + SCM_INTERNAL void scm_i_async_push (scm_i_thread *t, SCM proc); SCM_INTERNAL SCM scm_i_async_pop (scm_i_thread *t); diff --git a/libguile/threads.c b/libguile/threads.c index 91b18b43a..48a91e84f 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -307,29 +307,24 @@ block_self (SCM queue, scm_i_pthread_mutex_t *mutex, SCM q_handle; int err; - if (scm_i_setup_sleep (t, mutex, -1)) - { - scm_i_reset_sleep (t); - err = EINTR; - } - else - { - t->block_asyncs++; - q_handle = enqueue (queue, t->handle); - if (waittime == NULL) - err = scm_i_scm_pthread_cond_wait (&t->sleep_cond, mutex); - else - err = scm_i_scm_pthread_cond_timedwait (&t->sleep_cond, mutex, waittime); + if (scm_i_prepare_to_wait_on_cond (t, mutex, &t->sleep_cond)) + return EINTR; - /* When we are still on QUEUE, we have been interrupted. We - report this only when no other error (such as a timeout) has - happened above. - */ - if (remqueue (queue, q_handle) && err == 0) - err = EINTR; - t->block_asyncs--; - scm_i_reset_sleep (t); - } + t->block_asyncs++; + q_handle = enqueue (queue, t->handle); + if (waittime == NULL) + err = scm_i_scm_pthread_cond_wait (&t->sleep_cond, mutex); + else + err = scm_i_scm_pthread_cond_timedwait (&t->sleep_cond, mutex, waittime); + + /* When we are still on QUEUE, we have been interrupted. We + report this only when no other error (such as a timeout) has + happened above. + */ + if (remqueue (queue, q_handle) && err == 0) + err = EINTR; + t->block_asyncs--; + scm_i_wait_finished (t); return err; } @@ -1479,11 +1474,8 @@ scm_std_select (int nfds, readfds = &my_readfds; } - while (scm_i_setup_sleep (t, NULL, t->sleep_pipe[1])) - { - scm_i_reset_sleep (t); - SCM_TICK; - } + while (scm_i_prepare_to_wait_on_fd (t, t->sleep_pipe[1])) + SCM_TICK; wakeup_fd = t->sleep_pipe[0]; FD_SET (wakeup_fd, readfds); @@ -1502,7 +1494,7 @@ scm_std_select (int nfds, res = args.result; eno = args.errno_value; - scm_i_reset_sleep (t); + scm_i_wait_finished (t); if (res > 0 && FD_ISSET (wakeup_fd, readfds)) { From 5241d0685586f34055dae23fedc46134e2171865 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 8 Jan 2017 12:24:44 +0100 Subject: [PATCH 658/865] Thread prepare-to-wait respects block_asyncs * libguile/async.c (scm_i_prepare_to_wait): Don't signal interrupt if asyncs are blocked. --- libguile/async.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/libguile/async.c b/libguile/async.c index 7b3ccb850..fc03078e7 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -165,6 +165,9 @@ int scm_i_prepare_to_wait (scm_i_thread *t, struct scm_thread_wake_data *wake) { + if (t->block_asyncs) + return 0; + scm_atomic_set_pointer ((void **)&t->wake, wake); /* If no interrupt was registered in the meantime, then any future @@ -246,8 +249,6 @@ SCM_DEFINE (scm_system_async_mark_for_thread, "system-async-mark", 1, 1, 0, else { SCM_VALIDATE_THREAD (2, thread); - if (scm_c_thread_exited_p (thread)) - SCM_MISC_ERROR ("thread has already exited", SCM_EOL); t = SCM_I_THREAD_DATA (thread); } From ca598d31405ac77d5515a3d0b70eda9d41b5bf10 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 8 Jan 2017 12:26:10 +0100 Subject: [PATCH 659/865] Remove thread-exited? check in sigaction * libguile/scmsigs.c (scm_sigaction_for_thread): Remove check that thread hadn't exited. This check was racy as it's always possible that the other thread exits between checking it or even after the signal handler is installed. --- libguile/scmsigs.c | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index 36143afc4..f210380e8 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -327,11 +327,7 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0, if (SCM_UNBNDP (thread)) thread = scm_current_thread (); else - { - SCM_VALIDATE_THREAD (4, thread); - if (scm_c_thread_exited_p (thread)) - SCM_MISC_ERROR ("thread has already exited", SCM_EOL); - } + SCM_VALIDATE_THREAD (4, thread); scm_i_ensure_signal_delivery_thread (); From 78239acff60e74fa02ffbccc37ec710ad92be064 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 8 Jan 2017 12:27:26 +0100 Subject: [PATCH 660/865] Remove thread-specific admin mutex * libguile/threads.c (guilify_self_1): * libguile/threads.h (scm_i_thread): Remove unused thread "admin mutex". --- libguile/threads.c | 1 - libguile/threads.h | 2 -- 2 files changed, 3 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index 48a91e84f..b46a71b42 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -408,7 +408,6 @@ guilify_self_1 (struct GC_stack_base *base) currently have type `void'. */ abort (); - scm_i_pthread_mutex_init (&t.admin_mutex, NULL); t.exited = 0; t.guile_mode = 0; diff --git a/libguile/threads.h b/libguile/threads.h index e09a2ef3a..645e5eb65 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -54,8 +54,6 @@ typedef struct scm_i_thread { SCM handle; scm_i_pthread_t pthread; - scm_i_pthread_mutex_t admin_mutex; - SCM result; int exited; From a000e5c38d50883c517214776dda36f4e478ebad Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 8 Jan 2017 13:02:56 +0100 Subject: [PATCH 661/865] Enable interrupts only when running thread body * libguile/threads.c (really_launch): Start threads with asyncs blocked. * module/ice-9/threads.scm (call-with-new-thread): Unblock asyncs once we have the bookkeeping sorted out. Don't use with-continuation-barrier; it's not needed. Print nice thread backtraces. --- libguile/threads.c | 3 +++ module/ice-9/threads.scm | 38 ++++++++++++++++++++++++++------------ 2 files changed, 29 insertions(+), 12 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index b46a71b42..64bef8c89 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -732,6 +732,9 @@ typedef struct { static void * really_launch (void *d) { + scm_i_thread *t = SCM_I_CURRENT_THREAD; + /* The thread starts with asyncs blocked. */ + t->block_asyncs++; SCM_I_CURRENT_THREAD->result = scm_call_0 (((launch_data *)d)->thunk); return 0; } diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm index ae6a97db9..65108d9f1 100644 --- a/module/ice-9/threads.scm +++ b/module/ice-9/threads.scm @@ -128,23 +128,37 @@ Once @var{thunk} or @var{handler} returns, the return value is made the (lambda () (catch #t thunk handler)) thunk)) (thread #f)) + (define (call-with-backtrace thunk) + (let ((err (current-error-port))) + (catch #t + (lambda () (%start-stack 'thread thunk)) + (lambda _ (values)) + (lambda (key . args) + ;; Narrow by three: the dispatch-exception, + ;; this thunk, and make-stack. + (let ((stack (make-stack #t 3))) + (false-if-exception + (begin + (when stack + (display-backtrace stack err)) + (let ((frame (and stack (stack-ref stack 0)))) + (print-exception err frame key args))))))))) (with-mutex mutex (%call-with-new-thread (lambda () (call-with-values (lambda () - (with-continuation-barrier - (lambda () - (call-with-prompt cancel-tag - (lambda () - (lock-mutex mutex) - (set! thread (current-thread)) - (set! (thread-join-data thread) (cons cv mutex)) - (signal-condition-variable cv) - (unlock-mutex mutex) - (thunk)) - (lambda (k . args) - (apply values args)))))) + (call-with-prompt cancel-tag + (lambda () + (lock-mutex mutex) + (set! thread (current-thread)) + (set! (thread-join-data thread) (cons cv mutex)) + (signal-condition-variable cv) + (unlock-mutex mutex) + (call-with-unblocked-asyncs + (lambda () (call-with-backtrace thunk)))) + (lambda (k . args) + (apply values args)))) (lambda vals (lock-mutex mutex) ;; Probably now you're wondering why we are going to use From 12eb7b8256f579fab60ebe0b38eb8788c1276eb8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 8 Jan 2017 13:18:13 +0100 Subject: [PATCH 662/865] Prevent some interrupts of wait-condition-variable * libguile/threads.c (timed_wait): Disable interrupts while reacquiring mutex after wait-condition-variable. --- libguile/threads.c | 28 ++++++++++++++++++---------- 1 file changed, 18 insertions(+), 10 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index 64bef8c89..7d91a01da 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1290,7 +1290,23 @@ timed_wait (enum scm_mutex_kind kind, struct scm_mutex *m, struct scm_cond *c, err = block_self (c->waiting, &m->lock, waittime); /* We woke up for some reason. Reacquire the mutex before doing - anything else. */ + anything else. + + FIXME: We disable interrupts while reacquiring the mutex. If + we allow interrupts here, there's the risk of a nonlocal exit + before we reaquire the mutex, which would be visible to user + code. + + For example the unwind handler in + + (with-mutex m (wait-condition-variable c m)) + + that tries to unlock M could see M in an already-unlocked + state, if an interrupt while waiting on C caused the wait to + abort and the woke thread lost the race to reacquire M. That's + not great. Maybe it's necessary but for now we just disable + interrupts while reaquiring a mutex after a wait. */ + current_thread->block_asyncs++; if (kind == SCM_MUTEX_RECURSIVE && scm_is_eq (m->owner, current_thread->handle)) { @@ -1307,16 +1323,8 @@ timed_wait (enum scm_mutex_kind kind, struct scm_mutex *m, struct scm_cond *c, break; } block_self (m->waiting, &m->lock, waittime); - if (scm_is_eq (m->owner, SCM_BOOL_F)) - { - m->owner = current_thread->handle; - scm_i_pthread_mutex_unlock (&m->lock); - break; - } - scm_i_pthread_mutex_unlock (&m->lock); - scm_async_tick (); - scm_i_scm_pthread_mutex_lock (&m->lock); } + current_thread->block_asyncs--; /* Now that we have the mutex again, handle the return value. */ if (err == 0) From dffe495d0de1466f62a91a6d74cc0f388e0f4f3f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 8 Jan 2017 13:44:38 +0100 Subject: [PATCH 663/865] Exited threads retain less memory * libguile/threads.c (on_thread_exit): Lessen excess retention. --- libguile/threads.c | 23 +++++++++++++++++------ 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index 7d91a01da..da5b8141d 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -475,7 +475,9 @@ guilify_self_2 (SCM dynamic_state) static void on_thread_exit (void *v) { - /* This handler is executed in non-guile mode. */ + /* This handler is executed in non-guile mode. Note that although + libgc isn't guaranteed to see thread-locals, for this thread-local + that isn't an issue as we have the all_threads list. */ scm_i_thread *t = (scm_i_thread *) v, **tp; t->exited = 1; @@ -506,11 +508,20 @@ on_thread_exit (void *v) scm_i_pthread_mutex_unlock (&thread_admin_mutex); - if (t->vp) - { - scm_i_vm_free_stack (t->vp); - t->vp = NULL; - } + /* Although this thread has exited, the thread object might still be + alive. Release unused memory. */ + t->freelists = NULL; + t->pointerless_freelists = NULL; + t->dynamic_state = NULL; + t->dynstack.base = NULL; + t->dynstack.top = NULL; + t->dynstack.limit = NULL; + { + struct scm_vm *vp = t->vp; + t->vp = NULL; + if (vp) + scm_i_vm_free_stack (vp); + } #if SCM_USE_PTHREAD_THREADS GC_unregister_my_thread (); From b392d81c9ca0bec82b43ca49e8cf96c0e9460a89 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 8 Jan 2017 15:42:22 +0100 Subject: [PATCH 664/865] Fix close-port race. * libguile/ports.c (release_port): Fix race. --- libguile/ports.c | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 20319bc0b..f415453c4 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -134,15 +134,22 @@ static void release_port (SCM port) { scm_t_port *pt = SCM_PORT (port); - scm_t_uint32 prev; - prev = scm_atomic_subtract_uint32 (&pt->refcount, 1); - if (prev == 0) - /* Logic failure. */ - abort (); - - if (prev > 1) - /* Port still alive. */ + /* It's possible for two close-port invocations to race, and since + close-port is defined to be idempotent we need to avoid + decrementing the refcount past 0. The normal case is that it's + open with a refcount of 1 and we're going to change it to 0. + Otherwise if the refcount is higher we just subtract 1 and we're + done. However if the current refcount is 0 then the port has been + closed or is closing and we just return. */ + scm_t_uint32 cur = 1, next = 0; + while (!scm_atomic_compare_and_swap_uint32 (&pt->refcount, &cur, next)) + { + if (cur == 0) + return; + next = cur - 1; + } + if (cur > 1) return; /* FIXME: `catch' around the close call? It could throw an exception, From 6ff1ec9c31fadbcf5cfe3d4837b8fad62c1bcb27 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 8 Jan 2017 23:25:27 +0100 Subject: [PATCH 665/865] Fix mkstemp on macOS * libguile/filesys.c (scm_i_mkstemp): Limit flags to mkostemp. Based on a patch by Matt Wette; thanks! --- libguile/filesys.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/filesys.c b/libguile/filesys.c index cccb39787..ae164fe83 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1489,6 +1489,12 @@ SCM_DEFINE (scm_i_mkstemp, "mkstemp!", 1, 1, 0, else { open_flags = scm_i_mode_to_open_flags (mode, &is_binary, FUNC_NAME); + /* mkostemp(2) only defines O_APPEND, O_SYNC, and O_CLOEXEC to be + useful, as O_RDWR|O_CREAT|O_EXCL are implicitly added. It also + notes that other flags may error on some systems, which turns + out to be the case. Of those flags, O_APPEND is the only one + of interest anyway, so limit to that flag. */ + open_flags &= O_APPEND; mode_bits = scm_i_mode_bits (mode); } From c391ab8c9085226d0dd51424d427fa48c3e26881 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 8 Jan 2017 23:39:42 +0100 Subject: [PATCH 666/865] Speed up load-thunk-from-memory for page alignment * libguile/loader.c (page_size): New static var. (alloc_aligned): Enable mmap path that was never used in the past (!). Thanks to Matt Wette for the bug report! (load_thunk_from_memory): Use page_size instead of 4096. (scm_bootstrap_loader): Init page_size. --- libguile/loader.c | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/libguile/loader.c b/libguile/loader.c index 97effb30d..191e4c157 100644 --- a/libguile/loader.c +++ b/libguile/loader.c @@ -79,6 +79,9 @@ #define ELFDATA ELFDATA2LSB #endif +/* The page size. */ +static size_t page_size; + static void register_elf (char *data, size_t len, char *frame_maps); enum bytecode_kind @@ -192,12 +195,13 @@ alloc_aligned (size_t len, unsigned alignment) /* FIXME: Assert that we actually have an 8-byte-aligned malloc. */ ret = malloc (len); } -#if defined(HAVE_SYS_MMAN_H) && defined(MMAP_ANONYMOUS) - else if (alignment == SCM_PAGE_SIZE) +#if defined(HAVE_SYS_MMAN_H) && defined(HAVE_MAP_ANONYMOUS) + else if (alignment == page_size) { - ret = mmap (NULL, len, PROT_READ | PROT_WRITE, -1, 0); + ret = mmap (NULL, len, PROT_READ | PROT_WRITE, + MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); if (ret == MAP_FAILED) - SCM_SYSERROR; + scm_syserror ("load-thunk-from-memory"); } #endif else @@ -429,7 +433,7 @@ load_thunk_from_memory (char *data, size_t len, int is_read_only) continue; if (ph[i].p_flags == PF_R) continue; - if (ph[i].p_align != 4096) + if (ph[i].p_align != page_size) continue; if (mprotect (data + ph[i].p_vaddr, @@ -464,8 +468,6 @@ load_thunk_from_memory (char *data, size_t len, int is_read_only) } #undef FUNC_NAME -#define SCM_PAGE_SIZE 4096 - static char* map_file_contents (int fd, size_t len, int *is_read_only) #define FUNC_NAME "load-thunk-from-file" @@ -794,6 +796,11 @@ scm_find_slot_map_unlocked (const scm_t_uint32 *ip) void scm_bootstrap_loader (void) { + page_size = getpagesize (); + /* page_size should be a power of two. */ + if (page_size & (page_size - 1)) + abort (); + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, "scm_init_loader", (scm_t_extension_init_func)scm_init_loader, NULL); From 81d8ff9e451649d7c53210bff78bad6b65077910 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 8 Jan 2017 23:41:12 +0100 Subject: [PATCH 667/865] Fix alloc_aligned for high allocations * libguile/loader.c (alloc_aligned): Widen alignment. Thanks to Matt Wette for the report and the fix! --- libguile/loader.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/loader.c b/libguile/loader.c index 191e4c157..a4c3e884b 100644 --- a/libguile/loader.c +++ b/libguile/loader.c @@ -212,7 +212,7 @@ alloc_aligned (size_t len, unsigned alignment) ret = malloc (len + alignment - 1); if (!ret) abort (); - ret = (char *) ALIGN ((scm_t_uintptr) ret, alignment); + ret = (char *) ALIGN ((scm_t_uintptr) ret, (scm_t_uintptr) alignment); } return ret; From 2976abdbbbf4274dd4aabf12b50a1bea49882078 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 8 Jan 2017 23:45:58 +0100 Subject: [PATCH 668/865] Fix scm_init_stime for macOS * libguile/stime.c (scm_init_stime): Remove needless test of clock_getcpuclockid. Fixes build on macOS; thanks to Matt Wette for the report and fix. --- libguile/stime.c | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/libguile/stime.c b/libguile/stime.c index 4f3576682..5ca203491 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -833,10 +833,7 @@ scm_init_stime() { clockid_t dummy; - /* Only use the _POSIX_CPUTIME clock if it's going to work across - CPUs. */ - if (clock_getcpuclockid (0, &dummy) == 0 && - clock_gettime (CLOCK_PROCESS_CPUTIME_ID, &posix_run_time_base) == 0) + if (clock_gettime (CLOCK_PROCESS_CPUTIME_ID, &posix_run_time_base) == 0) get_internal_run_time = get_internal_run_time_posix_timer; else errno = 0; From 7e93950552cd9e85a1f3eb73faf16e8423b0fbbe Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Mon, 26 Dec 2016 21:41:17 +0100 Subject: [PATCH 669/865] Final names for new array functions Globally rename (array-from* -> array-slice), (array-from -> array-cell-ref), (array-amend! -> array-cell-set!), (array-for-each-cell -> array-slice-for-each). --- doc/ref/api-data.texi | 152 +++++++++++++++++++------------- libguile/array-map.c | 18 ++-- libguile/array-map.h | 4 +- libguile/arrays.c | 50 +++++------ libguile/arrays.h | 6 +- test-suite/tests/array-map.test | 10 +-- test-suite/tests/arrays.test | 48 +++++----- 7 files changed, 158 insertions(+), 130 deletions(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 58e9f435f..1b3170e4f 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -7761,37 +7761,57 @@ have smaller rank than @var{array}. @node Arrays as arrays of arrays @subsubsection Arrays as arrays of arrays -The functions in this section allow you to treat an array of rank -@math{n} as an array of lower rank @math{n-k} where the elements are -themselves arrays (`cells') of rank @math{k}. This replicates some of -the functionality of `enclosed arrays', a feature of old Guile that was -removed before @w{version 2.0}. However, these functions do not require -a special type and operate on any array. +@cindex array cell -When we operate on an array in this way, we speak of the first @math{k} -dimensions of the array as the @math{k}-`frame' of the array, while the -last @math{n-k} dimensions are the dimensions of the -@math{n-k}-`cell'. For example, a 2D-array (a matrix) can be seen as a -1D array of rows. In this case, the rows are the 1-cells of the array. +Mathematically, one can see an array of rank @math{n} (an +@math{n}-array) as an array of lower rank where the elements are +themselves arrays (`cells'). -@deffn {Scheme Procedure} array-from array idx @dots{} -@deffnx {C Function} scm_array_from (array, idxlist) -If the length of @var{idxlist} equals the rank @math{n} of -@var{array}, return the element at @code{(idx @dots{})}, just like -@code{(array-ref array idx @dots{})}. If, however, the length @math{k} -of @var{idxlist} is shorter than @math{n}, then return the shared -@math{(n-k)}-rank cell of @var{array} given by @var{idxlist}. +@cindex array frame +@cindex frame rank + +We speak of the first @math{n-k} dimensions of the array as the +@math{n-k}-`frame' of the array, while the last @math{k} dimensions are +the dimensions of the @math{k}-`cells'. For example, a 3-array can be +seen as a 2-array of vectors (1-arrays) or as a 1-array of matrices +(2-arrays). In each case, the vectors or matrices are the 1-cells or +2-cells of the array. This terminology originates in the J language. + +@cindex array slice +@cindex prefix slice + +The more vague concept of a `slice' refers to a subset of the array +where some indices are fixed and others are left free. As a Guile data +object, a cell is the same as a `prefix slice' (the first @math{n-k} +indices into the original array are fixed), except that a 0-cell is not +a shared array of the original array, but a 0-slice (where all the +indices into the original array are fixed) is. + +@cindex enclosed array + +Before @w{version 2.0}, Guile had a feature called `enclosed arrays' to +create special `array of arrays' objects. The functions in this section +do not need special types; instead, the frame rank is stated in each +function call, either implicitly or explicitly. + +@deffn {Scheme Procedure} array-cell-ref array idx @dots{} +@deffnx {C Function} scm_array_cell_ref (array, idxlist) +If the length of @var{idxlist} equals the rank @math{n} of @var{array}, +return the element at @code{(idx @dots{})}, just like @code{(array-ref +array idx @dots{})}. If, however, the length @math{k} of @var{idxlist} +is smaller than @math{n}, then return the @math{(n-k)}-cell of +@var{array} given by @var{idxlist}, as a shared array. For example: @lisp -(array-from #2((a b) (c d)) 0) @result{} #(a b) -(array-from #2((a b) (c d)) 1) @result{} #(c d) -(array-from #2((a b) (c d)) 1 1) @result{} d -(array-from #2((a b) (c d))) @result{} #2((a b) (c d)) +(array-cell-ref #2((a b) (c d)) 0) @result{} #(a b) +(array-cell-ref #2((a b) (c d)) 1) @result{} #(c d) +(array-cell-ref #2((a b) (c d)) 1 1) @result{} d +(array-cell-ref #2((a b) (c d))) @result{} #2((a b) (c d)) @end lisp -@code{(apply array-from array indices)} is equivalent to +@code{(apply array-cell-ref array indices)} is equivalent to @lisp (let ((len (length indices))) @@ -7802,28 +7822,27 @@ For example: (drop (array-dimensions a) len)))) @end lisp -The name `from' comes from the J language. @end deffn -@deffn {Scheme Procedure} array-from* array idx @dots{} -@deffnx {C Function} scm_array_from_s (array, idxlist) -Like @code{(array-from array idx @dots{})}, but return a 0-rank shared -array if the length of @var{idxlist} matches the rank of -@var{array}. This can be useful when using @var{ARRAY} as a place to -write into. +@deffn {Scheme Procedure} array-slice array idx @dots{} +@deffnx {C Function} scm_array_slice (array, idxlist) +Like @code{(array-cell-ref array idx @dots{})}, but return a 0-rank +shared array into @var{ARRAY} if the length of @var{idxlist} matches the +rank of @var{array}. This can be useful when using @var{ARRAY} as a +place to write to. Compare: @lisp -(array-from #2((a b) (c d)) 1 1) @result{} d -(array-from* #2((a b) (c d)) 1) @result{} #0(d) +(array-cell-ref #2((a b) (c d)) 1 1) @result{} d +(array-slice #2((a b) (c d)) 1 1) @result{} #0(d) (define a (make-array 'a 2 2)) -(array-fill! (array-from* a 1 1) 'b) +(array-fill! (array-slice a 1 1) 'b) a @result{} #2((a a) (a b)). -(array-fill! (array-from a 1 1) 'b) @result{} error: not an array +(array-fill! (array-cell-ref a 1 1) 'b) @result{} error: not an array @end lisp -@code{(apply array-from* array indices)} is equivalent to +@code{(apply array-slice array indices)} is equivalent to @lisp (apply make-shared-array a @@ -7833,12 +7852,12 @@ a @result{} #2((a a) (a b)). @end deffn -@deffn {Scheme Procedure} array-amend! array x idx @dots{} -@deffnx {C Function} scm_array_amend_x (array, x, idxlist) +@deffn {Scheme Procedure} array-cell-set! array x idx @dots{} +@deffnx {C Function} scm_array_cell_set_x (array, x, idxlist) If the length of @var{idxlist} equals the rank @math{n} of @var{array}, set the element at @code{(idx @dots{})} of @var{array} to @var{x}, just like @code{(array-set! array x idx @dots{})}. If, -however, the length @math{k} of @var{idxlist} is shorter than +however, the length @math{k} of @var{idxlist} is smaller than @math{n}, then copy the @math{(n-k)}-rank array @var{x} into the @math{(n-k)}-cell of @var{array} given by @var{idxlist}. In this case, the last @math{(n-k)} dimensions of @@ -7849,64 +7868,68 @@ This function returns the modified @var{array}. For example: @lisp -(array-amend! (make-array 'a 2 2) b 1 1) @result{} #2((a a) (a b)) -(array-amend! (make-array 'a 2 2) #(x y) 1) @result{} #2((a a) (x y)) +(array-cell-set! (make-array 'a 2 2) b 1 1) + @result{} #2((a a) (a b)) +(array-cell-set! (make-array 'a 2 2) #(x y) 1) + @result{} #2((a a) (x y)) @end lisp -Note that @code{array-amend!} will expect elements, not arrays, when the -destination has rank 0. One can work around this using -@code{array-from*} instead. +Note that @code{array-cell-set!} will expect elements, not arrays, when +the destination has rank 0. Use @code{array-slice} for the opposite +behavior. @lisp -(array-amend! (make-array 'a 2 2) #0(b) 1 1) @result{} #2((a a) (a #0(b))) -(let ((a (make-array 'a 2 2))) (array-copy! #0(b) (array-from* a 1 1)) a) @result{} #2((a a) (a b)) +(array-cell-set! (make-array 'a 2 2) #0(b) 1 1) + @result{} #2((a a) (a #0(b))) +(let ((a (make-array 'a 2 2))) + (array-copy! #0(b) (array-slice a 1 1)) a) + @result{} #2((a a) (a b)) @end lisp -@code{(apply array-amend! array x indices)} is equivalent to +@code{(apply array-cell-set! array x indices)} is equivalent to @lisp (let ((len (length indices))) (if (= (array-rank array) len) (apply array-set! array x indices) - (array-copy! x (apply array-from array indices))) + (array-copy! x (apply array-cell-ref array indices))) array) @end lisp -The name `amend' comes from the J language. @end deffn -@deffn {Scheme Procedure} array-for-each-cell frame-rank op x @dots{} -@deffnx {C Function} scm_array_for_each_cell (array, frame_rank, op, xlist) +@deffn {Scheme Procedure} array-slice-for-each frame-rank op x @dots{} +@deffnx {C Function} scm_array_slice_for_each (array, frame_rank, op, xlist) Each @var{x} must be an array of rank ≥ @var{frame-rank}, and the first @var{frame-rank} dimensions of each @var{x} must all be the -same. @var{array-for-each-cell} calls @var{op} with each set of +same. @var{array-slice-for-each} calls @var{op} with each set of (rank(@var{x}) - @var{frame-rank})-cells from @var{x}, in unspecified order. -@var{array-for-each-cell} allows you to loop over cells of any rank -without having to carry an index list or construct slices manually. The -cells passed to @var{op} are shared arrays of @var{X} so it is possible -to write to them. +@var{array-slice-for-each} allows you to loop over cells of any rank +without having to carry an index list or construct shared arrays +manually. The slices passed to @var{op} are always shared arrays of +@var{X}, even if they are of rank 0, so it is possible to write to them. This function returns an unspecified value. For example, to sort the rows of rank-2 array @code{a}: @lisp -(array-for-each-cell 1 (lambda (x) (sort! x <)) a) +(array-slice-for-each 1 (lambda (x) (sort! x <)) a) @end lisp -As another example, let @code{a} be a rank-2 array where each row is a 2-vector @math{(x,y)}. -Let's compute the arguments of these vectors and store them in rank-1 array @code{b}. +As another example, let @code{a} be a rank-2 array where each row is a +2-element vector @math{(x,y)}. Let's compute the arguments of these +vectors and store them in rank-1 array @code{b}. @lisp -(array-for-each-cell 1 +(array-slice-for-each 1 (lambda (a b) (array-set! b (atan (array-ref a 1) (array-ref a 0)))) a b) @end lisp -@code{(apply array-for-each-cell frame-rank op x)} is functionally -equivalent to +@code{(apply array-slice-for-each frame-rank op x)} is equivalent to @lisp (let ((frame (take (array-dimensions (car x)) frank))) @@ -7916,11 +7939,16 @@ equivalent to (error)) (array-index-map! (apply make-shared-array (make-array #t) (const '()) frame) - (lambda i (apply op (map (lambda (x) (apply array-from* x i)) x))))) + (lambda i (apply op (map (lambda (x) (apply array-slice x i)) x))))) @end lisp @end deffn +@deffn {Scheme Procedure} array-slice-for-each-in-order frame-rank op x @dots{} +@deffnx {C Function} scm_array_slice_for_each_in_order (array, frame_rank, op, xlist) +Same as @code{array-slice-for-each}, but the arguments are traversed +sequentially and in row-major order. +@end deffn @node Accessing Arrays from C @subsubsection Accessing Arrays from C diff --git a/libguile/array-map.c b/libguile/array-map.c index 19e85c369..c2825bc42 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -655,7 +655,7 @@ scm_i_array_rebase (SCM a, size_t base) static inline size_t padtoptr(size_t d) { return (d + (sizeof (void *) - 1)) & ~(sizeof (void *) - 1); } -SCM_DEFINE (scm_array_for_each_cell, "array-for-each-cell", 2, 0, 1, +SCM_DEFINE (scm_array_slice_for_each, "array-slice-for-each", 2, 0, 1, (SCM frame_rank, SCM op, SCM args), "Apply @var{op} to each of the cells of rank rank(@var{arg})-@var{frame_rank}\n" "of the arrays @var{args}, in unspecified order. The first\n" @@ -665,17 +665,17 @@ SCM_DEFINE (scm_array_for_each_cell, "array-for-each-cell", 2, 0, 1, "For example:\n" "@lisp\n" ";; Sort the rows of rank-2 array A.\n\n" - "(array-for-each-cell 1 (lambda (x) (sort! x <)) a)\n" + "(array-slice-for-each 1 (lambda (x) (sort! x <)) a)\n" "\n" ";; Compute the arguments of the (x y) vectors in the rows of rank-2\n" ";; array XYS and store them in rank-1 array ANGLES. Inside OP,\n" ";; XY is a rank-1 (2-1) array, and ANGLE is a rank-0 (1-1) array.\n\n" - "(array-for-each-cell 1 \n" + "(array-slice-for-each 1 \n" " (lambda (xy angle)\n" " (array-set! angle (atan (array-ref xy 1) (array-ref xy 0))))\n" " xys angles)\n" "@end lisp") -#define FUNC_NAME s_scm_array_for_each_cell +#define FUNC_NAME s_scm_array_slice_for_each { int const N = scm_ilength (args); int const frank = scm_to_int (frame_rank); @@ -787,7 +787,7 @@ SCM_DEFINE (scm_array_for_each_cell, "array-for-each-cell", 2, 0, 1, { for (n=0; n!=N; ++n) scm_array_handle_release(ah+n); - scm_misc_error("array-for-each-cell", msg, scm_cons_star(frame_rank, args)); + scm_misc_error("array-slice-for-each", msg, scm_cons_star(frame_rank, args)); } /* prepare moving cells. */ for (n=0; n!=N; ++n) @@ -884,13 +884,13 @@ SCM_DEFINE (scm_array_for_each_cell, "array-for-each-cell", 2, 0, 1, } #undef FUNC_NAME -SCM_DEFINE (scm_array_for_each_cell_in_order, "array-for-each-cell-in-order", 2, 0, 1, +SCM_DEFINE (scm_array_slice_for_each_in_order, "array-slice-for-each-in-order", 2, 0, 1, (SCM frank, SCM op, SCM a), - "Same as array-for-each-cell, but visit the cells sequentially\n" + "Same as array-slice-for-each, but visit the cells sequentially\n" "and in row-major order.\n") -#define FUNC_NAME s_scm_array_for_each_cell_in_order +#define FUNC_NAME s_scm_array_slice_for_each_in_order { - return scm_array_for_each_cell (frank, op, a); + return scm_array_slice_for_each (frank, op, a); } #undef FUNC_NAME diff --git a/libguile/array-map.h b/libguile/array-map.h index acfdd5e24..12351d13a 100644 --- a/libguile/array-map.h +++ b/libguile/array-map.h @@ -37,8 +37,8 @@ SCM_API SCM scm_array_map_x (SCM ra0, SCM proc, SCM lra); SCM_API SCM scm_array_for_each (SCM proc, SCM ra0, SCM lra); SCM_API SCM scm_array_index_map_x (SCM ra, SCM proc); SCM_API SCM scm_array_equal_p (SCM ra0, SCM ra1); -SCM_API SCM scm_array_for_each_cell (SCM frank, SCM op, SCM args); -SCM_API SCM scm_array_for_each_cell_in_order (SCM frank, SCM op, SCM args); +SCM_API SCM scm_array_slice_for_each (SCM frank, SCM op, SCM args); +SCM_API SCM scm_array_slice_for_each_in_order (SCM frank, SCM op, SCM args); SCM_INTERNAL SCM scm_i_array_rebase (SCM a, size_t base); SCM_INTERNAL void scm_init_array_map (void); diff --git a/libguile/arrays.c b/libguile/arrays.c index b17c415c2..8b8bc48cd 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -468,19 +468,19 @@ array_from_get_o (scm_t_array_handle *handle, size_t k, scm_t_array_dim *s, ssiz } } -SCM_DEFINE (scm_array_from_s, "array-from*", 1, 0, 1, +SCM_DEFINE (scm_array_slice, "array-slice", 1, 0, 1, (SCM ra, SCM indices), "Return the array slice @var{ra}[@var{indices} ..., ...]\n" "The rank of @var{ra} must equal to the number of indices or larger.\n\n" - "See also @code{array-ref}, @code{array-from}, @code{array-amend!}.\n\n" - "@code{array-from*} may return a rank-0 array. For example:\n" + "See also @code{array-ref}, @code{array-cell-ref}, @code{array-cell-set!}.\n\n" + "@code{array-slice} may return a rank-0 array. For example:\n" "@lisp\n" - "(array-from* #2((1 2 3) (4 5 6)) 1 1) @result{} #0(5)\n" - "(array-from* #2((1 2 3) (4 5 6)) 1) @result{} #(4 5 6)\n" - "(array-from* #2((1 2 3) (4 5 6))) @result{} #2((1 2 3) (4 5 6))\n" - "(array-from* #0(5) @result{} #0(5).\n" + "(array-slice #2((1 2 3) (4 5 6)) 1 1) @result{} #0(5)\n" + "(array-slice #2((1 2 3) (4 5 6)) 1) @result{} #(4 5 6)\n" + "(array-slice #2((1 2 3) (4 5 6))) @result{} #2((1 2 3) (4 5 6))\n" + "(array-slice #0(5) @result{} #0(5).\n" "@end lisp") -#define FUNC_NAME s_scm_array_from_s +#define FUNC_NAME s_scm_array_slice { SCM o, i = indices; size_t ndim, k; @@ -506,20 +506,20 @@ SCM_DEFINE (scm_array_from_s, "array-from*", 1, 0, 1, #undef FUNC_NAME -SCM_DEFINE (scm_array_from, "array-from", 1, 0, 1, +SCM_DEFINE (scm_array_cell_ref, "array-cell-ref", 1, 0, 1, (SCM ra, SCM indices), "Return the element at the @code{(@var{indices} ...)} position\n" "in array @var{ra}, or the array slice @var{ra}[@var{indices} ..., ...]\n" "if the rank of @var{ra} is larger than the number of indices.\n\n" - "See also @code{array-ref}, @code{array-from*}, @code{array-amend!}.\n\n" - "@code{array-from} never returns a rank 0 array. For example:\n" + "See also @code{array-ref}, @code{array-slice}, @code{array-cell-set!}.\n\n" + "@code{array-cell-ref} never returns a rank 0 array. For example:\n" "@lisp\n" - "(array-from #2((1 2 3) (4 5 6)) 1 1) @result{} 5\n" - "(array-from #2((1 2 3) (4 5 6)) 1) @result{} #(4 5 6)\n" - "(array-from #2((1 2 3) (4 5 6))) @result{} #2((1 2 3) (4 5 6))\n" - "(array-from #0(5) @result{} 5.\n" + "(array-cell-ref #2((1 2 3) (4 5 6)) 1 1) @result{} 5\n" + "(array-cell-ref #2((1 2 3) (4 5 6)) 1) @result{} #(4 5 6)\n" + "(array-cell-ref #2((1 2 3) (4 5 6))) @result{} #2((1 2 3) (4 5 6))\n" + "(array-cell-ref #0(5) @result{} 5.\n" "@end lisp") -#define FUNC_NAME s_scm_array_from +#define FUNC_NAME s_scm_array_cell_ref { SCM o, i = indices; size_t ndim, k; @@ -548,25 +548,25 @@ SCM_DEFINE (scm_array_from, "array-from", 1, 0, 1, #undef FUNC_NAME -SCM_DEFINE (scm_array_amend_x, "array-amend!", 2, 0, 1, +SCM_DEFINE (scm_array_cell_set_x, "array-cell-set!", 2, 0, 1, (SCM ra, SCM b, SCM indices), "Set the array slice @var{ra}[@var{indices} ..., ...] to @var{b}\n." - "Equivalent to @code{(array-copy! @var{b} (apply array-from @var{ra} @var{indices}))}\n" + "Equivalent to @code{(array-copy! @var{b} (apply array-cell-ref @var{ra} @var{indices}))}\n" "if the number of indices is smaller than the rank of @var{ra}; otherwise\n" "equivalent to @code{(apply array-set! @var{ra} @var{b} @var{indices})}.\n" "This function returns the modified array @var{ra}.\n\n" - "See also @code{array-ref}, @code{array-from}, @code{array-from*}.\n\n" + "See also @code{array-ref}, @code{array-cell-ref}, @code{array-slice}.\n\n" "For example:\n" "@lisp\n" "(define A (list->array 2 '((1 2 3) (4 5 6))))\n" - "(array-amend! A #0(99) 1 1) @result{} #2((1 2 3) (4 #0(99) 6))\n" - "(array-amend! A 99 1 1) @result{} #2((1 2 3) (4 99 6))\n" - "(array-amend! A #(a b c) 0) @result{} #2((a b c) (4 99 6))\n" - "(array-amend! A #2((x y z) (9 8 7))) @result{} #2((x y z) (9 8 7))\n\n" + "(array-cell-set! A #0(99) 1 1) @result{} #2((1 2 3) (4 #0(99) 6))\n" + "(array-cell-set! A 99 1 1) @result{} #2((1 2 3) (4 99 6))\n" + "(array-cell-set! A #(a b c) 0) @result{} #2((a b c) (4 99 6))\n" + "(array-cell-set! A #2((x y z) (9 8 7))) @result{} #2((x y z) (9 8 7))\n\n" "(define B (make-array 0))\n" - "(array-amend! B 15) @result{} #0(15)\n" + "(array-cell-set! B 15) @result{} #0(15)\n" "@end lisp") -#define FUNC_NAME s_scm_array_amend_x +#define FUNC_NAME s_scm_array_cell_set_x { SCM o, i = indices; size_t ndim, k; diff --git a/libguile/arrays.h b/libguile/arrays.h index 37eea69bd..b56abef94 100644 --- a/libguile/arrays.h +++ b/libguile/arrays.h @@ -49,9 +49,9 @@ SCM_API SCM scm_shared_array_increments (SCM ra); SCM_API SCM scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims); SCM_API SCM scm_transpose_array (SCM ra, SCM args); SCM_API SCM scm_array_contents (SCM ra, SCM strict); -SCM_API SCM scm_array_from_s (SCM ra, SCM indices); -SCM_API SCM scm_array_from (SCM ra, SCM indices); -SCM_API SCM scm_array_amend_x (SCM ra, SCM b, SCM indices); +SCM_API SCM scm_array_slice (SCM ra, SCM indices); +SCM_API SCM scm_array_cell_ref (SCM ra, SCM indices); +SCM_API SCM scm_array_cell_set_x (SCM ra, SCM b, SCM indices); SCM_API SCM scm_list_to_array (SCM ndim, SCM lst); SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst); diff --git a/test-suite/tests/array-map.test b/test-suite/tests/array-map.test index 3095b78f4..347184112 100644 --- a/test-suite/tests/array-map.test +++ b/test-suite/tests/array-map.test @@ -509,29 +509,29 @@ (array-for-each (lambda (b c) (set! a (cons* b c a))) b c))))) ;;; -;;; array-for-each-cell +;;; array-slice-for-each ;;; -(with-test-prefix "array-for-each-cell" +(with-test-prefix "array-slice-for-each" (pass-if-equal "1 argument frame rank 1" #2((1 3 9) (2 7 8)) (let* ((a (list->array 2 '((9 1 3) (7 8 2))))) - (array-for-each-cell 1 (lambda (a) (sort! a <)) a) + (array-slice-for-each 1 (lambda (a) (sort! a <)) a) a)) (pass-if-equal "2 arguments frame rank 1" #f64(8 -1) (let* ((x (list->typed-array 'f64 2 '((9 1) (7 8)))) (y (f64vector 99 99))) - (array-for-each-cell 1 (lambda (y x) (array-set! y (- (array-ref x 0) (array-ref x 1)))) y x) + (array-slice-for-each 1 (lambda (y x) (array-set! y (- (array-ref x 0) (array-ref x 1)))) y x) y)) (pass-if-equal "regression: zero-sized frame loop without unrolling" 99 (let* ((x 99) (o (make-array 0. 0 3 2))) - (array-for-each-cell 2 + (array-slice-for-each 2 (lambda (o a0 a1) (set! x 0)) o diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test index 4c943dd41..1df77b1ba 100644 --- a/test-suite/tests/arrays.test +++ b/test-suite/tests/arrays.test @@ -298,110 +298,110 @@ ;;; -;;; array-from* +;;; array-slice ;;; -(with-test-prefix/c&e "array-from*" +(with-test-prefix/c&e "array-slice" (pass-if "vector I" (let ((v (vector 1 2 3))) - (array-fill! (array-from* v 1) 'a) + (array-fill! (array-slice v 1) 'a) (array-equal? v #(1 a 3)))) (pass-if "vector II" (let ((v (vector 1 2 3))) - (array-copy! #(a b c) (array-from* v)) + (array-copy! #(a b c) (array-slice v)) (array-equal? v #(a b c)))) (pass-if "array I" (let ((a (list->array 2 '((1 2 3) (4 5 6))))) - (array-fill! (array-from* a 1 1) 'a) + (array-fill! (array-slice a 1 1) 'a) (array-equal? a #2((1 2 3) (4 a 6))))) (pass-if "array II" (let ((a (list->array 2 '((1 2 3) (4 5 6))))) - (array-copy! #(a b c) (array-from* a 1)) + (array-copy! #(a b c) (array-slice a 1)) (array-equal? a #2((1 2 3) (a b c))))) (pass-if "array III" (let ((a (list->array 2 '((1 2 3) (4 5 6))))) - (array-copy! #2((a b c) (x y z)) (array-from* a)) + (array-copy! #2((a b c) (x y z)) (array-slice a)) (array-equal? a #2((a b c) (x y z))))) (pass-if "rank 0 array" (let ((a (make-array 77))) - (array-fill! (array-from* a) 'a) + (array-fill! (array-slice a) 'a) (array-equal? a #0(a))))) ;;; -;;; array-from +;;; array-cell-ref ;;; -(with-test-prefix/c&e "array-from" +(with-test-prefix/c&e "array-cell-ref" (pass-if "vector I" (let ((v (vector 1 2 3))) - (equal? 2 (array-from v 1)))) + (equal? 2 (array-cell-ref v 1)))) (pass-if "vector II" (let ((v (vector 1 2 3))) - (array-copy! #(a b c) (array-from v)) + (array-copy! #(a b c) (array-cell-ref v)) (array-equal? v #(a b c)))) (pass-if "array I" (let ((a (list->array 2 '((1 2 3) (4 5 6))))) - (equal? 5 (array-from a 1 1)))) + (equal? 5 (array-cell-ref a 1 1)))) (pass-if "array II" (let ((a (list->array 2 '((1 2 3) (4 5 6))))) - (array-copy! #(a b c) (array-from a 1)) + (array-copy! #(a b c) (array-cell-ref a 1)) (array-equal? a #2((1 2 3) (a b c))))) (pass-if "array III" (let ((a (list->array 2 '((1 2 3) (4 5 6))))) - (array-copy! #2((a b c) (x y z)) (array-from a)) + (array-copy! #2((a b c) (x y z)) (array-cell-ref a)) (array-equal? a #2((a b c) (x y z))))) (pass-if "rank 0 array" (let ((a (make-array 77))) - (equal? (array-from a) 77)))) + (equal? (array-cell-ref a) 77)))) ;;; -;;; array-amend! +;;; array-cell-set! ;;; -(with-test-prefix/c&e "array-amend!" +(with-test-prefix/c&e "array-cell-set!" (pass-if "vector I" (let ((v (vector 1 2 3))) - (and (eq? v (array-amend! v 'x 1)) + (and (eq? v (array-cell-set! v 'x 1)) (array-equal? v #(1 x 3))))) (pass-if "vector II" (let ((v (vector 1 2 3))) - (and (eq? v (array-amend! (array-from v) #(a b c))) + (and (eq? v (array-cell-set! (array-cell-ref v) #(a b c))) (array-equal? v #(a b c))))) (pass-if "array I" (let ((a (list->array 2 '((1 2 3) (4 5 6))))) - (and (eq? a (array-amend! a 'x 1 1)) + (and (eq? a (array-cell-set! a 'x 1 1)) (array-equal? a #2((1 2 3) (4 x 6)))))) (pass-if "array II" (let ((a (list->array 2 '((1 2 3) (4 5 6))))) - (and (eq? a (array-amend! a #(a b c) 1)) + (and (eq? a (array-cell-set! a #(a b c) 1)) (array-equal? a #2((1 2 3) (a b c)))))) (pass-if "array III" (let ((a (list->array 2 '((1 2 3) (4 5 6))))) - (and (eq? a (array-amend! a #2((a b c) (x y z)))) + (and (eq? a (array-cell-set! a #2((a b c) (x y z)))) (array-equal? a #2((a b c) (x y z)))))) (pass-if "rank 0 array" (let ((a (make-array 77))) - (and (eq? a (array-amend! a 99)) + (and (eq? a (array-cell-set! a 99)) (array-equal? a #0(99)))))) From 63bf6ffa0d3cdddf8151cc80ac18fe5dfb614587 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 11 Jan 2017 22:17:24 +0100 Subject: [PATCH 670/865] Protect call-with-new-thread data from GC. * libguile/threads.c (struct launch_data): Add prev/next pointers. (protected_launch_data, protected_launch_data_lock): New static vars. (protect_launch_data, unprotect_launch_data): New functions. (really_launch, scm_sys_call_with_new_thread): Preserve launch data from GC. Thanks to Linas Vepstas for the report! --- libguile/threads.c | 39 +++++++++++++++++++++++++++++++++++++-- 1 file changed, 37 insertions(+), 2 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index da5b8141d..1faa539e1 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -735,15 +735,49 @@ scm_call_with_new_thread (SCM thunk, SCM handler) return scm_call_2 (call_with_new_thread, thunk, handler); } -typedef struct { +typedef struct launch_data launch_data; + +struct launch_data { + launch_data *prev; + launch_data *next; SCM dynamic_state; SCM thunk; -} launch_data; +}; + +/* GC-protect the launch data for new threads. */ +static launch_data *protected_launch_data; +static scm_i_pthread_mutex_t protected_launch_data_lock = + SCM_I_PTHREAD_MUTEX_INITIALIZER; + +static void +protect_launch_data (launch_data *data) +{ + scm_i_pthread_mutex_lock (&protected_launch_data_lock); + data->next = protected_launch_data; + if (protected_launch_data) + protected_launch_data->prev = data; + protected_launch_data = data; + scm_i_pthread_mutex_unlock (&protected_launch_data_lock); +} + +static void +unprotect_launch_data (launch_data *data) +{ + scm_i_pthread_mutex_lock (&protected_launch_data_lock); + if (data->next) + data->next->prev = data->prev; + if (data->prev) + data->prev->next = data->next; + else + protected_launch_data = data->next; + scm_i_pthread_mutex_unlock (&protected_launch_data_lock); +} static void * really_launch (void *d) { scm_i_thread *t = SCM_I_CURRENT_THREAD; + unprotect_launch_data (d); /* The thread starts with asyncs blocked. */ t->block_asyncs++; SCM_I_CURRENT_THREAD->result = scm_call_0 (((launch_data *)d)->thunk); @@ -774,6 +808,7 @@ SCM_DEFINE (scm_sys_call_with_new_thread, "%call-with-new-thread", 1, 0, 0, data = scm_gc_typed_calloc (launch_data); data->dynamic_state = scm_current_dynamic_state (); data->thunk = thunk; + protect_launch_data (data); err = scm_i_pthread_create (&id, NULL, launch_thread, data); if (err) { From 35a90592501ebde7e7ddbf2486ca9d315e317d09 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Mon, 12 Dec 2016 22:46:08 -0500 Subject: [PATCH 671/865] Add unboxed floating point comparison instructions. * libguile/vm-engine.c (BR_F64_ARITHMETIC): New preprocessor macro. (br_if_f64_ee, br_if_f64_lt, br_if_f64_le, br_if_f64_gt, br_if_f64_ge): New VM instructions. * doc/ref/vm.texi ("Unboxed Floating-Point Arithmetic"): Document them. * module/language/cps/compile-bytecode.scm (compile-function): Emit f64 comparison instructions. * module/language/cps/effects-analysis.scm: Define effects for f64 primcalls. * module/language/cps/primitives.scm (*branching-primcall-arities*): Add arities for f64 primcalls. * module/language/cps/specialize-numbers.scm (specialize-f64-comparison): New procedure. (specialize-operations): Specialize f64 comparisons. * module/system/vm/assembler.scm (emit-br-if-f64-=, emit-br-if-f64-<) (emit-br-if-f64-<=, emit-br-if-f64->, emit-br-if-f64->=): Export. * module/system/vm/disassembler.scm (code-annotation): Add annotations for f64 comparison instructions. --- doc/ref/vm.texi | 10 +++ libguile/vm-engine.c | 73 ++++++++++++++++++++-- module/language/cps/compile-bytecode.scm | 7 ++- module/language/cps/effects-analysis.scm | 5 ++ module/language/cps/primitives.scm | 7 ++- module/language/cps/specialize-numbers.scm | 52 ++++++++++----- module/language/cps/type-fold.scm | 5 ++ module/system/vm/assembler.scm | 5 ++ module/system/vm/disassembler.scm | 2 + 9 files changed, 145 insertions(+), 21 deletions(-) diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 1abbbce15..4e42bb94c 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -1674,3 +1674,13 @@ the operands as unboxed IEEE double floating-point numbers, and producing the same. @end deftypefn +@deftypefn Instruction {} br-if-f64-= s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} +@deftypefnx Instruction {} br-if-f64-< s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} +@deftypefnx Instruction {} br-if-f64-<= s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} +@deftypefnx Instruction {} br-if-f64-> s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} +@deftypefnx Instruction {} br-if-f64->= s24:@var{a} x8:@var{_} s24:@var{b} b1:@var{invert} x7:@var{_} l24:@var{offset} +If the unboxed IEEE double value in @var{a} is @code{=}, @code{<}, +@code{<=}, @code{>}, or @code{>=} to the unboxed IEEE double value in +@var{b}, respectively, add @var{offset} to the current instruction +pointer. +@end deftypefn diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 195237ab4..684840617 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -358,6 +358,24 @@ NEXT (3); \ } +#define BR_F64_ARITHMETIC(crel) \ + { \ + scm_t_uint32 a, b; \ + scm_t_uint64 x, y; \ + UNPACK_24 (op, a); \ + UNPACK_24 (ip[1], b); \ + x = SP_REF_F64 (a); \ + y = SP_REF_F64 (b); \ + if ((ip[2] & 0x1) ? !(x crel y) : (x crel y)) \ + { \ + scm_t_int32 offset = ip[2]; \ + offset >>= 8; /* Sign-extending shift. */ \ + NEXT (offset); \ + } \ + NEXT (3); \ + } + + #define ARGS1(a1) \ scm_t_uint16 dst, src; \ SCM a1; \ @@ -3935,11 +3953,56 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (1); } - VM_DEFINE_OP (187, unused_187, NULL, NOP) - VM_DEFINE_OP (188, unused_188, NULL, NOP) - VM_DEFINE_OP (189, unused_189, NULL, NOP) - VM_DEFINE_OP (190, unused_190, NULL, NOP) - VM_DEFINE_OP (191, unused_191, NULL, NOP) + /* br-if-f64-= a:12 b:12 invert:1 _:7 offset:24 + * + * If the F64 value in A is = to the F64 value in B, add OFFSET, a + * signed 24-bit number, to the current instruction pointer. + */ + VM_DEFINE_OP (187, br_if_f64_ee, "br-if-f64-=", OP3 (X8_S24, X8_S24, B1_X7_L24)) + { + BR_F64_ARITHMETIC (==); + } + + /* br-if-f64-< a:12 b:12 invert:1 _:7 offset:24 + * + * If the F64 value in A is < to the F64 value in B, add OFFSET, a + * signed 24-bit number, to the current instruction pointer. + */ + VM_DEFINE_OP (188, br_if_f64_lt, "br-if-f64-<", OP3 (X8_S24, X8_S24, B1_X7_L24)) + { + BR_F64_ARITHMETIC (<); + } + + /* br-if-f64-<= a:24 _:8 b:24 invert:1 _:7 offset:24 + * + * If the F64 value in A is <= than the F64 value in B, add OFFSET, a + * signed 24-bit number, to the current instruction pointer. + */ + VM_DEFINE_OP (189, br_if_f64_le, "br-if-f64-<=", OP3 (X8_S24, X8_S24, B1_X7_L24)) + { + BR_F64_ARITHMETIC (<=); + } + + /* br-if-f64-> a:24 _:8 b:24 invert:1 _:7 offset:24 + * + * If the F64 value in A is > than the F64 value in B, add OFFSET, a + * signed 24-bit number, to the current instruction pointer. + */ + VM_DEFINE_OP (190, br_if_f64_gt, "br-if-f64->", OP3 (X8_S24, X8_S24, B1_X7_L24)) + { + BR_F64_ARITHMETIC (>); + } + + /* br-if-uf4->= a:24 _:8 b:24 invert:1 _:7 offset:24 + * + * If the F64 value in A is >= than the F64 value in B, add OFFSET, a + * signed 24-bit number, to the current instruction pointer. + */ + VM_DEFINE_OP (191, br_if_f64_ge, "br-if-f64->=", OP3 (X8_S24, X8_S24, B1_X7_L24)) + { + BR_F64_ARITHMETIC (>=); + } + VM_DEFINE_OP (192, unused_192, NULL, NOP) VM_DEFINE_OP (193, unused_193, NULL, NOP) VM_DEFINE_OP (194, unused_194, NULL, NOP) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index db5b8fa70..a3f8ba4de 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -446,7 +446,12 @@ (($ $primcall 'u64-=-scm (a b)) (binary emit-br-if-u64-=-scm a b)) (($ $primcall 'u64->=-scm (a b)) (binary emit-br-if-u64->=-scm a b)) (($ $primcall 'u64->-scm (a b)) (binary emit-br-if-u64->-scm a b)) - (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b)))) + (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b)) + (($ $primcall 'f64-< (a b)) (binary emit-br-if-f64-< a b)) + (($ $primcall 'f64-<= (a b)) (binary emit-br-if-f64-<= a b)) + (($ $primcall 'f64-= (a b)) (binary emit-br-if-f64-= a b)) + (($ $primcall 'f64->= (a b)) (binary emit-br-if-f64->= a b)) + (($ $primcall 'f64-> (a b)) (binary emit-br-if-f64-> a b)))) (define (compile-trunc label k exp nreq rest-var) (define (do-call proc args emit-call) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 9ce65853d..f1833bbb5 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -439,6 +439,11 @@ is or might be a read or a write to the same location as A." ((u64-=-scm . _) &type-check) ((u64->=-scm . _) &type-check) ((u64->-scm . _) &type-check) + ((f64-= . _)) + ((f64-< . _)) + ((f64-> . _)) + ((f64-<= . _)) + ((f64->= . _)) ((zero? . _) &type-check) ((add . _) &type-check) ((add/immediate . _) &type-check) diff --git a/module/language/cps/primitives.scm b/module/language/cps/primitives.scm index bc03c983e..a3e6e38e6 100644 --- a/module/language/cps/primitives.scm +++ b/module/language/cps/primitives.scm @@ -99,7 +99,12 @@ (u64-=-scm . (1 . 2)) (u64->=-scm . (1 . 2)) (u64->-scm . (1 . 2)) - (logtest . (1 . 2)))) + (logtest . (1 . 2)) + (f64-= . (1 . 2)) + (f64-< . (1 . 2)) + (f64-> . (1 . 2)) + (f64-<= . (1 . 2)) + (f64->= . (1 . 2)))) (define (compute-prim-instructions) (let ((table (make-hash-table))) diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm index 8ce32453b..808ea6705 100644 --- a/module/language/cps/specialize-numbers.scm +++ b/module/language/cps/specialize-numbers.scm @@ -144,6 +144,20 @@ ($continue kop src ($primcall 'scm->u64 (a-u64))))))) +(define (specialize-f64-comparison cps kf kt src op a b) + (let ((op (symbol-append 'f64- op))) + (with-cps cps + (letv f64-a f64-b) + (letk kop ($kargs ('f64-b) (f64-b) + ($continue kf src + ($branch kt ($primcall op (f64-a f64-b)))))) + (letk kunbox-b ($kargs ('f64-a) (f64-a) + ($continue kop src + ($primcall 'scm->f64 (b))))) + (build-term + ($continue kunbox-b src + ($primcall 'scm->f64 (a))))))) + (define (sigbits-union x y) (and x y (logior x y))) @@ -287,6 +301,11 @@ BITS indicating the significant bits needed for a variable. BITS may be (lambda (type min max) (and (eqv? type &exact-integer) (<= 0 min max #xffffffffffffffff)))))) + (define (f64-operand? var) + (call-with-values (lambda () + (lookup-pre-type types label var)) + (lambda (type min max) + (and (eqv? type &flonum))))) (match cont (($ $kfun) (let ((types (infer-types cps label))) @@ -391,20 +410,25 @@ BITS indicating the significant bits needed for a variable. BITS may be ($ $continue k src ($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) (a b))))) (values - (if (u64-operand? a) - (let ((specialize (if (u64-operand? b) - specialize-u64-comparison - specialize-u64-scm-comparison))) - (with-cps cps - (let$ body (specialize k kt src op a b)) - (setk label ($kargs names vars ,body)))) - (if (u64-operand? b) - (let ((op (match op - ('< '>) ('<= '>=) ('= '=) ('>= '<=) ('> '<)))) - (with-cps cps - (let$ body (specialize-u64-scm-comparison k kt src op b a)) - (setk label ($kargs names vars ,body)))) - cps)) + (cond + ((or (f64-operand? a) (f64-operand? b)) + (with-cps cps + (let$ body (specialize-f64-comparison k kt src op a b)) + (setk label ($kargs names vars ,body)))) + ((u64-operand? a) + (let ((specialize (if (u64-operand? b) + specialize-u64-comparison + specialize-u64-scm-comparison))) + (with-cps cps + (let$ body (specialize k kt src op a b)) + (setk label ($kargs names vars ,body))))) + ((u64-operand? b) + (let ((op (match op + ('< '>) ('<= '>=) ('= '=) ('>= '<=) ('> '<)))) + (with-cps cps + (let$ body (specialize-u64-scm-comparison k kt src op b a)) + (setk label ($kargs names vars ,body))))) + (else cps)) types sigbits)) (_ (values cps types sigbits)))) diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm index 9459e31a0..fc37fac50 100644 --- a/module/language/cps/type-fold.scm +++ b/module/language/cps/type-fold.scm @@ -110,6 +110,11 @@ (else (values #f #f)))) (define-branch-folder-alias u64-< <) (define-branch-folder-alias u64-<-scm <) +;; We currently cannot define branch folders for floating point +;; comparison ops like the commented one below because we can't prove +;; there are no nans involved. +;; +;; (define-branch-folder-alias f64-< <) (define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1) (case (compare-ranges type0 min0 max0 type1 min1 max1) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 2c6bf816a..226a2233e 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -106,6 +106,11 @@ emit-br-if-u64-=-scm emit-br-if-u64->=-scm emit-br-if-u64->-scm + emit-br-if-f64-= + emit-br-if-f64-< + emit-br-if-f64-<= + emit-br-if-f64-> + emit-br-if-f64->= emit-box emit-box-ref emit-box-set! diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index b0867e665..b6f4f7804 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -198,6 +198,8 @@ address of that offset." 'br-if-u64-= 'br-if-u64-< 'br-if-u64-<= 'br-if-u64-<-scm 'br-if-u64-<=-scm 'br-if-u64-=-scm 'br-if-u64->-scm 'br-if-u64->=-scm + 'br-if-f64-= 'br-if-f64-< 'br-if-f64-<= + 'br-if-f64-> 'br-if-f64->= 'br-if-logtest) _ ... target) (list "-> ~A" (vector-ref labels (- (+ offset target) start)))) (('br-if-tc7 slot invert? tc7 target) From eec9aeba560111d79c767d7e4e387f0f07da20d1 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 19 Jan 2017 01:42:44 +0100 Subject: [PATCH 672/865] Fix build warning * libguile/stime.c (scm_init_stime): Remove unused variable. --- libguile/stime.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/libguile/stime.c b/libguile/stime.c index 5ca203491..4a7829833 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -831,8 +831,6 @@ scm_init_stime() #ifdef HAVE_POSIX_CPUTIME { - clockid_t dummy; - if (clock_gettime (CLOCK_PROCESS_CPUTIME_ID, &posix_run_time_base) == 0) get_internal_run_time = get_internal_run_time_posix_timer; else From c74426fcb2fd5c9f35ef354c78364fe63f911a69 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 19 Jan 2017 01:21:15 +0100 Subject: [PATCH 673/865] Update NEWS. * NEWS: Update. --- NEWS | 319 ++++++++++++++++++++++++++++++++--------------------------- 1 file changed, 175 insertions(+), 144 deletions(-) diff --git a/NEWS b/NEWS index 9a364cc46..5680a2032 100644 --- a/NEWS +++ b/NEWS @@ -6,162 +6,47 @@ Please send Guile bug reports to bug-guile@gnu.org. -Changes in 2.1.5 (changes since the 2.1.4 alpha release): +Changes in 2.1.6 (changes since the 2.1.5 alpha release): -* Notable changes -** Lightweight pre-emptive threading primitives +* New interfaces +** suspendable-continuation? -The compiler now inserts special "handle-interrupts" opcodes before each -call, return, and loop back-edge. This allows the user to interrupt any -computation and to accurately profile code using interrupts. It used to -be that interrupts were run by calling a C function from the VM; now -interrupt thunks are run directly from the VM. This allows interrupts -to save a delimited continuation and, if the continuation was -established from the same VM invocation (the usual restriction), that -continuation can then be resumed. In this way users can implement -lightweight pre-emptive threading facilities. +This predicate returns true if the delimited continuation captured by +aborting to a prompt would be able to be resumed. See "Prompt +Primitives" in the manual for more. -** with-dynamic-state in VM +** scm_c_prepare_to_wait_on_fd, scm_c_prepare_to_wait_on_cond, +** scm_c_wait_finished -Similarly, `with-dynamic-state' no longer recurses out of the VM, -allowing captured delimited continuations that include a -`with-dynamic-state' invocation to be resumed. This is a precondition -to allow lightweight threading libraries to establish a dynamic state -per thread. +See "Interrupts" in the manual for more. * Performance improvements -** Mutexes are now faster under contention -Guile implements its own mutexes, so that threads that are trying to -acquire a mutex can be interrupted. These mutexes used to be quite -inefficient when many threads were trying to acquire them, causing many -spurious wakeups and contention. This has been fixed. +** Support unboxed floating-point comparisons + +Thanks to David Thompson for this work. * Incompatible changes -** Threading facilities moved to (ice-9 threads) -It used to be that call-with-new-thread and other threading primitives -were available in the default environment. This is no longer the case; -they have been moved to (ice-9 threads) instead. Existing code will not -break, however; we used the deprecation facility to signal a warning -message while also providing these bindings in the root environment for -the duration of the 2.2 series. +** Rename new array functions -** SRFI-18 threads, mutexes, cond vars disjoint from Guile - -When we added support for the SRFI-18 threading library in Guile 2.0, we -did so in a way that made SRFI-18 mutexes the same as Guile mutexes. -This was a mistake. In Guile our goal is to provide basic, -well-thought-out, well-implemented, minimal primitives, on top of which -we can build a variety of opinionated frameworks. Incorporating SRFI-18 -functionality into core Guile caused us to bloat and slow down our core -threading primitives. Worse, they became very hard to describe; they -did many things, did them poorly, and all that they did was never -adequately specified. - -For all of these reasons we have returned to a situation where SRFI-18 -concepts are implemented only in the `(srfi srfi-18)' module. This -means that SRFI-18 threads are built on Guile threads, but aren't the -same as Guile threads; calling Guile `thread?' on a thread no longer -returns true. - -We realize this causes inconvenience to users who use both Guile -threading interfaces and SRFI-18 interfaces, and we lament the change -- -but we are better off now. We hope the newly revised "Scheduling" -section in the manual compensates for the headache. - -** Remove `lock-mutex' "owner" argument - -Mutex owners are a SRFI-18 concept; use SRFI-18 mutexes instead. -Relatedly, `scm_lock_mutex_timed' taking the owner argument is now -deprecated; use `scm_timed_lock_mutex' instead. - -** Remove `unlock-mutex' cond var and timeout arguments - -It used to be that `unlock-mutex' included `wait-condition-variable' -functionality. This has been deprecated; use SRFI-18 if you want this -behavior from `mutex-unlock!'. Relatedly, `scm_unlock_mutex_timed' is -deprecated; use `scm_unlock_mutex' instead. - -** Removed `unchecked-unlock' mutex flag - -This flag was introduced for internal use by SRFI-18; use SRFI-18 -mutexes if you need this behaviour. - -** SRFI-18 mutexes no longer recursive - -Contrary to specification, SRFI-18 mutexes in Guile were recursive. -This is no longer the case. - -** Thread cleanup handlers removed - -The `set-thread-cleanup!' and `thread-cleanup' functions that were added -in Guile 2.0 to support cleanup after thread cancellation are no longer -needed, since threads can declare cleanup handlers via `dynamic-wind'. - -** Only threads created by Guile are joinable - -`join-thread' used to work on "foreign" threads that were not created by -Guile itself, though their join value was always `#f'. This is no -longer the case; attempting to join a foreign thread will throw an -error. - -** Dynamic states capture values, not locations - -Dynamic states used to capture the locations of fluid-value -associations. Capturing the current dynamic state then setting a fluid -would result in a mutation of that captured state. Now capturing a -dynamic state simply captures the current values, and calling -`with-dynamic-state' copies those values into the Guile virtual machine -instead of aliasing them in a way that could allow them to be mutated in -place. This change allows Guile's fluid variables to be thread-safe. -To capture the locations of a dynamic state, capture a -`with-dynamic-state' invocation using partial continuations instead. - -* New deprecations -** Arbiters deprecated - -Arbiters were an experimental mutual exclusion facility from 20 years -ago that didn't survive the test of time. Use mutexes or atomic boxes -instead. - -** User asyncs deprecated - -Guile had (and still has) "system asyncs", which are asynchronous -interrupts, and also had this thing called "user asyncs", which was a -trivial unused data structure. Now that we have deprecated the old -`async', `async-mark', and `run-asyncs' procedures that comprised the -"user async" facility, we have been able to clarify our documentation to -only refer to "asyncs". - -** Critical sections deprecated - -Critical sections have long been just a fancy way to lock a mutex and -defer asynchronous interrupts. Instead of SCM_CRITICAL_SECTION_START, -make sure you're in a "scm_dynwind_begin (0)" and use -scm_dynwind_pthread_mutex_lock instead, possibly also with -scm_dynwind_block_asyncs. - -** `scm_make_mutex_with_flags' deprecated - -Use `scm_make_mutex_with_kind' instead. See "Mutexes and Condition -Variables" in the manual, for more. - -** Dynamic roots deprecated - -This was a facility that predated threads, was unused as far as we can -tell, and was never documented. Still, a grep of your code for -dynamic-root or dynamic_root would not be amiss. - -** `make-dynamic-state' deprecated - -Use `current-dynamic-state' to get an immutable copy of the current -fluid-value associations. +See "Arrays as arrays of arrays" in the manual for more. * Bug fixes -** cancel-thread uses asynchronous interrupts, not pthread_cancel -See "Asyncs" in the manual, for more on asynchronous interrupts. +** `scm_gc_warn_proc' writes directly to stderr + +The garbage collector sometimes has warnings to display to the user. +Before, Guile would see if the current warning port was a file port, and +in that case write the warning to that file, and otherwise default to +stderr. Now Guile just writes to stderr, fixing a bug where determining +the current warning port would allocate and thus deadlock as the GC +warnings are issued with the GC lock held. + +** Fix miscompilation in significant-bits computation for loop vars +** Fix many threading bugs +** Fix macOS portability bugs +Thanks to Matt Wette! Previous changes in 2.1.x (changes since the 2.0.x series): @@ -271,6 +156,30 @@ Following Emacs, you must use a C99-capable compiler when building Guile. In the future we also expect require C99 to use Guile's C interface, at least for `stdint' support. +** Lightweight pre-emptive threading primitives + +The compiler now inserts special "handle-interrupts" opcodes before each +call, return, and loop back-edge. This allows the user to interrupt any +computation and to accurately profile code using interrupts. It used to +be that interrupts were run by calling a C function from the VM; now +interrupt thunks are run directly from the VM. This allows interrupts +to save a delimited continuation and, if the continuation was +established from the same VM invocation (the usual restriction), that +continuation can then be resumed. In this way users can implement +lightweight pre-emptive threading facilities. + +** with-dynamic-state in VM + +Similarly, `with-dynamic-state' no longer recurses out of the VM, +allowing captured delimited continuations that include a +`with-dynamic-state' invocation to be resumed. This is a precondition +to allow lightweight threading libraries to establish a dynamic state +per thread. + +** cancel-thread uses asynchronous interrupts, not pthread_cancel + +See "Asyncs" in the manual, for more on asynchronous interrupts. + * Performance improvements ** Faster programs via new virtual machine @@ -347,6 +256,13 @@ is equivalent to an unbuffered port. Ports may set their default buffer sizes, and some ports (for example soft ports) are unbuffered by default for historical reasons. +** Mutexes are now faster under contention + +Guile implements its own mutexes, so that threads that are trying to +acquire a mutex can be interrupted. These mutexes used to be quite +inefficient when many threads were trying to acquire them, causing many +spurious wakeups and contention. This has been fixed. + * New interfaces ** New `cond-expand' feature: `guile-2.2' @@ -567,6 +483,86 @@ ports are both textual and binary, Guile's R6RS ports are also both textual and binary, and thus both kinds have port transcoders. This is an incompatibility with respect to R6RS. +** Threading facilities moved to (ice-9 threads) + +It used to be that call-with-new-thread and other threading primitives +were available in the default environment. This is no longer the case; +they have been moved to (ice-9 threads) instead. Existing code will not +break, however; we used the deprecation facility to signal a warning +message while also providing these bindings in the root environment for +the duration of the 2.2 series. + +** SRFI-18 threads, mutexes, cond vars disjoint from Guile + +When we added support for the SRFI-18 threading library in Guile 2.0, we +did so in a way that made SRFI-18 mutexes the same as Guile mutexes. +This was a mistake. In Guile our goal is to provide basic, +well-thought-out, well-implemented, minimal primitives, on top of which +we can build a variety of opinionated frameworks. Incorporating SRFI-18 +functionality into core Guile caused us to bloat and slow down our core +threading primitives. Worse, they became very hard to describe; they +did many things, did them poorly, and all that they did was never +adequately specified. + +For all of these reasons we have returned to a situation where SRFI-18 +concepts are implemented only in the `(srfi srfi-18)' module. This +means that SRFI-18 threads are built on Guile threads, but aren't the +same as Guile threads; calling Guile `thread?' on a thread no longer +returns true. + +We realize this causes inconvenience to users who use both Guile +threading interfaces and SRFI-18 interfaces, and we lament the change -- +but we are better off now. We hope the newly revised "Scheduling" +section in the manual compensates for the headache. + +** Remove `lock-mutex' "owner" argument + +Mutex owners are a SRFI-18 concept; use SRFI-18 mutexes instead. +Relatedly, `scm_lock_mutex_timed' taking the owner argument is now +deprecated; use `scm_timed_lock_mutex' instead. + +** Remove `unlock-mutex' cond var and timeout arguments + +It used to be that `unlock-mutex' included `wait-condition-variable' +functionality. This has been deprecated; use SRFI-18 if you want this +behavior from `mutex-unlock!'. Relatedly, `scm_unlock_mutex_timed' is +deprecated; use `scm_unlock_mutex' instead. + +** Removed `unchecked-unlock' mutex flag + +This flag was introduced for internal use by SRFI-18; use SRFI-18 +mutexes if you need this behaviour. + +** SRFI-18 mutexes no longer recursive + +Contrary to specification, SRFI-18 mutexes in Guile were recursive. +This is no longer the case. + +** Thread cleanup handlers removed + +The `set-thread-cleanup!' and `thread-cleanup' functions that were added +in Guile 2.0 to support cleanup after thread cancellation are no longer +needed, since threads can declare cleanup handlers via `dynamic-wind'. + +** Only threads created by Guile are joinable + +`join-thread' used to work on "foreign" threads that were not created by +Guile itself, though their join value was always `#f'. This is no +longer the case; attempting to join a foreign thread will throw an +error. + +** Dynamic states capture values, not locations + +Dynamic states used to capture the locations of fluid-value +associations. Capturing the current dynamic state then setting a fluid +would result in a mutation of that captured state. Now capturing a +dynamic state simply captures the current values, and calling +`with-dynamic-state' copies those values into the Guile virtual machine +instead of aliasing them in a way that could allow them to be mutated in +place. This change allows Guile's fluid variables to be thread-safe. +To capture the locations of a dynamic state, capture a +`with-dynamic-state' invocation using partial continuations instead. + ** Remove `frame-procedure' Several optimizations in Guile make `frame-procedure' an interface that @@ -811,9 +807,44 @@ as arguments to the `setvbuf' function. ** Arbiters -Use mutexes or atomic variables instead. +Arbiters were an experimental mutual exclusion facility from 20 years +ago that didn't survive the test of time. Use mutexes or atomic boxes +instead. -** `with-statprof' macro deprecated +** User asyncs + +Guile had (and still has) "system asyncs", which are asynchronous +interrupts, and also had this thing called "user asyncs", which was a +trivial unused data structure. Now that we have deprecated the old +`async', `async-mark', and `run-asyncs' procedures that comprised the +"user async" facility, we have been able to clarify our documentation to +only refer to "asyncs". + +** Critical sections + +Critical sections have long been just a fancy way to lock a mutex and +defer asynchronous interrupts. Instead of SCM_CRITICAL_SECTION_START, +make sure you're in a "scm_dynwind_begin (0)" and use +scm_dynwind_pthread_mutex_lock instead, possibly also with +scm_dynwind_block_asyncs. + +** `scm_make_mutex_with_flags' + +Use `scm_make_mutex_with_kind' instead. See "Mutexes and Condition +Variables" in the manual, for more. + +** Dynamic roots + +This was a facility that predated threads, was unused as far as we can +tell, and was never documented. Still, a grep of your code for +dynamic-root or dynamic_root would not be amiss. + +** `make-dynamic-state' + +Use `current-dynamic-state' to get an immutable copy of the current +fluid-value associations. + +** `with-statprof' macro Use the `statprof' procedure instead. From 81e9a128c146ccd495846ecbf664b3fd2855baf1 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 19 Jan 2017 01:27:18 +0100 Subject: [PATCH 674/865] Guile 2.1.6. * GUILE-VERSION (GUILE_MICRO_VERSION): Bump to 2.1.6. --- GUILE-VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index 056cbdecd..b46ba2887 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -3,7 +3,7 @@ # Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'. GUILE_MAJOR_VERSION=2 GUILE_MINOR_VERSION=1 -GUILE_MICRO_VERSION=5 +GUILE_MICRO_VERSION=6 GUILE_EFFECTIVE_VERSION=2.2 From 498f3f95684361f3591106a8f9cb9065fd649288 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 7 Feb 2017 09:28:39 +0100 Subject: [PATCH 675/865] Avoid stacks in dynamically-bound values * libguile/dynstack.h: * libguile/dynstack.c (scm_dynstack_find_old_fluid_value): New function. * libguile/fluids.c (saved_dynamic_state_ref): New helper. (scm_fluid_ref): Fix docstring. (scm_fluid_ref_star): New function allowing access to previous values for a fluid. (scm_dynamic_state_ref): New internal function. * libguile/fluids.h: Add scm_fluid_ref_star and scm_dynamic_state_ref. * libguile/stacks.c (scm_stack_id): Adapt to %stacks not being a chain. * libguile/throw.c (catch, throw_without_pre_unwind): Adapt to %exception-handlers not being a chain. * module/ice-9/boot-9.scm (catch, dispatch-exception): Instead of having %exception-handlers be a chain, use fluid-ref* to access the chain that is in place at the time the exception is thrown. Prevents unintended undelimited capture of the current exception handler stack by a delimited "catch". (%start-stack): Similarly, don't be a chain. * module/system/repl/debug.scm (frame->stack-vector): * module/system/repl/error-handling.scm (call-with-error-handling): * module/ice-9/save-stack.scm (save-stack): Adapt to %stacks not being a chain. * test-suite/tests/exceptions.test ("delimited exception handlers"): Add tests. * doc/ref/api-control.texi (Fluids and Dynamic States): Add docs. --- doc/ref/api-control.texi | 15 +++++ libguile/dynstack.c | 49 ++++++++++++++ libguile/dynstack.h | 3 + libguile/fluids.c | 47 ++++++++++++- libguile/fluids.h | 2 + libguile/stacks.c | 2 +- libguile/throw.c | 28 ++++---- module/ice-9/boot-9.scm | 96 +++++++++++++++------------ module/ice-9/save-stack.scm | 2 +- module/system/repl/debug.scm | 4 +- module/system/repl/error-handling.scm | 6 +- test-suite/tests/exceptions.test | 30 ++++++++- 12 files changed, 219 insertions(+), 65 deletions(-) diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index 73fbe3607..77d98b44e 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.texi @@ -1765,6 +1765,21 @@ a runtime error. Set the value associated with @var{fluid} in the current dynamic root. @end deffn +@deffn {Scheme Procedure} fluid-ref* fluid depth +@deffnx {C Function} scm_fluid_ref_star (fluid, depth) +Return the @var{depth}th oldest value associated with @var{fluid} in the +current thread. If @var{depth} equals or exceeds the number of values +that have been assigned to @var{fluid}, return the default value of the +fluid. @code{(fluid-ref* f 0)} is equivalent to @code{(fluid-ref f)}. + +@code{fluid-ref*} is useful when you want to maintain a stack-like +structure in a fluid, such as the stack of current exception handlers. +Using @code{fluid-ref*} instead of an explicit stack allows any partial +continuation captured by @code{call-with-prompt} to only capture the +bindings made within the limits of the prompt instead of the entire +continuation. @xref{Prompts}, for more on delimited continuations. +@end deffn + @deffn {Scheme Procedure} fluid-unset! fluid @deffnx {C Function} scm_fluid_unset_x (fluid) Disassociate the given fluid from any value, making it unbound. diff --git a/libguile/dynstack.c b/libguile/dynstack.c index ff57c430d..652d2b35a 100644 --- a/libguile/dynstack.c +++ b/libguile/dynstack.c @@ -504,6 +504,55 @@ scm_dynstack_find_prompt (scm_t_dynstack *dynstack, SCM key, return NULL; } +SCM +scm_dynstack_find_old_fluid_value (scm_t_dynstack *dynstack, SCM fluid, + size_t depth, SCM dflt) +{ + scm_t_bits *walk; + + for (walk = SCM_DYNSTACK_PREV (dynstack->top); walk; + walk = SCM_DYNSTACK_PREV (walk)) + { + scm_t_bits tag = SCM_DYNSTACK_TAG (walk); + + switch (SCM_DYNSTACK_TAG_TYPE (tag)) + { + case SCM_DYNSTACK_TYPE_WITH_FLUID: + { + if (scm_is_eq (WITH_FLUID_FLUID (walk), fluid)) + { + if (depth == 0) + return SCM_VARIABLE_REF (WITH_FLUID_VALUE_BOX (walk)); + else + depth--; + } + break; + } + case SCM_DYNSTACK_TYPE_DYNAMIC_STATE: + { + SCM state, val; + + /* The previous dynamic state may or may not have + established a binding for this fluid. */ + state = scm_variable_ref (DYNAMIC_STATE_STATE_BOX (walk)); + val = scm_dynamic_state_ref (state, fluid, SCM_UNDEFINED); + if (!SCM_UNBNDP (val)) + { + if (depth == 0) + return val; + else + depth--; + } + break; + } + default: + break; + } + } + + return dflt; +} + void scm_dynstack_wind_prompt (scm_t_dynstack *dynstack, scm_t_bits *item, scm_t_ptrdiff reloc, scm_i_jmp_buf *registers) diff --git a/libguile/dynstack.h b/libguile/dynstack.h index 9d91fb667..7e191fc27 100644 --- a/libguile/dynstack.h +++ b/libguile/dynstack.h @@ -201,6 +201,9 @@ SCM_INTERNAL scm_t_bits* scm_dynstack_find_prompt (scm_t_dynstack *, SCM, scm_t_uint32 **, scm_i_jmp_buf **); +SCM_INTERNAL SCM scm_dynstack_find_old_fluid_value (scm_t_dynstack *, + SCM, size_t, SCM); + SCM_INTERNAL void scm_dynstack_wind_prompt (scm_t_dynstack *, scm_t_bits *, scm_t_ptrdiff, scm_i_jmp_buf *); diff --git a/libguile/fluids.c b/libguile/fluids.c index 72c75952d..7daad7781 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -147,6 +147,16 @@ save_dynamic_state (scm_t_dynamic_state *state) return saved; } +static SCM +saved_dynamic_state_ref (SCM saved, SCM fluid, SCM dflt) +{ + for (; scm_is_pair (saved); saved = SCM_CDR (saved)) + if (scm_is_eq (SCM_CAAR (saved), fluid)) + return SCM_CDAR (saved); + + return scm_weak_table_refq (saved, fluid, dflt); +} + static SCM add_entry (void *data, SCM k, SCM v, SCM result) { @@ -300,7 +310,7 @@ SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0, (SCM fluid), "Return the value associated with @var{fluid} in the current\n" "dynamic root. If @var{fluid} has not been set, then return\n" - "@code{#f}.") + "its default value.") #define FUNC_NAME s_scm_fluid_ref { SCM ret; @@ -312,6 +322,33 @@ SCM_DEFINE (scm_fluid_ref, "fluid-ref", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_fluid_ref_star, "fluid-ref*", 2, 0, 0, + (SCM fluid, SCM depth), + "Return the @var{depth}th oldest value associated with\n" + "@var{fluid} in the current thread. If @var{depth} equals\n" + "or exceeds the number of values that have been assigned to\n" + "@var{fluid}, return the default value of the fluid.") +#define FUNC_NAME s_scm_fluid_ref_star +{ + SCM ret; + size_t c_depth; + + SCM_VALIDATE_FLUID (1, fluid); + c_depth = SCM_NUM2SIZE (2, depth); + + if (c_depth == 0) + ret = fluid_ref (SCM_I_CURRENT_THREAD->dynamic_state, fluid); + else + ret = scm_dynstack_find_old_fluid_value (&SCM_I_CURRENT_THREAD->dynstack, + fluid, c_depth - 1, + SCM_I_FLUID_DEFAULT (fluid)); + + if (SCM_UNBNDP (ret)) + scm_misc_error ("fluid-ref*", "unbound fluid: ~S", scm_list_1 (fluid)); + return ret; +} +#undef FUNC_NAME + SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0, (SCM fluid, SCM value), "Set the value associated with @var{fluid} in the current dynamic root.") @@ -499,6 +536,14 @@ SCM_DEFINE (scm_set_current_dynamic_state, "set-current-dynamic-state", 1,0,0, } #undef FUNC_NAME +SCM +scm_dynamic_state_ref (SCM state, SCM fluid, SCM dflt) +{ + SCM_ASSERT (is_dynamic_state (state), state, SCM_ARG1, + "dynamic-state-ref"); + return saved_dynamic_state_ref (get_dynamic_state (state), fluid, dflt); +} + static void swap_dynamic_state (SCM loc) { diff --git a/libguile/fluids.h b/libguile/fluids.h index 8031c0d48..6d7969e15 100644 --- a/libguile/fluids.h +++ b/libguile/fluids.h @@ -56,6 +56,7 @@ SCM_API SCM scm_make_unbound_fluid (void); SCM_API int scm_is_fluid (SCM obj); SCM_API SCM scm_fluid_p (SCM fl); SCM_API SCM scm_fluid_ref (SCM fluid); +SCM_API SCM scm_fluid_ref_star (SCM fluid, SCM depth); SCM_API SCM scm_fluid_set_x (SCM fluid, SCM value); SCM_API SCM scm_fluid_unset_x (SCM fluid); SCM_API SCM scm_fluid_bound_p (SCM fluid); @@ -80,6 +81,7 @@ SCM_API void scm_dynwind_current_dynamic_state (SCM state); SCM_API void *scm_c_with_dynamic_state (SCM state, void *(*func)(void *), void *data); SCM_API SCM scm_with_dynamic_state (SCM state, SCM proc); +SCM_INTERNAL SCM scm_dynamic_state_ref (SCM state, SCM fluid, SCM dflt); SCM_INTERNAL SCM scm_i_make_initial_dynamic_state (void); diff --git a/libguile/stacks.c b/libguile/stacks.c index 3d02d81f6..99ee233e3 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -414,7 +414,7 @@ SCM_DEFINE (scm_stack_id, "stack-id", 1, 0, 0, { /* Fetch most recent start-stack tag. */ SCM stacks = scm_fluid_ref (scm_sys_stacks); - return scm_is_pair (stacks) ? scm_caar (stacks) : SCM_BOOL_F; + return scm_is_pair (stacks) ? scm_car (stacks) : SCM_BOOL_F; } else if (SCM_CONTINUATIONP (stack)) /* FIXME: implement me */ diff --git a/libguile/throw.c b/libguile/throw.c index c3a46161b..5f6dcfa90 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -96,11 +96,10 @@ catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler) prompt_tag = scm_cons (SCM_INUM0, SCM_EOL); - eh = scm_c_make_vector (4, SCM_BOOL_F); - scm_c_vector_set_x (eh, 0, scm_fluid_ref (exception_handler_fluid)); - scm_c_vector_set_x (eh, 1, tag); - scm_c_vector_set_x (eh, 2, prompt_tag); - scm_c_vector_set_x (eh, 3, pre_unwind_handler); + eh = scm_c_make_vector (3, SCM_BOOL_F); + scm_c_vector_set_x (eh, 0, tag); + scm_c_vector_set_x (eh, 1, prompt_tag); + scm_c_vector_set_x (eh, 2, pre_unwind_handler); vp = scm_the_vm (); prev_cookie = vp->resumable_prompt_cookie; @@ -201,23 +200,26 @@ abort_to_prompt (SCM prompt_tag, SCM tag, SCM args) static SCM throw_without_pre_unwind (SCM tag, SCM args) { - SCM eh; + size_t depth = 0; /* This function is not only the boot implementation of "throw", it is also called in response to resource allocation failures such as stack-overflow or out-of-memory. For that reason we need to be careful to avoid allocating memory. */ - for (eh = scm_fluid_ref (exception_handler_fluid); - scm_is_true (eh); - eh = scm_c_vector_ref (eh, 0)) + while (1) { - SCM catch_key, prompt_tag; + SCM eh, catch_key, prompt_tag; - catch_key = scm_c_vector_ref (eh, 1); + eh = scm_fluid_ref_star (exception_handler_fluid, + scm_from_size_t (depth++)); + if (scm_is_false (eh)) + break; + + catch_key = scm_c_vector_ref (eh, 0); if (!scm_is_eq (catch_key, SCM_BOOL_T) && !scm_is_eq (catch_key, tag)) continue; - if (scm_is_true (scm_c_vector_ref (eh, 3))) + if (scm_is_true (scm_c_vector_ref (eh, 2))) { const char *key_chars; @@ -230,7 +232,7 @@ throw_without_pre_unwind (SCM tag, SCM args) "skipping pre-unwind handler.\n", key_chars); } - prompt_tag = scm_c_vector_ref (eh, 2); + prompt_tag = scm_c_vector_ref (eh, 1); if (scm_is_true (prompt_tag)) abort_to_prompt (prompt_tag, tag, args); } diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 802ca7735..229d91734 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -720,48 +720,59 @@ information is unavailable." (define with-throw-handler #f) (let ((%eh (module-ref (current-module) '%exception-handler))) (define (make-exception-handler catch-key prompt-tag pre-unwind) - (vector (fluid-ref %eh) catch-key prompt-tag pre-unwind)) - (define (exception-handler-prev handler) (vector-ref handler 0)) - (define (exception-handler-catch-key handler) (vector-ref handler 1)) - (define (exception-handler-prompt-tag handler) (vector-ref handler 2)) - (define (exception-handler-pre-unwind handler) (vector-ref handler 3)) + (vector catch-key prompt-tag pre-unwind)) + (define (exception-handler-catch-key handler) (vector-ref handler 0)) + (define (exception-handler-prompt-tag handler) (vector-ref handler 1)) + (define (exception-handler-pre-unwind handler) (vector-ref handler 2)) - (define %running-pre-unwind (make-fluid '())) + (define %running-pre-unwind (make-fluid #f)) + (define (pre-unwind-handler-running? handler) + (let lp ((depth 0)) + (let ((running (fluid-ref* %running-pre-unwind depth))) + (and running + (or (eq? running handler) (lp (1+ depth))))))) - (define (dispatch-exception handler key args) - (unless handler - (when (eq? key 'quit) - (primitive-exit (cond - ((not (pair? args)) 0) - ((integer? (car args)) (car args)) - ((not (car args)) 1) - (else 0)))) - (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" key args) - (primitive-exit 1)) - - (let ((catch-key (exception-handler-catch-key handler)) - (prev (exception-handler-prev handler))) - (if (or (eqv? catch-key #t) (eq? catch-key key)) - (let ((prompt-tag (exception-handler-prompt-tag handler)) - (pre-unwind (exception-handler-pre-unwind handler))) - (if pre-unwind - ;; Instead of using a "running" set, it would be a lot - ;; cleaner semantically to roll back the exception - ;; handler binding to the one that was in place when the - ;; pre-unwind handler was installed, and keep it like - ;; that for the rest of the dispatch. Unfortunately - ;; that is incompatible with existing semantics. We'll - ;; see if we can change that later on. - (let ((running (fluid-ref %running-pre-unwind))) - (with-fluid* %running-pre-unwind (cons handler running) - (lambda () - (unless (memq handler running) - (apply pre-unwind key args)) - (if prompt-tag - (apply abort-to-prompt prompt-tag key args) - (dispatch-exception prev key args))))) - (apply abort-to-prompt prompt-tag key args))) - (dispatch-exception prev key args)))) + (define (dispatch-exception depth key args) + (cond + ((fluid-ref* %eh depth) + => (lambda (handler) + (let ((catch-key (exception-handler-catch-key handler))) + (if (or (eqv? catch-key #t) (eq? catch-key key)) + (let ((prompt-tag (exception-handler-prompt-tag handler)) + (pre-unwind (exception-handler-pre-unwind handler))) + (cond + ((and pre-unwind + (not (pre-unwind-handler-running? handler))) + ;; Prevent errors from within the pre-unwind + ;; handler's invocation from being handled by this + ;; handler. + (with-fluid* %running-pre-unwind handler + (lambda () + ;; FIXME: Currently the "running" flag only + ;; applies to the pre-unwind handler; the + ;; post-unwind handler is still called if the + ;; error is explicitly rethrown. Instead it + ;; would be better to cause a recursive throw to + ;; skip all parts of this handler. Unfortunately + ;; that is incompatible with existing semantics. + ;; We'll see if we can change that later on. + (apply pre-unwind key args) + (dispatch-exception depth key args)))) + (prompt-tag + (apply abort-to-prompt prompt-tag key args)) + (else + (dispatch-exception (1+ depth) key args)))) + (dispatch-exception (1+ depth) key args))))) + ((eq? key 'quit) + (primitive-exit (cond + ((not (pair? args)) 0) + ((integer? (car args)) (car args)) + ((not (car args)) 1) + (else 0)))) + (else + (format (current-error-port) "guile: uncaught throw to ~a: ~a\n" + key args) + (primitive-exit 1)))) (define (throw key . args) "Invoke the catch form matching @var{key}, passing @var{args} to the @@ -773,7 +784,7 @@ If there is no handler at all, Guile prints an error and then exits." (unless (symbol? key) (throw 'wrong-type-arg "throw" "Wrong type argument in position ~a: ~a" (list 1 key) (list key))) - (dispatch-exception (fluid-ref %eh) key args)) + (dispatch-exception 0 key args)) (define* (catch k thunk handler #:optional pre-unwind-handler) "Invoke @var{thunk} in the dynamic context of @var{handler} for @@ -1681,8 +1692,7 @@ written into the port is returned." (call-with-prompt prompt-tag (lambda () - (with-fluids ((%stacks (acons tag prompt-tag - (or (fluid-ref %stacks) '())))) + (with-fluids ((%stacks (cons tag prompt-tag))) (thunk))) (lambda (k . args) (%start-stack tag (lambda () (apply k args))))))) diff --git a/module/ice-9/save-stack.scm b/module/ice-9/save-stack.scm index 8ba006788..5abd1d82a 100644 --- a/module/ice-9/save-stack.scm +++ b/module/ice-9/save-stack.scm @@ -53,6 +53,6 @@ ;; if any. (apply make-stack #t 2 - (if (pair? stacks) (cdar stacks) 0) + (if (pair? stacks) (cdr stacks) 0) narrowing))) (set! stack-saved? #t)))) diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm index 55062d783..383d37921 100644 --- a/module/system/repl/debug.scm +++ b/module/system/repl/debug.scm @@ -184,7 +184,7 @@ (define (frame->stack-vector frame) (let ((stack (make-stack frame))) (match (fluid-ref %stacks) - (((stack-tag . prompt-tag) . _) + ((stack-tag . prompt-tag) (narrow-stack->vector stack ;; Take the stack from the given frame, cutting 0 frames. @@ -206,5 +206,5 @@ ;; 2 ;; ;; Narrow the end of the stack to the most recent start-stack. ;; (and (pair? (fluid-ref %stacks)) -;; (cdar (fluid-ref %stacks)))))) +;; (cdr (fluid-ref %stacks)))))) diff --git a/module/system/repl/error-handling.scm b/module/system/repl/error-handling.scm index 94a9f2a66..8d5a8a5f0 100644 --- a/module/system/repl/error-handling.scm +++ b/module/system/repl/error-handling.scm @@ -57,7 +57,7 @@ (define (debug-trap-handler frame trap-idx trap-name) (let* ((tag (and (pair? (fluid-ref %stacks)) - (cdar (fluid-ref %stacks)))) + (cdr (fluid-ref %stacks)))) (stack (narrow-stack->vector (make-stack frame) ;; Take the stack from the given frame, cutting 0 @@ -132,7 +132,7 @@ (lambda (key . args) (if (not (memq key pass-keys)) (let* ((tag (and (pair? (fluid-ref %stacks)) - (cdar (fluid-ref %stacks)))) + (cdr (fluid-ref %stacks)))) (stack (narrow-stack->vector (make-stack #t) ;; Cut three frames from the top of the stack: @@ -161,7 +161,7 @@ (lambda (key . args) (if (not (memq key pass-keys)) (let* ((tag (and (pair? (fluid-ref %stacks)) - (cdar (fluid-ref %stacks)))) + (cdr (fluid-ref %stacks)))) (frames (narrow-stack->vector (make-stack #t) ;; Narrow as above, for the debugging case. diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test index a839b68de..391a19dca 100644 --- a/test-suite/tests/exceptions.test +++ b/test-suite/tests/exceptions.test @@ -16,7 +16,8 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -(use-modules (test-suite lib)) +(define-module (test-suite exceptions) + #:use-module (test-suite lib)) (define-syntax-parameter push (lambda (stx) @@ -365,3 +366,30 @@ ;; (not (eval `(,false-if-exception (,error "xxx")) ;; empty-environment)))) ) + +(with-test-prefix "delimited exception handlers" + (define (catch* key thunk) + (let ((tag (make-prompt-tag))) + (call-with-prompt tag + (lambda () + (catch key + (lambda () + (abort-to-prompt tag) + (thunk)) + (lambda args args))) + (lambda (k) k)))) + (pass-if-equal '(foo) + (let ((thunk (catch* 'foo (lambda () (throw 'foo))))) + (thunk))) + (pass-if-equal '(foo) + (let* ((thunk1 (catch* 'foo (lambda () (throw 'foo)))) + (thunk2 (catch* 'bar (lambda () (thunk1))))) + (thunk1))) + (pass-if-equal '(foo) + (let* ((thunk1 (catch* 'foo (lambda () (throw 'foo)))) + (thunk2 (catch* 'bar (lambda () (thunk1))))) + (thunk2))) + (pass-if-equal '(bar) + (let* ((thunk1 (catch* 'foo (lambda () (throw 'bar)))) + (thunk2 (catch* 'bar (lambda () (thunk1))))) + (thunk2)))) From a0028723da283d39e5ab4e43f8934506a917498b Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Tue, 7 Feb 2017 12:14:15 +0100 Subject: [PATCH 676/865] Fix bug #25492 * libguile/vm-engine.c (BR_F64_ARITHMETIC): Fix type. --- libguile/vm-engine.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 684840617..c9a9cecd1 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -361,7 +361,7 @@ #define BR_F64_ARITHMETIC(crel) \ { \ scm_t_uint32 a, b; \ - scm_t_uint64 x, y; \ + double x, y; \ UNPACK_24 (op, a); \ UNPACK_24 (ip[1], b); \ x = SP_REF_F64 (a); \ From ee2125c63973e5ebef2a04eb60d85e6a2b3ea412 Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Fri, 3 Feb 2017 12:16:42 +0100 Subject: [PATCH 677/865] Support arrays in truncated-print * module/ice-9/pretty-print.scm (print): Handle general arrays. * test-suite/tests/print.test: Test truncated-print with general arrays. --- module/ice-9/pretty-print.scm | 21 +++++++++++++++++++-- test-suite/tests/print.test | 17 ++++++++++++++++- 2 files changed, 35 insertions(+), 3 deletions(-) diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm index 007061f6e..22bbb8a94 100644 --- a/module/ice-9/pretty-print.scm +++ b/module/ice-9/pretty-print.scm @@ -397,7 +397,7 @@ sub-expression, via the @var{breadth-first?} keyword argument." (else (lp (cdr fixes)))))) - (define (print x width) + (define* (print x width #:key top?) (cond ((<= width 0) (error "expected a positive width" width)) @@ -428,6 +428,23 @@ sub-expression, via the @var{breadth-first?} keyword argument." (display ")")) (else (display "#")))) + ((and (array? x) (not (string? x))) + (let* ((prefix (if top? + (let ((s (format #f "~a" + (apply make-typed-array (array-type x) + *unspecified* + (make-list (array-rank x) 0))))) + (substring s 0 (- (string-length s) 2))) + "")) + (width-prefix (string-length prefix))) + (cond + ((>= width (+ 2 width-prefix ellipsis-width)) + (format #t "~a(" prefix) + (print-sequence x (- width width-prefix 2) (array-length x) + array-cell-ref identity) + (display ")")) + (else + (display "#"))))) ((pair? x) (cond ((>= width (+ 4 ellipsis-width)) @@ -446,4 +463,4 @@ sub-expression, via the @var{breadth-first?} keyword argument." (with-output-to-port port (lambda () - (print x width))))) + (print x width #:top? #t))))) diff --git a/test-suite/tests/print.test b/test-suite/tests/print.test index 6ef0e9fc7..836fa2271 100644 --- a/test-suite/tests/print.test +++ b/test-suite/tests/print.test @@ -145,4 +145,19 @@ (tprint (current-module) 20 "ISO-8859-1")) (pass-if-equal "#" - (tprint (current-module) 20 "UTF-8"))) + (tprint (current-module) 20 "UTF-8")) + + (pass-if-equal "#" + (tprint (make-typed-array 's32 0 20 20) 7 "UTF-8")) + + (pass-if-equal "#2s32(…)" + (tprint (make-typed-array 's32 0 20 20) 8 "UTF-8")) + + (pass-if-equal "#2s32(# …)" + (tprint (make-typed-array 's32 0 20 20) 10 "UTF-8")) + + (pass-if-equal "#2s32((…) …)" + (tprint (make-typed-array 's32 0 20 20) 12 "UTF-8")) + + (pass-if-equal "#2s32((0 …) …)" + (tprint (make-typed-array 's32 0 20 20) 14 "UTF-8"))) From 93cbaef1345d1ba09c584bbeac6acd4580b23d73 Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Tue, 7 Feb 2017 15:49:11 +0100 Subject: [PATCH 678/865] Fix rank 0 arrays and nested arrays in truncated-print * module/ice-9/pretty-print.scm (print): In the array case, pass #:inner? along to (print-sequence), unless we're at the last dimension of the array. Special case for 0-rank arrays, which cannot be empty and have no length. * test-suite/tests/print.test: Test some of the cases fixed by this patch. --- module/ice-9/pretty-print.scm | 35 +++++++++++++++++++++-------------- test-suite/tests/print.test | 29 ++++++++++++++++++++++++++++- 2 files changed, 49 insertions(+), 15 deletions(-) diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm index 22bbb8a94..d3d765202 100644 --- a/module/ice-9/pretty-print.scm +++ b/module/ice-9/pretty-print.scm @@ -328,7 +328,7 @@ sub-expression, via the @var{breadth-first?} keyword argument." (let ((ellipsis-width (string-length ellipsis))) - (define (print-sequence x width len ref next) + (define* (print-sequence x width len ref next #:key inner?) (let lp ((x x) (width width) (i 0)) @@ -337,7 +337,7 @@ sub-expression, via the @var{breadth-first?} keyword argument." (cond ((= i len)) ; catches 0-length case ((and (= i (1- len)) (or (zero? i) (> width 1))) - (print (ref x i) (if (zero? i) width (1- width)))) + (print (ref x i) (if (zero? i) width (1- width)) #:inner? inner?)) ((<= width (+ 1 ellipsis-width)) (display ellipsis)) (else @@ -347,7 +347,8 @@ sub-expression, via the @var{breadth-first?} keyword argument." (if breadth-first? (max 1 (1- (floor (/ width (- len i))))) - (- width (+ 1 ellipsis-width)))))))) + (- width (+ 1 ellipsis-width))) + #:inner? inner?))))) (display str) (lp (next x) (- width 1 (string-length str)) (1+ i))))))) @@ -397,7 +398,7 @@ sub-expression, via the @var{breadth-first?} keyword argument." (else (lp (cdr fixes)))))) - (define* (print x width #:key top?) + (define* (print x width #:key inner?) (cond ((<= width 0) (error "expected a positive width" width)) @@ -429,19 +430,25 @@ sub-expression, via the @var{breadth-first?} keyword argument." (else (display "#")))) ((and (array? x) (not (string? x))) - (let* ((prefix (if top? - (let ((s (format #f "~a" - (apply make-typed-array (array-type x) - *unspecified* - (make-list (array-rank x) 0))))) - (substring s 0 (- (string-length s) 2))) - "")) + (let* ((type (array-type x)) + (prefix + (if inner? + "" + (if (zero? (array-rank x)) + (string-append "#0" (if (eq? #t type) "" (symbol->string type))) + (let ((s (format #f "~a" + (apply make-typed-array type *unspecified* + (make-list (array-rank x) 0))))) + (substring s 0 (- (string-length s) 2)))))) (width-prefix (string-length prefix))) (cond ((>= width (+ 2 width-prefix ellipsis-width)) (format #t "~a(" prefix) - (print-sequence x (- width width-prefix 2) (array-length x) - array-cell-ref identity) + (if (zero? (array-rank x)) + (print (array-ref x) (- width width-prefix 2)) + (print-sequence x (- width width-prefix 2) (array-length x) + array-cell-ref identity + #:inner? (< 1 (array-rank x)))) (display ")")) (else (display "#"))))) @@ -463,4 +470,4 @@ sub-expression, via the @var{breadth-first?} keyword argument." (with-output-to-port port (lambda () - (print x width #:top? #t))))) + (print x width))))) diff --git a/test-suite/tests/print.test b/test-suite/tests/print.test index 836fa2271..82cc77603 100644 --- a/test-suite/tests/print.test +++ b/test-suite/tests/print.test @@ -147,6 +147,18 @@ (pass-if-equal "#" (tprint (current-module) 20 "UTF-8")) + (pass-if-equal "#0(#)" + (tprint (make-typed-array #t 9.0) 6 "UTF-8")) + + (pass-if-equal "#0(9.0)" + (tprint (make-typed-array #t 9.0) 7 "UTF-8")) + + (pass-if-equal "#0f64(#)" + (tprint (make-typed-array 'f64 9.0) 8 "UTF-8")) + + (pass-if-equal "#0f64(9.0)" + (tprint (make-typed-array 'f64 9.0) 10 "UTF-8")) + (pass-if-equal "#" (tprint (make-typed-array 's32 0 20 20) 7 "UTF-8")) @@ -160,4 +172,19 @@ (tprint (make-typed-array 's32 0 20 20) 12 "UTF-8")) (pass-if-equal "#2s32((0 …) …)" - (tprint (make-typed-array 's32 0 20 20) 14 "UTF-8"))) + (tprint (make-typed-array 's32 0 20 20) 14 "UTF-8")) + + (pass-if-equal "#2((#(9 9) #(9 9)) (#(9 9) #(9 9)))" + (tprint (make-typed-array #t (make-typed-array #t 9 2) 2 2) 40 "UTF-8")) + + (pass-if-equal "#(#2((9 9) (9 9)) #2((9 9) (9 9)))" + (tprint (make-vector 2 (make-typed-array #t 9 2 2)) 40 "UTF-8")) + + (pass-if-equal "(#2((9 9) (9 9)) #2((9 9) (9 9)))" + (tprint (make-list 2 (make-typed-array #t 9 2 2)) 40 "UTF-8")) + + (pass-if-equal "(#0(9) #0(9))" + (tprint (make-list 2 (make-typed-array #t 9)) 20 "UTF-8")) + + (pass-if-equal "(#0(9) #)" + (tprint (make-list 2 (make-typed-array #t 9)) 10 "UTF-8"))) From 8c50060ae94c60ec5b0f6d506bb5a8205a18d4bb Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 8 Feb 2017 08:01:55 +0100 Subject: [PATCH 679/865] Modernize (web http) a bit * module/web/http.scm: Modernize the Guile Scheme by using more match, when, unless, and non-tail conversion. No functional change, with the exception of fixing a bug in write-key-value-list for symbols like 100-continue that shouldn't print as #{100-continue}#. * test-suite/tests/web-http.test (pass-if-only-parse): (pass-if-reparse, pass-if-parse): Arrange to also serialize and reparse values from pass-if-parse. Apply to all existing tests except fragments where we don't expect fragments to be written out. --- module/web/http.scm | 707 +++++++++++++++++---------------- test-suite/tests/web-http.test | 27 +- 2 files changed, 377 insertions(+), 357 deletions(-) diff --git a/module/web/http.scm b/module/web/http.scm index c9fb195d7..57c209599 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -98,11 +98,11 @@ writer #:key multiple?) "Declare a parser, validator, and writer for a given header." - (if (and (string? name) parser validator writer) - (let ((decl (make-header-decl name parser validator writer multiple?))) - (hashq-set! *declared-headers* (string->header name) decl) - decl) - (error "bad header decl" name parser validator writer multiple?))) + (unless (and (string? name) parser validator writer) + (error "bad header decl" name parser validator writer multiple?)) + (let ((decl (make-header-decl name parser validator writer multiple?))) + (hashq-set! *declared-headers* (string->header name) decl) + decl)) (define (header->string sym) "Return the string form for the header named SYM." @@ -160,12 +160,11 @@ or if EOF is reached." (bad-header 'read-header-line line)))) (define (read-continuation-line port val) - (if (or (eqv? (peek-char port) #\space) - (eqv? (peek-char port) #\tab)) - (read-continuation-line port - (string-append val - (read-header-line port))) - val)) + (match (peek-char port) + ((or #\space #\tab) + (read-continuation-line port + (string-append val (read-header-line port)))) + (_ val))) (define *eof* (call-with-input-string "" read)) @@ -199,9 +198,9 @@ named SYM. Returns the parsed value." (define (valid-header? sym val) "Returns a true value iff VAL is a valid Scheme value for the header with name SYM." - (if (symbol? sym) - ((header-validator sym) val) - (error "header name not a symbol" sym))) + (unless (symbol? sym) + (error "header name not a symbol" sym)) + ((header-validator sym) val)) (define (write-header sym val port) "Write the given header name and value to PORT, using the writer @@ -225,10 +224,12 @@ as an ordered alist." "Write the given header alist to PORT. Doesn't write the final ‘\\r\\n’, as the user might want to add another header." (let lp ((headers headers)) - (if (pair? headers) - (begin - (write-header (caar headers) (cdar headers) port) - (lp (cdr headers)))))) + (match headers + (((k . v) . headers) + (write-header k v port) + (lp headers)) + (() + (values))))) @@ -271,9 +272,9 @@ as an ordered alist." (and idx (= idx (string-rindex str #\/)) (not (string-index str separators-without-slash))))) (define (parse-media-type str) - (if (validate-media-type str) - (string->symbol str) - (bad-header-component 'media-type str))) + (unless (validate-media-type str) + (bad-header-component 'media-type str)) + (string->symbol str)) (define* (skip-whitespace str #:optional (start 0) (end (string-length str))) (let lp ((i start)) @@ -317,47 +318,50 @@ as an ordered alist." (define (collect-escaped-string from start len escapes) (let ((to (make-string len))) (let lp ((start start) (i 0) (escapes escapes)) - (if (null? escapes) - (begin - (substring-move! from start (+ start (- len i)) to i) - to) - (let* ((e (car escapes)) - (next-start (+ start (- e i) 2))) - (substring-move! from start (- next-start 2) to i) - (string-set! to e (string-ref from (- next-start 1))) - (lp next-start (1+ e) (cdr escapes))))))) + (match escapes + (() + (substring-move! from start (+ start (- len i)) to i) + to) + ((e . escapes) + (let ((next-start (+ start (- e i) 2))) + (substring-move! from start (- next-start 2) to i) + (string-set! to e (string-ref from (- next-start 1))) + (lp next-start (1+ e) escapes))))))) ;; in incremental mode, returns two values: the string, and the index at ;; which the string ended (define* (parse-qstring str #:optional (start 0) (end (trim-whitespace str start)) #:key incremental?) - (if (and (< start end) (eqv? (string-ref str start) #\")) - (let lp ((i (1+ start)) (qi 0) (escapes '())) - (if (< i end) - (case (string-ref str i) - ((#\\) - (lp (+ i 2) (1+ qi) (cons qi escapes))) - ((#\") - (let ((out (collect-escaped-string str (1+ start) qi escapes))) - (if incremental? - (values out (1+ i)) - (if (= (1+ i) end) - out - (bad-header-component 'qstring str))))) - (else - (lp (1+ i) (1+ qi) escapes))) - (bad-header-component 'qstring str))) - (bad-header-component 'qstring str))) + (unless (and (< start end) (eqv? (string-ref str start) #\")) + (bad-header-component 'qstring str)) + (let lp ((i (1+ start)) (qi 0) (escapes '())) + (if (< i end) + (case (string-ref str i) + ((#\\) + (lp (+ i 2) (1+ qi) (cons qi escapes))) + ((#\") + (let ((out (collect-escaped-string str (1+ start) qi escapes))) + (cond + (incremental? (values out (1+ i))) + ((= (1+ i) end) out) + (else (bad-header-component 'qstring str))))) + (else + (lp (1+ i) (1+ qi) escapes))) + (bad-header-component 'qstring str)))) -(define (write-list l port write-item delim) - (if (pair? l) - (let lp ((l l)) - (write-item (car l) port) - (if (pair? (cdr l)) - (begin - (display delim port) - (lp (cdr l))))))) +(define (write-list items port write-item delim) + (match items + (() (values)) + ((item . items) + (write-item item port) + (let lp ((items items)) + (match items + (() (values)) + ((item . items) + (display delim port) + (write-item item port) + (lp items))))))) (define (write-qstring str port) (display #\" port) @@ -370,20 +374,20 @@ as an ordered alist." (define* (parse-quality str #:optional (start 0) (end (string-length str))) (define (char->decimal c) (let ((i (- (char->integer c) (char->integer #\0)))) - (if (and (<= 0 i) (< i 10)) - i - (bad-header-component 'quality str)))) + (unless (and (<= 0 i) (< i 10)) + (bad-header-component 'quality str)) + i)) (cond ((not (< start end)) (bad-header-component 'quality str)) ((eqv? (string-ref str start) #\1) - (if (or (string= str "1" start end) - (string= str "1." start end) - (string= str "1.0" start end) - (string= str "1.00" start end) - (string= str "1.000" start end)) - 1000 - (bad-header-component 'quality str))) + (unless (or (string= str "1" start end) + (string= str "1." start end) + (string= str "1.0" start end) + (string= str "1.00" start end) + (string= str "1.000" start end)) + (bad-header-component 'quality str)) + 1000) ((eqv? (string-ref str start) #\0) (if (or (string= str "0" start end) (string= str "0." start end)) @@ -425,10 +429,9 @@ as an ordered alist." (display (digit->char (modulo q 10)) port)) (define (list-of? val pred) - (or (null? val) - (and (pair? val) - (pred (car val)) - (list-of? (cdr val) pred)))) + (match val + (((? pred) ...) #t) + (_ #f))) (define* (parse-quality-list str) (map (lambda (part) @@ -436,20 +439,18 @@ as an ordered alist." ((string-rindex part #\;) => (lambda (idx) (let ((qpart (string-trim-both part char-set:whitespace (1+ idx)))) - (if (string-prefix? "q=" qpart) - (cons (parse-quality qpart 2) - (string-trim-both part char-set:whitespace 0 idx)) - (bad-header-component 'quality qpart))))) + (unless (string-prefix? "q=" qpart) + (bad-header-component 'quality qpart)) + (cons (parse-quality qpart 2) + (string-trim-both part char-set:whitespace 0 idx))))) (else (cons 1000 (string-trim-both part char-set:whitespace))))) (string-split str #\,))) (define (validate-quality-list l) - (list-of? l - (lambda (elt) - (and (pair? elt) - (valid-quality? (car elt)) - (string? (cdr elt)))))) + (match l + ((((? valid-quality?) . (? string?)) ...) #t) + (_ #f))) (define (write-quality-list l port) (write-list l port @@ -457,26 +458,25 @@ as an ordered alist." (let ((q (car x)) (str (cdr x))) (display str port) - (if (< q 1000) - (begin - (display ";q=" port) - (write-quality q port))))) + (when (< q 1000) + (display ";q=" port) + (write-quality q port)))) ",")) (define* (parse-non-negative-integer val #:optional (start 0) (end (string-length val))) (define (char->decimal c) (let ((i (- (char->integer c) (char->integer #\0)))) - (if (and (<= 0 i) (< i 10)) - i - (bad-header-component 'non-negative-integer val)))) - (if (not (< start end)) - (bad-header-component 'non-negative-integer val) - (let lp ((i start) (out 0)) - (if (< i end) - (lp (1+ i) - (+ (* out 10) (char->decimal (string-ref val i)))) - out)))) + (unless (and (<= 0 i) (< i 10)) + (bad-header-component 'non-negative-integer val)) + i)) + (unless (< start end) + (bad-header-component 'non-negative-integer val)) + (let lp ((i start) (out 0)) + (if (< i end) + (lp (1+ i) + (+ (* out 10) (char->decimal (string-ref val i)))) + out))) (define (non-negative-integer? code) (and (number? code) (>= code 0) (exact? code) (integer? code))) @@ -497,9 +497,9 @@ as an ordered alist." (define* (parse-key-value-list str #:optional (val-parser default-val-parser) (start 0) (end (string-length str))) - (let lp ((i start) (out '())) + (let lp ((i start)) (if (not (< i end)) - (reverse! out) + '() (let* ((i (skip-whitespace str i end)) (eq (string-index str #\= i end)) (comma (string-index str #\, i end)) @@ -520,37 +520,35 @@ as an ordered alist." (lambda (v-str next-i) (let ((v (val-parser k v-str)) (i (skip-whitespace str next-i end))) - (if (or (= i end) (eqv? (string-ref str i) #\,)) - (lp (1+ i) (cons (if v (cons k v) k) out)) - (bad-header-component 'key-value-list - (substring str start end)))))))))) + (unless (or (= i end) (eqv? (string-ref str i) #\,)) + (bad-header-component 'key-value-list + (substring str start end))) + (cons (if v (cons k v) k) + (lp (1+ i)))))))))) (define* (key-value-list? list #:optional (valid? default-val-validator)) (list-of? list (lambda (elt) - (cond - ((pair? elt) - (let ((k (car elt)) - (v (cdr elt))) - (and (symbol? k) - (valid? k v)))) - ((symbol? elt) - (valid? elt #f)) - (else #f))))) + (match elt + (((? symbol? k) . v) (valid? k v)) + ((? symbol? k) (valid? k #f)) + (_ #f))))) (define* (write-key-value-list list port #:optional (val-writer default-val-writer) (delim ", ")) (write-list list port (lambda (x port) - (let ((k (if (pair? x) (car x) x)) - (v (if (pair? x) (cdr x) #f))) - (display k port) - (if v - (begin - (display #\= port) - (val-writer k v port))))) + (match x + ((k . #f) + (display (symbol->string k) port)) + ((k . v) + (display (symbol->string k) port) + (display #\= port) + (val-writer k v port)) + (k + (display (symbol->string k) port)))) delim)) ;; param-component = token [ "=" (token | quoted-string) ] \ @@ -782,8 +780,8 @@ as an ordered alist." (define (parse-rfc-850-date str comma space zone-offset) ;; We could verify the day of the week but we don't. (let ((tail (substring str (1+ comma) space))) - (if (not (string-match? tail " dd-aaa-dd dd:dd:dd")) - (bad-header 'date str)) + (unless (string-match? tail " dd-aaa-dd dd:dd:dd") + (bad-header 'date str)) (let ((date (parse-non-negative-integer tail 1 3)) (month (parse-month tail 4 7)) (year (parse-non-negative-integer tail 8 10)) @@ -803,8 +801,8 @@ as an ordered alist." ;; 012345678901234567890123 ;; 0 1 2 (define (parse-asctime-date str) - (if (not (string-match? str "aaa aaa .d dd:dd:dd dddd")) - (bad-header 'date str)) + (unless (string-match? str "aaa aaa .d dd:dd:dd dddd") + (bad-header 'date str)) (let ((date (parse-non-negative-integer str (if (eqv? (string-ref str 8) #\space) 9 8) @@ -838,11 +836,10 @@ as an ordered alist." (define (display-digits n digits port) (define zero (char->integer #\0)) (let lp ((tens (expt 10 (1- digits)))) - (if (> tens 0) - (begin - (display (integer->char (+ zero (modulo (truncate/ n tens) 10))) - port) - (lp (floor/ tens 10)))))) + (when (> tens 0) + (display (integer->char (+ zero (modulo (truncate/ n tens) 10))) + port) + (lp (floor/ tens 10))))) (let ((date (if (zero? (date-zone-offset date)) date (time-tai->date (date->time-tai date) 0)))) @@ -895,13 +892,15 @@ as an ordered alist." (values (cons (substring val start delim) #t) delim))))) (define (entity-tag? val) - (and (pair? val) - (string? (car val)))) + (match val + (((? string?) . _) #t) + (_ #f))) (define (write-entity-tag val port) - (if (not (cdr val)) - (display "W/" port)) - (write-qstring (car val) port)) + (match val + ((tag . strong?) + (unless strong? (display "W/" port)) + (write-qstring tag port)))) (define* (parse-entity-tag-list val #:optional (start 0) (end (string-length val))) @@ -936,24 +935,24 @@ as an ordered alist." (start 0) (end (string-length str))) (let* ((start (skip-whitespace str start end)) (delim (or (string-index str char-set:whitespace start end) end))) - (if (= start end) - (bad-header-component 'authorization str)) + (when (= start end) + (bad-header-component 'authorization str)) (let ((scheme (string->symbol (string-downcase (substring str start (or delim end)))))) (case scheme ((basic) (let* ((start (skip-whitespace str delim end))) - (if (< start end) - (cons scheme (substring str start end)) - (bad-header-component 'credentials str)))) + (unless (< start end) + (bad-header-component 'credentials str)) + (cons scheme (substring str start end)))) (else (cons scheme (parse-key-value-list str default-val-parser delim end))))))) (define (validate-credentials val) - (and (pair? val) (symbol? (car val)) - (case (car val) - ((basic) (string? (cdr val))) - (else (key-value-list? (cdr val)))))) + (match val + (('basic . (? string?)) #t) + (((? symbol?) . (? key-value-list?)) #t) + (_ #f))) (define (write-credentials val port) (display (car val) port) @@ -1001,26 +1000,25 @@ as an ordered alist." (values #f delim))) (lambda (v next-i) (let ((i (skip-whitespace str next-i end))) - (if (or (= i end) (eqv? (string-ref str i) #\,)) - (lp (1+ i) (cons (if v (cons k v) k) out)) - (bad-header-component - 'challenge - (substring str start end))))))))))))) + (unless (or (= i end) (eqv? (string-ref str i) #\,)) + (bad-header-component 'challenge + (substring str start end))) + (lp (1+ i) (cons (if v (cons k v) k) out)))))))))))) (define* (parse-challenges str #:optional (val-parser default-val-parser) (start 0) (end (string-length str))) - (let lp ((i start) (ret '())) + (let lp ((i start)) (let ((i (skip-whitespace str i end))) (if (< i end) (call-with-values (lambda () (parse-challenge str i end)) (lambda (challenge i) - (lp i (cons challenge ret)))) - (reverse ret))))) + (cons challenge (lp i)))) + '())))) (define (validate-challenges val) - (list-of? val (lambda (x) - (and (pair? x) (symbol? (car x)) - (key-value-list? (cdr x)))))) + (match val + ((((? symbol?) . (? key-value-list?)) ...) #t) + (_ #f))) (define (write-challenge val port) (display (car val) port) @@ -1049,18 +1047,21 @@ as an ordered alist." "Parse an HTTP version from STR, returning it as a major–minor pair. For example, ‘HTTP/1.1’ parses as the pair of integers, ‘(1 . 1)’." - (or (let lp ((known *known-versions*)) - (and (pair? known) - (if (string= str (caar known) start end) - (cdar known) - (lp (cdr known))))) - (let ((dot-idx (string-index str #\. start end))) - (if (and (string-prefix? "HTTP/" str 0 5 start end) - dot-idx - (= dot-idx (string-rindex str #\. start end))) - (cons (parse-non-negative-integer str (+ start 5) dot-idx) - (parse-non-negative-integer str (1+ dot-idx) end)) - (bad-header-component 'http-version (substring str start end)))))) + (let lp ((known *known-versions*)) + (match known + (((version-str . version-val) . known) + (if (string= str version-str start end) + version-val + (lp known))) + (() + (let ((dot-idx (string-index str #\. start end))) + (unless (and (string-prefix? "HTTP/" str 0 5 start end) + dot-idx + (= dot-idx (string-rindex str #\. start end))) + + (bad-header-component 'http-version (substring str start end))) + (cons (parse-non-negative-integer str (+ start 5) dot-idx) + (parse-non-negative-integer str (1+ dot-idx) end))))))) (define (write-http-version val port) "Write the given major-minor version pair to PORT." @@ -1122,11 +1123,11 @@ three values: the method, the URI, and the version." (let* ((line (read-header-line port)) (d0 (string-index line char-set:whitespace)) ; "delimiter zero" (d1 (string-rindex line char-set:whitespace))) - (if (and d0 d1 (< d0 d1)) - (values (parse-http-method line 0 d0) - (parse-request-uri line (skip-whitespace line (1+ d0) d1) d1) - (parse-http-version line (1+ d1) (string-length line))) - (bad-request "Bad Request-Line: ~s" line)))) + (unless (and d0 d1 (< d0 d1)) + (bad-request "Bad Request-Line: ~s" line)) + (values (parse-http-method line 0 d0) + (parse-request-uri line (skip-whitespace line (1+ d0) d1) d1) + (parse-http-version line (1+ d1) (string-length line))))) (define (write-uri uri port) (when (uri-host uri) @@ -1166,11 +1167,13 @@ three values: the method, the URI, and the version." (when (and scheme host) (display scheme port) (display "://" port) - (if (string-index host #\:) - (begin (display #\[ port) - (display host port) - (display #\] port)) - (display host port)) + (cond + ((string-index host #\:) + (display #\[ port) + (display host port) + (display #\] port)) + (else + (display host port))) (unless ((@@ (web uri) default-port?) scheme host-port) (display #\: port) (display host-port port))))) @@ -1179,10 +1182,9 @@ three values: the method, the URI, and the version." (if (string-null? path) (display "/" port) (display path port)) - (if query - (begin - (display "?" port) - (display query port)))) + (when query + (display "?" port) + (display query port))) (display #\space port) (write-http-version version port) (display "\r\n" port)) @@ -1195,12 +1197,12 @@ values: the HTTP version, the response code, and the (possibly empty) (d0 (string-index line char-set:whitespace)) ; "delimiter zero" (d1 (and d0 (string-index line char-set:whitespace (skip-whitespace line d0))))) - (if (and d0 d1) - (values (parse-http-version line 0 d0) - (parse-non-negative-integer line (skip-whitespace line d0 d1) - d1) - (string-trim-both line char-set:whitespace d1)) - (bad-response "Bad Response-Line: ~s" line)))) + (unless (and d0 d1) + (bad-response "Bad Response-Line: ~s" line)) + (values (parse-http-version line 0 d0) + (parse-non-negative-integer line (skip-whitespace line d0 d1) + d1) + (string-trim-both line char-set:whitespace d1)))) (define (write-response-line version code reason-phrase port) "Write the first line of an HTTP response to PORT." @@ -1453,59 +1455,58 @@ treated specially, and is just returned as a plain string." (let lp ((i (skip-whitespace str 0))) (let* ((idx1 (string-index str #\space i)) (idx2 (string-index str #\space (1+ idx1)))) - (if (and idx1 idx2) - (let ((code (parse-non-negative-integer str i idx1)) - (agent (substring str (1+ idx1) idx2))) - (call-with-values - (lambda () (parse-qstring str (1+ idx2) #:incremental? #t)) - (lambda (text i) - (call-with-values - (lambda () - (let ((c (and (< i len) (string-ref str i)))) - (case c - ((#\space) - ;; we have a date. - (call-with-values - (lambda () (parse-qstring str (1+ i) - #:incremental? #t)) - (lambda (date i) - (values text (parse-date date) i)))) - (else - (values text #f i))))) - (lambda (text date i) - (let ((w (list code agent text date)) - (c (and (< i len) (string-ref str i)))) + (when (and idx1 idx2) + (let ((code (parse-non-negative-integer str i idx1)) + (agent (substring str (1+ idx1) idx2))) + (call-with-values + (lambda () (parse-qstring str (1+ idx2) #:incremental? #t)) + (lambda (text i) + (call-with-values + (lambda () + (let ((c (and (< i len) (string-ref str i)))) (case c - ((#f) (list w)) - ((#\,) (cons w (lp (skip-whitespace str (1+ i))))) - (else (bad-header 'warning str)))))))))))))) + ((#\space) + ;; we have a date. + (call-with-values + (lambda () (parse-qstring str (1+ i) + #:incremental? #t)) + (lambda (date i) + (values text (parse-date date) i)))) + (else + (values text #f i))))) + (lambda (text date i) + (let ((w (list code agent text date)) + (c (and (< i len) (string-ref str i)))) + (case c + ((#f) (list w)) + ((#\,) (cons w (lp (skip-whitespace str (1+ i))))) + (else (bad-header 'warning str)))))))))))))) (lambda (val) (list-of? val (lambda (elt) - (and (list? elt) - (= (length elt) 4) - (apply (lambda (code host text date) - (and (non-negative-integer? code) (< code 1000) - (string? host) - (string? text) - (or (not date) (date? date)))) - elt))))) + (match elt + ((code host text date) + (and (non-negative-integer? code) (< code 1000) + (string? host) + (string? text) + (or (not date) (date? date)))) + (_ #f))))) (lambda (val port) (write-list val port (lambda (w port) - (apply - (lambda (code host text date) + (match w + ((code host text date) (display code port) (display #\space port) (display host port) (display #\space port) (write-qstring text port) - (if date - (begin - (display #\space port) - (write-date date port)))) - w)) + (when date + (display #\space port) + (display #\" port) + (write-date date port) + (display #\" port))))) ", ")) #:multiple? #t) @@ -1529,18 +1530,14 @@ treated specially, and is just returned as a plain string." ;; (declare-header! "Content-Disposition" (lambda (str) - (let ((disposition (parse-param-list str default-val-parser))) - ;; Lazily reuse the param list parser. - (unless (and (pair? disposition) - (null? (cdr disposition))) - (bad-header-component 'content-disposition str)) - (car disposition))) + ;; Lazily reuse the param list parser. + (match (parse-param-list str default-val-parser) + ((disposition) disposition) + (_ (bad-header-component 'content-disposition str)))) (lambda (val) - (and (pair? val) - (symbol? (car val)) - (list-of? (cdr val) - (lambda (x) - (and (pair? x) (symbol? (car x)) (string? (cdr x))))))) + (match val + (((? symbol?) ((? symbol?) . (? string?)) ...) #t) + (_ #f))) (lambda (val port) (write-param-list (list val) port))) @@ -1577,44 +1574,44 @@ treated specially, and is just returned as a plain string." (lambda (str) (let ((dash (string-index str #\-)) (slash (string-index str #\/))) - (if (and (string-prefix? "bytes " str) slash) - (list 'bytes - (cond - (dash - (cons - (parse-non-negative-integer str 6 dash) - (parse-non-negative-integer str (1+ dash) slash))) - ((string= str "*" 6 slash) - '*) - (else - (bad-header 'content-range str))) - (if (string= str "*" (1+ slash)) - '* - (parse-non-negative-integer str (1+ slash)))) - (bad-header 'content-range str)))) + (unless (and (string-prefix? "bytes " str) slash) + (bad-header 'content-range str)) + (list 'bytes + (cond + (dash + (cons + (parse-non-negative-integer str 6 dash) + (parse-non-negative-integer str (1+ dash) slash))) + ((string= str "*" 6 slash) + '*) + (else + (bad-header 'content-range str))) + (if (string= str "*" (1+ slash)) + '* + (parse-non-negative-integer str (1+ slash)))))) (lambda (val) - (and (list? val) (= (length val) 3) - (symbol? (car val)) - (let ((x (cadr val))) - (or (eq? x '*) - (and (pair? x) - (non-negative-integer? (car x)) - (non-negative-integer? (cdr x))))) - (let ((x (caddr val))) - (or (eq? x '*) - (non-negative-integer? x))))) + (match val + (((? symbol?) + (or '* ((? non-negative-integer?) . (? non-negative-integer?))) + (or '* (? non-negative-integer?))) + #t) + (_ #f))) (lambda (val port) - (display (car val) port) - (display #\space port) - (if (eq? (cadr val) '*) - (display #\* port) - (begin - (display (caadr val) port) + (match val + ((unit range instance-length) + (display unit port) + (display #\space port) + (match range + ('* + (display #\* port)) + ((start . end) + (display start port) (display #\- port) - (display (caadr val) port))) - (if (eq? (caddr val) '*) - (display #\* port) - (display (caddr val) port)))) + (display end port))) + (display #\/ port) + (match instance-length + ('* (display #\* port)) + (len (display len port))))))) ;; Content-Type = media-type ;; @@ -1624,31 +1621,34 @@ treated specially, and is just returned as a plain string." (cons (parse-media-type (car parts)) (map (lambda (x) (let ((eq (string-index x #\=))) - (if (and eq (= eq (string-rindex x #\=))) - (cons - (string->symbol - (string-trim x char-set:whitespace 0 eq)) - (string-trim-right x char-set:whitespace (1+ eq))) - (bad-header 'content-type str)))) + (unless (and eq (= eq (string-rindex x #\=))) + (bad-header 'content-type str)) + (cons + (string->symbol + (string-trim x char-set:whitespace 0 eq)) + (string-trim-right x char-set:whitespace (1+ eq))))) (cdr parts))))) (lambda (val) - (and (pair? val) - (symbol? (car val)) - (list-of? (cdr val) - (lambda (x) - (and (pair? x) (symbol? (car x)) (string? (cdr x))))))) + (match val + (((? symbol?) ((? symbol?) . (? string?)) ...) #t) + (_ #f))) (lambda (val port) - (display (car val) port) - (if (pair? (cdr val)) - (begin + (match val + ((type . args) + (display type port) + (match args + (() (values)) + (args (display ";" port) (write-list - (cdr val) port + args port (lambda (pair port) - (display (car pair) port) - (display #\= port) - (display (cdr pair) port)) - ";"))))) + (match pair + ((k . v) + (display k port) + (display #\= port) + (display v port)))) + ";"))))))) ;; Expires = HTTP-date ;; @@ -1752,21 +1752,22 @@ treated specially, and is just returned as a plain string." (parse-non-negative-integer str (1+ colon))))) (cons host port))) (lambda (val) - (and (pair? val) - (string? (car val)) - (or (not (cdr val)) - (non-negative-integer? (cdr val))))) + (match val + (((? string?) . (or #f (? non-negative-integer?))) #t) + (_ #f))) (lambda (val port) - (if (string-index (car val) #\:) - (begin - (display #\[ port) - (display (car val) port) - (display #\] port)) - (display (car val) port)) - (if (cdr val) - (begin - (display #\: port) - (display (cdr val) port))))) + (match val + ((host-name . host-port) + (cond + ((string-index host-name #\:) + (display #\[ port) + (display host-name port) + (display #\] port)) + (else + (display host-name port))) + (when host-port + (display #\: port) + (display host-port port)))))) ;; If-Match = ( "*" | 1#entity-tag ) ;; @@ -1819,45 +1820,45 @@ treated specially, and is just returned as a plain string." ;; (declare-header! "Range" (lambda (str) - (if (string-prefix? "bytes=" str) - (cons - 'bytes - (map (lambda (x) - (let ((dash (string-index x #\-))) - (cond - ((not dash) - (bad-header 'range str)) - ((zero? dash) - (cons #f (parse-non-negative-integer x 1))) - ((= dash (1- (string-length x))) - (cons (parse-non-negative-integer x 0 dash) #f)) - (else - (cons (parse-non-negative-integer x 0 dash) - (parse-non-negative-integer x (1+ dash))))))) - (string-split (substring str 6) #\,))) - (bad-header 'range str))) + (unless (string-prefix? "bytes=" str) + (bad-header 'range str)) + (cons + 'bytes + (map (lambda (x) + (let ((dash (string-index x #\-))) + (cond + ((not dash) + (bad-header 'range str)) + ((zero? dash) + (cons #f (parse-non-negative-integer x 1))) + ((= dash (1- (string-length x))) + (cons (parse-non-negative-integer x 0 dash) #f)) + (else + (cons (parse-non-negative-integer x 0 dash) + (parse-non-negative-integer x (1+ dash))))))) + (string-split (substring str 6) #\,)))) (lambda (val) - (and (pair? val) - (symbol? (car val)) - (list-of? (cdr val) - (lambda (elt) - (and (pair? elt) - (let ((x (car elt)) (y (cdr elt))) - (and (or x y) - (or (not x) (non-negative-integer? x)) - (or (not y) (non-negative-integer? y))))))))) + (match val + (((? symbol?) + (or (#f . (? non-negative-integer?)) + ((? non-negative-integer?) . (? non-negative-integer?)) + ((? non-negative-integer?) . #f)) + ...) #t) + (_ #f))) (lambda (val port) - (display (car val) port) - (display #\= port) - (write-list - (cdr val) port - (lambda (pair port) - (if (car pair) - (display (car pair) port)) - (display #\- port) - (if (cdr pair) - (display (cdr pair) port))) - ","))) + (match val + ((unit . ranges) + (display unit port) + (display #\= port) + (write-list + ranges port + (lambda (range port) + (match range + ((start . end) + (when start (display start port)) + (display #\- port) + (when end (display end port))))) + ","))))) ;; Referer = URI-reference ;; @@ -1986,26 +1987,28 @@ closed it will also close PORT, unless the KEEP-ALIVE? is true." (let ((size (read-chunk-header port))) (set! chunk-size size) (set! remaining size) - (if (zero? size) - (begin - (set! finished? #t) - num-read) - (loop to-read num-read)))) + (cond + ((zero? size) + (set! finished? #t) + num-read) + (else + (loop to-read num-read))))) (else ;read from the current chunk (let* ((ask-for (min to-read remaining)) (read (get-bytevector-n! port bv (+ idx num-read) ask-for))) - (if (eof-object? read) - (begin ;premature termination - (set! finished? #t) - num-read) - (let ((left (- remaining read))) - (set! remaining left) - (when (zero? left) - ;; We're done with this chunk; read CR and LF. - (get-u8 port) (get-u8 port)) - (loop (- to-read read) - (+ num-read read)))))))) + (cond + ((eof-object? read) ;premature termination + (set! finished? #t) + num-read) + (else + (let ((left (- remaining read))) + (set! remaining left) + (when (zero? left) + ;; We're done with this chunk; read CR and LF. + (get-u8 port) (get-u8 port)) + (loop (- to-read read) + (+ num-read read))))))))) (loop to-read 0)) (make-custom-binary-input-port "chunked input port" read! #f #f close)) diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test index 03bd8b35b..da00ec316 100644 --- a/test-suite/tests/web-http.test +++ b/test-suite/tests/web-http.test @@ -39,7 +39,7 @@ #t (error "unexpected exception" message args)))))))) -(define-syntax pass-if-parse +(define-syntax pass-if-only-parse (syntax-rules () ((_ sym str val) (pass-if (format #f "~a: ~s -> ~s" 'sym str val) @@ -47,6 +47,23 @@ val) (valid-header? 'sym val)))))) +(define-syntax-rule (pass-if-reparse sym val) + (pass-if-equal (format #f "~a: ~s reparse" 'sym val) val + (let ((str (call-with-output-string + (lambda (port) + (write-header 'sym val port))))) + (call-with-values (lambda () (read-header (open-input-string str))) + (lambda (sym* val*) + (unless (eq? 'sym sym*) (error "unexpected header")) + val*))))) + +(define-syntax pass-if-parse + (syntax-rules () + ((_ sym str val) + (begin + (pass-if-only-parse sym str val) + (pass-if-reparse sym val))))) + (define-syntax pass-if-round-trip (syntax-rules () ((_ str) @@ -368,10 +385,10 @@ (pass-if-parse etag "foo" '("foo" . #t)) (pass-if-parse location "http://other-place" (build-uri 'http #:host "other-place")) - (pass-if-parse location "#foo" - (build-uri-reference #:fragment "foo")) - (pass-if-parse location "/#foo" - (build-uri-reference #:path "/" #:fragment "foo")) + (pass-if-only-parse location "#foo" + (build-uri-reference #:fragment "foo")) + (pass-if-only-parse location "/#foo" + (build-uri-reference #:path "/" #:fragment "foo")) (pass-if-parse location "/foo" (build-uri-reference #:path "/foo")) (pass-if-parse location "//server/foo" From 96b994b6f815747ce2548123cc996d8132bd4781 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 8 Feb 2017 08:45:42 +0100 Subject: [PATCH 680/865] Beginnings of suspendable HTTP * module/web/http.scm: Use put-string and other routines from (ice-9 textual-ports) in preference to `display'. The goal is for these operations to be suspendable. --- module/web/http.scm | 280 +++++++++++++++++++++++--------------------- 1 file changed, 146 insertions(+), 134 deletions(-) diff --git a/module/web/http.scm b/module/web/http.scm index 57c209599..c3fbf6f41 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -37,6 +37,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 q) #:use-module (ice-9 binary-ports) + #:use-module (ice-9 textual-ports) #:use-module (rnrs bytevectors) #:use-module (web uri) #:export (string->header @@ -73,6 +74,12 @@ set-http-proxy-port?!)) +(define (put-symbol port sym) + (put-string port (symbol->string sym))) + +(define (put-non-negative-integer port i) + (put-string port (number->string i))) + (define (string->header name) "Parse NAME to a symbolic header name." (string->symbol (string-downcase name))) @@ -205,10 +212,10 @@ header with name SYM." (define (write-header sym val port) "Write the given header name and value to PORT, using the writer from ‘header-writer’." - (display (header->string sym) port) - (display ": " port) + (put-string port (header->string sym)) + (put-string port ": ") ((header-writer sym) val port) - (display "\r\n" port)) + (put-string port "\r\n")) (define (read-headers port) "Read the headers of an HTTP message from PORT, returning them @@ -263,7 +270,7 @@ as an ordered alist." (define (validate-opaque-string val) (string? val)) (define (write-opaque-string val port) - (display val port)) + (put-string port val)) (define separators-without-slash (string->char-set "[^][()<>@,;:\\\"?= \t]")) @@ -312,7 +319,7 @@ as an ordered alist." (define (write-header-list val port) (write-list val port (lambda (x port) - (display (header->string x) port)) + (put-string port (header->string x))) ", ")) (define (collect-escaped-string from start len escapes) @@ -359,17 +366,17 @@ as an ordered alist." (match items (() (values)) ((item . items) - (display delim port) + (put-string port delim) (write-item item port) (lp items))))))) (define (write-qstring str port) - (display #\" port) + (put-char port #\") (if (string-index str #\") ;; optimize me (write-list (string-split str #\") port display "\\\"") - (display str port)) - (display #\" port)) + (put-string port str)) + (put-char port #\")) (define* (parse-quality str #:optional (start 0) (end (string-length str))) (define (char->decimal c) @@ -422,11 +429,11 @@ as an ordered alist." (define (write-quality q port) (define (digit->char d) (integer->char (+ (char->integer #\0) d))) - (display (digit->char (modulo (quotient q 1000) 10)) port) - (display #\. port) - (display (digit->char (modulo (quotient q 100) 10)) port) - (display (digit->char (modulo (quotient q 10) 10)) port) - (display (digit->char (modulo q 10)) port)) + (put-char port (digit->char (modulo (quotient q 1000) 10))) + (put-char port #\.) + (put-char port (digit->char (modulo (quotient q 100) 10))) + (put-char port (digit->char (modulo (quotient q 10) 10))) + (put-char port (digit->char (modulo q 10)))) (define (list-of? val pred) (match val @@ -457,9 +464,9 @@ as an ordered alist." (lambda (x port) (let ((q (car x)) (str (cdr x))) - (display str port) + (put-string port str) (when (< q 1000) - (display ";q=" port) + (put-string port ";q=") (write-quality q port)))) ",")) @@ -492,7 +499,7 @@ as an ordered alist." (string-index val #\,) (string-index val #\")) (write-qstring val port) - (display val port))) + (put-string port val))) (define* (parse-key-value-list str #:optional (val-parser default-val-parser) @@ -542,13 +549,13 @@ as an ordered alist." (lambda (x port) (match x ((k . #f) - (display (symbol->string k) port)) + (put-symbol port k)) ((k . v) - (display (symbol->string k) port) - (display #\= port) + (put-symbol port k) + (put-char port #\=) (val-writer k v port)) (k - (display (symbol->string k) port)))) + (put-symbol port k)))) delim)) ;; param-component = token [ "=" (token | quoted-string) ] \ @@ -837,33 +844,33 @@ as an ordered alist." (define zero (char->integer #\0)) (let lp ((tens (expt 10 (1- digits)))) (when (> tens 0) - (display (integer->char (+ zero (modulo (truncate/ n tens) 10))) - port) + (put-char port + (integer->char (+ zero (modulo (truncate/ n tens) 10)))) (lp (floor/ tens 10))))) (let ((date (if (zero? (date-zone-offset date)) date (time-tai->date (date->time-tai date) 0)))) - (display (case (date-week-day date) - ((0) "Sun, ") ((1) "Mon, ") ((2) "Tue, ") - ((3) "Wed, ") ((4) "Thu, ") ((5) "Fri, ") - ((6) "Sat, ") (else (error "bad date" date))) - port) + (put-string port + (case (date-week-day date) + ((0) "Sun, ") ((1) "Mon, ") ((2) "Tue, ") + ((3) "Wed, ") ((4) "Thu, ") ((5) "Fri, ") + ((6) "Sat, ") (else (error "bad date" date)))) (display-digits (date-day date) 2 port) - (display (case (date-month date) - ((1) " Jan ") ((2) " Feb ") ((3) " Mar ") - ((4) " Apr ") ((5) " May ") ((6) " Jun ") - ((7) " Jul ") ((8) " Aug ") ((9) " Sep ") - ((10) " Oct ") ((11) " Nov ") ((12) " Dec ") - (else (error "bad date" date))) - port) + (put-string port + (case (date-month date) + ((1) " Jan ") ((2) " Feb ") ((3) " Mar ") + ((4) " Apr ") ((5) " May ") ((6) " Jun ") + ((7) " Jul ") ((8) " Aug ") ((9) " Sep ") + ((10) " Oct ") ((11) " Nov ") ((12) " Dec ") + (else (error "bad date" date)))) (display-digits (date-year date) 4 port) - (display #\space port) + (put-char port #\space) (display-digits (date-hour date) 2 port) - (display #\: port) + (put-char port #\:) (display-digits (date-minute date) 2 port) - (display #\: port) + (put-char port #\:) (display-digits (date-second date) 2 port) - (display " GMT" port))) + (put-string port " GMT"))) ;; Following https://tools.ietf.org/html/rfc7232#section-2.3, an entity ;; tag should really be a qstring. However there are a number of @@ -899,7 +906,7 @@ as an ordered alist." (define (write-entity-tag val port) (match val ((tag . strong?) - (unless strong? (display "W/" port)) + (unless strong? (put-string port "W/")) (write-qstring tag port)))) (define* (parse-entity-tag-list val #:optional @@ -955,11 +962,14 @@ as an ordered alist." (_ #f))) (define (write-credentials val port) - (display (car val) port) - (display #\space port) - (case (car val) - ((basic) (display (cdr val) port)) - (else (write-key-value-list (cdr val) port)))) + (match val + (('basic . cred) + (put-string port "basic ") + (put-string port cred)) + ((scheme . params) + (put-symbol port scheme) + (put-char port #\space) + (write-key-value-list params port)))) ;; challenges = 1#challenge ;; challenge = auth-scheme 1*SP 1#auth-param @@ -1021,9 +1031,11 @@ as an ordered alist." (_ #f))) (define (write-challenge val port) - (display (car val) port) - (display #\space port) - (write-key-value-list (cdr val) port)) + (match val + ((scheme . params) + (put-symbol port scheme) + (put-char port #\space) + (write-key-value-list params port)))) (define (write-challenges val port) (write-list val port write-challenge ", ")) @@ -1065,10 +1077,10 @@ pair. For example, ‘HTTP/1.1’ parses as the pair of integers, (define (write-http-version val port) "Write the given major-minor version pair to PORT." - (display "HTTP/" port) - (display (car val) port) - (display #\. port) - (display (cdr val) port)) + (put-string port "HTTP/") + (put-non-negative-integer port (car val)) + (put-char port #\.) + (put-non-negative-integer port (cdr val))) (for-each (lambda (v) @@ -1132,17 +1144,17 @@ three values: the method, the URI, and the version." (define (write-uri uri port) (when (uri-host uri) (when (uri-scheme uri) - (display (uri-scheme uri) port) - (display #\: port)) - (display "//" port) + (put-symbol port (uri-scheme uri)) + (put-char port #\:)) + (put-string port "//") (when (uri-userinfo uri) - (display (uri-userinfo uri) port) - (display #\@ port)) - (display (uri-host uri) port) + (put-string port (uri-userinfo uri)) + (put-char port #\@)) + (put-string port (uri-host uri)) (let ((p (uri-port uri))) (when (and p (not (eqv? p 80))) - (display #\: port) - (display p port)))) + (put-char port #\:) + (put-non-negative-integer port p)))) (let* ((path (uri-path uri)) (len (string-length path))) (cond @@ -1151,43 +1163,43 @@ three values: the method, the URI, and the version." ((and (zero? len) (not (uri-host uri))) (bad-request "Empty path and no host for URI: ~s" uri)) (else - (display path port)))) + (put-string port path)))) (when (uri-query uri) - (display #\? port) - (display (uri-query uri) port))) + (put-char port #\?) + (put-string port (uri-query uri)))) (define (write-request-line method uri version port) "Write the first line of an HTTP request to PORT." - (display method port) - (display #\space port) + (put-symbol port method) + (put-char port #\space) (when (http-proxy-port? port) (let ((scheme (uri-scheme uri)) (host (uri-host uri)) (host-port (uri-port uri))) (when (and scheme host) - (display scheme port) - (display "://" port) + (put-symbol port scheme) + (put-string port "://") (cond - ((string-index host #\:) - (display #\[ port) - (display host port) - (display #\] port)) + ((host string-index #\:) + (put-char #\[ port) + (put-string port host + (put-char port #\]))) (else - (display host port))) + (put-string port host))) (unless ((@@ (web uri) default-port?) scheme host-port) - (display #\: port) - (display host-port port))))) + (put-char port #\:) + (put-non-negative-integer port host-port))))) (let ((path (uri-path uri)) (query (uri-query uri))) (if (string-null? path) - (display "/" port) - (display path port)) + (put-string port "/") + (put-string port path)) (when query - (display "?" port) - (display query port))) - (display #\space port) + (put-string port "?") + (put-string port query))) + (put-char port #\space) (write-http-version version port) - (display "\r\n" port)) + (put-string port "\r\n")) (define (read-response-line port) "Read the first line of an HTTP response from PORT, returning three @@ -1207,11 +1219,11 @@ values: the HTTP version, the response code, and the (possibly empty) (define (write-response-line version code reason-phrase port) "Write the first line of an HTTP response to PORT." (write-http-version version port) - (display #\space port) - (display code port) - (display #\space port) - (display reason-phrase port) - (display "\r\n" port)) + (put-char port #\space) + (put-non-negative-integer port code) + (put-char port #\space) + (put-string port reason-phrase) + (put-string port "\r\n")) @@ -1306,7 +1318,7 @@ treated specially, and is just returned as a plain string." (lambda (val) (or (eq? val '*) (entity-tag-list? val))) (lambda (val port) (if (eq? val '*) - (display "*" port) + (put-string port "*") (write-entity-tag-list val port))))) ;; emacs: (put 'declare-credentials-header! 'scheme-indent-function 1) @@ -1376,11 +1388,11 @@ treated specially, and is just returned as a plain string." (cond ((string? v) (default-val-writer k v port)) ((pair? v) - (display #\" port) + (put-char port #\") (write-header-list v port) - (display #\" port)) + (put-char port #\")) ((integer? v) - (display v port)) + (put-non-negative-integer port v)) (else (bad-header-component 'cache-control v))))) @@ -1395,10 +1407,10 @@ treated specially, and is just returned as a plain string." (lambda (val port) (write-list val port (lambda (x port) - (display (if (eq? x 'close) - "close" - (header->string x)) - port)) + (put-string port + (if (eq? x 'close) + "close" + (header->string x)))) ", "))) ;; Date = "Date" ":" HTTP-date @@ -1497,16 +1509,16 @@ treated specially, and is just returned as a plain string." (lambda (w port) (match w ((code host text date) - (display code port) - (display #\space port) - (display host port) - (display #\space port) + (put-non-negative-integer port code) + (put-char port #\space) + (put-string port host) + (put-char port #\space) (write-qstring text port) (when date - (display #\space port) - (display #\" port) + (put-char port #\space) + (put-char port #\") (write-date date port) - (display #\" port))))) + (put-char port #\"))))) ", ")) #:multiple? #t) @@ -1599,19 +1611,19 @@ treated specially, and is just returned as a plain string." (lambda (val port) (match val ((unit range instance-length) - (display unit port) - (display #\space port) + (put-symbol port unit) + (put-char port #\space) (match range ('* - (display #\* port)) + (put-char port #\*)) ((start . end) - (display start port) - (display #\- port) - (display end port))) - (display #\/ port) + (put-non-negative-integer port start) + (put-char port #\-) + (put-non-negative-integer port end))) + (put-char port #\/) (match instance-length - ('* (display #\* port)) - (len (display len port))))))) + ('* (put-char port #\*)) + (len (put-non-negative-integer port len))))))) ;; Content-Type = media-type ;; @@ -1635,19 +1647,19 @@ treated specially, and is just returned as a plain string." (lambda (val port) (match val ((type . args) - (display type port) + (put-symbol port type) (match args (() (values)) (args - (display ";" port) + (put-string port ";") (write-list args port (lambda (pair port) (match pair ((k . v) - (display k port) - (display #\= port) - (display v port)))) + (put-symbol port k) + (put-char port #\=) + (put-string port v)))) ";"))))))) ;; Expires = HTTP-date @@ -1760,14 +1772,14 @@ treated specially, and is just returned as a plain string." ((host-name . host-port) (cond ((string-index host-name #\:) - (display #\[ port) - (display host-name port) - (display #\] port)) + (put-char port #\[) + (put-string port host-name) + (put-char port #\])) (else - (display host-name port))) + (put-string port host-name))) (when host-port - (display #\: port) - (display host-port port)))))) + (put-char port #\:) + (put-non-negative-integer port host-port)))))) ;; If-Match = ( "*" | 1#entity-tag ) ;; @@ -1848,16 +1860,16 @@ treated specially, and is just returned as a plain string." (lambda (val port) (match val ((unit . ranges) - (display unit port) - (display #\= port) + (put-symbol port unit) + (put-char port #\=) (write-list ranges port (lambda (range port) (match range ((start . end) - (when start (display start port)) - (display #\- port) - (when end (display end port))))) + (when start (put-non-negative-integer port start)) + (put-char port #\-) + (when end (put-non-negative-integer port end))))) ","))))) ;; Referer = URI-reference @@ -1922,7 +1934,7 @@ treated specially, and is just returned as a plain string." (lambda (val port) (if (date? val) (write-date val port) - (display val port)))) + (put-non-negative-integer port val)))) ;; Server = 1*( product | comment ) ;; @@ -1939,7 +1951,7 @@ treated specially, and is just returned as a plain string." (or (eq? val '*) (list-of-header-names? val))) (lambda (val port) (if (eq? val '*) - (display "*" port) + (put-string port "*") (write-header-list val port)))) ;; WWW-Authenticate = 1#challenge @@ -2027,9 +2039,9 @@ KEEP-ALIVE? is true." (while (not (q-empty? q)) (f (deq! q)))) (define queue (make-q)) - (define (put-char c) + (define (%put-char c) (enq! queue c)) - (define (put-string s) + (define (%put-string s) (string-for-each (lambda (c) (enq! queue c)) s)) (define (flush) @@ -2037,18 +2049,18 @@ KEEP-ALIVE? is true." ;; empty, since it will be treated as the final chunk. (unless (q-empty? queue) (let ((len (q-length queue))) - (display (number->string len 16) port) - (display "\r\n" port) + (put-string port (number->string len 16)) + (put-string port "\r\n") (q-for-each (lambda (elem) (write-char elem port)) queue) - (display "\r\n" port)))) + (put-string port "\r\n")))) (define (close) (flush) - (display "0\r\n" port) + (put-string port "0\r\n") (force-output port) (unless keep-alive? (close-port port))) - (let ((ret (make-soft-port (vector put-char put-string flush #f close) "w"))) + (let ((ret (make-soft-port (vector %put-char %put-string flush #f close) "w"))) (setvbuf ret 'block buffering) ret)) From ecdff904cb9eb7b29d1b4f73d4ec744d1502c725 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 8 Feb 2017 08:58:46 +0100 Subject: [PATCH 681/865] Remove remaining "display" uses in (web http) * module/web/http.scm (header-writer): Default to calling put-string. (put-list): Rename from write-list, take the port first, and call the put-item function with port then value. Adapt all callers. (write-date): Rename display-digits to put-digits. (put-challenge): Rename from write-challenge, adapt arguments to put convention, and adapt callers. (declare-symbol-list-header!): Use put-symbol. (declare-integer-header!): Use put-non-negative-integer.o (declare-entity-tag-list-header!): Use put-entity-tag-list. ("If-Range", "Etag"): Adapt to put-entity-tag. (make-chunked-output-port): Use put-char. --- module/web/http.scm | 121 +++++++++++++++++++++++--------------------- 1 file changed, 62 insertions(+), 59 deletions(-) diff --git a/module/web/http.scm b/module/web/http.scm index c3fbf6f41..41e429ce3 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -145,11 +145,12 @@ is ‘string?’." (define (header-writer sym) "Return a procedure that writes values for headers named SYM to a port. The resulting procedure takes two arguments: a value and a port. -The default writer is ‘display’." +The default writer will call ‘put-string’." (let ((decl (lookup-header-decl sym))) (if decl (header-decl-writer decl) - display))) + (lambda (val port) + (put-string port val))))) (define (read-header-line port) "Read an HTTP header line and return it without its final CRLF or LF. @@ -308,7 +309,7 @@ as an ordered alist." (list-of? val string?)) (define (write-list-of-strings val port) - (write-list val port display ", ")) + (put-list port val put-string ", ")) (define (split-header-names str) (map string->header (split-and-trim str))) @@ -317,10 +318,10 @@ as an ordered alist." (list-of? val symbol?)) (define (write-header-list val port) - (write-list val port - (lambda (x port) - (put-string port (header->string x))) - ", ")) + (put-list port val + (lambda (port x) + (put-string port (header->string x))) + ", ")) (define (collect-escaped-string from start len escapes) (let ((to (make-string len))) @@ -357,24 +358,24 @@ as an ordered alist." (lp (1+ i) (1+ qi) escapes))) (bad-header-component 'qstring str)))) -(define (write-list items port write-item delim) +(define (put-list port items put-item delim) (match items (() (values)) ((item . items) - (write-item item port) + (put-item port item) (let lp ((items items)) (match items (() (values)) ((item . items) (put-string port delim) - (write-item item port) + (put-item port item) (lp items))))))) (define (write-qstring str port) (put-char port #\") (if (string-index str #\") ;; optimize me - (write-list (string-split str #\") port display "\\\"") + (put-list port (string-split str #\") put-string "\\\"") (put-string port str)) (put-char port #\")) @@ -460,15 +461,15 @@ as an ordered alist." (_ #f))) (define (write-quality-list l port) - (write-list l port - (lambda (x port) - (let ((q (car x)) - (str (cdr x))) - (put-string port str) - (when (< q 1000) - (put-string port ";q=") - (write-quality q port)))) - ",")) + (put-list port l + (lambda (port x) + (let ((q (car x)) + (str (cdr x))) + (put-string port str) + (when (< q 1000) + (put-string port ";q=") + (write-quality q port)))) + ",")) (define* (parse-non-negative-integer val #:optional (start 0) (end (string-length val))) @@ -544,9 +545,9 @@ as an ordered alist." (define* (write-key-value-list list port #:optional (val-writer default-val-writer) (delim ", ")) - (write-list - list port - (lambda (x port) + (put-list + port list + (lambda (port x) (match x ((k . #f) (put-symbol port k)) @@ -630,9 +631,9 @@ as an ordered alist." (define* (write-param-list list port #:optional (val-writer default-val-writer)) - (write-list - list port - (lambda (item port) + (put-list + port list + (lambda (port item) (write-key-value-list item port val-writer ";")) ",")) @@ -840,7 +841,7 @@ as an ordered alist." (parse-asctime-date str))))) (define (write-date date port) - (define (display-digits n digits port) + (define (put-digits port n digits) (define zero (char->integer #\0)) (let lp ((tens (expt 10 (1- digits)))) (when (> tens 0) @@ -855,7 +856,7 @@ as an ordered alist." ((0) "Sun, ") ((1) "Mon, ") ((2) "Tue, ") ((3) "Wed, ") ((4) "Thu, ") ((5) "Fri, ") ((6) "Sat, ") (else (error "bad date" date)))) - (display-digits (date-day date) 2 port) + (put-digits port (date-day date) 2) (put-string port (case (date-month date) ((1) " Jan ") ((2) " Feb ") ((3) " Mar ") @@ -863,13 +864,13 @@ as an ordered alist." ((7) " Jul ") ((8) " Aug ") ((9) " Sep ") ((10) " Oct ") ((11) " Nov ") ((12) " Dec ") (else (error "bad date" date)))) - (display-digits (date-year date) 4 port) + (put-digits port (date-year date) 4) (put-char port #\space) - (display-digits (date-hour date) 2 port) + (put-digits port (date-hour date) 2) (put-char port #\:) - (display-digits (date-minute date) 2 port) + (put-digits port (date-minute date) 2) (put-char port #\:) - (display-digits (date-second date) 2 port) + (put-digits port (date-second date) 2) (put-string port " GMT"))) ;; Following https://tools.ietf.org/html/rfc7232#section-2.3, an entity @@ -903,7 +904,7 @@ as an ordered alist." (((? string?) . _) #t) (_ #f))) -(define (write-entity-tag val port) +(define (put-entity-tag port val) (match val ((tag . strong?) (unless strong? (put-string port "W/")) @@ -928,8 +929,8 @@ as an ordered alist." (define (entity-tag-list? val) (list-of? val entity-tag?)) -(define (write-entity-tag-list val port) - (write-list val port write-entity-tag ", ")) +(define (put-entity-tag-list port val) + (put-list port val put-entity-tag ", ")) ;; credentials = auth-scheme #auth-param ;; auth-scheme = token @@ -1030,7 +1031,7 @@ as an ordered alist." ((((? symbol?) . (? key-value-list?)) ...) #t) (_ #f))) -(define (write-challenge val port) +(define (put-challenge port val) (match val ((scheme . params) (put-symbol port scheme) @@ -1038,7 +1039,7 @@ as an ordered alist." (write-key-value-list params port)))) (define (write-challenges val port) - (write-list val port write-challenge ", ")) + (put-list port val put-challenge ", ")) @@ -1258,7 +1259,7 @@ treated specially, and is just returned as a plain string." (lambda (v) (list-of? v symbol?)) (lambda (v port) - (write-list v port display ", ")))) + (put-list port v put-symbol ", ")))) ;; emacs: (put 'declare-header-list-header! 'scheme-indent-function 1) (define (declare-header-list-header! name) @@ -1268,7 +1269,8 @@ treated specially, and is just returned as a plain string." ;; emacs: (put 'declare-integer-header! 'scheme-indent-function 1) (define (declare-integer-header! name) (declare-header! name - parse-non-negative-integer non-negative-integer? display)) + parse-non-negative-integer non-negative-integer? + (lambda (val port) (put-non-negative-integer port val)))) ;; emacs: (put 'declare-uri-header! 'scheme-indent-function 1) (define (declare-uri-header! name) @@ -1319,7 +1321,7 @@ treated specially, and is just returned as a plain string." (lambda (val port) (if (eq? val '*) (put-string port "*") - (write-entity-tag-list val port))))) + (put-entity-tag-list port val))))) ;; emacs: (put 'declare-credentials-header! 'scheme-indent-function 1) (define (declare-credentials-header! name) @@ -1405,13 +1407,13 @@ treated specially, and is just returned as a plain string." split-header-names list-of-header-names? (lambda (val port) - (write-list val port - (lambda (x port) - (put-string port - (if (eq? x 'close) - "close" - (header->string x)))) - ", "))) + (put-list port val + (lambda (port x) + (put-string port + (if (eq? x 'close) + "close" + (header->string x)))) + ", "))) ;; Date = "Date" ":" HTTP-date ;; e.g. @@ -1504,9 +1506,9 @@ treated specially, and is just returned as a plain string." (or (not date) (date? date)))) (_ #f))))) (lambda (val port) - (write-list - val port - (lambda (w port) + (put-list + port val + (lambda (port w) (match w ((code host text date) (put-non-negative-integer port code) @@ -1652,9 +1654,9 @@ treated specially, and is just returned as a plain string." (() (values)) (args (put-string port ";") - (write-list - args port - (lambda (pair port) + (put-list + port args + (lambda (port pair) (match pair ((k . v) (put-symbol port k) @@ -1806,7 +1808,7 @@ treated specially, and is just returned as a plain string." (lambda (val port) (if (date? val) (write-date val port) - (write-entity-tag val port)))) + (put-entity-tag port val)))) ;; If-Unmodified-Since = HTTP-date ;; @@ -1862,9 +1864,9 @@ treated specially, and is just returned as a plain string." ((unit . ranges) (put-symbol port unit) (put-char port #\=) - (write-list - ranges port - (lambda (range port) + (put-list + port ranges + (lambda (port range) (match range ((start . end) (when start (put-non-negative-integer port start)) @@ -1907,7 +1909,8 @@ treated specially, and is just returned as a plain string." (declare-header! "ETag" parse-entity-tag entity-tag? - write-entity-tag) + (lambda (val port) + (put-entity-tag port val))) ;; Location = URI-reference ;; @@ -2051,7 +2054,7 @@ KEEP-ALIVE? is true." (let ((len (q-length queue))) (put-string port (number->string len 16)) (put-string port "\r\n") - (q-for-each (lambda (elem) (write-char elem port)) + (q-for-each (lambda (elem) (put-char port elem)) queue) (put-string port "\r\n")))) (define (close) From 8a4774dec8368def01af4126e77797468b0ce6de Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 8 Feb 2017 11:22:22 +0100 Subject: [PATCH 682/865] Prevent TOCTTOU bugs in suspendable ports * module/ice-9/suspendable-ports.scm: Prevent TOCTTOU bugs by additionally returning the buffer and offset when we compute an amount-buffered. --- module/ice-9/suspendable-ports.scm | 167 +++++++++++++++-------------- 1 file changed, 86 insertions(+), 81 deletions(-) diff --git a/module/ice-9/suspendable-ports.scm b/module/ice-9/suspendable-ports.scm index bc84a4a98..8ff0ba029 100644 --- a/module/ice-9/suspendable-ports.scm +++ b/module/ice-9/suspendable-ports.scm @@ -124,10 +124,9 @@ (and (eq? (peek-byte port) (bytevector-u8-ref bom 0)) (call-with-values (lambda () (fill-input port (bytevector-length bom))) - (lambda (buf buffered) + (lambda (buf cur buffered) (and (<= (bytevector-length bom) buffered) - (let ((bv (port-buffer-bytevector buf)) - (cur (port-buffer-cur buf))) + (let ((bv (port-buffer-bytevector buf))) (let lp ((i 1)) (if (= i (bytevector-length bom)) (begin @@ -160,10 +159,10 @@ (clear-stream-start-for-bom-read port io-mode) (let* ((buf (port-read-buffer port)) (cur (port-buffer-cur buf)) - (buffered (- (port-buffer-end buf) cur))) + (buffered (max (- (port-buffer-end buf) cur) 0))) (cond ((or (<= minimum-buffering buffered) (port-buffer-has-eof? buf)) - (values buf buffered)) + (values buf cur buffered)) (else (unless (input-port? port) (error "not an input port" port)) @@ -186,13 +185,13 @@ (cond ((zero? read) (set-port-buffer-has-eof?! buf #t) - (values buf buffered)) + (values buf 0 buffered)) (else (let ((buffered (+ buffered read))) (set-port-buffer-end! buf buffered) (if (< buffered minimum-buffering) (lp buffered) - (values buf buffered))))))))))))))) + (values buf 0 buffered))))))))))))))) (define* (force-output #:optional (port (current-output-port))) (unless (and (output-port? port) (not (port-closed? port))) @@ -215,9 +214,8 @@ (if (<= count buffered) (kfast buf (port-buffer-bytevector buf) cur buffered) (call-with-values (lambda () (fill-input port count)) - (lambda (buf buffered) - (kslow buf (port-buffer-bytevector buf) (port-buffer-cur buf) - buffered)))))) + (lambda (buf cur buffered) + (kslow buf (port-buffer-bytevector buf) cur buffered)))))) (define (peek-byte port) (peek-bytes port 1 @@ -258,7 +256,7 @@ (define (take-already-buffered) (let* ((buf (port-read-buffer port)) (cur (port-buffer-cur buf)) - (buffered (- (port-buffer-end buf) cur))) + (buffered (max (- (port-buffer-end buf) cur) 0))) (port-buffer-take! 0 buf cur (min count buffered)))) (define (trim-and-return len) (if (zero? len) @@ -268,12 +266,12 @@ partial))) (define (buffer-and-fill pos) (call-with-values (lambda () (fill-input port 1 'binary)) - (lambda (buf buffered) + (lambda (buf cur buffered) (if (zero? buffered) (begin (set-port-buffer-has-eof?! buf #f) (trim-and-return pos)) - (let ((pos (port-buffer-take! pos buf (port-buffer-cur buf) + (let ((pos (port-buffer-take! pos buf cur (min (- count pos) buffered)))) (if (= pos count) ret @@ -302,9 +300,15 @@ (error "not an output port" port)) (when (and (eq? (port-buffer-cur buf) end) (port-random-access? port)) (flush-input port)) - (bytevector-u8-set! bv end byte) - (set-port-buffer-end! buf (1+ end)) - (when (= (1+ end) (bytevector-length bv)) (flush-output port)))) + (cond + ((= end (bytevector-length bv)) + ;; Multiple threads racing; race to flush, then retry. + (flush-output port) + (put-u8 port byte)) + (else + (bytevector-u8-set! bv end byte) + (set-port-buffer-end! buf (1+ end)) + (when (= (1+ end) (bytevector-length bv)) (flush-output port)))))) (define* (put-bytevector port src #:optional (start 0) (count (- (bytevector-length src) start))) @@ -315,7 +319,7 @@ (size (bytevector-length bv)) (cur (port-buffer-cur buf)) (end (port-buffer-end buf)) - (buffered (- end cur))) + (buffered (max (- end cur) 0))) (when (and (eq? cur end) (port-random-access? port)) (flush-input port)) (cond @@ -425,71 +429,73 @@ (else 0))) (else 1))) -(define (peek-char-and-len/utf8 port first-byte) - (define (bad-utf8 len) - (if (eq? (port-conversion-strategy port) 'substitute) - (values #\xFFFD len) - (decoding-error "peek-char" port))) +(define (peek-char-and-next-cur/utf8 port buf cur first-byte) (if (< first-byte #x80) - (values (integer->char first-byte) 1) + (values (integer->char first-byte) buf (+ cur 1)) (call-with-values (lambda () (fill-input port (cond ((<= #xc2 first-byte #xdf) 2) ((= (logand first-byte #xf0) #xe0) 3) (else 4)))) - (lambda (buf buffering) - (let* ((bv (port-buffer-bytevector buf)) - (cur (port-buffer-cur buf))) + (lambda (buf cur buffering) + (let ((bv (port-buffer-bytevector buf))) (define (bad-utf8) (let ((len (bad-utf8-len bv cur buffering first-byte))) (when (zero? len) (error "internal error")) (if (eq? (port-conversion-strategy port) 'substitute) - (values #\xFFFD len) + (values #\xFFFD buf (+ cur len)) (decoding-error "peek-char" port)))) - (decode-utf8 bv cur buffering first-byte values bad-utf8)))))) + (decode-utf8 bv cur buffering first-byte + (lambda (char len) + (values char buf (+ cur len))) + bad-utf8)))))) -(define (peek-char-and-len/iso-8859-1 port first-byte) - (values (integer->char first-byte) 1)) +(define (peek-char-and-next-cur/iso-8859-1 port buf cur first-byte) + (values (integer->char first-byte) buf (+ cur 1))) -(define (peek-char-and-len/iconv port first-byte) +(define (peek-char-and-next-cur/iconv port) (let lp ((prev-input-size 0)) (let ((input-size (1+ prev-input-size))) (call-with-values (lambda () (fill-input port input-size)) - (lambda (buf buffered) + (lambda (buf cur buffered) (cond ((< buffered input-size) ;; Buffer failed to fill; EOF, possibly premature. (cond ((zero? prev-input-size) - (values the-eof-object 0)) + (values the-eof-object buf cur)) ((eq? (port-conversion-strategy port) 'substitute) - (values #\xFFFD prev-input-size)) + (values #\xFFFD buf (+ cur prev-input-size))) (else (decoding-error "peek-char" port)))) ((port-decode-char port (port-buffer-bytevector buf) - (port-buffer-cur buf) input-size) + cur input-size) => (lambda (char) - (values char input-size))) + (values char buf (+ cur input-size)))) (else (lp input-size)))))))) -(define (peek-char-and-len port) - (let ((first-byte (peek-byte port))) - (if (not first-byte) - (values the-eof-object 0) - (case (%port-encoding port) - ((UTF-8) - (peek-char-and-len/utf8 port first-byte)) - ((ISO-8859-1) - (peek-char-and-len/iso-8859-1 port first-byte)) - (else - (peek-char-and-len/iconv port first-byte)))))) +(define (peek-char-and-next-cur port) + (define (have-byte buf bv cur buffered) + (let ((first-byte (bytevector-u8-ref bv cur))) + (case (%port-encoding port) + ((UTF-8) + (peek-char-and-next-cur/utf8 port buf cur first-byte)) + ((ISO-8859-1) + (peek-char-and-next-cur/iso-8859-1 port buf cur first-byte)) + (else + (peek-char-and-next-cur/iconv port))))) + (peek-bytes port 1 have-byte + (lambda (buf bv cur buffered) + (if (< 0 buffered) + (have-byte buf bv cur buffered) + (values the-eof-object buf cur))))) (define* (peek-char #:optional (port (current-input-port))) (define (slow-path) - (call-with-values (lambda () (peek-char-and-len port)) - (lambda (char len) + (call-with-values (lambda () (peek-char-and-next-cur port)) + (lambda (char buf cur) char))) (define (fast-path buf bv cur buffered) (let ((u8 (bytevector-u8-ref bv cur)) @@ -532,15 +538,14 @@ (advance-port-position! (port-buffer-position buf) char) char) (define (slow-path) - (call-with-values (lambda () (peek-char-and-len port)) - (lambda (char len) - (let ((buf (port-read-buffer port))) - (set-port-buffer-cur! buf (+ (port-buffer-cur buf) len)) - (if (eq? char the-eof-object) - (begin - (set-port-buffer-has-eof?! buf #f) - char) - (finish buf char)))))) + (call-with-values (lambda () (peek-char-and-next-cur port)) + (lambda (char buf cur) + (set-port-buffer-cur! buf cur) + (if (eq? char the-eof-object) + (begin + (set-port-buffer-has-eof?! buf #f) + char) + (finish buf char))))) (define (fast-path buf bv cur buffered) (let ((u8 (bytevector-u8-ref bv cur)) (enc (%port-encoding port))) @@ -559,29 +564,29 @@ (lambda (buf bv cur buffered) (slow-path)))) (define-inlinable (port-fold-chars/iso-8859-1 port proc seed) - (let fold-buffer ((buf (port-read-buffer port)) - (seed seed)) - (let ((bv (port-buffer-bytevector buf)) - (end (port-buffer-end buf))) - (let fold-chars ((cur (port-buffer-cur buf)) - (seed seed)) - (cond - ((= end cur) - (call-with-values (lambda () (fill-input port)) - (lambda (buf buffered) - (if (zero? buffered) - (call-with-values (lambda () (proc the-eof-object seed)) - (lambda (seed done?) - (if done? seed (fold-buffer buf seed)))) - (fold-buffer buf seed))))) - (else - (let ((ch (integer->char (bytevector-u8-ref bv cur))) - (cur (1+ cur))) - (set-port-buffer-cur! buf cur) - (advance-port-position! (port-buffer-position buf) ch) - (call-with-values (lambda () (proc ch seed)) - (lambda (seed done?) - (if done? seed (fold-chars cur seed))))))))))) + (let* ((buf (port-read-buffer port)) + (cur (port-buffer-cur buf))) + (let fold-buffer ((buf buf) (cur cur) (seed seed)) + (let ((bv (port-buffer-bytevector buf)) + (end (port-buffer-end buf))) + (let fold-chars ((cur cur) (seed seed)) + (cond + ((= end cur) + (call-with-values (lambda () (fill-input port)) + (lambda (buf cur buffered) + (if (zero? buffered) + (call-with-values (lambda () (proc the-eof-object seed)) + (lambda (seed done?) + (if done? seed (fold-buffer buf cur seed)))) + (fold-buffer buf cur seed))))) + (else + (let ((ch (integer->char (bytevector-u8-ref bv cur))) + (cur (1+ cur))) + (set-port-buffer-cur! buf cur) + (advance-port-position! (port-buffer-position buf) ch) + (call-with-values (lambda () (proc ch seed)) + (lambda (seed done?) + (if done? seed (fold-chars cur seed)))))))))))) (define-inlinable (port-fold-chars port proc seed) (case (%port-encoding port) From 09a69dd712536350b4b8feec8cdec3dc49cb71d5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 8 Feb 2017 15:05:03 +0100 Subject: [PATCH 683/865] Prevent TOCTTOU bugs in C ports * libguile/ports-internal.h (scm_port_buffer_can_take): (scm_port_buffer_can_put): Add cur/end output arguments so that when a caller asks the buffer room, it can be relative to a fixed point in the buffer and not whatever point it's at when we go to fill it. (scm_port_buffer_did_take, scm_port_buffer_did_put): Similarly, require that the caller knows where they took/put data in the buffer. Prevents overflow. (scm_port_buffer_take_pointer, scm_port_buffer_put_pointer): Likewise, require that the caller has already checked and knows a position in the buffer and therefore how much data is available. (scm_port_buffer_take, scm_port_buffer_put, scm_port_buffer_putback): Adapt. * libguile/ports.h (scm_fill_input): Add cur/avail output arguments. * libguile/filesys.c: * libguile/poll.c: * libguile/ports.c: * libguile/r6rs-ports.c: * libguile/read.c: * libguile/rw.c: Adapt all callers. Gnarly work! --- libguile/filesys.c | 5 +- libguile/poll.c | 10 +- libguile/ports-internal.h | 55 ++++--- libguile/ports.c | 329 +++++++++++++++++++++++--------------- libguile/ports.h | 3 +- libguile/r6rs-ports.c | 13 +- libguile/read.c | 9 +- libguile/rw.c | 3 +- 8 files changed, 251 insertions(+), 176 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index ae164fe83..9f665c107 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -647,20 +647,21 @@ set_element (fd_set *set, SCM *ports_ready, SCM element, int pos) else { int use_buf = 0; + size_t cur; element = SCM_COERCE_OUTPORT (element); SCM_ASSERT (SCM_OPFPORTP (element), element, pos, "select"); if (pos == SCM_ARG1) { /* Check whether port has input buffered. */ - if (scm_port_buffer_can_take (SCM_PORT (element)->read_buf) > 0) + if (scm_port_buffer_can_take (SCM_PORT (element)->read_buf, &cur) > 0) use_buf = 1; } else if (pos == SCM_ARG2) { /* Check whether port's output buffer has room. > 1 since writing the last byte in the buffer causes flush. */ - if (scm_port_buffer_can_put (SCM_PORT (element)->write_buf) > 1) + if (scm_port_buffer_can_put (SCM_PORT (element)->write_buf, &cur) > 1) use_buf = 1; } fd = use_buf ? -1 : SCM_FPORT_FDES (element); diff --git a/libguile/poll.c b/libguile/poll.c index 64f3cef24..a17ca4148 100644 --- a/libguile/poll.c +++ b/libguile/poll.c @@ -108,12 +108,13 @@ scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout) else { scm_t_port *pt = SCM_PORT (port); + size_t tmp; - if (scm_port_buffer_can_take (pt->read_buf) > 0) + if (scm_port_buffer_can_take (pt->read_buf, &tmp) > 0) /* Buffered input waiting to be read. */ revents |= POLLIN; if (SCM_OUTPUT_PORT_P (port) - && scm_port_buffer_can_put (pt->write_buf) > 1) + && scm_port_buffer_can_put (pt->write_buf, &tmp) > 1) /* Buffered output possible. The "> 1" is because writing the last byte would flush the port. */ revents |= POLLOUT; @@ -146,12 +147,13 @@ scm_primitive_poll (SCM pollfds, SCM nfds, SCM ports, SCM timeout) else { scm_t_port *pt = SCM_PORT (port); + size_t tmp; - if (scm_port_buffer_can_take (pt->read_buf) > 0) + if (scm_port_buffer_can_take (pt->read_buf, &tmp) > 0) /* Buffered input waiting to be read. */ revents |= POLLIN; if (SCM_OUTPUT_PORT_P (port) - && scm_port_buffer_can_put (pt->write_buf) > 1) + && scm_port_buffer_can_put (pt->write_buf, &tmp) > 1) /* Buffered output possible. The "> 1" is because writing the last byte would flush the port. */ revents |= POLLOUT; diff --git a/libguile/ports-internal.h b/libguile/ports-internal.h index 4203a5c51..be7ba60f5 100644 --- a/libguile/ports-internal.h +++ b/libguile/ports-internal.h @@ -212,22 +212,26 @@ scm_port_buffer_reset_end (SCM buf) } static inline size_t -scm_port_buffer_can_take (SCM buf) +scm_port_buffer_can_take (SCM buf, size_t *cur_out) { size_t cur, end; cur = scm_to_size_t (scm_port_buffer_cur (buf)); end = scm_to_size_t (scm_port_buffer_end (buf)); - if (cur > end || end > scm_port_buffer_size (buf)) + if (end > scm_port_buffer_size (buf)) scm_misc_error (NULL, "invalid port buffer ~a", scm_list_1 (buf)); - return end - cur; + /* If something races and we end up with end < cur, signal the caller + to do a fill_input and centralize there. */ + *cur_out = cur; + return end < cur ? 0 : end - cur; } static inline size_t -scm_port_buffer_can_put (SCM buf) +scm_port_buffer_can_put (SCM buf, size_t *end_out) { size_t end = scm_to_size_t (scm_port_buffer_end (buf)); if (end > scm_port_buffer_size (buf)) scm_misc_error (NULL, "invalid port buffer ~a", scm_list_1 (buf)); + *end_out = end; return scm_port_buffer_size (buf) - end; } @@ -241,58 +245,59 @@ scm_port_buffer_can_putback (SCM buf) } static inline void -scm_port_buffer_did_take (SCM buf, size_t count) +scm_port_buffer_did_take (SCM buf, size_t prev_cur, size_t count) { - scm_port_buffer_set_cur - (buf, SCM_I_MAKINUM (SCM_I_INUM (scm_port_buffer_cur (buf)) + count)); + scm_port_buffer_set_cur (buf, SCM_I_MAKINUM (prev_cur + count)); } static inline void -scm_port_buffer_did_put (SCM buf, size_t count) +scm_port_buffer_did_put (SCM buf, size_t prev_end, size_t count) { - scm_port_buffer_set_end - (buf, SCM_I_MAKINUM (SCM_I_INUM (scm_port_buffer_end (buf)) + count)); + scm_port_buffer_set_end (buf, SCM_I_MAKINUM (prev_end + count)); } static inline const scm_t_uint8 * -scm_port_buffer_take_pointer (SCM buf) +scm_port_buffer_take_pointer (SCM buf, size_t cur) { signed char *ret = SCM_BYTEVECTOR_CONTENTS (scm_port_buffer_bytevector (buf)); - return ((scm_t_uint8 *) ret) + scm_to_size_t (scm_port_buffer_cur (buf)); + return ((scm_t_uint8 *) ret) + cur; } static inline scm_t_uint8 * -scm_port_buffer_put_pointer (SCM buf) +scm_port_buffer_put_pointer (SCM buf, size_t end) { signed char *ret = SCM_BYTEVECTOR_CONTENTS (scm_port_buffer_bytevector (buf)); - return ((scm_t_uint8 *) ret) + scm_to_size_t (scm_port_buffer_end (buf)); + return ((scm_t_uint8 *) ret) + end; } static inline size_t -scm_port_buffer_take (SCM buf, scm_t_uint8 *dst, size_t count) +scm_port_buffer_take (SCM buf, scm_t_uint8 *dst, size_t count, + size_t cur, size_t avail) { - count = min (count, scm_port_buffer_can_take (buf)); + if (avail < count) + count = avail; if (dst) - memcpy (dst, scm_port_buffer_take_pointer (buf), count); - scm_port_buffer_did_take (buf, count); + memcpy (dst, scm_port_buffer_take_pointer (buf, cur), count); + scm_port_buffer_did_take (buf, cur, count); return count; } static inline size_t -scm_port_buffer_put (SCM buf, const scm_t_uint8 *src, size_t count) +scm_port_buffer_put (SCM buf, const scm_t_uint8 *src, size_t count, + size_t end, size_t avail) { - count = min (count, scm_port_buffer_can_put (buf)); + if (avail < count) + count = avail; if (src) - memcpy (scm_port_buffer_put_pointer (buf), src, count); - scm_port_buffer_did_put (buf, count); + memcpy (scm_port_buffer_put_pointer (buf, end), src, count); + scm_port_buffer_did_put (buf, end, count); return count; } static inline void -scm_port_buffer_putback (SCM buf, const scm_t_uint8 *src, size_t count) +scm_port_buffer_putback (SCM buf, const scm_t_uint8 *src, size_t count, + size_t cur) { - size_t cur = scm_to_size_t (scm_port_buffer_cur (buf)); - assert (count <= cur); /* Sometimes used to move around data within a buffer, so we must use diff --git a/libguile/ports.c b/libguile/ports.c index f415453c4..3d5da3d9e 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1446,7 +1446,7 @@ get_byte_or_eof (SCM port) { SCM buf = SCM_PORT (port)->read_buf; SCM buf_bv, buf_cur, buf_end; - size_t cur; + size_t cur, avail; buf_bv = scm_port_buffer_bytevector (buf); buf_cur = scm_port_buffer_cur (buf); @@ -1463,12 +1463,9 @@ get_byte_or_eof (SCM port) return ret; } - buf = scm_fill_input (port, 0); + buf = scm_fill_input (port, 0, &cur, &avail); buf_bv = scm_port_buffer_bytevector (buf); - buf_cur = scm_port_buffer_cur (buf); - buf_end = scm_port_buffer_end (buf); - cur = scm_to_size_t (buf_cur); - if (cur < scm_to_size_t (buf_end)) + if (avail > 0) { scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf_bv)[cur]; scm_port_buffer_set_cur (buf, SCM_I_MAKINUM (cur + 1)); @@ -1483,11 +1480,11 @@ get_byte_or_eof (SCM port) /* Like `scm_get_byte_or_eof' but does not change PORT's `read_pos'. */ static int -peek_byte_or_eof (SCM port) +peek_byte_or_eof (SCM port, SCM *buf_out, size_t *cur_out) { SCM buf = SCM_PORT (port)->read_buf; SCM buf_bv, buf_cur, buf_end; - size_t cur; + size_t cur, avail; buf_bv = scm_port_buffer_bytevector (buf); buf_cur = scm_port_buffer_cur (buf); @@ -1499,15 +1496,16 @@ peek_byte_or_eof (SCM port) && SCM_LIKELY (cur < SCM_BYTEVECTOR_LENGTH (buf_bv))) { scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf_bv)[cur]; + *buf_out = buf; + *cur_out = cur; return ret; } - buf = scm_fill_input (port, 0); + buf = scm_fill_input (port, 0, &cur, &avail); buf_bv = scm_port_buffer_bytevector (buf); - buf_cur = scm_port_buffer_cur (buf); - buf_end = scm_port_buffer_end (buf); - cur = scm_to_size_t (buf_cur); - if (cur < scm_to_size_t (buf_end)) + *buf_out = buf; + *cur_out = cur; + if (avail > 0) { scm_t_uint8 ret = SCM_BYTEVECTOR_CONTENTS (buf_bv)[cur]; return ret; @@ -1525,7 +1523,9 @@ scm_get_byte_or_eof (SCM port) int scm_peek_byte_or_eof (SCM port) { - return peek_byte_or_eof (port); + SCM buf; + size_t cur; + return peek_byte_or_eof (port, &buf, &cur); } static size_t @@ -1589,7 +1589,9 @@ scm_c_read_bytes (SCM port, SCM dst, size_t start, size_t count) /* Take bytes first from the port's read buffer. */ { - size_t did_read = scm_port_buffer_take (read_buf, dst_ptr, to_read); + size_t cur, avail, did_read; + avail = scm_port_buffer_can_take (read_buf, &cur); + did_read = scm_port_buffer_take (read_buf, dst_ptr, to_read, cur, avail); dst_ptr += did_read; to_read -= did_read; } @@ -1603,8 +1605,11 @@ scm_c_read_bytes (SCM port, SCM dst, size_t start, size_t count) buffer directly. */ if (to_read < pt->read_buffering) { - read_buf = scm_fill_input (port, 0); - did_read = scm_port_buffer_take (read_buf, dst_ptr, to_read); + size_t cur, avail; + + read_buf = scm_fill_input (port, 0, &cur, &avail); + did_read = scm_port_buffer_take (read_buf, dst_ptr, to_read, + cur, avail); dst_ptr += did_read; to_read -= did_read; if (did_read == 0) @@ -1652,9 +1657,10 @@ scm_c_read (SCM port, void *buffer, size_t size) while (copied < size) { - size_t count; - read_buf = scm_fill_input (port, 0); - count = scm_port_buffer_take (read_buf, dst + copied, size - copied); + size_t cur, avail, count; + read_buf = scm_fill_input (port, 0, &cur, &avail); + count = scm_port_buffer_take (read_buf, dst + copied, size - copied, + cur, avail); copied += count; if (count == 0) { @@ -1745,43 +1751,44 @@ utf8_to_codepoint (const scm_t_uint8 *utf8_buf, size_t size) that cannot begin a valid UTF-8 sequence. Otherwise signal an error. */ static scm_t_wchar -peek_utf8_codepoint (SCM port, size_t *len) +peek_utf8_codepoint (SCM port, SCM *buf_out, size_t *cur_out, size_t *len_out) { #define DECODING_ERROR(bytes) \ - do { *len = bytes; goto decoding_error; } while (0) + do { *buf_out = buf; *cur_out = cur; *len_out = bytes; goto decoding_error; } while (0) #define RETURN(bytes, codepoint) \ - do { *len = bytes; return codepoint; } while (0) + do { *buf_out = buf; *cur_out = cur; *len_out = bytes; return codepoint; } while (0) + SCM buf; + size_t cur, avail; int first_byte; + const scm_t_uint8 *ptr; - first_byte = peek_byte_or_eof (port); + first_byte = peek_byte_or_eof (port, &buf, &cur); if (first_byte == EOF) RETURN (0, EOF); else if (first_byte < 0x80) RETURN (1, first_byte); else if (first_byte >= 0xc2 && first_byte <= 0xdf) { - SCM read_buf = scm_fill_input (port, 2); - size_t can_take = scm_port_buffer_can_take (read_buf); - const scm_t_uint8 *ptr = scm_port_buffer_take_pointer (read_buf); + buf = scm_fill_input (port, 2, &cur, &avail); + ptr = scm_port_buffer_take_pointer (buf, cur); - if (can_take < 2 || (ptr[1] & 0xc0) != 0x80) + if (avail < 2 || (ptr[1] & 0xc0) != 0x80) DECODING_ERROR (1); RETURN (2, (first_byte & 0x1f) << 6UL | (ptr[1] & 0x3f)); } else if ((first_byte & 0xf0) == 0xe0) { - SCM read_buf = scm_fill_input (port, 3); - size_t can_take = scm_port_buffer_can_take (read_buf); - const scm_t_uint8 *ptr = scm_port_buffer_take_pointer (read_buf); + buf = scm_fill_input (port, 3, &cur, &avail); + ptr = scm_port_buffer_take_pointer (buf, cur); - if (can_take < 2 || (ptr[1] & 0xc0) != 0x80 + if (avail < 2 || (ptr[1] & 0xc0) != 0x80 || (ptr[0] == 0xe0 && ptr[1] < 0xa0) || (ptr[0] == 0xed && ptr[1] > 0x9f)) DECODING_ERROR (1); - if (can_take < 3 || (ptr[2] & 0xc0) != 0x80) + if (avail < 3 || (ptr[2] & 0xc0) != 0x80) DECODING_ERROR (2); RETURN (3, @@ -1791,19 +1798,18 @@ peek_utf8_codepoint (SCM port, size_t *len) } else if (first_byte >= 0xf0 && first_byte <= 0xf4) { - SCM read_buf = scm_fill_input (port, 4); - size_t can_take = scm_port_buffer_can_take (read_buf); - const scm_t_uint8 *ptr = scm_port_buffer_take_pointer (read_buf); + buf = scm_fill_input (port, 4, &cur, &avail); + ptr = scm_port_buffer_take_pointer (buf, cur); - if (can_take < 2 || (ptr[1] & 0xc0) != 0x80 + if (avail < 2 || (ptr[1] & 0xc0) != 0x80 || (ptr[0] == 0xf0 && ptr[1] < 0x90) || (ptr[0] == 0xf4 && ptr[1] > 0x8f)) DECODING_ERROR (1); - if (can_take < 3 || (ptr[2] & 0xc0) != 0x80) + if (avail < 3 || (ptr[2] & 0xc0) != 0x80) DECODING_ERROR (2); - if (can_take < 4 || (ptr[3] & 0xc0) != 0x80) + if (avail < 4 || (ptr[3] & 0xc0) != 0x80) DECODING_ERROR (3); RETURN (4, @@ -1830,9 +1836,9 @@ peek_utf8_codepoint (SCM port, size_t *len) /* Peek an ISO-8859-1 codepoint (a byte) from PORT. On success, return the codepoint, and set *LEN to 1. Otherwise on EOF set *LEN to 0. */ static scm_t_wchar -peek_latin1_codepoint (SCM port, size_t *len) +peek_latin1_codepoint (SCM port, SCM *buf, size_t *cur, size_t *len) { - scm_t_wchar ret = peek_byte_or_eof (port); + scm_t_wchar ret = peek_byte_or_eof (port, buf, cur); *len = ret == EOF ? 0 : 1; @@ -1903,16 +1909,17 @@ SCM_DEFINE (scm_port_decode_char, "port-decode-char", 4, 0, 0, shortest prefix that cannot begin a valid UTF-8 sequence. Otherwise signal an error. */ static scm_t_wchar -peek_iconv_codepoint (SCM port, size_t *len) +peek_iconv_codepoint (SCM port, SCM *buf, size_t *cur, size_t *len) { size_t input_size = 0; SCM maybe_char = SCM_BOOL_F; while (scm_is_false (maybe_char)) { - SCM read_buf = scm_fill_input (port, input_size + 1); + size_t avail; + *buf = scm_fill_input (port, input_size + 1, cur, &avail); - if (scm_port_buffer_can_take (read_buf) <= input_size) + if (avail <= input_size) { *len = input_size; if (input_size == 0) @@ -1939,8 +1946,8 @@ peek_iconv_codepoint (SCM port, size_t *len) input_size++; maybe_char = scm_port_decode_char (port, - scm_port_buffer_bytevector (read_buf), - scm_port_buffer_cur (read_buf), + scm_port_buffer_bytevector (*buf), + SCM_I_MAKINUM (*cur), SCM_I_MAKINUM (input_size)); } @@ -1952,16 +1959,16 @@ peek_iconv_codepoint (SCM port, size_t *len) the length in bytes of that representation. Return 0 on success and an errno value on error. */ static SCM_C_INLINE scm_t_wchar -peek_codepoint (SCM port, size_t *len) +peek_codepoint (SCM port, SCM *buf, size_t *cur, size_t *len) { SCM encoding = SCM_PORT (port)->encoding; if (scm_is_eq (encoding, sym_UTF_8)) - return peek_utf8_codepoint (port, len); + return peek_utf8_codepoint (port, buf, cur, len); else if (scm_is_eq (encoding, sym_ISO_8859_1)) - return peek_latin1_codepoint (port, len); + return peek_latin1_codepoint (port, buf, cur, len); else - return peek_iconv_codepoint (port, len); + return peek_iconv_codepoint (port, buf, cur, len); } /* Read a codepoint from PORT and return it. */ @@ -1970,10 +1977,12 @@ scm_getc (SCM port) #define FUNC_NAME "scm_getc" { size_t len = 0; + size_t cur; + SCM buf; scm_t_wchar codepoint; - codepoint = peek_codepoint (port, &len); - scm_port_buffer_did_take (SCM_PORT (port)->read_buf, len); + codepoint = peek_codepoint (port, &buf, &cur, &len); + scm_port_buffer_did_take (buf, cur, len); if (codepoint == EOF) scm_i_clear_pending_eof (port); update_port_position (SCM_PORT (port)->position, codepoint); @@ -2017,25 +2026,28 @@ scm_unget_bytes (const scm_t_uint8 *buf, size_t len, SCM port) { scm_t_port *pt = SCM_PORT (port); SCM read_buf = pt->read_buf; + size_t cur; if (pt->rw_random) scm_flush (port); - if (scm_port_buffer_can_putback (read_buf) < len) + cur = scm_port_buffer_can_putback (read_buf); + + if (cur < len) { /* The bytes don't fit directly in the read_buf. */ size_t buffered, size; - buffered = scm_port_buffer_can_take (read_buf); + buffered = scm_port_buffer_can_take (read_buf, &cur); size = scm_port_buffer_size (read_buf); if (len <= size - buffered) { /* But they would fit if we shift the not-yet-read bytes from the read_buf right. Let's do that. */ - const scm_t_uint8 *to_shift = scm_port_buffer_take_pointer (read_buf); + const scm_t_uint8 *to_shift = scm_port_buffer_take_pointer (read_buf, cur); scm_port_buffer_reset_end (read_buf); - scm_port_buffer_putback (read_buf, to_shift, buffered); + scm_port_buffer_putback (read_buf, to_shift, buffered, size); } else { @@ -2046,9 +2058,11 @@ scm_unget_bytes (const scm_t_uint8 *buf, size_t len, SCM port) scm_from_size_t (size), SCM_BOOL_T); } + + cur = size - buffered; } - scm_port_buffer_putback (read_buf, buf, len); + scm_port_buffer_putback (read_buf, buf, len, cur); } #undef FUNC_NAME @@ -2160,14 +2174,15 @@ SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0, "sequence when the error is raised.\n") #define FUNC_NAME s_scm_peek_char { + SCM buf; scm_t_wchar c; - size_t len = 0; + size_t cur, len = 0; if (SCM_UNBNDP (port)) port = scm_current_input_port (); SCM_VALIDATE_OPINPORT (1, port); - c = peek_codepoint (port, &len); + c = peek_codepoint (port, &buf, &cur, &len); return c == EOF ? SCM_EOF_VAL : SCM_MAKE_CHAR (c); } @@ -2249,7 +2264,7 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, scm_t_port *pt; scm_t_port_type *ptob; scm_t_bits tag_word; - size_t read_buf_size, write_buf_size; + size_t read_buf_size, write_buf_size, cur, avail; SCM saved_read_buf; port = SCM_COERCE_OUTPORT (port); @@ -2309,8 +2324,8 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, pt->read_buf = make_port_buffer (port, read_buf_size); pt->write_buf = make_port_buffer (port, write_buf_size); - scm_unget_bytes (scm_port_buffer_take_pointer (saved_read_buf), - scm_port_buffer_can_take (saved_read_buf), + avail = scm_port_buffer_can_take (saved_read_buf, &cur); + scm_unget_bytes (scm_port_buffer_take_pointer (saved_read_buf, cur), avail, port); scm_port_buffer_set_has_eof_p (pt->read_buf, scm_port_buffer_has_eof_p (saved_read_buf)); @@ -2326,7 +2341,10 @@ size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len) { SCM read_buf = SCM_PORT (port)->read_buf; - return scm_port_buffer_take (read_buf, (scm_t_uint8 *) dest, read_len); + size_t cur, avail; + avail = scm_port_buffer_can_take (read_buf, &cur); + return scm_port_buffer_take (read_buf, (scm_t_uint8 *) dest, read_len, + cur, avail); } /* Clear a port's read buffers, returning the contents. */ @@ -2348,17 +2366,17 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, #define FUNC_NAME s_scm_drain_input { SCM read_buf, result; - long count; + size_t avail, cur; SCM_VALIDATE_OPINPORT (1, port); read_buf = SCM_PORT (port)->read_buf; - count = scm_port_buffer_can_take (read_buf); + avail = scm_port_buffer_can_take (read_buf, &cur); - if (count) + if (avail) { - const scm_t_uint8 *ptr = scm_port_buffer_take_pointer (read_buf); - result = scm_from_port_stringn ((const char *) ptr, count, port); - scm_port_buffer_did_take (read_buf, count); + const scm_t_uint8 *ptr = scm_port_buffer_take_pointer (read_buf, cur); + result = scm_from_port_stringn ((const char *) ptr, avail, port); + scm_port_buffer_did_take (read_buf, cur, avail); } else result = scm_nullstr; @@ -2371,12 +2389,13 @@ void scm_end_input (SCM port) { SCM buf; - size_t discarded; + size_t cur, avail; scm_t_off offset; buf = SCM_PORT (port)->read_buf; - discarded = scm_port_buffer_take (buf, NULL, (size_t) -1); - offset = - (scm_t_off) discarded; + avail = scm_port_buffer_can_take (buf, &cur); + scm_port_buffer_did_take (buf, cur, avail); + offset = - (scm_t_off) avail; if (offset != 0) { @@ -2415,7 +2434,8 @@ void scm_flush (SCM port) { SCM buf = SCM_PORT (port)->write_buf; - if (scm_port_buffer_can_take (buf)) + size_t cur; + if (scm_port_buffer_can_take (buf, &cur)) scm_i_write (port, buf); } @@ -2425,23 +2445,24 @@ maybe_consume_bom (SCM port, const unsigned char *bom, size_t bom_len) { SCM read_buf; const scm_t_uint8 *buf; + size_t cur, avail; - if (peek_byte_or_eof (port) != bom[0]) + if (peek_byte_or_eof (port, &read_buf, &cur) != bom[0]) return 0; /* Make sure there's enough space in the buffer for a BOM. Now that we matched the first byte, we know we're going to have to read this many bytes anyway. */ - read_buf = scm_fill_input (port, bom_len); - buf = scm_port_buffer_take_pointer (read_buf); + read_buf = scm_fill_input (port, bom_len, &cur, &avail); + buf = scm_port_buffer_take_pointer (read_buf, cur); - if (scm_port_buffer_can_take (read_buf) < bom_len) + if (avail < bom_len) return 0; if (memcmp (buf, bom, bom_len) != 0) return 0; - scm_port_buffer_did_take (read_buf, bom_len); + scm_port_buffer_did_take (read_buf, cur, bom_len); return bom_len; } @@ -2552,36 +2573,38 @@ SCM_DEFINE (scm_port_clear_stream_start_for_bom_write, if (scm_is_eq (pt->encoding, sym_UTF_16)) { SCM precise_encoding; - size_t ret; + size_t end, avail, ret; scm_port_acquire_iconv_descriptors (port, NULL, NULL); precise_encoding = pt->precise_encoding; scm_port_release_iconv_descriptors (port); + avail = scm_port_buffer_can_put (buf, &end); if (scm_is_eq (precise_encoding, sym_UTF_16LE)) ret = scm_port_buffer_put (buf, scm_utf16le_bom, - sizeof (scm_utf16le_bom)); + sizeof (scm_utf16le_bom), end, avail); else ret = scm_port_buffer_put (buf, scm_utf16be_bom, - sizeof (scm_utf16be_bom)); + sizeof (scm_utf16be_bom), end, avail); return scm_from_size_t (ret); } else if (scm_is_eq (pt->encoding, sym_UTF_32)) { SCM precise_encoding; - size_t ret; + size_t end, avail, ret; scm_port_acquire_iconv_descriptors (port, NULL, NULL); precise_encoding = pt->precise_encoding; scm_port_release_iconv_descriptors (port); + avail = scm_port_buffer_can_put (buf, &end); if (scm_is_eq (precise_encoding, sym_UTF_32LE)) ret = scm_port_buffer_put (buf, scm_utf32le_bom, - sizeof (scm_utf32le_bom)); + sizeof (scm_utf32le_bom), end, avail); else ret = scm_port_buffer_put (buf, scm_utf32be_bom, - sizeof (scm_utf32be_bom)); + sizeof (scm_utf32be_bom), end, avail); return scm_from_size_t (ret); } @@ -2591,11 +2614,12 @@ SCM_DEFINE (scm_port_clear_stream_start_for_bom_write, #undef FUNC_NAME SCM -scm_fill_input (SCM port, size_t minimum_size) +scm_fill_input (SCM port, size_t minimum_size, size_t *cur_out, + size_t *avail_out) { scm_t_port *pt = SCM_PORT (port); SCM read_buf; - size_t buffered; + size_t cur, buffered; if (minimum_size == 0) minimum_size = 1; @@ -2605,11 +2629,15 @@ scm_fill_input (SCM port, size_t minimum_size) filling the input buffers. */ port_clear_stream_start_for_bom_read (port, BOM_IO_TEXT); read_buf = pt->read_buf; - buffered = scm_port_buffer_can_take (read_buf); + buffered = scm_port_buffer_can_take (read_buf, &cur); if (buffered >= minimum_size || scm_is_true (scm_port_buffer_has_eof_p (read_buf))) - return read_buf; + { + *cur_out = cur; + *avail_out = buffered; + return read_buf; + } if (pt->rw_random) scm_flush (port); @@ -2626,10 +2654,11 @@ scm_fill_input (SCM port, size_t minimum_size) scm_port_buffer_reset (read_buf); else { - const scm_t_uint8 *to_shift = scm_port_buffer_take_pointer (read_buf); + const scm_t_uint8 *to_shift; + to_shift = scm_port_buffer_take_pointer (read_buf, cur); scm_port_buffer_reset (read_buf); - memmove (scm_port_buffer_put_pointer (read_buf), to_shift, buffered); - scm_port_buffer_did_put (read_buf, buffered); + memmove (scm_port_buffer_put_pointer (read_buf, 0), to_shift, buffered); + scm_port_buffer_did_put (read_buf, 0, buffered); } while (buffered < minimum_size @@ -2645,11 +2674,14 @@ scm_fill_input (SCM port, size_t minimum_size) count = scm_i_read_bytes (port, scm_port_buffer_bytevector (read_buf), buffered, to_read); + scm_port_buffer_did_put (read_buf, buffered, count); buffered += count; - scm_port_buffer_did_put (read_buf, count); scm_port_buffer_set_has_eof_p (read_buf, scm_from_bool (count == 0)); } + /* We ensured cur was zero. */ + *cur_out = 0; + *avail_out = buffered; return read_buf; } @@ -2682,7 +2714,7 @@ SCM_DEFINE (scm_expand_port_read_buffer_x, "expand-port-read-buffer!", 2, 1, 0, #define FUNC_NAME s_scm_expand_port_read_buffer_x { scm_t_port *pt; - size_t c_size; + size_t c_size, cur, avail; SCM new_buf; SCM_VALIDATE_OPINPORT (1, port); @@ -2695,19 +2727,21 @@ SCM_DEFINE (scm_expand_port_read_buffer_x, "expand-port-read-buffer!", 2, 1, 0, new_buf = make_port_buffer (port, c_size); scm_port_buffer_set_has_eof_p (new_buf, scm_port_buffer_has_eof_p (pt->read_buf)); + avail = scm_port_buffer_can_take (pt->read_buf, &cur); + if (scm_is_true (putback_p)) { scm_port_buffer_reset_end (new_buf); scm_port_buffer_putback (new_buf, - scm_port_buffer_take_pointer (pt->read_buf), - scm_port_buffer_can_take (pt->read_buf)); + scm_port_buffer_take_pointer (pt->read_buf, cur), + avail, c_size); } else { scm_port_buffer_reset (new_buf); scm_port_buffer_put (new_buf, - scm_port_buffer_take_pointer (pt->read_buf), - scm_port_buffer_can_take (pt->read_buf)); + scm_port_buffer_take_pointer (pt->read_buf, cur), + avail, 0, c_size); } pt->read_buf = new_buf; @@ -2793,6 +2827,8 @@ scm_i_write_bytes (SCM port, SCM src, size_t start, size_t count) size_t written = 0; scm_t_port_type *ptob = SCM_PORT_TYPE (port); + if (count > SCM_BYTEVECTOR_LENGTH (src)) + fprintf (stderr, "count: %zu %zu\n", count, scm_c_bytevector_length (src)); assert (count <= SCM_BYTEVECTOR_LENGTH (src)); assert (start + count <= SCM_BYTEVECTOR_LENGTH (src)); @@ -2852,8 +2888,7 @@ scm_i_write (SCM port, SCM buf) by GC when it's open, any subsequent close-port / force-output won't signal *another* error. */ - start = scm_to_size_t (scm_port_buffer_cur (buf)); - count = scm_port_buffer_can_take (buf); + count = scm_port_buffer_can_take (buf, &start); scm_port_buffer_reset (buf); scm_i_write_bytes (port, scm_port_buffer_bytevector (buf), start, count); @@ -2881,32 +2916,43 @@ scm_c_write_bytes (SCM port, SCM src, size_t start, size_t count) if (count < scm_port_buffer_size (write_buf)) { + size_t cur, end; + /* Make it so that the write_buf "end" cursor is only nonzero if there are buffered bytes already. */ - if (scm_port_buffer_can_take (write_buf) == 0) - scm_port_buffer_reset (write_buf); + if (scm_port_buffer_can_take (write_buf, &cur) == 0) + { + scm_port_buffer_reset (write_buf); + cur = 0; + } /* We buffer writes that are smaller in size than the write buffer. If the buffer is too full to hold the new data, we flush it beforehand. Otherwise it could be that the buffer is full after filling it with the new data; if that's the case, we flush then instead. */ - if (scm_port_buffer_can_put (write_buf) < count) - scm_i_write (port, write_buf); + if (scm_port_buffer_can_put (write_buf, &end) < count) + { + scm_i_write (port, write_buf); + end = 0; + } { signed char *src_ptr = SCM_BYTEVECTOR_CONTENTS (src) + start; - scm_port_buffer_put (write_buf, (scm_t_uint8 *) src_ptr, count); + scm_port_buffer_put (write_buf, (scm_t_uint8 *) src_ptr, count, + end, count); } - if (scm_port_buffer_can_put (write_buf) == 0) + if (scm_port_buffer_can_put (write_buf, &end) == 0) scm_i_write (port, write_buf); } else { + size_t tmp; + /* Our write would overflow the buffer. Flush buffered bytes (if needed), then write our bytes with just one syscall. */ - if (scm_port_buffer_can_take (write_buf)) + if (scm_port_buffer_can_take (write_buf, &tmp)) scm_i_write (port, write_buf); scm_i_write_bytes (port, src, start, count); @@ -2923,7 +2969,7 @@ scm_c_write (SCM port, const void *ptr, size_t size) { scm_t_port *pt; SCM write_buf; - size_t written = 0; + size_t end, avail, written = 0; int using_aux_buffer = 0; const scm_t_uint8 *src = ptr; @@ -2957,13 +3003,26 @@ scm_c_write (SCM port, const void *ptr, size_t size) write_buf = scm_port_auxiliary_write_buffer (port); } + if (using_aux_buffer) + { + end = 0; + avail = AUXILIARY_WRITE_BUFFER_SIZE; + } + else + avail = scm_port_buffer_can_put (write_buf, &end); + while (written < size) { - size_t did_put = scm_port_buffer_put (write_buf, src, size - written); + size_t did_put = scm_port_buffer_put (write_buf, src, size - written, + end, avail); written += did_put; src += did_put; - if (using_aux_buffer || scm_port_buffer_can_put (write_buf) == 0) - scm_i_write (port, write_buf); + if (using_aux_buffer || did_put == avail) + { + scm_i_write (port, write_buf); + end = 0; + avail = scm_port_buffer_size (write_buf); + } } } #undef FUNC_NAME @@ -3076,8 +3135,9 @@ try_encode_char_to_iconv_buf (SCM port, SCM buf, scm_t_uint32 ch) { scm_t_uint8 utf8[UTF8_BUFFER_SIZE]; size_t utf8_len = codepoint_to_utf8 (ch, utf8); - scm_t_uint8 *aux = scm_port_buffer_put_pointer (buf); - size_t can_put = scm_port_buffer_can_put (buf); + size_t end; + size_t can_put = scm_port_buffer_can_put (buf, &end); + scm_t_uint8 *aux = scm_port_buffer_put_pointer (buf, end); iconv_t output_cd; int saved_errno; @@ -3097,7 +3157,7 @@ try_encode_char_to_iconv_buf (SCM port, SCM buf, scm_t_uint32 ch) if (res != (size_t) -1) { /* Success. */ - scm_port_buffer_did_put (buf, can_put - output_left); + scm_port_buffer_did_put (buf, end, can_put - output_left); return 1; } @@ -3142,7 +3202,7 @@ try_encode_char_to_iconv_buf (SCM port, SCM buf, scm_t_uint32 ch) if (res != (size_t) -1) { - scm_port_buffer_did_put (buf, can_put - output_left); + scm_port_buffer_did_put (buf, end, can_put - output_left); return 1; } @@ -3156,27 +3216,30 @@ static size_t encode_latin1_chars_to_latin1_buf (SCM port, SCM buf, const scm_t_uint8 *chars, size_t count) { - return scm_port_buffer_put (buf, chars, count); + size_t end; + size_t avail = scm_port_buffer_can_put (buf, &end); + return scm_port_buffer_put (buf, chars, count, end, avail); } static size_t -encode_latin1_chars_to_utf8_buf (SCM port, SCM buf, const scm_t_uint8 *chars, - size_t count) +encode_latin1_chars_to_utf8_buf (SCM port, SCM buf, + const scm_t_uint8 *chars, size_t count) { - scm_t_uint8 *dst = scm_port_buffer_put_pointer (buf); - size_t buf_size = scm_port_buffer_can_put (buf); + size_t end; + size_t buf_size = scm_port_buffer_can_put (buf, &end); + scm_t_uint8 *dst = scm_port_buffer_put_pointer (buf, end); size_t read, written; for (read = 0, written = 0; read < count && written + UTF8_BUFFER_SIZE < buf_size; read++) written += codepoint_to_utf8 (chars[read], dst + written); - scm_port_buffer_did_put (buf, written); + scm_port_buffer_did_put (buf, end, written); return read; } static size_t -encode_latin1_chars_to_iconv_buf (SCM port, SCM buf, const scm_t_uint8 *chars, - size_t count) +encode_latin1_chars_to_iconv_buf (SCM port, SCM buf, + const scm_t_uint8 *chars, size_t count) { size_t read; for (read = 0; read < count; read++) @@ -3216,8 +3279,9 @@ encode_utf32_chars_to_latin1_buf (SCM port, SCM buf, const scm_t_uint32 *chars, size_t count) { scm_t_port *pt = SCM_PORT (port); - scm_t_uint8 *dst = scm_port_buffer_put_pointer (buf); - size_t buf_size = scm_port_buffer_can_put (buf); + size_t end; + size_t buf_size = scm_port_buffer_can_put (buf, &end); + scm_t_uint8 *dst = scm_port_buffer_put_pointer (buf, end); size_t read, written; for (read = 0, written = 0; read < count && written < buf_size; read++) { @@ -3238,7 +3302,7 @@ encode_utf32_chars_to_latin1_buf (SCM port, SCM buf, else break; } - scm_port_buffer_did_put (buf, written); + scm_port_buffer_did_put (buf, end, written); return read; } @@ -3246,14 +3310,15 @@ static size_t encode_utf32_chars_to_utf8_buf (SCM port, SCM buf, const scm_t_uint32 *chars, size_t count) { - scm_t_uint8 *dst = scm_port_buffer_put_pointer (buf); - size_t buf_size = scm_port_buffer_can_put (buf); + size_t end; + size_t buf_size = scm_port_buffer_can_put (buf, &end); + scm_t_uint8 *dst = scm_port_buffer_put_pointer (buf, end); size_t read, written; for (read = 0, written = 0; read < count && written + UTF8_BUFFER_SIZE < buf_size; read++) written += codepoint_to_utf8 (chars[read], dst + written); - scm_port_buffer_did_put (buf, written); + scm_port_buffer_did_put (buf, end, written); return read; } @@ -3580,6 +3645,7 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, #define FUNC_NAME s_scm_char_ready_p { SCM read_buf; + size_t tmp; if (SCM_UNBNDP (port)) port = scm_current_input_port (); @@ -3589,7 +3655,7 @@ SCM_DEFINE (scm_char_ready_p, "char-ready?", 0, 1, 0, read_buf = SCM_PORT (port)->read_buf; - if (scm_port_buffer_can_take (read_buf) || + if (scm_port_buffer_can_take (read_buf, &tmp) || scm_is_true (scm_port_buffer_has_eof_p (read_buf))) /* FIXME: Verify that a whole character is available? */ return SCM_BOOL_T; @@ -3656,6 +3722,7 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, if (ptob->seek && how == SEEK_CUR && off == 0) { + size_t tmp; /* If we are just querying the current position, avoid flushing buffers. We don't even need to require that the port supports random access. */ @@ -3663,8 +3730,8 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0, scm_dynwind_acquire_port (fd_port); rv = ptob->seek (fd_port, off, how); scm_dynwind_end (); - rv -= scm_port_buffer_can_take (pt->read_buf); - rv += scm_port_buffer_can_take (pt->write_buf); + rv -= scm_port_buffer_can_take (pt->read_buf, &tmp); + rv += scm_port_buffer_can_take (pt->write_buf, &tmp); return scm_from_off_t_or_off64_t (rv); } diff --git a/libguile/ports.h b/libguile/ports.h index 93a1a59de..d131db5be 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -199,7 +199,8 @@ SCM_API SCM scm_unread_string (SCM str, SCM port); /* Manipulating the buffers. */ SCM_API SCM scm_setvbuf (SCM port, SCM mode, SCM size); -SCM_API SCM scm_fill_input (SCM port, size_t minimum_size); +SCM_INTERNAL SCM scm_fill_input (SCM port, size_t minimum_size, + size_t *cur_out, size_t *avail_out); SCM_INTERNAL size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len); SCM_API SCM scm_drain_input (SCM port); SCM_API void scm_end_input (SCM port); diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index 674d89aaa..b919b4bdf 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -482,22 +482,21 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0, #define FUNC_NAME s_scm_get_bytevector_some { SCM buf; - size_t size; + size_t cur, avail; SCM bv; SCM_VALIDATE_BINARY_INPUT_PORT (1, port); - buf = scm_fill_input (port, 0); - size = scm_port_buffer_can_take (buf); - if (size == 0) + buf = scm_fill_input (port, 0, &cur, &avail); + if (avail == 0) { scm_port_buffer_set_has_eof_p (buf, SCM_BOOL_F); return SCM_EOF_VAL; } - bv = scm_c_make_bytevector (size); - scm_take_from_input_buffers - (port, (char *) SCM_BYTEVECTOR_CONTENTS (bv), size); + bv = scm_c_make_bytevector (avail); + scm_port_buffer_take (buf, (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bv), + avail, cur, avail); return bv; } diff --git a/libguile/read.c b/libguile/read.c index c7da054b0..5c436e2b2 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -2080,7 +2080,7 @@ scm_i_scan_for_encoding (SCM port) scm_t_port *pt; SCM buf; char header[SCM_ENCODING_SEARCH_SIZE+1]; - size_t bytes_read, encoding_length, i; + size_t cur, bytes_read, encoding_length, i; char *encoding = NULL; char *pos, *encoding_start; int in_comment; @@ -2091,11 +2091,10 @@ scm_i_scan_for_encoding (SCM port) if (pt->rw_random) scm_flush (port); - if (scm_port_buffer_can_take (buf) == 0) + if (scm_port_buffer_can_take (buf, &cur) == 0) { /* We can use the read buffer, and thus avoid a seek. */ - buf = scm_fill_input (port, 0); - bytes_read = scm_port_buffer_can_take (buf); + buf = scm_fill_input (port, 0, &cur, &bytes_read); if (bytes_read > SCM_ENCODING_SEARCH_SIZE) bytes_read = SCM_ENCODING_SEARCH_SIZE; @@ -2103,7 +2102,7 @@ scm_i_scan_for_encoding (SCM port) /* An unbuffered port -- don't scan. */ return NULL; - memcpy (header, scm_port_buffer_take_pointer (buf), bytes_read); + memcpy (header, scm_port_buffer_take_pointer (buf, cur), bytes_read); header[bytes_read] = '\0'; } else diff --git a/libguile/rw.c b/libguile/rw.c index 16dee5802..70bcd81a0 100644 --- a/libguile/rw.c +++ b/libguile/rw.c @@ -232,6 +232,7 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0, SCM port = (SCM_UNBNDP (port_or_fdes)? scm_current_output_port () : port_or_fdes); SCM write_buf; + size_t end; SCM_VALIDATE_OPFPORT (2, port); SCM_VALIDATE_OUTPUT_PORT (2, port); @@ -239,7 +240,7 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0, /* Filling the last character in the buffer would require a flush. */ - if (write_len < scm_port_buffer_can_put (write_buf)) + if (write_len < scm_port_buffer_can_put (write_buf, &end)) { scm_c_write (port, src, write_len); return scm_from_long (write_len); From 710ebfddc6845237ada24300940967ebb6ae38c1 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 8 Feb 2017 15:14:49 +0100 Subject: [PATCH 684/865] Web server and client use suspendable ports * module/web/request.scm (write-request): * module/web/response.scm (write-response): Use put-string instead of display. --- module/web/request.scm | 3 ++- module/web/response.scm | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/module/web/request.scm b/module/web/request.scm index 0a206cf35..c9f1dc1ac 100644 --- a/module/web/request.scm +++ b/module/web/request.scm @@ -22,6 +22,7 @@ (define-module (web request) #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) + #:use-module (ice-9 textual-ports) #:use-module (ice-9 rdelim) #:use-module (srfi srfi-9) #:use-module (web uri) @@ -214,7 +215,7 @@ on PORT, perhaps using some transfer encoding." (write-request-line (request-method r) (request-uri r) (request-version r) port) (write-headers (request-headers r) port) - (display "\r\n" port) + (put-string port "\r\n") (if (eq? port (request-port r)) r (make-request (request-method r) (request-uri r) (request-version r) diff --git a/module/web/response.scm b/module/web/response.scm index 614abcd55..06e1c6dc1 100644 --- a/module/web/response.scm +++ b/module/web/response.scm @@ -22,6 +22,7 @@ (define-module (web response) #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) + #:use-module (ice-9 textual-ports) #:use-module (ice-9 rdelim) #:use-module (ice-9 match) #:use-module (srfi srfi-9) @@ -220,7 +221,7 @@ on PORT, perhaps using some transfer encoding." (write-response-line (response-version r) (response-code r) (response-reason-phrase r) port) (write-headers (response-headers r) port) - (display "\r\n" port) + (put-string port "\r\n") (if (eq? port (response-port r)) r (make-response (response-version r) (response-code r) From 5048a8afbc00e3e0a65a5d2ffccfec666ec5a68b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 12 Feb 2017 18:02:53 +0100 Subject: [PATCH 685/865] Avoid reading garbage from dynstack * libguile/dynstack.c (push_dynstack_entry_unchecked): Reset top dynstack tag to prevent garbage. --- libguile/dynstack.c | 1 + 1 file changed, 1 insertion(+) diff --git a/libguile/dynstack.c b/libguile/dynstack.c index 652d2b35a..1eb1dcf38 100644 --- a/libguile/dynstack.c +++ b/libguile/dynstack.c @@ -113,6 +113,7 @@ push_dynstack_entry_unchecked (scm_t_dynstack *dynstack, SCM_DYNSTACK_SET_TAG (dynstack->top, SCM_MAKE_DYNSTACK_TAG (type, flags, len)); dynstack->top += SCM_DYNSTACK_HEADER_LEN + len; + SCM_DYNSTACK_SET_TAG (dynstack->top, 0); SCM_DYNSTACK_SET_PREV_OFFSET (dynstack->top, SCM_DYNSTACK_HEADER_LEN + len); return ret; From 00ed4043c258b35d9200b9be3070c24355e46b63 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 12 Feb 2017 18:22:44 +0100 Subject: [PATCH 686/865] VM continuations store FP/SP by offset * libguile/continuations.c (scm_i_continuation_to_frame): * libguile/stacks.c (scm_make_stack): * libguile/vm.c (scm_i_vm_cont_to_frame, scm_i_vm_capture_stack): (vm_return_to_continuation_inner) (struct vm_reinstate_partial_continuation_data): (vm_reinstate_partial_continuation_inner): (vm_reinstate_partial_continuation): * libguile/vm.h (sstruct scm_vm_cont): Simplify VM continuations by recording the top FP by offset, not value + reloc. * libguile/frames.c (frame_offset, scm_i_vm_frame_offset): Remove unused functions. * libguile/frames.h (SCM_VALIDATE_VM_FRAME, scm_i_vm_frame_offset): Remove. * libguile/control.c (reify_partial_continuation): Once we know the base_fp, relocate the dynamic stack. * libguile/dynstack.h: * libguile/dynstack.c (scm_dynstack_relocate_prompts): New function. (scm_dynstack_wind_prompt): Adapt to add new fp offset. --- libguile/continuations.c | 3 +-- libguile/control.c | 2 ++ libguile/dynstack.c | 27 ++++++++++++++++++++++++--- libguile/dynstack.h | 3 +++ libguile/frames.c | 28 ---------------------------- libguile/frames.h | 2 -- libguile/stacks.c | 5 +---- libguile/vm.c | 32 +++++++++----------------------- libguile/vm.h | 11 +++++++++-- 9 files changed, 49 insertions(+), 64 deletions(-) diff --git a/libguile/continuations.c b/libguile/continuations.c index 3eb31a0f9..e0f8cd64c 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -184,10 +184,9 @@ scm_i_continuation_to_frame (SCM continuation, struct scm_frame *frame) struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont->vm_cont); union scm_vm_stack_element *stack_top; - /* FIXME vm_cont should hold fp/sp offsets */ stack_top = data->stack_bottom + data->stack_size; frame->stack_holder = data; - frame->fp_offset = stack_top - (data->fp + data->reloc); + frame->fp_offset = data->fp_offset; frame->sp_offset = data->stack_size; frame->ip = data->ra; diff --git a/libguile/control.c b/libguile/control.c index 6691d551f..636718d02 100644 --- a/libguile/control.c +++ b/libguile/control.c @@ -113,6 +113,8 @@ reify_partial_continuation (struct scm_vm *vp, if (SCM_FRAME_DYNAMIC_LINK (base_fp) != saved_fp) abort(); + scm_dynstack_relocate_prompts (dynstack, vp->stack_top - base_fp); + /* Capture from the base_fp to the top thunk application frame. */ vm_cont = scm_i_vm_capture_stack (base_fp, vp->fp, vp->sp, vp->ip, dynstack, flags); diff --git a/libguile/dynstack.c b/libguile/dynstack.c index 1eb1dcf38..7448a9ab5 100644 --- a/libguile/dynstack.c +++ b/libguile/dynstack.c @@ -37,7 +37,9 @@ #define PROMPT_WORDS 5 #define PROMPT_KEY(top) (SCM_PACK ((top)[0])) #define PROMPT_FP(top) ((scm_t_ptrdiff) ((top)[1])) +#define SET_PROMPT_FP(top, fp) do { top[1] = (scm_t_bits)(fp); } while (0) #define PROMPT_SP(top) ((scm_t_ptrdiff) ((top)[2])) +#define SET_PROMPT_SP(top, sp) do { top[2] = (scm_t_bits)(sp); } while (0) #define PROMPT_IP(top) ((scm_t_uint32 *) ((top)[3])) #define PROMPT_JMPBUF(top) ((scm_i_jmp_buf *) ((top)[4])) @@ -287,6 +289,24 @@ scm_dynstack_capture (scm_t_dynstack *dynstack, scm_t_bits *item) return ret; } +void +scm_dynstack_relocate_prompts (scm_t_dynstack *dynstack, scm_t_ptrdiff base) +{ + scm_t_bits *walk; + + /* Relocate prompts. */ + for (walk = dynstack->top; walk; walk = SCM_DYNSTACK_PREV (walk)) + { + scm_t_bits tag = SCM_DYNSTACK_TAG (walk); + + if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT) + { + SET_PROMPT_FP (walk, PROMPT_FP (walk) - base); + SET_PROMPT_SP (walk, PROMPT_SP (walk) - base); + } + } +} + void scm_dynstack_wind_1 (scm_t_dynstack *dynstack, scm_t_bits *item) { @@ -556,7 +576,8 @@ scm_dynstack_find_old_fluid_value (scm_t_dynstack *dynstack, SCM fluid, void scm_dynstack_wind_prompt (scm_t_dynstack *dynstack, scm_t_bits *item, - scm_t_ptrdiff reloc, scm_i_jmp_buf *registers) + scm_t_ptrdiff base_fp_offset, + scm_i_jmp_buf *registers) { scm_t_bits tag = SCM_DYNSTACK_TAG (item); @@ -566,8 +587,8 @@ scm_dynstack_wind_prompt (scm_t_dynstack *dynstack, scm_t_bits *item, scm_dynstack_push_prompt (dynstack, SCM_DYNSTACK_TAG_FLAGS (tag), PROMPT_KEY (item), - PROMPT_FP (item) - reloc, - PROMPT_SP (item) - reloc, + PROMPT_FP (item) + base_fp_offset, + PROMPT_SP (item) + base_fp_offset, PROMPT_IP (item), registers); } diff --git a/libguile/dynstack.h b/libguile/dynstack.h index 7e191fc27..bd34d25a8 100644 --- a/libguile/dynstack.h +++ b/libguile/dynstack.h @@ -204,6 +204,9 @@ SCM_INTERNAL scm_t_bits* scm_dynstack_find_prompt (scm_t_dynstack *, SCM, SCM_INTERNAL SCM scm_dynstack_find_old_fluid_value (scm_t_dynstack *, SCM, size_t, SCM); +SCM_INTERNAL void scm_dynstack_relocate_prompts (scm_t_dynstack *, + scm_t_ptrdiff); + SCM_INTERNAL void scm_dynstack_wind_prompt (scm_t_dynstack *, scm_t_bits *, scm_t_ptrdiff, scm_i_jmp_buf *); diff --git a/libguile/frames.c b/libguile/frames.c index bc2e501da..11d4f12ee 100644 --- a/libguile/frames.c +++ b/libguile/frames.c @@ -76,22 +76,6 @@ frame_stack_top (enum scm_vm_frame_kind kind, const struct scm_frame *frame) } } -static scm_t_ptrdiff -frame_offset (enum scm_vm_frame_kind kind, const struct scm_frame *frame) -{ - switch (kind) - { - case SCM_VM_FRAME_KIND_CONT: - return ((struct scm_vm_cont *) frame->stack_holder)->reloc; - - case SCM_VM_FRAME_KIND_VM: - return 0; - - default: - abort (); - } -} - union scm_vm_stack_element* scm_i_frame_stack_top (SCM frame) #define FUNC_NAME "frame-stack-top" @@ -103,18 +87,6 @@ scm_i_frame_stack_top (SCM frame) } #undef FUNC_NAME -scm_t_ptrdiff -scm_i_frame_offset (SCM frame) -#define FUNC_NAME "frame-offset" -{ - SCM_VALIDATE_VM_FRAME (1, frame); - - return frame_offset (SCM_VM_FRAME_KIND (frame), - SCM_VM_FRAME_DATA (frame)); - -} -#undef FUNC_NAME - /* Scheme interface */ diff --git a/libguile/frames.h b/libguile/frames.h index ef668a9ce..ef2db3df5 100644 --- a/libguile/frames.h +++ b/libguile/frames.h @@ -139,11 +139,9 @@ enum scm_vm_frame_kind #define SCM_VM_FRAME_FP(f) (scm_i_frame_stack_top (f) - SCM_VM_FRAME_FP_OFFSET (f)) #define SCM_VM_FRAME_SP(f) (scm_i_frame_stack_top (f) - SCM_VM_FRAME_SP_OFFSET (f)) #define SCM_VM_FRAME_IP(f) SCM_VM_FRAME_DATA (f)->ip -#define SCM_VM_FRAME_OFFSET(f) scm_i_frame_offset (f) #define SCM_VALIDATE_VM_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_FRAME_P) SCM_INTERNAL union scm_vm_stack_element* scm_i_frame_stack_top (SCM frame); -SCM_INTERNAL scm_t_ptrdiff scm_i_frame_offset (SCM frame); /* See notes in frames.c before using this. */ SCM_INTERNAL SCM scm_c_frame_closure (enum scm_vm_frame_kind kind, diff --git a/libguile/stacks.c b/libguile/stacks.c index 99ee233e3..5679bec42 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -319,16 +319,13 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, { SCM cont; struct scm_vm_cont *c; - union scm_vm_stack_element *stack_top; cont = scm_i_capture_current_stack (); c = SCM_VM_CONT_DATA (cont); - /* FIXME vm_cont should hold fp/sp offsets */ - stack_top = c->stack_bottom + c->stack_size; kind = SCM_VM_FRAME_KIND_CONT; frame.stack_holder = c; - frame.fp_offset = stack_top - (c->fp + c->reloc); + frame.fp_offset = c->fp_offset; frame.sp_offset = c->stack_size; frame.ip = c->ra; } diff --git a/libguile/vm.c b/libguile/vm.c index 194f989ad..be30517c5 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -118,11 +118,9 @@ int scm_i_vm_cont_to_frame (SCM cont, struct scm_frame *frame) { struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont); - union scm_vm_stack_element *stack_top; - stack_top = data->stack_bottom + data->stack_size; frame->stack_holder = data; - frame->fp_offset = stack_top - (data->fp + data->reloc); + frame->fp_offset = data->fp_offset; frame->sp_offset = data->stack_size; frame->ip = data->ra; @@ -145,9 +143,8 @@ scm_i_vm_capture_stack (union scm_vm_stack_element *stack_top, p->stack_bottom = scm_gc_malloc (p->stack_size * sizeof (*p->stack_bottom), "capture_vm_cont"); p->ra = ra; - p->fp = fp; + p->fp_offset = stack_top - fp; memcpy (p->stack_bottom, sp, p->stack_size * sizeof (*p->stack_bottom)); - p->reloc = (p->stack_bottom + p->stack_size) - stack_top; p->dynstack = dynstack; p->flags = flags; return scm_cell (scm_tc7_vm_cont, (scm_t_bits) p); @@ -167,19 +164,15 @@ vm_return_to_continuation_inner (void *data_ptr) struct return_to_continuation_data *data = data_ptr; struct scm_vm *vp = data->vp; struct scm_vm_cont *cp = data->cp; - union scm_vm_stack_element *cp_stack_top; - scm_t_ptrdiff reloc; /* We know that there is enough space for the continuation, because we captured it in the past. However there may have been an expansion since the capture, so we may have to re-link the frame pointers. */ - cp_stack_top = cp->stack_bottom + cp->stack_size; - reloc = (vp->stack_top - (cp_stack_top - cp->reloc)); - vp->fp = cp->fp + reloc; memcpy (vp->stack_top - cp->stack_size, cp->stack_bottom, cp->stack_size * sizeof (*cp->stack_bottom)); + vp->fp = vp->stack_top - cp->fp_offset; vm_restore_sp (vp, vp->stack_top - cp->stack_size); return NULL; @@ -351,7 +344,6 @@ struct vm_reinstate_partial_continuation_data { struct scm_vm *vp; struct scm_vm_cont *cp; - scm_t_ptrdiff reloc; }; static void * @@ -360,21 +352,14 @@ vm_reinstate_partial_continuation_inner (void *data_ptr) struct vm_reinstate_partial_continuation_data *data = data_ptr; struct scm_vm *vp = data->vp; struct scm_vm_cont *cp = data->cp; - union scm_vm_stack_element *base_fp; - scm_t_ptrdiff reloc; - base_fp = vp->fp; - reloc = cp->reloc + (base_fp - (cp->stack_bottom + cp->stack_size)); - - memcpy (base_fp - cp->stack_size, + memcpy (vp->fp - cp->stack_size, cp->stack_bottom, cp->stack_size * sizeof (*cp->stack_bottom)); - vp->fp = cp->fp + reloc; + vp->fp -= cp->fp_offset; vp->ip = cp->ra; - data->reloc = reloc; - return NULL; } @@ -386,19 +371,20 @@ vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont, size_t nargs, struct vm_reinstate_partial_continuation_data data; struct scm_vm_cont *cp; union scm_vm_stack_element *args; - scm_t_ptrdiff reloc; + scm_t_ptrdiff old_fp_offset; args = alloca (nargs * sizeof (*args)); memcpy (args, vp->sp, nargs * sizeof (*args)); cp = SCM_VM_CONT_DATA (cont); + old_fp_offset = vp->stack_top - vp->fp; + vm_push_sp (vp, vp->fp - (cp->stack_size + nargs + 1)); data.vp = vp; data.cp = cp; GC_call_with_alloc_lock (vm_reinstate_partial_continuation_inner, &data); - reloc = data.reloc; /* The resume continuation will expect ARGS on the stack as if from a multiple-value return. Fill in the closure slot with #f, and copy @@ -419,7 +405,7 @@ vm_reinstate_partial_continuation (struct scm_vm *vp, SCM cont, size_t nargs, scm_t_bits tag = SCM_DYNSTACK_TAG (walk); if (SCM_DYNSTACK_TAG_TYPE (tag) == SCM_DYNSTACK_TYPE_PROMPT) - scm_dynstack_wind_prompt (dynstack, walk, reloc, registers); + scm_dynstack_wind_prompt (dynstack, walk, old_fp_offset, registers); else scm_dynstack_wind_1 (dynstack, walk); } diff --git a/libguile/vm.h b/libguile/vm.h index b26f7f406..a1cac391f 100644 --- a/libguile/vm.h +++ b/libguile/vm.h @@ -80,12 +80,19 @@ SCM_INTERNAL void scm_i_vm_free_stack (struct scm_vm *vp); #define SCM_F_VM_CONT_REWINDABLE 0x2 struct scm_vm_cont { - union scm_vm_stack_element *fp; + /* IP of newest frame. */ scm_t_uint32 *ra; + /* Offset of FP of newest frame, relative to stack top. */ + scm_t_ptrdiff fp_offset; + /* Besides being the stack size, this is also the offset of the SP of + the newest frame. */ scm_t_ptrdiff stack_size; + /* Stack bottom, which also keeps saved stack alive for GC. */ union scm_vm_stack_element *stack_bottom; - scm_t_ptrdiff reloc; + /* Saved dynamic stack, with prompts relocated to record saved SP/FP + offsets from the stack top of this scm_vm_cont. */ scm_t_dynstack *dynstack; + /* See the continuation is partial and/or rewindable. */ scm_t_uint32 flags; }; From 8e1af70c2c4ccc7fb19afa48ffd4662f95bb0f66 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 12 Feb 2017 20:33:37 +0100 Subject: [PATCH 687/865] Remove unused variable in continuations.c * libguile/continuations.c (scm_i_continuation_to_frame): Remove unused variable. --- libguile/continuations.c | 1 - 1 file changed, 1 deletion(-) diff --git a/libguile/continuations.c b/libguile/continuations.c index e0f8cd64c..1c0392dbf 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -182,7 +182,6 @@ scm_i_continuation_to_frame (SCM continuation, struct scm_frame *frame) if (scm_is_true (cont->vm_cont)) { struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont->vm_cont); - union scm_vm_stack_element *stack_top; stack_top = data->stack_bottom + data->stack_size; frame->stack_holder = data; From 2c02bdda191eecd998c33b00c56752b8ec7378ab Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 13 Feb 2017 10:13:27 +0100 Subject: [PATCH 688/865] Fix compilation of continuations.c * libguile/continuations.c (scm_i_continuation_to_frame): Remove unused assignment. The previous commit removed the declaration in order to silence an unused-assignment warning, but forgot to remove the assignment :/ --- libguile/continuations.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/libguile/continuations.c b/libguile/continuations.c index 1c0392dbf..80914bc04 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 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 License @@ -183,7 +183,6 @@ scm_i_continuation_to_frame (SCM continuation, struct scm_frame *frame) { struct scm_vm_cont *data = SCM_VM_CONT_DATA (cont->vm_cont); - stack_top = data->stack_bottom + data->stack_size; frame->stack_holder = data; frame->fp_offset = data->fp_offset; frame->sp_offset = data->stack_size; From 69ca2bb2217303b2556b131f3995ca4f6af81234 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 14 Feb 2017 21:57:35 +0100 Subject: [PATCH 689/865] Elide syscalls in fdes->port * libguile/fports.h (scm_t_fport): Add options field. (SCM_FDES_RANDOM_P): Deprecate. (scm_i_fdes_to_port): Add options argument. * libguile/fports.c (scm_i_fdes_to_port): Add options argument. Only verify FD if SCM_FPORT_OPTION_VERIFY is there. (scm_fdes_to_port, scm_open_file_with_encoding): Adapt to scm_i_fdes_to_port changes. (fport_random_access_p): Don't try to seek if NOT_SEEKABLE option is set. * libguile/deprecated.h: * libguile/deprecated.c (SCM_FDES_RANDOM_P): Deprecate. * NEWS: Add deprecation. * libguile/filesys.c: * libguile/ioext.c: * libguile/posix.c: * libguile/read.c: * libguile/socket.c: Adapt callers. --- NEWS | 11 +++++++++ libguile/deprecated.c | 14 +++++++++++ libguile/deprecated.h | 4 ++++ libguile/filesys.c | 2 +- libguile/fports.c | 56 +++++++++++++++++++++++++++---------------- libguile/fports.h | 29 +++++++++++++++------- libguile/ioext.c | 3 ++- libguile/posix.c | 14 +++++++---- libguile/read.c | 16 +++++-------- libguile/socket.c | 14 +++++++---- 10 files changed, 114 insertions(+), 49 deletions(-) diff --git a/NEWS b/NEWS index 5680a2032..46b09b9ae 100644 --- a/NEWS +++ b/NEWS @@ -5,6 +5,17 @@ See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. + +Changes in 2.1.7 (changes since the 2.1.6 alpha release): + +* New deprecations + +** `SCM_FDES_RANDOM_P' + +Instead, use `lseek (fd, 0, SEEK_CUR)' directly. + +* FIXME fold in 2.1.6 changes to main NEWS + Changes in 2.1.6 (changes since the 2.1.5 alpha release): diff --git a/libguile/deprecated.c b/libguile/deprecated.c index c3d4935d0..cee6b1d74 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -26,6 +26,9 @@ #define SCM_BUILDING_DEPRECATED_CODE +#include +#include + #include "libguile/_scm.h" #include "libguile/deprecation.h" @@ -938,6 +941,17 @@ scm_make_dynamic_state (SCM parent) } + + +int +SCM_FDES_RANDOM_P (int fdes) +{ + scm_c_issue_deprecation_warning + ("SCM_FDES_RANDOM_P is deprecated. Use lseek (fd, 0, SEEK_CUR)."); + + return (lseek (fdes, 0, SEEK_CUR) == -1) ? 0 : 1; +} + void diff --git a/libguile/deprecated.h b/libguile/deprecated.h index b1e455a89..2c49076a1 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -270,6 +270,10 @@ SCM_DEPRECATED SCM scm_from_contiguous_array (SCM bounds, const SCM *elts, +SCM_DEPRECATED int SCM_FDES_RANDOM_P (int fdes); + + + void scm_i_init_deprecated (void); #endif diff --git a/libguile/filesys.c b/libguile/filesys.c index 9f665c107..40d5a41d3 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1509,7 +1509,7 @@ SCM_DEFINE (scm_i_mkstemp, "mkstemp!", 1, 1, 0, scm_dynwind_end (); - port = scm_i_fdes_to_port (rv, mode_bits, tmpl); + port = scm_i_fdes_to_port (rv, mode_bits, tmpl, 0); if (is_binary) /* Use the binary-friendly ISO-8859-1 encoding. */ scm_i_set_port_encoding_x (port, NULL); diff --git a/libguile/fports.c b/libguile/fports.c index 8fa69933d..f79b4a3a8 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -264,7 +264,8 @@ scm_open_file_with_encoding (SCM filename, SCM mode, /* Create a port from this file descriptor. The port's encoding is initially %default-port-encoding. */ port = scm_i_fdes_to_port (fdes, scm_i_mode_bits (mode), - fport_canonicalize_filename (filename)); + fport_canonicalize_filename (filename), + 0); if (binary) { @@ -391,35 +392,41 @@ SCM_DEFINE (scm_i_open_file, "open-file", 2, 0, 1, NAME is a string to be used as the port's filename. */ SCM -scm_i_fdes_to_port (int fdes, long mode_bits, SCM name) +scm_i_fdes_to_port (int fdes, long mode_bits, SCM name, unsigned options) #define FUNC_NAME "scm_fdes_to_port" { SCM port; scm_t_fport *fp; - /* Test that fdes is valid. */ -#ifdef F_GETFL - int flags = fcntl (fdes, F_GETFL, 0); - if (flags == -1) - SCM_SYSERROR; - flags &= O_ACCMODE; - if (flags != O_RDWR - && ((flags != O_WRONLY && (mode_bits & SCM_WRTNG)) - || (flags != O_RDONLY && (mode_bits & SCM_RDNG)))) + if (options & SCM_FPORT_OPTION_VERIFY) { - SCM_MISC_ERROR ("requested file mode not available on fdes", SCM_EOL); - } + /* Check that the foreign FD is valid and matches the mode + bits. */ +#ifdef F_GETFL + int flags = fcntl (fdes, F_GETFL, 0); + if (flags == -1) + SCM_SYSERROR; + flags &= O_ACCMODE; + if (flags != O_RDWR + && ((flags != O_WRONLY && (mode_bits & SCM_WRTNG)) + || (flags != O_RDONLY && (mode_bits & SCM_RDNG)))) + { + SCM_MISC_ERROR ("requested file mode not available on fdes", + SCM_EOL); + } #else - /* If we don't have F_GETFL, as on mingw, at least we can test that - it is a valid file descriptor. */ - struct stat st; - if (fstat (fdes, &st) != 0) - SCM_SYSERROR; + /* If we don't have F_GETFL, as on mingw, at least we can test that + it is a valid file descriptor. */ + struct stat st; + if (fstat (fdes, &st) != 0) + SCM_SYSERROR; #endif + } fp = (scm_t_fport *) scm_gc_malloc_pointerless (sizeof (scm_t_fport), "file port"); fp->fdes = fdes; + fp->options = options; port = scm_c_make_port (scm_file_port_type, mode_bits, (scm_t_bits)fp); @@ -432,7 +439,8 @@ scm_i_fdes_to_port (int fdes, long mode_bits, SCM name) SCM scm_fdes_to_port (int fdes, char *mode, SCM name) { - return scm_i_fdes_to_port (fdes, scm_mode_bits (mode), name); + return scm_i_fdes_to_port (fdes, scm_mode_bits (mode), name, + SCM_FPORT_OPTION_VERIFY); } /* Return a lower bound on the number of bytes available for input. */ @@ -669,7 +677,15 @@ fport_close (SCM port) static int fport_random_access_p (SCM port) { - return SCM_FDES_RANDOM_P (SCM_FSTREAM (port)->fdes); + scm_t_fport *fp = SCM_FSTREAM (port); + + if (fp->options & SCM_FPORT_OPTION_NOT_SEEKABLE) + return 0; + + if (lseek (fp->fdes, 0, SEEK_CUR) == -1) + return 0; + + return 1; } static int diff --git a/libguile/fports.h b/libguile/fports.h index ee9bf7cbd..afb8ba771 100644 --- a/libguile/fports.h +++ b/libguile/fports.h @@ -31,10 +31,13 @@ /* struct allocated for each buffered FPORT. */ typedef struct scm_t_fport { - int fdes; /* file descriptor. */ - int revealed; /* 0 not revealed, > 1 revealed. - * Revealed ports do not get GC'd. - */ + /* The file descriptor. */ + int fdes; + /* Revealed count; 0 indicates not revealed, > 1 revealed. Revealed + ports do not get garbage-collected. */ + int revealed; + /* Set of scm_fport_option flags. */ + unsigned options; } scm_t_fport; SCM_API scm_t_port_type *scm_file_port_type; @@ -48,9 +51,6 @@ SCM_API scm_t_port_type *scm_file_port_type; #define SCM_OPINFPORTP(x) (SCM_OPFPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_RDNG)) #define SCM_OPOUTFPORTP(x) (SCM_OPFPORTP (x) && (SCM_CELL_WORD_0 (x) & SCM_WRTNG)) -/* test whether fdes supports random access. */ -#define SCM_FDES_RANDOM_P(fdes) ((lseek (fdes, 0, SEEK_CUR) == -1) ? 0 : 1) - SCM_API void scm_evict_ports (int fd); SCM_INTERNAL int scm_i_mode_to_open_flags (SCM mode, int *is_binary, @@ -74,8 +74,19 @@ SCM_INTERNAL void scm_init_fports (void); /* internal functions */ -SCM_INTERNAL SCM scm_i_fdes_to_port (int fdes, long mode_bits, SCM name); - +#ifdef BUILDING_LIBGUILE +enum scm_fport_option + { + /* FD's that aren't created by Guile probably need to be checked for + validity. We also check that the open mode is valid. */ + SCM_FPORT_OPTION_VERIFY = 1U<<0, + /* We know some ports aren't seekable and can elide a syscall in + that case. */ + SCM_FPORT_OPTION_NOT_SEEKABLE = 1U<<1 + }; +SCM_INTERNAL SCM scm_i_fdes_to_port (int fdes, long mode_bits, SCM name, + unsigned options); +#endif /* BUILDING_LIBGUILE */ #endif /* SCM_FPORTS_H */ diff --git a/libguile/ioext.c b/libguile/ioext.c index 43c915a09..4038fd54f 100644 --- a/libguile/ioext.c +++ b/libguile/ioext.c @@ -226,7 +226,8 @@ SCM_DEFINE (scm_fdopen, "fdopen", 2, 0, 0, #define FUNC_NAME s_scm_fdopen { return scm_i_fdes_to_port (scm_to_int (fdes), - scm_i_mode_bits (modes), SCM_BOOL_F); + scm_i_mode_bits (modes), SCM_BOOL_F, + SCM_FPORT_OPTION_VERIFY); } #undef FUNC_NAME diff --git a/libguile/posix.c b/libguile/posix.c index 495bfbbb8..686b801ff 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -242,8 +242,10 @@ SCM_DEFINE (scm_pipe, "pipe", 0, 0, 0, if (rv) SCM_SYSERROR; - p_rd = scm_fdes_to_port (fd[0], "r", sym_read_pipe); - p_wt = scm_fdes_to_port (fd[1], "w", sym_write_pipe); + p_rd = scm_i_fdes_to_port (fd[0], scm_mode_bits ("r"), sym_read_pipe, + SCM_FPORT_OPTION_NOT_SEEKABLE); + p_wt = scm_i_fdes_to_port (fd[1], scm_mode_bits ("w"), sym_write_pipe, + SCM_FPORT_OPTION_NOT_SEEKABLE); return scm_cons (p_rd, p_wt); } #undef FUNC_NAME @@ -1418,12 +1420,16 @@ scm_open_process (SCM mode, SCM prog, SCM args) if (reading) { close (c2p[1]); - read_port = scm_fdes_to_port (c2p[0], "r0", sym_read_pipe); + read_port = scm_i_fdes_to_port (c2p[0], scm_mode_bits ("r0"), + sym_read_pipe, + SCM_FPORT_OPTION_NOT_SEEKABLE); } if (writing) { close (p2c[0]); - write_port = scm_fdes_to_port (p2c[1], "w0", sym_write_pipe); + write_port = scm_i_fdes_to_port (p2c[1], scm_mode_bits ("w0"), + sym_write_pipe, + SCM_FPORT_OPTION_NOT_SEEKABLE); } return scm_values (scm_list_3 (read_port, diff --git a/libguile/read.c b/libguile/read.c index 5c436e2b2..085cdb9f1 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -2105,21 +2105,17 @@ scm_i_scan_for_encoding (SCM port) memcpy (header, scm_port_buffer_take_pointer (buf, cur), bytes_read); header[bytes_read] = '\0'; } - else + else if (pt->rw_random) { - /* Try to read some bytes and then seek back. Not all ports - support seeking back; and indeed some file ports (like - /dev/urandom) will succeed on an lseek (fd, 0, SEEK_CUR)---the - check performed by SCM_FPORT_FDES---but fail to seek - backwards. Hence this block comes second. We prefer to use - the read buffer in-place. */ - if (SCM_FPORTP (port) && !SCM_FDES_RANDOM_P (SCM_FPORT_FDES (port))) - return NULL; - + /* The port is seekable. This is OK but grubbing in the read + buffer is better, so this case is just a fallback. */ bytes_read = scm_c_read (port, header, SCM_ENCODING_SEARCH_SIZE); header[bytes_read] = '\0'; scm_seek (port, scm_from_int (0), scm_from_int (SEEK_SET)); } + else + /* No input available and not seekable; scan fails. */ + return NULL; /* search past "coding[:=]" */ pos = header; diff --git a/libguile/socket.c b/libguile/socket.c index 37e9f523f..4f2acffd7 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -367,7 +367,12 @@ SCM_DEFINE (scm_inet_pton, "inet-pton", 2, 0, 0, SCM_SYMBOL (sym_socket, "socket"); -#define SCM_SOCK_FD_TO_PORT(fd) scm_fdes_to_port (fd, "r+0", sym_socket) +static SCM +scm_socket_fd_to_port (int fd) +{ + return scm_i_fdes_to_port (fd, scm_mode_bits ("r+0"), sym_socket, + SCM_FPORT_OPTION_NOT_SEEKABLE); +} SCM_DEFINE (scm_socket, "socket", 3, 0, 0, (SCM family, SCM style, SCM proto), @@ -391,7 +396,7 @@ SCM_DEFINE (scm_socket, "socket", 3, 0, 0, scm_to_int (proto)); if (fd == -1) SCM_SYSERROR; - return SCM_SOCK_FD_TO_PORT (fd); + return scm_socket_fd_to_port (fd); } #undef FUNC_NAME @@ -413,7 +418,8 @@ SCM_DEFINE (scm_socketpair, "socketpair", 3, 0, 0, if (socketpair (fam, scm_to_int (style), scm_to_int (proto), fd) == -1) SCM_SYSERROR; - return scm_cons (SCM_SOCK_FD_TO_PORT (fd[0]), SCM_SOCK_FD_TO_PORT (fd[1])); + return scm_cons (scm_socket_fd_to_port (fd[0]), + scm_socket_fd_to_port (fd[1])); } #undef FUNC_NAME #endif @@ -1269,7 +1275,7 @@ SCM_DEFINE (scm_accept, "accept", 1, 0, 0, return SCM_BOOL_F; SCM_SYSERROR; } - newsock = SCM_SOCK_FD_TO_PORT (newfd); + newsock = scm_socket_fd_to_port (newfd); address = _scm_from_sockaddr (&addr, addr_size, FUNC_NAME); From 7e641595cd9b45ce7339e21c20a8ab81af9278f6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 15 Feb 2017 21:41:24 +0100 Subject: [PATCH 690/865] Update Gnulib to v0.1-1157-gb03f418. --- GNUmakefile | 2 +- build-aux/announce-gen | 2 +- build-aux/config.rpath | 2 +- build-aux/gendocs.sh | 6 +- build-aux/git-version-gen | 6 +- build-aux/gitlog-to-changelog | 2 +- build-aux/gnu-web-doc-update | 2 +- build-aux/gnupload | 2 +- build-aux/snippet/arg-nonnull.h | 2 +- build-aux/snippet/c++defs.h | 89 +++- build-aux/snippet/warn-on-use.h | 2 +- build-aux/useless-if-before-free | 7 +- build-aux/vc-list-files | 2 +- doc/gendocs_template | 2 +- doc/gendocs_template_min | 2 +- lib/Makefile.am | 68 ++- lib/accept.c | 2 +- lib/alignof.h | 2 +- lib/alloca.in.h | 4 +- lib/arpa_inet.in.h | 2 +- lib/asnprintf.c | 2 +- lib/assure.h | 2 +- lib/basename-lgpl.c | 2 +- lib/binary-io.h | 2 +- lib/bind.c | 2 +- lib/btowc.c | 2 +- lib/byteswap.in.h | 2 +- lib/c-ctype.h | 22 +- lib/c-strcase.h | 2 +- lib/c-strcasecmp.c | 2 +- lib/c-strcaseeq.h | 2 +- lib/c-strncasecmp.c | 2 +- lib/canonicalize-lgpl.c | 39 +- lib/ceil.c | 2 +- lib/close.c | 2 +- lib/config.charset | 2 +- lib/connect.c | 2 +- lib/copysign.c | 2 +- lib/dirent.in.h | 2 +- lib/dirfd.c | 2 +- lib/dirname-lgpl.c | 2 +- lib/dirname.h | 2 +- lib/dosname.h | 2 +- lib/dup2.c | 2 +- lib/duplocale.c | 2 +- lib/errno.in.h | 2 +- lib/fcntl.in.h | 2 +- lib/fd-hook.c | 2 +- lib/fd-hook.h | 2 +- lib/flexmember.h | 42 ++ lib/float+.h | 2 +- lib/float.c | 2 +- lib/float.in.h | 2 +- lib/flock.c | 2 +- lib/floor.c | 2 +- lib/frexp.c | 2 +- lib/fstat.c | 2 +- lib/fsync.c | 2 +- lib/full-read.c | 2 +- lib/full-read.h | 2 +- lib/full-write.c | 2 +- lib/full-write.h | 2 +- lib/gai_strerror.c | 2 +- lib/getaddrinfo.c | 2 +- lib/getlogin.c | 2 +- lib/getpeername.c | 2 +- lib/getsockname.c | 2 +- lib/getsockopt.c | 2 +- lib/gettext.h | 2 +- lib/gettimeofday.c | 2 +- lib/hard-locale.c | 2 +- lib/hard-locale.h | 2 +- lib/iconv.c | 2 +- lib/iconv.in.h | 2 +- lib/iconv_close.c | 2 +- lib/iconv_open.c | 2 +- lib/iconveh.h | 2 +- lib/inet_ntop.c | 2 +- lib/inet_pton.c | 2 +- lib/intprops.h | 57 ++- lib/isfinite.c | 2 +- lib/isinf.c | 2 +- lib/isnan.c | 2 +- lib/isnand-nolibm.h | 2 +- lib/isnand.c | 2 +- lib/isnanf-nolibm.h | 2 +- lib/isnanf.c | 2 +- lib/isnanl-nolibm.h | 2 +- lib/isnanl.c | 2 +- lib/itold.c | 2 +- lib/langinfo.in.h | 2 +- lib/limits.in.h | 63 +++ lib/link.c | 2 +- lib/listen.c | 2 +- lib/localcharset.c | 4 +- lib/localcharset.h | 2 +- lib/locale.in.h | 2 +- lib/localeconv.c | 2 +- lib/log.c | 2 +- lib/log1p.c | 2 +- lib/lstat.c | 2 +- lib/malloc.c | 2 +- lib/malloca.c | 2 +- lib/malloca.h | 15 +- lib/math.in.h | 201 +++++++-- lib/mbrtowc.c | 2 +- lib/mbsinit.c | 2 +- lib/mbtowc-impl.h | 2 +- lib/mbtowc.c | 2 +- lib/memchr.c | 2 +- lib/mkdir.c | 2 +- lib/mkostemp.c | 2 +- lib/mktime-internal.h | 2 +- lib/mktime.c | 4 +- lib/msvc-inval.c | 2 +- lib/msvc-inval.h | 2 +- lib/msvc-nothrow.c | 2 +- lib/msvc-nothrow.h | 2 +- lib/netdb.in.h | 2 +- lib/netinet_in.in.h | 2 +- lib/nl_langinfo.c | 39 +- lib/nproc.c | 2 +- lib/nproc.h | 2 +- lib/open.c | 2 +- lib/pathmax.h | 2 +- lib/pipe.c | 2 +- lib/pipe2.c | 2 +- lib/poll.c | 2 +- lib/poll.in.h | 2 +- lib/printf-args.c | 2 +- lib/printf-args.h | 2 +- lib/printf-parse.c | 2 +- lib/printf-parse.h | 2 +- lib/putenv.c | 2 +- lib/raise.c | 2 +- lib/read.c | 2 +- lib/readlink.c | 2 +- lib/recv.c | 2 +- lib/recvfrom.c | 2 +- lib/ref-add.sin | 2 +- lib/ref-del.sin | 2 +- lib/regcomp.c | 2 +- lib/regex.c | 2 +- lib/regex.h | 8 +- lib/regex_internal.c | 2 +- lib/regex_internal.h | 10 +- lib/regexec.c | 8 +- lib/rename.c | 2 +- lib/rmdir.c | 2 +- lib/round.c | 2 +- lib/safe-read.c | 2 +- lib/safe-read.h | 2 +- lib/safe-write.c | 2 +- lib/safe-write.h | 2 +- lib/same-inode.h | 8 +- lib/secure_getenv.c | 2 +- lib/select.c | 2 +- lib/send.c | 2 +- lib/sendto.c | 2 +- lib/setenv.c | 2 +- lib/setsockopt.c | 2 +- lib/shutdown.c | 2 +- lib/signal.in.h | 2 +- lib/signbitd.c | 2 +- lib/signbitf.c | 2 +- lib/signbitl.c | 2 +- lib/size_max.h | 2 +- lib/snprintf.c | 2 +- lib/socket.c | 2 +- lib/sockets.c | 2 +- lib/sockets.h | 8 +- lib/stat-time.h | 4 +- lib/stat.c | 2 +- lib/stdalign.in.h | 2 +- lib/stdbool.in.h | 2 +- lib/stddef.in.h | 2 +- lib/stdint.in.h | 736 +++++++++++++++++-------------- lib/stdio.in.h | 22 +- lib/stdlib.in.h | 17 +- lib/strdup.c | 2 +- lib/streq.h | 2 +- lib/strftime.c | 178 +++++--- lib/strftime.h | 2 +- lib/striconveh.c | 2 +- lib/striconveh.h | 2 +- lib/string.in.h | 18 +- lib/stripslash.c | 2 +- lib/sys_file.in.h | 2 +- lib/sys_select.in.h | 2 +- lib/sys_socket.in.h | 7 +- lib/sys_stat.in.h | 2 +- lib/sys_time.in.h | 9 +- lib/sys_times.in.h | 2 +- lib/sys_types.in.h | 2 +- lib/sys_uio.in.h | 2 +- lib/tempname.c | 2 +- lib/tempname.h | 2 +- lib/time-internal.h | 6 +- lib/time.in.h | 4 +- lib/time_r.c | 2 +- lib/time_rz.c | 5 +- lib/timegm.c | 2 +- lib/times.c | 2 +- lib/trunc.c | 2 +- lib/unistd.in.h | 8 +- lib/unsetenv.c | 2 +- lib/vasnprintf.c | 4 +- lib/vasnprintf.h | 2 +- lib/verify.h | 9 +- lib/vsnprintf.c | 2 +- lib/w32sock.h | 2 +- lib/wchar.in.h | 9 +- lib/wcrtomb.c | 2 +- lib/wctype.in.h | 23 +- lib/write.c | 2 +- lib/xalloc-oversized.h | 60 +++ lib/xsize.h | 2 +- m4/00gnulib.m4 | 2 +- m4/absolute-header.m4 | 2 +- m4/alloca.m4 | 2 +- m4/arpa_inet_h.m4 | 2 +- m4/autobuild.m4 | 2 +- m4/btowc.m4 | 2 +- m4/builtin-expect.m4 | 49 ++ m4/byteswap.m4 | 2 +- m4/canonicalize.m4 | 2 +- m4/ceil.m4 | 2 +- m4/check-math-lib.m4 | 2 +- m4/clock_time.m4 | 2 +- m4/close.m4 | 2 +- m4/configmake.m4 | 2 +- m4/copysign.m4 | 2 +- m4/dirent_h.m4 | 2 +- m4/dirfd.m4 | 2 +- m4/dirname.m4 | 2 +- m4/double-slash-root.m4 | 2 +- m4/dup2.m4 | 2 +- m4/duplocale.m4 | 2 +- m4/eealloc.m4 | 2 +- m4/environ.m4 | 2 +- m4/errno_h.m4 | 2 +- m4/exponentd.m4 | 2 +- m4/exponentf.m4 | 2 +- m4/exponentl.m4 | 2 +- m4/extensions.m4 | 46 +- m4/extern-inline.m4 | 2 +- m4/fcntl-o.m4 | 2 +- m4/fcntl_h.m4 | 2 +- m4/flexmember.m4 | 10 +- m4/float_h.m4 | 2 +- m4/flock.m4 | 2 +- m4/floor.m4 | 2 +- m4/fpieee.m4 | 2 +- m4/frexp.m4 | 2 +- m4/fstat.m4 | 2 +- m4/fsync.m4 | 2 +- m4/func.m4 | 2 +- m4/getaddrinfo.m4 | 6 +- m4/getlogin.m4 | 22 +- m4/gettimeofday.m4 | 2 +- m4/glibc21.m4 | 2 +- m4/gnulib-cache.m4 | 2 +- m4/gnulib-common.m4 | 2 +- m4/gnulib-comp.m4 | 29 +- m4/gnulib-tool.m4 | 2 +- m4/hard-locale.m4 | 2 +- m4/hostent.m4 | 2 +- m4/iconv.m4 | 24 +- m4/iconv_h.m4 | 2 +- m4/iconv_open-utf.m4 | 2 +- m4/iconv_open.m4 | 2 +- m4/include_next.m4 | 2 +- m4/inet_ntop.m4 | 2 +- m4/inet_pton.m4 | 2 +- m4/intmax_t.m4 | 2 +- m4/inttypes_h.m4 | 2 +- m4/isfinite.m4 | 2 +- m4/isinf.m4 | 2 +- m4/isnan.m4 | 2 +- m4/isnand.m4 | 2 +- m4/isnanf.m4 | 2 +- m4/isnanl.m4 | 2 +- m4/langinfo_h.m4 | 2 +- m4/largefile.m4 | 2 +- m4/ld-version-script.m4 | 2 +- m4/ldexp.m4 | 2 +- m4/lib-ld.m4 | 2 +- m4/lib-link.m4 | 2 +- m4/lib-prefix.m4 | 2 +- m4/libunistring.m4 | 2 +- m4/limits-h.m4 | 31 ++ m4/link.m4 | 3 +- m4/localcharset.m4 | 2 +- m4/locale-fr.m4 | 2 +- m4/locale-ja.m4 | 2 +- m4/locale-zh.m4 | 2 +- m4/locale_h.m4 | 2 +- m4/localeconv.m4 | 2 +- m4/log.m4 | 2 +- m4/log1p.m4 | 2 +- m4/longlong.m4 | 2 +- m4/lstat.m4 | 2 +- m4/malloc.m4 | 2 +- m4/malloca.m4 | 2 +- m4/math_h.m4 | 16 +- m4/mathfunc.m4 | 2 +- m4/mbrtowc.m4 | 14 +- m4/mbsinit.m4 | 2 +- m4/mbstate_t.m4 | 2 +- m4/mbtowc.m4 | 2 +- m4/memchr.m4 | 2 +- m4/mkdir.m4 | 2 +- m4/mkostemp.m4 | 2 +- m4/mktime.m4 | 2 +- m4/mmap-anon.m4 | 2 +- m4/mode_t.m4 | 2 +- m4/msvc-inval.m4 | 2 +- m4/msvc-nothrow.m4 | 2 +- m4/multiarch.m4 | 2 +- m4/netdb_h.m4 | 2 +- m4/netinet_in_h.m4 | 2 +- m4/nl_langinfo.m4 | 2 +- m4/nocrash.m4 | 2 +- m4/nproc.m4 | 7 +- m4/off_t.m4 | 2 +- m4/open.m4 | 2 +- m4/pathmax.m4 | 2 +- m4/pipe.m4 | 2 +- m4/pipe2.m4 | 2 +- m4/poll.m4 | 2 +- m4/poll_h.m4 | 2 +- m4/printf.m4 | 4 +- m4/putenv.m4 | 2 +- m4/raise.m4 | 2 +- m4/read.m4 | 2 +- m4/readlink.m4 | 2 +- m4/regex.m4 | 2 +- m4/rename.m4 | 2 +- m4/rmdir.m4 | 2 +- m4/round.m4 | 2 +- m4/safe-read.m4 | 2 +- m4/safe-write.m4 | 2 +- m4/secure_getenv.m4 | 2 +- m4/select.m4 | 2 +- m4/servent.m4 | 2 +- m4/setenv.m4 | 2 +- m4/signal_h.m4 | 2 +- m4/signbit.m4 | 2 +- m4/size_max.m4 | 2 +- m4/snprintf.m4 | 12 +- m4/socketlib.m4 | 2 +- m4/sockets.m4 | 2 +- m4/socklen.m4 | 2 +- m4/sockpfaf.m4 | 2 +- m4/ssize_t.m4 | 2 +- m4/stat-time.m4 | 2 +- m4/stat.m4 | 2 +- m4/stdalign.m4 | 2 +- m4/stdbool.m4 | 30 +- m4/stddef_h.m4 | 2 +- m4/stdint.m4 | 66 ++- m4/stdint_h.m4 | 2 +- m4/stdio_h.m4 | 14 +- m4/stdlib_h.m4 | 7 +- m4/strdup.m4 | 2 +- m4/strftime.m4 | 2 +- m4/string_h.m4 | 2 +- m4/sys_file_h.m4 | 2 +- m4/sys_select_h.m4 | 2 +- m4/sys_socket_h.m4 | 2 +- m4/sys_stat_h.m4 | 2 +- m4/sys_time_h.m4 | 2 +- m4/sys_times_h.m4 | 2 +- m4/sys_types_h.m4 | 29 +- m4/sys_uio_h.m4 | 2 +- m4/tempname.m4 | 2 +- m4/time_h.m4 | 2 +- m4/time_r.m4 | 2 +- m4/time_rz.m4 | 2 +- m4/timegm.m4 | 2 +- m4/times.m4 | 2 +- m4/tm_gmtoff.m4 | 2 +- m4/trunc.m4 | 2 +- m4/unistd_h.m4 | 5 +- m4/vasnprintf.m4 | 2 +- m4/visibility.m4 | 2 +- m4/vsnprintf.m4 | 12 +- m4/warn-on-use.m4 | 2 +- m4/warnings.m4 | 2 +- m4/wchar_h.m4 | 16 +- m4/wchar_t.m4 | 2 +- m4/wcrtomb.m4 | 2 +- m4/wctype_h.m4 | 2 +- m4/wint_t.m4 | 36 +- m4/write.m4 | 2 +- m4/xsize.m4 | 2 +- maint.mk | 105 +++-- 397 files changed, 1995 insertions(+), 1095 deletions(-) create mode 100644 lib/flexmember.h create mode 100644 lib/limits.in.h create mode 100644 lib/xalloc-oversized.h create mode 100644 m4/builtin-expect.m4 create mode 100644 m4/limits-h.m4 diff --git a/GNUmakefile b/GNUmakefile index a869da5bf..a2f81118e 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -5,7 +5,7 @@ # It is necessary if you want to build targets usually of interest # only to the maintainer. -# Copyright (C) 2001, 2003, 2006-2016 Free Software Foundation, Inc. +# Copyright (C) 2001, 2003, 2006-2017 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/build-aux/announce-gen b/build-aux/announce-gen index b46117459..e789b13a8 100755 --- a/build-aux/announce-gen +++ b/build-aux/announce-gen @@ -9,7 +9,7 @@ my $VERSION = '2016-01-12 23:09'; # UTC # If you change this file with Emacs, please let the write hook # do its job. Otherwise, update this string manually. -# Copyright (C) 2002-2016 Free Software Foundation, Inc. +# Copyright (C) 2002-2017 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/build-aux/config.rpath b/build-aux/config.rpath index 98183ff2f..af3c41559 100755 --- a/build-aux/config.rpath +++ b/build-aux/config.rpath @@ -2,7 +2,7 @@ # Output a system dependent set of variables, describing how to set the # run time search path of shared libraries in an executable. # -# Copyright 1996-2016 Free Software Foundation, Inc. +# Copyright 1996-2017 Free Software Foundation, Inc. # Taken from GNU libtool, 2001 # Originally by Gordon Matzigkeit , 1996 # diff --git a/build-aux/gendocs.sh b/build-aux/gendocs.sh index fef6280a2..3b71b36a2 100755 --- a/build-aux/gendocs.sh +++ b/build-aux/gendocs.sh @@ -2,9 +2,9 @@ # gendocs.sh -- generate a GNU manual in many formats. This script is # mentioned in maintain.texi. See the help message below for usage details. -scriptversion=2016-05-20.09 +scriptversion=2016-12-31.18 -# Copyright 2003-2016 Free Software Foundation, Inc. +# Copyright 2003-2017 Free Software Foundation, Inc. # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -72,7 +72,7 @@ texarg="-t @finalout" version="gendocs.sh $scriptversion -Copyright 2016 Free Software Foundation, Inc. +Copyright 2017 Free Software Foundation, Inc. There is NO warranty. You may redistribute this software under the terms of the GNU General Public License. For more information about these matters, see the files named COPYING." diff --git a/build-aux/git-version-gen b/build-aux/git-version-gen index 9e5e4fb11..c1c18c0c5 100755 --- a/build-aux/git-version-gen +++ b/build-aux/git-version-gen @@ -1,8 +1,8 @@ #!/bin/sh # Print a version string. -scriptversion=2016-05-08.18; # UTC +scriptversion=2017-01-09.19; # UTC -# Copyright (C) 2007-2016 Free Software Foundation, Inc. +# Copyright (C) 2007-2017 Free Software Foundation, Inc. # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -206,7 +206,7 @@ v=`echo "$v" |sed "s/^$prefix//"` # string we're using came from git. I.e., skip the test if it's "UNKNOWN" # or if it came from .tarball-version. if test "x$v_from_git" != x; then - # Don't declare a version "dirty" merely because a time stamp has changed. + # Don't declare a version "dirty" merely because a timestamp has changed. git update-index --refresh > /dev/null 2>&1 dirty=`exec 2>/dev/null;git diff-index --name-only HEAD` || dirty= diff --git a/build-aux/gitlog-to-changelog b/build-aux/gitlog-to-changelog index 83bafdffa..cf1642546 100755 --- a/build-aux/gitlog-to-changelog +++ b/build-aux/gitlog-to-changelog @@ -9,7 +9,7 @@ my $VERSION = '2016-03-22 21:49'; # UTC # If you change this file with Emacs, please let the write hook # do its job. Otherwise, update this string manually. -# Copyright (C) 2008-2016 Free Software Foundation, Inc. +# Copyright (C) 2008-2017 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/build-aux/gnu-web-doc-update b/build-aux/gnu-web-doc-update index 271e69370..a8ed60952 100755 --- a/build-aux/gnu-web-doc-update +++ b/build-aux/gnu-web-doc-update @@ -4,7 +4,7 @@ VERSION=2016-01-12.23; # UTC -# Copyright (C) 2009-2016 Free Software Foundation, Inc. +# Copyright (C) 2009-2017 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/build-aux/gnupload b/build-aux/gnupload index 8d0299d69..d4d95ee9b 100755 --- a/build-aux/gnupload +++ b/build-aux/gnupload @@ -3,7 +3,7 @@ scriptversion=2016-01-11.22; # UTC -# Copyright (C) 2004-2016 Free Software Foundation, Inc. +# Copyright (C) 2004-2017 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/build-aux/snippet/arg-nonnull.h b/build-aux/snippet/arg-nonnull.h index 584649f69..1e62cc898 100644 --- a/build-aux/snippet/arg-nonnull.h +++ b/build-aux/snippet/arg-nonnull.h @@ -1,5 +1,5 @@ /* A C macro for declaring that specific arguments must not be NULL. - Copyright (C) 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published diff --git a/build-aux/snippet/c++defs.h b/build-aux/snippet/c++defs.h index 813f2e2e4..f03f3591c 100644 --- a/build-aux/snippet/c++defs.h +++ b/build-aux/snippet/c++defs.h @@ -1,5 +1,5 @@ /* C++ compatible function declaration macros. - Copyright (C) 2010-2016 Free Software Foundation, Inc. + Copyright (C) 2010-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published @@ -17,6 +17,15 @@ #ifndef _GL_CXXDEFS_H #define _GL_CXXDEFS_H +/* Begin/end the GNULIB_NAMESPACE namespace. */ +#if defined __cplusplus && defined GNULIB_NAMESPACE +# define _GL_BEGIN_NAMESPACE namespace GNULIB_NAMESPACE { +# define _GL_END_NAMESPACE } +#else +# define _GL_BEGIN_NAMESPACE +# define _GL_END_NAMESPACE +#endif + /* The three most frequent use cases of these macros are: * For providing a substitute for a function that is missing on some @@ -111,14 +120,25 @@ that redirects to rpl_func, if GNULIB_NAMESPACE is defined. Example: _GL_CXXALIAS_RPL (open, int, (const char *filename, int flags, ...)); - */ + + Wrapping rpl_func in an object with an inline conversion operator + avoids a reference to rpl_func unless GNULIB_NAMESPACE::func is + actually used in the program. */ #define _GL_CXXALIAS_RPL(func,rettype,parameters) \ _GL_CXXALIAS_RPL_1 (func, rpl_##func, rettype, parameters) #if defined __cplusplus && defined GNULIB_NAMESPACE # define _GL_CXXALIAS_RPL_1(func,rpl_func,rettype,parameters) \ namespace GNULIB_NAMESPACE \ { \ - rettype (*const func) parameters = ::rpl_func; \ + static const struct _gl_ ## func ## _wrapper \ + { \ + typedef rettype (*type) parameters; \ + \ + inline operator type () const \ + { \ + return ::rpl_func; \ + } \ + } func = {}; \ } \ _GL_EXTERN_C int _gl_cxxalias_dummy #else @@ -135,8 +155,15 @@ # define _GL_CXXALIAS_RPL_CAST_1(func,rpl_func,rettype,parameters) \ namespace GNULIB_NAMESPACE \ { \ - rettype (*const func) parameters = \ - reinterpret_cast(::rpl_func); \ + static const struct _gl_ ## func ## _wrapper \ + { \ + typedef rettype (*type) parameters; \ + \ + inline operator type () const \ + { \ + return reinterpret_cast(::rpl_func); \ + } \ + } func = {}; \ } \ _GL_EXTERN_C int _gl_cxxalias_dummy #else @@ -150,19 +177,24 @@ is defined. Example: _GL_CXXALIAS_SYS (open, int, (const char *filename, int flags, ...)); - */ + + Wrapping func in an object with an inline conversion operator + avoids a reference to func unless GNULIB_NAMESPACE::func is + actually used in the program. */ #if defined __cplusplus && defined GNULIB_NAMESPACE - /* If we were to write - rettype (*const func) parameters = ::func; - like above in _GL_CXXALIAS_RPL_1, the compiler could optimize calls - better (remove an indirection through a 'static' pointer variable), - but then the _GL_CXXALIASWARN macro below would cause a warning not only - for uses of ::func but also for uses of GNULIB_NAMESPACE::func. */ -# define _GL_CXXALIAS_SYS(func,rettype,parameters) \ - namespace GNULIB_NAMESPACE \ - { \ - static rettype (*func) parameters = ::func; \ - } \ +# define _GL_CXXALIAS_SYS(func,rettype,parameters) \ + namespace GNULIB_NAMESPACE \ + { \ + static const struct _gl_ ## func ## _wrapper \ + { \ + typedef rettype (*type) parameters; \ + \ + inline operator type () const \ + { \ + return ::func; \ + } \ + } func = {}; \ + } \ _GL_EXTERN_C int _gl_cxxalias_dummy #else # define _GL_CXXALIAS_SYS(func,rettype,parameters) \ @@ -178,8 +210,15 @@ # define _GL_CXXALIAS_SYS_CAST(func,rettype,parameters) \ namespace GNULIB_NAMESPACE \ { \ - static rettype (*func) parameters = \ - reinterpret_cast(::func); \ + static const struct _gl_ ## func ## _wrapper \ + { \ + typedef rettype (*type) parameters; \ + \ + inline operator type () const \ + { \ + return reinterpret_cast(::func); \ + } \ + } func = {}; \ } \ _GL_EXTERN_C int _gl_cxxalias_dummy #else @@ -202,9 +241,15 @@ # define _GL_CXXALIAS_SYS_CAST2(func,rettype,parameters,rettype2,parameters2) \ namespace GNULIB_NAMESPACE \ { \ - static rettype (*func) parameters = \ - reinterpret_cast( \ - (rettype2(*)parameters2)(::func)); \ + static const struct _gl_ ## func ## _wrapper \ + { \ + typedef rettype (*type) parameters; \ + \ + inline operator type () const \ + { \ + return reinterpret_cast((rettype2 (*) parameters2)(::func)); \ + } \ + } func = {}; \ } \ _GL_EXTERN_C int _gl_cxxalias_dummy #else diff --git a/build-aux/snippet/warn-on-use.h b/build-aux/snippet/warn-on-use.h index 2948b4788..3c0eb579f 100644 --- a/build-aux/snippet/warn-on-use.h +++ b/build-aux/snippet/warn-on-use.h @@ -1,5 +1,5 @@ /* A C macro for emitting warnings if a function is used. - Copyright (C) 2010-2016 Free Software Foundation, Inc. + Copyright (C) 2010-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published diff --git a/build-aux/useless-if-before-free b/build-aux/useless-if-before-free index 1899b1ffd..4e3f3a265 100755 --- a/build-aux/useless-if-before-free +++ b/build-aux/useless-if-before-free @@ -4,13 +4,13 @@ eval '(exit $?0)' && eval 'exec perl -wST "$0" "$@"' # Detect instances of "if (p) free (p);". # Likewise "if (p != 0)", "if (0 != p)", or with NULL; and with braces. -my $VERSION = '2016-01-12 23:13'; # UTC +my $VERSION = '2016-08-01 17:47'; # UTC # The definition above must lie within the first 8 lines in order # for the Emacs time-stamp write hook (at end) to update it. # If you change this file with Emacs, please let the write hook # do its job. Otherwise, update this string manually. -# Copyright (C) 2008-2016 Free Software Foundation, Inc. +# Copyright (C) 2008-2017 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -129,6 +129,9 @@ sub is_NULL ($) $err = EXIT_ERROR, next; while (defined (my $line = )) { + # Skip non-matching lines early to save time + $line =~ /\bif\b/ + or next; while ($line =~ /\b(if\s*\(\s*([^)]+?)(?:\s*!=\s*([^)]+?))?\s*\) # 1 2 3 diff --git a/build-aux/vc-list-files b/build-aux/vc-list-files index c5c420a4b..2d17eaf69 100755 --- a/build-aux/vc-list-files +++ b/build-aux/vc-list-files @@ -4,7 +4,7 @@ # Print a version string. scriptversion=2016-01-11.22; # UTC -# Copyright (C) 2006-2016 Free Software Foundation, Inc. +# Copyright (C) 2006-2017 Free Software Foundation, Inc. # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/doc/gendocs_template b/doc/gendocs_template index fea0ebc23..178f6cb4c 100644 --- a/doc/gendocs_template +++ b/doc/gendocs_template @@ -77,7 +77,7 @@ the FSF. Broken links and other corrections or suggestions can be sent to <%%EMAIL%%>.

-

Copyright © 2016 Free Software Foundation, Inc.

+

Copyright © 2017 Free Software Foundation, Inc.

This page is licensed under a Creative diff --git a/doc/gendocs_template_min b/doc/gendocs_template_min index 935c135b5..112fa3bfb 100644 --- a/doc/gendocs_template_min +++ b/doc/gendocs_template_min @@ -80,7 +80,7 @@ the FSF. Broken links and other corrections or suggestions can be sent to <%%EMAIL%%>.

-

Copyright © 2016 Free Software Foundation, Inc.

+

Copyright © 2017 Free Software Foundation, Inc.

This page is licensed under a Creative diff --git a/lib/Makefile.am b/lib/Makefile.am index 666dc0052..5da186f6f 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -1,6 +1,6 @@ ## DO NOT EDIT! GENERATED AUTOMATICALLY! ## Process this file with automake to produce Makefile.in. -# Copyright (C) 2002-2016 Free Software Foundation, Inc. +# Copyright (C) 2002-2017 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -63,6 +63,7 @@ libgnu_la_LDFLAGS += $(ISNANL_LIBM) libgnu_la_LDFLAGS += $(LDEXP_LIBM) libgnu_la_LDFLAGS += $(LIBSOCKET) libgnu_la_LDFLAGS += $(LIB_CLOCK_GETTIME) +libgnu_la_LDFLAGS += $(LIB_GETLOGIN) libgnu_la_LDFLAGS += $(LIB_POLL) libgnu_la_LDFLAGS += $(LIB_SELECT) libgnu_la_LDFLAGS += $(LOG1P_LIBM) @@ -516,6 +517,15 @@ EXTRA_DIST += fd-hook.h ## end gnulib module fd-hook +## begin gnulib module flexmember + +if gl_GNULIB_ENABLED_flexmember + +endif +EXTRA_DIST += flexmember.h + +## end gnulib module flexmember + ## begin gnulib module float BUILT_SOURCES += $(FLOAT_H) @@ -960,6 +970,34 @@ EXTRA_DIST += libunistring.valgrind ## end gnulib module libunistring +## begin gnulib module limits-h + +BUILT_SOURCES += $(LIMITS_H) + +# We need the following in order to create when the system +# doesn't have one that is compatible with GNU. +if GL_GENERATE_LIMITS_H +limits.h: limits.in.h $(top_builddir)/config.status + $(AM_V_GEN)rm -f $@-t $@ && \ + { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */' && \ + sed -e 's|@''GUARD_PREFIX''@|GL|g' \ + -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \ + -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \ + -e 's|@''PRAGMA_COLUMNS''@|@PRAGMA_COLUMNS@|g' \ + -e 's|@''NEXT_LIMITS_H''@|$(NEXT_LIMITS_H)|g' \ + < $(srcdir)/limits.in.h; \ + } > $@-t && \ + mv $@-t $@ +else +limits.h: $(top_builddir)/config.status + rm -f $@ +endif +MOSTLYCLEANFILES += limits.h limits.h-t + +EXTRA_DIST += limits.in.h + +## end gnulib module limits-h + ## begin gnulib module link @@ -1368,11 +1406,18 @@ math.h: math.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $( -e 's|@''HAVE_DECL_TRUNCF''@|$(HAVE_DECL_TRUNCF)|g' \ -e 's|@''HAVE_DECL_TRUNCL''@|$(HAVE_DECL_TRUNCL)|g' \ | \ - sed -e 's|@''REPLACE_CBRTF''@|$(REPLACE_CBRTF)|g' \ + sed -e 's|@''REPLACE_ACOSF''@|$(REPLACE_ACOSF)|g' \ + -e 's|@''REPLACE_ASINF''@|$(REPLACE_ASINF)|g' \ + -e 's|@''REPLACE_ATANF''@|$(REPLACE_ATANF)|g' \ + -e 's|@''REPLACE_ATAN2F''@|$(REPLACE_ATAN2F)|g' \ + -e 's|@''REPLACE_CBRTF''@|$(REPLACE_CBRTF)|g' \ -e 's|@''REPLACE_CBRTL''@|$(REPLACE_CBRTL)|g' \ -e 's|@''REPLACE_CEIL''@|$(REPLACE_CEIL)|g' \ -e 's|@''REPLACE_CEILF''@|$(REPLACE_CEILF)|g' \ -e 's|@''REPLACE_CEILL''@|$(REPLACE_CEILL)|g' \ + -e 's|@''REPLACE_COSF''@|$(REPLACE_COSF)|g' \ + -e 's|@''REPLACE_COSHF''@|$(REPLACE_COSHF)|g' \ + -e 's|@''REPLACE_EXPF''@|$(REPLACE_EXPF)|g' \ -e 's|@''REPLACE_EXPM1''@|$(REPLACE_EXPM1)|g' \ -e 's|@''REPLACE_EXPM1F''@|$(REPLACE_EXPM1F)|g' \ -e 's|@''REPLACE_EXP2''@|$(REPLACE_EXP2)|g' \ @@ -1428,7 +1473,12 @@ math.h: math.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $( -e 's|@''REPLACE_ROUNDL''@|$(REPLACE_ROUNDL)|g' \ -e 's|@''REPLACE_SIGNBIT''@|$(REPLACE_SIGNBIT)|g' \ -e 's|@''REPLACE_SIGNBIT_USING_GCC''@|$(REPLACE_SIGNBIT_USING_GCC)|g' \ + -e 's|@''REPLACE_SINF''@|$(REPLACE_SINF)|g' \ + -e 's|@''REPLACE_SINHF''@|$(REPLACE_SINHF)|g' \ + -e 's|@''REPLACE_SQRTF''@|$(REPLACE_SQRTF)|g' \ -e 's|@''REPLACE_SQRTL''@|$(REPLACE_SQRTL)|g' \ + -e 's|@''REPLACE_TANF''@|$(REPLACE_TANF)|g' \ + -e 's|@''REPLACE_TANHF''@|$(REPLACE_TANHF)|g' \ -e 's|@''REPLACE_TRUNC''@|$(REPLACE_TRUNC)|g' \ -e 's|@''REPLACE_TRUNCF''@|$(REPLACE_TRUNCF)|g' \ -e 's|@''REPLACE_TRUNCL''@|$(REPLACE_TRUNCL)|g' \ @@ -2172,6 +2222,7 @@ stdint.h: stdint.in.h $(top_builddir)/config.status -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \ -e 's|@''PRAGMA_COLUMNS''@|@PRAGMA_COLUMNS@|g' \ -e 's|@''NEXT_STDINT_H''@|$(NEXT_STDINT_H)|g' \ + -e 's/@''HAVE_C99_STDINT_H''@/$(HAVE_C99_STDINT_H)/g' \ -e 's/@''HAVE_SYS_TYPES_H''@/$(HAVE_SYS_TYPES_H)/g' \ -e 's/@''HAVE_INTTYPES_H''@/$(HAVE_INTTYPES_H)/g' \ -e 's/@''HAVE_SYS_INTTYPES_H''@/$(HAVE_SYS_INTTYPES_H)/g' \ @@ -2193,6 +2244,7 @@ stdint.h: stdint.in.h $(top_builddir)/config.status -e 's/@''BITSIZEOF_WINT_T''@/$(BITSIZEOF_WINT_T)/g' \ -e 's/@''HAVE_SIGNED_WINT_T''@/$(HAVE_SIGNED_WINT_T)/g' \ -e 's/@''WINT_T_SUFFIX''@/$(WINT_T_SUFFIX)/g' \ + -e 's/@''GNULIB_OVERRIDES_WINT_T''@/$(GNULIB_OVERRIDES_WINT_T)/g' \ < $(srcdir)/stdint.in.h; \ } > $@-t && \ mv $@-t $@ @@ -2397,6 +2449,7 @@ stdlib.h: stdlib.in.h $(top_builddir)/config.status $(CXXDEFS_H) \ -e 's|@''HAVE_POSIX_OPENPT''@|$(HAVE_POSIX_OPENPT)|g' \ -e 's|@''HAVE_PTSNAME''@|$(HAVE_PTSNAME)|g' \ -e 's|@''HAVE_PTSNAME_R''@|$(HAVE_PTSNAME_R)|g' \ + -e 's|@''HAVE_QSORT_R''@|$(HAVE_QSORT_R)|g' \ -e 's|@''HAVE_RANDOM''@|$(HAVE_RANDOM)|g' \ -e 's|@''HAVE_RANDOM_H''@|$(HAVE_RANDOM_H)|g' \ -e 's|@''HAVE_RANDOM_R''@|$(HAVE_RANDOM_R)|g' \ @@ -3058,7 +3111,6 @@ unistd.h: unistd.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H -e 's|@''HAVE_GETDTABLESIZE''@|$(HAVE_GETDTABLESIZE)|g' \ -e 's|@''HAVE_GETGROUPS''@|$(HAVE_GETGROUPS)|g' \ -e 's|@''HAVE_GETHOSTNAME''@|$(HAVE_GETHOSTNAME)|g' \ - -e 's|@''HAVE_GETLOGIN''@|$(HAVE_GETLOGIN)|g' \ -e 's|@''HAVE_GETPAGESIZE''@|$(HAVE_GETPAGESIZE)|g' \ -e 's|@''HAVE_GROUP_MEMBER''@|$(HAVE_GROUP_MEMBER)|g' \ -e 's|@''HAVE_LCHOWN''@|$(HAVE_LCHOWN)|g' \ @@ -3080,6 +3132,7 @@ unistd.h: unistd.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H -e 's|@''HAVE_DECL_FCHDIR''@|$(HAVE_DECL_FCHDIR)|g' \ -e 's|@''HAVE_DECL_FDATASYNC''@|$(HAVE_DECL_FDATASYNC)|g' \ -e 's|@''HAVE_DECL_GETDOMAINNAME''@|$(HAVE_DECL_GETDOMAINNAME)|g' \ + -e 's|@''HAVE_DECL_GETLOGIN''@|$(HAVE_DECL_GETLOGIN)|g' \ -e 's|@''HAVE_DECL_GETLOGIN_R''@|$(HAVE_DECL_GETLOGIN_R)|g' \ -e 's|@''HAVE_DECL_GETPAGESIZE''@|$(HAVE_DECL_GETPAGESIZE)|g' \ -e 's|@''HAVE_DECL_GETUSERSHELL''@|$(HAVE_DECL_GETUSERSHELL)|g' \ @@ -3200,6 +3253,7 @@ wchar.h: wchar.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) -e 's|@''HAVE_FEATURES_H''@|$(HAVE_FEATURES_H)|g' \ -e 's|@''NEXT_WCHAR_H''@|$(NEXT_WCHAR_H)|g' \ -e 's|@''HAVE_WCHAR_H''@|$(HAVE_WCHAR_H)|g' \ + -e 's/@''GNULIB_OVERRIDES_WINT_T''@/$(GNULIB_OVERRIDES_WINT_T)/g' \ -e 's/@''GNULIB_BTOWC''@/$(GNULIB_BTOWC)/g' \ -e 's/@''GNULIB_WCTOB''@/$(GNULIB_WCTOB)/g' \ -e 's/@''GNULIB_MBSINIT''@/$(GNULIB_MBSINIT)/g' \ @@ -3333,6 +3387,7 @@ wctype.h: wctype.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(WARN_ON_USE_H -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \ -e 's|@''PRAGMA_COLUMNS''@|@PRAGMA_COLUMNS@|g' \ -e 's|@''NEXT_WCTYPE_H''@|$(NEXT_WCTYPE_H)|g' \ + -e 's/@''GNULIB_OVERRIDES_WINT_T''@/$(GNULIB_OVERRIDES_WINT_T)/g' \ -e 's/@''GNULIB_ISWBLANK''@/$(GNULIB_ISWBLANK)/g' \ -e 's/@''GNULIB_WCTYPE''@/$(GNULIB_WCTYPE)/g' \ -e 's/@''GNULIB_ISWCTYPE''@/$(GNULIB_ISWCTYPE)/g' \ @@ -3367,6 +3422,13 @@ EXTRA_libgnu_la_SOURCES += write.c ## end gnulib module write +## begin gnulib module xalloc-oversized + + +EXTRA_DIST += xalloc-oversized.h + +## end gnulib module xalloc-oversized + ## begin gnulib module xsize if gl_GNULIB_ENABLED_xsize diff --git a/lib/accept.c b/lib/accept.c index 694d13b19..1aee71f42 100644 --- a/lib/accept.c +++ b/lib/accept.c @@ -1,6 +1,6 @@ /* accept.c --- wrappers for Windows accept function - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/alignof.h b/lib/alignof.h index 944e935be..53583b833 100644 --- a/lib/alignof.h +++ b/lib/alignof.h @@ -1,5 +1,5 @@ /* Determine alignment of types. - Copyright (C) 2003-2004, 2006, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2003-2004, 2006, 2009-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/alloca.in.h b/lib/alloca.in.h index c50e0c9f3..f6d41db8d 100644 --- a/lib/alloca.in.h +++ b/lib/alloca.in.h @@ -1,6 +1,6 @@ /* Memory allocation on the stack. - Copyright (C) 1995, 1999, 2001-2004, 2006-2016 Free Software Foundation, + Copyright (C) 1995, 1999, 2001-2004, 2006-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it @@ -51,6 +51,8 @@ extern "C" void *_alloca (unsigned short); # pragma intrinsic (_alloca) # define alloca _alloca +# elif defined __MVS__ +# include # else # include # ifdef __cplusplus diff --git a/lib/arpa_inet.in.h b/lib/arpa_inet.in.h index f9d9e6408..6efde0a69 100644 --- a/lib/arpa_inet.in.h +++ b/lib/arpa_inet.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 2005-2006, 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2005-2006, 2008-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/asnprintf.c b/lib/asnprintf.c index cd20a808e..1e8819cd9 100644 --- a/lib/asnprintf.c +++ b/lib/asnprintf.c @@ -1,5 +1,5 @@ /* Formatted output to strings. - Copyright (C) 1999, 2002, 2006, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 1999, 2002, 2006, 2009-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/assure.h b/lib/assure.h index bb0cb45f4..cef2a7353 100644 --- a/lib/assure.h +++ b/lib/assure.h @@ -1,6 +1,6 @@ /* Run-time assert-like macros. - Copyright (C) 2014-2016 Free Software Foundation, Inc. + Copyright (C) 2014-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/basename-lgpl.c b/lib/basename-lgpl.c index d91fbfae5..0e6b0a1db 100644 --- a/lib/basename-lgpl.c +++ b/lib/basename-lgpl.c @@ -1,6 +1,6 @@ /* basename.c -- return the last element in a file name - Copyright (C) 1990, 1998-2001, 2003-2006, 2009-2016 Free Software + Copyright (C) 1990, 1998-2001, 2003-2006, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/binary-io.h b/lib/binary-io.h index ffdae0281..9aeebb7a6 100644 --- a/lib/binary-io.h +++ b/lib/binary-io.h @@ -1,5 +1,5 @@ /* Binary mode I/O. - Copyright (C) 2001, 2003, 2005, 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2001, 2003, 2005, 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/bind.c b/lib/bind.c index 8111351f6..666e800c7 100644 --- a/lib/bind.c +++ b/lib/bind.c @@ -1,6 +1,6 @@ /* bind.c --- wrappers for Windows bind function - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/btowc.c b/lib/btowc.c index f49bc9afa..bfc694e15 100644 --- a/lib/btowc.c +++ b/lib/btowc.c @@ -1,5 +1,5 @@ /* Convert unibyte character to wide character. - Copyright (C) 2008, 2010-2016 Free Software Foundation, Inc. + Copyright (C) 2008, 2010-2017 Free Software Foundation, Inc. Written by Bruno Haible , 2008. This program is free software: you can redistribute it and/or modify diff --git a/lib/byteswap.in.h b/lib/byteswap.in.h index c73e1a8d2..026f5fc0f 100644 --- a/lib/byteswap.in.h +++ b/lib/byteswap.in.h @@ -1,5 +1,5 @@ /* byteswap.h - Byte swapping - Copyright (C) 2005, 2007, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2005, 2007, 2009-2017 Free Software Foundation, Inc. Written by Oskar Liljeblad , 2005. This program is free software: you can redistribute it and/or modify diff --git a/lib/c-ctype.h b/lib/c-ctype.h index 177e8c26c..a789222bc 100644 --- a/lib/c-ctype.h +++ b/lib/c-ctype.h @@ -5,7 +5,7 @@ functions' behaviour depends on the current locale set via setlocale. - Copyright (C) 2000-2003, 2006, 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2000-2003, 2006, 2008-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -115,16 +115,16 @@ extern "C" { /* Cases for lowercase hex letters, and lowercase letters, all offset by N. */ -#define _C_CTYPE_LOWER_A_THRU_F_N(n) \ - case 'a' + (n): case 'b' + (n): case 'c' + (n): case 'd' + (n): \ - case 'e' + (n): case 'f' + (n) -#define _C_CTYPE_LOWER_N(n) \ - _C_CTYPE_LOWER_A_THRU_F_N(n): \ - case 'g' + (n): case 'h' + (n): case 'i' + (n): case 'j' + (n): \ - case 'k' + (n): case 'l' + (n): case 'm' + (n): case 'n' + (n): \ - case 'o' + (n): case 'p' + (n): case 'q' + (n): case 'r' + (n): \ - case 's' + (n): case 't' + (n): case 'u' + (n): case 'v' + (n): \ - case 'w' + (n): case 'x' + (n): case 'y' + (n): case 'z' + (n) +#define _C_CTYPE_LOWER_A_THRU_F_N(N) \ + case 'a' + (N): case 'b' + (N): case 'c' + (N): case 'd' + (N): \ + case 'e' + (N): case 'f' + (N) +#define _C_CTYPE_LOWER_N(N) \ + _C_CTYPE_LOWER_A_THRU_F_N(N): \ + case 'g' + (N): case 'h' + (N): case 'i' + (N): case 'j' + (N): \ + case 'k' + (N): case 'l' + (N): case 'm' + (N): case 'n' + (N): \ + case 'o' + (N): case 'p' + (N): case 'q' + (N): case 'r' + (N): \ + case 's' + (N): case 't' + (N): case 'u' + (N): case 'v' + (N): \ + case 'w' + (N): case 'x' + (N): case 'y' + (N): case 'z' + (N) /* Cases for hex letters, digits, lower, punct, and upper. */ diff --git a/lib/c-strcase.h b/lib/c-strcase.h index 5a5ef810d..3f7d9b0fd 100644 --- a/lib/c-strcase.h +++ b/lib/c-strcase.h @@ -1,5 +1,5 @@ /* Case-insensitive string comparison functions in C locale. - Copyright (C) 1995-1996, 2001, 2003, 2005, 2009-2016 Free Software + Copyright (C) 1995-1996, 2001, 2003, 2005, 2009-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/c-strcasecmp.c b/lib/c-strcasecmp.c index 1b3e57454..6eba82676 100644 --- a/lib/c-strcasecmp.c +++ b/lib/c-strcasecmp.c @@ -1,5 +1,5 @@ /* c-strcasecmp.c -- case insensitive string comparator in C locale - Copyright (C) 1998-1999, 2005-2006, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 1998-1999, 2005-2006, 2009-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/c-strcaseeq.h b/lib/c-strcaseeq.h index f9a5d861c..7c303f5df 100644 --- a/lib/c-strcaseeq.h +++ b/lib/c-strcaseeq.h @@ -1,5 +1,5 @@ /* Optimized case-insensitive string comparison in C locale. - Copyright (C) 2001-2002, 2007, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2001-2002, 2007, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/c-strncasecmp.c b/lib/c-strncasecmp.c index c6436e0db..5431aafd6 100644 --- a/lib/c-strncasecmp.c +++ b/lib/c-strncasecmp.c @@ -1,5 +1,5 @@ /* c-strncasecmp.c -- case insensitive string comparator in C locale - Copyright (C) 1998-1999, 2005-2006, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 1998-1999, 2005-2006, 2009-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/canonicalize-lgpl.c b/lib/canonicalize-lgpl.c index 23b9d6aa6..e5706969f 100644 --- a/lib/canonicalize-lgpl.c +++ b/lib/canonicalize-lgpl.c @@ -1,5 +1,5 @@ /* Return the canonical absolute name of a given file. - Copyright (C) 1996-2016 Free Software Foundation, Inc. + Copyright (C) 1996-2017 Free Software Foundation, Inc. This file is part of the GNU C Library. This program is free software: you can redistribute it and/or modify @@ -83,7 +83,23 @@ # define DOUBLE_SLASH_IS_DISTINCT_ROOT 0 #endif +/* Define this independently so that stdint.h is not a prerequisite. */ +#ifndef SIZE_MAX +# define SIZE_MAX ((size_t) -1) +#endif + #if !FUNC_REALPATH_WORKS || defined _LIBC + +static void +alloc_failed (void) +{ +#if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ + /* Avoid errno problem without using the malloc or realloc modules; see: + http://lists.gnu.org/archive/html/bug-gnulib/2016-08/msg00025.html */ + errno = ENOMEM; +#endif +} + /* Return the canonical absolute name of file NAME. A canonical name does not contain any ".", ".." components nor any repeated path separators ('/') or symlinks. All path components must exist. If @@ -135,9 +151,7 @@ __realpath (const char *name, char *resolved) rpath = malloc (path_max); if (rpath == NULL) { - /* It's easier to set errno to ENOMEM than to rely on the - 'malloc-posix' gnulib module. */ - errno = ENOMEM; + alloc_failed (); return NULL; } } @@ -185,7 +199,6 @@ __realpath (const char *name, char *resolved) #else struct stat st; #endif - int n; /* Skip sequence of multiple path-separators. */ while (ISSLASH (*start)) @@ -238,9 +251,7 @@ __realpath (const char *name, char *resolved) new_rpath = (char *) realloc (rpath, new_size); if (new_rpath == NULL) { - /* It's easier to set errno to ENOMEM than to rely on the - 'realloc-posix' gnulib module. */ - errno = ENOMEM; + alloc_failed (); goto error; } rpath = new_rpath; @@ -268,6 +279,7 @@ __realpath (const char *name, char *resolved) { char *buf; size_t len; + ssize_t n; if (++num_links > MAXSYMLINKS) { @@ -278,7 +290,7 @@ __realpath (const char *name, char *resolved) buf = malloca (path_max); if (!buf) { - errno = ENOMEM; + __set_errno (ENOMEM); goto error; } @@ -287,7 +299,7 @@ __realpath (const char *name, char *resolved) { int saved_errno = errno; freea (buf); - errno = saved_errno; + __set_errno (saved_errno); goto error; } buf[n] = '\0'; @@ -298,13 +310,14 @@ __realpath (const char *name, char *resolved) if (!extra_buf) { freea (buf); - errno = ENOMEM; + __set_errno (ENOMEM); goto error; } } len = strlen (end); - if ((long int) (n + len) >= path_max) + /* Check that n + len + 1 doesn't overflow and is <= path_max. */ + if (n >= SIZE_MAX - len || n + len >= path_max) { freea (buf); __set_errno (ENAMETOOLONG); @@ -370,7 +383,7 @@ error: freea (extra_buf); if (resolved == NULL) free (rpath); - errno = saved_errno; + __set_errno (saved_errno); } return NULL; } diff --git a/lib/ceil.c b/lib/ceil.c index ac9640772..d253d4856 100644 --- a/lib/ceil.c +++ b/lib/ceil.c @@ -1,5 +1,5 @@ /* Round towards positive infinity. - Copyright (C) 2007, 2010-2016 Free Software Foundation, Inc. + Copyright (C) 2007, 2010-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/close.c b/lib/close.c index 730d6747c..bb635c3b0 100644 --- a/lib/close.c +++ b/lib/close.c @@ -1,5 +1,5 @@ /* close replacement. - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/config.charset b/lib/config.charset index 05773ddf3..83cf4ec3e 100644 --- a/lib/config.charset +++ b/lib/config.charset @@ -1,7 +1,7 @@ #! /bin/sh # Output a system dependent table of character encoding aliases. # -# Copyright (C) 2000-2004, 2006-2016 Free Software Foundation, Inc. +# Copyright (C) 2000-2004, 2006-2017 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/connect.c b/lib/connect.c index 1c7dddd94..d3a2e124a 100644 --- a/lib/connect.c +++ b/lib/connect.c @@ -1,6 +1,6 @@ /* connect.c --- wrappers for Windows connect function - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/copysign.c b/lib/copysign.c index 5a172bf4d..a0d2b6806 100644 --- a/lib/copysign.c +++ b/lib/copysign.c @@ -1,5 +1,5 @@ /* Copy sign into another 'double' number. - Copyright (C) 2011-2016 Free Software Foundation, Inc. + Copyright (C) 2011-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/dirent.in.h b/lib/dirent.in.h index ab872a7a2..e5a31e34c 100644 --- a/lib/dirent.in.h +++ b/lib/dirent.in.h @@ -1,5 +1,5 @@ /* A GNU-like . - Copyright (C) 2006-2016 Free Software Foundation, Inc. + Copyright (C) 2006-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/dirfd.c b/lib/dirfd.c index 4e41830df..2082bdbbd 100644 --- a/lib/dirfd.c +++ b/lib/dirfd.c @@ -1,6 +1,6 @@ /* dirfd.c -- return the file descriptor associated with an open DIR* - Copyright (C) 2001, 2006, 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2001, 2006, 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/dirname-lgpl.c b/lib/dirname-lgpl.c index 6740f2027..4fb9ba821 100644 --- a/lib/dirname-lgpl.c +++ b/lib/dirname-lgpl.c @@ -1,6 +1,6 @@ /* dirname.c -- return all but the last element in a file name - Copyright (C) 1990, 1998, 2000-2001, 2003-2006, 2009-2016 Free Software + Copyright (C) 1990, 1998, 2000-2001, 2003-2006, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/dirname.h b/lib/dirname.h index d74ea71dc..99a3e9b1d 100644 --- a/lib/dirname.h +++ b/lib/dirname.h @@ -1,6 +1,6 @@ /* Take file names apart into directory and base names. - Copyright (C) 1998, 2001, 2003-2006, 2009-2016 Free Software Foundation, + Copyright (C) 1998, 2001, 2003-2006, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/dosname.h b/lib/dosname.h index d451076e0..774623f78 100644 --- a/lib/dosname.h +++ b/lib/dosname.h @@ -1,6 +1,6 @@ /* File names on MS-DOS/Windows systems. - Copyright (C) 2000-2001, 2004-2006, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2000-2001, 2004-2006, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/dup2.c b/lib/dup2.c index bb33eacdf..0871eda68 100644 --- a/lib/dup2.c +++ b/lib/dup2.c @@ -1,6 +1,6 @@ /* Duplicate an open file descriptor to a specified file descriptor. - Copyright (C) 1999, 2004-2007, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 1999, 2004-2007, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/duplocale.c b/lib/duplocale.c index c9f9e4932..eb7b8d365 100644 --- a/lib/duplocale.c +++ b/lib/duplocale.c @@ -1,5 +1,5 @@ /* Duplicate a locale object. - Copyright (C) 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/errno.in.h b/lib/errno.in.h index 3e1b5b510..48c5d935d 100644 --- a/lib/errno.in.h +++ b/lib/errno.in.h @@ -1,6 +1,6 @@ /* A POSIX-like . - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/fcntl.in.h b/lib/fcntl.in.h index d4e34fe13..dc8d7340f 100644 --- a/lib/fcntl.in.h +++ b/lib/fcntl.in.h @@ -1,6 +1,6 @@ /* Like , but with non-working flags defined to 0. - Copyright (C) 2006-2016 Free Software Foundation, Inc. + Copyright (C) 2006-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/fd-hook.c b/lib/fd-hook.c index 7404aaa5e..627863a29 100644 --- a/lib/fd-hook.c +++ b/lib/fd-hook.c @@ -1,5 +1,5 @@ /* Hook for making making file descriptor functions close(), ioctl() extensible. - Copyright (C) 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2009-2017 Free Software Foundation, Inc. Written by Bruno Haible , 2009. This program is free software: you can redistribute it and/or modify it diff --git a/lib/fd-hook.h b/lib/fd-hook.h index b56f1328e..246ca7769 100644 --- a/lib/fd-hook.h +++ b/lib/fd-hook.h @@ -1,5 +1,5 @@ /* Hook for making making file descriptor functions close(), ioctl() extensible. - Copyright (C) 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/flexmember.h b/lib/flexmember.h new file mode 100644 index 000000000..3ef4f9802 --- /dev/null +++ b/lib/flexmember.h @@ -0,0 +1,42 @@ +/* Sizes of structs with flexible array members. + + Copyright 2016-2017 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . + + Written by Paul Eggert. */ + +#include + +/* Nonzero multiple of alignment of TYPE, suitable for FLEXSIZEOF below. + On older platforms without _Alignof, use a pessimistic bound that is + safe in practice even if FLEXIBLE_ARRAY_MEMBER is 1. + On newer platforms, use _Alignof to get a tighter bound. */ + +#if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112 +# define FLEXALIGNOF(type) (sizeof (type) & ~ (sizeof (type) - 1)) +#else +# define FLEXALIGNOF(type) _Alignof (type) +#endif + +/* Upper bound on the size of a struct of type TYPE with a flexible + array member named MEMBER that is followed by N bytes of other data. + This is not simply sizeof (TYPE) + N, since it may require + alignment on unusually picky C11 platforms, and + FLEXIBLE_ARRAY_MEMBER may be 1 on pre-C11 platforms. + Yield a value less than N if and only if arithmetic overflow occurs. */ + +#define FLEXSIZEOF(type, member, n) \ + ((offsetof (type, member) + FLEXALIGNOF (type) - 1 + (n)) \ + & ~ (FLEXALIGNOF (type) - 1)) diff --git a/lib/float+.h b/lib/float+.h index 14b81203a..41c3d57b4 100644 --- a/lib/float+.h +++ b/lib/float+.h @@ -1,5 +1,5 @@ /* Supplemental information about the floating-point formats. - Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2017 Free Software Foundation, Inc. Written by Bruno Haible , 2007. This program is free software; you can redistribute it and/or modify diff --git a/lib/float.c b/lib/float.c index 1d1d54f18..48567817f 100644 --- a/lib/float.c +++ b/lib/float.c @@ -1,5 +1,5 @@ /* Auxiliary definitions for . - Copyright (C) 2011-2016 Free Software Foundation, Inc. + Copyright (C) 2011-2017 Free Software Foundation, Inc. Written by Bruno Haible , 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/float.in.h b/lib/float.in.h index 20989c089..2b0625359 100644 --- a/lib/float.in.h +++ b/lib/float.in.h @@ -1,6 +1,6 @@ /* A correct . - Copyright (C) 2007-2016 Free Software Foundation, Inc. + Copyright (C) 2007-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/flock.c b/lib/flock.c index 53f7ae528..7698e43ff 100644 --- a/lib/flock.c +++ b/lib/flock.c @@ -6,7 +6,7 @@ Written by Richard W.M. Jones - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-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 diff --git a/lib/floor.c b/lib/floor.c index 3225f40b8..5305fb3ae 100644 --- a/lib/floor.c +++ b/lib/floor.c @@ -1,5 +1,5 @@ /* Round towards negative infinity. - Copyright (C) 2007, 2010-2016 Free Software Foundation, Inc. + Copyright (C) 2007, 2010-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/frexp.c b/lib/frexp.c index a1a23aa54..8bcf890c9 100644 --- a/lib/frexp.c +++ b/lib/frexp.c @@ -1,5 +1,5 @@ /* Split a double into fraction and mantissa. - Copyright (C) 2007-2016 Free Software Foundation, Inc. + Copyright (C) 2007-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/fstat.c b/lib/fstat.c index f93f60fd2..4832548f1 100644 --- a/lib/fstat.c +++ b/lib/fstat.c @@ -1,5 +1,5 @@ /* fstat() replacement. - Copyright (C) 2011-2016 Free Software Foundation, Inc. + Copyright (C) 2011-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/fsync.c b/lib/fsync.c index b107dfcf9..8304751a4 100644 --- a/lib/fsync.c +++ b/lib/fsync.c @@ -7,7 +7,7 @@ Written by Richard W.M. Jones - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-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 diff --git a/lib/full-read.c b/lib/full-read.c index 0b1a8f35c..97ac45fa1 100644 --- a/lib/full-read.c +++ b/lib/full-read.c @@ -1,5 +1,5 @@ /* An interface to read that retries after partial reads and interrupts. - Copyright (C) 2002-2003, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2002-2003, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/full-read.h b/lib/full-read.h index dbf4cd679..d1277635c 100644 --- a/lib/full-read.h +++ b/lib/full-read.h @@ -1,6 +1,6 @@ /* An interface to read() that reads all it is asked to read. - Copyright (C) 2002, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2002, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/full-write.c b/lib/full-write.c index 9419d70cb..75fd857d8 100644 --- a/lib/full-write.c +++ b/lib/full-write.c @@ -1,6 +1,6 @@ /* An interface to read and write that retries (if necessary) until complete. - Copyright (C) 1993-1994, 1997-2006, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 1993-1994, 1997-2006, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/full-write.h b/lib/full-write.h index 3715bec59..002924991 100644 --- a/lib/full-write.h +++ b/lib/full-write.h @@ -1,6 +1,6 @@ /* An interface to write() that writes all it is asked to write. - Copyright (C) 2002-2003, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2002-2003, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/gai_strerror.c b/lib/gai_strerror.c index 6acc85973..20d5513d4 100644 --- a/lib/gai_strerror.c +++ b/lib/gai_strerror.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1997, 2001-2002, 2004-2006, 2008-2016 Free Software +/* Copyright (C) 1997, 2001-2002, 2004-2006, 2008-2017 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Philip Blundell , 1997. diff --git a/lib/getaddrinfo.c b/lib/getaddrinfo.c index 33d731f19..361dbc25a 100644 --- a/lib/getaddrinfo.c +++ b/lib/getaddrinfo.c @@ -1,5 +1,5 @@ /* Get address information (partial implementation). - Copyright (C) 1997, 2001-2002, 2004-2016 Free Software Foundation, Inc. + Copyright (C) 1997, 2001-2002, 2004-2017 Free Software Foundation, Inc. Contributed by Simon Josefsson . This program is free software; you can redistribute it and/or modify diff --git a/lib/getlogin.c b/lib/getlogin.c index 27efb2b95..47c586a62 100644 --- a/lib/getlogin.c +++ b/lib/getlogin.c @@ -1,6 +1,6 @@ /* Provide a working getlogin for systems which lack it. - Copyright (C) 2010-2016 Free Software Foundation, Inc. + Copyright (C) 2010-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/getpeername.c b/lib/getpeername.c index a1d207d5d..e36e57bb0 100644 --- a/lib/getpeername.c +++ b/lib/getpeername.c @@ -1,6 +1,6 @@ /* getpeername.c --- wrappers for Windows getpeername function - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/getsockname.c b/lib/getsockname.c index 3fc808967..08d0ead77 100644 --- a/lib/getsockname.c +++ b/lib/getsockname.c @@ -1,6 +1,6 @@ /* getsockname.c --- wrappers for Windows getsockname function - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/getsockopt.c b/lib/getsockopt.c index 6242deef7..eabbd246c 100644 --- a/lib/getsockopt.c +++ b/lib/getsockopt.c @@ -1,6 +1,6 @@ /* getsockopt.c --- wrappers for Windows getsockopt function - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/gettext.h b/lib/gettext.h index a22c9fa8b..da14fdcde 100644 --- a/lib/gettext.h +++ b/lib/gettext.h @@ -1,5 +1,5 @@ /* Convenience header for conditional use of GNU . - Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2009-2016 Free Software + Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2009-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/gettimeofday.c b/lib/gettimeofday.c index 83c72d9ce..b4375fef7 100644 --- a/lib/gettimeofday.c +++ b/lib/gettimeofday.c @@ -1,6 +1,6 @@ /* Provide gettimeofday for systems that don't have it or for which it's broken. - Copyright (C) 2001-2003, 2005-2007, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2001-2003, 2005-2007, 2009-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/hard-locale.c b/lib/hard-locale.c index 6addf453d..845282dd3 100644 --- a/lib/hard-locale.c +++ b/lib/hard-locale.c @@ -1,6 +1,6 @@ /* hard-locale.c -- Determine whether a locale is hard. - Copyright (C) 1997-1999, 2002-2004, 2006-2007, 2009-2016 Free Software + Copyright (C) 1997-1999, 2002-2004, 2006-2007, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/hard-locale.h b/lib/hard-locale.h index a4a4c0643..b7cd5d19e 100644 --- a/lib/hard-locale.h +++ b/lib/hard-locale.h @@ -1,6 +1,6 @@ /* Determine whether a locale is hard. - Copyright (C) 1999, 2003-2004, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 1999, 2003-2004, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/iconv.c b/lib/iconv.c index 97e61bd13..c0f1a8352 100644 --- a/lib/iconv.c +++ b/lib/iconv.c @@ -1,5 +1,5 @@ /* Character set conversion. - Copyright (C) 1999-2001, 2007, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 1999-2001, 2007, 2009-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/iconv.in.h b/lib/iconv.in.h index eb55e2b5b..0864267ef 100644 --- a/lib/iconv.in.h +++ b/lib/iconv.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 2007-2016 Free Software Foundation, Inc. + Copyright (C) 2007-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/iconv_close.c b/lib/iconv_close.c index e15cde16a..823cf452f 100644 --- a/lib/iconv_close.c +++ b/lib/iconv_close.c @@ -1,5 +1,5 @@ /* Character set conversion. - Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/iconv_open.c b/lib/iconv_open.c index 434fa9534..48a28dbe4 100644 --- a/lib/iconv_open.c +++ b/lib/iconv_open.c @@ -1,5 +1,5 @@ /* Character set conversion. - Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/iconveh.h b/lib/iconveh.h index 1bac9a8ab..c074a8c25 100644 --- a/lib/iconveh.h +++ b/lib/iconveh.h @@ -1,5 +1,5 @@ /* Character set conversion handler type. - Copyright (C) 2001-2007, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2001-2007, 2009-2017 Free Software Foundation, Inc. Written by Bruno Haible. This program is free software: you can redistribute it and/or modify diff --git a/lib/inet_ntop.c b/lib/inet_ntop.c index 37d93f88b..b30a26667 100644 --- a/lib/inet_ntop.c +++ b/lib/inet_ntop.c @@ -1,6 +1,6 @@ /* inet_ntop.c -- convert IPv4 and IPv6 addresses from binary to text form - Copyright (C) 2005-2006, 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2005-2006, 2008-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/inet_pton.c b/lib/inet_pton.c index fac8fd41b..8e8b8c1da 100644 --- a/lib/inet_pton.c +++ b/lib/inet_pton.c @@ -1,6 +1,6 @@ /* inet_pton.c -- convert IPv4 and IPv6 addresses from text to binary form - Copyright (C) 2006, 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2006, 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/intprops.h b/lib/intprops.h index feb02c3c6..eb06b6917 100644 --- a/lib/intprops.h +++ b/lib/intprops.h @@ -1,6 +1,6 @@ /* intprops.h -- properties of integer types - Copyright (C) 2001-2016 Free Software Foundation, Inc. + Copyright (C) 2001-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published @@ -47,12 +47,16 @@ /* Minimum and maximum values for integer types and expressions. */ +/* The width in bits of the integer type or expression T. + Padding bits are not supported; this is checked at compile-time below. */ +#define TYPE_WIDTH(t) (sizeof (t) * CHAR_BIT) + /* The maximum and minimum values for the integer type T. */ #define TYPE_MINIMUM(t) ((t) ~ TYPE_MAXIMUM (t)) #define TYPE_MAXIMUM(t) \ ((t) (! TYPE_SIGNED (t) \ ? (t) -1 \ - : ((((t) 1 << (sizeof (t) * CHAR_BIT - 2)) - 1) * 2 + 1))) + : ((((t) 1 << (TYPE_WIDTH (t) - 2)) - 1) * 2 + 1))) /* The maximum and minimum values for the type of the expression E, after integer promotion. E should not have side effects. */ @@ -65,7 +69,13 @@ ? _GL_SIGNED_INT_MAXIMUM (e) \ : _GL_INT_NEGATE_CONVERT (e, 1)) #define _GL_SIGNED_INT_MAXIMUM(e) \ - (((_GL_INT_CONVERT (e, 1) << (sizeof ((e) + 0) * CHAR_BIT - 2)) - 1) * 2 + 1) + (((_GL_INT_CONVERT (e, 1) << (TYPE_WIDTH ((e) + 0) - 2)) - 1) * 2 + 1) + +/* Work around OpenVMS incompatibility with C99. */ +#if !defined LLONG_MAX && defined __INT64_MAX +# define LLONG_MAX __INT64_MAX +# define LLONG_MIN __INT64_MIN +#endif /* This include file assumes that signed types are two's complement without padding bits; the above macros have undefined behavior otherwise. @@ -84,10 +94,15 @@ verify (TYPE_MAXIMUM (long int) == LONG_MAX); verify (TYPE_MINIMUM (long long int) == LLONG_MIN); verify (TYPE_MAXIMUM (long long int) == LLONG_MAX); #endif +/* Similarly, sanity-check one ISO/IEC TS 18661-1:2014 macro if defined. */ +#ifdef UINT_WIDTH +verify (TYPE_WIDTH (unsigned int) == UINT_WIDTH); +#endif /* Does the __typeof__ keyword work? This could be done by 'configure', but for now it's easier to do it by hand. */ -#if (2 <= __GNUC__ || defined __IBM__TYPEOF__ \ +#if (2 <= __GNUC__ \ + || (1210 <= __IBMC__ && defined __IBM__TYPEOF__) \ || (0x5110 <= __SUNPRO_C && !__STDC__)) # define _GL_HAVE___TYPEOF__ 1 #else @@ -116,8 +131,7 @@ verify (TYPE_MAXIMUM (long long int) == LLONG_MAX); signed, this macro may overestimate the true bound by one byte when applied to unsigned types of size 2, 4, 16, ... bytes. */ #define INT_STRLEN_BOUND(t) \ - (INT_BITS_STRLEN_BOUND (sizeof (t) * CHAR_BIT \ - - _GL_SIGNED_TYPE_OR_EXPR (t)) \ + (INT_BITS_STRLEN_BOUND (TYPE_WIDTH (t) - _GL_SIGNED_TYPE_OR_EXPR (t)) \ + _GL_SIGNED_TYPE_OR_EXPR (t)) /* Bound on buffer size needed to represent an integer type or expression T, @@ -222,20 +236,23 @@ verify (TYPE_MAXIMUM (long long int) == LLONG_MAX); ? (a) < (min) >> (b) \ : (max) >> (b) < (a)) -/* True if __builtin_add_overflow (A, B, P) works when P is null. */ -#define _GL_HAS_BUILTIN_OVERFLOW_WITH_NULL (7 <= __GNUC__) +/* True if __builtin_add_overflow (A, B, P) works when P is non-null. */ +#define _GL_HAS_BUILTIN_OVERFLOW (5 <= __GNUC__) + +/* True if __builtin_add_overflow_p (A, B, C) works. */ +#define _GL_HAS_BUILTIN_OVERFLOW_P (7 <= __GNUC__) /* The _GL*_OVERFLOW macros have the same restrictions as the *_RANGE_OVERFLOW macros, except that they do not assume that operands (e.g., A and B) have the same type as MIN and MAX. Instead, they assume that the result (e.g., A + B) has that type. */ -#if _GL_HAS_BUILTIN_OVERFLOW_WITH_NULL -# define _GL_ADD_OVERFLOW(a, b, min, max) - __builtin_add_overflow (a, b, (__typeof__ ((a) + (b)) *) 0) -# define _GL_SUBTRACT_OVERFLOW(a, b, min, max) - __builtin_sub_overflow (a, b, (__typeof__ ((a) - (b)) *) 0) -# define _GL_MULTIPLY_OVERFLOW(a, b, min, max) - __builtin_mul_overflow (a, b, (__typeof__ ((a) * (b)) *) 0) +#if _GL_HAS_BUILTIN_OVERFLOW_P +# define _GL_ADD_OVERFLOW(a, b, min, max) \ + __builtin_add_overflow_p (a, b, (__typeof__ ((a) + (b))) 0) +# define _GL_SUBTRACT_OVERFLOW(a, b, min, max) \ + __builtin_sub_overflow_p (a, b, (__typeof__ ((a) - (b))) 0) +# define _GL_MULTIPLY_OVERFLOW(a, b, min, max) \ + __builtin_mul_overflow_p (a, b, (__typeof__ ((a) * (b))) 0) #else # define _GL_ADD_OVERFLOW(a, b, min, max) \ ((min) < 0 ? INT_ADD_RANGE_OVERFLOW (a, b, min, max) \ @@ -315,7 +332,7 @@ verify (TYPE_MAXIMUM (long long int) == LLONG_MAX); _GL_BINARY_OP_OVERFLOW (a, b, _GL_ADD_OVERFLOW) #define INT_SUBTRACT_OVERFLOW(a, b) \ _GL_BINARY_OP_OVERFLOW (a, b, _GL_SUBTRACT_OVERFLOW) -#if _GL_HAS_BUILTIN_OVERFLOW_WITH_NULL +#if _GL_HAS_BUILTIN_OVERFLOW_P # define INT_NEGATE_OVERFLOW(a) INT_SUBTRACT_OVERFLOW (0, a) #else # define INT_NEGATE_OVERFLOW(a) \ @@ -349,10 +366,6 @@ verify (TYPE_MAXIMUM (long long int) == LLONG_MAX); #define INT_MULTIPLY_WRAPV(a, b, r) \ _GL_INT_OP_WRAPV (a, b, r, *, __builtin_mul_overflow, INT_MULTIPLY_OVERFLOW) -#ifndef __has_builtin -# define __has_builtin(x) 0 -#endif - /* Nonzero if this compiler has GCC bug 68193 or Clang bug 25390. See: https://gcc.gnu.org/bugzilla/show_bug.cgi?id=68193 https://llvm.org/bugs/show_bug.cgi?id=25390 @@ -369,7 +382,7 @@ verify (TYPE_MAXIMUM (long long int) == LLONG_MAX); the operation. BUILTIN is the builtin operation, and OVERFLOW the overflow predicate. Return 1 if the result overflows. See above for restrictions. */ -#if 5 <= __GNUC__ || __has_builtin (__builtin_add_overflow) +#if _GL_HAS_BUILTIN_OVERFLOW # define _GL_INT_OP_WRAPV(a, b, r, op, builtin, overflow) builtin (a, b, r) #elif 201112 <= __STDC_VERSION__ && !_GL__GENERIC_BOGUS # define _GL_INT_OP_WRAPV(a, b, r, op, builtin, overflow) \ @@ -412,7 +425,7 @@ verify (TYPE_MAXIMUM (long long int) == LLONG_MAX); # else # define _GL_INT_OP_WRAPV_LONGISH(a, b, r, op, overflow) \ _GL_INT_OP_CALC (a, b, r, op, overflow, unsigned long int, \ - long int, LONG_MIN, LONG_MAX)) + long int, LONG_MIN, LONG_MAX) # endif #endif diff --git a/lib/isfinite.c b/lib/isfinite.c index 431518e98..d689bb2b9 100644 --- a/lib/isfinite.c +++ b/lib/isfinite.c @@ -1,5 +1,5 @@ /* Test for finite value (zero, subnormal, or normal, and not infinite or NaN). - Copyright (C) 2007-2016 Free Software Foundation, Inc. + Copyright (C) 2007-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isinf.c b/lib/isinf.c index fa9565ae4..8dd72a305 100644 --- a/lib/isinf.c +++ b/lib/isinf.c @@ -1,5 +1,5 @@ /* Test for positive or negative infinity. - Copyright (C) 2007-2016 Free Software Foundation, Inc. + Copyright (C) 2007-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnan.c b/lib/isnan.c index e9a86149d..519f3dc8a 100644 --- a/lib/isnan.c +++ b/lib/isnan.c @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007-2016 Free Software Foundation, Inc. + Copyright (C) 2007-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnand-nolibm.h b/lib/isnand-nolibm.h index c30ae24db..1b1c32943 100644 --- a/lib/isnand-nolibm.h +++ b/lib/isnand-nolibm.h @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007-2016 Free Software Foundation, Inc. + Copyright (C) 2007-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnand.c b/lib/isnand.c index 2e25f353f..906faf152 100644 --- a/lib/isnand.c +++ b/lib/isnand.c @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnanf-nolibm.h b/lib/isnanf-nolibm.h index 8166b9b55..9e55c6c1a 100644 --- a/lib/isnanf-nolibm.h +++ b/lib/isnanf-nolibm.h @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007-2016 Free Software Foundation, Inc. + Copyright (C) 2007-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnanf.c b/lib/isnanf.c index 6c82c5e0c..2831654d1 100644 --- a/lib/isnanf.c +++ b/lib/isnanf.c @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnanl-nolibm.h b/lib/isnanl-nolibm.h index 517547d1a..1667e55c0 100644 --- a/lib/isnanl-nolibm.h +++ b/lib/isnanl-nolibm.h @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007-2016 Free Software Foundation, Inc. + Copyright (C) 2007-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/isnanl.c b/lib/isnanl.c index 77404b7f5..fe733bc86 100644 --- a/lib/isnanl.c +++ b/lib/isnanl.c @@ -1,5 +1,5 @@ /* Test for NaN that does not need libm. - Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/itold.c b/lib/itold.c index 57f5e9578..facf4ae61 100644 --- a/lib/itold.c +++ b/lib/itold.c @@ -1,5 +1,5 @@ /* Replacement for 'int' to 'long double' conversion routine. - Copyright (C) 2011-2016 Free Software Foundation, Inc. + Copyright (C) 2011-2017 Free Software Foundation, Inc. Written by Bruno Haible , 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/langinfo.in.h b/lib/langinfo.in.h index 42c7cefb9..689e82c9a 100644 --- a/lib/langinfo.in.h +++ b/lib/langinfo.in.h @@ -1,5 +1,5 @@ /* Substitute for and wrapper around . - Copyright (C) 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2009-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/limits.in.h b/lib/limits.in.h new file mode 100644 index 000000000..7ff33ab12 --- /dev/null +++ b/lib/limits.in.h @@ -0,0 +1,63 @@ +/* A GNU-like . + + Copyright 2016-2017 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public License + as published by the Free Software Foundation; either version 2, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program; if not, see . */ + +#ifndef _@GUARD_PREFIX@_LIMITS_H + +#if __GNUC__ >= 3 +@PRAGMA_SYSTEM_HEADER@ +#endif +@PRAGMA_COLUMNS@ + +/* The include_next requires a split double-inclusion guard. */ +#@INCLUDE_NEXT@ @NEXT_LIMITS_H@ + +#ifndef _@GUARD_PREFIX@_LIMITS_H +#define _@GUARD_PREFIX@_LIMITS_H + +/* The number of usable bits in an unsigned or signed integer type + with minimum value MIN and maximum value MAX, as an int expression + suitable in #if. Cover all known practical hosts. This + implementation exploits the fact that MAX is 1 less than a power of + 2, and merely counts the number of 1 bits in MAX; "COBn" means + "count the number of 1 bits in the low-order n bits"). */ +#define _GL_INTEGER_WIDTH(min, max) (((min) < 0) + _GL_COB128 (max)) +#define _GL_COB128(n) (_GL_COB64 ((n) >> 31 >> 31 >> 2) + _GL_COB64 (n)) +#define _GL_COB64(n) (_GL_COB32 ((n) >> 31 >> 1) + _GL_COB32 (n)) +#define _GL_COB32(n) (_GL_COB16 ((n) >> 16) + _GL_COB16 (n)) +#define _GL_COB16(n) (_GL_COB8 ((n) >> 8) + _GL_COB8 (n)) +#define _GL_COB8(n) (_GL_COB4 ((n) >> 4) + _GL_COB4 (n)) +#define _GL_COB4(n) (!!((n) & 8) + !!((n) & 4) + !!((n) & 2) + !!((n) & 1)) + +/* Macros specified by ISO/IEC TS 18661-1:2014. */ + +#if (! defined ULLONG_WIDTH \ + && (defined _GNU_SOURCE || defined __STDC_WANT_IEC_60559_BFP_EXT__)) +# define CHAR_WIDTH _GL_INTEGER_WIDTH (CHAR_MIN, CHAR_MAX) +# define SCHAR_WIDTH _GL_INTEGER_WIDTH (SCHAR_MIN, SCHAR_MAX) +# define UCHAR_WIDTH _GL_INTEGER_WIDTH (0, UCHAR_MAX) +# define SHRT_WIDTH _GL_INTEGER_WIDTH (SHRT_MIN, SHRT_MAX) +# define USHRT_WIDTH _GL_INTEGER_WIDTH (0, USHRT_MAX) +# define INT_WIDTH _GL_INTEGER_WIDTH (INT_MIN, INT_MAX) +# define UINT_WIDTH _GL_INTEGER_WIDTH (0, UINT_MAX) +# define LONG_WIDTH _GL_INTEGER_WIDTH (LONG_MIN, LONG_MAX) +# define ULONG_WIDTH _GL_INTEGER_WIDTH (0, ULONG_MAX) +# define LLONG_WIDTH _GL_INTEGER_WIDTH (LLONG_MIN, LLONG_MAX) +# define ULLONG_WIDTH _GL_INTEGER_WIDTH (0, ULLONG_MAX) +#endif /* !ULLONG_WIDTH && (_GNU_SOURCE || __STDC_WANT_IEC_60559_BFP_EXT__) */ + +#endif /* _@GUARD_PREFIX@_LIMITS_H */ +#endif /* _@GUARD_PREFIX@_LIMITS_H */ diff --git a/lib/link.c b/lib/link.c index 9cd840c3e..625d2e82d 100644 --- a/lib/link.c +++ b/lib/link.c @@ -1,6 +1,6 @@ /* Emulate link on platforms that lack it, namely native Windows platforms. - Copyright (C) 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2009-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/listen.c b/lib/listen.c index 014e82f85..284415a08 100644 --- a/lib/listen.c +++ b/lib/listen.c @@ -1,6 +1,6 @@ /* listen.c --- wrappers for Windows listen function - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/localcharset.c b/lib/localcharset.c index 7ce17e69e..4be72d616 100644 --- a/lib/localcharset.c +++ b/lib/localcharset.c @@ -1,6 +1,6 @@ /* Determine a canonical name for the current locale's character encoding. - Copyright (C) 2000-2006, 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2000-2006, 2008-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -507,7 +507,7 @@ locale_charset (void) current_locale = setlocale (LC_CTYPE, NULL); pdot = strrchr (current_locale, '.'); - if (pdot) + if (pdot && 2 + strlen (pdot + 1) + 1 <= sizeof (buf)) sprintf (buf, "CP%s", pdot + 1); else { diff --git a/lib/localcharset.h b/lib/localcharset.h index 49de10a43..641eceae5 100644 --- a/lib/localcharset.h +++ b/lib/localcharset.h @@ -1,5 +1,5 @@ /* Determine a canonical name for the current locale's character encoding. - Copyright (C) 2000-2003, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2000-2003, 2009-2017 Free Software Foundation, Inc. This file is part of the GNU CHARSET Library. This program is free software; you can redistribute it and/or modify diff --git a/lib/locale.in.h b/lib/locale.in.h index f7b19caa0..50ccae610 100644 --- a/lib/locale.in.h +++ b/lib/locale.in.h @@ -1,5 +1,5 @@ /* A POSIX . - Copyright (C) 2007-2016 Free Software Foundation, Inc. + Copyright (C) 2007-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/localeconv.c b/lib/localeconv.c index 609dbb63a..c38035f0d 100644 --- a/lib/localeconv.c +++ b/lib/localeconv.c @@ -1,5 +1,5 @@ /* Query locale dependent information for formatting numbers. - Copyright (C) 2012-2016 Free Software Foundation, Inc. + Copyright (C) 2012-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/log.c b/lib/log.c index 547201f32..2ec8cb9d5 100644 --- a/lib/log.c +++ b/lib/log.c @@ -1,5 +1,5 @@ /* Logarithm. - Copyright (C) 2012-2016 Free Software Foundation, Inc. + Copyright (C) 2012-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/log1p.c b/lib/log1p.c index bc4127b80..d266290ac 100644 --- a/lib/log1p.c +++ b/lib/log1p.c @@ -1,5 +1,5 @@ /* Natural logarithm of 1 plus argument. - Copyright (C) 2012-2016 Free Software Foundation, Inc. + Copyright (C) 2012-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/lstat.c b/lib/lstat.c index 0a0141607..f4cdb2a3e 100644 --- a/lib/lstat.c +++ b/lib/lstat.c @@ -1,6 +1,6 @@ /* Work around a bug of lstat on some systems - Copyright (C) 1997-2006, 2008-2016 Free Software Foundation, Inc. + Copyright (C) 1997-2006, 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/malloc.c b/lib/malloc.c index ea63740f3..6b5e53ee7 100644 --- a/lib/malloc.c +++ b/lib/malloc.c @@ -1,6 +1,6 @@ /* malloc() function that is glibc compatible. - Copyright (C) 1997-1998, 2006-2007, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 1997-1998, 2006-2007, 2009-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/malloca.c b/lib/malloca.c index 942c60f9b..c0ff33568 100644 --- a/lib/malloca.c +++ b/lib/malloca.c @@ -1,5 +1,5 @@ /* Safe automatic memory allocation. - Copyright (C) 2003, 2006-2007, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2003, 2006-2007, 2009-2017 Free Software Foundation, Inc. Written by Bruno Haible , 2003. This program is free software; you can redistribute it and/or modify diff --git a/lib/malloca.h b/lib/malloca.h index 90fc3a6dc..3b61ca2b9 100644 --- a/lib/malloca.h +++ b/lib/malloca.h @@ -1,5 +1,5 @@ /* Safe automatic memory allocation. - Copyright (C) 2003-2007, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2003-2007, 2009-2017 Free Software Foundation, Inc. Written by Bruno Haible , 2003. This program is free software; you can redistribute it and/or modify @@ -21,6 +21,9 @@ #include #include #include +#include + +#include "xalloc-oversized.h" #ifdef __cplusplus @@ -73,15 +76,7 @@ extern void freea (void *p); It allocates an array of N objects, each with S bytes of memory, on the stack. S must be positive and N must be nonnegative. The array must be freed using freea() before the function returns. */ -#if 1 -/* Cf. the definition of xalloc_oversized. */ -# define nmalloca(n, s) \ - ((n) > (size_t) (sizeof (ptrdiff_t) <= sizeof (size_t) ? -1 : -2) / (s) \ - ? NULL \ - : malloca ((n) * (s))) -#else -extern void * nmalloca (size_t n, size_t s); -#endif +#define nmalloca(n, s) (xalloc_oversized (n, s) ? NULL : malloca ((n) * (s))) #ifdef __cplusplus diff --git a/lib/math.in.h b/lib/math.in.h index b3832c10e..53d385e54 100644 --- a/lib/math.in.h +++ b/lib/math.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 2002-2003, 2007-2016 Free Software Foundation, Inc. + Copyright (C) 2002-2003, 2007-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -63,6 +63,7 @@ _gl_cxx_ ## func ## l (long double l) \ return func (l); \ } # define _GL_MATH_CXX_REAL_FLOATING_DECL_2(func) \ +_GL_BEGIN_NAMESPACE \ inline int \ func (float f) \ { \ @@ -77,7 +78,8 @@ inline int \ func (long double l) \ { \ return _gl_cxx_ ## func ## l (l); \ -} +} \ +_GL_END_NAMESPACE #endif /* Helper macros to define a portability warning for the @@ -210,11 +212,20 @@ _NaN () #if @GNULIB_ACOSF@ -# if !@HAVE_ACOSF@ -# undef acosf +# if @REPLACE_ACOSF@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef acosf +# define acosf rpl_acosf +# endif +_GL_FUNCDECL_RPL (acosf, float, (float x)); +_GL_CXXALIAS_RPL (acosf, float, (float x)); +# else +# if !@HAVE_ACOSF@ +# undef acosf _GL_FUNCDECL_SYS (acosf, float, (float x)); -# endif +# endif _GL_CXXALIAS_SYS (acosf, float, (float x)); +# endif _GL_CXXALIASWARN (acosf); #elif defined GNULIB_POSIXCHECK # undef acosf @@ -241,11 +252,20 @@ _GL_WARN_ON_USE (acosl, "acosl is unportable - " #if @GNULIB_ASINF@ -# if !@HAVE_ASINF@ -# undef asinf +# if @REPLACE_ASINF@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef asinf +# define asinf rpl_asinf +# endif +_GL_FUNCDECL_RPL (asinf, float, (float x)); +_GL_CXXALIAS_RPL (asinf, float, (float x)); +# else +# if !@HAVE_ASINF@ +# undef asinf _GL_FUNCDECL_SYS (asinf, float, (float x)); -# endif +# endif _GL_CXXALIAS_SYS (asinf, float, (float x)); +# endif _GL_CXXALIASWARN (asinf); #elif defined GNULIB_POSIXCHECK # undef asinf @@ -272,11 +292,20 @@ _GL_WARN_ON_USE (asinl, "asinl is unportable - " #if @GNULIB_ATANF@ -# if !@HAVE_ATANF@ -# undef atanf +# if @REPLACE_ATANF@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef atanf +# define atanf rpl_atanf +# endif +_GL_FUNCDECL_RPL (atanf, float, (float x)); +_GL_CXXALIAS_RPL (atanf, float, (float x)); +# else +# if !@HAVE_ATANF@ +# undef atanf _GL_FUNCDECL_SYS (atanf, float, (float x)); -# endif +# endif _GL_CXXALIAS_SYS (atanf, float, (float x)); +# endif _GL_CXXALIASWARN (atanf); #elif defined GNULIB_POSIXCHECK # undef atanf @@ -303,11 +332,20 @@ _GL_WARN_ON_USE (atanl, "atanl is unportable - " #if @GNULIB_ATAN2F@ -# if !@HAVE_ATAN2F@ -# undef atan2f +# if @REPLACE_ATAN2F@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef atan2f +# define atan2f rpl_atan2f +# endif +_GL_FUNCDECL_RPL (atan2f, float, (float y, float x)); +_GL_CXXALIAS_RPL (atan2f, float, (float y, float x)); +# else +# if !@HAVE_ATAN2F@ +# undef atan2f _GL_FUNCDECL_SYS (atan2f, float, (float y, float x)); -# endif +# endif _GL_CXXALIAS_SYS (atan2f, float, (float y, float x)); +# endif _GL_CXXALIASWARN (atan2f); #elif defined GNULIB_POSIXCHECK # undef atan2f @@ -406,6 +444,7 @@ _GL_WARN_ON_USE (ceilf, "ceilf is unportable - " #if @GNULIB_CEIL@ # if @REPLACE_CEIL@ # if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef ceil # define ceil rpl_ceil # endif _GL_FUNCDECL_RPL (ceil, double, (double x)); @@ -485,11 +524,20 @@ _GL_WARN_ON_USE (copysign, "copysignl is unportable - " #if @GNULIB_COSF@ -# if !@HAVE_COSF@ -# undef cosf +# if @REPLACE_COSF@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef cosf +# define cosf rpl_cosf +# endif +_GL_FUNCDECL_RPL (cosf, float, (float x)); +_GL_CXXALIAS_RPL (cosf, float, (float x)); +# else +# if !@HAVE_COSF@ +# undef cosf _GL_FUNCDECL_SYS (cosf, float, (float x)); -# endif +# endif _GL_CXXALIAS_SYS (cosf, float, (float x)); +# endif _GL_CXXALIASWARN (cosf); #elif defined GNULIB_POSIXCHECK # undef cosf @@ -516,11 +564,20 @@ _GL_WARN_ON_USE (cosl, "cosl is unportable - " #if @GNULIB_COSHF@ -# if !@HAVE_COSHF@ -# undef coshf +# if @REPLACE_COSHF@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef coshf +# define coshf rpl_coshf +# endif +_GL_FUNCDECL_RPL (coshf, float, (float x)); +_GL_CXXALIAS_RPL (coshf, float, (float x)); +# else +# if !@HAVE_COSHF@ +# undef coshf _GL_FUNCDECL_SYS (coshf, float, (float x)); -# endif +# endif _GL_CXXALIAS_SYS (coshf, float, (float x)); +# endif _GL_CXXALIASWARN (coshf); #elif defined GNULIB_POSIXCHECK # undef coshf @@ -532,11 +589,20 @@ _GL_WARN_ON_USE (coshf, "coshf is unportable - " #if @GNULIB_EXPF@ -# if !@HAVE_EXPF@ -# undef expf +# if @REPLACE_EXPF@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef expf +# define expf rpl_expf +# endif +_GL_FUNCDECL_RPL (expf, float, (float x)); +_GL_CXXALIAS_RPL (expf, float, (float x)); +# else +# if !@HAVE_EXPF@ +# undef expf _GL_FUNCDECL_SYS (expf, float, (float x)); -# endif +# endif _GL_CXXALIAS_SYS (expf, float, (float x)); +# endif _GL_CXXALIASWARN (expf); #elif defined GNULIB_POSIXCHECK # undef expf @@ -753,6 +819,7 @@ _GL_WARN_ON_USE (floorf, "floorf is unportable - " #if @GNULIB_FLOOR@ # if @REPLACE_FLOOR@ # if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef floor # define floor rpl_floor # endif _GL_FUNCDECL_RPL (floor, double, (double x)); @@ -973,6 +1040,7 @@ _GL_WARN_ON_USE (frexpf, "frexpf is unportable - " #if @GNULIB_FREXP@ # if @REPLACE_FREXP@ # if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef frexp # define frexp rpl_frexp # endif _GL_FUNCDECL_RPL (frexp, double, (double x, int *expptr) _GL_ARG_NONNULL ((2))); @@ -980,7 +1048,7 @@ _GL_CXXALIAS_RPL (frexp, double, (double x, int *expptr)); # else _GL_CXXALIAS_SYS (frexp, double, (double x, int *expptr)); # endif -_GL_CXXALIASWARN (frexp); +_GL_CXXALIASWARN1 (frexp, double, (double x, int *expptr)); #elif defined GNULIB_POSIXCHECK # undef frexp /* Assume frexp is always declared. */ @@ -1822,11 +1890,20 @@ _GL_WARN_ON_USE (roundl, "roundl is unportable - " #if @GNULIB_SINF@ -# if !@HAVE_SINF@ -# undef sinf +# if @REPLACE_SINF@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef sinf +# define sinf rpl_sinf +# endif +_GL_FUNCDECL_RPL (sinf, float, (float x)); +_GL_CXXALIAS_RPL (sinf, float, (float x)); +# else +# if !@HAVE_SINF@ + # undef sinf _GL_FUNCDECL_SYS (sinf, float, (float x)); -# endif +# endif _GL_CXXALIAS_SYS (sinf, float, (float x)); +# endif _GL_CXXALIASWARN (sinf); #elif defined GNULIB_POSIXCHECK # undef sinf @@ -1853,11 +1930,20 @@ _GL_WARN_ON_USE (sinl, "sinl is unportable - " #if @GNULIB_SINHF@ -# if !@HAVE_SINHF@ -# undef sinhf +# if @REPLACE_SINHF@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef sinhf +# define sinhf rpl_sinhf +# endif +_GL_FUNCDECL_RPL (sinhf, float, (float x)); +_GL_CXXALIAS_RPL (sinhf, float, (float x)); +# else +# if !@HAVE_SINHF@ +# undef sinhf _GL_FUNCDECL_SYS (sinhf, float, (float x)); -# endif +# endif _GL_CXXALIAS_SYS (sinhf, float, (float x)); +# endif _GL_CXXALIASWARN (sinhf); #elif defined GNULIB_POSIXCHECK # undef sinhf @@ -1869,11 +1955,20 @@ _GL_WARN_ON_USE (sinhf, "sinhf is unportable - " #if @GNULIB_SQRTF@ -# if !@HAVE_SQRTF@ -# undef sqrtf +# if @REPLACE_SQRTF@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef sqrtf +# define sqrtf rpl_sqrtf +# endif +_GL_FUNCDECL_RPL (sqrtf, float, (float x)); +_GL_CXXALIAS_RPL (sqrtf, float, (float x)); +# else +# if !@HAVE_SQRTF@ +# undef sqrtf _GL_FUNCDECL_SYS (sqrtf, float, (float x)); -# endif +# endif _GL_CXXALIAS_SYS (sqrtf, float, (float x)); +# endif _GL_CXXALIASWARN (sqrtf); #elif defined GNULIB_POSIXCHECK # undef sqrtf @@ -1909,11 +2004,20 @@ _GL_WARN_ON_USE (sqrtl, "sqrtl is unportable - " #if @GNULIB_TANF@ -# if !@HAVE_TANF@ -# undef tanf +# if @REPLACE_TANF@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef tanf +# define tanf rpl_tanf +# endif +_GL_FUNCDECL_RPL (tanf, float, (float x)); +_GL_CXXALIAS_RPL (tanf, float, (float x)); +# else +# if !@HAVE_TANF@ +# undef tanf _GL_FUNCDECL_SYS (tanf, float, (float x)); -# endif +# endif _GL_CXXALIAS_SYS (tanf, float, (float x)); +# endif _GL_CXXALIASWARN (tanf); #elif defined GNULIB_POSIXCHECK # undef tanf @@ -1940,11 +2044,20 @@ _GL_WARN_ON_USE (tanl, "tanl is unportable - " #if @GNULIB_TANHF@ -# if !@HAVE_TANHF@ -# undef tanhf +# if @REPLACE_TANHF@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef tanhf +# define tanhf rpl_tanhf +# endif +_GL_FUNCDECL_RPL (tanhf, float, (float x)); +_GL_CXXALIAS_RPL (tanhf, float, (float x)); +# else +# if !@HAVE_TANHF@ +# undef tanhf _GL_FUNCDECL_SYS (tanhf, float, (float x)); -# endif +# endif _GL_CXXALIAS_SYS (tanhf, float, (float x)); +# endif _GL_CXXALIASWARN (tanhf); #elif defined GNULIB_POSIXCHECK # undef tanhf @@ -1958,6 +2071,7 @@ _GL_WARN_ON_USE (tanhf, "tanhf is unportable - " #if @GNULIB_TRUNCF@ # if @REPLACE_TRUNCF@ # if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef truncf # define truncf rpl_truncf # endif _GL_FUNCDECL_RPL (truncf, float, (float x)); @@ -1980,6 +2094,7 @@ _GL_WARN_ON_USE (truncf, "truncf is unportable - " #if @GNULIB_TRUNC@ # if @REPLACE_TRUNC@ # if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef trunc # define trunc rpl_trunc # endif _GL_FUNCDECL_RPL (trunc, double, (double x)); @@ -2039,7 +2154,7 @@ _GL_EXTERN_C int gl_isfinitel (long double x); gl_isfinitef (x)) # endif # ifdef __cplusplus -# ifdef isfinite +# if defined isfinite || defined GNULIB_NAMESPACE _GL_MATH_CXX_REAL_FLOATING_DECL_1 (isfinite) # undef isfinite _GL_MATH_CXX_REAL_FLOATING_DECL_2 (isfinite) @@ -2066,7 +2181,7 @@ _GL_EXTERN_C int gl_isinfl (long double x); gl_isinff (x)) # endif # ifdef __cplusplus -# ifdef isinf +# if defined isinf || defined GNULIB_NAMESPACE _GL_MATH_CXX_REAL_FLOATING_DECL_1 (isinf) # undef isinf _GL_MATH_CXX_REAL_FLOATING_DECL_2 (isinf) @@ -2184,7 +2299,7 @@ _GL_EXTERN_C int rpl_isnanl (long double x) _GL_ATTRIBUTE_CONST; __builtin_isnanf ((float)(x))) # endif # ifdef __cplusplus -# ifdef isnan +# if defined isnan || defined GNULIB_NAMESPACE _GL_MATH_CXX_REAL_FLOATING_DECL_1 (isnan) # undef isnan _GL_MATH_CXX_REAL_FLOATING_DECL_2 (isnan) @@ -2259,7 +2374,7 @@ _GL_EXTERN_C int gl_signbitl (long double arg); gl_signbitf (x)) # endif # ifdef __cplusplus -# ifdef signbit +# if defined signbit || defined GNULIB_NAMESPACE _GL_MATH_CXX_REAL_FLOATING_DECL_1 (signbit) # undef signbit _GL_MATH_CXX_REAL_FLOATING_DECL_2 (signbit) diff --git a/lib/mbrtowc.c b/lib/mbrtowc.c index 2e5a0b6aa..d19b1a035 100644 --- a/lib/mbrtowc.c +++ b/lib/mbrtowc.c @@ -1,5 +1,5 @@ /* Convert multibyte character to wide character. - Copyright (C) 1999-2002, 2005-2016 Free Software Foundation, Inc. + Copyright (C) 1999-2002, 2005-2017 Free Software Foundation, Inc. Written by Bruno Haible , 2008. This program is free software: you can redistribute it and/or modify diff --git a/lib/mbsinit.c b/lib/mbsinit.c index 54ecc9edf..4d0b1184a 100644 --- a/lib/mbsinit.c +++ b/lib/mbsinit.c @@ -1,5 +1,5 @@ /* Test for initial conversion state. - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. Written by Bruno Haible , 2008. This program is free software: you can redistribute it and/or modify diff --git a/lib/mbtowc-impl.h b/lib/mbtowc-impl.h index 156693409..268f0e3da 100644 --- a/lib/mbtowc-impl.h +++ b/lib/mbtowc-impl.h @@ -1,5 +1,5 @@ /* Convert multibyte character to wide character. - Copyright (C) 2011-2016 Free Software Foundation, Inc. + Copyright (C) 2011-2017 Free Software Foundation, Inc. Written by Bruno Haible , 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/mbtowc.c b/lib/mbtowc.c index 253fd223b..fbed5dc2f 100644 --- a/lib/mbtowc.c +++ b/lib/mbtowc.c @@ -1,5 +1,5 @@ /* Convert multibyte character to wide character. - Copyright (C) 2011-2016 Free Software Foundation, Inc. + Copyright (C) 2011-2017 Free Software Foundation, Inc. Written by Bruno Haible , 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/memchr.c b/lib/memchr.c index f866c959e..91c2b8767 100644 --- a/lib/memchr.c +++ b/lib/memchr.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1991, 1993, 1996-1997, 1999-2000, 2003-2004, 2006, 2008-2016 +/* Copyright (C) 1991, 1993, 1996-1997, 1999-2000, 2003-2004, 2006, 2008-2017 Free Software Foundation, Inc. Based on strlen implementation by Torbjorn Granlund (tege@sics.se), diff --git a/lib/mkdir.c b/lib/mkdir.c index 8a1854502..1ac765007 100644 --- a/lib/mkdir.c +++ b/lib/mkdir.c @@ -1,7 +1,7 @@ /* On some systems, mkdir ("foo/", 0700) fails because of the trailing slash. On those systems, this wrapper removes the trailing slash. - Copyright (C) 2001, 2003, 2006, 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2001, 2003, 2006, 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/mkostemp.c b/lib/mkostemp.c index 25a63b7b1..d2190bd6e 100644 --- a/lib/mkostemp.c +++ b/lib/mkostemp.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998-1999, 2001, 2005-2007, 2009-2016 Free Software +/* Copyright (C) 1998-1999, 2001, 2005-2007, 2009-2017 Free Software Foundation, Inc. This file is derived from the one in the GNU C Library. diff --git a/lib/mktime-internal.h b/lib/mktime-internal.h index 0c9e20405..bfde06fa2 100644 --- a/lib/mktime-internal.h +++ b/lib/mktime-internal.h @@ -1,6 +1,6 @@ /* mktime variant that also uses an offset guess - Copyright 2016 Free Software Foundation, Inc. + Copyright 2016-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public diff --git a/lib/mktime.c b/lib/mktime.c index 9eb3e7652..2efd44a22 100644 --- a/lib/mktime.c +++ b/lib/mktime.c @@ -1,5 +1,5 @@ /* Convert a 'struct tm' to a time_t value. - Copyright (C) 1993-2016 Free Software Foundation, Inc. + Copyright (C) 1993-2017 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Paul Eggert . @@ -153,7 +153,7 @@ isdst_differ (int a, int b) /* Return an integer value measuring (YEAR1-YDAY1 HOUR1:MIN1:SEC1) - (YEAR0-YDAY0 HOUR0:MIN0:SEC0) in seconds, assuming that the clocks - were not adjusted between the time stamps. + were not adjusted between the timestamps. The YEAR values uses the same numbering as TP->tm_year. Values need not be in the usual range. However, YEAR1 must not overflow diff --git a/lib/msvc-inval.c b/lib/msvc-inval.c index c649d5f99..32818f7da 100644 --- a/lib/msvc-inval.c +++ b/lib/msvc-inval.c @@ -1,5 +1,5 @@ /* Invalid parameter handler for MSVC runtime libraries. - Copyright (C) 2011-2016 Free Software Foundation, Inc. + Copyright (C) 2011-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/msvc-inval.h b/lib/msvc-inval.h index 32a44a340..8147f09ab 100644 --- a/lib/msvc-inval.h +++ b/lib/msvc-inval.h @@ -1,5 +1,5 @@ /* Invalid parameter handler for MSVC runtime libraries. - Copyright (C) 2011-2016 Free Software Foundation, Inc. + Copyright (C) 2011-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/msvc-nothrow.c b/lib/msvc-nothrow.c index 1c7b5849f..c8e483b7f 100644 --- a/lib/msvc-nothrow.c +++ b/lib/msvc-nothrow.c @@ -1,6 +1,6 @@ /* Wrappers that don't throw invalid parameter notifications with MSVC runtime libraries. - Copyright (C) 2011-2016 Free Software Foundation, Inc. + Copyright (C) 2011-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/msvc-nothrow.h b/lib/msvc-nothrow.h index f76f4de84..52dbeb1f2 100644 --- a/lib/msvc-nothrow.h +++ b/lib/msvc-nothrow.h @@ -1,6 +1,6 @@ /* Wrappers that don't throw invalid parameter notifications with MSVC runtime libraries. - Copyright (C) 2011-2016 Free Software Foundation, Inc. + Copyright (C) 2011-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/netdb.in.h b/lib/netdb.in.h index 8361da811..d14d57bad 100644 --- a/lib/netdb.in.h +++ b/lib/netdb.in.h @@ -1,5 +1,5 @@ /* Provide a netdb.h header file for systems lacking it (read: MinGW). - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. Written by Simon Josefsson. This program is free software; you can redistribute it and/or modify diff --git a/lib/netinet_in.in.h b/lib/netinet_in.in.h index 4be15ab26..51dc48bfd 100644 --- a/lib/netinet_in.in.h +++ b/lib/netinet_in.in.h @@ -1,5 +1,5 @@ /* Substitute for . - Copyright (C) 2007-2016 Free Software Foundation, Inc. + Copyright (C) 2007-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/nl_langinfo.c b/lib/nl_langinfo.c index 5c3124fab..441e75cd2 100644 --- a/lib/nl_langinfo.c +++ b/lib/nl_langinfo.c @@ -1,6 +1,6 @@ /* nl_langinfo() replacement: query locale dependent information. - Copyright (C) 2007-2016 Free Software Foundation, Inc. + Copyright (C) 2007-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -34,7 +34,6 @@ static char * ctype_codeset (void) { static char buf[2 + 10 + 1]; - size_t buflen = 0; char const *locale = setlocale (LC_CTYPE, NULL); char *codeset = buf; size_t codesetlen; @@ -99,14 +98,14 @@ rpl_nl_langinfo (nl_item item) # endif # if GNULIB_defined_T_FMT_AMPM case T_FMT_AMPM: - return "%I:%M:%S %p"; + return (char *) "%I:%M:%S %p"; # endif # if GNULIB_defined_ERA case ERA: /* The format is not standardized. In glibc it is a sequence of strings of the form "direction:offset:start_date:end_date:era_name:era_format" with an empty string at the end. */ - return ""; + return (char *) ""; case ERA_D_FMT: /* The %Ex conversion in strftime behaves like %x if the locale does not have an alternative time format. */ @@ -125,13 +124,13 @@ rpl_nl_langinfo (nl_item item) case ALT_DIGITS: /* The format is not standardized. In glibc it is a sequence of 10 strings, appended in memory. */ - return "\0\0\0\0\0\0\0\0\0\0"; + return (char *) "\0\0\0\0\0\0\0\0\0\0"; # endif # if GNULIB_defined_YESEXPR || !FUNC_NL_LANGINFO_YESEXPR_WORKS case YESEXPR: - return "^[yY]"; + return (char *) "^[yY]"; case NOEXPR: - return "^[nN]"; + return (char *) "^[nN]"; # endif default: break; @@ -163,9 +162,9 @@ nl_langinfo (nl_item item) return codeset; } # ifdef __BEOS__ - return "UTF-8"; + return (char *) "UTF-8"; # else - return "ISO-8859-1"; + return (char *) "ISO-8859-1"; # endif /* nl_langinfo items of the LC_NUMERIC category */ case RADIXCHAR: @@ -178,23 +177,23 @@ nl_langinfo (nl_item item) TODO: Really use the locale. */ case D_T_FMT: case ERA_D_T_FMT: - return "%a %b %e %H:%M:%S %Y"; + return (char *) "%a %b %e %H:%M:%S %Y"; case D_FMT: case ERA_D_FMT: - return "%m/%d/%y"; + return (char *) "%m/%d/%y"; case T_FMT: case ERA_T_FMT: - return "%H:%M:%S"; + return (char *) "%H:%M:%S"; case T_FMT_AMPM: - return "%I:%M:%S %p"; + return (char *) "%I:%M:%S %p"; case AM_STR: if (!strftime (nlbuf, sizeof nlbuf, "%p", &tmm)) - return "AM"; + return (char *) "AM"; return nlbuf; case PM_STR: tmm.tm_hour = 12; if (!strftime (nlbuf, sizeof nlbuf, "%p", &tmm)) - return "PM"; + return (char *) "PM"; return nlbuf; case DAY_1: case DAY_2: @@ -274,9 +273,9 @@ nl_langinfo (nl_item item) return nlbuf; } case ERA: - return ""; + return (char *) ""; case ALT_DIGITS: - return "\0\0\0\0\0\0\0\0\0\0"; + return (char *) "\0\0\0\0\0\0\0\0\0\0"; /* nl_langinfo items of the LC_MONETARY category. */ case CRNCYSTR: return localeconv () ->currency_symbol; @@ -311,11 +310,11 @@ nl_langinfo (nl_item item) /* nl_langinfo items of the LC_MESSAGES category TODO: Really use the locale. */ case YESEXPR: - return "^[yY]"; + return (char *) "^[yY]"; case NOEXPR: - return "^[nN]"; + return (char *) "^[nN]"; default: - return ""; + return (char *) ""; } } diff --git a/lib/nproc.c b/lib/nproc.c index e79094cf1..78e13e3bf 100644 --- a/lib/nproc.c +++ b/lib/nproc.c @@ -1,6 +1,6 @@ /* Detect the number of processors. - Copyright (C) 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2009-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/nproc.h b/lib/nproc.h index 6f8b4ae7c..4f60219d2 100644 --- a/lib/nproc.h +++ b/lib/nproc.h @@ -1,6 +1,6 @@ /* Detect the number of processors. - Copyright (C) 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2009-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/open.c b/lib/open.c index b815fcdb5..4dd5e2be7 100644 --- a/lib/open.c +++ b/lib/open.c @@ -1,5 +1,5 @@ /* Open a descriptor to a file. - Copyright (C) 2007-2016 Free Software Foundation, Inc. + Copyright (C) 2007-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/pathmax.h b/lib/pathmax.h index e7b8c7cd8..0ebce818f 100644 --- a/lib/pathmax.h +++ b/lib/pathmax.h @@ -1,5 +1,5 @@ /* Define PATH_MAX somehow. Requires sys/types.h. - Copyright (C) 1992, 1999, 2001, 2003, 2005, 2009-2016 Free Software + Copyright (C) 1992, 1999, 2001, 2003, 2005, 2009-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/pipe.c b/lib/pipe.c index 4eda943d2..349a85950 100644 --- a/lib/pipe.c +++ b/lib/pipe.c @@ -1,5 +1,5 @@ /* Create a pipe. - Copyright (C) 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2009-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/pipe2.c b/lib/pipe2.c index e4ec14632..13e3dcf28 100644 --- a/lib/pipe2.c +++ b/lib/pipe2.c @@ -1,5 +1,5 @@ /* Create a pipe, with specific opening flags. - Copyright (C) 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2009-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/poll.c b/lib/poll.c index bf8dd1c97..e700ac358 100644 --- a/lib/poll.c +++ b/lib/poll.c @@ -1,7 +1,7 @@ /* Emulation for poll(2) Contributed by Paolo Bonzini. - Copyright 2001-2003, 2006-2016 Free Software Foundation, Inc. + Copyright 2001-2003, 2006-2017 Free Software Foundation, Inc. This file is part of gnulib. diff --git a/lib/poll.in.h b/lib/poll.in.h index 7066229d8..e9b141d8f 100644 --- a/lib/poll.in.h +++ b/lib/poll.in.h @@ -1,7 +1,7 @@ /* Header for poll(2) emulation Contributed by Paolo Bonzini. - Copyright 2001-2003, 2007, 2009-2016 Free Software Foundation, Inc. + Copyright 2001-2003, 2007, 2009-2017 Free Software Foundation, Inc. This file is part of gnulib. diff --git a/lib/printf-args.c b/lib/printf-args.c index ff8662549..42975fa22 100644 --- a/lib/printf-args.c +++ b/lib/printf-args.c @@ -1,5 +1,5 @@ /* Decomposed printf argument list. - Copyright (C) 1999, 2002-2003, 2005-2007, 2009-2016 Free Software + Copyright (C) 1999, 2002-2003, 2005-2007, 2009-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/printf-args.h b/lib/printf-args.h index 3b2fe7fc5..a7df28636 100644 --- a/lib/printf-args.h +++ b/lib/printf-args.h @@ -1,5 +1,5 @@ /* Decomposed printf argument list. - Copyright (C) 1999, 2002-2003, 2006-2007, 2011-2016 Free Software + Copyright (C) 1999, 2002-2003, 2006-2007, 2011-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/printf-parse.c b/lib/printf-parse.c index f19d17f99..a3b2c9da1 100644 --- a/lib/printf-parse.c +++ b/lib/printf-parse.c @@ -1,5 +1,5 @@ /* Formatted output to strings. - Copyright (C) 1999-2000, 2002-2003, 2006-2016 Free Software Foundation, Inc. + Copyright (C) 1999-2000, 2002-2003, 2006-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/printf-parse.h b/lib/printf-parse.h index 4e753bef8..571571914 100644 --- a/lib/printf-parse.h +++ b/lib/printf-parse.h @@ -1,5 +1,5 @@ /* Parse printf format string. - Copyright (C) 1999, 2002-2003, 2005, 2007, 2010-2016 Free Software + Copyright (C) 1999, 2002-2003, 2005, 2007, 2010-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify diff --git a/lib/putenv.c b/lib/putenv.c index 8db04d23a..ba1cc07dd 100644 --- a/lib/putenv.c +++ b/lib/putenv.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1991, 1994, 1997-1998, 2000, 2003-2016 Free Software +/* Copyright (C) 1991, 1994, 1997-1998, 2000, 2003-2017 Free Software Foundation, Inc. NOTE: The canonical source of this file is maintained with the GNU C diff --git a/lib/raise.c b/lib/raise.c index 60a76c462..223c1528c 100644 --- a/lib/raise.c +++ b/lib/raise.c @@ -1,6 +1,6 @@ /* Provide a non-threads replacement for the POSIX raise function. - Copyright (C) 2002-2003, 2005-2006, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2002-2003, 2005-2006, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/read.c b/lib/read.c index aea8bbc04..5385cfd5a 100644 --- a/lib/read.c +++ b/lib/read.c @@ -1,5 +1,5 @@ /* POSIX compatible read() function. - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. Written by Bruno Haible , 2011. This program is free software: you can redistribute it and/or modify diff --git a/lib/readlink.c b/lib/readlink.c index 53ee57d54..d624fec89 100644 --- a/lib/readlink.c +++ b/lib/readlink.c @@ -1,5 +1,5 @@ /* Stub for readlink(). - Copyright (C) 2003-2007, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2003-2007, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/recv.c b/lib/recv.c index a6e962fb1..d5b115d3f 100644 --- a/lib/recv.c +++ b/lib/recv.c @@ -1,6 +1,6 @@ /* recv.c --- wrappers for Windows recv function - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/recvfrom.c b/lib/recvfrom.c index 2da508e7a..bf4b87310 100644 --- a/lib/recvfrom.c +++ b/lib/recvfrom.c @@ -1,6 +1,6 @@ /* recvfrom.c --- wrappers for Windows recvfrom function - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/ref-add.sin b/lib/ref-add.sin index 313d82ee0..bfd5b80c8 100644 --- a/lib/ref-add.sin +++ b/lib/ref-add.sin @@ -1,6 +1,6 @@ # Add this package to a list of references stored in a text file. # -# Copyright (C) 2000, 2009-2016 Free Software Foundation, Inc. +# Copyright (C) 2000, 2009-2017 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/ref-del.sin b/lib/ref-del.sin index 46532d8eb..f281f21d1 100644 --- a/lib/ref-del.sin +++ b/lib/ref-del.sin @@ -1,6 +1,6 @@ # Remove this package from a list of references stored in a text file. # -# Copyright (C) 2000, 2009-2016 Free Software Foundation, Inc. +# Copyright (C) 2000, 2009-2017 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/regcomp.c b/lib/regcomp.c index 6c4db27cf..9fd4fed99 100644 --- a/lib/regcomp.c +++ b/lib/regcomp.c @@ -1,5 +1,5 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2016 Free Software Foundation, Inc. + Copyright (C) 2002-2017 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa . diff --git a/lib/regex.c b/lib/regex.c index f5b46559a..d1de1395c 100644 --- a/lib/regex.c +++ b/lib/regex.c @@ -1,5 +1,5 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2016 Free Software Foundation, Inc. + Copyright (C) 2002-2017 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa . diff --git a/lib/regex.h b/lib/regex.h index 3ba64ac89..e356b2cd9 100644 --- a/lib/regex.h +++ b/lib/regex.h @@ -1,6 +1,6 @@ /* Definitions for data structures and routines for the regular expression library. - Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2016 Free Software + Copyright (C) 1985, 1989-1993, 1995-1998, 2000-2003, 2005-2017 Free Software Foundation, Inc. This file is part of the GNU C Library. @@ -552,7 +552,7 @@ extern int re_compile_fastmap (struct re_pattern_buffer *__buffer); match, or -2 for an internal error. Also return register information in REGS (if REGS and BUFFER->no_sub are nonzero). */ extern regoff_t re_search (struct re_pattern_buffer *__buffer, - const char *__string, regoff_t __length, + const char *__String, regoff_t __length, regoff_t __start, regoff_t __range, struct re_registers *__regs); @@ -570,7 +570,7 @@ extern regoff_t re_search_2 (struct re_pattern_buffer *__buffer, /* Like 're_search', but return how many characters in STRING the regexp in BUFFER matched, starting at position START. */ extern regoff_t re_match (struct re_pattern_buffer *__buffer, - const char *__string, regoff_t __length, + const char *__String, regoff_t __length, regoff_t __start, struct re_registers *__regs); @@ -642,7 +642,7 @@ extern int regcomp (regex_t *_Restrict_ __preg, int __cflags); extern int regexec (const regex_t *_Restrict_ __preg, - const char *_Restrict_ __string, size_t __nmatch, + const char *_Restrict_ __String, size_t __nmatch, regmatch_t __pmatch[_Restrict_arr_], int __eflags); diff --git a/lib/regex_internal.c b/lib/regex_internal.c index cd78b252a..03f689523 100644 --- a/lib/regex_internal.c +++ b/lib/regex_internal.c @@ -1,5 +1,5 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2016 Free Software Foundation, Inc. + Copyright (C) 2002-2017 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa . diff --git a/lib/regex_internal.h b/lib/regex_internal.h index 56a315a4f..9bb074056 100644 --- a/lib/regex_internal.h +++ b/lib/regex_internal.h @@ -1,5 +1,5 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2016 Free Software Foundation, Inc. + Copyright (C) 2002-2017 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa . @@ -33,6 +33,8 @@ #include #include +#include "intprops.h" + #ifdef _LIBC # include # define lock_define(name) __libc_lock_define (, name) @@ -113,11 +115,7 @@ # define RE_ENABLE_I18N #endif -#if __GNUC__ >= 3 -# define BE(expr, val) __builtin_expect (expr, val) -#else -# define BE(expr, val) (expr) -#endif +#define BE(expr, val) __builtin_expect (expr, val) /* Number of ASCII characters. */ #define ASCII_CHARS 0x80 diff --git a/lib/regexec.c b/lib/regexec.c index afdc1737b..ef52b243a 100644 --- a/lib/regexec.c +++ b/lib/regexec.c @@ -1,5 +1,5 @@ /* Extended regular expression matching and search library. - Copyright (C) 2002-2016 Free Software Foundation, Inc. + Copyright (C) 2002-2017 Free Software Foundation, Inc. This file is part of the GNU C Library. Contributed by Isamu Hasegawa . @@ -354,10 +354,12 @@ re_search_2_stub (struct re_pattern_buffer *bufp, const char *string1, { const char *str; regoff_t rval; - Idx len = length1 + length2; + Idx len; char *s = NULL; - if (BE (length1 < 0 || length2 < 0 || stop < 0 || len < length1, 0)) + if (BE ((length1 < 0 || length2 < 0 || stop < 0 + || INT_ADD_WRAPV (length1, length2, &len)), + 0)) return -2; /* Concatenate the strings. */ diff --git a/lib/rename.c b/lib/rename.c index 53fde10a7..dfa1e3b40 100644 --- a/lib/rename.c +++ b/lib/rename.c @@ -1,6 +1,6 @@ /* Work around rename bugs in some systems. - Copyright (C) 2001-2003, 2005-2006, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2001-2003, 2005-2006, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/rmdir.c b/lib/rmdir.c index cd4d9c1c6..95d3f3d26 100644 --- a/lib/rmdir.c +++ b/lib/rmdir.c @@ -1,6 +1,6 @@ /* Work around rmdir bugs. - Copyright (C) 1988, 1990, 1999, 2003-2006, 2009-2016 Free Software + Copyright (C) 1988, 1990, 1999, 2003-2006, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/round.c b/lib/round.c index 7a595ad4f..86f24df7f 100644 --- a/lib/round.c +++ b/lib/round.c @@ -1,5 +1,5 @@ /* Round toward nearest, breaking ties away from zero. - Copyright (C) 2007, 2010-2016 Free Software Foundation, Inc. + Copyright (C) 2007, 2010-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/safe-read.c b/lib/safe-read.c index 57978af6b..bf9d7be7c 100644 --- a/lib/safe-read.c +++ b/lib/safe-read.c @@ -1,6 +1,6 @@ /* An interface to read and write that retries after interrupts. - Copyright (C) 1993-1994, 1998, 2002-2006, 2009-2016 Free Software + Copyright (C) 1993-1994, 1998, 2002-2006, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/safe-read.h b/lib/safe-read.h index 6665f2dd8..09da317df 100644 --- a/lib/safe-read.h +++ b/lib/safe-read.h @@ -1,5 +1,5 @@ /* An interface to read() that retries after interrupts. - Copyright (C) 2002, 2006, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2002, 2006, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/safe-write.c b/lib/safe-write.c index 96c5db28a..c906694ec 100644 --- a/lib/safe-write.c +++ b/lib/safe-write.c @@ -1,5 +1,5 @@ /* An interface to write that retries after interrupts. - Copyright (C) 2002, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2002, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/safe-write.h b/lib/safe-write.h index 3bae8535d..dfada8b1d 100644 --- a/lib/safe-write.h +++ b/lib/safe-write.h @@ -1,5 +1,5 @@ /* An interface to write() that retries after interrupts. - Copyright (C) 2002, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2002, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/same-inode.h b/lib/same-inode.h index e19c68ae4..88a43c7f7 100644 --- a/lib/same-inode.h +++ b/lib/same-inode.h @@ -1,6 +1,6 @@ -/* Determine whether two stat buffers refer to the same file. +/* Determine whether two stat buffers are known to refer to the same file. - Copyright (C) 2006, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2006, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -24,6 +24,10 @@ && (a).st_ino[1] == (b).st_ino[1] \ && (a).st_ino[2] == (b).st_ino[2] \ && (a).st_dev == (b).st_dev) +# elif (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ +/* On MinGW, struct stat lacks necessary info, so always return 0. + Callers can use !a.st_ino to deduce that the information is unknown. */ +# define SAME_INODE(a, b) 0 # else # define SAME_INODE(a, b) \ ((a).st_ino == (b).st_ino \ diff --git a/lib/secure_getenv.c b/lib/secure_getenv.c index 821cb092d..b8c64c7a8 100644 --- a/lib/secure_getenv.c +++ b/lib/secure_getenv.c @@ -1,6 +1,6 @@ /* Look up an environment variable, returning NULL in insecure situations. - Copyright 2013-2016 Free Software Foundation, Inc. + Copyright 2013-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/select.c b/lib/select.c index 4f6acccd2..fe50a9569 100644 --- a/lib/select.c +++ b/lib/select.c @@ -1,7 +1,7 @@ /* Emulation for select(2) Contributed by Paolo Bonzini. - Copyright 2008-2016 Free Software Foundation, Inc. + Copyright 2008-2017 Free Software Foundation, Inc. This file is part of gnulib. diff --git a/lib/send.c b/lib/send.c index 3f1c567f5..d4a17a5a8 100644 --- a/lib/send.c +++ b/lib/send.c @@ -1,6 +1,6 @@ /* send.c --- wrappers for Windows send function - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sendto.c b/lib/sendto.c index 494f3885d..1941beca1 100644 --- a/lib/sendto.c +++ b/lib/sendto.c @@ -1,6 +1,6 @@ /* sendto.c --- wrappers for Windows sendto function - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/setenv.c b/lib/setenv.c index f67233b0f..be43c0cec 100644 --- a/lib/setenv.c +++ b/lib/setenv.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1992, 1995-2003, 2005-2016 Free Software Foundation, Inc. +/* Copyright (C) 1992, 1995-2003, 2005-2017 Free Software Foundation, Inc. This file is part of the GNU C Library. This program is free software: you can redistribute it and/or modify diff --git a/lib/setsockopt.c b/lib/setsockopt.c index 1e863a8f0..8d4c1f070 100644 --- a/lib/setsockopt.c +++ b/lib/setsockopt.c @@ -1,6 +1,6 @@ /* setsockopt.c --- wrappers for Windows setsockopt function - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/shutdown.c b/lib/shutdown.c index b9539712d..16496dcbf 100644 --- a/lib/shutdown.c +++ b/lib/shutdown.c @@ -1,6 +1,6 @@ /* shutdown.c --- wrappers for Windows shutdown function - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/signal.in.h b/lib/signal.in.h index 90f7d309e..2a272cccc 100644 --- a/lib/signal.in.h +++ b/lib/signal.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 2006-2016 Free Software Foundation, Inc. + Copyright (C) 2006-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/signbitd.c b/lib/signbitd.c index f584fe2f1..096af7d4f 100644 --- a/lib/signbitd.c +++ b/lib/signbitd.c @@ -1,5 +1,5 @@ /* signbit() macro: Determine the sign bit of a floating-point number. - Copyright (C) 2007-2016 Free Software Foundation, Inc. + Copyright (C) 2007-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/signbitf.c b/lib/signbitf.c index 7d35edaa5..09443b11c 100644 --- a/lib/signbitf.c +++ b/lib/signbitf.c @@ -1,5 +1,5 @@ /* signbit() macro: Determine the sign bit of a floating-point number. - Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/signbitl.c b/lib/signbitl.c index b12590dc8..c072bf84f 100644 --- a/lib/signbitl.c +++ b/lib/signbitl.c @@ -1,5 +1,5 @@ /* signbit() macro: Determine the sign bit of a floating-point number. - Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2007, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/size_max.h b/lib/size_max.h index 5b04b79fa..2f4a439b5 100644 --- a/lib/size_max.h +++ b/lib/size_max.h @@ -1,5 +1,5 @@ /* size_max.h -- declare SIZE_MAX through system headers - Copyright (C) 2005-2006, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2005-2006, 2009-2017 Free Software Foundation, Inc. Written by Simon Josefsson. This program is free software; you can redistribute it and/or modify diff --git a/lib/snprintf.c b/lib/snprintf.c index 2205cb78d..51ef37443 100644 --- a/lib/snprintf.c +++ b/lib/snprintf.c @@ -1,5 +1,5 @@ /* Formatted output to strings. - Copyright (C) 2004, 2006-2016 Free Software Foundation, Inc. + Copyright (C) 2004, 2006-2017 Free Software Foundation, Inc. Written by Simon Josefsson and Paul Eggert. This program is free software; you can redistribute it and/or modify diff --git a/lib/socket.c b/lib/socket.c index af269820b..1c3500ad8 100644 --- a/lib/socket.c +++ b/lib/socket.c @@ -1,6 +1,6 @@ /* socket.c --- wrappers for Windows socket function - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sockets.c b/lib/sockets.c index ca6595448..8aa275636 100644 --- a/lib/sockets.c +++ b/lib/sockets.c @@ -1,6 +1,6 @@ /* sockets.c --- wrappers for Windows socket functions - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sockets.h b/lib/sockets.h index a1555a099..9698f32c6 100644 --- a/lib/sockets.h +++ b/lib/sockets.h @@ -1,6 +1,6 @@ /* sockets.h - wrappers for Windows socket functions - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -27,13 +27,13 @@ #define SOCKETS_2_2 0x0202 int gl_sockets_startup (int version) -#if !WINDOWS_SOCKETS +#ifndef WINDOWS_SOCKETS _GL_ATTRIBUTE_CONST #endif ; int gl_sockets_cleanup (void) -#if !WINDOWS_SOCKETS +#ifndef WINDOWS_SOCKETS _GL_ATTRIBUTE_CONST #endif ; @@ -41,7 +41,7 @@ int gl_sockets_cleanup (void) /* This function is useful it you create a socket using gnulib's Winsock wrappers but needs to pass on the socket handle to some other library that only accepts sockets. */ -#if WINDOWS_SOCKETS +#ifdef WINDOWS_SOCKETS #include diff --git a/lib/stat-time.h b/lib/stat-time.h index 1399246d4..f761d27bc 100644 --- a/lib/stat-time.h +++ b/lib/stat-time.h @@ -1,6 +1,6 @@ /* stat-related time functions. - Copyright (C) 2005, 2007, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2005, 2007, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -181,7 +181,7 @@ get_stat_birthtime (struct stat const *st) || defined HAVE_STRUCT_STAT_ST_BIRTHTIMENSEC) /* FreeBSD and NetBSD sometimes signal the absence of knowledge by using zero. Attempt to work around this problem. Alas, this can - report failure even for valid time stamps. Also, NetBSD + report failure even for valid timestamps. Also, NetBSD sometimes returns junk in the birth time fields; work around this bug if it is detected. */ if (! (t.tv_sec && 0 <= t.tv_nsec && t.tv_nsec < 1000000000)) diff --git a/lib/stat.c b/lib/stat.c index 83a9a6e4a..cf261789b 100644 --- a/lib/stat.c +++ b/lib/stat.c @@ -1,5 +1,5 @@ /* Work around platform bugs in stat. - Copyright (C) 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/stdalign.in.h b/lib/stdalign.in.h index 41913c0be..2c00533d6 100644 --- a/lib/stdalign.in.h +++ b/lib/stdalign.in.h @@ -1,6 +1,6 @@ /* A substitute for ISO C11 . - Copyright 2011-2016 Free Software Foundation, Inc. + Copyright 2011-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/stdbool.in.h b/lib/stdbool.in.h index 267215bcc..301df94a3 100644 --- a/lib/stdbool.in.h +++ b/lib/stdbool.in.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2001-2003, 2006-2016 Free Software Foundation, Inc. +/* Copyright (C) 2001-2003, 2006-2017 Free Software Foundation, Inc. Written by Bruno Haible , 2001. This program is free software; you can redistribute it and/or modify diff --git a/lib/stddef.in.h b/lib/stddef.in.h index 927bc2db4..7b0ce956c 100644 --- a/lib/stddef.in.h +++ b/lib/stddef.in.h @@ -1,6 +1,6 @@ /* A substitute for POSIX 2008 , for platforms that have issues. - Copyright (C) 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2009-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/stdint.in.h b/lib/stdint.in.h index d5698477c..11e8e13f4 100644 --- a/lib/stdint.in.h +++ b/lib/stdint.in.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2001-2002, 2004-2016 Free Software Foundation, Inc. +/* Copyright (C) 2001-2002, 2004-2017 Free Software Foundation, Inc. Written by Paul Eggert, Bruno Haible, Sam Steingold, Peter Burwood. This file is part of gnulib. @@ -79,49 +79,60 @@ #if ! defined _@GUARD_PREFIX@_STDINT_H && ! defined _GL_JUST_INCLUDE_SYSTEM_STDINT_H #define _@GUARD_PREFIX@_STDINT_H +/* Get SCHAR_MIN, SCHAR_MAX, UCHAR_MAX, INT_MIN, INT_MAX, + LONG_MIN, LONG_MAX, ULONG_MAX, _GL_INTEGER_WIDTH. */ +#include + +/* Override WINT_MIN and WINT_MAX if gnulib's or overrides + wint_t. */ +#if @GNULIB_OVERRIDES_WINT_T@ +# undef WINT_MIN +# undef WINT_MAX +# define WINT_MIN 0x0U +# define WINT_MAX 0xffffffffU +#endif + +#if ! @HAVE_C99_STDINT_H@ + /* defines some of the stdint.h types as well, on glibc, IRIX 6.5, and OpenBSD 3.8 (via ). AIX 5.2 isn't needed and causes troubles. Mac OS X 10.4.6 includes (which is us), but relies on the system definitions, so include after @NEXT_STDINT_H@. */ -#if @HAVE_SYS_TYPES_H@ && ! defined _AIX -# include -#endif +# if @HAVE_SYS_TYPES_H@ && ! defined _AIX +# include +# endif -/* Get SCHAR_MIN, SCHAR_MAX, UCHAR_MAX, INT_MIN, INT_MAX, - LONG_MIN, LONG_MAX, ULONG_MAX. */ -#include - -#if @HAVE_INTTYPES_H@ +# if @HAVE_INTTYPES_H@ /* In OpenBSD 3.8, includes , which defines int{8,16,32,64}_t, uint{8,16,32,64}_t and __BIT_TYPES_DEFINED__. also defines intptr_t and uintptr_t. */ -# include -#elif @HAVE_SYS_INTTYPES_H@ +# include +# elif @HAVE_SYS_INTTYPES_H@ /* Solaris 7 has the types except the *_fast*_t types, and the macros except for *_FAST*_*, INTPTR_MIN, PTRDIFF_MIN, PTRDIFF_MAX. */ -# include -#endif +# include +# endif -#if @HAVE_SYS_BITYPES_H@ && ! defined __BIT_TYPES_DEFINED__ +# if @HAVE_SYS_BITYPES_H@ && ! defined __BIT_TYPES_DEFINED__ /* Linux libc4 >= 4.6.7 and libc5 have a that defines int{8,16,32,64}_t and __BIT_TYPES_DEFINED__. In libc5 >= 5.2.2 it is included by . */ -# include -#endif +# include +# endif -#undef _GL_JUST_INCLUDE_SYSTEM_INTTYPES_H +# undef _GL_JUST_INCLUDE_SYSTEM_INTTYPES_H /* Minimum and maximum values for an integer type under the usual assumption. Return an unspecified value if BITS == 0, adding a check to pacify picky compilers. */ -#define _STDINT_MIN(signed, bits, zero) \ - ((signed) ? ~ _STDINT_MAX (signed, bits, zero) : (zero)) +# define _STDINT_MIN(signed, bits, zero) \ + ((signed) ? ~ _STDINT_MAX (signed, bits, zero) : (zero)) -#define _STDINT_MAX(signed, bits, zero) \ - (((((zero) + 1) << ((bits) ? (bits) - 1 - (signed) : 0)) - 1) * 2 + 1) +# define _STDINT_MAX(signed, bits, zero) \ + (((((zero) + 1) << ((bits) ? (bits) - 1 - (signed) : 0)) - 1) * 2 + 1) #if !GNULIB_defined_stdint_types @@ -130,26 +141,26 @@ /* Here we assume a standard architecture where the hardware integer types have 8, 16, 32, optionally 64 bits. */ -#undef int8_t -#undef uint8_t +# undef int8_t +# undef uint8_t typedef signed char gl_int8_t; typedef unsigned char gl_uint8_t; -#define int8_t gl_int8_t -#define uint8_t gl_uint8_t +# define int8_t gl_int8_t +# define uint8_t gl_uint8_t -#undef int16_t -#undef uint16_t +# undef int16_t +# undef uint16_t typedef short int gl_int16_t; typedef unsigned short int gl_uint16_t; -#define int16_t gl_int16_t -#define uint16_t gl_uint16_t +# define int16_t gl_int16_t +# define uint16_t gl_uint16_t -#undef int32_t -#undef uint32_t +# undef int32_t +# undef uint32_t typedef int gl_int32_t; typedef unsigned int gl_uint32_t; -#define int32_t gl_int32_t -#define uint32_t gl_uint32_t +# define int32_t gl_int32_t +# define uint32_t gl_uint32_t /* If the system defines INT64_MAX, assume int64_t works. That way, if the underlying platform defines int64_t to be a 64-bit long long @@ -157,54 +168,54 @@ typedef unsigned int gl_uint32_t; int, which would mess up C++ name mangling. We must use #ifdef rather than #if, to avoid an error with HP-UX 10.20 cc. */ -#ifdef INT64_MAX -# define GL_INT64_T -#else +# ifdef INT64_MAX +# define GL_INT64_T +# else /* Do not undefine int64_t if gnulib is not being used with 64-bit types, since otherwise it breaks platforms like Tandem/NSK. */ -# if LONG_MAX >> 31 >> 31 == 1 -# undef int64_t +# if LONG_MAX >> 31 >> 31 == 1 +# undef int64_t typedef long int gl_int64_t; -# define int64_t gl_int64_t -# define GL_INT64_T -# elif defined _MSC_VER -# undef int64_t +# define int64_t gl_int64_t +# define GL_INT64_T +# elif defined _MSC_VER +# undef int64_t typedef __int64 gl_int64_t; -# define int64_t gl_int64_t -# define GL_INT64_T -# elif @HAVE_LONG_LONG_INT@ -# undef int64_t +# define int64_t gl_int64_t +# define GL_INT64_T +# elif @HAVE_LONG_LONG_INT@ +# undef int64_t typedef long long int gl_int64_t; -# define int64_t gl_int64_t -# define GL_INT64_T +# define int64_t gl_int64_t +# define GL_INT64_T +# endif # endif -#endif -#ifdef UINT64_MAX -# define GL_UINT64_T -#else -# if ULONG_MAX >> 31 >> 31 >> 1 == 1 -# undef uint64_t +# ifdef UINT64_MAX +# define GL_UINT64_T +# else +# if ULONG_MAX >> 31 >> 31 >> 1 == 1 +# undef uint64_t typedef unsigned long int gl_uint64_t; -# define uint64_t gl_uint64_t -# define GL_UINT64_T -# elif defined _MSC_VER -# undef uint64_t +# define uint64_t gl_uint64_t +# define GL_UINT64_T +# elif defined _MSC_VER +# undef uint64_t typedef unsigned __int64 gl_uint64_t; -# define uint64_t gl_uint64_t -# define GL_UINT64_T -# elif @HAVE_UNSIGNED_LONG_LONG_INT@ -# undef uint64_t +# define uint64_t gl_uint64_t +# define GL_UINT64_T +# elif @HAVE_UNSIGNED_LONG_LONG_INT@ +# undef uint64_t typedef unsigned long long int gl_uint64_t; -# define uint64_t gl_uint64_t -# define GL_UINT64_T +# define uint64_t gl_uint64_t +# define GL_UINT64_T +# endif # endif -#endif /* Avoid collision with Solaris 2.5.1 etc. */ -#define _UINT8_T -#define _UINT32_T -#define _UINT64_T +# define _UINT8_T +# define _UINT32_T +# define _UINT64_T /* 7.18.1.2. Minimum-width integer types */ @@ -213,26 +224,26 @@ typedef unsigned long long int gl_uint64_t; types have 8, 16, 32, optionally 64 bits. Therefore the leastN_t types are the same as the corresponding N_t types. */ -#undef int_least8_t -#undef uint_least8_t -#undef int_least16_t -#undef uint_least16_t -#undef int_least32_t -#undef uint_least32_t -#undef int_least64_t -#undef uint_least64_t -#define int_least8_t int8_t -#define uint_least8_t uint8_t -#define int_least16_t int16_t -#define uint_least16_t uint16_t -#define int_least32_t int32_t -#define uint_least32_t uint32_t -#ifdef GL_INT64_T -# define int_least64_t int64_t -#endif -#ifdef GL_UINT64_T -# define uint_least64_t uint64_t -#endif +# undef int_least8_t +# undef uint_least8_t +# undef int_least16_t +# undef uint_least16_t +# undef int_least32_t +# undef uint_least32_t +# undef int_least64_t +# undef uint_least64_t +# define int_least8_t int8_t +# define uint_least8_t uint8_t +# define int_least16_t int16_t +# define uint_least16_t uint16_t +# define int_least32_t int32_t +# define uint_least32_t uint32_t +# ifdef GL_INT64_T +# define int_least64_t int64_t +# endif +# ifdef GL_UINT64_T +# define uint_least64_t uint64_t +# endif /* 7.18.1.3. Fastest minimum-width integer types */ @@ -245,55 +256,55 @@ typedef unsigned long long int gl_uint64_t; uses types consistent with glibc, as that lessens the chance of incompatibility with older GNU hosts. */ -#undef int_fast8_t -#undef uint_fast8_t -#undef int_fast16_t -#undef uint_fast16_t -#undef int_fast32_t -#undef uint_fast32_t -#undef int_fast64_t -#undef uint_fast64_t +# undef int_fast8_t +# undef uint_fast8_t +# undef int_fast16_t +# undef uint_fast16_t +# undef int_fast32_t +# undef uint_fast32_t +# undef int_fast64_t +# undef uint_fast64_t typedef signed char gl_int_fast8_t; typedef unsigned char gl_uint_fast8_t; -#ifdef __sun +# ifdef __sun /* Define types compatible with SunOS 5.10, so that code compiled under earlier SunOS versions works with code compiled under SunOS 5.10. */ typedef int gl_int_fast32_t; typedef unsigned int gl_uint_fast32_t; -#else +# else typedef long int gl_int_fast32_t; typedef unsigned long int gl_uint_fast32_t; -#endif +# endif typedef gl_int_fast32_t gl_int_fast16_t; typedef gl_uint_fast32_t gl_uint_fast16_t; -#define int_fast8_t gl_int_fast8_t -#define uint_fast8_t gl_uint_fast8_t -#define int_fast16_t gl_int_fast16_t -#define uint_fast16_t gl_uint_fast16_t -#define int_fast32_t gl_int_fast32_t -#define uint_fast32_t gl_uint_fast32_t -#ifdef GL_INT64_T -# define int_fast64_t int64_t -#endif -#ifdef GL_UINT64_T -# define uint_fast64_t uint64_t -#endif +# define int_fast8_t gl_int_fast8_t +# define uint_fast8_t gl_uint_fast8_t +# define int_fast16_t gl_int_fast16_t +# define uint_fast16_t gl_uint_fast16_t +# define int_fast32_t gl_int_fast32_t +# define uint_fast32_t gl_uint_fast32_t +# ifdef GL_INT64_T +# define int_fast64_t int64_t +# endif +# ifdef GL_UINT64_T +# define uint_fast64_t uint64_t +# endif /* 7.18.1.4. Integer types capable of holding object pointers */ /* kLIBC's stdint.h defines _INTPTR_T_DECLARED and needs its own definitions of intptr_t and uintptr_t (which use int and unsigned) to avoid clashes with declarations of system functions like sbrk. */ -#ifndef _INTPTR_T_DECLARED -#undef intptr_t -#undef uintptr_t +# ifndef _INTPTR_T_DECLARED +# undef intptr_t +# undef uintptr_t typedef long int gl_intptr_t; typedef unsigned long int gl_uintptr_t; -#define intptr_t gl_intptr_t -#define uintptr_t gl_uintptr_t -#endif +# define intptr_t gl_intptr_t +# define uintptr_t gl_uintptr_t +# endif /* 7.18.1.5. Greatest-width integer types */ @@ -304,33 +315,33 @@ typedef unsigned long int gl_uintptr_t; similarly for UINTMAX_MAX and uintmax_t. This avoids problems with assuming one type where another is used by the system. */ -#ifndef INTMAX_MAX -# undef INTMAX_C -# undef intmax_t -# if @HAVE_LONG_LONG_INT@ && LONG_MAX >> 30 == 1 +# ifndef INTMAX_MAX +# undef INTMAX_C +# undef intmax_t +# if @HAVE_LONG_LONG_INT@ && LONG_MAX >> 30 == 1 typedef long long int gl_intmax_t; -# define intmax_t gl_intmax_t -# elif defined GL_INT64_T -# define intmax_t int64_t -# else +# define intmax_t gl_intmax_t +# elif defined GL_INT64_T +# define intmax_t int64_t +# else typedef long int gl_intmax_t; -# define intmax_t gl_intmax_t +# define intmax_t gl_intmax_t +# endif # endif -#endif -#ifndef UINTMAX_MAX -# undef UINTMAX_C -# undef uintmax_t -# if @HAVE_UNSIGNED_LONG_LONG_INT@ && ULONG_MAX >> 31 == 1 +# ifndef UINTMAX_MAX +# undef UINTMAX_C +# undef uintmax_t +# if @HAVE_UNSIGNED_LONG_LONG_INT@ && ULONG_MAX >> 31 == 1 typedef unsigned long long int gl_uintmax_t; -# define uintmax_t gl_uintmax_t -# elif defined GL_UINT64_T -# define uintmax_t uint64_t -# else +# define uintmax_t gl_uintmax_t +# elif defined GL_UINT64_T +# define uintmax_t uint64_t +# else typedef unsigned long int gl_uintmax_t; -# define uintmax_t gl_uintmax_t +# define uintmax_t gl_uintmax_t +# endif # endif -#endif /* Verify that intmax_t and uintmax_t have the same size. Too much code breaks if this is not the case. If this check fails, the reason is likely @@ -338,8 +349,8 @@ typedef unsigned long int gl_uintmax_t; typedef int _verify_intmax_size[sizeof (intmax_t) == sizeof (uintmax_t) ? 1 : -1]; -#define GNULIB_defined_stdint_types 1 -#endif /* !GNULIB_defined_stdint_types */ +# define GNULIB_defined_stdint_types 1 +# endif /* !GNULIB_defined_stdint_types */ /* 7.18.2. Limits of specified-width integer types */ @@ -348,37 +359,37 @@ typedef int _verify_intmax_size[sizeof (intmax_t) == sizeof (uintmax_t) /* Here we assume a standard architecture where the hardware integer types have 8, 16, 32, optionally 64 bits. */ -#undef INT8_MIN -#undef INT8_MAX -#undef UINT8_MAX -#define INT8_MIN (~ INT8_MAX) -#define INT8_MAX 127 -#define UINT8_MAX 255 +# undef INT8_MIN +# undef INT8_MAX +# undef UINT8_MAX +# define INT8_MIN (~ INT8_MAX) +# define INT8_MAX 127 +# define UINT8_MAX 255 -#undef INT16_MIN -#undef INT16_MAX -#undef UINT16_MAX -#define INT16_MIN (~ INT16_MAX) -#define INT16_MAX 32767 -#define UINT16_MAX 65535 +# undef INT16_MIN +# undef INT16_MAX +# undef UINT16_MAX +# define INT16_MIN (~ INT16_MAX) +# define INT16_MAX 32767 +# define UINT16_MAX 65535 -#undef INT32_MIN -#undef INT32_MAX -#undef UINT32_MAX -#define INT32_MIN (~ INT32_MAX) -#define INT32_MAX 2147483647 -#define UINT32_MAX 4294967295U +# undef INT32_MIN +# undef INT32_MAX +# undef UINT32_MAX +# define INT32_MIN (~ INT32_MAX) +# define INT32_MAX 2147483647 +# define UINT32_MAX 4294967295U -#if defined GL_INT64_T && ! defined INT64_MAX +# if defined GL_INT64_T && ! defined INT64_MAX /* Prefer (- INTMAX_C (1) << 63) over (~ INT64_MAX) because SunPRO C 5.0 evaluates the latter incorrectly in preprocessor expressions. */ -# define INT64_MIN (- INTMAX_C (1) << 63) -# define INT64_MAX INTMAX_C (9223372036854775807) -#endif +# define INT64_MIN (- INTMAX_C (1) << 63) +# define INT64_MAX INTMAX_C (9223372036854775807) +# endif -#if defined GL_UINT64_T && ! defined UINT64_MAX -# define UINT64_MAX UINTMAX_C (18446744073709551615) -#endif +# if defined GL_UINT64_T && ! defined UINT64_MAX +# define UINT64_MAX UINTMAX_C (18446744073709551615) +# endif /* 7.18.2.2. Limits of minimum-width integer types */ @@ -386,38 +397,38 @@ typedef int _verify_intmax_size[sizeof (intmax_t) == sizeof (uintmax_t) types have 8, 16, 32, optionally 64 bits. Therefore the leastN_t types are the same as the corresponding N_t types. */ -#undef INT_LEAST8_MIN -#undef INT_LEAST8_MAX -#undef UINT_LEAST8_MAX -#define INT_LEAST8_MIN INT8_MIN -#define INT_LEAST8_MAX INT8_MAX -#define UINT_LEAST8_MAX UINT8_MAX +# undef INT_LEAST8_MIN +# undef INT_LEAST8_MAX +# undef UINT_LEAST8_MAX +# define INT_LEAST8_MIN INT8_MIN +# define INT_LEAST8_MAX INT8_MAX +# define UINT_LEAST8_MAX UINT8_MAX -#undef INT_LEAST16_MIN -#undef INT_LEAST16_MAX -#undef UINT_LEAST16_MAX -#define INT_LEAST16_MIN INT16_MIN -#define INT_LEAST16_MAX INT16_MAX -#define UINT_LEAST16_MAX UINT16_MAX +# undef INT_LEAST16_MIN +# undef INT_LEAST16_MAX +# undef UINT_LEAST16_MAX +# define INT_LEAST16_MIN INT16_MIN +# define INT_LEAST16_MAX INT16_MAX +# define UINT_LEAST16_MAX UINT16_MAX -#undef INT_LEAST32_MIN -#undef INT_LEAST32_MAX -#undef UINT_LEAST32_MAX -#define INT_LEAST32_MIN INT32_MIN -#define INT_LEAST32_MAX INT32_MAX -#define UINT_LEAST32_MAX UINT32_MAX +# undef INT_LEAST32_MIN +# undef INT_LEAST32_MAX +# undef UINT_LEAST32_MAX +# define INT_LEAST32_MIN INT32_MIN +# define INT_LEAST32_MAX INT32_MAX +# define UINT_LEAST32_MAX UINT32_MAX -#undef INT_LEAST64_MIN -#undef INT_LEAST64_MAX -#ifdef GL_INT64_T -# define INT_LEAST64_MIN INT64_MIN -# define INT_LEAST64_MAX INT64_MAX -#endif +# undef INT_LEAST64_MIN +# undef INT_LEAST64_MAX +# ifdef GL_INT64_T +# define INT_LEAST64_MIN INT64_MIN +# define INT_LEAST64_MAX INT64_MAX +# endif -#undef UINT_LEAST64_MAX -#ifdef GL_UINT64_T -# define UINT_LEAST64_MAX UINT64_MAX -#endif +# undef UINT_LEAST64_MAX +# ifdef GL_UINT64_T +# define UINT_LEAST64_MAX UINT64_MAX +# endif /* 7.18.2.3. Limits of fastest minimum-width integer types */ @@ -425,117 +436,117 @@ typedef int _verify_intmax_size[sizeof (intmax_t) == sizeof (uintmax_t) types have 8, 16, 32, optionally 64 bits. Therefore the fastN_t types are taken from the same list of types. */ -#undef INT_FAST8_MIN -#undef INT_FAST8_MAX -#undef UINT_FAST8_MAX -#define INT_FAST8_MIN SCHAR_MIN -#define INT_FAST8_MAX SCHAR_MAX -#define UINT_FAST8_MAX UCHAR_MAX +# undef INT_FAST8_MIN +# undef INT_FAST8_MAX +# undef UINT_FAST8_MAX +# define INT_FAST8_MIN SCHAR_MIN +# define INT_FAST8_MAX SCHAR_MAX +# define UINT_FAST8_MAX UCHAR_MAX -#undef INT_FAST16_MIN -#undef INT_FAST16_MAX -#undef UINT_FAST16_MAX -#define INT_FAST16_MIN INT_FAST32_MIN -#define INT_FAST16_MAX INT_FAST32_MAX -#define UINT_FAST16_MAX UINT_FAST32_MAX +# undef INT_FAST16_MIN +# undef INT_FAST16_MAX +# undef UINT_FAST16_MAX +# define INT_FAST16_MIN INT_FAST32_MIN +# define INT_FAST16_MAX INT_FAST32_MAX +# define UINT_FAST16_MAX UINT_FAST32_MAX -#undef INT_FAST32_MIN -#undef INT_FAST32_MAX -#undef UINT_FAST32_MAX -#ifdef __sun -# define INT_FAST32_MIN INT_MIN -# define INT_FAST32_MAX INT_MAX -# define UINT_FAST32_MAX UINT_MAX -#else -# define INT_FAST32_MIN LONG_MIN -# define INT_FAST32_MAX LONG_MAX -# define UINT_FAST32_MAX ULONG_MAX -#endif +# undef INT_FAST32_MIN +# undef INT_FAST32_MAX +# undef UINT_FAST32_MAX +# ifdef __sun +# define INT_FAST32_MIN INT_MIN +# define INT_FAST32_MAX INT_MAX +# define UINT_FAST32_MAX UINT_MAX +# else +# define INT_FAST32_MIN LONG_MIN +# define INT_FAST32_MAX LONG_MAX +# define UINT_FAST32_MAX ULONG_MAX +# endif -#undef INT_FAST64_MIN -#undef INT_FAST64_MAX -#ifdef GL_INT64_T -# define INT_FAST64_MIN INT64_MIN -# define INT_FAST64_MAX INT64_MAX -#endif +# undef INT_FAST64_MIN +# undef INT_FAST64_MAX +# ifdef GL_INT64_T +# define INT_FAST64_MIN INT64_MIN +# define INT_FAST64_MAX INT64_MAX +# endif -#undef UINT_FAST64_MAX -#ifdef GL_UINT64_T -# define UINT_FAST64_MAX UINT64_MAX -#endif +# undef UINT_FAST64_MAX +# ifdef GL_UINT64_T +# define UINT_FAST64_MAX UINT64_MAX +# endif /* 7.18.2.4. Limits of integer types capable of holding object pointers */ -#undef INTPTR_MIN -#undef INTPTR_MAX -#undef UINTPTR_MAX -#define INTPTR_MIN LONG_MIN -#define INTPTR_MAX LONG_MAX -#define UINTPTR_MAX ULONG_MAX +# undef INTPTR_MIN +# undef INTPTR_MAX +# undef UINTPTR_MAX +# define INTPTR_MIN LONG_MIN +# define INTPTR_MAX LONG_MAX +# define UINTPTR_MAX ULONG_MAX /* 7.18.2.5. Limits of greatest-width integer types */ -#ifndef INTMAX_MAX -# undef INTMAX_MIN -# ifdef INT64_MAX -# define INTMAX_MIN INT64_MIN -# define INTMAX_MAX INT64_MAX -# else -# define INTMAX_MIN INT32_MIN -# define INTMAX_MAX INT32_MAX +# ifndef INTMAX_MAX +# undef INTMAX_MIN +# ifdef INT64_MAX +# define INTMAX_MIN INT64_MIN +# define INTMAX_MAX INT64_MAX +# else +# define INTMAX_MIN INT32_MIN +# define INTMAX_MAX INT32_MAX +# endif # endif -#endif -#ifndef UINTMAX_MAX -# ifdef UINT64_MAX -# define UINTMAX_MAX UINT64_MAX -# else -# define UINTMAX_MAX UINT32_MAX +# ifndef UINTMAX_MAX +# ifdef UINT64_MAX +# define UINTMAX_MAX UINT64_MAX +# else +# define UINTMAX_MAX UINT32_MAX +# endif # endif -#endif /* 7.18.3. Limits of other integer types */ /* ptrdiff_t limits */ -#undef PTRDIFF_MIN -#undef PTRDIFF_MAX -#if @APPLE_UNIVERSAL_BUILD@ -# ifdef _LP64 -# define PTRDIFF_MIN _STDINT_MIN (1, 64, 0l) -# define PTRDIFF_MAX _STDINT_MAX (1, 64, 0l) +# undef PTRDIFF_MIN +# undef PTRDIFF_MAX +# if @APPLE_UNIVERSAL_BUILD@ +# ifdef _LP64 +# define PTRDIFF_MIN _STDINT_MIN (1, 64, 0l) +# define PTRDIFF_MAX _STDINT_MAX (1, 64, 0l) +# else +# define PTRDIFF_MIN _STDINT_MIN (1, 32, 0) +# define PTRDIFF_MAX _STDINT_MAX (1, 32, 0) +# endif # else -# define PTRDIFF_MIN _STDINT_MIN (1, 32, 0) -# define PTRDIFF_MAX _STDINT_MAX (1, 32, 0) -# endif -#else -# define PTRDIFF_MIN \ +# define PTRDIFF_MIN \ _STDINT_MIN (1, @BITSIZEOF_PTRDIFF_T@, 0@PTRDIFF_T_SUFFIX@) -# define PTRDIFF_MAX \ +# define PTRDIFF_MAX \ _STDINT_MAX (1, @BITSIZEOF_PTRDIFF_T@, 0@PTRDIFF_T_SUFFIX@) -#endif +# endif /* sig_atomic_t limits */ -#undef SIG_ATOMIC_MIN -#undef SIG_ATOMIC_MAX -#define SIG_ATOMIC_MIN \ +# undef SIG_ATOMIC_MIN +# undef SIG_ATOMIC_MAX +# define SIG_ATOMIC_MIN \ _STDINT_MIN (@HAVE_SIGNED_SIG_ATOMIC_T@, @BITSIZEOF_SIG_ATOMIC_T@, \ 0@SIG_ATOMIC_T_SUFFIX@) -#define SIG_ATOMIC_MAX \ +# define SIG_ATOMIC_MAX \ _STDINT_MAX (@HAVE_SIGNED_SIG_ATOMIC_T@, @BITSIZEOF_SIG_ATOMIC_T@, \ 0@SIG_ATOMIC_T_SUFFIX@) /* size_t limit */ -#undef SIZE_MAX -#if @APPLE_UNIVERSAL_BUILD@ -# ifdef _LP64 -# define SIZE_MAX _STDINT_MAX (0, 64, 0ul) +# undef SIZE_MAX +# if @APPLE_UNIVERSAL_BUILD@ +# ifdef _LP64 +# define SIZE_MAX _STDINT_MAX (0, 64, 0ul) +# else +# define SIZE_MAX _STDINT_MAX (0, 32, 0ul) +# endif # else -# define SIZE_MAX _STDINT_MAX (0, 32, 0ul) +# define SIZE_MAX _STDINT_MAX (0, @BITSIZEOF_SIZE_T@, 0@SIZE_T_SUFFIX@) # endif -#else -# define SIZE_MAX _STDINT_MAX (0, @BITSIZEOF_SIZE_T@, 0@SIZE_T_SUFFIX@) -#endif /* wchar_t limits */ /* Get WCHAR_MIN, WCHAR_MAX. @@ -543,29 +554,29 @@ typedef int _verify_intmax_size[sizeof (intmax_t) == sizeof (uintmax_t) sequence of nested includes -> -> -> , and the latter includes and assumes its types are already defined. */ -#if @HAVE_WCHAR_H@ && ! (defined WCHAR_MIN && defined WCHAR_MAX) +# if @HAVE_WCHAR_H@ && ! (defined WCHAR_MIN && defined WCHAR_MAX) /* BSD/OS 4.0.1 has a bug: , and must be included before . */ -# include -# include -# include -# define _GL_JUST_INCLUDE_SYSTEM_WCHAR_H -# include -# undef _GL_JUST_INCLUDE_SYSTEM_WCHAR_H -#endif -#undef WCHAR_MIN -#undef WCHAR_MAX -#define WCHAR_MIN \ +# include +# include +# include +# define _GL_JUST_INCLUDE_SYSTEM_WCHAR_H +# include +# undef _GL_JUST_INCLUDE_SYSTEM_WCHAR_H +# endif +# undef WCHAR_MIN +# undef WCHAR_MAX +# define WCHAR_MIN \ _STDINT_MIN (@HAVE_SIGNED_WCHAR_T@, @BITSIZEOF_WCHAR_T@, 0@WCHAR_T_SUFFIX@) -#define WCHAR_MAX \ +# define WCHAR_MAX \ _STDINT_MAX (@HAVE_SIGNED_WCHAR_T@, @BITSIZEOF_WCHAR_T@, 0@WCHAR_T_SUFFIX@) /* wint_t limits */ -#undef WINT_MIN -#undef WINT_MAX -#define WINT_MIN \ +# undef WINT_MIN +# undef WINT_MAX +# define WINT_MIN \ _STDINT_MIN (@HAVE_SIGNED_WINT_T@, @BITSIZEOF_WINT_T@, 0@WINT_T_SUFFIX@) -#define WINT_MAX \ +# define WINT_MAX \ _STDINT_MAX (@HAVE_SIGNED_WINT_T@, @BITSIZEOF_WINT_T@, 0@WINT_T_SUFFIX@) /* 7.18.4. Macros for integer constants */ @@ -576,59 +587,120 @@ typedef int _verify_intmax_size[sizeof (intmax_t) == sizeof (uintmax_t) /* Here we assume a standard architecture where the hardware integer types have 8, 16, 32, optionally 64 bits, and int is 32 bits. */ -#undef INT8_C -#undef UINT8_C -#define INT8_C(x) x -#define UINT8_C(x) x +# undef INT8_C +# undef UINT8_C +# define INT8_C(x) x +# define UINT8_C(x) x -#undef INT16_C -#undef UINT16_C -#define INT16_C(x) x -#define UINT16_C(x) x +# undef INT16_C +# undef UINT16_C +# define INT16_C(x) x +# define UINT16_C(x) x -#undef INT32_C -#undef UINT32_C -#define INT32_C(x) x -#define UINT32_C(x) x ## U +# undef INT32_C +# undef UINT32_C +# define INT32_C(x) x +# define UINT32_C(x) x ## U -#undef INT64_C -#undef UINT64_C -#if LONG_MAX >> 31 >> 31 == 1 -# define INT64_C(x) x##L -#elif defined _MSC_VER -# define INT64_C(x) x##i64 -#elif @HAVE_LONG_LONG_INT@ -# define INT64_C(x) x##LL -#endif -#if ULONG_MAX >> 31 >> 31 >> 1 == 1 -# define UINT64_C(x) x##UL -#elif defined _MSC_VER -# define UINT64_C(x) x##ui64 -#elif @HAVE_UNSIGNED_LONG_LONG_INT@ -# define UINT64_C(x) x##ULL -#endif +# undef INT64_C +# undef UINT64_C +# if LONG_MAX >> 31 >> 31 == 1 +# define INT64_C(x) x##L +# elif defined _MSC_VER +# define INT64_C(x) x##i64 +# elif @HAVE_LONG_LONG_INT@ +# define INT64_C(x) x##LL +# endif +# if ULONG_MAX >> 31 >> 31 >> 1 == 1 +# define UINT64_C(x) x##UL +# elif defined _MSC_VER +# define UINT64_C(x) x##ui64 +# elif @HAVE_UNSIGNED_LONG_LONG_INT@ +# define UINT64_C(x) x##ULL +# endif /* 7.18.4.2. Macros for greatest-width integer constants */ -#ifndef INTMAX_C -# if @HAVE_LONG_LONG_INT@ && LONG_MAX >> 30 == 1 -# define INTMAX_C(x) x##LL -# elif defined GL_INT64_T -# define INTMAX_C(x) INT64_C(x) -# else -# define INTMAX_C(x) x##L +# ifndef INTMAX_C +# if @HAVE_LONG_LONG_INT@ && LONG_MAX >> 30 == 1 +# define INTMAX_C(x) x##LL +# elif defined GL_INT64_T +# define INTMAX_C(x) INT64_C(x) +# else +# define INTMAX_C(x) x##L +# endif # endif -#endif -#ifndef UINTMAX_C -# if @HAVE_UNSIGNED_LONG_LONG_INT@ && ULONG_MAX >> 31 == 1 -# define UINTMAX_C(x) x##ULL -# elif defined GL_UINT64_T -# define UINTMAX_C(x) UINT64_C(x) -# else -# define UINTMAX_C(x) x##UL +# ifndef UINTMAX_C +# if @HAVE_UNSIGNED_LONG_LONG_INT@ && ULONG_MAX >> 31 == 1 +# define UINTMAX_C(x) x##ULL +# elif defined GL_UINT64_T +# define UINTMAX_C(x) UINT64_C(x) +# else +# define UINTMAX_C(x) x##UL +# endif # endif -#endif + +#endif /* !@HAVE_C99_STDINT_H@ */ + +/* Macros specified by ISO/IEC TS 18661-1:2014. */ + +#if (!defined UINTMAX_WIDTH \ + && (defined _GNU_SOURCE || defined __STDC_WANT_IEC_60559_BFP_EXT__)) +# ifdef INT8_MAX +# define INT8_WIDTH _GL_INTEGER_WIDTH (INT8_MIN, INT8_MAX) +# endif +# ifdef UINT8_MAX +# define UINT8_WIDTH _GL_INTEGER_WIDTH (0, UINT8_MAX) +# endif +# ifdef INT16_MAX +# define INT16_WIDTH _GL_INTEGER_WIDTH (INT16_MIN, INT16_MAX) +# endif +# ifdef UINT16_MAX +# define UINT16_WIDTH _GL_INTEGER_WIDTH (0, UINT16_MAX) +# endif +# ifdef INT32_MAX +# define INT32_WIDTH _GL_INTEGER_WIDTH (INT32_MIN, INT32_MAX) +# endif +# ifdef UINT32_MAX +# define UINT32_WIDTH _GL_INTEGER_WIDTH (0, UINT32_MAX) +# endif +# ifdef INT64_MAX +# define INT64_WIDTH _GL_INTEGER_WIDTH (INT64_MIN, INT64_MAX) +# endif +# ifdef UINT64_MAX +# define UINT64_WIDTH _GL_INTEGER_WIDTH (0, UINT64_MAX) +# endif +# define INT_LEAST8_WIDTH _GL_INTEGER_WIDTH (INT_LEAST8_MIN, INT_LEAST8_MAX) +# define UINT_LEAST8_WIDTH _GL_INTEGER_WIDTH (0, UINT_LEAST8_MAX) +# define INT_LEAST16_WIDTH _GL_INTEGER_WIDTH (INT_LEAST16_MIN, INT_LEAST16_MAX) +# define UINT_LEAST16_WIDTH _GL_INTEGER_WIDTH (0, UINT_LEAST16_MAX) +# define INT_LEAST32_WIDTH _GL_INTEGER_WIDTH (INT_LEAST32_MIN, INT_LEAST32_MAX) +# define UINT_LEAST32_WIDTH _GL_INTEGER_WIDTH (0, UINT_LEAST32_MAX) +# define INT_LEAST64_WIDTH _GL_INTEGER_WIDTH (INT_LEAST64_MIN, INT_LEAST64_MAX) +# define UINT_LEAST64_WIDTH _GL_INTEGER_WIDTH (0, UINT_LEAST64_MAX) +# define INT_FAST8_WIDTH _GL_INTEGER_WIDTH (INT_FAST8_MIN, INT_FAST8_MAX) +# define UINT_FAST8_WIDTH _GL_INTEGER_WIDTH (0, UINT_FAST8_MAX) +# define INT_FAST16_WIDTH _GL_INTEGER_WIDTH (INT_FAST16_MIN, INT_FAST16_MAX) +# define UINT_FAST16_WIDTH _GL_INTEGER_WIDTH (0, UINT_FAST16_MAX) +# define INT_FAST32_WIDTH _GL_INTEGER_WIDTH (INT_FAST32_MIN, INT_FAST32_MAX) +# define UINT_FAST32_WIDTH _GL_INTEGER_WIDTH (0, UINT_FAST32_MAX) +# define INT_FAST64_WIDTH _GL_INTEGER_WIDTH (INT_FAST64_MIN, INT_FAST64_MAX) +# define UINT_FAST64_WIDTH _GL_INTEGER_WIDTH (0, UINT_FAST64_MAX) +# define INTPTR_WIDTH _GL_INTEGER_WIDTH (INTPTR_MIN, INTPTR_MAX) +# define UINTPTR_WIDTH _GL_INTEGER_WIDTH (0, UINTPTR_MAX) +# define INTMAX_WIDTH _GL_INTEGER_WIDTH (INTMAX_MIN, INTMAX_MAX) +# define UINTMAX_WIDTH _GL_INTEGER_WIDTH (0, UINTMAX_MAX) +# define PTRDIFF_WIDTH _GL_INTEGER_WIDTH (PTRDIFF_MIN, PTRDIFF_MAX) +# define SIZE_WIDTH _GL_INTEGER_WIDTH (0, SIZE_MAX) +# define WCHAR_WIDTH _GL_INTEGER_WIDTH (WCHAR_MIN, WCHAR_MAX) +# ifdef WINT_MAX +# define WINT_WIDTH _GL_INTEGER_WIDTH (WINT_MIN, WINT_MAX) +# endif +# ifdef SIG_ATOMIC_MAX +# define SIG_ATOMIC_WIDTH _GL_INTEGER_WIDTH (SIG_ATOMIC_MIN, SIG_ATOMIC_MAX) +# endif +#endif /* !WINT_WIDTH && (_GNU_SOURCE || __STDC_WANT_IEC_60559_BFP_EXT__) */ #endif /* _@GUARD_PREFIX@_STDINT_H */ #endif /* !(defined __ANDROID__ && ...) */ diff --git a/lib/stdio.in.h b/lib/stdio.in.h index ce100aa8e..3306464b9 100644 --- a/lib/stdio.in.h +++ b/lib/stdio.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 2004, 2007-2016 Free Software Foundation, Inc. + Copyright (C) 2004, 2007-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -118,6 +118,26 @@ # include #endif +/* MSVC declares 'perror' in , not in . We must include + it before we #define perror rpl_perror. */ +/* But in any case avoid namespace pollution on glibc systems. */ +#if (@GNULIB_PERROR@ || defined GNULIB_POSIXCHECK) \ + && ((defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__) \ + && ! defined __GLIBC__ +# include +#endif + +/* MSVC declares 'remove' in , not in . We must include + it before we #define remove rpl_remove. */ +/* MSVC declares 'rename' in , not in . We must include + it before we #define rename rpl_rename. */ +/* But in any case avoid namespace pollution on glibc systems. */ +#if (@GNULIB_REMOVE@ || @GNULIB_RENAME@ || defined GNULIB_POSIXCHECK) \ + && ((defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__) \ + && ! defined __GLIBC__ +# include +#endif + /* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */ diff --git a/lib/stdlib.in.h b/lib/stdlib.in.h index ec7a2efbe..987167d79 100644 --- a/lib/stdlib.in.h +++ b/lib/stdlib.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 1995, 2001-2004, 2006-2016 Free Software Foundation, Inc. + Copyright (C) 1995, 2001-2004, 2006-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -521,6 +521,9 @@ _GL_CXXALIASWARN (putenv); #endif #if @GNULIB_QSORT_R@ +/* Sort an array of NMEMB elements, starting at address BASE, each element + occupying SIZE bytes, in ascending order according to the comparison + function COMPARE. */ # if @REPLACE_QSORT_R@ # if !(defined __cplusplus && defined GNULIB_NAMESPACE) # undef qsort_r @@ -535,12 +538,24 @@ _GL_CXXALIAS_RPL (qsort_r, void, (void *base, size_t nmemb, size_t size, void *), void *arg)); # else +# if !@HAVE_QSORT_R@ +_GL_FUNCDECL_SYS (qsort_r, void, (void *base, size_t nmemb, size_t size, + int (*compare) (void const *, void const *, + void *), + void *arg) _GL_ARG_NONNULL ((1, 4))); +# endif _GL_CXXALIAS_SYS (qsort_r, void, (void *base, size_t nmemb, size_t size, int (*compare) (void const *, void const *, void *), void *arg)); # endif _GL_CXXALIASWARN (qsort_r); +#elif defined GNULIB_POSIXCHECK +# undef qsort_r +# if HAVE_RAW_DECL_QSORT_R +_GL_WARN_ON_USE (qsort_r, "qsort_r is not portable - " + "use gnulib module qsort_r for portability"); +# endif #endif diff --git a/lib/strdup.c b/lib/strdup.c index b44862daf..ece20c5bf 100644 --- a/lib/strdup.c +++ b/lib/strdup.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1991, 1996-1998, 2002-2004, 2006-2007, 2009-2016 Free Software +/* Copyright (C) 1991, 1996-1998, 2002-2004, 2006-2007, 2009-2017 Free Software Foundation, Inc. This file is part of the GNU C Library. diff --git a/lib/streq.h b/lib/streq.h index 9be29390c..831ded2e2 100644 --- a/lib/streq.h +++ b/lib/streq.h @@ -1,5 +1,5 @@ /* Optimized string comparison. - Copyright (C) 2001-2002, 2007, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2001-2002, 2007, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published diff --git a/lib/strftime.c b/lib/strftime.c index b10f82f0e..8091f3d08 100644 --- a/lib/strftime.c +++ b/lib/strftime.c @@ -1,22 +1,22 @@ -/* Copyright (C) 1991-2001, 2003-2007, 2009-2016 Free Software Foundation, Inc. +/* Copyright (C) 1991-2017 Free Software Foundation, Inc. + This file is part of the GNU C Library. - NOTE: The canonical source of this file is maintained with the GNU C Library. - Bugs can be reported to bug-glibc@prep.ai.mit.edu. + The GNU C Library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU Lesser General Public License as published by - the Free Software Foundation; either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, + The GNU C Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU Lesser General Public License for more details. + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Lesser General Public License for more details. - You should have received a copy of the GNU Lesser General Public License - along with this program. If not, see . */ + You should have received a copy of the GNU Lesser General Public + License along with the GNU C Library; if not, see + . */ #ifdef _LIBC +# define USE_IN_EXTENDED_LOCALE_MODEL 1 # define HAVE_STRUCT_ERA_ENTRY 1 # define HAVE_TM_GMTOFF 1 # define HAVE_TM_ZONE 1 @@ -63,10 +63,10 @@ extern char *tzname[]; #endif #include -#include #include #include #include +#include #ifdef COMPILE_WIDE # include @@ -247,11 +247,11 @@ extern char *tzname[]; # undef _NL_CURRENT # define _NL_CURRENT(category, item) \ (current->values[_NL_ITEM_INDEX (item)].string) +# define LOCALE_PARAM , __locale_t loc # define LOCALE_ARG , loc -# define LOCALE_PARAM_PROTO , __locale_t loc # define HELPER_LOCALE_ARG , current #else -# define LOCALE_PARAM_PROTO +# define LOCALE_PARAM # define LOCALE_ARG # ifdef _LIBC # define HELPER_LOCALE_ARG , _NL_CURRENT_DATA (LC_TIME) @@ -304,18 +304,22 @@ fwrite_uppcase (FILE *fp, const CHAR_T *src, size_t len) } } #else +static CHAR_T *memcpy_lowcase (CHAR_T *dest, const CHAR_T *src, + size_t len LOCALE_PARAM); + static CHAR_T * -memcpy_lowcase (CHAR_T *dest, const CHAR_T *src, - size_t len LOCALE_PARAM_PROTO) +memcpy_lowcase (CHAR_T *dest, const CHAR_T *src, size_t len LOCALE_PARAM) { while (len-- > 0) dest[len] = TOLOWER ((UCHAR_T) src[len], loc); return dest; } +static CHAR_T *memcpy_uppcase (CHAR_T *dest, const CHAR_T *src, + size_t len LOCALE_PARAM); + static CHAR_T * -memcpy_uppcase (CHAR_T *dest, const CHAR_T *src, - size_t len LOCALE_PARAM_PROTO) +memcpy_uppcase (CHAR_T *dest, const CHAR_T *src, size_t len LOCALE_PARAM) { while (len-- > 0) dest[len] = TOUPPER ((UCHAR_T) src[len], loc); @@ -328,6 +332,7 @@ memcpy_uppcase (CHAR_T *dest, const CHAR_T *src, /* Yield the difference between *A and *B, measured in seconds, ignoring leap seconds. */ # define tm_diff ftime_tm_diff +static int tm_diff (const struct tm *, const struct tm *); static int tm_diff (const struct tm *a, const struct tm *b) { @@ -359,6 +364,7 @@ tm_diff (const struct tm *a, const struct tm *b) #define ISO_WEEK_START_WDAY 1 /* Monday */ #define ISO_WEEK1_WDAY 4 /* Thursday */ #define YDAY_MINIMUM (-366) +static int iso_week_days (int, int); #ifdef __GNUC__ __inline__ #endif @@ -401,17 +407,41 @@ iso_week_days (int yday, int wday) # define ns 0 #endif +static size_t __strftime_internal (STREAM_OR_CHAR_T *, STRFTIME_ARG (size_t) + const CHAR_T *, const struct tm *, + bool, bool * + extra_args_spec LOCALE_PARAM); -/* Just like my_strftime, below, but with one more parameter, UPCASE, - to indicate that the result should be converted to upper case. */ +/* Write information from TP into S according to the format + string FORMAT, writing no more that MAXSIZE characters + (including the terminating '\0') and returning number of + characters written. If S is NULL, nothing will be written + anywhere, so to determine how many characters would be + written, use NULL for S and (size_t) -1 for MAXSIZE. */ +size_t +my_strftime (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize) + const CHAR_T *format, + const struct tm *tp extra_args_spec LOCALE_PARAM) +{ + bool tzset_called = false; + return __strftime_internal (s, STRFTIME_ARG (maxsize) format, tp, + false, &tzset_called extra_args LOCALE_ARG); +} +#if defined _LIBC && ! FPRINTFTIME +libc_hidden_def (my_strftime) +#endif + +/* Just like my_strftime, above, but with two more parameters. + UPCASE indicate that the result should be converted to upper case, + and *TZSET_CALLED indicates whether tzset has been called here. */ static size_t -strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, - STRFTIME_ARG (size_t maxsize) - const CHAR_T *format, - const struct tm *tp extra_args_spec LOCALE_PARAM_PROTO) +__strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize) + const CHAR_T *format, + const struct tm *tp, bool upcase, bool *tzset_called + extra_args_spec LOCALE_PARAM) { #if defined _LIBC && defined USE_IN_EXTENDED_LOCALE_MODEL - struct locale_data *const current = loc->__locales[LC_TIME]; + struct __locale_data *const current = loc->__locales[LC_TIME]; #endif #if FPRINTFTIME size_t maxsize = (size_t) -1; @@ -426,13 +456,17 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, only a few elements. Dereference the pointers only if the format requires this. Then it is ok to fail if the pointers are invalid. */ # define a_wkday \ - ((const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(ABDAY_1) + tp->tm_wday)) + ((const CHAR_T *) (tp->tm_wday < 0 || tp->tm_wday > 6 \ + ? "?" : _NL_CURRENT (LC_TIME, NLW(ABDAY_1) + tp->tm_wday))) # define f_wkday \ - ((const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(DAY_1) + tp->tm_wday)) + ((const CHAR_T *) (tp->tm_wday < 0 || tp->tm_wday > 6 \ + ? "?" : _NL_CURRENT (LC_TIME, NLW(DAY_1) + tp->tm_wday))) # define a_month \ - ((const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(ABMON_1) + tp->tm_mon)) + ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \ + ? "?" : _NL_CURRENT (LC_TIME, NLW(ABMON_1) + tp->tm_mon))) # define f_month \ - ((const CHAR_T *) _NL_CURRENT (LC_TIME, NLW(MON_1) + tp->tm_mon)) + ((const CHAR_T *) (tp->tm_mon < 0 || tp->tm_mon > 11 \ + ? "?" : _NL_CURRENT (LC_TIME, NLW(MON_1) + tp->tm_mon))) # define ampm \ ((const CHAR_T *) _NL_CURRENT (LC_TIME, tp->tm_hour > 11 \ ? NLW(PM_STR) : NLW(AM_STR))) @@ -482,16 +516,22 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, # if !HAVE_TM_ZONE /* Infer the zone name from *TZ instead of from TZNAME. */ tzname_vec = tz->tzname_copy; -# endif - /* POSIX.1 requires that local time zone information be used as - though strftime called tzset. */ -# if HAVE_TZSET - tzset (); # endif } /* The tzset() call might have changed the value. */ if (!(zone && *zone) && tp->tm_isdst >= 0) - zone = tzname_vec[tp->tm_isdst != 0]; + { + /* POSIX.1 requires that local time zone information be used as + though strftime called tzset. */ +# if HAVE_TZSET + if (!*tzset_called) + { + tzset (); + *tzset_called = true; + } +# endif + zone = tzname_vec[tp->tm_isdst != 0]; + } #endif if (! zone) zone = ""; @@ -699,11 +739,10 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, /* The mask is not what you might think. When the ordinal i'th bit is set, insert a colon before the i'th digit of the time zone representation. */ -#define DO_TZ_OFFSET(d, negative, mask, v) \ +#define DO_TZ_OFFSET(d, mask, v) \ do \ { \ digits = d; \ - negative_number = negative; \ tz_colon_mask = mask; \ u_number_value = v; \ goto do_tz_offset; \ @@ -801,14 +840,15 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, subformat: { - size_t len = strftime_case_ (to_uppcase, - NULL, STRFTIME_ARG ((size_t) -1) - subfmt, - tp extra_args LOCALE_ARG); - add (len, strftime_case_ (to_uppcase, p, - STRFTIME_ARG (maxsize - i) - subfmt, - tp extra_args LOCALE_ARG)); + size_t len = __strftime_internal (NULL, STRFTIME_ARG ((size_t) -1) + subfmt, + tp, to_uppcase, tzset_called + extra_args LOCALE_ARG); + add (len, __strftime_internal (p, + STRFTIME_ARG (maxsize - i) + subfmt, + tp, to_uppcase, tzset_called + extra_args LOCALE_ARG)); } break; @@ -845,8 +885,6 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, #endif case L_('C'): - if (modifier == L_('O')) - goto bad_format; if (modifier == L_('E')) { #if HAVE_STRUCT_ERA_ENTRY @@ -1115,6 +1153,10 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, goto underlying_strftime; #endif + case L_('q'): /* GNU extension. */ + DO_SIGNED_NUMBER (1, false, ((tp->tm_mon * 11) >> 5) + 1); + break; + case L_('R'): subfmt = L_("%H:%M"); goto subformat; @@ -1364,6 +1406,16 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, struct tm ltm; time_t lt; + /* POSIX.1 requires that local time zone information be used as + though strftime called tzset. */ +# if HAVE_TZSET + if (!*tzset_called) + { + tzset (); + *tzset_called = true; + } +# endif + ltm = *tp; lt = mktime_z (tz, <m); @@ -1391,6 +1443,7 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, } #endif + negative_number = diff < 0 || (diff == 0 && *zone == '-'); hour_diff = diff / 60 / 60; min_diff = diff / 60 % 60; sec_diff = diff % 60; @@ -1398,13 +1451,13 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, switch (colons) { case 0: /* +hhmm */ - DO_TZ_OFFSET (5, diff < 0, 0, hour_diff * 100 + min_diff); + DO_TZ_OFFSET (5, 0, hour_diff * 100 + min_diff); case 1: tz_hh_mm: /* +hh:mm */ - DO_TZ_OFFSET (6, diff < 0, 04, hour_diff * 100 + min_diff); + DO_TZ_OFFSET (6, 04, hour_diff * 100 + min_diff); case 2: tz_hh_mm_ss: /* +hh:mm:ss */ - DO_TZ_OFFSET (9, diff < 0, 024, + DO_TZ_OFFSET (9, 024, hour_diff * 10000 + min_diff * 100 + sec_diff); case 3: /* +hh if possible, else +hh:mm, else +hh:mm:ss */ @@ -1412,7 +1465,7 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, goto tz_hh_mm_ss; if (min_diff != 0) goto tz_hh_mm; - DO_TZ_OFFSET (3, diff < 0, 0, hour_diff); + DO_TZ_OFFSET (3, 0, hour_diff); default: goto bad_format; @@ -1444,22 +1497,3 @@ strftime_case_ (bool upcase, STREAM_OR_CHAR_T *s, return i; } - -/* Write information from TP into S according to the format - string FORMAT, writing no more that MAXSIZE characters - (including the terminating '\0') and returning number of - characters written. If S is NULL, nothing will be written - anywhere, so to determine how many characters would be - written, use NULL for S and (size_t) -1 for MAXSIZE. */ -size_t -my_strftime (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize) - const CHAR_T *format, - const struct tm *tp extra_args_spec LOCALE_PARAM_PROTO) -{ - return strftime_case_ (false, s, STRFTIME_ARG (maxsize) - format, tp extra_args LOCALE_ARG); -} - -#if defined _LIBC && ! FPRINTFTIME -libc_hidden_def (my_strftime) -#endif diff --git a/lib/strftime.h b/lib/strftime.h index 9247af68b..523898856 100644 --- a/lib/strftime.h +++ b/lib/strftime.h @@ -1,6 +1,6 @@ /* declarations for strftime.c - Copyright (C) 2002, 2004, 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2002, 2004, 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/striconveh.c b/lib/striconveh.c index 23a071825..5aec9bb83 100644 --- a/lib/striconveh.c +++ b/lib/striconveh.c @@ -1,5 +1,5 @@ /* Character set conversion with error handling. - Copyright (C) 2001-2016 Free Software Foundation, Inc. + Copyright (C) 2001-2017 Free Software Foundation, Inc. Written by Bruno Haible and Simon Josefsson. This program is free software: you can redistribute it and/or modify diff --git a/lib/striconveh.h b/lib/striconveh.h index a6fe7cfe5..0109ebd07 100644 --- a/lib/striconveh.h +++ b/lib/striconveh.h @@ -1,5 +1,5 @@ /* Character set conversion with error handling. - Copyright (C) 2001-2007, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2001-2007, 2009-2017 Free Software Foundation, Inc. Written by Bruno Haible and Simon Josefsson. This program is free software: you can redistribute it and/or modify diff --git a/lib/string.in.h b/lib/string.in.h index 94019c6b2..c0d517820 100644 --- a/lib/string.in.h +++ b/lib/string.in.h @@ -1,6 +1,6 @@ /* A GNU-like . - Copyright (C) 1995-1996, 2001-2016 Free Software Foundation, Inc. + Copyright (C) 1995-1996, 2001-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -416,15 +416,15 @@ _GL_WARN_ON_USE (strncat, "strncat is unportable - " # undef strndup # define strndup rpl_strndup # endif -_GL_FUNCDECL_RPL (strndup, char *, (char const *__string, size_t __n) +_GL_FUNCDECL_RPL (strndup, char *, (char const *__s, size_t __n) _GL_ARG_NONNULL ((1))); -_GL_CXXALIAS_RPL (strndup, char *, (char const *__string, size_t __n)); +_GL_CXXALIAS_RPL (strndup, char *, (char const *__s, size_t __n)); # else # if ! @HAVE_DECL_STRNDUP@ -_GL_FUNCDECL_SYS (strndup, char *, (char const *__string, size_t __n) +_GL_FUNCDECL_SYS (strndup, char *, (char const *__s, size_t __n) _GL_ARG_NONNULL ((1))); # endif -_GL_CXXALIAS_SYS (strndup, char *, (char const *__string, size_t __n)); +_GL_CXXALIAS_SYS (strndup, char *, (char const *__s, size_t __n)); # endif _GL_CXXALIASWARN (strndup); #elif defined GNULIB_POSIXCHECK @@ -444,17 +444,17 @@ _GL_WARN_ON_USE (strndup, "strndup is unportable - " # undef strnlen # define strnlen rpl_strnlen # endif -_GL_FUNCDECL_RPL (strnlen, size_t, (char const *__string, size_t __maxlen) +_GL_FUNCDECL_RPL (strnlen, size_t, (char const *__s, size_t __maxlen) _GL_ATTRIBUTE_PURE _GL_ARG_NONNULL ((1))); -_GL_CXXALIAS_RPL (strnlen, size_t, (char const *__string, size_t __maxlen)); +_GL_CXXALIAS_RPL (strnlen, size_t, (char const *__s, size_t __maxlen)); # else # if ! @HAVE_DECL_STRNLEN@ -_GL_FUNCDECL_SYS (strnlen, size_t, (char const *__string, size_t __maxlen) +_GL_FUNCDECL_SYS (strnlen, size_t, (char const *__s, size_t __maxlen) _GL_ATTRIBUTE_PURE _GL_ARG_NONNULL ((1))); # endif -_GL_CXXALIAS_SYS (strnlen, size_t, (char const *__string, size_t __maxlen)); +_GL_CXXALIAS_SYS (strnlen, size_t, (char const *__s, size_t __maxlen)); # endif _GL_CXXALIASWARN (strnlen); #elif defined GNULIB_POSIXCHECK diff --git a/lib/stripslash.c b/lib/stripslash.c index 809ab7a28..ec2e05e49 100644 --- a/lib/stripslash.c +++ b/lib/stripslash.c @@ -1,6 +1,6 @@ /* stripslash.c -- remove redundant trailing slashes from a file name - Copyright (C) 1990, 2001, 2003-2006, 2009-2016 Free Software Foundation, + Copyright (C) 1990, 2001, 2003-2006, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify diff --git a/lib/sys_file.in.h b/lib/sys_file.in.h index 9973c27f0..26dec1d3e 100644 --- a/lib/sys_file.in.h +++ b/lib/sys_file.in.h @@ -1,6 +1,6 @@ /* Provide a more complete sys/file.h. - Copyright (C) 2007-2016 Free Software Foundation, Inc. + Copyright (C) 2007-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sys_select.in.h b/lib/sys_select.in.h index 53e318a3c..cba4b412b 100644 --- a/lib/sys_select.in.h +++ b/lib/sys_select.in.h @@ -1,5 +1,5 @@ /* Substitute for . - Copyright (C) 2007-2016 Free Software Foundation, Inc. + Copyright (C) 2007-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sys_socket.in.h b/lib/sys_socket.in.h index 26024f69b..841b4135f 100644 --- a/lib/sys_socket.in.h +++ b/lib/sys_socket.in.h @@ -1,6 +1,6 @@ /* Provide a sys/socket header file for systems lacking it (read: MinGW) and for systems where it is incomplete. - Copyright (C) 2005-2016 Free Software Foundation, Inc. + Copyright (C) 2005-2017 Free Software Foundation, Inc. Written by Simon Josefsson. This program is free software; you can redistribute it and/or modify @@ -79,7 +79,12 @@ _GL_INLINE_HEADER_BEGIN #if !@HAVE_SA_FAMILY_T@ # if !GNULIB_defined_sa_family_t +/* On OS/2 kLIBC, sa_family_t is unsigned char unless TCPV40HDRS is defined. */ +# if !defined __KLIBC__ || defined TCPV40HDRS typedef unsigned short sa_family_t; +# else +typedef unsigned char sa_family_t; +# endif # define GNULIB_defined_sa_family_t 1 # endif #endif diff --git a/lib/sys_stat.in.h b/lib/sys_stat.in.h index 2d063956d..72c465deb 100644 --- a/lib/sys_stat.in.h +++ b/lib/sys_stat.in.h @@ -1,5 +1,5 @@ /* Provide a more complete sys/stat header file. - Copyright (C) 2005-2016 Free Software Foundation, Inc. + Copyright (C) 2005-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sys_time.in.h b/lib/sys_time.in.h index e1e26e33b..f141b5210 100644 --- a/lib/sys_time.in.h +++ b/lib/sys_time.in.h @@ -1,6 +1,6 @@ /* Provide a more complete sys/time.h. - Copyright (C) 2007-2016 Free Software Foundation, Inc. + Copyright (C) 2007-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -109,6 +109,13 @@ _GL_CXXALIAS_SYS_CAST (gettimeofday, int, (struct timeval *restrict, void *restrict)); # endif _GL_CXXALIASWARN (gettimeofday); +# if defined __cplusplus && defined GNULIB_NAMESPACE +namespace GNULIB_NAMESPACE { + typedef ::timeval +#undef timeval + timeval; +} +# endif #elif defined GNULIB_POSIXCHECK # undef gettimeofday # if HAVE_RAW_DECL_GETTIMEOFDAY diff --git a/lib/sys_times.in.h b/lib/sys_times.in.h index 693eedec5..d98ca11e5 100644 --- a/lib/sys_times.in.h +++ b/lib/sys_times.in.h @@ -1,5 +1,5 @@ /* Provide a sys/times.h header file. - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sys_types.in.h b/lib/sys_types.in.h index 9ca53ac0e..78d8faee3 100644 --- a/lib/sys_types.in.h +++ b/lib/sys_types.in.h @@ -1,6 +1,6 @@ /* Provide a more complete sys/types.h. - Copyright (C) 2011-2016 Free Software Foundation, Inc. + Copyright (C) 2011-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/sys_uio.in.h b/lib/sys_uio.in.h index d72eb568a..ec57b7c22 100644 --- a/lib/sys_uio.in.h +++ b/lib/sys_uio.in.h @@ -1,5 +1,5 @@ /* Substitute for . - Copyright (C) 2011-2016 Free Software Foundation, Inc. + Copyright (C) 2011-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/tempname.c b/lib/tempname.c index 5136bb495..f6436a932 100644 --- a/lib/tempname.c +++ b/lib/tempname.c @@ -1,6 +1,6 @@ /* tempname.c - generate the name of a temporary file. - Copyright (C) 1991-2003, 2005-2007, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 1991-2003, 2005-2007, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/tempname.h b/lib/tempname.h index 4e032880a..5b740e852 100644 --- a/lib/tempname.h +++ b/lib/tempname.h @@ -1,6 +1,6 @@ /* Create a temporary file or directory. - Copyright (C) 2006, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2006, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/time-internal.h b/lib/time-internal.h index 48c0977d1..375e1341a 100644 --- a/lib/time-internal.h +++ b/lib/time-internal.h @@ -1,6 +1,6 @@ /* Time internal interface - Copyright 2015-2016 Free Software Foundation, Inc. + Copyright 2015-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -38,8 +38,8 @@ struct tm_zone /* A sequence of null-terminated strings packed next to each other. The strings are followed by an extra null byte. If TZ_IS_SET, there must be at least one string and the first string (which is - actually a TZ environment value value) may be empty. Otherwise - all strings must be nonempty. + actually a TZ environment value) may be empty. Otherwise all + strings must be nonempty. Abbreviations are stored here because otherwise the values of tm_zone and/or tzname would be dead after changing TZ and calling diff --git a/lib/time.in.h b/lib/time.in.h index 503085a60..296ea51f5 100644 --- a/lib/time.in.h +++ b/lib/time.in.h @@ -1,6 +1,6 @@ /* A more-standard . - Copyright (C) 2007-2016 Free Software Foundation, Inc. + Copyright (C) 2007-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -217,7 +217,7 @@ _GL_CXXALIAS_SYS (gmtime, struct tm *, (time_t const *__timer)); _GL_CXXALIASWARN (gmtime); # endif -/* Parse BUF as a time stamp, assuming FORMAT specifies its layout, and store +/* Parse BUF as a timestamp, assuming FORMAT specifies its layout, and store the resulting broken-down time into TM. See . */ # if @GNULIB_STRPTIME@ diff --git a/lib/time_r.c b/lib/time_r.c index 34ced96bf..7de3e3aac 100644 --- a/lib/time_r.c +++ b/lib/time_r.c @@ -1,6 +1,6 @@ /* Reentrant time functions like localtime_r. - Copyright (C) 2003, 2006-2007, 2010-2016 Free Software Foundation, Inc. + Copyright (C) 2003, 2006-2007, 2010-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/time_rz.c b/lib/time_rz.c index 612093bbc..c6e6083a6 100644 --- a/lib/time_rz.c +++ b/lib/time_rz.c @@ -1,6 +1,6 @@ /* Time zone functions such as tzalloc and localtime_rz - Copyright 2015-2016 Free Software Foundation, Inc. + Copyright 2015-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -32,6 +32,7 @@ #include #include +#include "flexmember.h" #include "time-internal.h" #if !HAVE_TZSET @@ -94,7 +95,7 @@ tzalloc (char const *name) { size_t name_size = name ? strlen (name) + 1 : 0; size_t abbr_size = name_size < ABBR_SIZE_MIN ? ABBR_SIZE_MIN : name_size + 1; - timezone_t tz = malloc (offsetof (struct tm_zone, abbrs) + abbr_size); + timezone_t tz = malloc (FLEXSIZEOF (struct tm_zone, abbrs, abbr_size)); if (tz) { tz->next = NULL; diff --git a/lib/timegm.c b/lib/timegm.c index 112be1ac6..168da8ead 100644 --- a/lib/timegm.c +++ b/lib/timegm.c @@ -1,6 +1,6 @@ /* Convert UTC calendar time to simple time. Like mktime but assumes UTC. - Copyright (C) 1994, 1997, 2003-2004, 2006-2007, 2009-2016 Free Software + Copyright (C) 1994, 1997, 2003-2004, 2006-2007, 2009-2017 Free Software Foundation, Inc. This file is part of the GNU C Library. This program is free software; you can redistribute it and/or modify diff --git a/lib/times.c b/lib/times.c index 4fa15c2df..f403e3de7 100644 --- a/lib/times.c +++ b/lib/times.c @@ -1,6 +1,6 @@ /* Get process times - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/trunc.c b/lib/trunc.c index eba389a3e..f110f46ca 100644 --- a/lib/trunc.c +++ b/lib/trunc.c @@ -1,5 +1,5 @@ /* Round towards zero. - Copyright (C) 2007, 2010-2016 Free Software Foundation, Inc. + Copyright (C) 2007, 2010-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/unistd.in.h b/lib/unistd.in.h index 26b73a8a2..2f862c853 100644 --- a/lib/unistd.in.h +++ b/lib/unistd.in.h @@ -1,5 +1,5 @@ /* Substitute for and wrapper around . - Copyright (C) 2003-2016 Free Software Foundation, Inc. + Copyright (C) 2003-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -55,9 +55,13 @@ #include /* mingw doesn't define the SEEK_* or *_FILENO macros in . */ +/* MSVC declares 'unlink' in , not in . We must include + it before we #define unlink rpl_unlink. */ /* Cygwin 1.7.1 declares symlinkat in , not in . */ /* But avoid namespace pollution on glibc systems. */ #if (!(defined SEEK_CUR && defined SEEK_END && defined SEEK_SET) \ + || ((@GNULIB_UNLINK@ || defined GNULIB_POSIXCHECK) \ + && ((defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__)) \ || ((@GNULIB_SYMLINKAT@ || defined GNULIB_POSIXCHECK) \ && defined __CYGWIN__)) \ && ! defined __GLIBC__ @@ -776,7 +780,7 @@ _GL_WARN_ON_USE (gethostname, "gethostname is unportable - " ${LOGNAME-$USER} on Unix platforms, $USERNAME on native Windows platforms. */ -# if !@HAVE_GETLOGIN@ +# if !@HAVE_DECL_GETLOGIN@ _GL_FUNCDECL_SYS (getlogin, char *, (void)); # endif _GL_CXXALIAS_SYS (getlogin, char *, (void)); diff --git a/lib/unsetenv.c b/lib/unsetenv.c index e94ea8f26..708119346 100644 --- a/lib/unsetenv.c +++ b/lib/unsetenv.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1992, 1995-2002, 2005-2016 Free Software Foundation, Inc. +/* Copyright (C) 1992, 1995-2002, 2005-2017 Free Software Foundation, Inc. This file is part of the GNU C Library. This program is free software: you can redistribute it and/or modify diff --git a/lib/vasnprintf.c b/lib/vasnprintf.c index e31dbadf0..412219bf4 100644 --- a/lib/vasnprintf.c +++ b/lib/vasnprintf.c @@ -1,5 +1,5 @@ /* vsprintf with automatic memory allocation. - Copyright (C) 1999, 2002-2016 Free Software Foundation, Inc. + Copyright (C) 1999, 2002-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -4832,9 +4832,9 @@ VASNPRINTF (DCHAR_T *resultbuf, size_t *lengthp, break; # else *fbp++ = 'l'; - /*FALLTHROUGH*/ # endif #endif + /*FALLTHROUGH*/ case TYPE_LONGINT: case TYPE_ULONGINT: #if HAVE_WINT_T diff --git a/lib/vasnprintf.h b/lib/vasnprintf.h index 47216c4c0..3631ff8c8 100644 --- a/lib/vasnprintf.h +++ b/lib/vasnprintf.h @@ -1,5 +1,5 @@ /* vsprintf with automatic memory allocation. - Copyright (C) 2002-2004, 2007-2016 Free Software Foundation, Inc. + Copyright (C) 2002-2004, 2007-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/verify.h b/lib/verify.h index 356c7fa0d..2d996ad3a 100644 --- a/lib/verify.h +++ b/lib/verify.h @@ -1,6 +1,6 @@ /* Compile-time assert-like macros. - Copyright (C) 2005-2006, 2009-2016 Free Software Foundation, Inc. + Copyright (C) 2005-2006, 2009-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -248,7 +248,12 @@ template /* Verify requirement R at compile-time, as a declaration without a trailing ';'. */ -#define verify(R) _GL_VERIFY (R, "verify (" #R ")") +#ifdef __GNUC__ +# define verify(R) _GL_VERIFY (R, "verify (" #R ")") +#else +/* PGI barfs if R is long. Play it safe. */ +# define verify(R) _GL_VERIFY (R, "verify (...)") +#endif #ifndef __has_builtin # define __has_builtin(x) 0 diff --git a/lib/vsnprintf.c b/lib/vsnprintf.c index af0517401..2014ce9c4 100644 --- a/lib/vsnprintf.c +++ b/lib/vsnprintf.c @@ -1,5 +1,5 @@ /* Formatted output to strings. - Copyright (C) 2004, 2006-2016 Free Software Foundation, Inc. + Copyright (C) 2004, 2006-2017 Free Software Foundation, Inc. Written by Simon Josefsson and Yoann Vandoorselaere . This program is free software; you can redistribute it and/or modify diff --git a/lib/w32sock.h b/lib/w32sock.h index f9506b71e..9c55e5a05 100644 --- a/lib/w32sock.h +++ b/lib/w32sock.h @@ -1,6 +1,6 @@ /* w32sock.h --- internal auxiliary functions for Windows socket functions - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/lib/wchar.in.h b/lib/wchar.in.h index 7d1aa162b..9f2fbc6db 100644 --- a/lib/wchar.in.h +++ b/lib/wchar.in.h @@ -1,6 +1,6 @@ /* A substitute for ISO C99 , for platforms that have issues. - Copyright (C) 2007-2016 Free Software Foundation, Inc. + Copyright (C) 2007-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -35,6 +35,7 @@ || (defined __hpux \ && ((defined _INTTYPES_INCLUDED && !defined strtoimax) \ || defined _GL_JUST_INCLUDE_SYSTEM_WCHAR_H)) \ + || (defined __MINGW32__ && defined __STRING_H_SOURCED__) \ || defined _GL_ALREADY_INCLUDING_WCHAR_H) /* Special invocation convention: - Inside glibc and uClibc header files, but not MinGW. @@ -44,6 +45,8 @@ and once directly. In both situations 'wint_t' is not yet defined, therefore we cannot provide the function overrides; instead include only the system's . + - With MinGW 3.22, when includes , only some part of + is actually processed, and that doesn't include 'mbstate_t'. - On IRIX 6.5, similarly, we have an include -> , and the latter includes . But here, we have no way to detect whether is completely included or is still being included. */ @@ -110,10 +113,10 @@ # define WEOF -1 # endif #else -/* MSVC defines wint_t as 'unsigned short' in . +/* mingw and MSVC define wint_t as 'unsigned short' in . This is too small: ISO C 99 section 7.24.1.(2) says that wint_t must be "unchanged by default argument promotions". Override it. */ -# if defined _MSC_VER +# if @GNULIB_OVERRIDES_WINT_T@ # if !GNULIB_defined_wint_t # include typedef unsigned int rpl_wint_t; diff --git a/lib/wcrtomb.c b/lib/wcrtomb.c index d6cc58a14..ee5906c30 100644 --- a/lib/wcrtomb.c +++ b/lib/wcrtomb.c @@ -1,5 +1,5 @@ /* Convert wide character to multibyte character. - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. Written by Bruno Haible , 2008. This program is free software: you can redistribute it and/or modify diff --git a/lib/wctype.in.h b/lib/wctype.in.h index 3d889f0fc..f4c7c014a 100644 --- a/lib/wctype.in.h +++ b/lib/wctype.in.h @@ -1,6 +1,6 @@ /* A substitute for ISO C99 , for platforms that lack it. - Copyright (C) 2006-2016 Free Software Foundation, Inc. + Copyright (C) 2006-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by @@ -25,13 +25,25 @@ * wctrans_t, and wctype_t are not yet implemented. */ -#ifndef _@GUARD_PREFIX@_WCTYPE_H - #if __GNUC__ >= 3 @PRAGMA_SYSTEM_HEADER@ #endif @PRAGMA_COLUMNS@ +#if (defined __MINGW32__ && defined __CTYPE_H_SOURCED__) + +/* Special invocation convention: + - With MinGW 3.22, when includes , only some part of + is being processed, which doesn't include the idempotency + guard. */ + +#@INCLUDE_NEXT@ @NEXT_WCTYPE_H@ + +#else +/* Normal invocation convention. */ + +#ifndef _@GUARD_PREFIX@_WCTYPE_H + #if @HAVE_WINT_T@ /* Solaris 2.5 has a bug: must be included before . Tru64 with Desktop Toolkit C has a bug: must be included before @@ -93,10 +105,10 @@ _GL_INLINE_HEADER_BEGIN # define WEOF -1 # endif #else -/* MSVC defines wint_t as 'unsigned short' in . +/* mingw and MSVC define wint_t as 'unsigned short' in . This is too small: ISO C 99 section 7.24.1.(2) says that wint_t must be "unchanged by default argument promotions". Override it. */ -# if defined _MSC_VER +# if @GNULIB_OVERRIDES_WINT_T@ # if !GNULIB_defined_wint_t # include typedef unsigned int rpl_wint_t; @@ -512,3 +524,4 @@ _GL_INLINE_HEADER_END #endif /* _@GUARD_PREFIX@_WCTYPE_H */ #endif /* _@GUARD_PREFIX@_WCTYPE_H */ +#endif diff --git a/lib/write.c b/lib/write.c index e3cd35a36..c451a5011 100644 --- a/lib/write.c +++ b/lib/write.c @@ -1,5 +1,5 @@ /* POSIX compatible write() function. - Copyright (C) 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2008-2017 Free Software Foundation, Inc. Written by Bruno Haible , 2008. This program is free software: you can redistribute it and/or modify diff --git a/lib/xalloc-oversized.h b/lib/xalloc-oversized.h new file mode 100644 index 000000000..1b92a588c --- /dev/null +++ b/lib/xalloc-oversized.h @@ -0,0 +1,60 @@ +/* xalloc-oversized.h -- memory allocation size checking + + Copyright (C) 1990-2000, 2003-2004, 2006-2017 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#ifndef XALLOC_OVERSIZED_H_ +#define XALLOC_OVERSIZED_H_ + +#include +#include + +/* True if N * S would overflow in a size_t calculation, + or would generate a value larger than PTRDIFF_MAX. + This expands to a constant expression if N and S are both constants. + By gnulib convention, SIZE_MAX represents overflow in size + calculations, so the conservative size_t-based dividend to use here + is SIZE_MAX - 1. */ +#define __xalloc_oversized(n, s) \ + ((size_t) (PTRDIFF_MAX < SIZE_MAX ? PTRDIFF_MAX : SIZE_MAX - 1) / (s) < (n)) + +#if PTRDIFF_MAX < SIZE_MAX +typedef ptrdiff_t __xalloc_count_type; +#else +typedef size_t __xalloc_count_type; +#endif + +/* Return 1 if an array of N objects, each of size S, cannot exist + reliably due to size or ptrdiff_t arithmetic overflow. S must be + positive and N must be nonnegative. This is a macro, not a + function, so that it works correctly even when SIZE_MAX < N. */ + +#if 7 <= __GNUC__ +# define xalloc_oversized(n, s) \ + __builtin_mul_overflow_p (n, s, (__xalloc_count_type) 1) +#elif 5 <= __GNUC__ && !__STRICT_ANSI__ +# define xalloc_oversized(n, s) \ + (__builtin_constant_p (n) && __builtin_constant_p (s) \ + ? __xalloc_oversized (n, s) \ + : ({ __xalloc_count_type __xalloc_count; \ + __builtin_mul_overflow (n, s, &__xalloc_count); })) + +/* Other compilers use integer division; this may be slower but is + more portable. */ +#else +# define xalloc_oversized(n, s) __xalloc_oversized (n, s) +#endif + +#endif /* !XALLOC_OVERSIZED_H_ */ diff --git a/lib/xsize.h b/lib/xsize.h index 840d6829f..d78767188 100644 --- a/lib/xsize.h +++ b/lib/xsize.h @@ -1,6 +1,6 @@ /* xsize.h -- Checked size_t computations. - Copyright (C) 2003, 2008-2016 Free Software Foundation, Inc. + Copyright (C) 2003, 2008-2017 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by diff --git a/m4/00gnulib.m4 b/m4/00gnulib.m4 index bb37e32aa..bb3512fd5 100644 --- a/m4/00gnulib.m4 +++ b/m4/00gnulib.m4 @@ -1,5 +1,5 @@ # 00gnulib.m4 serial 3 -dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/absolute-header.m4 b/m4/absolute-header.m4 index 7ffc38d7a..c73adc82d 100644 --- a/m4/absolute-header.m4 +++ b/m4/absolute-header.m4 @@ -1,5 +1,5 @@ # absolute-header.m4 serial 16 -dnl Copyright (C) 2006-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/alloca.m4 b/m4/alloca.m4 index 2382ff1ee..7f0604cbd 100644 --- a/m4/alloca.m4 +++ b/m4/alloca.m4 @@ -1,5 +1,5 @@ # alloca.m4 serial 14 -dnl Copyright (C) 2002-2004, 2006-2007, 2009-2016 Free Software Foundation, +dnl Copyright (C) 2002-2004, 2006-2007, 2009-2017 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/arpa_inet_h.m4 b/m4/arpa_inet_h.m4 index 5387f2840..d6554554f 100644 --- a/m4/arpa_inet_h.m4 +++ b/m4/arpa_inet_h.m4 @@ -1,5 +1,5 @@ # arpa_inet_h.m4 serial 13 -dnl Copyright (C) 2006, 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/autobuild.m4 b/m4/autobuild.m4 index 66b183b23..f5f2a1899 100644 --- a/m4/autobuild.m4 +++ b/m4/autobuild.m4 @@ -1,5 +1,5 @@ # autobuild.m4 serial 7 -dnl Copyright (C) 2004, 2006-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2004, 2006-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/btowc.m4 b/m4/btowc.m4 index 47e8fd8a1..102180938 100644 --- a/m4/btowc.m4 +++ b/m4/btowc.m4 @@ -1,5 +1,5 @@ # btowc.m4 serial 10 -dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/builtin-expect.m4 b/m4/builtin-expect.m4 new file mode 100644 index 000000000..aa3364bff --- /dev/null +++ b/m4/builtin-expect.m4 @@ -0,0 +1,49 @@ +dnl Check for __builtin_expect. + +dnl Copyright 2016-2017 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl Written by Paul Eggert. + +AC_DEFUN([gl___BUILTIN_EXPECT], +[ + AC_CACHE_CHECK([for __builtin_expect], + [gl_cv___builtin_expect], + [AC_LINK_IFELSE( + [AC_LANG_SOURCE([[ + int + main (int argc, char **argv) + { + argc = __builtin_expect (argc, 100); + return argv[argc != 100][0]; + }]])], + [gl_cv___builtin_expect=yes], + [AC_LINK_IFELSE( + [AC_LANG_SOURCE([[ + #include + int + main (int argc, char **argv) + { + argc = __builtin_expect (argc, 100); + return argv[argc != 100][0]; + }]])], + [gl_cv___builtin_expect="in "], + [gl_cv___builtin_expect=no])])]) + if test "$gl_cv___builtin_expect" = yes; then + AC_DEFINE([HAVE___BUILTIN_EXPECT], [1]) + elif test "$gl_cv___builtin_expect" = "in "; then + AC_DEFINE([HAVE___BUILTIN_EXPECT], [2]) + fi + AH_VERBATIM([HAVE___BUILTIN_EXPECT], + [/* Define to 1 if the compiler supports __builtin_expect, + and to 2 if does. */ +#undef HAVE___BUILTIN_EXPECT +#ifndef HAVE___BUILTIN_EXPECT +# define __builtin_expect(e, c) (e) +#elif HAVE___BUILTIN_EXPECT == 2 +# include +#endif + ]) +]) diff --git a/m4/byteswap.m4 b/m4/byteswap.m4 index 27f0fd69d..f20d0f490 100644 --- a/m4/byteswap.m4 +++ b/m4/byteswap.m4 @@ -1,5 +1,5 @@ # byteswap.m4 serial 4 -dnl Copyright (C) 2005, 2007, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2005, 2007, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/canonicalize.m4 b/m4/canonicalize.m4 index cbbf3e267..c04ff8dd0 100644 --- a/m4/canonicalize.m4 +++ b/m4/canonicalize.m4 @@ -1,6 +1,6 @@ # canonicalize.m4 serial 28 -dnl Copyright (C) 2003-2007, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2003-2007, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/ceil.m4 b/m4/ceil.m4 index 214e5657a..f58a99899 100644 --- a/m4/ceil.m4 +++ b/m4/ceil.m4 @@ -1,5 +1,5 @@ # ceil.m4 serial 9 -dnl Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/check-math-lib.m4 b/m4/check-math-lib.m4 index 58af05100..8241eedc3 100644 --- a/m4/check-math-lib.m4 +++ b/m4/check-math-lib.m4 @@ -1,5 +1,5 @@ # check-math-lib.m4 serial 4 -dnl Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/clock_time.m4 b/m4/clock_time.m4 index beace12c7..12d95ffeb 100644 --- a/m4/clock_time.m4 +++ b/m4/clock_time.m4 @@ -1,5 +1,5 @@ # clock_time.m4 serial 10 -dnl Copyright (C) 2002-2006, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2006, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/close.m4 b/m4/close.m4 index 310f076be..005a43ae1 100644 --- a/m4/close.m4 +++ b/m4/close.m4 @@ -1,5 +1,5 @@ # close.m4 serial 8 -dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/configmake.m4 b/m4/configmake.m4 index 80b92548c..b783296b6 100644 --- a/m4/configmake.m4 +++ b/m4/configmake.m4 @@ -1,5 +1,5 @@ # configmake.m4 serial 2 -dnl Copyright (C) 2010-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/copysign.m4 b/m4/copysign.m4 index fd1f7be4b..a39de0171 100644 --- a/m4/copysign.m4 +++ b/m4/copysign.m4 @@ -1,5 +1,5 @@ # copysign.m4 serial 1 -dnl Copyright (C) 2011-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/dirent_h.m4 b/m4/dirent_h.m4 index 68836a406..1f9c4f31f 100644 --- a/m4/dirent_h.m4 +++ b/m4/dirent_h.m4 @@ -1,5 +1,5 @@ # dirent_h.m4 serial 16 -dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/dirfd.m4 b/m4/dirfd.m4 index 1d7cb080d..b4ec3d191 100644 --- a/m4/dirfd.m4 +++ b/m4/dirfd.m4 @@ -2,7 +2,7 @@ dnl Find out how to get the file descriptor associated with an open DIR*. -# Copyright (C) 2001-2006, 2008-2016 Free Software Foundation, Inc. +# Copyright (C) 2001-2006, 2008-2017 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/dirname.m4 b/m4/dirname.m4 index 6f8bec32c..46f5394c7 100644 --- a/m4/dirname.m4 +++ b/m4/dirname.m4 @@ -1,5 +1,5 @@ #serial 10 -*- autoconf -*- -dnl Copyright (C) 2002-2006, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2006, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/double-slash-root.m4 b/m4/double-slash-root.m4 index dfd3921d1..c80f9eada 100644 --- a/m4/double-slash-root.m4 +++ b/m4/double-slash-root.m4 @@ -1,5 +1,5 @@ # double-slash-root.m4 serial 4 -*- Autoconf -*- -dnl Copyright (C) 2006, 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/dup2.m4 b/m4/dup2.m4 index 5b68312b1..bdb9ae250 100644 --- a/m4/dup2.m4 +++ b/m4/dup2.m4 @@ -1,5 +1,5 @@ #serial 25 -dnl Copyright (C) 2002, 2005, 2007, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2002, 2005, 2007, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/duplocale.m4 b/m4/duplocale.m4 index fcf9d3980..b5efd246b 100644 --- a/m4/duplocale.m4 +++ b/m4/duplocale.m4 @@ -1,5 +1,5 @@ # duplocale.m4 serial 8 -dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/eealloc.m4 b/m4/eealloc.m4 index 63d74defe..96b9bca5a 100644 --- a/m4/eealloc.m4 +++ b/m4/eealloc.m4 @@ -1,5 +1,5 @@ # eealloc.m4 serial 3 -dnl Copyright (C) 2003, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/environ.m4 b/m4/environ.m4 index 9a0ea7e21..3b9fa5f58 100644 --- a/m4/environ.m4 +++ b/m4/environ.m4 @@ -1,5 +1,5 @@ # environ.m4 serial 6 -dnl Copyright (C) 2001-2004, 2006-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2004, 2006-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/errno_h.m4 b/m4/errno_h.m4 index b111fce05..9f0f2f2fb 100644 --- a/m4/errno_h.m4 +++ b/m4/errno_h.m4 @@ -1,5 +1,5 @@ # errno_h.m4 serial 12 -dnl Copyright (C) 2004, 2006, 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2004, 2006, 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/exponentd.m4 b/m4/exponentd.m4 index 7869a7d6c..cd64b92d0 100644 --- a/m4/exponentd.m4 +++ b/m4/exponentd.m4 @@ -1,5 +1,5 @@ # exponentd.m4 serial 3 -dnl Copyright (C) 2007-2008, 2010-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2008, 2010-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/exponentf.m4 b/m4/exponentf.m4 index d4298f299..54f609e5a 100644 --- a/m4/exponentf.m4 +++ b/m4/exponentf.m4 @@ -1,5 +1,5 @@ # exponentf.m4 serial 2 -dnl Copyright (C) 2007-2008, 2010-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2008, 2010-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/exponentl.m4 b/m4/exponentl.m4 index c49cf2c3e..c9cb81dd8 100644 --- a/m4/exponentl.m4 +++ b/m4/exponentl.m4 @@ -1,5 +1,5 @@ # exponentl.m4 serial 3 -dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/extensions.m4 b/m4/extensions.m4 index 6d378ec41..c60f537db 100644 --- a/m4/extensions.m4 +++ b/m4/extensions.m4 @@ -1,7 +1,7 @@ -# serial 13 -*- Autoconf -*- +# serial 15 -*- Autoconf -*- # Enable extensions on systems that normally disable them. -# Copyright (C) 2003, 2006-2016 Free Software Foundation, Inc. +# Copyright (C) 2003, 2006-2017 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. @@ -60,7 +60,7 @@ dnl configure.ac when using autoheader 2.62. #ifndef _ALL_SOURCE # undef _ALL_SOURCE #endif -/* Enable general extensions on OS X. */ +/* Enable general extensions on macOS. */ #ifndef _DARWIN_C_SOURCE # undef _DARWIN_C_SOURCE #endif @@ -68,14 +68,38 @@ dnl configure.ac when using autoheader 2.62. #ifndef _GNU_SOURCE # undef _GNU_SOURCE #endif -/* Use GNU style printf and scanf. */ -#ifndef __USE_MINGW_ANSI_STDIO -# undef __USE_MINGW_ANSI_STDIO -#endif /* Enable threading extensions on Solaris. */ #ifndef _POSIX_PTHREAD_SEMANTICS # undef _POSIX_PTHREAD_SEMANTICS #endif +/* Enable extensions specified by ISO/IEC TS 18661-5:2014. */ +#ifndef __STDC_WANT_IEC_60559_ATTRIBS_EXT__ +# undef __STDC_WANT_IEC_60559_ATTRIBS_EXT__ +#endif +/* Enable extensions specified by ISO/IEC TS 18661-1:2014. */ +#ifndef __STDC_WANT_IEC_60559_BFP_EXT__ +# undef __STDC_WANT_IEC_60559_BFP_EXT__ +#endif +/* Enable extensions specified by ISO/IEC TS 18661-2:2015. */ +#ifndef __STDC_WANT_IEC_60559_DFP_EXT__ +# undef __STDC_WANT_IEC_60559_DFP_EXT__ +#endif +/* Enable extensions specified by ISO/IEC TS 18661-4:2015. */ +#ifndef __STDC_WANT_IEC_60559_FUNCS_EXT__ +# undef __STDC_WANT_IEC_60559_FUNCS_EXT__ +#endif +/* Enable extensions specified by ISO/IEC TS 18661-3:2015. */ +#ifndef __STDC_WANT_IEC_60559_TYPES_EXT__ +# undef __STDC_WANT_IEC_60559_TYPES_EXT__ +#endif +/* Enable extensions specified by ISO/IEC TR 24731-2:2010. */ +#ifndef __STDC_WANT_LIB_EXT2__ +# undef __STDC_WANT_LIB_EXT2__ +#endif +/* Enable extensions specified by ISO/IEC 24747:2009. */ +#ifndef __STDC_WANT_MATH_SPEC_FUNCS__ +# undef __STDC_WANT_MATH_SPEC_FUNCS__ +#endif /* Enable extensions on HP NonStop. */ #ifndef _TANDEM_SOURCE # undef _TANDEM_SOURCE @@ -104,8 +128,14 @@ dnl configure.ac when using autoheader 2.62. AC_DEFINE([_ALL_SOURCE]) AC_DEFINE([_DARWIN_C_SOURCE]) AC_DEFINE([_GNU_SOURCE]) - AC_DEFINE([__USE_MINGW_ANSI_STDIO]) AC_DEFINE([_POSIX_PTHREAD_SEMANTICS]) + AC_DEFINE([__STDC_WANT_IEC_60559_ATTRIBS_EXT__]) + AC_DEFINE([__STDC_WANT_IEC_60559_BFP_EXT__]) + AC_DEFINE([__STDC_WANT_IEC_60559_DFP_EXT__]) + AC_DEFINE([__STDC_WANT_IEC_60559_FUNCS_EXT__]) + AC_DEFINE([__STDC_WANT_IEC_60559_TYPES_EXT__]) + AC_DEFINE([__STDC_WANT_LIB_EXT2__]) + AC_DEFINE([__STDC_WANT_MATH_SPEC_FUNCS__]) AC_DEFINE([_TANDEM_SOURCE]) AC_CACHE_CHECK([whether _XOPEN_SOURCE should be defined], [ac_cv_should_define__xopen_source], diff --git a/m4/extern-inline.m4 b/m4/extern-inline.m4 index 1e578f3de..00f960968 100644 --- a/m4/extern-inline.m4 +++ b/m4/extern-inline.m4 @@ -1,6 +1,6 @@ dnl 'extern inline' a la ISO C99. -dnl Copyright 2012-2016 Free Software Foundation, Inc. +dnl Copyright 2012-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/fcntl-o.m4 b/m4/fcntl-o.m4 index 24fcf88d0..3c3b63c52 100644 --- a/m4/fcntl-o.m4 +++ b/m4/fcntl-o.m4 @@ -1,5 +1,5 @@ # fcntl-o.m4 serial 4 -dnl Copyright (C) 2006, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/fcntl_h.m4 b/m4/fcntl_h.m4 index ef0d78dde..09c21eff9 100644 --- a/m4/fcntl_h.m4 +++ b/m4/fcntl_h.m4 @@ -1,6 +1,6 @@ # serial 15 # Configure fcntl.h. -dnl Copyright (C) 2006-2007, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2007, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/flexmember.m4 b/m4/flexmember.m4 index baa9ff8fb..35580ac27 100644 --- a/m4/flexmember.m4 +++ b/m4/flexmember.m4 @@ -1,7 +1,7 @@ -# serial 3 +# serial 4 # Check for flexible array member support. -# Copyright (C) 2006, 2009-2016 Free Software Foundation, Inc. +# Copyright (C) 2006, 2009-2017 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. @@ -19,8 +19,10 @@ AC_DEFUN([AC_C_FLEXIBLE_ARRAY_MEMBER], #include struct s { int n; double d[]; };]], [[int m = getchar (); - struct s *p = malloc (offsetof (struct s, d) - + m * sizeof (double)); + size_t nbytes = offsetof (struct s, d) + m * sizeof (double); + nbytes += sizeof (struct s) - 1; + nbytes -= nbytes % sizeof (struct s); + struct s *p = malloc (nbytes); p->d[0] = 0.0; return p->d != (double *) NULL;]])], [ac_cv_c_flexmember=yes], diff --git a/m4/float_h.m4 b/m4/float_h.m4 index e2887eb5c..e8522ab11 100644 --- a/m4/float_h.m4 +++ b/m4/float_h.m4 @@ -1,5 +1,5 @@ # float_h.m4 serial 9 -dnl Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/flock.m4 b/m4/flock.m4 index 01b38b7d5..5b3544df2 100644 --- a/m4/flock.m4 +++ b/m4/flock.m4 @@ -1,5 +1,5 @@ # flock.m4 serial 3 -dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/floor.m4 b/m4/floor.m4 index cd895054f..713e7b346 100644 --- a/m4/floor.m4 +++ b/m4/floor.m4 @@ -1,5 +1,5 @@ # floor.m4 serial 8 -dnl Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/fpieee.m4 b/m4/fpieee.m4 index e11ac9f09..69579d82a 100644 --- a/m4/fpieee.m4 +++ b/m4/fpieee.m4 @@ -1,5 +1,5 @@ # fpieee.m4 serial 2 -*- coding: utf-8 -*- -dnl Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/frexp.m4 b/m4/frexp.m4 index 23f582167..73f50b3e3 100644 --- a/m4/frexp.m4 +++ b/m4/frexp.m4 @@ -1,5 +1,5 @@ # frexp.m4 serial 15 -dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/fstat.m4 b/m4/fstat.m4 index 29f9b8165..14c871a8b 100644 --- a/m4/fstat.m4 +++ b/m4/fstat.m4 @@ -1,5 +1,5 @@ # fstat.m4 serial 4 -dnl Copyright (C) 2011-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/fsync.m4 b/m4/fsync.m4 index 405d43d6d..f1399de39 100644 --- a/m4/fsync.m4 +++ b/m4/fsync.m4 @@ -1,5 +1,5 @@ # fsync.m4 serial 2 -dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/func.m4 b/m4/func.m4 index f537b157d..bd429eeae 100644 --- a/m4/func.m4 +++ b/m4/func.m4 @@ -1,5 +1,5 @@ # func.m4 serial 2 -dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/getaddrinfo.m4 b/m4/getaddrinfo.m4 index 2af1e0136..f5e228471 100644 --- a/m4/getaddrinfo.m4 +++ b/m4/getaddrinfo.m4 @@ -1,5 +1,5 @@ -# getaddrinfo.m4 serial 30 -dnl Copyright (C) 2004-2016 Free Software Foundation, Inc. +# getaddrinfo.m4 serial 31 +dnl Copyright (C) 2004-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -8,7 +8,7 @@ AC_DEFUN([gl_GETADDRINFO], [ AC_REQUIRE([gl_HEADER_SYS_SOCKET])dnl for HAVE_SYS_SOCKET_H, HAVE_WINSOCK2_H AC_REQUIRE([gl_HEADER_NETDB])dnl for HAVE_NETDB_H - AC_MSG_NOTICE([checking how to do getaddrinfo, freeaddrinfo and getnameinfo]) + AC_MSG_CHECKING([how to do getaddrinfo, freeaddrinfo and getnameinfo]) GETADDRINFO_LIB= gai_saved_LIBS="$LIBS" diff --git a/m4/getlogin.m4 b/m4/getlogin.m4 index b3b2655db..c013fdd47 100644 --- a/m4/getlogin.m4 +++ b/m4/getlogin.m4 @@ -1,5 +1,5 @@ -# getlogin.m4 serial 3 -dnl Copyright (C) 2010-2016 Free Software Foundation, Inc. +# getlogin.m4 serial 5 +dnl Copyright (C) 2010-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -7,8 +7,26 @@ dnl with or without modifications, as long as this notice is preserved. AC_DEFUN([gl_FUNC_GETLOGIN], [ AC_REQUIRE([gl_UNISTD_H_DEFAULTS]) + AC_CHECK_DECLS_ONCE([getlogin]) + if test $ac_cv_have_decl_getlogin = no; then + HAVE_DECL_GETLOGIN=0 + fi AC_CHECK_FUNCS_ONCE([getlogin]) if test $ac_cv_func_getlogin = no; then HAVE_GETLOGIN=0 fi ]) + +dnl Determines the library needed by the implementation of the +dnl getlogin and getlogin_r functions. +AC_DEFUN([gl_LIB_GETLOGIN], +[ + AC_REQUIRE([AC_CANONICAL_HOST]) + case $host_os in + mingw*) + LIB_GETLOGIN='-ladvapi32' ;; + *) + LIB_GETLOGIN= ;; + esac + AC_SUBST([LIB_GETLOGIN]) +]) diff --git a/m4/gettimeofday.m4 b/m4/gettimeofday.m4 index 4ae5d63fe..4f501e5bf 100644 --- a/m4/gettimeofday.m4 +++ b/m4/gettimeofday.m4 @@ -1,6 +1,6 @@ # serial 21 -# Copyright (C) 2001-2003, 2005, 2007, 2009-2016 Free Software Foundation, Inc. +# Copyright (C) 2001-2003, 2005, 2007, 2009-2017 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/glibc21.m4 b/m4/glibc21.m4 index dafebf501..2e30ed688 100644 --- a/m4/glibc21.m4 +++ b/m4/glibc21.m4 @@ -1,5 +1,5 @@ # glibc21.m4 serial 5 -dnl Copyright (C) 2000-2002, 2004, 2008, 2010-2016 Free Software Foundation, +dnl Copyright (C) 2000-2002, 2004, 2008, 2010-2017 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index f6d36c733..f552a18c1 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -1,4 +1,4 @@ -# Copyright (C) 2002-2016 Free Software Foundation, Inc. +# Copyright (C) 2002-2017 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4 index f8454c8a0..7d9b40b79 100644 --- a/m4/gnulib-common.m4 +++ b/m4/gnulib-common.m4 @@ -1,5 +1,5 @@ # gnulib-common.m4 serial 36 -dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 9881c1b75..9380120e7 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -1,5 +1,5 @@ # DO NOT EDIT! GENERATED AUTOMATICALLY! -# Copyright (C) 2002-2016 Free Software Foundation, Inc. +# Copyright (C) 2002-2017 Free Software Foundation, Inc. # # This file is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -55,6 +55,7 @@ AC_DEFUN([gl_EARLY], # Code from module binary-io: # Code from module bind: # Code from module btowc: + # Code from module builtin-expect: # Code from module byteswap: # Code from module c-ctype: # Code from module c-strcase: @@ -133,6 +134,7 @@ AC_DEFUN([gl_EARLY], # Code from module lib-symbol-versions: # Code from module lib-symbol-visibility: # Code from module libunistring: + # Code from module limits-h: # Code from module link: # Code from module listen: # Code from module localcharset: @@ -242,6 +244,7 @@ AC_DEFUN([gl_EARLY], # Code from module wcrtomb: # Code from module wctype-h: # Code from module write: + # Code from module xalloc-oversized: # Code from module xsize: ]) @@ -341,7 +344,7 @@ AC_DEFUN([gl_INIT], AC_LIBOBJ([floor]) fi gl_MATH_MODULE_INDICATOR([floor]) - gl_FUNC_FREXP + AC_REQUIRE([gl_FUNC_FREXP]) if test $gl_func_frexp != yes; then AC_LIBOBJ([frexp]) fi @@ -372,6 +375,7 @@ AC_DEFUN([gl_INIT], AC_LIBOBJ([getlogin]) fi gl_UNISTD_MODULE_INDICATOR([getlogin]) + AC_REQUIRE([gl_LIB_GETLOGIN]) AC_REQUIRE([gl_HEADER_SYS_SOCKET]) if test "$ac_cv_header_winsock2_h" = yes; then AC_LIBOBJ([getpeername]) @@ -473,6 +477,7 @@ AC_DEFUN([gl_INIT], gl_LD_VERSION_SCRIPT gl_VISIBILITY gl_LIBUNISTRING + gl_LIMITS_H gl_FUNC_LINK if test $HAVE_LINK = 0 || test $REPLACE_LINK = 1; then AC_LIBOBJ([link]) @@ -706,6 +711,7 @@ AC_DEFUN([gl_INIT], gl_gnulib_enabled_alloca=false gl_gnulib_enabled_assure=false gl_gnulib_enabled_btowc=false + gl_gnulib_enabled_37f71b604aa9c54446783d80f42fe547=false gl_gnulib_enabled_chdir=false gl_gnulib_enabled_dup2=false gl_gnulib_enabled_43fe87a341d9b4b93c47c3ad819a5239=false @@ -779,6 +785,13 @@ AC_SUBST([LTALLOCA]) fi fi } + func_gl_gnulib_m4code_37f71b604aa9c54446783d80f42fe547 () + { + if ! $gl_gnulib_enabled_37f71b604aa9c54446783d80f42fe547; then + gl___BUILTIN_EXPECT + gl_gnulib_enabled_37f71b604aa9c54446783d80f42fe547=true + fi + } func_gl_gnulib_m4code_chdir () { if ! $gl_gnulib_enabled_chdir; then @@ -1368,9 +1381,15 @@ AC_SUBST([LTALLOCA]) if test $ac_use_included_regex = yes; then func_gl_gnulib_m4code_btowc fi + if test $ac_use_included_regex = yes; then + func_gl_gnulib_m4code_37f71b604aa9c54446783d80f42fe547 + fi if test $ac_use_included_regex = yes; then func_gl_gnulib_m4code_be453cec5eecf5731a274f2de7f2db36 fi + if test $ac_use_included_regex = yes; then + func_gl_gnulib_m4code_intprops + fi if test $ac_use_included_regex = yes; then func_gl_gnulib_m4code_mbrtowc fi @@ -1447,6 +1466,7 @@ AC_SUBST([LTALLOCA]) AM_CONDITIONAL([gl_GNULIB_ENABLED_alloca], [$gl_gnulib_enabled_alloca]) AM_CONDITIONAL([gl_GNULIB_ENABLED_assure], [$gl_gnulib_enabled_assure]) AM_CONDITIONAL([gl_GNULIB_ENABLED_btowc], [$gl_gnulib_enabled_btowc]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_37f71b604aa9c54446783d80f42fe547], [$gl_gnulib_enabled_37f71b604aa9c54446783d80f42fe547]) AM_CONDITIONAL([gl_GNULIB_ENABLED_chdir], [$gl_gnulib_enabled_chdir]) AM_CONDITIONAL([gl_GNULIB_ENABLED_dup2], [$gl_gnulib_enabled_dup2]) AM_CONDITIONAL([gl_GNULIB_ENABLED_43fe87a341d9b4b93c47c3ad819a5239], [$gl_gnulib_enabled_43fe87a341d9b4b93c47c3ad819a5239]) @@ -1677,6 +1697,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/fcntl.in.h lib/fd-hook.c lib/fd-hook.h + lib/flexmember.h lib/float+.h lib/float.c lib/float.in.h @@ -1724,6 +1745,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/itold.c lib/langinfo.in.h lib/libunistring.valgrind + lib/limits.in.h lib/link.c lib/listen.c lib/localcharset.c @@ -1854,6 +1876,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/wctype-h.c lib/wctype.in.h lib/write.c + lib/xalloc-oversized.h lib/xsize.c lib/xsize.h m4/00gnulib.m4 @@ -1862,6 +1885,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/arpa_inet_h.m4 m4/autobuild.m4 m4/btowc.m4 + m4/builtin-expect.m4 m4/byteswap.m4 m4/canonicalize.m4 m4/ceil.m4 @@ -1926,6 +1950,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/lib-link.m4 m4/lib-prefix.m4 m4/libunistring.m4 + m4/limits-h.m4 m4/link.m4 m4/localcharset.m4 m4/locale-fr.m4 diff --git a/m4/gnulib-tool.m4 b/m4/gnulib-tool.m4 index 0d2ee444b..2e2d8f6dc 100644 --- a/m4/gnulib-tool.m4 +++ b/m4/gnulib-tool.m4 @@ -1,5 +1,5 @@ # gnulib-tool.m4 serial 2 -dnl Copyright (C) 2004-2005, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2004-2005, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/hard-locale.m4 b/m4/hard-locale.m4 index 4661bfc5a..d79acd658 100644 --- a/m4/hard-locale.m4 +++ b/m4/hard-locale.m4 @@ -1,5 +1,5 @@ # hard-locale.m4 serial 8 -dnl Copyright (C) 2002-2006, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2006, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/hostent.m4 b/m4/hostent.m4 index 1b2488abc..595a68d0c 100644 --- a/m4/hostent.m4 +++ b/m4/hostent.m4 @@ -1,5 +1,5 @@ # hostent.m4 serial 2 -dnl Copyright (C) 2008, 2010-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2008, 2010-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/iconv.m4 b/m4/iconv.m4 index aa159c539..bdafc54e3 100644 --- a/m4/iconv.m4 +++ b/m4/iconv.m4 @@ -1,4 +1,4 @@ -# iconv.m4 serial 19 (gettext-0.18.2) +# iconv.m4 serial 20 dnl Copyright (C) 2000-2002, 2007-2014, 2016 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -258,14 +258,18 @@ size_t iconv(); am_cv_proto_iconv=`echo "[$]am_cv_proto_iconv" | tr -s ' ' | sed -e 's/( /(/'` AC_MSG_RESULT([ $am_cv_proto_iconv]) - AC_DEFINE_UNQUOTED([ICONV_CONST], [$am_cv_proto_iconv_arg1], - [Define as const if the declaration of iconv() needs const.]) - dnl Also substitute ICONV_CONST in the gnulib generated . - m4_ifdef([gl_ICONV_H_DEFAULTS], - [AC_REQUIRE([gl_ICONV_H_DEFAULTS]) - if test -n "$am_cv_proto_iconv_arg1"; then - ICONV_CONST="const" - fi - ]) + else + dnl When compiling GNU libiconv on a system that does not have iconv yet, + dnl pick the POSIX compliant declaration without 'const'. + am_cv_proto_iconv_arg1="" fi + AC_DEFINE_UNQUOTED([ICONV_CONST], [$am_cv_proto_iconv_arg1], + [Define as const if the declaration of iconv() needs const.]) + dnl Also substitute ICONV_CONST in the gnulib generated . + m4_ifdef([gl_ICONV_H_DEFAULTS], + [AC_REQUIRE([gl_ICONV_H_DEFAULTS]) + if test -n "$am_cv_proto_iconv_arg1"; then + ICONV_CONST="const" + fi + ]) ]) diff --git a/m4/iconv_h.m4 b/m4/iconv_h.m4 index c95ecc294..d4ac24357 100644 --- a/m4/iconv_h.m4 +++ b/m4/iconv_h.m4 @@ -1,5 +1,5 @@ # iconv_h.m4 serial 8 -dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/iconv_open-utf.m4 b/m4/iconv_open-utf.m4 index 2c1802357..4a3211cee 100644 --- a/m4/iconv_open-utf.m4 +++ b/m4/iconv_open-utf.m4 @@ -1,5 +1,5 @@ # iconv_open-utf.m4 serial 1 -dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/iconv_open.m4 b/m4/iconv_open.m4 index 54e1dc8a6..2517a5bba 100644 --- a/m4/iconv_open.m4 +++ b/m4/iconv_open.m4 @@ -1,5 +1,5 @@ # iconv_open.m4 serial 14 -dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/include_next.m4 b/m4/include_next.m4 index db0f2c079..e687e232a 100644 --- a/m4/include_next.m4 +++ b/m4/include_next.m4 @@ -1,5 +1,5 @@ # include_next.m4 serial 23 -dnl Copyright (C) 2006-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/inet_ntop.m4 b/m4/inet_ntop.m4 index 26464c34a..f4ac237ce 100644 --- a/m4/inet_ntop.m4 +++ b/m4/inet_ntop.m4 @@ -1,5 +1,5 @@ # inet_ntop.m4 serial 19 -dnl Copyright (C) 2005-2006, 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2005-2006, 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/inet_pton.m4 b/m4/inet_pton.m4 index 4f5db7149..407c29c2c 100644 --- a/m4/inet_pton.m4 +++ b/m4/inet_pton.m4 @@ -1,5 +1,5 @@ # inet_pton.m4 serial 17 -dnl Copyright (C) 2006, 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2006, 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/intmax_t.m4 b/m4/intmax_t.m4 index 9559accab..ff143e9d8 100644 --- a/m4/intmax_t.m4 +++ b/m4/intmax_t.m4 @@ -1,5 +1,5 @@ # intmax_t.m4 serial 8 -dnl Copyright (C) 1997-2004, 2006-2007, 2009-2016 Free Software Foundation, +dnl Copyright (C) 1997-2004, 2006-2007, 2009-2017 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/inttypes_h.m4 b/m4/inttypes_h.m4 index 76571199f..924030505 100644 --- a/m4/inttypes_h.m4 +++ b/m4/inttypes_h.m4 @@ -1,5 +1,5 @@ # inttypes_h.m4 serial 10 -dnl Copyright (C) 1997-2004, 2006, 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 1997-2004, 2006, 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/isfinite.m4 b/m4/isfinite.m4 index 7b9641c03..fab12be86 100644 --- a/m4/isfinite.m4 +++ b/m4/isfinite.m4 @@ -1,5 +1,5 @@ # isfinite.m4 serial 15 -dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/isinf.m4 b/m4/isinf.m4 index d062be02b..146529d9d 100644 --- a/m4/isinf.m4 +++ b/m4/isinf.m4 @@ -1,5 +1,5 @@ # isinf.m4 serial 11 -dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/isnan.m4 b/m4/isnan.m4 index 98a32f3ab..844aac279 100644 --- a/m4/isnan.m4 +++ b/m4/isnan.m4 @@ -1,5 +1,5 @@ # isnan.m4 serial 5 -dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/isnand.m4 b/m4/isnand.m4 index bcf3840db..cbe6a38e1 100644 --- a/m4/isnand.m4 +++ b/m4/isnand.m4 @@ -1,5 +1,5 @@ # isnand.m4 serial 11 -dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/isnanf.m4 b/m4/isnanf.m4 index f49d20c6d..1a0d03e63 100644 --- a/m4/isnanf.m4 +++ b/m4/isnanf.m4 @@ -1,5 +1,5 @@ # isnanf.m4 serial 14 -dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/isnanl.m4 b/m4/isnanl.m4 index 9766e4720..a42cfc075 100644 --- a/m4/isnanl.m4 +++ b/m4/isnanl.m4 @@ -1,5 +1,5 @@ # isnanl.m4 serial 19 -dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/langinfo_h.m4 b/m4/langinfo_h.m4 index edbbe762c..ea94b4ed2 100644 --- a/m4/langinfo_h.m4 +++ b/m4/langinfo_h.m4 @@ -1,5 +1,5 @@ # langinfo_h.m4 serial 7 -dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/largefile.m4 b/m4/largefile.m4 index 8bbdfaac1..790f7c0ad 100644 --- a/m4/largefile.m4 +++ b/m4/largefile.m4 @@ -1,6 +1,6 @@ # Enable large files on systems where this is not the default. -# Copyright 1992-1996, 1998-2016 Free Software Foundation, Inc. +# Copyright 1992-1996, 1998-2017 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/ld-version-script.m4 b/m4/ld-version-script.m4 index 330c2ccf0..caccec11b 100644 --- a/m4/ld-version-script.m4 +++ b/m4/ld-version-script.m4 @@ -1,5 +1,5 @@ # ld-version-script.m4 serial 4 -dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/ldexp.m4 b/m4/ldexp.m4 index 596dede4d..151a6777f 100644 --- a/m4/ldexp.m4 +++ b/m4/ldexp.m4 @@ -1,5 +1,5 @@ # ldexp.m4 serial 1 -dnl Copyright (C) 2010-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/lib-ld.m4 b/m4/lib-ld.m4 index 6209de65d..a7733e47d 100644 --- a/m4/lib-ld.m4 +++ b/m4/lib-ld.m4 @@ -1,5 +1,5 @@ # lib-ld.m4 serial 6 -dnl Copyright (C) 1996-2003, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 1996-2003, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/lib-link.m4 b/m4/lib-link.m4 index 2f518553b..1ce9a5ab3 100644 --- a/m4/lib-link.m4 +++ b/m4/lib-link.m4 @@ -1,5 +1,5 @@ # lib-link.m4 serial 26 (gettext-0.18.2) -dnl Copyright (C) 2001-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/lib-prefix.m4 b/m4/lib-prefix.m4 index 6851031d3..68a0835c6 100644 --- a/m4/lib-prefix.m4 +++ b/m4/lib-prefix.m4 @@ -1,5 +1,5 @@ # lib-prefix.m4 serial 7 (gettext-0.18) -dnl Copyright (C) 2001-2005, 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2005, 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/libunistring.m4 b/m4/libunistring.m4 index 31a610e0d..024989693 100644 --- a/m4/libunistring.m4 +++ b/m4/libunistring.m4 @@ -1,5 +1,5 @@ # libunistring.m4 serial 11 -dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/limits-h.m4 b/m4/limits-h.m4 new file mode 100644 index 000000000..443f91b4d --- /dev/null +++ b/m4/limits-h.m4 @@ -0,0 +1,31 @@ +dnl Check whether limits.h has needed features. + +dnl Copyright 2016-2017 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl From Paul Eggert. + +AC_DEFUN_ONCE([gl_LIMITS_H], +[ + gl_CHECK_NEXT_HEADERS([limits.h]) + + AC_CACHE_CHECK([whether limits.h has ULLONG_WIDTH etc.], + [gl_cv_header_limits_width], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([[#ifndef __STDC_WANT_IEC_60559_BFP_EXT__ + #define __STDC_WANT_IEC_60559_BFP_EXT__ 1 + #endif + #include + int ullw = ULLONG_WIDTH;]])], + [gl_cv_header_limits_width=yes], + [gl_cv_header_limits_width=no])]) + if test "$gl_cv_header_limits_width" = yes; then + LIMITS_H= + else + LIMITS_H=limits.h + fi + AC_SUBST([LIMITS_H]) + AM_CONDITIONAL([GL_GENERATE_LIMITS_H], [test -n "$LIMITS_H"]) +]) diff --git a/m4/link.m4 b/m4/link.m4 index 77f5a2b9c..021c30140 100644 --- a/m4/link.m4 +++ b/m4/link.m4 @@ -1,5 +1,5 @@ # link.m4 serial 8 -dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -22,6 +22,7 @@ AC_DEFUN([gl_FUNC_LINK], AC_RUN_IFELSE( [AC_LANG_PROGRAM( [[#include + #include ]], [[int result = 0; if (!link ("conftest.a", "conftest.b/")) diff --git a/m4/localcharset.m4 b/m4/localcharset.m4 index 22c311b98..0c1ff3868 100644 --- a/m4/localcharset.m4 +++ b/m4/localcharset.m4 @@ -1,5 +1,5 @@ # localcharset.m4 serial 7 -dnl Copyright (C) 2002, 2004, 2006, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2002, 2004, 2006, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/locale-fr.m4 b/m4/locale-fr.m4 index 92896a039..93d3da7d7 100644 --- a/m4/locale-fr.m4 +++ b/m4/locale-fr.m4 @@ -1,5 +1,5 @@ # locale-fr.m4 serial 17 -dnl Copyright (C) 2003, 2005-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2005-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/locale-ja.m4 b/m4/locale-ja.m4 index f222a0869..c1d1154b9 100644 --- a/m4/locale-ja.m4 +++ b/m4/locale-ja.m4 @@ -1,5 +1,5 @@ # locale-ja.m4 serial 12 -dnl Copyright (C) 2003, 2005-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2005-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/locale-zh.m4 b/m4/locale-zh.m4 index 2271f7783..14594182c 100644 --- a/m4/locale-zh.m4 +++ b/m4/locale-zh.m4 @@ -1,5 +1,5 @@ # locale-zh.m4 serial 12 -dnl Copyright (C) 2003, 2005-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2005-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/locale_h.m4 b/m4/locale_h.m4 index 563f8f81d..7426a6528 100644 --- a/m4/locale_h.m4 +++ b/m4/locale_h.m4 @@ -1,5 +1,5 @@ # locale_h.m4 serial 19 -dnl Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/localeconv.m4 b/m4/localeconv.m4 index 6e1dbf109..c287aa526 100644 --- a/m4/localeconv.m4 +++ b/m4/localeconv.m4 @@ -1,5 +1,5 @@ # localeconv.m4 serial 1 -dnl Copyright (C) 2012-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2012-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/log.m4 b/m4/log.m4 index a4401b679..90dee2403 100644 --- a/m4/log.m4 +++ b/m4/log.m4 @@ -1,5 +1,5 @@ # log.m4 serial 4 -dnl Copyright (C) 2011-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/log1p.m4 b/m4/log1p.m4 index 055aba81f..f55ac549e 100644 --- a/m4/log1p.m4 +++ b/m4/log1p.m4 @@ -1,5 +1,5 @@ # log1p.m4 serial 3 -dnl Copyright (C) 2012-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2012-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/longlong.m4 b/m4/longlong.m4 index 36d8b1242..9a3294bc2 100644 --- a/m4/longlong.m4 +++ b/m4/longlong.m4 @@ -1,5 +1,5 @@ # longlong.m4 serial 17 -dnl Copyright (C) 1999-2007, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 1999-2007, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/lstat.m4 b/m4/lstat.m4 index e143d5c8b..953c117d8 100644 --- a/m4/lstat.m4 +++ b/m4/lstat.m4 @@ -1,6 +1,6 @@ # serial 27 -# Copyright (C) 1997-2001, 2003-2016 Free Software Foundation, Inc. +# Copyright (C) 1997-2001, 2003-2017 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, diff --git a/m4/malloc.m4 b/m4/malloc.m4 index c393690e2..e1d2ec687 100644 --- a/m4/malloc.m4 +++ b/m4/malloc.m4 @@ -1,5 +1,5 @@ # malloc.m4 serial 15 -dnl Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/malloca.m4 b/m4/malloca.m4 index b368b20e5..6956baf20 100644 --- a/m4/malloca.m4 +++ b/m4/malloca.m4 @@ -1,5 +1,5 @@ # malloca.m4 serial 1 -dnl Copyright (C) 2003-2004, 2006-2007, 2009-2016 Free Software Foundation, +dnl Copyright (C) 2003-2004, 2006-2007, 2009-2017 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/math_h.m4 b/m4/math_h.m4 index 35d07ee5f..6db72ca63 100644 --- a/m4/math_h.m4 +++ b/m4/math_h.m4 @@ -1,5 +1,5 @@ -# math_h.m4 serial 114 -dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. +# math_h.m4 serial 115 +dnl Copyright (C) 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -256,11 +256,18 @@ AC_DEFUN([gl_MATH_H_DEFAULTS], HAVE_DECL_TRUNC=1; AC_SUBST([HAVE_DECL_TRUNC]) HAVE_DECL_TRUNCF=1; AC_SUBST([HAVE_DECL_TRUNCF]) HAVE_DECL_TRUNCL=1; AC_SUBST([HAVE_DECL_TRUNCL]) + REPLACE_ACOSF=0; AC_SUBST([REPLACE_ACOSF]) + REPLACE_ASINF=0; AC_SUBST([REPLACE_ASINF]) + REPLACE_ATANF=0; AC_SUBST([REPLACE_ATANF]) + REPLACE_ATAN2F=0; AC_SUBST([REPLACE_ATAN2F]) REPLACE_CBRTF=0; AC_SUBST([REPLACE_CBRTF]) REPLACE_CBRTL=0; AC_SUBST([REPLACE_CBRTL]) REPLACE_CEIL=0; AC_SUBST([REPLACE_CEIL]) REPLACE_CEILF=0; AC_SUBST([REPLACE_CEILF]) REPLACE_CEILL=0; AC_SUBST([REPLACE_CEILL]) + REPLACE_COSF=0; AC_SUBST([REPLACE_COSF]) + REPLACE_COSHF=0; AC_SUBST([REPLACE_COSHF]) + REPLACE_EXPF=0; AC_SUBST([REPLACE_EXPF]) REPLACE_EXPM1=0; AC_SUBST([REPLACE_EXPM1]) REPLACE_EXPM1F=0; AC_SUBST([REPLACE_EXPM1F]) REPLACE_EXP2=0; AC_SUBST([REPLACE_EXP2]) @@ -315,7 +322,12 @@ AC_DEFUN([gl_MATH_H_DEFAULTS], REPLACE_ROUNDL=0; AC_SUBST([REPLACE_ROUNDL]) REPLACE_SIGNBIT=0; AC_SUBST([REPLACE_SIGNBIT]) REPLACE_SIGNBIT_USING_GCC=0; AC_SUBST([REPLACE_SIGNBIT_USING_GCC]) + REPLACE_SINF=0; AC_SUBST([REPLACE_SINF]) + REPLACE_SINHF=0; AC_SUBST([REPLACE_SINHF]) + REPLACE_SQRTF=0; AC_SUBST([REPLACE_SQRTF]) REPLACE_SQRTL=0; AC_SUBST([REPLACE_SQRTL]) + REPLACE_TANF=0; AC_SUBST([REPLACE_TANF]) + REPLACE_TANHF=0; AC_SUBST([REPLACE_TANHF]) REPLACE_TRUNC=0; AC_SUBST([REPLACE_TRUNC]) REPLACE_TRUNCF=0; AC_SUBST([REPLACE_TRUNCF]) REPLACE_TRUNCL=0; AC_SUBST([REPLACE_TRUNCL]) diff --git a/m4/mathfunc.m4 b/m4/mathfunc.m4 index 0170697a7..b55ebc772 100644 --- a/m4/mathfunc.m4 +++ b/m4/mathfunc.m4 @@ -1,5 +1,5 @@ # mathfunc.m4 serial 11 -dnl Copyright (C) 2010-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mbrtowc.m4 b/m4/mbrtowc.m4 index d370fccf0..536183f4f 100644 --- a/m4/mbrtowc.m4 +++ b/m4/mbrtowc.m4 @@ -1,5 +1,5 @@ # mbrtowc.m4 serial 27 -*- coding: utf-8 -*- -dnl Copyright (C) 2001-2002, 2004-2005, 2008-2016 Free Software Foundation, +dnl Copyright (C) 2001-2002, 2004-2005, 2008-2017 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -164,7 +164,7 @@ int main () memset (&state, '\0', sizeof (mbstate_t)); if (mbrtowc (&wc, input + 1, 1, &state) == (size_t)(-2)) if (mbsinit (&state)) - return 1; + return 2; } return 0; }]])], @@ -224,7 +224,7 @@ int main () memset (&state, '\0', sizeof (mbstate_t)); if (mbrtowc (&wc, input + 3, 6, &state) != 4 && mbtowc (&wc, input + 3, 6) == 4) - return 1; + return 2; } return 0; }]])], @@ -352,7 +352,7 @@ int main () mbrtowc (&wc, NULL, 5, &state); /* Check that wc was not modified. */ if (wc != (wchar_t) 0xBADFACE) - return 1; + return 2; } return 0; }]])], @@ -539,7 +539,7 @@ int main () memset (&state, '\0', sizeof (mbstate_t)); if (mbrtowc (&wc, "", 1, &state) != 0) - return 1; + return 2; } return 0; }]])], @@ -608,7 +608,7 @@ AC_DEFUN([gl_MBRTOWC_C_LOCALE], int i; char *locale = setlocale (LC_ALL, "C"); if (! locale) - return 1; + return 2; for (i = CHAR_MIN; i <= CHAR_MAX; i++) { char c = i; @@ -616,7 +616,7 @@ AC_DEFUN([gl_MBRTOWC_C_LOCALE], mbstate_t mbs = { 0, }; size_t ss = mbrtowc (&wc, &c, 1, &mbs); if (1 < ss) - return 1; + return 3; } return 0; ]])], diff --git a/m4/mbsinit.m4 b/m4/mbsinit.m4 index 88f08367a..5904a5107 100644 --- a/m4/mbsinit.m4 +++ b/m4/mbsinit.m4 @@ -1,5 +1,5 @@ # mbsinit.m4 serial 8 -dnl Copyright (C) 2008, 2010-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2008, 2010-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mbstate_t.m4 b/m4/mbstate_t.m4 index 0a8eae254..6325cf3a4 100644 --- a/m4/mbstate_t.m4 +++ b/m4/mbstate_t.m4 @@ -1,5 +1,5 @@ # mbstate_t.m4 serial 13 -dnl Copyright (C) 2000-2002, 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2000-2002, 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mbtowc.m4 b/m4/mbtowc.m4 index e770bbf70..378a4e258 100644 --- a/m4/mbtowc.m4 +++ b/m4/mbtowc.m4 @@ -1,5 +1,5 @@ # mbtowc.m4 serial 2 -dnl Copyright (C) 2011-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/memchr.m4 b/m4/memchr.m4 index 25d32f0ec..b6ec81401 100644 --- a/m4/memchr.m4 +++ b/m4/memchr.m4 @@ -1,5 +1,5 @@ # memchr.m4 serial 12 -dnl Copyright (C) 2002-2004, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2004, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mkdir.m4 b/m4/mkdir.m4 index 574092bb2..5eec622ef 100644 --- a/m4/mkdir.m4 +++ b/m4/mkdir.m4 @@ -1,6 +1,6 @@ # serial 11 -# Copyright (C) 2001, 2003-2004, 2006, 2008-2016 Free Software Foundation, Inc. +# Copyright (C) 2001, 2003-2004, 2006, 2008-2017 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/mkostemp.m4 b/m4/mkostemp.m4 index 1f44a0390..337f17b5c 100644 --- a/m4/mkostemp.m4 +++ b/m4/mkostemp.m4 @@ -1,5 +1,5 @@ # mkostemp.m4 serial 2 -dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mktime.m4 b/m4/mktime.m4 index 23cad732f..d594ddc58 100644 --- a/m4/mktime.m4 +++ b/m4/mktime.m4 @@ -1,5 +1,5 @@ # serial 27 -dnl Copyright (C) 2002-2003, 2005-2007, 2009-2016 Free Software Foundation, +dnl Copyright (C) 2002-2003, 2005-2007, 2009-2017 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/mmap-anon.m4 b/m4/mmap-anon.m4 index 853c89dc9..263687d1a 100644 --- a/m4/mmap-anon.m4 +++ b/m4/mmap-anon.m4 @@ -1,5 +1,5 @@ # mmap-anon.m4 serial 10 -dnl Copyright (C) 2005, 2007, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2005, 2007, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mode_t.m4 b/m4/mode_t.m4 index 0cd40dba4..75d372a4a 100644 --- a/m4/mode_t.m4 +++ b/m4/mode_t.m4 @@ -1,5 +1,5 @@ # mode_t.m4 serial 2 -dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/msvc-inval.m4 b/m4/msvc-inval.m4 index f5e4c8930..332437511 100644 --- a/m4/msvc-inval.m4 +++ b/m4/msvc-inval.m4 @@ -1,5 +1,5 @@ # msvc-inval.m4 serial 1 -dnl Copyright (C) 2011-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/msvc-nothrow.m4 b/m4/msvc-nothrow.m4 index 58f5c0bc2..3014661f0 100644 --- a/m4/msvc-nothrow.m4 +++ b/m4/msvc-nothrow.m4 @@ -1,5 +1,5 @@ # msvc-nothrow.m4 serial 1 -dnl Copyright (C) 2011-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/multiarch.m4 b/m4/multiarch.m4 index 43b5d0575..30006cb33 100644 --- a/m4/multiarch.m4 +++ b/m4/multiarch.m4 @@ -1,5 +1,5 @@ # multiarch.m4 serial 7 -dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/netdb_h.m4 b/m4/netdb_h.m4 index 4e5206ceb..3a34d2536 100644 --- a/m4/netdb_h.m4 +++ b/m4/netdb_h.m4 @@ -1,5 +1,5 @@ # netdb_h.m4 serial 11 -dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/netinet_in_h.m4 b/m4/netinet_in_h.m4 index 93dcc6894..f93665702 100644 --- a/m4/netinet_in_h.m4 +++ b/m4/netinet_in_h.m4 @@ -1,5 +1,5 @@ # netinet_in_h.m4 serial 5 -dnl Copyright (C) 2006-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/nl_langinfo.m4 b/m4/nl_langinfo.m4 index a2f7196eb..16de8de30 100644 --- a/m4/nl_langinfo.m4 +++ b/m4/nl_langinfo.m4 @@ -1,5 +1,5 @@ # nl_langinfo.m4 serial 5 -dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/nocrash.m4 b/m4/nocrash.m4 index d8dd8f13a..2c2c5fb45 100644 --- a/m4/nocrash.m4 +++ b/m4/nocrash.m4 @@ -1,5 +1,5 @@ # nocrash.m4 serial 4 -dnl Copyright (C) 2005, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2005, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/nproc.m4 b/m4/nproc.m4 index fead2346b..e1ca5b397 100644 --- a/m4/nproc.m4 +++ b/m4/nproc.m4 @@ -1,5 +1,5 @@ -# nproc.m4 serial 4 -dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. +# nproc.m4 serial 5 +dnl Copyright (C) 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -40,7 +40,8 @@ AC_DEFUN([gl_PREREQ_NPROC], [gl_cv_func_sched_getaffinity3], [AC_COMPILE_IFELSE( [AC_LANG_PROGRAM( - [[#include ]], + [[#include + #include ]], [[sched_getaffinity (0, 0, (cpu_set_t *) 0);]])], [gl_cv_func_sched_getaffinity3=yes], [gl_cv_func_sched_getaffinity3=no]) diff --git a/m4/off_t.m4 b/m4/off_t.m4 index 282751b47..92c45ef78 100644 --- a/m4/off_t.m4 +++ b/m4/off_t.m4 @@ -1,5 +1,5 @@ # off_t.m4 serial 1 -dnl Copyright (C) 2012-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2012-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/open.m4 b/m4/open.m4 index 53d30381d..2a869dc6b 100644 --- a/m4/open.m4 +++ b/m4/open.m4 @@ -1,5 +1,5 @@ # open.m4 serial 14 -dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/pathmax.m4 b/m4/pathmax.m4 index 6f8e59a1a..c6c9f24d0 100644 --- a/m4/pathmax.m4 +++ b/m4/pathmax.m4 @@ -1,5 +1,5 @@ # pathmax.m4 serial 10 -dnl Copyright (C) 2002-2003, 2005-2006, 2009-2016 Free Software Foundation, +dnl Copyright (C) 2002-2003, 2005-2006, 2009-2017 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/pipe.m4 b/m4/pipe.m4 index 0fe69755f..c35b32c50 100644 --- a/m4/pipe.m4 +++ b/m4/pipe.m4 @@ -1,5 +1,5 @@ # pipe.m4 serial 2 -dnl Copyright (C) 2010-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/pipe2.m4 b/m4/pipe2.m4 index c09fceebb..7393343c5 100644 --- a/m4/pipe2.m4 +++ b/m4/pipe2.m4 @@ -1,5 +1,5 @@ # pipe2.m4 serial 2 -dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/poll.m4 b/m4/poll.m4 index edeaaeb8a..5706ab514 100644 --- a/m4/poll.m4 +++ b/m4/poll.m4 @@ -1,5 +1,5 @@ # poll.m4 serial 17 -dnl Copyright (c) 2003, 2005-2007, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (c) 2003, 2005-2007, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/poll_h.m4 b/m4/poll_h.m4 index 85699e01b..b3d6dab5a 100644 --- a/m4/poll_h.m4 +++ b/m4/poll_h.m4 @@ -1,5 +1,5 @@ # poll_h.m4 serial 2 -dnl Copyright (C) 2010-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/printf.m4 b/m4/printf.m4 index e495e0cbc..a44ac66b8 100644 --- a/m4/printf.m4 +++ b/m4/printf.m4 @@ -1,5 +1,5 @@ # printf.m4 serial 52 -dnl Copyright (C) 2003, 2007-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -38,6 +38,8 @@ int main () if (sprintf (buf, "%ju %d", (uintmax_t) 12345671, 33, 44, 55) < 0 || strcmp (buf, "12345671 33") != 0) result |= 1; +#else + result |= 1; #endif buf[0] = '\0'; if (sprintf (buf, "%zu %d", (size_t) 12345672, 33, 44, 55) < 0 diff --git a/m4/putenv.m4 b/m4/putenv.m4 index c3c30d845..a8e3ab33d 100644 --- a/m4/putenv.m4 +++ b/m4/putenv.m4 @@ -1,5 +1,5 @@ # putenv.m4 serial 20 -dnl Copyright (C) 2002-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/raise.m4 b/m4/raise.m4 index 71c1f4c37..28c2e0b5c 100644 --- a/m4/raise.m4 +++ b/m4/raise.m4 @@ -1,5 +1,5 @@ # raise.m4 serial 3 -dnl Copyright (C) 2011-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/read.m4 b/m4/read.m4 index 5a18c11d0..36249abdc 100644 --- a/m4/read.m4 +++ b/m4/read.m4 @@ -1,5 +1,5 @@ # read.m4 serial 4 -dnl Copyright (C) 2011-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/readlink.m4 b/m4/readlink.m4 index ede0378b4..d3ba0ad42 100644 --- a/m4/readlink.m4 +++ b/m4/readlink.m4 @@ -1,5 +1,5 @@ # readlink.m4 serial 12 -dnl Copyright (C) 2003, 2007, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2007, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/regex.m4 b/m4/regex.m4 index abfd262de..61ff09872 100644 --- a/m4/regex.m4 +++ b/m4/regex.m4 @@ -1,6 +1,6 @@ # serial 66 -# Copyright (C) 1996-2001, 2003-2016 Free Software Foundation, Inc. +# Copyright (C) 1996-2001, 2003-2017 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, diff --git a/m4/rename.m4 b/m4/rename.m4 index fbcc758d5..7c3ffe7c2 100644 --- a/m4/rename.m4 +++ b/m4/rename.m4 @@ -1,6 +1,6 @@ # serial 26 -# Copyright (C) 2001, 2003, 2005-2006, 2009-2016 Free Software Foundation, Inc. +# Copyright (C) 2001, 2003, 2005-2006, 2009-2017 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/rmdir.m4 b/m4/rmdir.m4 index ebb3b5db1..f585c2769 100644 --- a/m4/rmdir.m4 +++ b/m4/rmdir.m4 @@ -1,5 +1,5 @@ # rmdir.m4 serial 13 -dnl Copyright (C) 2002, 2005, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2002, 2005, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/round.m4 b/m4/round.m4 index 35ffa40ee..45b7df459 100644 --- a/m4/round.m4 +++ b/m4/round.m4 @@ -1,5 +1,5 @@ # round.m4 serial 16 -dnl Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/safe-read.m4 b/m4/safe-read.m4 index 2221682ef..022bb654a 100644 --- a/m4/safe-read.m4 +++ b/m4/safe-read.m4 @@ -1,5 +1,5 @@ # safe-read.m4 serial 6 -dnl Copyright (C) 2002-2003, 2005-2006, 2009-2016 Free Software Foundation, +dnl Copyright (C) 2002-2003, 2005-2006, 2009-2017 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/safe-write.m4 b/m4/safe-write.m4 index a99fb1f10..09a2226ef 100644 --- a/m4/safe-write.m4 +++ b/m4/safe-write.m4 @@ -1,5 +1,5 @@ # safe-write.m4 serial 4 -dnl Copyright (C) 2002, 2005-2006, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2002, 2005-2006, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/secure_getenv.m4 b/m4/secure_getenv.m4 index 398317360..6bd4afd9c 100644 --- a/m4/secure_getenv.m4 +++ b/m4/secure_getenv.m4 @@ -1,5 +1,5 @@ # Look up an environment variable more securely. -dnl Copyright 2013-2016 Free Software Foundation, Inc. +dnl Copyright 2013-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/select.m4 b/m4/select.m4 index d19365541..c7844bc8e 100644 --- a/m4/select.m4 +++ b/m4/select.m4 @@ -1,5 +1,5 @@ # select.m4 serial 8 -dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/servent.m4 b/m4/servent.m4 index 182e7f627..89331e23a 100644 --- a/m4/servent.m4 +++ b/m4/servent.m4 @@ -1,5 +1,5 @@ # servent.m4 serial 2 -dnl Copyright (C) 2008, 2010-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2008, 2010-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/setenv.m4 b/m4/setenv.m4 index 5d49aba60..005aa8cfe 100644 --- a/m4/setenv.m4 +++ b/m4/setenv.m4 @@ -1,5 +1,5 @@ # setenv.m4 serial 26 -dnl Copyright (C) 2001-2004, 2006-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2004, 2006-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/signal_h.m4 b/m4/signal_h.m4 index bcfd7b4be..eaf5ce98e 100644 --- a/m4/signal_h.m4 +++ b/m4/signal_h.m4 @@ -1,5 +1,5 @@ # signal_h.m4 serial 18 -dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/signbit.m4 b/m4/signbit.m4 index e42f18319..9d2b0a8db 100644 --- a/m4/signbit.m4 +++ b/m4/signbit.m4 @@ -1,5 +1,5 @@ # signbit.m4 serial 13 -dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/size_max.m4 b/m4/size_max.m4 index de69025d6..05ad1b602 100644 --- a/m4/size_max.m4 +++ b/m4/size_max.m4 @@ -1,5 +1,5 @@ # size_max.m4 serial 10 -dnl Copyright (C) 2003, 2005-2006, 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2005-2006, 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/snprintf.m4 b/m4/snprintf.m4 index f876b5599..e5155f798 100644 --- a/m4/snprintf.m4 +++ b/m4/snprintf.m4 @@ -1,5 +1,5 @@ -# snprintf.m4 serial 6 -dnl Copyright (C) 2002-2004, 2007-2016 Free Software Foundation, Inc. +# snprintf.m4 serial 7 +dnl Copyright (C) 2002-2004, 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -46,6 +46,14 @@ AC_DEFUN([gl_REPLACE_SNPRINTF], AC_LIBOBJ([snprintf]) if test $ac_cv_func_snprintf = yes; then REPLACE_SNPRINTF=1 + else + AC_CHECK_DECLS_ONCE([snprintf]) + if test $ac_cv_have_decl_snprintf = yes; then + dnl If the function is declared but does not appear to exist, it may be + dnl defined as an inline function. In order to avoid a conflict, we have + dnl to define rpl_snprintf, not snprintf. + REPLACE_SNPRINTF=1 + fi fi gl_PREREQ_SNPRINTF ]) diff --git a/m4/socketlib.m4 b/m4/socketlib.m4 index 5da64fcac..c708fd260 100644 --- a/m4/socketlib.m4 +++ b/m4/socketlib.m4 @@ -1,5 +1,5 @@ # socketlib.m4 serial 1 -dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sockets.m4 b/m4/sockets.m4 index 7e77a62e8..0ef23bc32 100644 --- a/m4/sockets.m4 +++ b/m4/sockets.m4 @@ -1,5 +1,5 @@ # sockets.m4 serial 7 -dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/socklen.m4 b/m4/socklen.m4 index 634c43a35..0a62f49d6 100644 --- a/m4/socklen.m4 +++ b/m4/socklen.m4 @@ -1,5 +1,5 @@ # socklen.m4 serial 10 -dnl Copyright (C) 2005-2007, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2005-2007, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sockpfaf.m4 b/m4/sockpfaf.m4 index dce8b8f01..c2e258215 100644 --- a/m4/sockpfaf.m4 +++ b/m4/sockpfaf.m4 @@ -1,5 +1,5 @@ # sockpfaf.m4 serial 8 -dnl Copyright (C) 2004, 2006, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2004, 2006, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/ssize_t.m4 b/m4/ssize_t.m4 index 3e7b9e6e0..66ba9d4ea 100644 --- a/m4/ssize_t.m4 +++ b/m4/ssize_t.m4 @@ -1,5 +1,5 @@ # ssize_t.m4 serial 5 (gettext-0.18.2) -dnl Copyright (C) 2001-2003, 2006, 2010-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2001-2003, 2006, 2010-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/stat-time.m4 b/m4/stat-time.m4 index 231cb7403..4017fc9d7 100644 --- a/m4/stat-time.m4 +++ b/m4/stat-time.m4 @@ -1,6 +1,6 @@ # Checks for stat-related time functions. -# Copyright (C) 1998-1999, 2001, 2003, 2005-2007, 2009-2016 Free Software +# Copyright (C) 1998-1999, 2001, 2003, 2005-2007, 2009-2017 Free Software # Foundation, Inc. # This file is free software; the Free Software Foundation diff --git a/m4/stat.m4 b/m4/stat.m4 index a794975de..9ff77df9e 100644 --- a/m4/stat.m4 +++ b/m4/stat.m4 @@ -1,6 +1,6 @@ # serial 11 -# Copyright (C) 2009-2016 Free Software Foundation, Inc. +# Copyright (C) 2009-2017 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, diff --git a/m4/stdalign.m4 b/m4/stdalign.m4 index 49980cd63..3a1265824 100644 --- a/m4/stdalign.m4 +++ b/m4/stdalign.m4 @@ -1,6 +1,6 @@ # Check for stdalign.h that conforms to C11. -dnl Copyright 2011-2016 Free Software Foundation, Inc. +dnl Copyright 2011-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/stdbool.m4 b/m4/stdbool.m4 index a55615318..d36812336 100644 --- a/m4/stdbool.m4 +++ b/m4/stdbool.m4 @@ -1,11 +1,11 @@ # Check for stdbool.h that conforms to C99. -dnl Copyright (C) 2002-2006, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2006, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. -#serial 6 +#serial 7 # Prepare for substituting if it is not supported. @@ -44,7 +44,10 @@ AC_DEFUN([AC_CHECK_HEADER_STDBOOL], [[ #include - #if __cplusplus < 201103 + #ifdef __cplusplus + typedef bool Bool; + #else + typedef _Bool Bool; #ifndef bool "error: bool is not defined" #endif @@ -66,37 +69,38 @@ AC_DEFUN([AC_CHECK_HEADER_STDBOOL], "error: __bool_true_false_are_defined is not defined" #endif - struct s { _Bool s: 1; _Bool t; } s; + struct s { Bool s: 1; Bool t; bool u: 1; bool v; } s; char a[true == 1 ? 1 : -1]; char b[false == 0 ? 1 : -1]; char c[__bool_true_false_are_defined == 1 ? 1 : -1]; char d[(bool) 0.5 == true ? 1 : -1]; /* See body of main program for 'e'. */ - char f[(_Bool) 0.0 == false ? 1 : -1]; + char f[(Bool) 0.0 == false ? 1 : -1]; char g[true]; - char h[sizeof (_Bool)]; + char h[sizeof (Bool)]; char i[sizeof s.t]; enum { j = false, k = true, l = false * true, m = true * 256 }; /* The following fails for HP aC++/ANSI C B3910B A.05.55 [Dec 04 2003]. */ - _Bool n[m]; + Bool n[m]; char o[sizeof n == m * sizeof n[0] ? 1 : -1]; - char p[-1 - (_Bool) 0 < 0 && -1 - (bool) 0 < 0 ? 1 : -1]; + char p[-1 - (Bool) 0 < 0 && -1 - (bool) 0 < 0 ? 1 : -1]; /* Catch a bug in an HP-UX C compiler. See http://gcc.gnu.org/ml/gcc-patches/2003-12/msg02303.html http://lists.gnu.org/archive/html/bug-coreutils/2005-11/msg00161.html */ - _Bool q = true; - _Bool *pq = &q; + Bool q = true; + Bool *pq = &q; + bool *qq = &q; ]], [[ bool e = &s; - *pq |= q; - *pq |= ! q; + *pq |= q; *pq |= ! q; + *qq |= q; *qq |= ! q; /* Refer to every declared value, to avoid compiler optimizations. */ return (!a + !b + !c + !d + !e + !f + !g + !h + !i + !!j + !k + !!l - + !m + !n + !o + !p + !q + !pq); + + !m + !n + !o + !p + !q + !pq + !qq); ]])], [ac_cv_header_stdbool_h=yes], [ac_cv_header_stdbool_h=no])]) diff --git a/m4/stddef_h.m4 b/m4/stddef_h.m4 index c045c65f9..f45def101 100644 --- a/m4/stddef_h.m4 +++ b/m4/stddef_h.m4 @@ -1,6 +1,6 @@ dnl A placeholder for , for platforms that have issues. # stddef_h.m4 serial 5 -dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/stdint.m4 b/m4/stdint.m4 index 0b4b9060d..4ac854d51 100644 --- a/m4/stdint.m4 +++ b/m4/stdint.m4 @@ -1,5 +1,5 @@ -# stdint.m4 serial 44 -dnl Copyright (C) 2001-2016 Free Software Foundation, Inc. +# stdint.m4 serial 50 +dnl Copyright (C) 2001-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -11,6 +11,9 @@ AC_DEFUN_ONCE([gl_STDINT_H], [ AC_PREREQ([2.59])dnl + AC_REQUIRE([gl_LIMITS_H]) + AC_REQUIRE([gt_TYPE_WINT_T]) + dnl Check for long long int and unsigned long long int. AC_REQUIRE([AC_TYPE_LONG_LONG_INT]) if test $ac_cv_type_long_long_int = yes; then @@ -152,6 +155,15 @@ uintptr_t h = UINTPTR_MAX; intmax_t i = INTMAX_MAX; uintmax_t j = UINTMAX_MAX; +/* Check that SIZE_MAX has the correct type, if possible. */ +#if 201112 <= __STDC_VERSION__ +int k = _Generic (SIZE_MAX, size_t: 0); +#elif (2 <= __GNUC__ || defined __IBM__TYPEOF__ \ + || (0x5110 <= __SUNPRO_C && !__STDC__)) +extern size_t k; +extern __typeof__ (SIZE_MAX) k; +#endif + #include /* for CHAR_BIT */ #define TYPE_MINIMUM(t) \ ((t) ((t) 0 < (t) -1 ? (t) 0 : ~ TYPE_MAXIMUM (t))) @@ -282,14 +294,20 @@ static const char *macro_values[] = ]) ]) fi + + HAVE_C99_STDINT_H=0 + HAVE_SYS_BITYPES_H=0 + HAVE_SYS_INTTYPES_H=0 + STDINT_H=stdint.h if test "$gl_cv_header_working_stdint_h" = yes; then + HAVE_C99_STDINT_H=1 dnl Now see whether the system works without dnl __STDC_CONSTANT_MACROS/__STDC_LIMIT_MACROS defined. AC_CACHE_CHECK([whether stdint.h predates C++11], [gl_cv_header_stdint_predates_cxx11_h], [gl_cv_header_stdint_predates_cxx11_h=yes AC_COMPILE_IFELSE([ - AC_LANG_PROGRAM([[ + AC_LANG_PROGRAM([[ #define _GL_JUST_INCLUDE_SYSTEM_STDINT_H 1 /* work if build isn't clean */ #include ] @@ -306,27 +324,44 @@ int32_t i32 = INT32_C (0x7fffffff); AC_DEFINE([__STDC_LIMIT_MACROS], [1], [Define to 1 if the system predates C++11.]) fi - STDINT_H= + AC_CACHE_CHECK([whether stdint.h has UINTMAX_WIDTH etc.], + [gl_cv_header_stdint_width], + [gl_cv_header_stdint_width=no + AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([[ + /* Work if build is not clean. */ + #define _GL_JUST_INCLUDE_SYSTEM_STDINT_H 1 + #ifndef __STDC_WANT_IEC_60559_BFP_EXT__ + #define __STDC_WANT_IEC_60559_BFP_EXT__ 1 + #endif + #include + ]gl_STDINT_INCLUDES[ + int iw = UINTMAX_WIDTH; + ]])], + [gl_cv_header_stdint_width=yes])]) + if test "$gl_cv_header_stdint_width" = yes; then + STDINT_H= + fi else dnl Check for , and for dnl (used in Linux libc4 >= 4.6.7 and libc5). AC_CHECK_HEADERS([sys/inttypes.h sys/bitypes.h]) if test $ac_cv_header_sys_inttypes_h = yes; then HAVE_SYS_INTTYPES_H=1 - else - HAVE_SYS_INTTYPES_H=0 fi - AC_SUBST([HAVE_SYS_INTTYPES_H]) if test $ac_cv_header_sys_bitypes_h = yes; then HAVE_SYS_BITYPES_H=1 - else - HAVE_SYS_BITYPES_H=0 fi - AC_SUBST([HAVE_SYS_BITYPES_H]) - gl_STDINT_TYPE_PROPERTIES - STDINT_H=stdint.h fi + + dnl The substitute stdint.h needs the substitute limit.h's _GL_INTEGER_WIDTH. + LIMITS_H=limits.h + AM_CONDITIONAL([GL_GENERATE_LIMITS_H], [test -n "$LIMITS_H"]) + + AC_SUBST([HAVE_C99_STDINT_H]) + AC_SUBST([HAVE_SYS_BITYPES_H]) + AC_SUBST([HAVE_SYS_INTTYPES_H]) AC_SUBST([STDINT_H]) AM_CONDITIONAL([GL_GENERATE_STDINT_H], [test -n "$STDINT_H"]) ]) @@ -494,7 +529,7 @@ AC_DEFUN([gl_STDINT_TYPE_PROPERTIES], dnl requirement that wint_t is "unchanged by default argument promotions". dnl In this case gnulib's and override wint_t. dnl Set the variable BITSIZEOF_WINT_T accordingly. - if test $BITSIZEOF_WINT_T -lt 32; then + if test $GNULIB_OVERRIDES_WINT_T = 1; then BITSIZEOF_WINT_T=32 fi ]) @@ -504,8 +539,3 @@ dnl Remove this when we can assume autoconf >= 2.61. m4_ifdef([AC_COMPUTE_INT], [], [ AC_DEFUN([AC_COMPUTE_INT], [_AC_COMPUTE_INT([$2],[$1],[$3],[$4])]) ]) - -# Hey Emacs! -# Local Variables: -# indent-tabs-mode: nil -# End: diff --git a/m4/stdint_h.m4 b/m4/stdint_h.m4 index f823b94c3..786eaa3c9 100644 --- a/m4/stdint_h.m4 +++ b/m4/stdint_h.m4 @@ -1,5 +1,5 @@ # stdint_h.m4 serial 9 -dnl Copyright (C) 1997-2004, 2006, 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 1997-2004, 2006, 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/stdio_h.m4 b/m4/stdio_h.m4 index 0e387585d..9ffbb852e 100644 --- a/m4/stdio_h.m4 +++ b/m4/stdio_h.m4 @@ -1,14 +1,18 @@ -# stdio_h.m4 serial 46 -dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. +# stdio_h.m4 serial 48 +dnl Copyright (C) 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. AC_DEFUN([gl_STDIO_H], [ - dnl For __USE_MINGW_ANSI_STDIO - AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) - + AH_VERBATIM([MINGW_ANSI_STDIO], +[/* Use GNU style printf and scanf. */ +#ifndef __USE_MINGW_ANSI_STDIO +# undef __USE_MINGW_ANSI_STDIO +#endif +]) + AC_DEFINE([__USE_MINGW_ANSI_STDIO]) AC_REQUIRE([gl_STDIO_H_DEFAULTS]) gl_NEXT_HEADERS([stdio.h]) diff --git a/m4/stdlib_h.m4 b/m4/stdlib_h.m4 index 19107c419..110fe2d1a 100644 --- a/m4/stdlib_h.m4 +++ b/m4/stdlib_h.m4 @@ -1,5 +1,5 @@ -# stdlib_h.m4 serial 42 -dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. +# stdlib_h.m4 serial 43 +dnl Copyright (C) 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -21,7 +21,7 @@ AC_DEFUN([gl_STDLIB_H], #endif ]], [_Exit atoll canonicalize_file_name getloadavg getsubopt grantpt initstate initstate_r mkdtemp mkostemp mkostemps mkstemp mkstemps - posix_openpt ptsname ptsname_r random random_r realpath rpmatch + posix_openpt ptsname ptsname_r qsort_r random random_r realpath rpmatch secure_getenv setenv setstate setstate_r srandom srandom_r strtod strtoll strtoull unlockpt unsetenv]) ]) @@ -85,6 +85,7 @@ AC_DEFUN([gl_STDLIB_H_DEFAULTS], HAVE_POSIX_OPENPT=1; AC_SUBST([HAVE_POSIX_OPENPT]) HAVE_PTSNAME=1; AC_SUBST([HAVE_PTSNAME]) HAVE_PTSNAME_R=1; AC_SUBST([HAVE_PTSNAME_R]) + HAVE_QSORT_R=1; AC_SUBST([HAVE_QSORT_R]) HAVE_RANDOM=1; AC_SUBST([HAVE_RANDOM]) HAVE_RANDOM_H=1; AC_SUBST([HAVE_RANDOM_H]) HAVE_RANDOM_R=1; AC_SUBST([HAVE_RANDOM_R]) diff --git a/m4/strdup.m4 b/m4/strdup.m4 index ff7060abd..a92dbd63b 100644 --- a/m4/strdup.m4 +++ b/m4/strdup.m4 @@ -1,6 +1,6 @@ # strdup.m4 serial 13 -dnl Copyright (C) 2002-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, diff --git a/m4/strftime.m4 b/m4/strftime.m4 index 9598e7272..3a5db9b4e 100644 --- a/m4/strftime.m4 +++ b/m4/strftime.m4 @@ -1,6 +1,6 @@ # serial 33 -# Copyright (C) 1996-1997, 1999-2007, 2009-2016 Free Software Foundation, Inc. +# Copyright (C) 1996-1997, 1999-2007, 2009-2017 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, diff --git a/m4/string_h.m4 b/m4/string_h.m4 index 0c5ec6f9a..3d2ad2219 100644 --- a/m4/string_h.m4 +++ b/m4/string_h.m4 @@ -1,6 +1,6 @@ # Configure a GNU-like replacement for . -# Copyright (C) 2007-2016 Free Software Foundation, Inc. +# Copyright (C) 2007-2017 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_file_h.m4 b/m4/sys_file_h.m4 index cacc625a0..631757211 100644 --- a/m4/sys_file_h.m4 +++ b/m4/sys_file_h.m4 @@ -1,7 +1,7 @@ # Configure a replacement for . # serial 6 -# Copyright (C) 2008-2016 Free Software Foundation, Inc. +# Copyright (C) 2008-2017 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_select_h.m4 b/m4/sys_select_h.m4 index 23526e5f5..4ec28009d 100644 --- a/m4/sys_select_h.m4 +++ b/m4/sys_select_h.m4 @@ -1,5 +1,5 @@ # sys_select_h.m4 serial 20 -dnl Copyright (C) 2006-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_socket_h.m4 b/m4/sys_socket_h.m4 index ae500c760..3ecbe7c02 100644 --- a/m4/sys_socket_h.m4 +++ b/m4/sys_socket_h.m4 @@ -1,5 +1,5 @@ # sys_socket_h.m4 serial 23 -dnl Copyright (C) 2005-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2005-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_stat_h.m4 b/m4/sys_stat_h.m4 index 3d43b6f5e..1e34ac40d 100644 --- a/m4/sys_stat_h.m4 +++ b/m4/sys_stat_h.m4 @@ -1,5 +1,5 @@ # sys_stat_h.m4 serial 28 -*- Autoconf -*- -dnl Copyright (C) 2006-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_time_h.m4 b/m4/sys_time_h.m4 index 3061a9c18..e622dbe9a 100644 --- a/m4/sys_time_h.m4 +++ b/m4/sys_time_h.m4 @@ -1,7 +1,7 @@ # Configure a replacement for . # serial 8 -# Copyright (C) 2007, 2009-2016 Free Software Foundation, Inc. +# Copyright (C) 2007, 2009-2017 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_times_h.m4 b/m4/sys_times_h.m4 index e472e717a..078e5238c 100644 --- a/m4/sys_times_h.m4 +++ b/m4/sys_times_h.m4 @@ -1,7 +1,7 @@ # Configure a replacement for . # serial 8 -# Copyright (C) 2008-2016 Free Software Foundation, Inc. +# Copyright (C) 2008-2017 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/sys_types_h.m4 b/m4/sys_types_h.m4 index b0aabb478..2eb4e9e44 100644 --- a/m4/sys_types_h.m4 +++ b/m4/sys_types_h.m4 @@ -1,5 +1,5 @@ -# sys_types_h.m4 serial 5 -dnl Copyright (C) 2011-2016 Free Software Foundation, Inc. +# sys_types_h.m4 serial 6 +dnl Copyright (C) 2011-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -22,3 +22,28 @@ AC_DEFUN_ONCE([gl_SYS_TYPES_H], AC_DEFUN([gl_SYS_TYPES_H_DEFAULTS], [ ]) + +# This works around a buggy version in autoconf <= 2.69. +# See + +m4_version_prereq([2.70], [], [ + +# This is taken from the following Autoconf patch: +# http://git.sv.gnu.org/cgit/autoconf.git/commit/?id=e17a30e98 + +m4_undefine([AC_HEADER_MAJOR]) +AC_DEFUN([AC_HEADER_MAJOR], +[AC_CHECK_HEADERS_ONCE([sys/types.h]) +AC_CHECK_HEADER([sys/mkdev.h], + [AC_DEFINE([MAJOR_IN_MKDEV], [1], + [Define to 1 if `major', `minor', and `makedev' are declared in + .])]) +if test $ac_cv_header_sys_mkdev_h = no; then + AC_CHECK_HEADER([sys/sysmacros.h], + [AC_DEFINE([MAJOR_IN_SYSMACROS], [1], + [Define to 1 if `major', `minor', and `makedev' are declared in + .])]) +fi +]) + +]) diff --git a/m4/sys_uio_h.m4 b/m4/sys_uio_h.m4 index d4d967fd5..68ef08848 100644 --- a/m4/sys_uio_h.m4 +++ b/m4/sys_uio_h.m4 @@ -1,5 +1,5 @@ # sys_uio_h.m4 serial 1 -dnl Copyright (C) 2011-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2011-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/tempname.m4 b/m4/tempname.m4 index acf4c8d07..a59f4c086 100644 --- a/m4/tempname.m4 +++ b/m4/tempname.m4 @@ -1,6 +1,6 @@ #serial 5 -# Copyright (C) 2006-2007, 2009-2016 Free Software Foundation, Inc. +# Copyright (C) 2006-2007, 2009-2017 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/time_h.m4 b/m4/time_h.m4 index eb2a631e2..b92567875 100644 --- a/m4/time_h.m4 +++ b/m4/time_h.m4 @@ -1,6 +1,6 @@ # Configure a more-standard replacement for . -# Copyright (C) 2000-2001, 2003-2007, 2009-2016 Free Software Foundation, Inc. +# Copyright (C) 2000-2001, 2003-2007, 2009-2017 Free Software Foundation, Inc. # serial 9 diff --git a/m4/time_r.m4 b/m4/time_r.m4 index 21b4a2cc1..3e24ccb2e 100644 --- a/m4/time_r.m4 +++ b/m4/time_r.m4 @@ -1,6 +1,6 @@ dnl Reentrant time functions: localtime_r, gmtime_r. -dnl Copyright (C) 2003, 2006-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2006-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/time_rz.m4 b/m4/time_rz.m4 index 9b1db1b24..79060e00f 100644 --- a/m4/time_rz.m4 +++ b/m4/time_rz.m4 @@ -1,6 +1,6 @@ dnl Time zone functions: tzalloc, localtime_rz, etc. -dnl Copyright (C) 2015-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2015-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/timegm.m4 b/m4/timegm.m4 index 752aa43d7..510e25ab4 100644 --- a/m4/timegm.m4 +++ b/m4/timegm.m4 @@ -1,5 +1,5 @@ # timegm.m4 serial 11 -dnl Copyright (C) 2003, 2007, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2003, 2007, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/times.m4 b/m4/times.m4 index ad44c5c7f..57570de43 100644 --- a/m4/times.m4 +++ b/m4/times.m4 @@ -1,5 +1,5 @@ # times.m4 serial 2 -dnl Copyright (C) 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/tm_gmtoff.m4 b/m4/tm_gmtoff.m4 index ce0671fd1..32db008d9 100644 --- a/m4/tm_gmtoff.m4 +++ b/m4/tm_gmtoff.m4 @@ -1,5 +1,5 @@ # tm_gmtoff.m4 serial 3 -dnl Copyright (C) 2002, 2009-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2002, 2009-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/trunc.m4 b/m4/trunc.m4 index 4759b47f2..a070d7828 100644 --- a/m4/trunc.m4 +++ b/m4/trunc.m4 @@ -1,5 +1,5 @@ # trunc.m4 serial 9 -dnl Copyright (C) 2007, 2010-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007, 2010-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/unistd_h.m4 b/m4/unistd_h.m4 index 544dadb41..25aef19ec 100644 --- a/m4/unistd_h.m4 +++ b/m4/unistd_h.m4 @@ -1,5 +1,5 @@ -# unistd_h.m4 serial 68 -dnl Copyright (C) 2006-2016 Free Software Foundation, Inc. +# unistd_h.m4 serial 69 +dnl Copyright (C) 2006-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -145,6 +145,7 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS], HAVE_DECL_FCHDIR=1; AC_SUBST([HAVE_DECL_FCHDIR]) HAVE_DECL_FDATASYNC=1; AC_SUBST([HAVE_DECL_FDATASYNC]) HAVE_DECL_GETDOMAINNAME=1; AC_SUBST([HAVE_DECL_GETDOMAINNAME]) + HAVE_DECL_GETLOGIN=1; AC_SUBST([HAVE_DECL_GETLOGIN]) HAVE_DECL_GETLOGIN_R=1; AC_SUBST([HAVE_DECL_GETLOGIN_R]) HAVE_DECL_GETPAGESIZE=1; AC_SUBST([HAVE_DECL_GETPAGESIZE]) HAVE_DECL_GETUSERSHELL=1; AC_SUBST([HAVE_DECL_GETUSERSHELL]) diff --git a/m4/vasnprintf.m4 b/m4/vasnprintf.m4 index 2d4b46310..47c5951cb 100644 --- a/m4/vasnprintf.m4 +++ b/m4/vasnprintf.m4 @@ -1,5 +1,5 @@ # vasnprintf.m4 serial 36 -dnl Copyright (C) 2002-2004, 2006-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2004, 2006-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/visibility.m4 b/m4/visibility.m4 index e99e3fbad..ce00e7250 100644 --- a/m4/visibility.m4 +++ b/m4/visibility.m4 @@ -1,5 +1,5 @@ # visibility.m4 serial 5 (gettext-0.18.2) -dnl Copyright (C) 2005, 2008, 2010-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2005, 2008, 2010-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/vsnprintf.m4 b/m4/vsnprintf.m4 index e056f05cd..9c37bca9c 100644 --- a/m4/vsnprintf.m4 +++ b/m4/vsnprintf.m4 @@ -1,5 +1,5 @@ -# vsnprintf.m4 serial 6 -dnl Copyright (C) 2002-2004, 2007-2016 Free Software Foundation, Inc. +# vsnprintf.m4 serial 7 +dnl Copyright (C) 2002-2004, 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -46,6 +46,14 @@ AC_DEFUN([gl_REPLACE_VSNPRINTF], AC_LIBOBJ([vsnprintf]) if test $ac_cv_func_vsnprintf = yes; then REPLACE_VSNPRINTF=1 + else + AC_CHECK_DECLS_ONCE([vsnprintf]) + if test $ac_cv_have_decl_vsnprintf = yes; then + dnl If the function is declared but does not appear to exist, it may be + dnl defined as an inline function. In order to avoid a conflict, we have + dnl to define rpl_vsnprintf, not vsnprintf. + REPLACE_VSNPRINTF=1 + fi fi gl_PREREQ_VSNPRINTF ]) diff --git a/m4/warn-on-use.m4 b/m4/warn-on-use.m4 index 08440ec59..25ce73789 100644 --- a/m4/warn-on-use.m4 +++ b/m4/warn-on-use.m4 @@ -1,5 +1,5 @@ # warn-on-use.m4 serial 5 -dnl Copyright (C) 2010-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2010-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/warnings.m4 b/m4/warnings.m4 index 924e21d5e..e697174ed 100644 --- a/m4/warnings.m4 +++ b/m4/warnings.m4 @@ -1,5 +1,5 @@ # warnings.m4 serial 11 -dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/wchar_h.m4 b/m4/wchar_h.m4 index b40b73237..d0e11a04e 100644 --- a/m4/wchar_h.m4 +++ b/m4/wchar_h.m4 @@ -1,13 +1,13 @@ dnl A placeholder for ISO C99 , for platforms that have issues. -dnl Copyright (C) 2007-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. dnl Written by Eric Blake. -# wchar_h.m4 serial 39 +# wchar_h.m4 serial 40 AC_DEFUN([gl_WCHAR_H], [ @@ -81,8 +81,14 @@ AC_DEFUN([gl_WCHAR_H_INLINE_OK], extern int zero (void); int main () { return zero(); } ]])]) + dnl Do not rename the object file from conftest.$ac_objext to + dnl conftest1.$ac_objext, as this will cause the link to fail on + dnl z/OS when using the XPLINK object format (due to duplicate + dnl CSECT names). Instead, temporarily redefine $ac_compile so + dnl that the object file has the latter name from the start. + save_ac_compile="$ac_compile" + ac_compile=`echo "$save_ac_compile" | sed s/conftest/conftest1/` if AC_TRY_EVAL([ac_compile]); then - mv conftest.$ac_objext conftest1.$ac_objext AC_LANG_CONFTEST([ AC_LANG_SOURCE([[#define wcstod renamed_wcstod /* Tru64 with Desktop Toolkit C has a bug: must be included before @@ -95,8 +101,9 @@ int main () { return zero(); } #include int zero (void) { return 0; } ]])]) + dnl See note above about renaming object files. + ac_compile=`echo "$save_ac_compile" | sed s/conftest/conftest2/` if AC_TRY_EVAL([ac_compile]); then - mv conftest.$ac_objext conftest2.$ac_objext if $CC -o conftest$ac_exeext $CFLAGS $LDFLAGS conftest1.$ac_objext conftest2.$ac_objext $LIBS >&AS_MESSAGE_LOG_FD 2>&1; then : else @@ -104,6 +111,7 @@ int zero (void) { return 0; } fi fi fi + ac_compile="$save_ac_compile" rm -f conftest1.$ac_objext conftest2.$ac_objext conftest$ac_exeext ]) if test $gl_cv_header_wchar_h_correct_inline = no; then diff --git a/m4/wchar_t.m4 b/m4/wchar_t.m4 index 2db8c3f2f..11783d299 100644 --- a/m4/wchar_t.m4 +++ b/m4/wchar_t.m4 @@ -1,5 +1,5 @@ # wchar_t.m4 serial 4 (gettext-0.18.2) -dnl Copyright (C) 2002-2003, 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2002-2003, 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/wcrtomb.m4 b/m4/wcrtomb.m4 index 267b3c9b2..0aa040df3 100644 --- a/m4/wcrtomb.m4 +++ b/m4/wcrtomb.m4 @@ -1,5 +1,5 @@ # wcrtomb.m4 serial 11 -dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/wctype_h.m4 b/m4/wctype_h.m4 index accc001ca..45ddaeb17 100644 --- a/m4/wctype_h.m4 +++ b/m4/wctype_h.m4 @@ -2,7 +2,7 @@ dnl A placeholder for ISO C99 , for platforms that lack it. -dnl Copyright (C) 2006-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2006-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/wint_t.m4 b/m4/wint_t.m4 index 8ff2a5b5a..65e25a4c3 100644 --- a/m4/wint_t.m4 +++ b/m4/wint_t.m4 @@ -1,11 +1,12 @@ -# wint_t.m4 serial 5 (gettext-0.18.2) -dnl Copyright (C) 2003, 2007-2016 Free Software Foundation, Inc. +# wint_t.m4 serial 6 +dnl Copyright (C) 2003, 2007-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. dnl From Bruno Haible. -dnl Test whether has the 'wint_t' type. +dnl Test whether has the 'wint_t' type and whether gnulib's +dnl or would, if present, override 'wint_t'. dnl Prerequisite: AC_PROG_CC AC_DEFUN([gt_TYPE_WINT_T], @@ -28,5 +29,34 @@ AC_DEFUN([gt_TYPE_WINT_T], [gt_cv_c_wint_t=no])]) if test $gt_cv_c_wint_t = yes; then AC_DEFINE([HAVE_WINT_T], [1], [Define if you have the 'wint_t' type.]) + + dnl Determine whether gnulib's or would, if present, + dnl override 'wint_t'. + AC_CACHE_CHECK([whether wint_t is too small], + [gl_cv_type_wint_t_too_small], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([[ +/* Tru64 with Desktop Toolkit C has a bug: must be included before + . + BSD/OS 4.0.1 has a bug: , and must be + included before . */ +#if !(defined __GLIBC__ && !defined __UCLIBC__) +# include +# include +# include +#endif +#include + int verify[sizeof (wint_t) < sizeof (int) ? -1 : 1]; + ]])], + [gl_cv_type_wint_t_too_small=no], + [gl_cv_type_wint_t_too_small=yes])]) + if test $gl_cv_type_wint_t_too_small = yes; then + GNULIB_OVERRIDES_WINT_T=1 + else + GNULIB_OVERRIDES_WINT_T=0 + fi + else + GNULIB_OVERRIDES_WINT_T=0 fi + AC_SUBST([GNULIB_OVERRIDES_WINT_T]) ]) diff --git a/m4/write.m4 b/m4/write.m4 index d9b93f9a3..fd46acc1b 100644 --- a/m4/write.m4 +++ b/m4/write.m4 @@ -1,5 +1,5 @@ # write.m4 serial 5 -dnl Copyright (C) 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/xsize.m4 b/m4/xsize.m4 index 16764e89d..5f8505770 100644 --- a/m4/xsize.m4 +++ b/m4/xsize.m4 @@ -1,5 +1,5 @@ # xsize.m4 serial 5 -dnl Copyright (C) 2003-2004, 2008-2016 Free Software Foundation, Inc. +dnl Copyright (C) 2003-2004, 2008-2017 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/maint.mk b/maint.mk index aa23364a1..0cabd2f31 100644 --- a/maint.mk +++ b/maint.mk @@ -2,7 +2,7 @@ # This Makefile fragment tries to be general-purpose enough to be # used by many projects via the gnulib maintainer-makefile module. -## Copyright (C) 2001-2016 Free Software Foundation, Inc. +## Copyright (C) 2001-2017 Free Software Foundation, Inc. ## ## This program is free software: you can redistribute it and/or modify ## it under the terms of the GNU General Public License as published by @@ -55,6 +55,10 @@ VC = $(GIT) VC_LIST = $(srcdir)/$(_build-aux)/vc-list-files -C $(srcdir) +# You can override this variable in cfg.mk if your gnulib submodule lives +# in a different location. +gnulib_dir ?= $(srcdir)/gnulib + # You can override this variable in cfg.mk to set your own regexp # matching files to ignore. VC_LIST_ALWAYS_EXCLUDE_REGEX ?= ^$$ @@ -437,17 +441,26 @@ sc_require_config_h: halt='the above files do not include ' \ $(_sc_search_regexp) +# Print each file name for which the first #include does not match +# $(config_h_header). Like grep -m 1, this only looks at the first match. +perl_config_h_first_ = \ + -e 'BEGIN {$$ret = 0}' \ + -e 'if (/^\# *include\b/) {' \ + -e ' if (not m{^\# *include $(config_h_header)}) {' \ + -e ' print "$$ARGV\n";' \ + -e ' $$ret = 1;' \ + -e ' }' \ + -e ' \# Move on to next file after first include' \ + -e ' close ARGV;' \ + -e '}' \ + -e 'END {exit $$ret}' + # You must include before including any other header file. # This can possibly be via a package-specific header, if given by cfg.mk. sc_require_config_h_first: @if $(VC_LIST_EXCEPT) | grep '\.c$$' > /dev/null; then \ - fail=0; \ - for i in $$($(VC_LIST_EXCEPT) | grep '\.c$$'); do \ - grep '^# *include\>' $$i | $(SED) 1q \ - | grep -E '^# *include $(config_h_header)' > /dev/null \ - || { echo $$i; fail=1; }; \ - done; \ - test $$fail = 1 && \ + files=$$($(VC_LIST_EXCEPT) | grep '\.c$$') && \ + perl -n $(perl_config_h_first_) $$files || \ { echo '$(ME): the above files include some other header' \ 'before ' 1>&2; exit 1; } || :; \ else :; \ @@ -648,17 +661,14 @@ sc_prohibit_strings_without_use: re='\<(strn?casecmp|ffs(ll)?)\>' \ $(_sc_header_without_use) -# Get the list of symbol names with this: -# perl -lne '/^# *define ([A-Z]\w+)\(/ and print $1' lib/intprops.h|fmt -_intprops_names = \ - TYPE_IS_INTEGER TYPE_SIGNED TYPE_MINIMUM TYPE_MAXIMUM \ - INT_BITS_STRLEN_BOUND INT_STRLEN_BOUND INT_BUFSIZE_BOUND \ - INT_ADD_RANGE_OVERFLOW INT_SUBTRACT_RANGE_OVERFLOW \ - INT_NEGATE_RANGE_OVERFLOW INT_MULTIPLY_RANGE_OVERFLOW \ - INT_DIVIDE_RANGE_OVERFLOW INT_REMAINDER_RANGE_OVERFLOW \ - INT_LEFT_SHIFT_RANGE_OVERFLOW INT_ADD_OVERFLOW INT_SUBTRACT_OVERFLOW \ - INT_NEGATE_OVERFLOW INT_MULTIPLY_OVERFLOW INT_DIVIDE_OVERFLOW \ - INT_REMAINDER_OVERFLOW INT_LEFT_SHIFT_OVERFLOW +# Extract the raw list of symbol names with this: +gl_extract_define_simple = \ + /^\# *define ([A-Z]\w+)\(/ and print $$1 +# Filter out duplicates and convert to a space-separated list: +_intprops_names = \ + $(shell f=$(gnulib_dir)/lib/intprops.h; \ + perl -lne '$(gl_extract_define_simple)' $$f | sort -u | tr '\n' ' ') +# Remove trailing space and convert to a regular expression: _intprops_syms_re = $(subst $(_sp),|,$(strip $(_intprops_names))) # Prohibit the inclusion of intprops.h without an actual use. sc_prohibit_intprops_without_use: @@ -707,15 +717,6 @@ sc_changelog: halt='found unexpected prefix in a ChangeLog' \ $(_sc_search_regexp) -# Ensure that each .c file containing a "main" function also -# calls set_program_name. -sc_program_name: - @require='set_program_name *\(.*\);' \ - in_vc_files='\.c$$' \ - containing='\

$@-1; \ - files=; \ - for file in $$($(VC_LIST_EXCEPT)) $(generated_files); do \ - test -r $$file || continue; \ - case $$file in \ - *.m4|*.mk) continue ;; \ - *.?|*.??) ;; \ - *) continue;; \ - esac; \ - case $$file in \ - *.[ch]) \ - base=`expr " $$file" : ' \(.*\)\..'`; \ - { test -f $$base.l || test -f $$base.y; } && continue;; \ - esac; \ - files="$$files $$file"; \ - done; \ + files=$$(perl $(perl_translatable_files_list_) \ + $$($(VC_LIST_EXCEPT)) $(generated_files)); \ grep -E -l '$(_gl_translatable_string_re)' $$files \ | $(SED) 's|^$(_dot_escaped_srcdir)/||' | sort -u > $@-2; \ diff -u -L $(po_file) -L $(po_file) $@-1 $@-2 \ @@ -1284,7 +1293,6 @@ vc-diff-check: rel-files = $(DIST_ARCHIVES) -gnulib_dir ?= $(srcdir)/gnulib gnulib-version = $$(cd $(gnulib_dir) \ && { git describe || git rev-parse --short=10 HEAD; } ) bootstrap-tools ?= autoconf,automake,gnulib @@ -1494,7 +1502,10 @@ gen-coverage: --highlight --frames --legend \ --title "$(PACKAGE_NAME)" -coverage: init-coverage build-coverage gen-coverage +coverage: + $(MAKE) init-coverage + $(MAKE) build-coverage + $(MAKE) gen-coverage # Some projects carry local adjustments for gnulib modules via patches in # a gnulib patch directory whose default name is gl/ (defined in bootstrap From 9399c1347918fb9b39ee4b1443bcc0df78ebf750 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 15 Feb 2017 21:45:17 +0100 Subject: [PATCH 691/865] Switch to accept4 * lib/Makefile.am: * m4/gnulib-cache.m4: * m4/gnulib-comp.m4: Switch from accept gnulib module to accept4. * libguile/socket.c (scm_accept): Use accept4. --- lib/Makefile.am | 12 +++-- libguile/socket.c | 2 +- m4/gnulib-cache.m4 | 4 +- m4/gnulib-comp.m4 | 120 +++++---------------------------------------- 4 files changed, 23 insertions(+), 115 deletions(-) diff --git a/lib/Makefile.am b/lib/Makefile.am index 5da186f6f..6336db4cf 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -21,7 +21,7 @@ # the same distribution terms as the rest of that program. # # Generated by gnulib-tool. -# Reproduce by: gnulib-tool --import --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --avoid=unistr/base --avoid=unistr/u8-mbtouc --avoid=unistr/u8-mbtouc-unsafe --avoid=unistr/u8-mbtoucr --avoid=unistr/u8-prev --avoid=unistr/u8-uctomb --avoid=unitypes --lgpl=3 --conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd dirname-lgpl duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkostemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar +# Reproduce by: gnulib-tool --import --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --avoid=unistr/base --avoid=unistr/u8-mbtouc --avoid=unistr/u8-mbtouc-unsafe --avoid=unistr/u8-mbtoucr --avoid=unistr/u8-prev --avoid=unistr/u8-uctomb --avoid=unitypes --lgpl=3 --conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept4 alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd dirname-lgpl duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkostemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar AUTOMAKE_OPTIONS = 1.9.6 gnits @@ -93,6 +93,12 @@ EXTRA_libgnu_la_SOURCES += accept.c ## end gnulib module accept +## begin gnulib module accept4 + +libgnu_la_SOURCES += accept4.c + +## end gnulib module accept4 + ## begin gnulib module alignof @@ -1579,9 +1585,7 @@ EXTRA_libgnu_la_SOURCES += mktime.c ## begin gnulib module msvc-inval -if gl_GNULIB_ENABLED_f691f076f650964c9f5598c3ee487616 -endif EXTRA_DIST += msvc-inval.c msvc-inval.h EXTRA_libgnu_la_SOURCES += msvc-inval.c @@ -1590,9 +1594,7 @@ EXTRA_libgnu_la_SOURCES += msvc-inval.c ## begin gnulib module msvc-nothrow -if gl_GNULIB_ENABLED_676220fa4366efa9bdbfccf11a857c07 -endif EXTRA_DIST += msvc-nothrow.c msvc-nothrow.h EXTRA_libgnu_la_SOURCES += msvc-nothrow.c diff --git a/libguile/socket.c b/libguile/socket.c index 4f2acffd7..9ddc4a21f 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -1268,7 +1268,7 @@ SCM_DEFINE (scm_accept, "accept", 1, 0, 0, sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); fd = SCM_FPORT_FDES (sock); - SCM_SYSCALL (newfd = accept (fd, (struct sockaddr *) &addr, &addr_size)); + SCM_SYSCALL (newfd = accept4 (fd, (struct sockaddr *) &addr, &addr_size, 0)); if (newfd == -1) { if (errno == EAGAIN || errno == EWOULDBLOCK) diff --git a/m4/gnulib-cache.m4 b/m4/gnulib-cache.m4 index f552a18c1..01f82d59b 100644 --- a/m4/gnulib-cache.m4 +++ b/m4/gnulib-cache.m4 @@ -27,12 +27,12 @@ # Specification in the form of a command-line invocation: -# gnulib-tool --import --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --avoid=unistr/base --avoid=unistr/u8-mbtouc --avoid=unistr/u8-mbtouc-unsafe --avoid=unistr/u8-mbtoucr --avoid=unistr/u8-prev --avoid=unistr/u8-uctomb --avoid=unitypes --lgpl=3 --conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd dirname-lgpl duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkostemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar +# gnulib-tool --import --local-dir=gnulib-local --lib=libgnu --source-base=lib --m4-base=m4 --doc-base=doc --tests-base=tests --aux-dir=build-aux --avoid=lock --avoid=unistr/base --avoid=unistr/u8-mbtouc --avoid=unistr/u8-mbtouc-unsafe --avoid=unistr/u8-mbtoucr --avoid=unistr/u8-prev --avoid=unistr/u8-uctomb --avoid=unitypes --lgpl=3 --conditional-dependencies --libtool --macro-prefix=gl --no-vc-files accept4 alignof alloca-opt announce-gen autobuild bind byteswap c-strcase canonicalize-lgpl ceil clock-time close connect copysign dirfd dirname-lgpl duplocale environ extensions flock floor fpieee frexp fstat fsync full-read full-write func gendocs getaddrinfo getlogin getpeername getsockname getsockopt git-version-gen gitlog-to-changelog gnu-web-doc-update gnupload havelib iconv_open-utf inet_ntop inet_pton isfinite isinf isnan ldexp lib-symbol-versions lib-symbol-visibility libunistring link listen localcharset locale log1p lstat maintainer-makefile malloc-gnu malloca mkdir mkostemp nl_langinfo nproc open pipe-posix pipe2 poll putenv readlink recv recvfrom regex rename rmdir select send sendto setenv setsockopt shutdown socket stat-time stdlib strftime striconveh string sys_stat time times trunc unistd verify vsnprintf warnings wchar # Specification in the form of a few gnulib-tool.m4 macro invocations: gl_LOCAL_DIR([gnulib-local]) gl_MODULES([ - accept + accept4 alignof alloca-opt announce-gen diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index 9380120e7..290d77933 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -44,6 +44,7 @@ AC_DEFUN([gl_EARLY], # Code from module absolute-header: # Code from module accept: + # Code from module accept4: # Code from module alignof: # Code from module alloca: # Code from module alloca-opt: @@ -267,6 +268,8 @@ AC_DEFUN([gl_INIT], AC_LIBOBJ([accept]) fi gl_SYS_SOCKET_MODULE_INDICATOR([accept]) + gl_FUNC_ACCEPT4 + gl_SYS_SOCKET_MODULE_INDICATOR([accept4]) gl_FUNC_ALLOCA gl_HEADER_ARPA_INET AC_PROG_MKDIR_P @@ -529,6 +532,14 @@ AC_DEFUN([gl_INIT], fi gl_MODULE_INDICATOR([mkostemp]) gl_STDLIB_MODULE_INDICATOR([mkostemp]) + AC_REQUIRE([gl_MSVC_INVAL]) + if test $HAVE_MSVC_INVALID_PARAMETER_HANDLER = 1; then + AC_LIBOBJ([msvc-inval]) + fi + AC_REQUIRE([gl_MSVC_NOTHROW]) + if test $HAVE_MSVC_INVALID_PARAMETER_HANDLER = 1; then + AC_LIBOBJ([msvc-nothrow]) + fi gl_MULTIARCH gl_HEADER_NETDB gl_HEADER_NETINET_IN @@ -731,8 +742,6 @@ AC_DEFUN([gl_INIT], gl_gnulib_enabled_memchr=false gl_gnulib_enabled_mktime=false gl_gnulib_enabled_5264294aa0a5557541b53c8c741f7f31=false - gl_gnulib_enabled_f691f076f650964c9f5598c3ee487616=false - gl_gnulib_enabled_676220fa4366efa9bdbfccf11a857c07=false gl_gnulib_enabled_pathmax=false gl_gnulib_enabled_raise=false gl_gnulib_enabled_round=false @@ -809,12 +818,6 @@ AC_SUBST([LTALLOCA]) fi gl_UNISTD_MODULE_INDICATOR([dup2]) gl_gnulib_enabled_dup2=true - if test $HAVE_DUP2 = 0 || test $REPLACE_DUP2 = 1; then - func_gl_gnulib_m4code_f691f076f650964c9f5598c3ee487616 - fi - if test $HAVE_DUP2 = 0 || test $REPLACE_DUP2 = 1; then - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 - fi fi } func_gl_gnulib_m4code_43fe87a341d9b4b93c47c3ad819a5239 () @@ -1007,27 +1010,6 @@ AC_SUBST([LTALLOCA]) func_gl_gnulib_m4code_mktime fi } - func_gl_gnulib_m4code_f691f076f650964c9f5598c3ee487616 () - { - if ! $gl_gnulib_enabled_f691f076f650964c9f5598c3ee487616; then - AC_REQUIRE([gl_MSVC_INVAL]) - if test $HAVE_MSVC_INVALID_PARAMETER_HANDLER = 1; then - AC_LIBOBJ([msvc-inval]) - fi - gl_gnulib_enabled_f691f076f650964c9f5598c3ee487616=true - fi - } - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 () - { - if ! $gl_gnulib_enabled_676220fa4366efa9bdbfccf11a857c07; then - AC_REQUIRE([gl_MSVC_NOTHROW]) - if test $HAVE_MSVC_INVALID_PARAMETER_HANDLER = 1; then - AC_LIBOBJ([msvc-nothrow]) - fi - gl_gnulib_enabled_676220fa4366efa9bdbfccf11a857c07=true - func_gl_gnulib_m4code_f691f076f650964c9f5598c3ee487616 - fi - } func_gl_gnulib_m4code_pathmax () { if ! $gl_gnulib_enabled_pathmax; then @@ -1045,9 +1027,6 @@ AC_SUBST([LTALLOCA]) fi gl_SIGNAL_MODULE_INDICATOR([raise]) gl_gnulib_enabled_raise=true - if test $HAVE_RAISE = 0 || test $REPLACE_RAISE = 1; then - func_gl_gnulib_m4code_f691f076f650964c9f5598c3ee487616 - fi fi } func_gl_gnulib_m4code_round () @@ -1133,7 +1112,6 @@ AC_SUBST([LTALLOCA]) AC_REQUIRE([gl_SOCKETS]) gl_gnulib_enabled_sockets=true func_gl_gnulib_m4code_43fe87a341d9b4b93c47c3ad819a5239 - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 fi } func_gl_gnulib_m4code_stat () @@ -1258,39 +1236,18 @@ AC_SUBST([LTALLOCA]) func_gl_gnulib_m4code_size_max fi } - if test "$ac_cv_header_winsock2_h" = yes; then - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 - fi - if test "$ac_cv_header_winsock2_h" = yes; then - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 - fi if test $HAVE_CANONICALIZE_FILE_NAME = 0 || test $REPLACE_CANONICALIZE_FILE_NAME = 1; then func_gl_gnulib_m4code_pathmax fi if test $REPLACE_CLOSE = 1; then func_gl_gnulib_m4code_43fe87a341d9b4b93c47c3ad819a5239 fi - if test $REPLACE_CLOSE = 1; then - func_gl_gnulib_m4code_f691f076f650964c9f5598c3ee487616 - fi - if test "$ac_cv_header_winsock2_h" = yes; then - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 - fi if test $HAVE_COPYSIGN = 0; then func_gl_gnulib_m4code_signbit fi - if test $HAVE_FLOCK = 0; then - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 - fi if test $gl_func_frexp != yes; then func_gl_gnulib_m4code_b1df7117b479d2da59d76deba468ee21 fi - if test $REPLACE_STAT = 1; then - func_gl_gnulib_m4code_f691f076f650964c9f5598c3ee487616 - fi - if test $HAVE_FSYNC = 0; then - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 - fi if test $HAVE_GETADDRINFO = 0 || test $HAVE_DECL_GAI_STRERROR = 0 || test $REPLACE_GAI_STRERROR = 1; then func_gl_gnulib_m4code_be453cec5eecf5731a274f2de7f2db36 fi @@ -1306,15 +1263,6 @@ AC_SUBST([LTALLOCA]) if test $HAVE_GETADDRINFO = 0; then func_gl_gnulib_m4code_sockets fi - if test "$ac_cv_header_winsock2_h" = yes; then - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 - fi - if test "$ac_cv_header_winsock2_h" = yes; then - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 - fi - if test "$ac_cv_header_winsock2_h" = yes; then - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 - fi if test $REPLACE_ISFINITE = 1; then func_gl_gnulib_m4code_b1df7117b479d2da59d76deba468ee21 fi @@ -1330,9 +1278,6 @@ AC_SUBST([LTALLOCA]) if test $HAVE_LINK = 0 || test $REPLACE_LINK = 1; then func_gl_gnulib_m4code_f9850631dca91859e9cddac9359921c0 fi - if test "$ac_cv_header_winsock2_h" = yes; then - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 - fi if test $HAVE_LOG1P = 0 || test $REPLACE_LOG1P = 1; then func_gl_gnulib_m4code_log fi @@ -1357,27 +1302,12 @@ AC_SUBST([LTALLOCA]) if test $HAVE_POLL = 0 || test $REPLACE_POLL = 1; then func_gl_gnulib_m4code_assure fi - if test $HAVE_POLL = 0 || test $REPLACE_POLL = 1; then - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 - fi if test $HAVE_POLL = 0 || test $REPLACE_POLL = 1; then func_gl_gnulib_m4code_sockets fi - if test $REPLACE_READ = 1; then - func_gl_gnulib_m4code_f691f076f650964c9f5598c3ee487616 - fi - if test $REPLACE_READ = 1; then - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 - fi if test $HAVE_READLINK = 0 || test $REPLACE_READLINK = 1; then func_gl_gnulib_m4code_stat fi - if test "$ac_cv_header_winsock2_h" = yes; then - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 - fi - if test "$ac_cv_header_winsock2_h" = yes; then - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 - fi if test $ac_use_included_regex = yes; then func_gl_gnulib_m4code_btowc fi @@ -1414,27 +1344,9 @@ AC_SUBST([LTALLOCA]) if test $REPLACE_SELECT = 1; then func_gl_gnulib_m4code_dup2 fi - if test $REPLACE_SELECT = 1; then - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 - fi if test $REPLACE_SELECT = 1; then func_gl_gnulib_m4code_sockets fi - if test "$ac_cv_header_winsock2_h" = yes; then - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 - fi - if test "$ac_cv_header_winsock2_h" = yes; then - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 - fi - if test "$ac_cv_header_winsock2_h" = yes; then - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 - fi - if test "$ac_cv_header_winsock2_h" = yes; then - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 - fi - if test "$ac_cv_header_winsock2_h" = yes; then - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 - fi if test "$ac_cv_header_winsock2_h" = yes; then func_gl_gnulib_m4code_sockets fi @@ -1453,12 +1365,6 @@ AC_SUBST([LTALLOCA]) if test $ac_cv_func_vsnprintf = no || test $REPLACE_VSNPRINTF = 1; then func_gl_gnulib_m4code_vasnprintf fi - if test $REPLACE_WRITE = 1; then - func_gl_gnulib_m4code_f691f076f650964c9f5598c3ee487616 - fi - if test $REPLACE_WRITE = 1; then - func_gl_gnulib_m4code_676220fa4366efa9bdbfccf11a857c07 - fi if test $REPLACE_WRITE = 1; then func_gl_gnulib_m4code_raise fi @@ -1486,8 +1392,6 @@ AC_SUBST([LTALLOCA]) AM_CONDITIONAL([gl_GNULIB_ENABLED_memchr], [$gl_gnulib_enabled_memchr]) AM_CONDITIONAL([gl_GNULIB_ENABLED_mktime], [$gl_gnulib_enabled_mktime]) AM_CONDITIONAL([gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31], [$gl_gnulib_enabled_5264294aa0a5557541b53c8c741f7f31]) - AM_CONDITIONAL([gl_GNULIB_ENABLED_f691f076f650964c9f5598c3ee487616], [$gl_gnulib_enabled_f691f076f650964c9f5598c3ee487616]) - AM_CONDITIONAL([gl_GNULIB_ENABLED_676220fa4366efa9bdbfccf11a857c07], [$gl_gnulib_enabled_676220fa4366efa9bdbfccf11a857c07]) AM_CONDITIONAL([gl_GNULIB_ENABLED_pathmax], [$gl_gnulib_enabled_pathmax]) AM_CONDITIONAL([gl_GNULIB_ENABLED_raise], [$gl_gnulib_enabled_raise]) AM_CONDITIONAL([gl_GNULIB_ENABLED_round], [$gl_gnulib_enabled_round]) @@ -1662,6 +1566,7 @@ AC_DEFUN([gl_FILE_LIST], [ doc/gendocs_template doc/gendocs_template_min lib/accept.c + lib/accept4.c lib/alignof.h lib/alloca.c lib/alloca.in.h @@ -1881,6 +1786,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/xsize.h m4/00gnulib.m4 m4/absolute-header.m4 + m4/accept4.m4 m4/alloca.m4 m4/arpa_inet_h.m4 m4/autobuild.m4 From 6e0965104c579431e5a786b60e1a964a112c73b8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 15 Feb 2017 22:01:51 +0100 Subject: [PATCH 692/865] Add accept4 support * doc/ref/posix.texi (Network Sockets and Communication): Add documentation. * libguile/socket.c (scm_accept4): New function, replaces accept implementation. (scm_accept): Call scm_accept4. (scm_init_socket): Define SOCK_CLOEXEC and SOCK_NONBLOCK. * libguile/socket.h: Add private scm_accept4 decl. * module/ice-9/suspendable-ports.scm (accept): Update. --- doc/ref/posix.texi | 6 +++++- libguile/socket.c | 26 ++++++++++++++++++++------ libguile/socket.h | 1 + module/ice-9/suspendable-ports.scm | 4 ++-- 4 files changed, 28 insertions(+), 9 deletions(-) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index bcb16bd1a..4afe6bf20 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -3276,7 +3276,7 @@ the queue. The return value is unspecified. @end deffn -@deffn {Scheme Procedure} accept sock +@deffn {Scheme Procedure} accept sock [flags] @deffnx {C Function} scm_accept (sock) Accept a connection from socket port @var{sock} which has been enabled for listening with @code{listen} above. @@ -3300,6 +3300,10 @@ connected and ready to communicate. The @code{cdr} is a socket address object (@pxref{Network Socket Address}) which is where the remote connection is from (like @code{getpeername} below). +@var{flags}, if given, may include @code{SOCK_CLOEXEC} or +@code{SOCK_NONBLOCK}, which like @code{O_CLOEXEC} and @code{O_NONBLOCK} +apply to the newly accepted socket. + All communication takes place using the new socket returned. The given @var{sock} remains bound and listening, and @code{accept} may be called on it again to get another incoming connection when desired. diff --git a/libguile/socket.c b/libguile/socket.c index 9ddc4a21f..64df64f4b 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -1243,8 +1243,8 @@ SCM_DEFINE (scm_make_socket_address, "make-socket-address", 2, 0, 1, #undef FUNC_NAME -SCM_DEFINE (scm_accept, "accept", 1, 0, 0, - (SCM sock), +SCM_DEFINE (scm_accept4, "accept", 1, 1, 0, + (SCM sock, SCM flags), "Accept a connection on a bound, listening socket. If there\n" "are no pending connections in the queue, there are two\n" "possibilities: if the socket has been configured as\n" @@ -1256,10 +1256,11 @@ SCM_DEFINE (scm_accept, "accept", 1, 0, 0, "initiated the connection.\n\n" "@var{sock} does not become part of the\n" "connection and will continue to accept new requests.") -#define FUNC_NAME s_scm_accept +#define FUNC_NAME s_scm_accept4 { int fd; int newfd; + int c_flags; SCM address; SCM newsock; socklen_t addr_size = MAX_ADDR_SIZE; @@ -1267,8 +1268,11 @@ SCM_DEFINE (scm_accept, "accept", 1, 0, 0, sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); + c_flags = SCM_UNBNDP (flags) ? 0 : scm_to_int (flags); + fd = SCM_FPORT_FDES (sock); - SCM_SYSCALL (newfd = accept4 (fd, (struct sockaddr *) &addr, &addr_size, 0)); + SCM_SYSCALL (newfd = accept4 (fd, (struct sockaddr *) &addr, &addr_size, + c_flags)); if (newfd == -1) { if (errno == EAGAIN || errno == EWOULDBLOCK) @@ -1276,13 +1280,18 @@ SCM_DEFINE (scm_accept, "accept", 1, 0, 0, SCM_SYSERROR; } newsock = scm_socket_fd_to_port (newfd); - address = _scm_from_sockaddr (&addr, addr_size, - FUNC_NAME); + address = _scm_from_sockaddr (&addr, addr_size, FUNC_NAME); return scm_cons (newsock, address); } #undef FUNC_NAME +SCM +scm_accept (SCM sock) +{ + return scm_accept4 (sock, SCM_UNDEFINED); +} + SCM_DEFINE (scm_getsockname, "getsockname", 1, 0, 0, (SCM sock), "Return the address of @var{sock}, in the same form as the\n" @@ -1644,6 +1653,11 @@ scm_init_socket () scm_c_define ("SOCK_RDM", scm_from_int (SOCK_RDM)); #endif + /* accept4 flags. No ifdef as accept4 has a gnulib + implementation. */ + scm_c_define ("SOCK_CLOEXEC", scm_from_int (SOCK_CLOEXEC)); + scm_c_define ("SOCK_NONBLOCK", scm_from_int (SOCK_NONBLOCK)); + /* setsockopt level. SOL_IP, SOL_TCP and SOL_UDP are defined on gnu/linux, but not on for diff --git a/libguile/socket.h b/libguile/socket.h index a211867c6..d7c368a22 100644 --- a/libguile/socket.h +++ b/libguile/socket.h @@ -42,6 +42,7 @@ SCM_API SCM scm_shutdown (SCM sfd, SCM how); SCM_API SCM scm_connect (SCM sockfd, SCM fam, SCM address, SCM args); SCM_API SCM scm_bind (SCM sockfd, SCM fam, SCM address, SCM args); SCM_API SCM scm_listen (SCM sfd, SCM backlog); +SCM_INTERNAL SCM scm_accept4 (SCM sockfd, SCM flags); SCM_API SCM scm_accept (SCM sockfd); SCM_API SCM scm_getsockname (SCM sockfd); SCM_API SCM scm_getpeername (SCM sockfd); diff --git a/module/ice-9/suspendable-ports.scm b/module/ice-9/suspendable-ports.scm index 8ff0ba029..a366c8b9c 100644 --- a/module/ice-9/suspendable-ports.scm +++ b/module/ice-9/suspendable-ports.scm @@ -678,9 +678,9 @@ (define accept (let ((%accept (@ (guile) accept))) - (lambda (port) + (lambda* (port #:optional (flags 0)) (let lp () - (or (%accept port) + (or (%accept port flags) (begin (wait-for-readable port) (lp))))))) From 4706d6982457498c60e575a026229e03820381d3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 15 Feb 2017 22:14:37 +0100 Subject: [PATCH 693/865] Fix accept4 gnulib update. * m4/accept4.m4: Add missing file. * lib/accept4.c: Add missing file. * .gitignore: Update. --- .gitignore | 2 + lib/accept4.c | 128 ++++++++++++++++++++++++++++++++++++++++++++++++++ m4/accept4.m4 | 18 +++++++ 3 files changed, 148 insertions(+) create mode 100644 lib/accept4.c create mode 100644 m4/accept4.m4 diff --git a/.gitignore b/.gitignore index 2c1f9d840..fb9e53b1f 100644 --- a/.gitignore +++ b/.gitignore @@ -165,3 +165,5 @@ INSTALL /test-suite/standalone/test-foreign-object-c /test-suite/standalone/test-srfi-4 /meta/build-env +/lib/limits.h +/lib/stdint.h diff --git a/lib/accept4.c b/lib/accept4.c new file mode 100644 index 000000000..9fab9c645 --- /dev/null +++ b/lib/accept4.c @@ -0,0 +1,128 @@ +/* Accept a connection on a socket, with specific opening flags. + Copyright (C) 2009-2017 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License along + with this program; if not, see . */ + +#include + +/* Specification. */ +#include + +#include +#include +#include "binary-io.h" +#include "msvc-nothrow.h" + +#ifndef SOCK_CLOEXEC +# define SOCK_CLOEXEC 0 +#endif + +int +accept4 (int sockfd, struct sockaddr *addr, socklen_t *addrlen, int flags) +{ + int fd; + +#if HAVE_ACCEPT4 +# undef accept4 + /* Try the system call first, if it exists. (We may be running with a glibc + that has the function but with an older kernel that lacks it.) */ + { + /* Cache the information whether the system call really exists. */ + static int have_accept4_really; /* 0 = unknown, 1 = yes, -1 = no */ + if (have_accept4_really >= 0) + { + int result = accept4 (sockfd, addr, addrlen, flags); + if (!(result < 0 && errno == ENOSYS)) + { + have_accept4_really = 1; + return result; + } + have_accept4_really = -1; + } + } +#endif + + /* Check the supported flags. */ + if ((flags & ~(SOCK_CLOEXEC | O_TEXT | O_BINARY)) != 0) + { + errno = EINVAL; + return -1; + } + + fd = accept (sockfd, addr, addrlen); + if (fd < 0) + return -1; + +#if SOCK_CLOEXEC +# if (defined _WIN32 || defined __WIN32__) && ! defined __CYGWIN__ +/* Native Windows API. */ + if (flags & SOCK_CLOEXEC) + { + HANDLE curr_process = GetCurrentProcess (); + HANDLE old_handle = (HANDLE) _get_osfhandle (fd); + HANDLE new_handle; + int nfd; + + if (!DuplicateHandle (curr_process, /* SourceProcessHandle */ + old_handle, /* SourceHandle */ + curr_process, /* TargetProcessHandle */ + (PHANDLE) &new_handle, /* TargetHandle */ + (DWORD) 0, /* DesiredAccess */ + FALSE, /* InheritHandle */ + DUPLICATE_SAME_ACCESS)) /* Options */ + { + close (fd); + errno = EBADF; /* arbitrary */ + return -1; + } + + /* Closing fd before allocating the new fd ensures that the new fd will + have the minimum possible value. */ + close (fd); + nfd = _open_osfhandle ((intptr_t) new_handle, + O_NOINHERIT | (flags & (O_TEXT | O_BINARY))); + if (nfd < 0) + { + CloseHandle (new_handle); + return -1; + } + return nfd; + } +# else +/* Unix API. */ + if (flags & SOCK_CLOEXEC) + { + int fcntl_flags; + + if ((fcntl_flags = fcntl (fd, F_GETFD, 0)) < 0 + || fcntl (fd, F_SETFD, fcntl_flags | FD_CLOEXEC) == -1) + { + int saved_errno = errno; + close (fd); + errno = saved_errno; + return -1; + } + } +# endif +#endif + +#if O_BINARY + if (flags & O_BINARY) + set_binary_mode (fd, O_BINARY); + else if (flags & O_TEXT) + set_binary_mode (fd, O_TEXT); +#endif + + return fd; +} diff --git a/m4/accept4.m4 b/m4/accept4.m4 new file mode 100644 index 000000000..841e9b50f --- /dev/null +++ b/m4/accept4.m4 @@ -0,0 +1,18 @@ +# accept4.m4 serial 2 +dnl Copyright (C) 2009-2017 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_FUNC_ACCEPT4], +[ + AC_REQUIRE([gl_SYS_SOCKET_H_DEFAULTS]) + + dnl Persuade glibc to declare accept4(). + AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS]) + + AC_CHECK_FUNCS_ONCE([accept4]) + if test $ac_cv_func_accept4 != yes; then + HAVE_ACCEPT4=0 + fi +]) From cd3ff33a31c51612f2247bdb15ecbe92d7da1310 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 16 Feb 2017 10:38:15 +0100 Subject: [PATCH 694/865] Cheaper fluid-ref cache * libguile/cache-internal.h (struct scm_cache_entry): Add needs_flush member. (scm_cache_evict_1): Clear needs_flush on newly evicted entry. (scm_cache_insert): Propagate needs_flush to new entry. * libguile/fluids.c (restore_dynamic_state): Mark all restored entries as needing a flush. (save_dynamic_state): Only cons on "needs_flush" entries to the resulting dynamic state. The result is the same as before but avoiding the refq on the weak table. (fluid_set_x): Propagate needs_flush down to the cache. (fluid_ref): When adding entry to cache, use needs_flush==0. (scm_fluid_set_x, scm_fluid_unset_x, scm_swap_fluid, swap_fluid): Use needs_flush==1. --- libguile/cache-internal.h | 6 +++++- libguile/fluids.c | 30 +++++++++++++++++------------- 2 files changed, 22 insertions(+), 14 deletions(-) diff --git a/libguile/cache-internal.h b/libguile/cache-internal.h index fc1e3c139..88bb24af0 100644 --- a/libguile/cache-internal.h +++ b/libguile/cache-internal.h @@ -37,6 +37,7 @@ struct scm_cache_entry { scm_t_bits key; scm_t_bits value; + int needs_flush; }; #define SCM_CACHE_SIZE 8 @@ -73,6 +74,7 @@ scm_cache_evict_1 (struct scm_cache *cache, struct scm_cache_entry *evicted) sizeof (cache->entries[0]) * idx); cache->entries[0].key = 0; cache->entries[0].value = 0; + cache->entries[0].needs_flush = 0; } static inline struct scm_cache_entry* @@ -89,7 +91,7 @@ scm_cache_lookup (struct scm_cache *cache, SCM k) static inline void scm_cache_insert (struct scm_cache *cache, SCM k, SCM v, - struct scm_cache_entry *evicted) + struct scm_cache_entry *evicted, int needs_flush) { struct scm_cache_entry *entry; @@ -99,6 +101,7 @@ scm_cache_insert (struct scm_cache *cache, SCM k, SCM v, if (entry->key == SCM_UNPACK (k)) { entry->value = SCM_UNPACK (v); + entry->needs_flush = needs_flush; return; } memmove (cache->entries, @@ -106,6 +109,7 @@ scm_cache_insert (struct scm_cache *cache, SCM k, SCM v, (entry - cache->entries) * sizeof (*entry)); entry->key = SCM_UNPACK (k); entry->value = SCM_UNPACK (v); + entry->needs_flush = needs_flush; } #endif /* SCM_CACHE_INTERNAL_H */ diff --git a/libguile/fluids.c b/libguile/fluids.c index 7daad7781..5b42ccb6d 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -114,10 +114,11 @@ restore_dynamic_state (SCM saved, scm_t_dynamic_state *state) { entry->key = SCM_UNPACK (SCM_CAAR (saved)); entry->value = SCM_UNPACK (SCM_CDAR (saved)); + entry->needs_flush = 1; saved = scm_cdr (saved); } else - entry->key = entry->value = 0; + entry->key = entry->value = entry->needs_flush = 0; } state->values = saved; state->has_aliased_values = 1; @@ -133,9 +134,7 @@ save_dynamic_state (scm_t_dynamic_state *state) struct scm_cache_entry *entry = &state->cache.entries[slot]; SCM key = SCM_PACK (entry->key); SCM value = SCM_PACK (entry->value); - if (entry->key && - !scm_is_eq (scm_weak_table_refq (state->values, key, SCM_UNDEFINED), - value)) + if (entry->key && entry->needs_flush) { if (state->has_aliased_values) saved = scm_acons (key, value, saved); @@ -249,7 +248,8 @@ scm_is_fluid (SCM obj) } static void -fluid_set_x (scm_t_dynamic_state *dynamic_state, SCM fluid, SCM value) +fluid_set_x (scm_t_dynamic_state *dynamic_state, SCM fluid, SCM value, + int needs_flush) { struct scm_cache_entry *entry; struct scm_cache_entry evicted = { 0, 0 }; @@ -257,13 +257,17 @@ fluid_set_x (scm_t_dynamic_state *dynamic_state, SCM fluid, SCM value) entry = scm_cache_lookup (&dynamic_state->cache, fluid); if (scm_is_eq (SCM_PACK (entry->key), fluid)) { - entry->value = SCM_UNPACK (value); + if (SCM_UNPACK (value) != entry->value) + { + entry->needs_flush = 1; + entry->value = SCM_UNPACK (value); + } return; } - scm_cache_insert (&dynamic_state->cache, fluid, value, &evicted); + scm_cache_insert (&dynamic_state->cache, fluid, value, &evicted, 1); - if (evicted.key != 0) + if (evicted.key != 0 && evicted.needs_flush) { fluid = SCM_PACK (evicted.key); value = SCM_PACK (evicted.value); @@ -300,7 +304,7 @@ fluid_ref (scm_t_dynamic_state *dynamic_state, SCM fluid) val = SCM_I_FLUID_DEFAULT (fluid); /* Cache this lookup. */ - fluid_set_x (dynamic_state, fluid, val); + fluid_set_x (dynamic_state, fluid, val, 0); } return val; @@ -355,7 +359,7 @@ SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0, #define FUNC_NAME s_scm_fluid_set_x { SCM_VALIDATE_FLUID (1, fluid); - fluid_set_x (SCM_I_CURRENT_THREAD->dynamic_state, fluid, value); + fluid_set_x (SCM_I_CURRENT_THREAD->dynamic_state, fluid, value, 1); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -369,7 +373,7 @@ SCM_DEFINE (scm_fluid_unset_x, "fluid-unset!", 1, 0, 0, suite demands it, but I would prefer not to. */ SCM_VALIDATE_FLUID (1, fluid); SCM_SET_CELL_OBJECT_1 (fluid, SCM_UNDEFINED); - fluid_set_x (SCM_I_CURRENT_THREAD->dynamic_state, fluid, SCM_UNDEFINED); + fluid_set_x (SCM_I_CURRENT_THREAD->dynamic_state, fluid, SCM_UNDEFINED, 1); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -397,7 +401,7 @@ void scm_swap_fluid (SCM fluid, SCM value_box, scm_t_dynamic_state *dynstate) { SCM val = fluid_ref (dynstate, fluid); - fluid_set_x (dynstate, fluid, SCM_VARIABLE_REF (value_box)); + fluid_set_x (dynstate, fluid, SCM_VARIABLE_REF (value_box), 1); SCM_VARIABLE_SET (value_box, val); } @@ -474,7 +478,7 @@ swap_fluid (SCM data) scm_t_dynamic_state *dynstate = SCM_I_CURRENT_THREAD->dynamic_state; SCM f = SCM_CAR (data); SCM t = fluid_ref (dynstate, f); - fluid_set_x (dynstate, f, SCM_CDR (data)); + fluid_set_x (dynstate, f, SCM_CDR (data), 1); SCM_SETCDR (data, t); } From c38b9625c88f4d1760068926273b6d89ffbd4527 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 16 Feb 2017 10:43:23 +0100 Subject: [PATCH 695/865] Remove unnecessary scm_i_string_start_writing calls * libguile/strings.c (scm_string, scm_c_make_string): * libguile/srfi-13.c (scm_reverse_list_to_string, scm_string_map) (scm_string_unfold, scm_string_unfold_right, scm_xsubstring) (scm_string_filter, scm_string_delete): Remove scm_i_string_start_writing / scm_i_string_stop_writing calls around fresh strings that aren't visible to other threads. --- libguile/read.c | 6 ++---- libguile/srfi-13.c | 30 ++++++++++++++---------------- libguile/strings.c | 5 ----- 3 files changed, 16 insertions(+), 25 deletions(-) diff --git a/libguile/read.c b/libguile/read.c index 085cdb9f1..0946ff379 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -1556,7 +1556,8 @@ scm_read_extended_symbol (scm_t_wchar chr, SCM port) size_t len = 0; SCM buf = scm_i_make_string (1024, NULL, 0); - buf = scm_i_string_start_writing (buf); + /* No need to scm_i_string_start_writing (), as the string isn't + visible to any other thread. */ while ((chr = scm_getc (port)) != EOF) { @@ -1620,16 +1621,13 @@ scm_read_extended_symbol (scm_t_wchar chr, SCM port) { SCM addy; - scm_i_string_stop_writing (); addy = scm_i_make_string (1024, NULL, 0); buf = scm_string_append (scm_list_2 (buf, addy)); len = 0; - buf = scm_i_string_start_writing (buf); } } done: - scm_i_string_stop_writing (); if (chr == EOF) scm_i_input_error ("scm_read_extended_symbol", port, "end of file while reading symbol", SCM_EOL); diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c index 5c30dfe20..c77cba9b2 100644 --- a/libguile/srfi-13.c +++ b/libguile/srfi-13.c @@ -351,7 +351,8 @@ SCM_DEFINE (scm_reverse_list_to_string, "reverse-list->string", 1, 0, 0, } rest = chrs; j = i; - result = scm_i_string_start_writing (result); + /* No need to scm_i_string_start_writing (), as the string isn't + visible to any other thread. */ while (j > 0 && scm_is_pair (rest)) { SCM elt = SCM_CAR (rest); @@ -359,7 +360,6 @@ SCM_DEFINE (scm_reverse_list_to_string, "reverse-list->string", 1, 0, 0, rest = SCM_CDR (rest); j--; } - scm_i_string_stop_writing (); } return result; @@ -2515,9 +2515,9 @@ SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0, if (!SCM_CHARP (ch)) SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); cstart++; - result = scm_i_string_start_writing (result); + /* No need to scm_i_string_start_writing (), as the string isn't + visible to any other thread. */ scm_i_string_set_x (result, p, SCM_CHAR (ch)); - scm_i_string_stop_writing (); p++; } @@ -2658,9 +2658,9 @@ SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0, if (!SCM_CHARP (ch)) SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f)); str = scm_i_make_string (1, NULL, 0); - str = scm_i_string_start_writing (str); + /* No need to scm_i_string_start_writing (), as the string isn't + visible to any other thread. */ scm_i_string_set_x (str, i, SCM_CHAR (ch)); - scm_i_string_stop_writing (); i++; ans = scm_string_append (scm_list_2 (ans, str)); @@ -2724,9 +2724,9 @@ SCM_DEFINE (scm_string_unfold_right, "string-unfold-right", 4, 2, 0, if (!SCM_CHARP (ch)) SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f)); str = scm_i_make_string (1, NULL, 0); - str = scm_i_string_start_writing (str); + /* No need to scm_i_string_start_writing (), as the string isn't + visible to any other thread. */ scm_i_string_set_x (str, i, SCM_CHAR (ch)); - scm_i_string_stop_writing (); i++; ans = scm_string_append (scm_list_2 (str, ans)); @@ -2839,7 +2839,6 @@ SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0, SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL); result = scm_i_make_string (cto - cfrom, NULL, 0); - result = scm_i_string_start_writing (result); p = 0; while (cfrom < cto) @@ -2853,7 +2852,6 @@ SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0, cfrom++; p++; } - scm_i_string_stop_writing (); scm_remember_upto_here_1 (s); return result; @@ -3191,8 +3189,9 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0, { size_t dst = 0; result = scm_i_make_string (count, NULL, 0); - result = scm_i_string_start_writing (result); + /* No need to scm_i_string_start_writing (), as the string isn't + visible to any other thread. */ /* decrement "count" in this loop as well as using idx, so that if another thread is simultaneously changing "s" there's no chance it'll make us copy more than count characters */ @@ -3205,7 +3204,6 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0, count--; } } - scm_i_string_stop_writing (); } } else @@ -3301,7 +3299,8 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, int i = 0; /* new string for retained portion */ result = scm_i_make_string (count, NULL, 0); - result = scm_i_string_start_writing (result); + /* No need to scm_i_string_start_writing (), as the string isn't + visible to any other thread. */ /* decrement "count" in this loop as well as using idx, so that if another thread is simultaneously changing "s" there's no chance it'll make us copy more than count characters */ @@ -3315,7 +3314,6 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, count--; } } - scm_i_string_stop_writing (); } } else if (SCM_CHARSETP (char_pred)) @@ -3343,8 +3341,9 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, size_t i = 0; /* new string for retained portion */ result = scm_i_make_string (count, NULL, 0); - result = scm_i_string_start_writing (result); + /* No need to scm_i_string_start_writing (), as the string isn't + visible to any other thread. */ /* decrement "count" in this loop as well as using idx, so that if another thread is simultaneously changing "s" there's no chance it'll make us copy more than count characters */ @@ -3357,7 +3356,6 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, count--; } } - scm_i_string_stop_writing (); } } else diff --git a/libguile/strings.c b/libguile/strings.c index cdbc3587f..a153d29ab 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -1145,7 +1145,6 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1, char *buf; result = scm_i_make_string (len, NULL, 0); - result = scm_i_string_start_writing (result); buf = scm_i_string_writable_chars (result); while (len > 0 && scm_is_pair (rest)) { @@ -1162,7 +1161,6 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1, scm_t_wchar *buf; result = scm_i_make_wide_string (len, NULL, 0); - result = scm_i_string_start_writing (result); buf = scm_i_string_writable_wide_chars (result); while (len > 0 && scm_is_pair (rest)) { @@ -1174,7 +1172,6 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1, scm_remember_upto_here_1 (elt); } } - scm_i_string_stop_writing (); if (len > 0) scm_misc_error (NULL, "list changed while constructing string", SCM_EOL); @@ -1211,10 +1208,8 @@ scm_c_make_string (size_t len, SCM chr) else { SCM_VALIDATE_CHAR (0, chr); - res = scm_i_string_start_writing (res); for (p = 0; p < len; p++) scm_i_string_set_x (res, p, SCM_CHAR (chr)); - scm_i_string_stop_writing (); } return res; From d0934df1f2f0e5d3fa9a1a1f15e6f2dec1d15698 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 16 Feb 2017 12:57:46 +0100 Subject: [PATCH 696/865] Stringbufs immutable by default * libguile/snarf.h (SCM_IMMUTABLE_STRINGBUF): Remove shared flag. Stringbufs are immutable by default. * libguile/strings.c: Rewrite blurb. Change to have stringbufs be immutable by default and mutable only when marked as such. Going mutable means making a private copy. (STRINGBUF_MUTABLE, STRINGBUF_F_MUTABLE): New definitions. (SET_STRINGBUF_SHARED): Remove. (scm_i_print_stringbuf): Simplify to just alias the stringbuf as-is. (substring_with_immutable_stringbuf): New helper. (scm_i_substring, scm_i_substring_read_only, scm_i_substring_copy): use new helper. (scm_i_string_ensure_mutable_x): New helper. (scm_i_substring_shared): Use scm_i_string_ensure_mutable_x. (stringbuf_write_mutex): Remove; yaaaaaaaay. (scm_i_string_start_writing): Use scm_i_string_ensure_mutable_x. No more mutex. (scm_i_string_stop_writing): Now a no-op. (scm_i_make_symbol): Use substring/copy. (scm_sys_string_dump, scm_sys_symbol_dump): Update. * libguile/strings.h (SCM_I_STRINGBUF_F_SHARED): Remove. (SCM_I_STRINGBUF_F_MUTABLE): Add. * module/system/vm/assembler.scm (link-data): Don't add shared flag any more. Existing compiled flags are harmless tho. * test-suite/tests/strings.test ("string internals"): Update. --- libguile/snarf.h | 2 +- libguile/strings.c | 327 +++++++++++++-------------------- libguile/strings.h | 2 +- module/system/vm/assembler.scm | 7 +- test-suite/tests/strings.test | 34 +++- 5 files changed, 158 insertions(+), 214 deletions(-) diff --git a/libguile/snarf.h b/libguile/snarf.h index d0b683308..aafd5bd13 100644 --- a/libguile/snarf.h +++ b/libguile/snarf.h @@ -308,7 +308,7 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));) } \ c_name = \ { \ - scm_tc7_stringbuf | SCM_I_STRINGBUF_F_SHARED, \ + scm_tc7_stringbuf, \ sizeof (contents) - 1, \ contents \ } diff --git a/libguile/strings.c b/libguile/strings.c index a153d29ab..e460a938d 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -54,40 +54,34 @@ SCM_SYMBOL (sym_UTF_8, "UTF-8"); SCM_SYMBOL (sym_ISO_8859_1, "ISO-8859-1"); SCM_SYMBOL (sym_error, "error"); -/* Stringbufs - * - * XXX - keeping an accurate refcount during GC seems to be quite - * tricky, so we just keep score of whether a stringbuf might be - * shared, not whether it definitely is. - * - * The scheme I (mvo) tried to keep an accurate reference count would - * recount all strings that point to a stringbuf during the mark-phase - * of the GC. This was done since one cannot access the stringbuf of - * a string when that string is freed (in order to decrease the - * reference count). The memory of the stringbuf might have been - * reused already for something completely different. - * - * This recounted worked for a small number of threads beating on - * cow-strings, but it failed randomly with more than 10 threads, say. - * I couldn't figure out what went wrong, so I used the conservative - * approach implemented below. - * - * There are 2 storage strategies for stringbufs: 8-bit and wide. 8-bit - * strings are ISO-8859-1-encoded strings; wide strings are 32-bit (UCS-4) - * strings. - */ +/* A stringbuf is a linear buffer of characters. Every string has a + stringbuf. Strings may reference just a slice of a stringbuf; that's + often the case for strings made by the "substring" function. + + Stringbufs may hold either 8-bit characters or 32-bit characters. In + either case the characters are Unicode codepoints. "Narrow" + stringbufs thus have the ISO-8859-1 (Latin-1) encoding, and "wide" + stringbufs have the UTF-32 (UCS-4) encoding. + + By default, stringbufs are immutable. This enables an O(1) + "substring" operation with no synchronization. A string-set! will + first ensure that the string's stringbuf is mutable, copying the + stringbuf if necessary. This is therefore a copy-on-write + representation. However, taking a substring of a mutable stringbuf + is an O(n) operation as it has to create a new immutable stringbuf. + There are also mutation-sharing substrings as well. */ /* The size in words of the stringbuf header (type tag + size). */ #define STRINGBUF_HEADER_SIZE 2U #define STRINGBUF_HEADER_BYTES (STRINGBUF_HEADER_SIZE * sizeof (SCM)) -#define STRINGBUF_F_SHARED SCM_I_STRINGBUF_F_SHARED #define STRINGBUF_F_WIDE SCM_I_STRINGBUF_F_WIDE +#define STRINGBUF_F_MUTABLE SCM_I_STRINGBUF_F_MUTABLE #define STRINGBUF_TAG scm_tc7_stringbuf -#define STRINGBUF_SHARED(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_SHARED) #define STRINGBUF_WIDE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_WIDE) +#define STRINGBUF_MUTABLE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_MUTABLE) #define STRINGBUF_CONTENTS(buf) ((void *) \ SCM_CELL_OBJECT_LOC (buf, \ @@ -97,16 +91,6 @@ SCM_SYMBOL (sym_error, "error"); #define STRINGBUF_LENGTH(buf) (SCM_CELL_WORD_1 (buf)) -#define SET_STRINGBUF_SHARED(buf) \ - do \ - { \ - /* Don't modify BUF if it's already marked as shared since it might be \ - a read-only, statically allocated stringbuf. */ \ - if (SCM_LIKELY (!STRINGBUF_SHARED (buf))) \ - SCM_SET_CELL_WORD_0 ((buf), SCM_CELL_WORD_0 (buf) | STRINGBUF_F_SHARED); \ - } \ - while (0) - #ifdef SCM_STRING_LENGTH_HISTOGRAM static size_t lenhist[1001]; #endif @@ -231,8 +215,6 @@ narrow_stringbuf (SCM buf) return new_buf; } -scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; - /* Copy-on-write strings. */ @@ -267,15 +249,8 @@ scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; void scm_i_print_stringbuf (SCM exp, SCM port, scm_print_state *pstate) { - SCM str; - - scm_i_pthread_mutex_lock (&stringbuf_write_mutex); - SET_STRINGBUF_SHARED (exp); - scm_i_pthread_mutex_unlock (&stringbuf_write_mutex); - - str = scm_double_cell (RO_STRING_TAG, SCM_UNPACK(exp), - 0, STRINGBUF_LENGTH (exp)); - + SCM str = scm_double_cell (STRING_TAG, SCM_UNPACK(exp), 0, + STRINGBUF_LENGTH (exp)); scm_puts ("#", port); @@ -289,7 +264,6 @@ static void init_null_stringbuf (void) { null_stringbuf = make_stringbuf (0); - SET_STRINGBUF_SHARED (null_stringbuf); } /* Create a scheme string with space for LEN 8-bit Latin-1-encoded @@ -359,77 +333,110 @@ get_str_buf_start (SCM *str, SCM *buf, size_t *start) *buf = STRING_STRINGBUF (*str); } +static SCM +substring_with_immutable_stringbuf (SCM str, size_t start, size_t end, + int force_copy_p, int read_only_p) +{ + SCM buf; + size_t str_start, len; + scm_t_bits tag = read_only_p ? RO_STRING_TAG : STRING_TAG; + + get_str_buf_start (&str, &buf, &str_start); + len = end - start; + start += str_start; + + if (len == 0) + return scm_i_make_string (0, NULL, read_only_p); + else if (!force_copy_p && SCM_LIKELY (!STRINGBUF_MUTABLE (buf))) + return scm_double_cell (tag, SCM_UNPACK (buf), start, len); + else + { + SCM new_buf, new_str; + + if (STRINGBUF_WIDE (buf)) + { + new_buf = make_wide_stringbuf (len); + u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (new_buf), + (scm_t_uint32 *) (STRINGBUF_WIDE_CHARS (buf) + start), len); + new_str = scm_double_cell (tag, SCM_UNPACK (new_buf), 0, len); + scm_i_try_narrow_string (new_str); + } + else + { + new_buf = make_stringbuf (len); + memcpy (STRINGBUF_CHARS (new_buf), + STRINGBUF_CHARS (buf) + start, len); + new_str = scm_double_cell (tag, SCM_UNPACK (new_buf), 0, len); + } + + return new_str; + } +} + SCM scm_i_substring (SCM str, size_t start, size_t end) { - if (start == end) - return scm_i_make_string (0, NULL, 0); - else - { - SCM buf; - size_t str_start; - get_str_buf_start (&str, &buf, &str_start); - scm_i_pthread_mutex_lock (&stringbuf_write_mutex); - SET_STRINGBUF_SHARED (buf); - scm_i_pthread_mutex_unlock (&stringbuf_write_mutex); - return scm_double_cell (STRING_TAG, SCM_UNPACK(buf), - (scm_t_bits)str_start + start, - (scm_t_bits) end - start); - } + return substring_with_immutable_stringbuf (str, start, end, 0, 0); } SCM scm_i_substring_read_only (SCM str, size_t start, size_t end) { - if (start == end) - return scm_i_make_string (0, NULL, 1); - else - { - SCM buf; - size_t str_start; - get_str_buf_start (&str, &buf, &str_start); - scm_i_pthread_mutex_lock (&stringbuf_write_mutex); - SET_STRINGBUF_SHARED (buf); - scm_i_pthread_mutex_unlock (&stringbuf_write_mutex); - return scm_double_cell (RO_STRING_TAG, SCM_UNPACK(buf), - (scm_t_bits)str_start + start, - (scm_t_bits) end - start); - } + return substring_with_immutable_stringbuf (str, start, end, 0, 1); } SCM scm_i_substring_copy (SCM str, size_t start, size_t end) { - if (start == end) - return scm_i_make_string (0, NULL, 0); - else + return substring_with_immutable_stringbuf (str, start, end, 1, 0); +} + +static void +scm_i_string_ensure_mutable_x (SCM str) +{ + SCM buf; + + if (IS_SH_STRING (str)) { - size_t len = end - start; - SCM buf, my_buf, substr; - size_t str_start; - int wide = 0; - get_str_buf_start (&str, &buf, &str_start); - if (scm_i_is_narrow_string (str)) - { - my_buf = make_stringbuf (len); - memcpy (STRINGBUF_CHARS (my_buf), - STRINGBUF_CHARS (buf) + str_start + start, len); - } - else - { - my_buf = make_wide_stringbuf (len); - u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (my_buf), - (scm_t_uint32 *) (STRINGBUF_WIDE_CHARS (buf) + str_start - + start), len); - wide = 1; - } - scm_remember_upto_here_1 (buf); - substr = scm_double_cell (STRING_TAG, SCM_UNPACK (my_buf), - (scm_t_bits) 0, (scm_t_bits) len); - if (wide) - scm_i_try_narrow_string (substr); - return substr; + /* Shared-mutation strings always have mutable stringbufs. */ + buf = STRING_STRINGBUF (SH_STRING_STRING (str)); + if (!STRINGBUF_MUTABLE (buf)) + abort (); + return; } + + if (IS_RO_STRING (str)) + scm_misc_error (NULL, "string is read-only: ~s", scm_list_1 (str)); + + buf = STRING_STRINGBUF (str); + + if (STRINGBUF_MUTABLE (buf)) + return; + + /* Otherwise copy and mark the fresh stringbuf as mutable. Note that + we copy the whole stringbuf so that the start/len offsets from the + original string keep working, so that concurrent accessors on this + string don't see things in an inconsistent state. */ + { + SCM new_buf; + size_t len = STRINGBUF_LENGTH (buf); + + if (STRINGBUF_WIDE (buf)) + { + new_buf = make_wide_stringbuf (len); + u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (new_buf), + (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf), len); + } + else + { + new_buf = make_stringbuf (len); + memcpy (STRINGBUF_CHARS (new_buf), STRINGBUF_CHARS (buf), len); + } + + SCM_SET_CELL_WORD_0 (new_buf, + SCM_CELL_WORD_0 (new_buf) | STRINGBUF_F_MUTABLE); + SET_STRING_STRINGBUF (str, new_buf); + } } SCM @@ -439,6 +446,8 @@ scm_i_substring_shared (SCM str, size_t start, size_t end) return str; else if (start == end) return scm_i_make_string (0, NULL, 0); + else if (IS_RO_STRING (str)) + return scm_i_substring_read_only (str, start, end); else { size_t len = end - start; @@ -447,6 +456,9 @@ scm_i_substring_shared (SCM str, size_t start, size_t end) start += STRING_START (str); str = SH_STRING_STRING (str); } + + scm_i_string_ensure_mutable_x (str); + return scm_double_cell (SH_STRING_TAG, SCM_UNPACK(str), (scm_t_bits)start, (scm_t_bits) len); } @@ -568,60 +580,13 @@ scm_i_string_wide_chars (SCM str) scm_list_1 (str)); } -/* If the buffer in ORIG_STR is shared, copy ORIG_STR's characters to +/* If the buffer in ORIG_STR is immutable, copy ORIG_STR's characters to a new string buffer, so that it can be modified without modifying - other strings. Also, lock the string mutex. Later, one must call - scm_i_string_stop_writing to unlock the mutex. */ + other strings. */ SCM scm_i_string_start_writing (SCM orig_str) { - SCM buf, str = orig_str; - size_t start; - - get_str_buf_start (&str, &buf, &start); - if (IS_RO_STRING (str)) - scm_misc_error (NULL, "string is read-only: ~s", scm_list_1 (orig_str)); - - scm_i_pthread_mutex_lock (&stringbuf_write_mutex); - if (STRINGBUF_SHARED (buf)) - { - /* Clone the stringbuf. */ - size_t len = STRING_LENGTH (str); - SCM new_buf; - - scm_i_pthread_mutex_unlock (&stringbuf_write_mutex); - - if (scm_i_is_narrow_string (str)) - { - new_buf = make_stringbuf (len); - memcpy (STRINGBUF_CHARS (new_buf), - STRINGBUF_CHARS (buf) + STRING_START (str), len); - - } - else - { - new_buf = make_wide_stringbuf (len); - u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (new_buf), - (scm_t_uint32 *) (STRINGBUF_WIDE_CHARS (buf) - + STRING_START (str)), len); - } - - SET_STRING_STRINGBUF (str, new_buf); - start -= STRING_START (str); - - /* FIXME: The following operations are not atomic, so other threads - looking at STR may see an inconsistent state. Nevertheless it can't - hurt much since (i) accessing STR while it is being mutated can't - yield a crash, and (ii) concurrent accesses to STR should be - protected by a mutex at the application level. The latter may not - apply when STR != ORIG_STR, though. */ - SET_STRING_START (str, 0); - SET_STRING_STRINGBUF (str, new_buf); - - buf = new_buf; - - scm_i_pthread_mutex_lock (&stringbuf_write_mutex); - } + scm_i_string_ensure_mutable_x (orig_str); return orig_str; } @@ -661,7 +626,6 @@ scm_i_string_writable_wide_chars (SCM str) void scm_i_string_stop_writing (void) { - scm_i_pthread_mutex_unlock (&stringbuf_write_mutex); } /* Return the Xth character of STR as a UCS-4 codepoint. */ @@ -768,42 +732,10 @@ scm_i_make_symbol (SCM name, scm_t_bits flags, unsigned long hash, SCM props) { SCM buf; - size_t start = STRING_START (name); size_t length = STRING_LENGTH (name); - if (IS_SH_STRING (name)) - { - name = SH_STRING_STRING (name); - start += STRING_START (name); - } + name = scm_i_substring_copy (name, 0, length); buf = STRING_STRINGBUF (name); - - if (start == 0 && length == STRINGBUF_LENGTH (buf)) - { - /* reuse buf. */ - scm_i_pthread_mutex_lock (&stringbuf_write_mutex); - SET_STRINGBUF_SHARED (buf); - scm_i_pthread_mutex_unlock (&stringbuf_write_mutex); - } - else - { - /* make new buf. */ - if (scm_i_is_narrow_string (name)) - { - SCM new_buf = make_stringbuf (length); - memcpy (STRINGBUF_CHARS (new_buf), - STRINGBUF_CHARS (buf) + start, length); - buf = new_buf; - } - else - { - SCM new_buf = make_wide_stringbuf (length); - u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (new_buf), - (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf) + start, - length); - buf = new_buf; - } - } return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf), (scm_t_bits) hash, SCM_UNPACK (props)); } @@ -882,9 +814,6 @@ SCM scm_i_symbol_substring (SCM sym, size_t start, size_t end) { SCM buf = SYMBOL_STRINGBUF (sym); - scm_i_pthread_mutex_lock (&stringbuf_write_mutex); - SET_STRINGBUF_SHARED (buf); - scm_i_pthread_mutex_unlock (&stringbuf_write_mutex); return scm_double_cell (RO_STRING_TAG, SCM_UNPACK (buf), (scm_t_bits)start, (scm_t_bits) end - start); } @@ -921,8 +850,8 @@ SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, (SCM str), "A new string containing this string's stringbuf's characters\n" "@item stringbuf-length\n" "The number of characters in this stringbuf\n" - "@item stringbuf-shared\n" - "@code{#t} if this stringbuf is shared\n" + "@item stringbuf-mutable\n" + "@code{#t} if this stringbuf is mutable\n" "@item stringbuf-wide\n" "@code{#t} if this stringbuf's characters are stored in a\n" "32-bit buffer, or @code{#f} if they are stored in an 8-bit\n" @@ -984,11 +913,11 @@ SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, (SCM str), } e7 = scm_cons (scm_from_latin1_symbol ("stringbuf-length"), scm_from_size_t (STRINGBUF_LENGTH (buf))); - if (STRINGBUF_SHARED (buf)) - e8 = scm_cons (scm_from_latin1_symbol ("stringbuf-shared"), + if (STRINGBUF_MUTABLE (buf)) + e8 = scm_cons (scm_from_latin1_symbol ("stringbuf-mutable"), SCM_BOOL_T); else - e8 = scm_cons (scm_from_latin1_symbol ("stringbuf-shared"), + e8 = scm_cons (scm_from_latin1_symbol ("stringbuf-mutable"), SCM_BOOL_F); if (STRINGBUF_WIDE (buf)) e9 = scm_cons (scm_from_latin1_symbol ("stringbuf-wide"), @@ -1015,8 +944,8 @@ SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0, (SCM sym), "A new string containing this symbols's stringbuf's characters\n" "@item stringbuf-length\n" "The number of characters in this stringbuf\n" - "@item stringbuf-shared\n" - "@code{#t} if this stringbuf is shared\n" + "@item stringbuf-mutable\n" + "@code{#t} if this stringbuf is mutable\n" "@item stringbuf-wide\n" "@code{#t} if this stringbuf's characters are stored in a\n" "32-bit buffer, or @code{#f} if they are stored in an 8-bit\n" @@ -1057,11 +986,11 @@ SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0, (SCM sym), } e5 = scm_cons (scm_from_latin1_symbol ("stringbuf-length"), scm_from_size_t (STRINGBUF_LENGTH (buf))); - if (STRINGBUF_SHARED (buf)) - e6 = scm_cons (scm_from_latin1_symbol ("stringbuf-shared"), + if (STRINGBUF_MUTABLE (buf)) + e6 = scm_cons (scm_from_latin1_symbol ("stringbuf-mutable"), SCM_BOOL_T); else - e6 = scm_cons (scm_from_latin1_symbol ("stringbuf-shared"), + e6 = scm_cons (scm_from_latin1_symbol ("stringbuf-mutable"), SCM_BOOL_F); if (STRINGBUF_WIDE (buf)) e7 = scm_cons (scm_from_latin1_symbol ("stringbuf-wide"), diff --git a/libguile/strings.h b/libguile/strings.h index 882e7ce64..77690ce67 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -182,8 +182,8 @@ SCM_API SCM scm_makfromstrs (int argc, char **argv); #define scm_tc7_ro_string (scm_tc7_string + 0x200) /* Flags for shared and wide strings. */ -#define SCM_I_STRINGBUF_F_SHARED 0x100 #define SCM_I_STRINGBUF_F_WIDE 0x400 +#define SCM_I_STRINGBUF_F_MUTABLE 0x800 SCM_INTERNAL void scm_i_print_stringbuf (SCM exp, SCM port, scm_print_state *pstate); diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 226a2233e..aa803acaf 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -1385,13 +1385,10 @@ should be .data or .rodata), and return the resulting linker object. (modulo (- alignment (modulo address alignment)) alignment))) (define tc7-vector 13) - (define stringbuf-shared-flag #x100) (define stringbuf-wide-flag #x400) (define tc7-stringbuf 39) - (define tc7-narrow-stringbuf - (+ tc7-stringbuf stringbuf-shared-flag)) - (define tc7-wide-stringbuf - (+ tc7-stringbuf stringbuf-shared-flag stringbuf-wide-flag)) + (define tc7-narrow-stringbuf tc7-stringbuf) + (define tc7-wide-stringbuf (+ tc7-stringbuf stringbuf-wide-flag)) (define tc7-ro-string (+ 21 #x200)) (define tc7-program 69) (define tc7-bytevector 77) diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test index 66c8a6b95..b404253ce 100644 --- a/test-suite/tests/strings.test +++ b/test-suite/tests/strings.test @@ -111,27 +111,45 @@ (not (eq? (assq-ref (%string-dump s2) 'shared) s1)))) - (pass-if "ASCII substrings share stringbufs before copy-on-write" + (pass-if "ASCII substrings immutable before copy-on-write" (let* ((s1 "foobar") (s2 (substring s1 0 3))) - (assq-ref (%string-dump s1) 'stringbuf-shared))) + (and (not (assq-ref (%string-dump s1) 'stringbuf-mutable)) + (not (assq-ref (%string-dump s2) 'stringbuf-mutable))))) - (pass-if "BMP substrings share stringbufs before copy-on-write" + (pass-if "BMP substrings immutable before copy-on-write" (let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105") (s2 (substring s1 0 3))) - (assq-ref (%string-dump s1) 'stringbuf-shared))) + (and (not (assq-ref (%string-dump s1) 'stringbuf-mutable)) + (not (assq-ref (%string-dump s2) 'stringbuf-mutable))))) - (pass-if "ASCII substrings don't share stringbufs after copy-on-write" + (pass-if "ASCII base string still immutable after copy-on-write" (let* ((s1 "foobar") (s2 (substring s1 0 3))) (string-set! s2 0 #\F) - (not (assq-ref (%string-dump s2) 'stringbuf-shared)))) + (and (not (assq-ref (%string-dump s1) 'stringbuf-mutable)) + (assq-ref (%string-dump s2) 'stringbuf-mutable)))) - (pass-if "BMP substrings don't share stringbufs after copy-on-write" + (pass-if "BMP base string still immutable after copy-on-write" (let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105") (s2 (substring s1 0 3))) (string-set! s2 0 #\F) - (not (assq-ref (%string-dump s2) 'stringbuf-shared)))) + (and (not (assq-ref (%string-dump s1) 'stringbuf-mutable)) + (assq-ref (%string-dump s2) 'stringbuf-mutable)))) + + (pass-if "ASCII substrings mutable after shared mutation" + (let* ((s1 "foobar") + (s2 (substring/shared s1 0 3))) + (string-set! s2 0 #\F) + (and (assq-ref (%string-dump s1) 'stringbuf-mutable) + (assq-ref (%string-dump s2) 'stringbuf-mutable)))) + + (pass-if "BMP substrings mutable after shared mutation" + (let* ((s1 "\u0100\u0101\u0102\u0103\u0104\u0105") + (s2 (substring/shared s1 0 3))) + (string-set! s2 0 #\F) + (and (assq-ref (%string-dump s1) 'stringbuf-mutable) + (assq-ref (%string-dump s2) 'stringbuf-mutable)))) (with-test-prefix "encodings" From 60035b66c795ffe82800b6400e5aba5b3d6fd5ca Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 17 Feb 2017 10:54:21 +0100 Subject: [PATCH 697/865] Revert "Cheaper fluid-ref cache" This reverts commit cd3ff33a31c51612f2247bdb15ecbe92d7da1310. --- libguile/cache-internal.h | 6 +----- libguile/fluids.c | 30 +++++++++++++----------------- 2 files changed, 14 insertions(+), 22 deletions(-) diff --git a/libguile/cache-internal.h b/libguile/cache-internal.h index 88bb24af0..fc1e3c139 100644 --- a/libguile/cache-internal.h +++ b/libguile/cache-internal.h @@ -37,7 +37,6 @@ struct scm_cache_entry { scm_t_bits key; scm_t_bits value; - int needs_flush; }; #define SCM_CACHE_SIZE 8 @@ -74,7 +73,6 @@ scm_cache_evict_1 (struct scm_cache *cache, struct scm_cache_entry *evicted) sizeof (cache->entries[0]) * idx); cache->entries[0].key = 0; cache->entries[0].value = 0; - cache->entries[0].needs_flush = 0; } static inline struct scm_cache_entry* @@ -91,7 +89,7 @@ scm_cache_lookup (struct scm_cache *cache, SCM k) static inline void scm_cache_insert (struct scm_cache *cache, SCM k, SCM v, - struct scm_cache_entry *evicted, int needs_flush) + struct scm_cache_entry *evicted) { struct scm_cache_entry *entry; @@ -101,7 +99,6 @@ scm_cache_insert (struct scm_cache *cache, SCM k, SCM v, if (entry->key == SCM_UNPACK (k)) { entry->value = SCM_UNPACK (v); - entry->needs_flush = needs_flush; return; } memmove (cache->entries, @@ -109,7 +106,6 @@ scm_cache_insert (struct scm_cache *cache, SCM k, SCM v, (entry - cache->entries) * sizeof (*entry)); entry->key = SCM_UNPACK (k); entry->value = SCM_UNPACK (v); - entry->needs_flush = needs_flush; } #endif /* SCM_CACHE_INTERNAL_H */ diff --git a/libguile/fluids.c b/libguile/fluids.c index 5b42ccb6d..7daad7781 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -114,11 +114,10 @@ restore_dynamic_state (SCM saved, scm_t_dynamic_state *state) { entry->key = SCM_UNPACK (SCM_CAAR (saved)); entry->value = SCM_UNPACK (SCM_CDAR (saved)); - entry->needs_flush = 1; saved = scm_cdr (saved); } else - entry->key = entry->value = entry->needs_flush = 0; + entry->key = entry->value = 0; } state->values = saved; state->has_aliased_values = 1; @@ -134,7 +133,9 @@ save_dynamic_state (scm_t_dynamic_state *state) struct scm_cache_entry *entry = &state->cache.entries[slot]; SCM key = SCM_PACK (entry->key); SCM value = SCM_PACK (entry->value); - if (entry->key && entry->needs_flush) + if (entry->key && + !scm_is_eq (scm_weak_table_refq (state->values, key, SCM_UNDEFINED), + value)) { if (state->has_aliased_values) saved = scm_acons (key, value, saved); @@ -248,8 +249,7 @@ scm_is_fluid (SCM obj) } static void -fluid_set_x (scm_t_dynamic_state *dynamic_state, SCM fluid, SCM value, - int needs_flush) +fluid_set_x (scm_t_dynamic_state *dynamic_state, SCM fluid, SCM value) { struct scm_cache_entry *entry; struct scm_cache_entry evicted = { 0, 0 }; @@ -257,17 +257,13 @@ fluid_set_x (scm_t_dynamic_state *dynamic_state, SCM fluid, SCM value, entry = scm_cache_lookup (&dynamic_state->cache, fluid); if (scm_is_eq (SCM_PACK (entry->key), fluid)) { - if (SCM_UNPACK (value) != entry->value) - { - entry->needs_flush = 1; - entry->value = SCM_UNPACK (value); - } + entry->value = SCM_UNPACK (value); return; } - scm_cache_insert (&dynamic_state->cache, fluid, value, &evicted, 1); + scm_cache_insert (&dynamic_state->cache, fluid, value, &evicted); - if (evicted.key != 0 && evicted.needs_flush) + if (evicted.key != 0) { fluid = SCM_PACK (evicted.key); value = SCM_PACK (evicted.value); @@ -304,7 +300,7 @@ fluid_ref (scm_t_dynamic_state *dynamic_state, SCM fluid) val = SCM_I_FLUID_DEFAULT (fluid); /* Cache this lookup. */ - fluid_set_x (dynamic_state, fluid, val, 0); + fluid_set_x (dynamic_state, fluid, val); } return val; @@ -359,7 +355,7 @@ SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0, #define FUNC_NAME s_scm_fluid_set_x { SCM_VALIDATE_FLUID (1, fluid); - fluid_set_x (SCM_I_CURRENT_THREAD->dynamic_state, fluid, value, 1); + fluid_set_x (SCM_I_CURRENT_THREAD->dynamic_state, fluid, value); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -373,7 +369,7 @@ SCM_DEFINE (scm_fluid_unset_x, "fluid-unset!", 1, 0, 0, suite demands it, but I would prefer not to. */ SCM_VALIDATE_FLUID (1, fluid); SCM_SET_CELL_OBJECT_1 (fluid, SCM_UNDEFINED); - fluid_set_x (SCM_I_CURRENT_THREAD->dynamic_state, fluid, SCM_UNDEFINED, 1); + fluid_set_x (SCM_I_CURRENT_THREAD->dynamic_state, fluid, SCM_UNDEFINED); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -401,7 +397,7 @@ void scm_swap_fluid (SCM fluid, SCM value_box, scm_t_dynamic_state *dynstate) { SCM val = fluid_ref (dynstate, fluid); - fluid_set_x (dynstate, fluid, SCM_VARIABLE_REF (value_box), 1); + fluid_set_x (dynstate, fluid, SCM_VARIABLE_REF (value_box)); SCM_VARIABLE_SET (value_box, val); } @@ -478,7 +474,7 @@ swap_fluid (SCM data) scm_t_dynamic_state *dynstate = SCM_I_CURRENT_THREAD->dynamic_state; SCM f = SCM_CAR (data); SCM t = fluid_ref (dynstate, f); - fluid_set_x (dynstate, f, SCM_CDR (data), 1); + fluid_set_x (dynstate, f, SCM_CDR (data)); SCM_SETCDR (data, t); } From 2864f11d3415c650d9e80f8e7787e4df81dcc7e9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 17 Feb 2017 11:01:19 +0100 Subject: [PATCH 698/865] Bump fluid cache size to 16 entries * libguile/cache-internal.h (SCM_CACHE_SIZE): Bump to 16. It seems that a thread accesses more than 8 fluids by default (%stacks, the exception handler, current ports, current-fiber, port read/write waiters) which leads every fiber to cause cache eviction and copying the value table, which is a bottleneck. Instead just bump this cache size. (scm_cache_lookup): Update unrolled search. --- libguile/cache-internal.h | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/cache-internal.h b/libguile/cache-internal.h index fc1e3c139..4c1732f81 100644 --- a/libguile/cache-internal.h +++ b/libguile/cache-internal.h @@ -39,7 +39,7 @@ struct scm_cache_entry scm_t_bits value; }; -#define SCM_CACHE_SIZE 8 +#define SCM_CACHE_SIZE 16 struct scm_cache { @@ -81,6 +81,7 @@ scm_cache_lookup (struct scm_cache *cache, SCM k) scm_t_bits k_bits = SCM_UNPACK (k); struct scm_cache_entry *entry = cache->entries; /* Unrolled binary search, compiled to branchless cmp + cmov chain. */ + if (entry[8].key <= k_bits) entry += 8; if (entry[4].key <= k_bits) entry += 4; if (entry[2].key <= k_bits) entry += 2; if (entry[1].key <= k_bits) entry += 1; From 9ee21f3e97ae65b79a861d076e3ea8f73508bda8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 17 Feb 2017 11:29:31 +0100 Subject: [PATCH 699/865] Minor make-string optimization * libguile/strings.c (STRINGBUF_SET_MUTABLE): New helper. (scm_i_string_ensure_mutable_x): Use new helper. (scm_make_string): Mark stringbuf as mutable. --- libguile/strings.c | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/libguile/strings.c b/libguile/strings.c index e460a938d..8d0aa453f 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -83,6 +83,10 @@ SCM_SYMBOL (sym_error, "error"); #define STRINGBUF_WIDE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_WIDE) #define STRINGBUF_MUTABLE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_MUTABLE) + +#define STRINGBUF_SET_MUTABLE(buf) \ + SCM_SET_CELL_WORD_0 (buf, SCM_CELL_WORD_0 (buf) | STRINGBUF_F_MUTABLE) + #define STRINGBUF_CONTENTS(buf) ((void *) \ SCM_CELL_OBJECT_LOC (buf, \ STRINGBUF_HEADER_SIZE)) @@ -433,8 +437,7 @@ scm_i_string_ensure_mutable_x (SCM str) memcpy (STRINGBUF_CHARS (new_buf), STRINGBUF_CHARS (buf), len); } - SCM_SET_CELL_WORD_0 (new_buf, - SCM_CELL_WORD_0 (new_buf) | STRINGBUF_F_MUTABLE); + STRINGBUF_SET_MUTABLE (new_buf); SET_STRING_STRINGBUF (str, new_buf); } } @@ -1119,7 +1122,12 @@ SCM_DEFINE (scm_make_string, "make-string", 1, 1, 0, "of the string are all set to @code{#\nul}.") #define FUNC_NAME s_scm_make_string { - return scm_c_make_string (scm_to_size_t (k), chr); + SCM ret = scm_c_make_string (scm_to_size_t (k), chr); + /* Given that make-string is mostly used by Scheme to prepare a + mutable string buffer, let's go ahead and mark this as mutable to + avoid a copy when this buffer is next written to. */ + STRINGBUF_SET_MUTABLE (STRING_STRINGBUF (ret)); + return ret; } #undef FUNC_NAME From bfa6c401ceb418f63ba30e12ac73b34b0835ac88 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 17 Feb 2017 11:58:22 +0100 Subject: [PATCH 700/865] Speed up number->string * libguile/numbers.c (scm_number_to_string): Use scm_from_latin1_string where appropriate. Avoids mucking about with iconv. --- libguile/numbers.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index bc930af3b..07170d922 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -5623,7 +5623,7 @@ SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0, { char num_buf [SCM_INTBUFLEN]; size_t length = scm_iint2str (SCM_I_INUM (n), base, num_buf); - return scm_from_locale_stringn (num_buf, length); + return scm_from_latin1_stringn (num_buf, length); } else if (SCM_BIGP (n)) { @@ -5640,13 +5640,13 @@ SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0, else if (SCM_FRACTIONP (n)) { return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n), radix), - scm_from_locale_string ("/"), + scm_from_latin1_string ("/"), scm_number_to_string (SCM_FRACTION_DENOMINATOR (n), radix))); } else if (SCM_INEXACTP (n)) { char num_buf [FLOBUFLEN]; - return scm_from_locale_stringn (num_buf, iflo2str (n, num_buf, base)); + return scm_from_latin1_stringn (num_buf, iflo2str (n, num_buf, base)); } else SCM_WRONG_TYPE_ARG (1, n); From db502f118e1b89dcfa8b91da99c6cce8ed23de35 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 18 Feb 2017 09:21:04 +0100 Subject: [PATCH 701/865] Fold 2.1.6 NEWS changes * NEWS: Fold 2.1.6 changes into main 2.2 NEWS. --- NEWS | 62 ++++++++++++++++-------------------------------------------- 1 file changed, 16 insertions(+), 46 deletions(-) diff --git a/NEWS b/NEWS index 46b09b9ae..1c7111f27 100644 --- a/NEWS +++ b/NEWS @@ -8,57 +8,12 @@ Please send Guile bug reports to bug-guile@gnu.org. Changes in 2.1.7 (changes since the 2.1.6 alpha release): -* New deprecations - -** `SCM_FDES_RANDOM_P' - -Instead, use `lseek (fd, 0, SEEK_CUR)' directly. - -* FIXME fold in 2.1.6 changes to main NEWS - - -Changes in 2.1.6 (changes since the 2.1.5 alpha release): - * New interfaces -** suspendable-continuation? - -This predicate returns true if the delimited continuation captured by -aborting to a prompt would be able to be resumed. See "Prompt -Primitives" in the manual for more. - -** scm_c_prepare_to_wait_on_fd, scm_c_prepare_to_wait_on_cond, -** scm_c_wait_finished - -See "Interrupts" in the manual for more. - * Performance improvements - -** Support unboxed floating-point comparisons - -Thanks to David Thompson for this work. - +* New deprecations * Incompatible changes - -** Rename new array functions - -See "Arrays as arrays of arrays" in the manual for more. - * Bug fixes -** `scm_gc_warn_proc' writes directly to stderr - -The garbage collector sometimes has warnings to display to the user. -Before, Guile would see if the current warning port was a file port, and -in that case write the warning to that file, and otherwise default to -stderr. Now Guile just writes to stderr, fixing a bug where determining -the current warning port would allocate and thus deadlock as the GC -warnings are issued with the GC lock held. - -** Fix miscompilation in significant-bits computation for loop vars -** Fix many threading bugs -** Fix macOS portability bugs -Thanks to Matt Wette! - Previous changes in 2.1.x (changes since the 2.0.x series): @@ -316,6 +271,17 @@ See "R6RS Transcoders" in the manual. See "Atomics" in the manual. +** suspendable-continuation? + +This predicate returns true if the delimited continuation captured by +aborting to a prompt would be able to be resumed. See "Prompt +Primitives" in the manual for more. + +** scm_c_prepare_to_wait_on_fd, scm_c_prepare_to_wait_on_cond, +** scm_c_wait_finished + +See "Interrupts" in the manual for more. + ** File descriptor finalizers See "Ports and File Descriptors" in the manual. @@ -816,6 +782,10 @@ scm_t_debug_info', `scm_pure_generic_p', `SCM_PUREGENERICP', Instead, use the symbol values `none', `line', or `block', respectively, as arguments to the `setvbuf' function. +** `SCM_FDES_RANDOM_P' + +Instead, use `lseek (fd, 0, SEEK_CUR)' directly. + ** Arbiters Arbiters were an experimental mutual exclusion facility from 20 years From c288d396fc92db63bf1a040975d5e5f47060bd9e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 18 Feb 2017 09:53:26 +0100 Subject: [PATCH 702/865] Update NEWS for 2.1.7. * NEWS: Update. --- NEWS | 76 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 74 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index 1c7111f27..4dc7173af 100644 --- a/NEWS +++ b/NEWS @@ -8,12 +8,84 @@ Please send Guile bug reports to bug-guile@gnu.org. Changes in 2.1.7 (changes since the 2.1.6 alpha release): -* New interfaces +* Notable changes + +** Web server now suspendable + +The web server's implementation has been slightly modified in order to +allow coroutines to suspend and resume around it when it would block on +input or output. See "Non-Blocking IO" in the manual for more. + +** Add support for arrays in `truncated-print'. + +See "Pretty Printing" in the manual. Thanks to Daniel Llorens. + +** Gnulib update + +Gnulib has been updated to v0.1-1157-gb03f418. + * Performance improvements + +** Stringbufs immutable by default + +Stringbufs are backing buffers for strings, and are not user-visible. +Calling "substring" on a base string will result in a new string that +shares state with the base string's stringbuf. A subsequent attempt to +mutate the substring will first copy a fresh stringbuf; that is, Guile's +strings are copy-on-write. There is also "substring/shared" which +allows mutations to be shared between substring and base string; in that +case the stringbuf is modified directly. + +It used to be that mutating a string would have to take a global lock, +to ensure that no one was concurrently taking a copy-on-write substring +of that string. That is, stringbufs were mutable by default and +transitioning to immutable could happen at any time. + +This situation has been reversed: stringbufs are now immutable by +default and attempts to mutate an immutable stringbuf will copy a fresh +stringbuf and mark it as mutable. This way we can avoid the global +lock. This change likely speeds up common "substring" workloads, though +it make make the first in-place mutation on an immutable string take +more time because it has to copy a fresh backing stringbuf. + +** Speed up number->string + +** `accept' now takes optional flags argument + +These flags can include `SOCK_NONBLOCK' and `SOCK_CLOEXEC', indicating +options to apply to the returned socket, potentially removing the need +for additional system calls to set these options. See "Network Sockets +and Communication" in the manual, for more. + * New deprecations -* Incompatible changes + +** `SCM_FDES_RANDOM_P' + +Instead, use `lseek (fd, 0, SEEK_CUR)' directly. + * Bug fixes +** Fix too-broad capture of dynamic stack by delimited continuations + +Guile was using explicit stacks to represent, for example, the chain of +current exception handlers. This means that a delimited continuation +that captured a "catch" expression would capture the whole stack of +exception handlers, not just the exception handler added by the "catch". +This led to strangeness when resuming the continuation in some other +context like other threads; "throw" could see an invalid stack of +exception handlers. This has been fixed by the addition of the new +"fluid-ref*" procedure that can access older values of fluids; in this +way the exception handler stack is now implicit. See "Fluids and +Dynamic States" in the manual, for more on fluid-ref*. + +** Fix bug comparing unboxed floating-point values (#25492) + +Thanks to Daniel Llorens. + +** Fix crasher bugs for multiple threads writing to same port + +** Fix bug resuming partial continuations that contain prompts + Previous changes in 2.1.x (changes since the 2.0.x series): From c58c143f31fe4c1717fc8846a8681de2bb4b3869 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 18 Feb 2017 10:17:17 +0100 Subject: [PATCH 703/865] Guile 2.1.7. * GUILE-VERSION: Bump to 2.1.7. --- GUILE-VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index b46ba2887..84848c922 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -3,7 +3,7 @@ # Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'. GUILE_MAJOR_VERSION=2 GUILE_MINOR_VERSION=1 -GUILE_MICRO_VERSION=6 +GUILE_MICRO_VERSION=7 GUILE_EFFECTIVE_VERSION=2.2 From d0811644f6c8b7bd7dd812b91e53dc3b8b153d12 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 19 Feb 2017 11:56:24 +0100 Subject: [PATCH 704/865] Fix flonum/complex type inference. * module/language/cps/types.scm (define-binary-result!): Arithmetic where one argument is a flonum may produce a complex. * test-suite/tests/compiler.test: Add test. --- module/language/cps/types.scm | 8 ++++++-- test-suite/tests/compiler.test | 12 ++++++++++++ 2 files changed, 18 insertions(+), 2 deletions(-) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index c7e42117c..a66e4b800 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -970,11 +970,15 @@ minimum, and maximum." ;; One input not a number. Perhaps we end up dispatching to ;; GOOPS. (define! result &all-types -inf.0 +inf.0)) - ;; Complex and floating-point numbers are contagious. + ;; Complex numbers are contagious. ((or (eqv? a-type &complex) (eqv? b-type &complex)) (define! result &complex -inf.0 +inf.0)) ((or (eqv? a-type &flonum) (eqv? b-type &flonum)) - (define! result &flonum min* max*)) + ;; If one argument is a flonum, the result will be flonum or + ;; possibly complex. + (let ((result-type (logand (logior a-type b-type) + (logior &complex &flonum)))) + (define! result result-type min* max*))) ;; Exact integers are closed under some operations. ((and closed? (eqv? a-type &exact-integer) (eqv? b-type &exact-integer)) (define! result &exact-integer min* max*)) diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test index 582ce6e28..4f644f339 100644 --- a/test-suite/tests/compiler.test +++ b/test-suite/tests/compiler.test @@ -239,3 +239,15 @@ (begin (test-proc) #t))) + +(with-test-prefix "flonum inference" + (define test-code + '(lambda (x) (let ((y (if x 0.0 0.0+0.0i))) (+ y 0.0)))) + (define test-proc #f) + (pass-if "compiling test works" + (begin + (set! test-proc (compile test-code)) + (procedure? test-proc))) + + (pass-if-equal "test flonum" 0.0 (test-proc #t)) + (pass-if-equal "test complex" 0.0+0.0i (test-proc #f))) From 36023a0d2e14f02f7370c899b52e9803bc8c0078 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 21 Feb 2017 22:01:45 +0100 Subject: [PATCH 705/865] Conditionally define SOCK_CLOEXEC, SOCK_NONBLOCK * libguile/socket.c (scm_init_socket): Conditionally define SOCK_CLOEXEC and SOCK_NONBLOCK. Fixes compilation on macOS. --- libguile/socket.c | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/libguile/socket.c b/libguile/socket.c index 64df64f4b..71c17e892 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -1653,10 +1653,13 @@ scm_init_socket () scm_c_define ("SOCK_RDM", scm_from_int (SOCK_RDM)); #endif - /* accept4 flags. No ifdef as accept4 has a gnulib - implementation. */ + /* accept4 flags. */ +#ifdef SOCK_CLOEXEC scm_c_define ("SOCK_CLOEXEC", scm_from_int (SOCK_CLOEXEC)); +#endif +#ifdef SOCK_NONBLOCK scm_c_define ("SOCK_NONBLOCK", scm_from_int (SOCK_NONBLOCK)); +#endif /* setsockopt level. From c4b0491e91a7c4d4a2b89511b37eae61e79de47a Mon Sep 17 00:00:00 2001 From: Matt Wette Date: Tue, 21 Feb 2017 22:07:39 +0100 Subject: [PATCH 706/865] Fix make-polar signedness of zeros on macOS * configure.ac: Check for __sincos. * libguile/numbers.c (scm_c_make_polar): Fall back to __sincos if possible. Fixes zero signedness of make-polar on macOS. --- configure.ac | 3 ++- libguile/numbers.c | 2 ++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 020151911..8c90d3feb 100644 --- a/configure.ac +++ b/configure.ac @@ -1152,8 +1152,9 @@ AC_REPLACE_FUNCS([strerror memmove]) # asinh, acosh, atanh, trunc - C99 standard, generally not available on # older systems # sincos - GLIBC extension +# __sincos - APPLE extension # -AC_CHECK_FUNCS(asinh acosh atanh copysign finite sincos trunc) +AC_CHECK_FUNCS(asinh acosh atanh copysign finite sincos __sincos trunc) # C99 specifies isinf and isnan as macros. # HP-UX provides only macros, no functions. diff --git a/libguile/numbers.c b/libguile/numbers.c index 07170d922..b926d2472 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -9109,6 +9109,8 @@ scm_c_make_polar (double mag, double ang) details. */ #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE) sincos (ang, &s, &c); +#elif (defined HAVE___SINCOS) + __sincos (ang, &s, &c); #else s = sin (ang); c = cos (ang); From 5333642b71a35d1a181a9cf008caefe77b44b2a0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 21 Feb 2017 22:12:18 +0100 Subject: [PATCH 707/865] Use labs instead of abs where needed * libguile/numbers.c (log_of_fraction): Use labs instead of abs on longs. Thanks to Matt Wette for the tip. --- libguile/numbers.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index b926d2472..99b564e95 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -9953,7 +9953,7 @@ log_of_fraction (SCM n, SCM d) long n_size = scm_to_long (scm_integer_length (n)); long d_size = scm_to_long (scm_integer_length (d)); - if (abs (n_size - d_size) > 1) + if (labs (n_size - d_size) > 1) return (scm_difference (log_of_exact_integer (n), log_of_exact_integer (d))); else if (scm_is_false (scm_negative_p (n))) From 4dcc97288dc2c43ea9f2e61fdb1357cec3936fc9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 22 Feb 2017 22:20:07 +0100 Subject: [PATCH 708/865] Fix compute-frame-sizes for case-lambda jumps * module/system/vm/frame.scm (compute-frame-sizes): Fix for jumps to the next arity. --- module/system/vm/frame.scm | 3 +++ 1 file changed, 3 insertions(+) diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index c9090ef36..b699590f6 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -103,6 +103,9 @@ (define (find-idx n diff) (let lp ((n n) (diff diff)) (cond + ((= n (vector-length parsed)) + ;; Possible for jumps to alternate arities. + #f) ((negative? diff) (lp (1- n) (+ diff (vector-ref parsed (1- n))))) ((positive? diff) From c7fb87cd6e8ccf7e2a47c715a1d4a6cf82d846a3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 22 Feb 2017 23:07:27 +0100 Subject: [PATCH 709/865] Fix multi-arity dispatch in GOOPS * module/oop/goops.scm (multiple-arity-dispatcher): Fix dispatch for max-arity+1 when a generic is already in multiple-arity dispatch. Fixes #24454. * test-suite/tests/goops.test ("dispatch"): Add test. --- module/oop/goops.scm | 2 +- test-suite/tests/goops.test | 11 +++++++++++ 2 files changed, 12 insertions(+), 1 deletion(-) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index e4f51600e..ece03c6e0 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -1333,7 +1333,7 @@ function." #`(case-lambda #,@(build-clauses #'(arg ...)) (args (apply miss args))))))) - (arity-case (vector-length fv) 20 dispatch + (arity-case (1- (vector-length fv)) 20 dispatch (lambda args (let ((nargs (length args))) (if (< nargs (vector-length fv)) diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test index 730aabb31..259eba84b 100644 --- a/test-suite/tests/goops.test +++ b/test-suite/tests/goops.test @@ -690,3 +690,14 @@ (class () (slot) #:name ' #:static-slot-allocation? #t)) (pass-if-equal "non-static subclass" '(a d) (map slot-definition-name (class-slots (class () (d) #:name ')))))) + +(with-test-prefix "dispatch" + (pass-if-equal "multi-arity dispatch" 0 + (eval '(begin + (define-method (dispatch (x ) . args) 0) + (dispatch 1) + (dispatch 1 2) + ;; By now "dispatch" is forced into multi-arity mode. Test + ;; that the multi-arity dispatcher works: + (dispatch 1 2 3)) + (current-module)))) From 7242ca566f44ba498b9c3ecacb996182ab57cdce Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 23 Feb 2017 09:29:31 +0100 Subject: [PATCH 710/865] Fix typo in old NEWS. * NEWS: Fix typo. --- NEWS | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 4dc7173af..21268135a 100644 --- a/NEWS +++ b/NEWS @@ -1055,7 +1055,7 @@ if you defined a class C: And now you define a subclass, intending to provide an #:init-value for the slot A: - (define-class D () + (define-class D (A) (a #:init-value 42)) Really what you have done is define in D a new slot with the same name, From b6d3ab6c0f912c48463b597ccfa18879f550cf50 Mon Sep 17 00:00:00 2001 From: Freja Nordsiek Date: Mon, 10 Oct 2016 15:50:19 +0700 Subject: [PATCH 711/865] Fixed specific version of guile search in autoconf macro GUILE_PROGS. * meta/guile.m4 (GUILE_PROGS): Search for guile with suffixes first ('-X.Y' and 'X.Y' where X.Y denotes the version) before searching for guile with no suffix. Patch co-authored by Andy Wingo. --- meta/guile.m4 | 30 ++++++++++++++++++++++-------- 1 file changed, 22 insertions(+), 8 deletions(-) diff --git a/meta/guile.m4 b/meta/guile.m4 index 9fd4f1a9f..2e4f3dc3d 100644 --- a/meta/guile.m4 +++ b/meta/guile.m4 @@ -181,7 +181,12 @@ AC_DEFUN([GUILE_SITE_DIR], # # This macro looks for programs @code{guile} and @code{guild}, setting # variables @var{GUILE} and @var{GUILD} to their paths, respectively. -# If @code{guile} is not found, signal an error. +# The macro will attempt to find @code{guile} with the suffix of +# @code{-X.Y}, followed by looking for it with the suffix @code{X.Y}, and +# then fall back to looking for @code{guile} with no suffix. If +# @code{guile} is still not found, signal an error. The suffix, if any, +# that was required to find @code{guile} will be used for @code{guild} +# as well. # # By default, this macro will search for the latest stable version of # Guile (e.g. 2.0). x.y or x.y.z versions can be specified. If an older @@ -198,16 +203,25 @@ AC_DEFUN([GUILE_SITE_DIR], # The variables are marked for substitution, as by @code{AC_SUBST}. # AC_DEFUN([GUILE_PROGS], - [AC_PATH_PROG(GUILE,guile) - _guile_required_version="m4_default([$1], [$GUILE_EFFECTIVE_VERSION])" + [_guile_required_version="m4_default([$1], [$GUILE_EFFECTIVE_VERSION])" if test -z "$_guile_required_version"; then _guile_required_version=2.0 fi - if test "$GUILE" = "" ; then + + _guile_candidates=guile + _tmp= + for v in `echo "$_guile_required_version" | tr . ' '`; do + if test -n "$_tmp"; then _tmp=.$_tmp; fi + _tmp=$v$_tmp + _guile_candidates="guile-$_tmp guile$_tmp $_guile_candidates" + done + + AC_PATH_PROGS(GUILE,[$_guile_candidates]) + if test -z "$GUILE"; then AC_MSG_ERROR([guile required but not found]) fi - AC_SUBST(GUILE) + _guile_suffix=`echo "$GUILE" | sed -e 's,^.*/guile\(.*\)$,\1,'` _guile_effective_version=`$GUILE -c "(display (effective-version))"` if test -z "$GUILE_EFFECTIVE_VERSION"; then GUILE_EFFECTIVE_VERSION=$_guile_effective_version @@ -246,15 +260,15 @@ AC_DEFUN([GUILE_PROGS], fi AC_MSG_RESULT([$_guile_prog_version]) - AC_PATH_PROG(GUILD,guild) + AC_PATH_PROG(GUILD,[guild$_guile_suffix]) AC_SUBST(GUILD) - AC_PATH_PROG(GUILE_CONFIG,guile-config) + AC_PATH_PROG(GUILE_CONFIG,[guile-config$_guile_suffix]) AC_SUBST(GUILE_CONFIG) if test -n "$GUILD"; then GUILE_TOOLS=$GUILD else - AC_PATH_PROG(GUILE_TOOLS,guile-tools) + AC_PATH_PROG(GUILE_TOOLS,[guile-tools$_guile_suffix]) fi AC_SUBST(GUILE_TOOLS) ]) From 23278d07deb31cbb028df4ad789fb9ad46a05ca2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 23 Feb 2017 11:37:06 +0100 Subject: [PATCH 712/865] Fix kfun parse-cps bug * module/language/cps.scm (parse-cps): Fix bug parsing kfun. --- module/language/cps.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/language/cps.scm b/module/language/cps.scm index b66bc38c0..5d4826990 100644 --- a/module/language/cps.scm +++ b/module/language/cps.scm @@ -271,7 +271,7 @@ (build-cont ($kreceive req rest k))) (('kargs names syms body) (build-cont ($kargs names syms ,(parse-cps body)))) - (('kfun src meta self ktail kclause) + (('kfun meta self ktail kclause) (build-cont ($kfun (src exp) meta self ktail kclause))) (('ktail) (build-cont ($ktail))) From f261eaf03a607a22f8092dc43592ee72190494a7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 23 Feb 2017 11:37:44 +0100 Subject: [PATCH 713/865] Fix guild compile --to=cps / --from=cps * module/language/cps/spec.scm (read-cps, write-cps): Fix CPS serialization and parsing, so that "guild compile" works with --to=cps and --from=cps. --- module/language/cps/spec.scm | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/module/language/cps/spec.scm b/module/language/cps/spec.scm index 7330885ab..e2c46d275 100644 --- a/module/language/cps/spec.scm +++ b/module/language/cps/spec.scm @@ -19,19 +19,33 @@ ;;; Code: (define-module (language cps spec) + #:use-module (ice-9 match) #:use-module (system base language) #:use-module (language cps) + #:use-module (language cps intmap) #:use-module (language cps compile-bytecode) #:export (cps)) +(define (read-cps port env) + (let lp ((out empty-intmap)) + (match (read port) + ((k exp) (lp (intmap-add! out k (parse-cps exp)))) + ((? eof-object?) + (if (eq? out empty-intmap) + the-eof-object + (persistent-intmap out)))))) + (define* (write-cps exp #:optional (port (current-output-port))) - (write (unparse-cps exp) port)) + (intmap-fold (lambda (k cps port) + (write (list k (unparse-cps cps)) port) + (newline port) + port) + exp port)) (define-language cps #:title "CPS Intermediate Language" - #:reader (lambda (port env) (read port)) + #:reader read-cps #:printer write-cps - #:parser parse-cps #:compilers `((bytecode . ,compile-bytecode)) #:for-humans? #f ) From f8dd4f67b5af9e80642a6b262f96049690a3e8bf Mon Sep 17 00:00:00 2001 From: "Diogo F. S. Ramos" Date: Sun, 26 Feb 2017 19:19:00 -0300 Subject: [PATCH 714/865] Explain why no native accessors for `s8' and `u8' exist * doc/ref/api-data.texi: Instead of saying it is obvious, explain why no native endianness accessors exist for the `s8' and `u8' variants. --- doc/ref/api-data.texi | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 1b3170e4f..bf46d5cd6 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -6942,8 +6942,9 @@ Store @var{value} as an @var{n}-bit (signed) integer (where @var{n} is @end deffn Finally, a variant specialized for the host's endianness is available -for each of these functions (with the exception of the @code{u8} -accessors, for obvious reasons): +for each of these functions (with the exception of the @code{u8} and +@code{s8} accessors, as endianness is about byte order and there is only +1 byte): @deffn {Scheme Procedure} bytevector-u16-native-ref bv index @deffnx {Scheme Procedure} bytevector-s16-native-ref bv index From 70d4c4b284ba85d89969d8da43f80ff66f491e37 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 28 Feb 2017 10:12:57 +0100 Subject: [PATCH 715/865] Fix (* x -1) for GOOPS types * libguile/numbers.c (scm_product): Only reduce (* x -1) to (- x) when X is a bignum. Fixes weirdness when X is not a number and instead multiplication should dispatch to GOOPS. Thanks to Alejandro Sanchez for the report. --- libguile/numbers.c | 28 +++++++++++++--------------- 1 file changed, 13 insertions(+), 15 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 99b564e95..0d053c867 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -8021,17 +8021,6 @@ scm_product (SCM x, SCM y) else return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product); break; - case -1: - /* - * This case is important for more than just optimization. - * It handles the case of negating - * (+ 1 most-positive-fixnum) aka (- most-negative-fixnum), - * which is a bignum that must be changed back into a fixnum. - * Failure to do so will cause the following to return #f: - * (= most-negative-fixnum (* -1 (- most-negative-fixnum))) - */ - return scm_difference(y, SCM_UNDEFINED); - break; } if (SCM_LIKELY (SCM_I_INUMP (y))) @@ -8056,10 +8045,19 @@ scm_product (SCM x, SCM y) } else if (SCM_BIGP (y)) { - SCM result = scm_i_mkbig (); - mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), xx); - scm_remember_upto_here_1 (y); - return result; + /* There is one bignum which, when multiplied by negative one, + becomes a non-zero fixnum: (1+ most-positive-fixum). Since + we know the type of X and Y are numbers, delegate this + special case to scm_difference. */ + if (xx == -1) + return scm_difference (y, SCM_UNDEFINED); + else + { + SCM result = scm_i_mkbig (); + mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), xx); + scm_remember_upto_here_1 (y); + return result; + } } else if (SCM_REALP (y)) return scm_i_from_double (xx * SCM_REAL_VALUE (y)); From 9e28a12121414b4b0508d56c9fe011d9059f48b7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 28 Feb 2017 10:45:21 +0100 Subject: [PATCH 716/865] Revert "futures: Limit the number of nested futures on the same stack." This reverts commit 8a177d316c0062afe74f9a761ef460e297435e59, though keeping the additional tests. (Guile 2.2 doesn't have a fixed stack limit). --- doc/ref/api-scheduling.texi | 7 ------- module/ice-9/futures.scm | 23 +++++++---------------- 2 files changed, 7 insertions(+), 23 deletions(-) diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index bf85a6411..ff8473ae2 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -830,13 +830,6 @@ future has completed. This suspend/resume is achieved by capturing the calling future's continuation, and later reinstating it (@pxref{Prompts, delimited continuations}). -Note that @code{par-map} above is not tail-recursive. This could lead -to stack overflows when @var{lst} is large compared to -@code{(current-processor-count)}. To address that, @code{touch} uses -the suspend mechanism described above to limit the number of nested -futures executing on the same stack. Thus, the above code should never -run into stack overflows. - @deffn {Scheme Syntax} future exp Return a future for expression @var{exp}. This is equivalent to: diff --git a/module/ice-9/futures.scm b/module/ice-9/futures.scm index cc57e5c61..4a462839a 100644 --- a/module/ice-9/futures.scm +++ b/module/ice-9/futures.scm @@ -1,6 +1,6 @@ ;;; -*- mode: scheme; coding: utf-8; -*- ;;; -;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +;;; Copyright (C) 2010, 2011, 2012 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 @@ -90,14 +90,8 @@ touched." ;; A mapping of nested futures to futures waiting for them to complete. (define %futures-waiting '()) -;; Nesting level of futures. Incremented each time a future is touched -;; from within a future. -(define %nesting-level (make-parameter 0)) - -;; Maximum nesting level. The point is to avoid stack overflows when -;; nested futures are executed on the same stack. See -;; . -(define %max-nesting-level 200) +;; Whether currently running within a future. +(define %within-future? (make-parameter #f)) (define-syntax-rule (with-mutex m e0 e1 ...) ;; Copied from (ice-9 threads) to avoid circular dependency. @@ -153,8 +147,7 @@ adding it to the waiter queue." (thunk (lambda () (call-with-prompt %future-prompt (lambda () - (parameterize ((%nesting-level - (1+ (%nesting-level)))) + (parameterize ((%within-future? #t)) ((future-thunk future)))) suspend)))) (set-future-result! future @@ -253,16 +246,14 @@ adding it to the waiter queue." (unlock-mutex (future-mutex future))) ((started) (unlock-mutex (future-mutex future)) - (if (> (%nesting-level) 0) + (if (%within-future?) (abort-to-prompt %future-prompt future) (begin (work) (loop)))) - (else ; queued + (else (unlock-mutex (future-mutex future)) - (if (> (%nesting-level) %max-nesting-level) - (abort-to-prompt %future-prompt future) - (work)) + (work) (loop)))) ((future-result future))) From 631e9901d84ba59ffcb21de95dbb6c9215b642c7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 28 Feb 2017 11:31:52 +0100 Subject: [PATCH 717/865] Declare module exports before loading imports * module/ice-9/boot-9.scm (define-module*): Process module imports after module exports. Allows for an additional kind of circular module imports (see https://bugs.gnu.org/15540). * test-suite/tests/modules.test ("circular imports"): Add test. --- module/ice-9/boot-9.scm | 73 ++++++++++++++++------------------- test-suite/tests/modules.test | 41 ++++++++++++++++++++ 2 files changed, 74 insertions(+), 40 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 229d91734..b480e3dd1 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2859,24 +2859,13 @@ written into the port is returned." (define (list-of pred l) (or (null? l) (and (pair? l) (pred (car l)) (list-of pred (cdr l))))) + (define (valid-import? x) + (list? x)) (define (valid-export? x) (or (symbol? x) (and (pair? x) (symbol? (car x)) (symbol? (cdr x))))) (define (valid-autoload? x) (and (pair? x) (list-of symbol? (car x)) (list-of symbol? (cdr x)))) - (define (resolve-imports imports) - (define (resolve-import import-spec) - (if (list? import-spec) - (apply resolve-interface import-spec) - (error "unexpected use-module specification" import-spec))) - (let lp ((imports imports) (out '())) - (cond - ((null? imports) (reverse! out)) - ((pair? imports) - (lp (cdr imports) - (cons (resolve-import (car imports)) out))) - (else (error "unexpected tail of imports list" imports))))) - ;; We could add a #:no-check arg, set by the define-module macro, if ;; these checks are taking too much time. ;; @@ -2891,33 +2880,37 @@ written into the port is returned." (error "expected list of integers for version")) (set-module-version! module version) (set-module-version! (module-public-interface module) version)) - (let ((imports (resolve-imports imports))) - (call-with-deferred-observers - (lambda () - (unless (list-of valid-export? exports) - (error "expected exports to be a list of symbols or symbol pairs")) - (unless (list-of valid-export? replacements) - (error "expected replacements to be a list of symbols or symbol pairs")) - (unless (list-of valid-export? re-exports) - (error "expected re-exports to be a list of symbols or symbol pairs")) - (unless (null? imports) - (module-use-interfaces! module imports)) - (module-export! module exports) - (module-replace! module replacements) - (module-re-export! module re-exports) - ;; FIXME: Avoid use of `apply'. - (apply module-autoload! module autoloads) - (let ((duplicates (or duplicates - ;; Avoid stompling a previously installed - ;; duplicates handlers if possible. - (and (not (module-duplicates-handlers module)) - ;; Note: If you change this default, - ;; change it also in - ;; `default-duplicate-binding-procedures'. - '(replace warn-override-core warn last))))) - (when duplicates - (let ((handlers (lookup-duplicates-handlers duplicates))) - (set-module-duplicates-handlers! module handlers))))))) + (call-with-deferred-observers + (lambda () + (unless (list-of valid-import? imports) + (error "expected imports to be a list of import specifications")) + (unless (list-of valid-export? exports) + (error "expected exports to be a list of symbols or symbol pairs")) + (unless (list-of valid-export? replacements) + (error "expected replacements to be a list of symbols or symbol pairs")) + (unless (list-of valid-export? re-exports) + (error "expected re-exports to be a list of symbols or symbol pairs")) + (module-export! module exports) + (module-replace! module replacements) + (unless (null? imports) + (let ((imports (map (lambda (import-spec) + (apply resolve-interface import-spec)) + imports))) + (module-use-interfaces! module imports))) + (module-re-export! module re-exports) + ;; FIXME: Avoid use of `apply'. + (apply module-autoload! module autoloads) + (let ((duplicates (or duplicates + ;; Avoid stompling a previously installed + ;; duplicates handlers if possible. + (and (not (module-duplicates-handlers module)) + ;; Note: If you change this default, + ;; change it also in + ;; `default-duplicate-binding-procedures'. + '(replace warn-override-core warn last))))) + (when duplicates + (let ((handlers (lookup-duplicates-handlers duplicates))) + (set-module-duplicates-handlers! module handlers)))))) (when transformer (unless (and (pair? transformer) (list-of symbol? transformer)) diff --git a/test-suite/tests/modules.test b/test-suite/tests/modules.test index 5e08ac9c9..d99b961b3 100644 --- a/test-suite/tests/modules.test +++ b/test-suite/tests/modules.test @@ -422,3 +422,44 @@ (pass-if "version-matches? against less specified version" (not (version-matches? '(1 2 3) '(1 2))))) + + +(with-test-prefix "circular imports" + (pass-if-equal "#:select" 1 + (begin + (eval + '(begin + (define-module (test-circular-imports)) + (define (init-module-a) + (eval '(begin + (define-module (test-circular-imports a) + #:use-module (test-circular-imports b) + #:export (from-a)) + (define from-a 1)) + (current-module))) + (define (init-module-b) + (eval '(begin + (define-module (test-circular-imports b) + #:use-module ((test-circular-imports a) + #:select (from-a)) + #:export (from-b)) + (define from-b 2)) + (current-module))) + (define (submodule-binder mod name) + (let ((m (make-module 31))) + (set-module-kind! m 'directory) + (set-module-name! m (append (module-name mod) (list name))) + (module-define-submodule! mod name m) + (case name + ((a) (init-module-a)) + ((b) (init-module-b)) + ((c) #t) + (else (error "unreachable"))) + m)) + (set-module-submodule-binder! (current-module) submodule-binder)) + (current-module)) + (eval '(begin + (define-module (test-circular-imports c)) + (use-modules (test-circular-imports a)) + from-a) + (current-module))))) From 4c3bea3dba345567c3689bf4ba68a85f6209eb17 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 28 Feb 2017 13:14:02 +0100 Subject: [PATCH 718/865] Fix support for threads already known to GC * libguile/threads.h (scm_i_thread): Add bool tracking whether the thread needs to be unregistered from libgc. * libguile/threads.c (guilify_self_1): Add needs_unregister arg. (on_thread_exit): Only unregister thread if the thread needs it. (scm_i_init_thread_for_guile): A thread needs unregistering if GC_register_my_thread succeeded. (scm_threads_prehistory): Don't unregister initial thread. Fixes #19523. Thanks to Anthonin Bonnefoy for the report. --- libguile/threads.c | 19 ++++++++++++++----- libguile/threads.h | 3 +++ 2 files changed, 17 insertions(+), 5 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index 1faa539e1..e67616c03 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -372,7 +372,7 @@ static SCM default_dynamic_state; /* Perform first stage of thread initialisation, in non-guile mode. */ static void -guilify_self_1 (struct GC_stack_base *base) +guilify_self_1 (struct GC_stack_base *base, int needs_unregister) { scm_i_thread t; @@ -410,6 +410,7 @@ guilify_self_1 (struct GC_stack_base *base) t.exited = 0; t.guile_mode = 0; + t.needs_unregister = needs_unregister; /* The switcheroo. */ { @@ -523,8 +524,13 @@ on_thread_exit (void *v) scm_i_vm_free_stack (vp); } +#ifdef SCM_HAVE_THREAD_STORAGE_CLASS + scm_i_current_thread = NULL; +#endif + #if SCM_USE_PTHREAD_THREADS - GC_unregister_my_thread (); + if (t->needs_unregister) + GC_unregister_my_thread (); #endif } @@ -586,6 +592,8 @@ scm_i_init_thread_for_guile (struct GC_stack_base *base, } else { + int needs_unregister = 0; + /* Guile is already initialized, but this thread enters it for the first time. Only initialize this thread. */ @@ -593,10 +601,11 @@ scm_i_init_thread_for_guile (struct GC_stack_base *base, /* Register this thread with libgc. */ #if SCM_USE_PTHREAD_THREADS - GC_register_my_thread (base); + if (GC_register_my_thread (base) == GC_SUCCESS) + needs_unregister = 1; #endif - guilify_self_1 (base); + guilify_self_1 (base, needs_unregister); guilify_self_2 (dynamic_state); } return 1; @@ -1782,7 +1791,7 @@ scm_threads_prehistory (void *base) GC_MAKE_PROC (GC_new_proc (thread_mark), 0), 0, 1); - guilify_self_1 ((struct GC_stack_base *) base); + guilify_self_1 ((struct GC_stack_base *) base, 0); } scm_t_bits scm_tc16_thread; diff --git a/libguile/threads.h b/libguile/threads.h index 645e5eb65..55c566d23 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -59,6 +59,9 @@ typedef struct scm_i_thread { /* Boolean indicating whether the thread is in guile mode. */ int guile_mode; + /* Boolean indicating whether to call GC_unregister_my_thread () when + this thread exits. */ + int needs_unregister; struct scm_thread_wake_data *wake; scm_i_pthread_cond_t sleep_cond; From 94d70684c19f8074baaec83ae2038898ad3e092f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 23 Jun 2016 18:31:55 +0200 Subject: [PATCH 719/865] Register R6RS port and bytevector internals early * libguile/bytevectors.c (sym_big, sym_little): Rename from scm_sym_big and scm_sym_little, and don't use the snarf mechanism as we need to initialize this value eagerly in case the C API is used before the Scheme module is loaded. (scm_bootstrap_bytevectors): Initialize the endianness symbols here. * libguile/r6rs-ports.c (scm_register_r6rs_ports): Register the R6RS port kinds here, for the same reason. --- libguile/bytevectors.c | 24 ++++++++++++------------ libguile/r6rs-ports.c | 12 ++++++------ 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index cf247dcd4..58df01830 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -430,8 +430,8 @@ scm_i_print_bytevector (SCM bv, SCM port, scm_print_state *pstate SCM_UNUSED) /* General operations. */ -SCM_SYMBOL (scm_sym_big, "big"); -SCM_SYMBOL (scm_sym_little, "little"); +static SCM sym_big; +static SCM sym_little; SCM scm_endianness_big, scm_endianness_little; @@ -812,13 +812,13 @@ bytevector_large_ref (const char *c_bv, size_t c_size, int signed_p, if (signed_p) { - if (scm_is_eq (endianness, scm_sym_big)) + if (scm_is_eq (endianness, sym_big)) negative_p = c_bv[0] & 0x80; else negative_p = c_bv[c_size - 1] & 0x80; } - c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1; + c_endianness = scm_is_eq (endianness, sym_big) ? 1 : -1; mpz_init (c_mpz); mpz_import (c_mpz, 1 /* 1 word */, 1 /* word order doesn't matter */, @@ -845,7 +845,7 @@ bytevector_large_set (char *c_bv, size_t c_size, int signed_p, mpz_t c_mpz; int c_endianness, c_sign, err = 0; - c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1; + c_endianness = scm_is_eq (endianness, sym_big) ? 1 : -1; mpz_init (c_mpz); scm_to_mpz (value, c_mpz); @@ -1881,9 +1881,9 @@ utf_encoding_name (char *name, size_t utf_width, SCM endianness) ? "32" : "??")))); strcat (name, - ((scm_is_eq (endianness, scm_sym_big)) + ((scm_is_eq (endianness, sym_big)) ? "BE" - : ((scm_is_eq (endianness, scm_sym_little)) + : ((scm_is_eq (endianness, sym_little)) ? "LE" : "unknown"))); } @@ -1901,7 +1901,7 @@ utf_encoding_name (char *name, size_t utf_width, SCM endianness) \ SCM_VALIDATE_STRING (1, str); \ if (scm_is_eq (endianness, SCM_UNDEFINED)) \ - endianness = scm_sym_big; \ + endianness = sym_big; \ else \ SCM_VALIDATE_SYMBOL (2, endianness); \ \ @@ -2018,7 +2018,7 @@ SCM_DEFINE (scm_string_to_utf32, "string->utf32", \ SCM_VALIDATE_BYTEVECTOR (1, utf); \ if (scm_is_eq (endianness, SCM_UNDEFINED)) \ - endianness = scm_sym_big; \ + endianness = sym_big; \ else \ SCM_VALIDATE_SYMBOL (2, endianness); \ \ @@ -2109,13 +2109,13 @@ scm_bootstrap_bytevectors (void) scm_i_register_vector_constructor (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_VU8], scm_make_bytevector); + + scm_endianness_big = sym_big = scm_from_latin1_symbol ("big"); + scm_endianness_little = sym_little = scm_from_latin1_symbol ("little"); } void scm_init_bytevectors (void) { #include "libguile/bytevectors.x" - - scm_endianness_big = scm_sym_big; - scm_endianness_little = scm_sym_little; } diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index b919b4bdf..c2f97ffa1 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -1158,12 +1158,6 @@ scm_register_r6rs_ports (void) "scm_init_r6rs_ports", (scm_t_extension_init_func) scm_init_r6rs_ports, NULL); -} - -void -scm_init_r6rs_ports (void) -{ -#include "libguile/r6rs-ports.x" initialize_bytevector_input_ports (); initialize_custom_binary_input_ports (); @@ -1172,3 +1166,9 @@ scm_init_r6rs_ports (void) initialize_custom_binary_input_output_ports (); initialize_transcoded_ports (); } + +void +scm_init_r6rs_ports (void) +{ +#include "libguile/r6rs-ports.x" +} From f3a1872703bf8b9b8f92bbdba01aa75927bd1b8f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 28 Feb 2017 16:22:42 +0100 Subject: [PATCH 720/865] "Scripting Examples" update. * doc/ref/scheme-scripts.texi (Scripting Examples): Mention system* and open-pipe. --- doc/ref/scheme-scripts.texi | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/doc/ref/scheme-scripts.texi b/doc/ref/scheme-scripts.texi index 7552dba33..296bea772 100644 --- a/doc/ref/scheme-scripts.texi +++ b/doc/ref/scheme-scripts.texi @@ -402,6 +402,17 @@ $ ./choose 50 100 100891344545564193334812497256 @end example +Finally, seasoned scripters are probably missing a mention of +subprocesses. In Bash, for example, most shell scripts run other +programs like @code{sed} or the like to do the actual work. + +In Guile it's often possible get everything done within Guile itself, so +do give that a try first. But if you just need to run a program and +wait for it to finish, use @code{system*}. If you need to run a +sub-program and capture its output, or give it input, use +@code{open-pipe}. @xref{Processes}, and @xref{Pipes}, for more +information. + @c Local Variables: @c TeX-master: "guile.texi" From 33514ffe22b8cd15ff7ba95bcee80a534b2bbc2a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 28 Feb 2017 17:02:25 +0100 Subject: [PATCH 721/865] Fix segfault introduced with R6RS port commit * libguile/init.c (scm_i_init_guile): Move scm_register_r6rs_ports later, so that defining port types hsa the SCM trampoline subrs defined. * libguile/bytevectors.c (scm_bootstrap_bytevectors): Cosmetic changes. --- libguile/bytevectors.c | 11 ++++++----- libguile/init.c | 2 +- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index 58df01830..7b4585d1f 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -2095,10 +2095,14 @@ scm_bootstrap_bytevectors (void) loaded. */ scm_null_bytevector = make_bytevector (0, SCM_ARRAY_ELEMENT_TYPE_VU8); + + scm_endianness_big = sym_big = scm_from_latin1_symbol ("big"); + scm_endianness_little = sym_little = scm_from_latin1_symbol ("little"); + #ifdef WORDS_BIGENDIAN - scm_i_native_endianness = scm_from_latin1_symbol ("big"); + scm_i_native_endianness = sym_big; #else - scm_i_native_endianness = scm_from_latin1_symbol ("little"); + scm_i_native_endianness = sym_little; #endif scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, @@ -2109,9 +2113,6 @@ scm_bootstrap_bytevectors (void) scm_i_register_vector_constructor (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_VU8], scm_make_bytevector); - - scm_endianness_big = sym_big = scm_from_latin1_symbol ("big"); - scm_endianness_little = sym_little = scm_from_latin1_symbol ("little"); } void diff --git a/libguile/init.c b/libguile/init.c index a8f690b62..1a6f599fa 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -399,7 +399,6 @@ scm_i_init_guile (void *base) scm_bootstrap_programs (); scm_bootstrap_vm (); scm_register_atomic (); - scm_register_r6rs_ports (); scm_register_fdes_finalizers (); scm_register_foreign (); scm_register_foreign_object (); @@ -431,6 +430,7 @@ scm_i_init_guile (void *base) scm_init_feature (); scm_init_backtrace (); scm_init_ports (); + scm_register_r6rs_ports (); /* requires ports */ scm_init_fports (); scm_init_strports (); scm_init_hash (); From 68f13adaaf3e556cc134b3057086e4e1df8de9ba Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 28 Feb 2017 20:42:45 +0100 Subject: [PATCH 722/865] Better errors for odd-length keyword args * libguile/vm-engine.c (bind-kwargs): * libguile/vm.c (vm_error_kwargs_missing_value): * libguile/eval.c (error_missing_value) (prepare_boot_closure_env_for_apply): Adapt to mirror VM behavior. * libguile/keywords.c (scm_c_bind_keyword_arguments): Likewise. * module/ice-9/eval.scm (primitive-eval): Update to error on (foo #:kw) with a "Keyword argument has no value" instead of the horrible "odd argument list length". Also adapts to the expected args format for the keyword-argument-error exception printer in all cases. Matches 1.8 optargs behavior also. * test-suite/standalone/test-scm-c-bind-keyword-arguments.c (test_missing_value): (missing_value_error_handler): Update test. * test-suite/tests/optargs.test: Add tests. --- libguile/eval.c | 56 ++++++++++++------- libguile/keywords.c | 24 ++++---- libguile/vm-engine.c | 13 +++-- libguile/vm.c | 8 +-- module/ice-9/eval.scm | 51 ++++++++++------- .../test-scm-c-bind-keyword-arguments.c | 22 ++++---- test-suite/tests/optargs.test | 16 ++++++ 7 files changed, 120 insertions(+), 70 deletions(-) diff --git a/libguile/eval.c b/libguile/eval.c index 93788ebfc..e9ff02a8b 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -195,6 +195,12 @@ env_set (SCM env, int depth, int width, SCM val) VECTOR_SET (env, width + 1, val); } +static void error_missing_value (SCM proc, SCM kw) +{ + scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc, + scm_from_locale_string ("Keyword argument has no value"), SCM_EOL, + scm_list_1 (kw)); +} static void error_invalid_keyword (SCM proc, SCM obj) { @@ -832,28 +838,40 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, { SCM walk; - if (scm_is_pair (args) && scm_is_pair (CDR (args))) - for (; scm_is_pair (args) && scm_is_pair (CDR (args)); - args = CDR (args)) - { - SCM k = CAR (args), v = CADR (args); - if (!scm_is_keyword (k)) + while (scm_is_pair (args)) + { + SCM k = CAR (args); + args = CDR (args); + if (!scm_is_keyword (k)) + { + if (scm_is_true (rest)) + continue; + else + break; + } + for (walk = kw; scm_is_pair (walk); walk = CDR (walk)) + if (scm_is_eq (k, CAAR (walk))) { - if (scm_is_true (rest)) - continue; + if (scm_is_pair (args)) + { + SCM v = CAR (args); + args = CDR (args); + env_set (env, 0, SCM_I_INUM (CDAR (walk)), v); + break; + } else - break; + error_missing_value (proc, k); } - for (walk = kw; scm_is_pair (walk); walk = CDR (walk)) - if (scm_is_eq (k, CAAR (walk))) - { - env_set (env, 0, SCM_I_INUM (CDAR (walk)), v); - args = CDR (args); - break; - } - if (scm_is_null (walk) && scm_is_false (aok)) - error_unrecognized_keyword (proc, k); - } + if (scm_is_null (walk)) + { + if (scm_is_false (aok)) + error_unrecognized_keyword (proc, k); + else if (!scm_is_pair (args)) + /* Advance past argument of unrecognized + keyword, if present. */ + args = CDR (args); + } + } if (scm_is_pair (args) && scm_is_false (rest)) error_invalid_keyword (proc, CAR (args)); } diff --git a/libguile/keywords.c b/libguile/keywords.c index 0ead33692..087042b84 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -125,18 +125,12 @@ scm_c_bind_keyword_arguments (const char *subr, SCM rest, { va_list va; - if (SCM_UNLIKELY (!(flags & SCM_ALLOW_NON_KEYWORD_ARGUMENTS) - && scm_ilength (rest) % 2 != 0)) - scm_error (scm_keyword_argument_error, - subr, "Odd length of keyword argument list", - SCM_EOL, SCM_BOOL_F); - while (scm_is_pair (rest)) { SCM kw_or_arg = SCM_CAR (rest); SCM tail = SCM_CDR (rest); - if (scm_is_keyword (kw_or_arg) && scm_is_pair (tail)) + if (scm_is_keyword (kw_or_arg)) { SCM kw; SCM *arg_p; @@ -154,6 +148,11 @@ scm_c_bind_keyword_arguments (const char *subr, SCM rest, scm_from_latin1_string ("Unrecognized keyword"), SCM_EOL, scm_list_1 (kw_or_arg)); + + /* Advance REST. Advance past the argument of an + unrecognized keyword, but don't error if such a + keyword has no argument. */ + rest = scm_is_pair (tail) ? SCM_CDR (tail) : tail; break; } arg_p = va_arg (va, SCM *); @@ -161,14 +160,19 @@ scm_c_bind_keyword_arguments (const char *subr, SCM rest, { /* We found the matching keyword. Store the associated value and break out of the loop. */ + if (!scm_is_pair (tail)) + scm_error_scm (scm_keyword_argument_error, + scm_from_locale_string (subr), + scm_from_latin1_string + ("Keyword argument has no value"), + SCM_EOL, scm_list_1 (kw)); *arg_p = SCM_CAR (tail); + /* Advance REST. */ + rest = SCM_CDR (tail); break; } } va_end (va); - - /* Advance REST. */ - rest = SCM_CDR (tail); } else { diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index c9a9cecd1..9ddda8f2a 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -1269,9 +1269,6 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, while (n < ntotal) FP_SET (n++, SCM_UNDEFINED); - VM_ASSERT (has_rest || (nkw % 2) == 0, - vm_error_kwargs_length_not_even (FP_REF (0))); - /* Now bind keywords, in the order given. */ for (n = 0; n < nkw; n++) if (scm_is_keyword (FP_REF (ntotal + n))) @@ -1281,8 +1278,14 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, if (scm_is_eq (SCM_CAAR (walk), FP_REF (ntotal + n))) { SCM si = SCM_CDAR (walk); - FP_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_uint32 (si), - FP_REF (ntotal + n + 1)); + if (n + 1 < nkw) + { + FP_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_uint32 (si), + FP_REF (ntotal + n + 1)); + } + else + vm_error_kwargs_missing_value (FP_REF (0), + FP_REF (ntotal + n)); break; } VM_ASSERT (scm_is_pair (walk) || allow_other_keys, diff --git a/libguile/vm.c b/libguile/vm.c index be30517c5..e8f75b14f 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -422,7 +422,7 @@ static void vm_error_bad_instruction (scm_t_uint32 inst) SCM_NORETURN SCM_NOINLI static void vm_error_unbound (SCM sym) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_variable (const char *func_name, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN SCM_NOINLINE; -static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN SCM_NOINLINE; +static void vm_error_kwargs_missing_value (SCM proc, SCM kw) SCM_NORETURN SCM_NOINLINE; static void vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) SCM_NORETURN SCM_NOINLINE; static void vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) SCM_NORETURN SCM_NOINLINE; static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN SCM_NOINLINE; @@ -479,11 +479,11 @@ vm_error_apply_to_non_list (SCM x) } static void -vm_error_kwargs_length_not_even (SCM proc) +vm_error_kwargs_missing_value (SCM proc, SCM kw) { scm_error_scm (sym_keyword_argument_error, proc, - scm_from_latin1_string ("Odd length of keyword argument list"), - SCM_EOL, SCM_BOOL_F); + scm_from_latin1_string ("Keyword argument has no value"), + SCM_EOL, scm_list_1 (kw)); } static void diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm index a2bab2065..d21f59abd 100644 --- a/module/ice-9/eval.scm +++ b/module/ice-9/eval.scm @@ -498,27 +498,38 @@ (define (bind-kw args) (let lp ((args args)) (cond - ((and (pair? args) (pair? (cdr args)) - (keyword? (car args))) - (let ((kw-pair (assq (car args) keywords)) - (v (cadr args))) - (if kw-pair - ;; Found a known keyword; set its value. - (env-set! env 0 (cdr kw-pair) v) - ;; Unknown keyword. - (if (not allow-other-keys?) - ((scm-error - 'keyword-argument-error - "eval" "Unrecognized keyword" - '() (list (car args)))))) - (lp (cddr args)))) ((pair? args) - (if rest? - ;; Be lenient parsing rest args. - (lp (cdr args)) - ((scm-error 'keyword-argument-error - "eval" "Invalid keyword" - '() (list (car args)))))) + (cond + ((keyword? (car args)) + (let ((k (car args)) + (args (cdr args))) + (cond + ((assq k keywords) + => (lambda (kw-pair) + ;; Found a known keyword; set its value. + (if (pair? args) + (let ((v (car args)) + (args (cdr args))) + (env-set! env 0 (cdr kw-pair) v) + (lp args)) + ((scm-error 'keyword-argument-error + "eval" + "Keyword argument has no value" + '() (list k)))))) + ;; Otherwise unknown keyword. + (allow-other-keys? + (lp (if (pair? args) (cdr args) args))) + (else + ((scm-error 'keyword-argument-error + "eval" "Unrecognized keyword" + '() (list k))))))) + (rest? + ;; Be lenient parsing rest args. + (lp (cdr args))) + (else + ((scm-error 'keyword-argument-error + "eval" "Invalid keyword" + '() (list (car args))))))) (else (body env))))) (bind-req args)))))))) diff --git a/test-suite/standalone/test-scm-c-bind-keyword-arguments.c b/test-suite/standalone/test-scm-c-bind-keyword-arguments.c index f4cd53d84..90bcf2baf 100644 --- a/test-suite/standalone/test-scm-c-bind-keyword-arguments.c +++ b/test-suite/standalone/test-scm-c-bind-keyword-arguments.c @@ -94,33 +94,31 @@ invalid_keyword_error_handler (void *data, SCM key, SCM args) } static SCM -test_odd_length (void *data) +test_missing_value (void *data) { SCM k_foo = scm_from_utf8_keyword ("foo"); - SCM k_bar = scm_from_utf8_keyword ("bar"); - SCM arg_foo, arg_bar; + SCM arg_foo; scm_c_bind_keyword_arguments ("test", - scm_list_n (k_foo, SCM_EOL, - SCM_INUM0, + scm_list_n (k_foo, SCM_UNDEFINED), SCM_ALLOW_OTHER_KEYS, k_foo, &arg_foo, - k_bar, &arg_bar, SCM_UNDEFINED); assert (0); } static SCM -odd_length_error_handler (void *data, SCM key, SCM args) +missing_value_error_handler (void *data, SCM key, SCM args) { SCM expected_args = scm_list_n (scm_from_utf8_string ("test"), - scm_from_utf8_string ("Odd length of keyword argument list"), - SCM_EOL, SCM_BOOL_F, + scm_from_utf8_string ("Keyword argument has no value"), + SCM_EOL, scm_list_1 (scm_from_utf8_keyword ("foo")), SCM_UNDEFINED); assert (scm_is_eq (key, scm_from_utf8_symbol ("keyword-argument-error"))); + scm_write (args, scm_current_output_port ()); assert (scm_is_true (scm_equal_p (args, expected_args))); return SCM_BOOL_T; @@ -214,10 +212,10 @@ test_scm_c_bind_keyword_arguments () test_invalid_keyword, NULL, invalid_keyword_error_handler, NULL); - /* Test odd length error. */ + /* Test missing value error. */ scm_internal_catch (SCM_BOOL_T, - test_odd_length, NULL, - odd_length_error_handler, NULL); + test_missing_value, NULL, + missing_value_error_handler, NULL); } static void diff --git a/test-suite/tests/optargs.test b/test-suite/tests/optargs.test index 047417b4c..9590f414c 100644 --- a/test-suite/tests/optargs.test +++ b/test-suite/tests/optargs.test @@ -154,6 +154,14 @@ (lambda (key proc fmt args data) data))) + (pass-if-equal "missing argument" '("Keyword argument has no value" #:x) + (catch 'keyword-argument-error + (lambda () + (let ((f (lambda* (#:key x) x))) + (f #:x))) + (lambda (key proc fmt args data) + (cons fmt data)))) + (pass-if-equal "invalid keyword" '(not-a-keyword) (catch 'keyword-argument-error (lambda () @@ -178,6 +186,14 @@ (lambda (key proc fmt args data) data))) + (pass-if-equal "missing argument" + '("Keyword argument has no value" #:encoding) + (catch 'keyword-argument-error + (lambda () + (open-file "/dev/null" "r" #:encoding)) + (lambda (key proc fmt args data) + (cons fmt data)))) + (pass-if-equal "invalid keyword" '(not-a-keyword) (catch 'keyword-argument-error (lambda () From 62f08b8f38990c1849ea61cd622f84b3d2611cd9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Mar 2017 09:41:57 +0100 Subject: [PATCH 723/865] Fix "Scheme Syntax" info rendering * doc/ref/api-evaluation.texi (Expression Syntax): Fix quote and quasiquote so that they actually look different in Info. --- doc/ref/api-evaluation.texi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index 3a3e9e632..f7ec4afbd 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -92,7 +92,7 @@ Note that an application must not attempt to modify literal strings, since they may be in read-only memory. @item (quote @var{data}) -@itemx '@var{data} +@itemx @verb{|'|}@var{data} @findex quote @findex ' Quoting is used to obtain a literal symbol (instead of a variable @@ -114,7 +114,7 @@ vectors obtained from a @code{quote} form, since they may be in read-only memory. @item (quasiquote @var{data}) -@itemx `@var{data} +@itemx @verb{|`|}@var{data} @findex quasiquote @findex ` Backquote quasi-quotation is like @code{quote}, but selected From 67b8b6fb06fe3dd2f0ae03604ebb9bd3fea43661 Mon Sep 17 00:00:00 2001 From: Wilfred Hughes Date: Mon, 5 Sep 2016 22:23:13 -0400 Subject: [PATCH 724/865] Favor docstrings for describing the purpose of functions. * module/ice-9/boot-9.scm: Where functions have docstring-style comments, make them proper docstrings. --- module/ice-9/boot-9.scm | 266 ++++++++++++++++------------------------ 1 file changed, 103 insertions(+), 163 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index b480e3dd1..75906ff4c 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -168,16 +168,13 @@ a-cont ;;; {Simple Debugging Tools} ;;; -;; peek takes any number of arguments, writes them to the -;; current ouput port, and returns the last argument. -;; It is handy to wrap around an expression to look at -;; a value each time is evaluated, e.g.: -;; -;; (+ 10 (troublesome-fn)) -;; => (+ 10 (pk 'troublesome-fn-returned (troublesome-fn))) -;; - (define (peek . stuff) + "Write arguments to the current output port, and return the last argument. + +This is handy for tracing function calls, e.g.: + +(+ 10 (troublesome-fn)) +=> (+ 10 (pk 'troublesome-fn-returned (troublesome-fn)))" (newline) (display ";;; ") (write stuff) @@ -202,11 +199,11 @@ a-cont (if (not (memq sym *features*)) (set! *features* (cons sym *features*)))) -;; Return #t iff FEATURE is available to this Guile interpreter. In SLIB, -;; provided? also checks to see if the module is available. We should do that -;; too, but don't. +;; In SLIB, provided? also checks to see if the module is available. We +;; should do that too, but don't. (define (provided? feature) + "Return #t iff FEATURE is available to this Guile interpreter." (and (memq feature *features*) #t)) @@ -308,13 +305,10 @@ a-cont ;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...) ;;; -;; and-map f l -;; -;; Apply f to successive elements of l until exhaustion or f returns #f. -;; If returning early, return #f. Otherwise, return the last value returned -;; by f. If f has never been called because l is empty, return #t. -;; (define (and-map f lst) + "Apply F to successive elements of LST until exhaustion or F returns #f. +If returning early, return #f. Otherwise, return the last value returned +by F. If F has never been called because LST is empty, return #t." (let loop ((result #t) (l lst)) (and result @@ -322,12 +316,9 @@ a-cont result) (loop (f (car l)) (cdr l)))))) -;; or-map f l -;; -;; Apply f to successive elements of l until exhaustion or while f returns #f. -;; If returning early, return the return value of f. -;; (define (or-map f lst) + "Apply F to successive elements of LST until exhaustion or while F returns #f. +If returning early, return the return value of F." (let loop ((result #f) (l lst)) (or result @@ -362,9 +353,8 @@ a-cont (char_pred (string-ref s (1- end)))) (string-every-c-code char_pred s start end)))) -;; A variant of string-fill! that we keep for compatability -;; (define (substring-fill! str start end fill) + "A variant of string-fill! that we keep for compatibility." (string-fill! str fill start end)) @@ -1705,10 +1695,10 @@ written into the port is returned." ;;; {Loading by paths} ;;; -;;; Load a Scheme source file named NAME, searching for it in the -;;; directories listed in %load-path, and applying each of the file -;;; name extensions listed in %load-extensions. (define (load-from-path name) + "Load a Scheme source file named NAME, searching for it in the +directories listed in %load-path, and applying each of the file +name extensions listed in %load-extensions." (start-stack 'load-stack (primitive-load-path name))) @@ -1997,10 +1987,9 @@ written into the port is returned." ;; make-module &opt size uses binder ;; -;; Create a new module, perhaps with a particular size of obarray, -;; initial uses list, or binding procedure. -;; (define* (make-module #:optional (size 31) (uses '()) (binder #f)) + "Create a new module, perhaps with a particular size of obarray, +initial uses list, or binding procedure." (if (not (integer? size)) (error "Illegal size to make-module." size)) (if (not (and (list? uses) @@ -2029,15 +2018,15 @@ written into the port is returned." (cons module proc)) (define* (module-observe-weak module observer-id #:optional (proc observer-id)) - ;; Register PROC as an observer of MODULE under name OBSERVER-ID (which can - ;; be any Scheme object). PROC is invoked and passed MODULE any time - ;; MODULE is modified. PROC gets unregistered when OBSERVER-ID gets GC'd - ;; (thus, it is never unregistered if OBSERVER-ID is an immediate value, - ;; for instance). + "Register PROC as an observer of MODULE under name OBSERVER-ID (which can +be any Scheme object). PROC is invoked and passed MODULE any time +MODULE is modified. PROC gets unregistered when OBSERVER-ID gets GC'd +(thus, it is never unregistered if OBSERVER-ID is an immediate value, +for instance). - ;; The two-argument version is kept for backward compatibility: when called - ;; with two arguments, the observer gets unregistered when closure PROC - ;; gets GC'd (making it impossible to use an anonymous lambda for PROC). +The two-argument version is kept for backward compatibility: when called +with two arguments, the observer gets unregistered when closure PROC +gets GC'd (making it impossible to use an anonymous lambda for PROC)." (hashq-set! (module-weak-observers module) observer-id proc)) (define (module-unobserve token) @@ -2103,13 +2092,10 @@ written into the port is returned." ;;; of M.'' ;;; -;; module-search fn m -;; -;; return the first non-#f result of FN applied to M and then to -;; the modules in the uses of m, and so on recursively. If all applications -;; return #f, then so does this function. -;; (define (module-search fn m v) + "Return the first non-#f result of FN applied to M and then to +the modules in the uses of M, and so on recursively. If all applications +return #f, then so does this function." (define (loop pos) (and (pair? pos) (or (module-search fn (car pos) v) @@ -2124,21 +2110,15 @@ written into the port is returned." ;;; of S in M has been set to some well-defined value. ;;; -;; module-locally-bound? module symbol -;; -;; Is a symbol bound (interned and defined) locally in a given module? -;; (define (module-locally-bound? m v) + "Is symbol V bound (interned and defined) locally in module M?" (let ((var (module-local-variable m v))) (and var (variable-bound? var)))) -;; module-bound? module symbol -;; -;; Is a symbol bound (interned and defined) anywhere in a given module -;; or its uses? -;; (define (module-bound? m v) + "Is symbol V bound (interned and defined) anywhere in module M or its +uses?" (let ((var (module-variable m v))) (and var (variable-bound? var)))) @@ -2170,22 +2150,16 @@ written into the port is returned." (define (module-obarray-remove! ob key) ((if (symbol? key) hashq-remove! hash-remove!) ob key)) -;; module-symbol-locally-interned? module symbol -;; -;; is a symbol interned (not neccessarily defined) locally in a given module -;; or its uses? Interned symbols shadow inherited bindings even if -;; they are not themselves bound to a defined value. -;; (define (module-symbol-locally-interned? m v) + "Is symbol V interned (not neccessarily defined) locally in module M +or its uses? Interned symbols shadow inherited bindings even if they +are not themselves bound to a defined value." (not (not (module-obarray-get-handle (module-obarray m) v)))) -;; module-symbol-interned? module symbol -;; -;; is a symbol interned (not neccessarily defined) anywhere in a given module -;; or its uses? Interned symbols shadow inherited bindings even if -;; they are not themselves bound to a defined value. -;; (define (module-symbol-interned? m v) + "Is symbol V interned (not neccessarily defined) anywhere in module M +or its uses? Interned symbols shadow inherited bindings even if they +are not themselves bound to a defined value." (module-search module-symbol-locally-interned? m v)) @@ -2217,14 +2191,10 @@ written into the port is returned." ;;; variable is dereferenced. ;;; -;; module-symbol-binding module symbol opt-value -;; -;; return the binding of a variable specified by name within -;; a given module, signalling an error if the variable is unbound. -;; If the OPT-VALUE is passed, then instead of signalling an error, -;; return OPT-VALUE. -;; (define (module-symbol-local-binding m v . opt-val) + "Return the binding of variable V specified by name within module M, +signalling an error if the variable is unbound. If the OPT-VALUE is +passed, then instead of signalling an error, return OPT-VALUE." (let ((var (module-local-variable m v))) (if (and var (variable-bound? var)) (variable-ref var) @@ -2232,14 +2202,10 @@ written into the port is returned." (car opt-val) (error "Locally unbound variable." v))))) -;; module-symbol-binding module symbol opt-value -;; -;; return the binding of a variable specified by name within -;; a given module, signalling an error if the variable is unbound. -;; If the OPT-VALUE is passed, then instead of signalling an error, -;; return OPT-VALUE. -;; (define (module-symbol-binding m v . opt-val) + "Return the binding of variable V specified by name within module M, +signalling an error if the variable is unbound. If the OPT-VALUE is +passed, then instead of signalling an error, return OPT-VALUE." (let ((var (module-variable m v))) (if (and var (variable-bound? var)) (variable-ref var) @@ -2253,15 +2219,12 @@ written into the port is returned." ;;; {Adding Variables to Modules} ;;; -;; module-make-local-var! module symbol -;; -;; ensure a variable for V in the local namespace of M. -;; If no variable was already there, then create a new and uninitialzied -;; variable. -;; ;; This function is used in modules.c. ;; (define (module-make-local-var! m v) + "Ensure a variable for V in the local namespace of M. +If no variable was already there, then create a new and uninitialized +variable." (or (let ((b (module-obarray-ref (module-obarray m) v))) (and (variable? b) (begin @@ -2275,13 +2238,10 @@ written into the port is returned." (module-add! m v local-var) local-var))) -;; module-ensure-local-variable! module symbol -;; -;; Ensure that there is a local variable in MODULE for SYMBOL. If -;; there is no binding for SYMBOL, create a new uninitialized -;; variable. Return the local variable. -;; (define (module-ensure-local-variable! module symbol) + "Ensure that there is a local variable in MODULE for SYMBOL. If +there is no binding for SYMBOL, create a new uninitialized +variable. Return the local variable." (or (module-local-variable module symbol) (let ((var (make-undefined-variable))) (module-add! module symbol var) @@ -2289,9 +2249,8 @@ written into the port is returned." ;; module-add! module symbol var ;; -;; ensure a particular variable for V in the local namespace of M. -;; (define (module-add! m v var) + "Ensure a particular variable for V in the local namespace of M." (if (not (variable? var)) (error "Bad variable to module-add!" var)) (if (not (symbol? v)) @@ -2299,11 +2258,8 @@ written into the port is returned." (module-obarray-set! (module-obarray m) v var) (module-modified m)) -;; module-remove! -;; -;; make sure that a symbol is undefined in the local namespace of M. -;; (define (module-remove! m v) + "Make sure that symbol V is undefined in the local namespace of M." (module-obarray-remove! (module-obarray m) v) (module-modified m)) @@ -2313,9 +2269,8 @@ written into the port is returned." ;; MODULE-FOR-EACH -- exported ;; -;; Call PROC on each symbol in MODULE, with arguments of (SYMBOL VARIABLE). -;; (define (module-for-each proc module) + "Call PROC on each symbol in MODULE, with arguments of (SYMBOL VARIABLE)." (hash-for-each proc (module-obarray module))) (define (module-map proc module) @@ -2357,12 +2312,10 @@ written into the port is returned." ;;; {MODULE-REF -- exported} ;;; - -;; Returns the value of a variable called NAME in MODULE or any of its -;; used modules. If there is no such variable, then if the optional third -;; argument DEFAULT is present, it is returned; otherwise an error is signaled. -;; (define (module-ref module name . rest) + "Returns the value of a variable called NAME in MODULE or any of its +used modules. If there is no such variable, then if the optional third +argument DEFAULT is present, it is returned; otherwise an error is signaled." (let ((variable (module-variable module name))) (if (and variable (variable-bound? variable)) (variable-ref variable) @@ -2373,10 +2326,9 @@ written into the port is returned." ;; MODULE-SET! -- exported ;; -;; Sets the variable called NAME in MODULE (or in a module that MODULE uses) -;; to VALUE; if there is no such variable, an error is signaled. -;; (define (module-set! module name value) + "Sets the variable called NAME in MODULE (or in a module that MODULE uses) +to VALUE; if there is no such variable, an error is signaled." (let ((variable (module-variable module name))) (if variable (variable-set! variable value) @@ -2384,10 +2336,9 @@ written into the port is returned." ;; MODULE-DEFINE! -- exported ;; -;; Sets the variable called NAME in MODULE to VALUE; if there is no such -;; variable, it is added first. -;; (define (module-define! module name value) + "Sets the variable called NAME in MODULE to VALUE; if there is no such +variable, it is added first." (let ((variable (module-local-variable module name))) (if variable (begin @@ -2398,18 +2349,14 @@ written into the port is returned." ;; MODULE-DEFINED? -- exported ;; -;; Return #t iff NAME is defined in MODULE (or in a module that MODULE -;; uses) -;; (define (module-defined? module name) + "Return #t iff NAME is defined in MODULE (or in a module that MODULE +uses)." (let ((variable (module-variable module name))) (and variable (variable-bound? variable)))) -;; MODULE-USE! module interface -;; -;; Add INTERFACE to the list of interfaces used by MODULE. -;; (define (module-use! module interface) + "Add INTERFACE to the list of interfaces used by MODULE." (if (not (or (eq? module interface) (memq interface (module-uses module)))) (begin @@ -2421,12 +2368,9 @@ written into the port is returned." (hash-clear! (module-import-obarray module)) (module-modified module)))) -;; MODULE-USE-INTERFACES! module interfaces -;; -;; Same as MODULE-USE!, but only notifies module observers after all -;; interfaces are added to the inports list. -;; (define (module-use-interfaces! module interfaces) + "Same as MODULE-USE!, but only notifies module observers after all +interfaces are added to the inports list." (let* ((cur (module-uses module)) (new (let lp ((in interfaces) (out '())) (if (null? in) @@ -2764,40 +2708,6 @@ written into the port is returned." (eq? (car (last-pair use-list)) the-scm-module)) (set-module-uses! module (reverse (cdr (reverse use-list))))))) -;; Return a module that is an interface to the module designated by -;; NAME. -;; -;; `resolve-interface' takes four keyword arguments: -;; -;; #:select SELECTION -;; -;; SELECTION is a list of binding-specs to be imported; A binding-spec -;; is either a symbol or a pair of symbols (ORIG . SEEN), where ORIG -;; is the name in the used module and SEEN is the name in the using -;; module. Note that SEEN is also passed through RENAMER, below. The -;; default is to select all bindings. If you specify no selection but -;; a renamer, only the bindings that already exist in the used module -;; are made available in the interface. Bindings that are added later -;; are not picked up. -;; -;; #:hide BINDINGS -;; -;; BINDINGS is a list of bindings which should not be imported. -;; -;; #:prefix PREFIX -;; -;; PREFIX is a symbol that will be appended to each exported name. -;; The default is to not perform any renaming. -;; -;; #:renamer RENAMER -;; -;; RENAMER is a procedure that takes a symbol and returns its new -;; name. The default is not perform any renaming. -;; -;; Signal "no code for module" error if module name is not resolvable -;; or its public interface is not available. Signal "no binding" -;; error if selected binding does not exist in the used module. -;; (define* (resolve-interface name #:key (select #f) (hide '()) @@ -2806,6 +2716,39 @@ written into the port is returned." (symbol-prefix-proc prefix) identity)) version) + "Return a module that is an interface to the module designated by +NAME. + +`resolve-interface' takes four keyword arguments: + + #:select SELECTION + +SELECTION is a list of binding-specs to be imported; A binding-spec +is either a symbol or a pair of symbols (ORIG . SEEN), where ORIG +is the name in the used module and SEEN is the name in the using +module. Note that SEEN is also passed through RENAMER, below. The +default is to select all bindings. If you specify no selection but +a renamer, only the bindings that already exist in the used module +are made available in the interface. Bindings that are added later +are not picked up. + + #:hide BINDINGS + +BINDINGS is a list of bindings which should not be imported. + + #:prefix PREFIX + +PREFIX is a symbol that will be appended to each exported name. +The default is to not perform any renaming. + + #:renamer RENAMER + +RENAMER is a procedure that takes a symbol and returns its new +name. The default is not perform any renaming. + +Signal \"no code for module\" error if module name is not resolvable +or its public interface is not available. Signal \"no binding\" +error if selected binding does not exist in the used module." (let* ((module (resolve-module name #t version #:ensure #f)) (public-i (and module (module-public-interface module)))) (unless public-i @@ -3460,12 +3403,11 @@ but it fails to load." (lambda formals body ...)) -;; Export a local variable - ;; This function is called from "modules.c". If you change it, be ;; sure to update "modules.c" as well. (define (module-export! m names) + "Export a local variable." (let ((public-i (module-public-interface m))) (for-each (lambda (name) (let* ((internal-name (if (pair? name) (car name) name)) @@ -3486,9 +3428,8 @@ but it fails to load." (module-add! public-i external-name var))) names))) -;; Export all local variables from a module -;; (define (module-export-all! mod) + "Export all local variables from a module." (define (fresh-interface!) (let ((iface (make-module))) (set-module-name! iface (module-name mod)) @@ -3500,9 +3441,8 @@ but it fails to load." (fresh-interface!)))) (set-module-obarray! iface (module-obarray mod)))) -;; Re-export a imported variable -;; (define (module-re-export! m names) + "Re-export an imported variable." (let ((public-i (module-public-interface m))) (for-each (lambda (name) (let* ((internal-name (if (pair? name) (car name) name)) From fcebf93ecba790356e4b8dc76e6e863a34fb6438 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Mar 2017 10:40:52 +0100 Subject: [PATCH 725/865] Minor expansion of guile-test comments * test-suite/guile-test: Add -L to example. --- test-suite/guile-test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/guile-test b/test-suite/guile-test index da1bcda25..9accb009b 100755 --- a/test-suite/guile-test +++ b/test-suite/guile-test @@ -23,7 +23,7 @@ ;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA -;;;; Usage: [guile -e main -s] guile-test [OPTIONS] [TEST ...] +;;;; Usage: [guile -L `pwd`/test-suite -e main -s] guile-test [OPTIONS] [TEST ...] ;;;; ;;;; Run tests from the Guile test suite. Report failures and ;;;; unexpected passes to the standard output, along with a summary of From 1da66a6ab14b6aaedeea2a77dce130c8b397cbf0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Mar 2017 14:14:06 +0100 Subject: [PATCH 726/865] String ports can be truncated * libguile/strports.c (string_port_truncate): (scm_make_string_port_type): Support truncate-file on string ports. * test-suite/tests/ports.test ("string ports"): Add tests. --- libguile/strports.c | 13 +++++++++++++ test-suite/tests/ports.test | 39 +++++++++++++++++++++++++++++++++++++ 2 files changed, 52 insertions(+) diff --git a/libguile/strports.c b/libguile/strports.c index b12d6694a..5f78785d1 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -134,6 +134,18 @@ string_port_seek (SCM port, scm_t_off offset, int whence) } #undef FUNC_NAME +static void +string_port_truncate (SCM port, scm_t_off length) +#define FUNC_NAME "string_port_truncate" +{ + struct string_port *stream = (void *) SCM_STREAM (port); + + if (0 <= length && stream->pos <= length && length <= stream->len) + stream->len = length; + else + scm_out_of_range (FUNC_NAME, scm_from_off_t_or_off64_t (length)); +} +#undef FUNC_NAME /* The initial size in bytes of a string port's buffer. */ @@ -372,6 +384,7 @@ scm_make_string_port_type () string_port_read, string_port_write); scm_set_port_seek (ptob, string_port_seek); + scm_set_port_truncate (ptob, string_port_truncate); return ptob; } diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index 86165fdef..207c0cfa7 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -735,6 +735,45 @@ (pass-if "output check" (string=? text result))) + (pass-if-exception "truncating input string fails" + exception:wrong-type-arg + (call-with-input-string "hej" + (lambda (p) + (truncate-file p 0)))) + + (pass-if-equal "truncating output string" "hej" + (call-with-output-string + (lambda (p) + (truncate-file p 0) + (display "hej" p)))) + + (pass-if-exception "truncating output string before position" + exception:out-of-range + (call-with-output-string + (lambda (p) + (display "hej" p) + (truncate-file p 0)))) + + (pass-if-equal "truncating output string at position" "hej" + (call-with-output-string + (lambda (p) + (display "hej" p) + (truncate-file p 3)))) + + (pass-if-equal "truncating output string after seek" "" + (call-with-output-string + (lambda (p) + (display "hej" p) + (seek p 0 SEEK_SET) + (truncate-file p 0)))) + + (pass-if-equal "truncating output string after seek to end" "hej" + (call-with-output-string + (lambda (p) + (display "hej" p) + (seek p 0 SEEK_SET) + (truncate-file p 3)))) + (pass-if "%default-port-encoding is ignored" (let ((str "ĉu bone?")) ;; Latin-1 cannot represent ‘ĉ’. From e13cd5c77c030f22e3f5c27f15bb979bfda7d2ba Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Mar 2017 14:24:41 +0100 Subject: [PATCH 727/865] Flush when getting string from r6rs string output port * module/rnrs/io/ports.scm (open-string-output-port): Calling the get-string proc should flush the buffer and reset the file position. * test-suite/tests/r6rs-ports.test ("8.2.10 Output ports"): Add tests. Thanks to Freja Nordsiek for the report. --- module/rnrs/io/ports.scm | 6 +++++- test-suite/tests/r6rs-ports.test | 15 +++++++++++++++ 2 files changed, 20 insertions(+), 1 deletion(-) diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm index e924ad8fc..594606785 100644 --- a/module/rnrs/io/ports.scm +++ b/module/rnrs/io/ports.scm @@ -387,7 +387,11 @@ read from/written to in @var{port}." as a string, and a thunk to retrieve the characters associated with that port." (let ((port (open-output-string))) (values port - (lambda () (get-output-string port))))) + (lambda () + (let ((s (get-output-string port))) + (seek port 0 SEEK_SET) + (truncate-file port 0) + s))))) (define* (open-file-output-port filename #:optional diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index 94d9fc072..ba3131f2e 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -745,6 +745,21 @@ not `set-port-position!'" (with-test-prefix "open-file-output-port" (test-output-file-opener open-file-output-port (test-file))) + (pass-if "open-string-output-port" + (call-with-values open-string-output-port + (lambda (port proc) + (and (port? port) (thunk? proc))))) + + (pass-if-equal "calling string output port truncates port" + '("hello" "" "world") + (call-with-values open-string-output-port + (lambda (port proc) + (display "hello" port) + (let* ((s1 (proc)) + (s2 (proc))) + (display "world" port) + (list s1 s2 (proc)))))) + (pass-if "open-bytevector-output-port" (let-values (((port get-content) (open-bytevector-output-port #f))) From a86bb2e613f050e63275c357d7df41f019d5efc8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Mar 2017 14:48:37 +0100 Subject: [PATCH 728/865] Fix (mkstemp! "XX" 0) errors * libguile/filesys.c (scm_i_mkstemp): Validate "mode" argument as a string, and validate writability of template string early too. Thanks to Jean Louis for the bug report. --- libguile/filesys.c | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/libguile/filesys.c b/libguile/filesys.c index 40d5a41d3..b5b7e723b 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1475,6 +1475,14 @@ SCM_DEFINE (scm_i_mkstemp, "mkstemp!", 1, 1, 0, int open_flags, is_binary; SCM port; + SCM_VALIDATE_STRING (SCM_ARG1, tmpl); + if (!SCM_UNBNDP (mode)) + SCM_VALIDATE_STRING (SCM_ARG2, mode); + + /* Ensure tmpl is mutable. */ + scm_i_string_start_writing (tmpl); + scm_i_string_stop_writing (); + scm_dynwind_begin (0); c_tmpl = scm_to_locale_string (tmpl); From 77cfd7e4bfbf8271a5b75a62bbad3ce0bf79f209 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Mar 2017 15:37:05 +0100 Subject: [PATCH 729/865] Fix class slot allocation since GOOPS rewrite * module/oop/goops.scm (%compute-layout): Fix class slot layout. Before, a #:class that was an argument to #:allocation was getting interpreted as a keyword with a value. * test-suite/tests/goops.test ("#:class slot allocation"): Add test. --- module/oop/goops.scm | 2 +- test-suite/tests/goops.test | 9 +++++++++ 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index ece03c6e0..b7d980dce 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -765,7 +765,7 @@ slots as we go." (define (slot-protection-and-kind slot) (define (subclass? class parent) (memq parent (class-precedence-list class))) - (let ((type (kw-arg-ref (%slot-definition-options slot) #:class))) + (let ((type (get-keyword #:class (%slot-definition-options slot)))) (if (and type (subclass? type )) (values (cond ((subclass? type ) #\s) diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test index 259eba84b..6c6660478 100644 --- a/test-suite/tests/goops.test +++ b/test-suite/tests/goops.test @@ -572,6 +572,15 @@ exception:out-of-range (make #:a (ash 1 64)))) +(with-test-prefix "#:class slot allocation" + (pass-if-equal "basic class slot allocation" #:class + (eval '(begin + (define-class () + (bar #:allocation #:class #:init-value 'baz)) + (slot-definition-allocation + (class-slot-definition 'bar))) + (current-module)))) + (with-test-prefix "#:each-subclass" (let* (( (class () From 374b88580c388af1e96ff82cedd2b6f9a708580b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Mar 2017 16:06:53 +0100 Subject: [PATCH 730/865] Fix trap frame matching * module/system/vm/traps.scm (program-last-ip): Actually return an absolute IP. Fixes traps! --- module/system/vm/traps.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm index db82a0ab9..c4861c925 100644 --- a/module/system/vm/traps.scm +++ b/module/system/vm/traps.scm @@ -110,7 +110,9 @@ ;; Returns an absolute IP. (define (program-last-ip prog) (let ((pdi (find-program-debug-info (program-code prog)))) - (and pdi (program-debug-info-size pdi)))) + (and pdi + (+ (program-debug-info-addr pdi) + (program-debug-info-size pdi))))) (define (frame-matcher proc) (let ((proc (if (struct? proc) From 0cd60c3f2660f6fe08845a4bc1836ac8e933e9e6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Mar 2017 17:23:29 +0100 Subject: [PATCH 731/865] Cosmetic REPL server improvements * module/system/repl/server.scm (run-server*): Cosmetic improvements. --- module/system/repl/server.scm | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/module/system/repl/server.scm b/module/system/repl/server.scm index f6981edf0..cdb43cd7b 100644 --- a/module/system/repl/server.scm +++ b/module/system/repl/server.scm @@ -116,16 +116,16 @@ (sigaction SIGPIPE SIG_IGN) (add-open-socket! server-socket shutdown-server) (listen server-socket 5) - (let lp ((client (accept-new-client))) - ;; If client is false, we are shutting down. - (if client - (let ((client-socket (car client)) - (client-addr (cdr client))) - (make-thread serve-client client-socket client-addr) - (lp (accept-new-client))) - (begin (close shutdown-write-pipe) - (close shutdown-read-pipe) - (close server-socket))))) + (let lp () + (match (accept-new-client) + (#f + ;; If client is false, we are shutting down. + (close shutdown-write-pipe) + (close shutdown-read-pipe) + (close server-socket)) + ((client-socket . client-addr) + (make-thread serve-client client-socket client-addr) + (lp))))) (define* (spawn-server #:optional (server-socket (make-tcp-server-socket))) (make-thread run-server server-socket)) From 0660364998a5d6492858cd7270e7e7349521711d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Mar 2017 17:23:48 +0100 Subject: [PATCH 732/865] scm_std_select doesn't tick itself * libguile/threads.c (scm_std_select): If there are unblocked asyncs pending, return directly instead of ticking ourselves. --- libguile/threads.c | 69 +++++++++++++++++++++++++--------------------- 1 file changed, 37 insertions(+), 32 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index e67616c03..c999411e1 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1539,40 +1539,45 @@ scm_std_select (int nfds, readfds = &my_readfds; } - while (scm_i_prepare_to_wait_on_fd (t, t->sleep_pipe[1])) - SCM_TICK; - - wakeup_fd = t->sleep_pipe[0]; - FD_SET (wakeup_fd, readfds); - if (wakeup_fd >= nfds) - nfds = wakeup_fd+1; - - args.nfds = nfds; - args.read_fds = readfds; - args.write_fds = writefds; - args.except_fds = exceptfds; - args.timeout = timeout; - - /* Explicitly cooperate with the GC. */ - scm_without_guile (do_std_select, &args); - - res = args.result; - eno = args.errno_value; - - scm_i_wait_finished (t); - - if (res > 0 && FD_ISSET (wakeup_fd, readfds)) + if (scm_i_prepare_to_wait_on_fd (t, t->sleep_pipe[1])) { - char dummy; - full_read (wakeup_fd, &dummy, 1); + eno = EINTR; + res = -1; + } + else + { + wakeup_fd = t->sleep_pipe[0]; + FD_SET (wakeup_fd, readfds); + if (wakeup_fd >= nfds) + nfds = wakeup_fd+1; - FD_CLR (wakeup_fd, readfds); - res -= 1; - if (res == 0) - { - eno = EINTR; - res = -1; - } + args.nfds = nfds; + args.read_fds = readfds; + args.write_fds = writefds; + args.except_fds = exceptfds; + args.timeout = timeout; + + /* Explicitly cooperate with the GC. */ + scm_without_guile (do_std_select, &args); + + res = args.result; + eno = args.errno_value; + + scm_i_wait_finished (t); + + if (res > 0 && FD_ISSET (wakeup_fd, readfds)) + { + char dummy; + full_read (wakeup_fd, &dummy, 1); + + FD_CLR (wakeup_fd, readfds); + res -= 1; + if (res == 0) + { + eno = EINTR; + res = -1; + } + } } errno = eno; return res; From 24eea1be08391475fe932f44df51ebe1aca75a2b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Mar 2017 17:25:59 +0100 Subject: [PATCH 733/865] "select" no longer throws exception on EINTR * doc/ref/posix.texi (Ports and File Descriptors): Update. * libguile/filesys.c (scm_select): Use scm_std_select so that pending interrupts can be delivered. On EINTR or EAGAIN, just return directly so that calling Scheme code can run asyncs. --- doc/ref/posix.texi | 8 ++++---- libguile/filesys.c | 21 +++++++++++---------- 2 files changed, 15 insertions(+), 14 deletions(-) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 4afe6bf20..6f9ce545e 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -529,10 +529,10 @@ to provide input, accept output, or the existence of exceptional conditions on a collection of ports or file descriptors, or waiting for a timeout to occur. -When an error occurs, of if it is interrupted by a signal, this -procedure throws a @code{system-error} exception -(@pxref{Conventions, @code{system-error}}). In case of an -interruption, the associated error number is @var{EINTR}. +When an error occurs, this procedure throws a @code{system-error} +exception (@pxref{Conventions, @code{system-error}}). Note that +@code{select} may return early for other reasons, for example due to +pending interrupts. @xref{Asyncs}, for more on interrupts. @var{reads}, @var{writes} and @var{excepts} can be lists or vectors, with each member a port or a file descriptor. diff --git a/libguile/filesys.c b/libguile/filesys.c index b5b7e723b..478369df0 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -44,6 +44,7 @@ #include "libguile/feature.h" #include "libguile/fports.h" #include "libguile/strings.h" +#include "libguile/iselect.h" #include "libguile/vectors.h" #include "libguile/dynwind.h" #include "libguile/ports.h" @@ -79,8 +80,6 @@ #include #endif -#include - #ifdef HAVE_STRING_H #include #endif @@ -776,10 +775,9 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0, "exceptional conditions on a collection of ports or file\n" "descriptors, or waiting for a timeout to occur.\n\n" - "When an error occurs, of if it is interrupted by a signal, this\n" - "procedure throws a @code{system-error} exception\n" - "(@pxref{Conventions, @code{system-error}}). In case of an\n" - "interruption, the associated error number is @var{EINTR}.\n\n" + "When an error occurs, this procedure throws a\n" + "@code{system-error} exception " + "(@pxref{Conventions, @code{system-error}}).\n\n" "@var{reads}, @var{writes} and @var{excepts} can be lists or\n" "vectors, with each member a port or a file descriptor.\n" @@ -899,12 +897,15 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0, } { - int rv = select (max_fd + 1, - &read_set, &write_set, &except_set, - time_ptr); - if (rv < 0) + int rv = scm_std_select (max_fd + 1, + &read_set, &write_set, &except_set, + time_ptr); + /* Let EINTR / EAGAIN cause a return to the user and let them loop + to run any asyncs that might be pending. */ + if (rv < 0 && errno != EINTR && errno != EAGAIN) SCM_SYSERROR; } + return scm_list_3 (retrieve_select_type (&read_set, read_ports_ready, reads), retrieve_select_type (&write_set, write_ports_ready, writes), retrieve_select_type (&except_set, SCM_EOL, excepts)); From 82ea7c763b5f6b030583ef354263b33855111160 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Mar 2017 17:34:41 +0100 Subject: [PATCH 734/865] Fix open-file mode misinterpretation * libguile/fports.c (scm_i_mode_to_open_flags): Validate that argument is string. Fixes #25498. --- libguile/fports.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/libguile/fports.c b/libguile/fports.c index f79b4a3a8..94092b872 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -159,6 +159,9 @@ scm_i_mode_to_open_flags (SCM mode, int *is_binary, const char *FUNC_NAME) int flags = 0; const char *md, *ptr; + if (SCM_UNLIKELY (!scm_is_string (mode))) + scm_out_of_range (FUNC_NAME, mode); + if (SCM_UNLIKELY (!scm_i_try_narrow_string (mode))) scm_out_of_range (FUNC_NAME, mode); From 36321a8ffd95c8a73bd63dd6ab9fdd81590b7558 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Mar 2017 12:28:03 +0100 Subject: [PATCH 735/865] Remove extraneous debugging output in test * test-suite/standalone/test-scm-c-bind-keyword-arguments.c (missing_value_error_handler): Remove debugging write. --- test-suite/standalone/test-scm-c-bind-keyword-arguments.c | 1 - 1 file changed, 1 deletion(-) diff --git a/test-suite/standalone/test-scm-c-bind-keyword-arguments.c b/test-suite/standalone/test-scm-c-bind-keyword-arguments.c index 90bcf2baf..453c53ce8 100644 --- a/test-suite/standalone/test-scm-c-bind-keyword-arguments.c +++ b/test-suite/standalone/test-scm-c-bind-keyword-arguments.c @@ -118,7 +118,6 @@ missing_value_error_handler (void *data, SCM key, SCM args) SCM_UNDEFINED); assert (scm_is_eq (key, scm_from_utf8_symbol ("keyword-argument-error"))); - scm_write (args, scm_current_output_port ()); assert (scm_is_true (scm_equal_p (args, expected_args))); return SCM_BOOL_T; From a8d1c7d61018bb2c77c6ffd57f3c1672361ce1e9 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 24 Feb 2016 02:17:43 -0500 Subject: [PATCH 736/865] Avoid signed integer overflows in numeric conversions. Reported by Miroslav Lichvar in * libguile/conv-integer.i.c: Avoid signed overflow. * libguile/numbers.c (scm_is_signed_integer): Avoid signed overflow. --- libguile/conv-integer.i.c | 15 ++++++++++----- libguile/numbers.c | 15 ++++++++++----- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/libguile/conv-integer.i.c b/libguile/conv-integer.i.c index a5362d39c..0aa81dc74 100644 --- a/libguile/conv-integer.i.c +++ b/libguile/conv-integer.i.c @@ -64,25 +64,30 @@ SCM_TO_TYPE_PROTO (SCM val) } else { - scm_t_intmax n; + scm_t_uintmax abs_n; + TYPE n; size_t count; if (mpz_sizeinbase (SCM_I_BIG_MPZ (val), 2) > CHAR_BIT*sizeof (scm_t_uintmax)) goto out_of_range; - mpz_export (&n, &count, 1, sizeof (scm_t_uintmax), 0, 0, + mpz_export (&abs_n, &count, 1, sizeof (scm_t_uintmax), 0, 0, SCM_I_BIG_MPZ (val)); if (mpz_sgn (SCM_I_BIG_MPZ (val)) >= 0) { - if (n < 0) + if (abs_n <= TYPE_MAX) + n = abs_n; + else goto out_of_range; } else { - n = -n; - if (n >= 0) + /* Carefully avoid signed integer overflow. */ + if (TYPE_MIN < 0 && abs_n - 1 <= -(TYPE_MIN + 1)) + n = -1 - (TYPE)(abs_n - 1); + else goto out_of_range; } diff --git a/libguile/numbers.c b/libguile/numbers.c index 0d053c867..34980c6a9 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995-2015 Free Software Foundation, Inc. +/* Copyright (C) 1995-2016 Free Software Foundation, Inc. * * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories * and Bellcore. See scm_divide. @@ -9641,6 +9641,7 @@ scm_is_signed_integer (SCM val, scm_t_intmax min, scm_t_intmax max) } else { + scm_t_uintmax abs_n; scm_t_intmax n; size_t count; @@ -9648,18 +9649,22 @@ scm_is_signed_integer (SCM val, scm_t_intmax min, scm_t_intmax max) > CHAR_BIT*sizeof (scm_t_uintmax)) return 0; - mpz_export (&n, &count, 1, sizeof (scm_t_uintmax), 0, 0, + mpz_export (&abs_n, &count, 1, sizeof (scm_t_uintmax), 0, 0, SCM_I_BIG_MPZ (val)); if (mpz_sgn (SCM_I_BIG_MPZ (val)) >= 0) { - if (n < 0) + if (abs_n <= max) + n = abs_n; + else return 0; } else { - n = -n; - if (n >= 0) + /* Carefully avoid signed integer overflow. */ + if (min < 0 && abs_n - 1 <= -(min + 1)) + n = -1 - (scm_t_intmax)(abs_n - 1); + else return 0; } From 1d257c27f004fe4db81d62033b5cf2d8fafcd68f Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 6 Apr 2016 17:36:57 -0400 Subject: [PATCH 737/865] Do not assume that sizeof (long) == sizeof (void *) == sizeof (SCM). This assumption does not hold on systems that use the LLP64 data model. Partially fixes . Reported by Peter TB Brett . * libguile/numbers.h (scm_t_inum): Move here from numbers.c, and change to be equivalent to 'long' (formerly 'scm_t_signed_bits'). (SCM_MOST_POSITIVE_FIXNUM, SCM_MOST_NEGATIVE_FIXNUM): Define based on SCM_I_FIXNUM_BIT instead of SCM_T_SIGNED_BITS_MAX. (SCM_I_INUM): Adjust definitions to return a 'scm_t_inum', and avoiding the assumption that SCM_UNPACK returns a 'long'. * libguile/numbers.c (scm_t_inum): Move definition to numbers.h. Verify that 'scm_t_inum' fits within a SCM value. (scm_i_inum2big): Remove preprocessor code that forced a compile error unless sizeof (long) == sizeof (void *). --- libguile/numbers.c | 10 +++------- libguile/numbers.h | 31 +++++++++++++++---------------- 2 files changed, 18 insertions(+), 23 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 34980c6a9..3e0efc8bb 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -86,7 +86,9 @@ /* FIXME: We assume that FLT_RADIX is 2 */ verify (FLT_RADIX == 2); -typedef scm_t_signed_bits scm_t_inum; +/* Make sure that scm_t_inum fits within a SCM value. */ +verify (sizeof (scm_t_inum) <= sizeof (scm_t_bits)); + #define scm_from_inum(x) (scm_from_signed_integer (x)) /* Test an inum to see if it can be converted to a double without loss @@ -271,13 +273,7 @@ scm_i_inum2big (scm_t_inum x) { /* Return a newly created bignum initialized to X. */ SCM z = make_bignum (); -#if SIZEOF_VOID_P == SIZEOF_LONG mpz_init_set_si (SCM_I_BIG_MPZ (z), x); -#else - /* Note that in this case, you'll also have to check all mpz_*_ui and - mpz_*_si invocations in Guile. */ -#error creation of mpz not implemented for this inum size -#endif return z; } diff --git a/libguile/numbers.h b/libguile/numbers.h index bba336bd4..d2799b1c6 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -3,8 +3,8 @@ #ifndef SCM_NUMBERS_H #define SCM_NUMBERS_H -/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, - * 2008, 2009, 2010, 2011, 2013, 2014 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1998, 2000-2006, 2008-2011, 2013, 2014, + * 2016 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 License @@ -38,16 +38,15 @@ typedef scm_t_int32 scm_t_wchar; /* Immediate Numbers, also known as fixnums * - * Inums are exact integer data that fits within an SCM word. */ - -/* SCM_T_SIGNED_MAX is (- (expt 2 n) 1), - * SCM_MOST_POSITIVE_FIXNUM should be (- (expt 2 (- n 2)) 1) - * which is the same as (/ (- (expt 2 n) 4) 4) - */ - + * Inums are exact integers that fit within an SCM word + * (along with two tagging bits). + * + * In the current implementation, Inums must also fit within a long + * because that's what GMP's mpz_*_si functions accept. */ +typedef long scm_t_inum; #define SCM_I_FIXNUM_BIT (SCM_LONG_BIT - 2) -#define SCM_MOST_POSITIVE_FIXNUM ((SCM_T_SIGNED_BITS_MAX-3)/4) -#define SCM_MOST_NEGATIVE_FIXNUM (-SCM_MOST_POSITIVE_FIXNUM-1) +#define SCM_MOST_NEGATIVE_FIXNUM (-1L << (SCM_I_FIXNUM_BIT - 1)) +#define SCM_MOST_POSITIVE_FIXNUM (- (SCM_MOST_NEGATIVE_FIXNUM + 1)) /* SCM_SRS (X, Y) is signed right shift, defined as floor (X / 2^Y), where Y must be non-negative and less than the width in bits of X. @@ -74,12 +73,12 @@ typedef scm_t_int32 scm_t_wchar; NOTE: X must not perform side effects. */ #ifdef __GNUC__ -# define SCM_I_INUM(x) (SCM_SRS ((scm_t_signed_bits) SCM_UNPACK (x), 2)) +# define SCM_I_INUM(x) (SCM_SRS ((scm_t_inum) SCM_UNPACK (x), 2)) #else -# define SCM_I_INUM(x) \ - (SCM_UNPACK (x) > LONG_MAX \ - ? -1 - (scm_t_signed_bits) (~SCM_UNPACK (x) >> 2) \ - : (scm_t_signed_bits) (SCM_UNPACK (x) >> 2)) +# define SCM_I_INUM(x) \ + (SCM_UNPACK (x) > SCM_T_SIGNED_BITS_MAX \ + ? -1 - (scm_t_inum) (~SCM_UNPACK (x) >> 2) \ + : (scm_t_inum) (SCM_UNPACK (x) >> 2)) #endif #define SCM_I_INUMP(x) (2 & SCM_UNPACK (x)) From 7a32add5dc1c5dfab8b2bd8700207d8ac776b654 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 4 Aug 2016 19:14:30 +0200 Subject: [PATCH 738/865] texinfo: Remove unnecessary (oop goops) dependency. * module/texinfo/string-utils.scm: Remove #:use-module (oop goops). --- module/texinfo/string-utils.scm | 1 - 1 file changed, 1 deletion(-) diff --git a/module/texinfo/string-utils.scm b/module/texinfo/string-utils.scm index 22f969c04..42074d334 100644 --- a/module/texinfo/string-utils.scm +++ b/module/texinfo/string-utils.scm @@ -26,7 +26,6 @@ (define-module (texinfo string-utils) #:use-module (srfi srfi-13) #:use-module (srfi srfi-14) - #:use-module (oop goops) #:export (escape-special-chars transform-string expand-tabs From 8f7ed8abf22daf3c82b26e292b28eaf0a275e29a Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 11 Aug 2016 03:59:40 -0400 Subject: [PATCH 739/865] build: .x and .doc files depend on generated includes. Fixes . * libguile/Makefile.am (BUILT_INCLUDES): New variable. (BUILT_SOURCES): Put generated .h to BUILT_INCLUDES. (DOT_X_FILES, EXTRA_DOT_X_FILES, DOT_DOC_FILES, EXTRA_DOT_DOC_FILES): Depend on $(BUILT_INCLUDES), in place of scmconfig.h which is included in $(BUILT_INCLUDES). --- libguile/Makefile.am | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index c36a7e5ef..fa602201c 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -443,9 +443,9 @@ vm-operations.h: vm-engine.c | sed -e 's,VM_DEFINE_OP (\(.*\)).*, M (\1) \\,' >> $@ @echo '' >> $@ -BUILT_SOURCES = cpp-E.c cpp-SIG.c libpath.h \ - scmconfig.h \ - vm-operations.h $(DOT_X_FILES) $(EXTRA_DOT_X_FILES) +BUILT_INCLUDES = vm-operations.h scmconfig.h +BUILT_SOURCES = cpp-E.c cpp-SIG.c libpath.h $(BUILT_INCLUDES) \ + $(DOT_X_FILES) $(EXTRA_DOT_X_FILES) # Force the generation of `guile-procedures.texi' because the top-level # Makefile expects it to be built. @@ -754,9 +754,9 @@ SUFFIXES = .x .doc .c.doc: $(AM_V_SNARF)./guile-snarf-docs -o $@ $< -- $(snarfcppopts) -$(DOT_X_FILES) $(EXTRA_DOT_X_FILES): scmconfig.h snarf.h guile-snarf.in version.h +$(DOT_X_FILES) $(EXTRA_DOT_X_FILES): $(BUILT_INCLUDES) snarf.h guile-snarf.in version.h -$(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES): scmconfig.h snarf.h guile-snarf-docs.in guile_filter_doc_snarfage$(EXEEXT) +$(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES): $(BUILT_INCLUDES) snarf.h guile-snarf-docs.in guile_filter_doc_snarfage$(EXEEXT) error.x: cpp-E.c posix.x: cpp-SIG.c From b56b944920c2a1789ae1568bb146fa71ceaa92b9 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 9 Sep 2016 07:32:53 -0400 Subject: [PATCH 740/865] http: Do not use 'eq?' to compare characters in parse-request-uri. * module/web/http.scm (parse-request-uri): Use 'eqv?' to compare characters. --- module/web/http.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/web/http.scm b/module/web/http.scm index 41e429ce3..1f208f44e 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -1118,7 +1118,7 @@ not have to have a scheme or host name. The result is a URI object." (bad-request "Missing Request-URI")) ((string= str "*" start end) #f) - ((eq? (string-ref str start) #\/) + ((eqv? (string-ref str start) #\/) (let* ((q (string-index str #\? start end)) (f (string-index str #\# start end)) (q (and q (or (not f) (< q f)) q))) From 25652ff84c7949427cdda7395a44bab9a0392c4b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Mar 2017 19:52:17 +0100 Subject: [PATCH 741/865] %port-encoding requires an open port * libguile/ports.c (scm_sys_port_encoding) (scm_sys_set_port_encoding_x): Require an open port, to match 2.0 behavior. --- libguile/ports.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 3d5da3d9e..1be4a3778 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1211,7 +1211,7 @@ SCM_DEFINE (scm_sys_port_encoding, "%port-encoding", 1, 0, 0, "uses to interpret its input and output.\n") #define FUNC_NAME s_scm_sys_port_encoding { - SCM_VALIDATE_PORT (1, port); + SCM_VALIDATE_OPPORT (1, port); return SCM_PORT (port)->encoding; } @@ -1232,7 +1232,7 @@ SCM_DEFINE (scm_sys_set_port_encoding_x, "%set-port-encoding!", 2, 0, 0, "and this procedure can be used to modify that encoding.\n") #define FUNC_NAME s_scm_sys_set_port_encoding_x { - SCM_VALIDATE_PORT (1, port); + SCM_VALIDATE_OPPORT (1, port); SCM_VALIDATE_SYMBOL (2, enc); scm_i_set_port_encoding_x (port, scm_i_symbol_chars (enc)); From 844b2cf7586c31c01ab8e255d8a21aa836b7ff0b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 11 Oct 2016 10:14:26 +0200 Subject: [PATCH 742/865] Remove 'umask' calls from 'mkdir'. Fixes . * libguile/filesys.c (SCM_DEFINE): Remove calls to 'umask' when MODE is unbound; instead, use 0777 as the mode. Update docstring to clarify this. * doc/ref/posix.texi (File System): Adjust accordingly. * NEWS: Mention it. --- NEWS | 14 +++++++++++++- doc/ref/posix.texi | 7 ++++--- libguile/filesys.c | 25 ++++++++++--------------- 3 files changed, 27 insertions(+), 19 deletions(-) diff --git a/NEWS b/NEWS index 21268135a..7fa279a35 100644 --- a/NEWS +++ b/NEWS @@ -996,9 +996,21 @@ Changes in 2.0.13 (since 2.0.12): See "File System" in the manual, for more. * Bug fixes + +** 'mkdir' procedure no longer calls umask(2) () + +When the second argument to the 'mkdir' procedure was omitted, it would +call umask(0) followed by umask(previous_umask) and apply the umask to +mode #o777. + +This was unnecessary and a security issue for multi-threaded +applications: during a small window the process' umask was set to zero, +so other threads calling mkdir(2) or open(2) could end up creating +world-readable/writable/executable directories or files. + ** Fix optimizer bug when compiling fixpoint operator ** Fix build error on MinGW -** Update `uname' implementation on MinGW +** Update 'uname' implementation on MinGW Changes in 2.0.12 (since 2.0.11): diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 6f9ce545e..64e668d17 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -870,9 +870,10 @@ Create a symbolic link named @var{newpath} with the value (i.e., pointing to) @deffn {Scheme Procedure} mkdir path [mode] @deffnx {C Function} scm_mkdir (path, mode) Create a new directory named by @var{path}. If @var{mode} is omitted -then the permissions of the directory file are set using the current -umask (@pxref{Processes}). Otherwise they are set to the decimal -value specified with @var{mode}. The return value is unspecified. +then the permissions of the directory are set to @code{#o777} +masked with the current umask (@pxref{Processes, @code{umask}}). +Otherwise they are set to the value specified with @var{mode}. +The return value is unspecified. @end deffn @deffn {Scheme Procedure} rmdir path diff --git a/libguile/filesys.c b/libguile/filesys.c index 478369df0..f18560162 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1,5 +1,5 @@ /* Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004, 2006, - * 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. + * 2009, 2010, 2011, 2012, 2013, 2014, 2016 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 License @@ -1258,26 +1258,21 @@ SCM_DEFINE (scm_getcwd, "getcwd", 0, 0, 0, SCM_DEFINE (scm_mkdir, "mkdir", 1, 1, 0, (SCM path, SCM mode), "Create a new directory named by @var{path}. If @var{mode} is omitted\n" - "then the permissions of the directory file are set using the current\n" - "umask. Otherwise they are set to the decimal value specified with\n" - "@var{mode}. The return value is unspecified.") + "then the permissions of the directory are set to @code{#o777}\n" + "masked with the current umask (@pxref{Processes, @code{umask}}).\n" + "Otherwise they are set to the value specified with @var{mode}.\n" + "The return value is unspecified.") #define FUNC_NAME s_scm_mkdir { int rv; - mode_t mask; + mode_t c_mode; - if (SCM_UNBNDP (mode)) - { - mask = umask (0); - umask (mask); - STRING_SYSCALL (path, c_path, rv = mkdir (c_path, 0777 ^ mask)); - } - else - { - STRING_SYSCALL (path, c_path, rv = mkdir (c_path, scm_to_uint (mode))); - } + c_mode = SCM_UNBNDP (mode) ? 0777 : scm_to_uint (mode); + + STRING_SYSCALL (path, c_path, rv = mkdir (c_path, c_mode)); if (rv != 0) SCM_SYSERROR; + return SCM_UNSPECIFIED; } #undef FUNC_NAME From 1107db3eb193f2afa0aa18d37e3688ad74c77a14 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 11 Oct 2016 10:55:23 +0200 Subject: [PATCH 743/865] Document 'scm_to_uintptr_t' and 'scm_from_uintptr_t'. * doc/ref/api-data.texi (Integers): Document them. --- NEWS | 2 ++ doc/ref/api-data.texi | 4 +++- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 7fa279a35..5d5221ec8 100644 --- a/NEWS +++ b/NEWS @@ -995,6 +995,8 @@ Changes in 2.0.13 (since 2.0.12): See "File System" in the manual, for more. +** New 'scm_to_uintptr_t' and 'scm_from_uintptr_t' C functions + * Bug fixes ** 'mkdir' procedure no longer calls umask(2) () diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index bf46d5cd6..76a742d36 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000-2004, 2006-2015 +@c Copyright (C) 1996, 1997, 2000-2004, 2006-2016 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -422,6 +422,7 @@ function will always succeed and will always return an exact number. @deftypefnx {C Function} {unsigned long long} scm_to_ulong_long (SCM x) @deftypefnx {C Function} size_t scm_to_size_t (SCM x) @deftypefnx {C Function} ssize_t scm_to_ssize_t (SCM x) +@deftypefnx {C Function} scm_t_uintptr scm_to_uintptr_t (SCM x) @deftypefnx {C Function} scm_t_ptrdiff scm_to_ptrdiff_t (SCM x) @deftypefnx {C Function} scm_t_int8 scm_to_int8 (SCM x) @deftypefnx {C Function} scm_t_uint8 scm_to_uint8 (SCM x) @@ -458,6 +459,7 @@ the corresponding types are. @deftypefnx {C Function} SCM scm_from_ulong_long (unsigned long long x) @deftypefnx {C Function} SCM scm_from_size_t (size_t x) @deftypefnx {C Function} SCM scm_from_ssize_t (ssize_t x) +@deftypefnx {C Function} SCM scm_from_uintptr_t (uintptr_t x) @deftypefnx {C Function} SCM scm_from_ptrdiff_t (scm_t_ptrdiff x) @deftypefnx {C Function} SCM scm_from_int8 (scm_t_int8 x) @deftypefnx {C Function} SCM scm_from_uint8 (scm_t_uint8 x) From 7d6f309ccde91711a957485a2fbb82f2e81d4db2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 11 Oct 2016 10:57:43 +0200 Subject: [PATCH 744/865] Treat 'SIG_IGN' as a pointer. * libguile/posix.c (scm_system_star): Cast 'SIG_IGN' to 'scm_t_uintptr_t' and use 'scm_from_uintptr_t'. This fixes an 'int-conversion' warning with GCC 6.2. --- libguile/posix.c | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index 686b801ff..041b8b129 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1,6 +1,6 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, - * 2014 Free Software Foundation, Inc. + * 2014, 2016 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 License @@ -1489,10 +1489,12 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, scm_dynwind_begin (0); /* Make sure the child can't kill us (as per normal system call). */ - scm_dynwind_sigaction (SIGINT, scm_from_long ((long) SIG_IGN), + scm_dynwind_sigaction (SIGINT, + scm_from_uintptr_t ((scm_t_uintptr) SIG_IGN), SCM_UNDEFINED); #ifdef SIGQUIT - scm_dynwind_sigaction (SIGQUIT, scm_from_long ((long) SIG_IGN), + scm_dynwind_sigaction (SIGQUIT, + scm_from_uintptr_t ((scm_t_uintptr) SIG_IGN), SCM_UNDEFINED); #endif From b473598f2630c677200153ccd963dcb747b7298d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 11 Oct 2016 11:09:46 +0200 Subject: [PATCH 745/865] tests: Use the "normalized codeset" in locale names. * test-suite/tests/i18n.test (%french-locale-name) (%french-utf8-locale-name, %turkish-utf8-locale-name) (%german-utf8-locale-name, %greek-utf8-locale-name): Use the normalized codeset for ISO-8859-1 and UTF-8. --- test-suite/tests/i18n.test | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index 73502a01e..0078baa17 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -1,7 +1,7 @@ ;;;; i18n.test --- Exercise the i18n API. -*- coding: utf-8; mode: scheme; -*- ;;;; ;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011, 2012, -;;;; 2013, 2014, 2015 Free Software Foundation, Inc. +;;;; 2013, 2014, 2015, 2016 Free Software Foundation, Inc. ;;;; Ludovic Courtès ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -87,7 +87,7 @@ (define %french-locale-name (if mingw? "fra_FRA.850" - "fr_FR.ISO-8859-1")) + "fr_FR.iso88591")) ;"iso88591" is the "normalized codeset" ;; What we really want for the following locales is that they be Unicode ;; capable, not necessarily UTF-8, which Windows does not provide. @@ -95,22 +95,22 @@ (define %french-utf8-locale-name (if mingw? "fra_FRA.1252" - "fr_FR.UTF-8")) + "fr_FR.utf8")) ;"utf8" is the "normalized codeset" (define %turkish-utf8-locale-name (if mingw? "tur_TRK.1254" - "tr_TR.UTF-8")) + "tr_TR.utf8")) (define %german-utf8-locale-name (if mingw? "deu_DEU.1252" - "de_DE.UTF-8")) + "de_DE.utf8")) (define %greek-utf8-locale-name (if mingw? "grc_ELL.1253" - "el_GR.UTF-8")) + "el_GR.utf8")) (define %american-english-locale-name "en_US") From 402162cfcffca48d9dd518f33700eac759e35db6 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 9 Sep 2016 07:36:52 -0400 Subject: [PATCH 746/865] REPL Server: Guard against HTTP inter-protocol exploitation attacks. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Reported by Christopher Allan Webber Co-authored-by: Ludovic Courtès This commit adds protection to Guile's REPL servers against HTTP inter-protocol exploitation attacks, a scenario whereby an attacker can, via an HTML page, cause a web browser to send data to TCP servers listening on a loopback interface or private network. See and , The HTML Form Protocol Attack (2001) by Tochen Topf . Here we add a procedure to 'before-read-hook' that looks for a possible HTTP request-line in the first line of input from the client socket. If present, the socket is drained and closed, and a loud warning is written to stderr (POSIX file descriptor 2). * module/system/repl/server.scm: Add 'maybe-check-for-http-request' to 'before-read-hook' when this module is loaded. (with-temporary-port-encoding, with-saved-port-line+column) (drain-input-and-close, permissive-http-request-line?) (check-for-http-request, guard-against-http-request) (maybe-check-for-http-request): New procedures. (serve-client): Use 'guard-against-http-request'. * module/system/repl/coop-server.scm (start-repl-client): Use 'guard-against-http-request'. * doc/ref/guile-invoke.texi (Command-line Options): In the description of the --listen option, make the security warning more prominent. Mention the new protection added here. Recommend using UNIX domain sockets for REPL servers. "a path to" => "the file name of". --- doc/ref/guile-invoke.texi | 20 +++- module/system/repl/coop-server.scm | 9 +- module/system/repl/server.scm | 183 ++++++++++++++++++++++++++++- 3 files changed, 203 insertions(+), 9 deletions(-) diff --git a/doc/ref/guile-invoke.texi b/doc/ref/guile-invoke.texi index bc33ce080..d0f728e12 100644 --- a/doc/ref/guile-invoke.texi +++ b/doc/ref/guile-invoke.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010, 2011, 2013, 2014 -@c Free Software Foundation, Inc. +@c Copyright (C) 1996, 1997, 2000-2005, 2010, 2011, 2013, 2014, +@c 2016 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Invoking Guile @@ -176,7 +176,7 @@ the @file{.guile} file. @xref{Init File}. While this program runs, listen on a local port or a path for REPL clients. If @var{p} starts with a number, it is assumed to be a local port on which to listen. If it starts with a forward slash, it is -assumed to be a path to a UNIX domain socket on which to listen. +assumed to be the file name of a UNIX domain socket on which to listen. If @var{p} is not given, the default is local port 37146. If you look at it upside down, it almost spells ``Guile''. If you have netcat @@ -184,12 +184,22 @@ installed, you should be able to @kbd{nc localhost 37146} and get a Guile prompt. Alternately you can fire up Emacs and connect to the process; see @ref{Using Guile in Emacs} for more details. -Note that opening a port allows anyone who can connect to that port---in -the TCP case, any local user---to do anything Guile can do, as the user +@quotation Note +Opening a port allows anyone who can connect to that port to do anything +Guile can do, as the user that the Guile process is running as. Do not use @option{--listen} on multi-user machines. Of course, if you do not pass @option{--listen} to Guile, no port will be opened. +Guile protects against the +@uref{https://en.wikipedia.org/wiki/Inter-protocol_exploitation, +@dfn{HTTP inter-protocol exploitation attack}}, a scenario whereby an +attacker can, @i{via} an HTML page, cause a web browser to send data to +TCP servers listening on a loopback interface or private network. +Nevertheless, you are advised to use UNIX domain sockets, as in +@code{--listen=/some/local/file}, whenever possible. +@end quotation + That said, @option{--listen} is great for interactive debugging and development. diff --git a/module/system/repl/coop-server.scm b/module/system/repl/coop-server.scm index f3f5116a9..c29bbd645 100644 --- a/module/system/repl/coop-server.scm +++ b/module/system/repl/coop-server.scm @@ -1,6 +1,6 @@ ;;; Cooperative REPL server -;; Copyright (C) 2014 Free Software Foundation, Inc. +;; Copyright (C) 2014, 2016 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,6 @@ #:use-module (ice-9 threads) #:use-module (ice-9 q) #:use-module (srfi srfi-9) - #:use-module ((system repl server) #:select (make-tcp-server-socket)) #:export (spawn-coop-repl-server poll-coop-repl-server)) @@ -35,7 +34,9 @@ (define sym (@@ module sym)) ...)) (import-private (system repl repl) start-repl* prompting-meta-read) -(import-private (system repl server) run-server* add-open-socket! close-socket!) +(import-private (system repl server) + run-server* add-open-socket! close-socket! + make-tcp-server-socket guard-against-http-request) (define-record-type (%make-coop-repl-server mutex queue) @@ -177,6 +178,8 @@ and output is sent over the socket CLIENT." ;; another thread. (add-open-socket! client (lambda () (close-fdes (fileno client)))) + (guard-against-http-request client) + (with-continuation-barrier (lambda () (coop-repl-prompt diff --git a/module/system/repl/server.scm b/module/system/repl/server.scm index cdb43cd7b..725eb4eda 100644 --- a/module/system/repl/server.scm +++ b/module/system/repl/server.scm @@ -1,6 +1,6 @@ ;;; Repl server -;; Copyright (C) 2003, 2010, 2011, 2014 Free Software Foundation, Inc. +;; Copyright (C) 2003, 2010, 2011, 2014, 2016 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 @@ -22,8 +22,14 @@ (define-module (system repl server) #:use-module (system repl repl) #:use-module (ice-9 threads) + #:use-module (ice-9 rdelim) #:use-module (ice-9 match) + #:use-module (ice-9 iconv) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 binary-ports) + #:use-module ((rnrs io ports) #:select (call-with-port)) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) ; cut #:export (make-tcp-server-socket make-unix-domain-server-socket run-server @@ -136,6 +142,8 @@ ;; To shut down this thread and socket, cause it to unwind. (add-open-socket! client (lambda () (cancel-thread thread)))) + (guard-against-http-request client) + (dynamic-wind (lambda () #f) (with-continuation-barrier @@ -147,3 +155,176 @@ (with-fluids ((*repl-stack* '())) (start-repl))))) (lambda () (close-socket! client)))) + + +;;; +;;; The following code adds protection to Guile's REPL servers against +;;; HTTP inter-protocol exploitation attacks, a scenario whereby an +;;; attacker can, via an HTML page, cause a web browser to send data to +;;; TCP servers listening on a loopback interface or private network. +;;; See and +;;; , The HTML Form Protocol +;;; Attack (2001) by Tochen Topf . +;;; +;;; Here we add a procedure to 'before-read-hook' that looks for a possible +;;; HTTP request-line in the first line of input from the client socket. If +;;; present, the socket is drained and closed, and a loud warning is written +;;; to stderr (POSIX file descriptor 2). +;;; + +(define (with-temporary-port-encoding port encoding thunk) + "Call THUNK in a dynamic environment in which the encoding of PORT is +temporarily set to ENCODING." + (let ((saved-encoding #f)) + (dynamic-wind + (lambda () + (unless (port-closed? port) + (set! saved-encoding (port-encoding port)) + (set-port-encoding! port encoding))) + thunk + (lambda () + (unless (port-closed? port) + (set! encoding (port-encoding port)) + (set-port-encoding! port saved-encoding)))))) + +(define (with-saved-port-line+column port thunk) + "Save the line and column of PORT before entering THUNK, and restore +their previous values upon normal or non-local exit from THUNK." + (let ((saved-line #f) (saved-column #f)) + (dynamic-wind + (lambda () + (unless (port-closed? port) + (set! saved-line (port-line port)) + (set! saved-column (port-column port)))) + thunk + (lambda () + (unless (port-closed? port) + (set-port-line! port saved-line) + (set-port-column! port saved-column)))))) + +(define (drain-input-and-close socket) + "Drain input from SOCKET using ISO-8859-1 encoding until it would block, +and then close it. Return the drained input as a string." + (dynamic-wind + (lambda () + ;; Enable full buffering mode on the socket to allow + ;; 'get-bytevector-some' to return non-trivial chunks. + (setvbuf socket _IOFBF)) + (lambda () + (let loop ((chunks '())) + (let ((result (and (char-ready? socket) + (get-bytevector-some socket)))) + (if (bytevector? result) + (loop (cons (bytevector->string result "ISO-8859-1") + chunks)) + (string-concatenate-reverse chunks))))) + (lambda () + ;; Close the socket even in case of an exception. + (close-port socket)))) + +(define permissive-http-request-line? + ;; This predicate is deliberately permissive + ;; when checking the Request-URI component. + (let ((cs (ucs-range->char-set #x20 #x7E)) + (rx (make-regexp + (string-append + "^(OPTIONS|GET|HEAD|POST|PUT|DELETE|TRACE|CONNECT) " + "[^ ]+ " + "HTTP/[0-9]+.[0-9]+$")))) + (lambda (line) + "Return true if LINE might plausibly be an HTTP request-line, +otherwise return #f." + ;; We cannot simplify this to a simple 'regexp-exec', because + ;; 'regexp-exec' cannot cope with NUL bytes. + (and (string-every cs line) + (regexp-exec rx line))))) + +(define (check-for-http-request socket) + "Check for a possible HTTP request in the initial input from SOCKET. +If one is found, close the socket and print a report to STDERR (fdes 2). +Otherwise, put back the bytes." + ;; Temporarily set the port encoding to ISO-8859-1 to allow lossless + ;; reading and unreading of the first line, regardless of what bytes + ;; are present. Note that a valid HTTP request-line contains only + ;; ASCII characters. + (with-temporary-port-encoding socket "ISO-8859-1" + (lambda () + ;; Save the port 'line' and 'column' counters and later restore + ;; them, since unreading what we read is not sufficient to do so. + (with-saved-port-line+column socket + (lambda () + ;; Read up to (but not including) the first CR or LF. + ;; Although HTTP mandates CRLF line endings, we are permissive + ;; here to guard against the possibility that in some + ;; environments CRLF might be converted to LF before it + ;; reaches us. + (match (read-delimited "\r\n" socket 'peek) + ((? eof-object?) + ;; We found EOF before any input. Nothing to do. + 'done) + + ((? permissive-http-request-line? request-line) + ;; The input from the socket began with a plausible HTTP + ;; request-line, which is unlikely to be legitimate and may + ;; indicate an possible break-in attempt. + + ;; First, set the current port parameters to a void-port, + ;; to avoid sending any more data over the socket, to cause + ;; the REPL reader to see EOF, and to swallow any remaining + ;; output gracefully. + (let ((void-port (%make-void-port "rw"))) + (current-input-port void-port) + (current-output-port void-port) + (current-error-port void-port) + (current-warning-port void-port)) + + ;; Read from the socket until we would block, + ;; and then close it. + (let ((drained-input (drain-input-and-close socket))) + + ;; Print a report to STDERR (POSIX file descriptor 2). + ;; XXX Can we do better here? + (call-with-port (dup->port 2 "w") + (cut format <> " +@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +@@ POSSIBLE BREAK-IN ATTEMPT ON THE REPL SERVER @@ +@@ BY AN HTTP INTER-PROTOCOL EXPLOITATION ATTACK. See: @@ +@@ @@ +@@ Possible HTTP request received: ~S +@@ The associated socket has been closed. @@ +@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" + (string-append request-line + drained-input))))) + + (start-line + ;; The HTTP request-line was not found, so + ;; 'unread' the characters that we have read. + (unread-string start-line socket)))))))) + +(define (guard-against-http-request socket) + "Arrange for the Guile REPL to check for an HTTP request in the +initial input from SOCKET, in which case the socket will be closed. +This guards against HTTP inter-protocol exploitation attacks, a scenario +whereby an attacker can, via an HTML page, cause a web browser to send +data to TCP servers listening on a loopback interface or private +network." + (%set-port-property! socket 'guard-against-http-request? #t)) + +(define* (maybe-check-for-http-request + #:optional (socket (current-input-port))) + "Apply check-for-http-request to SOCKET if previously requested by +guard-against-http-request. This procedure is intended to be added to +before-read-hook." + (when (%port-property socket 'guard-against-http-request?) + (check-for-http-request socket) + (unless (port-closed? socket) + (%set-port-property! socket 'guard-against-http-request? #f)))) + +;; Install the hook. +(add-hook! before-read-hook + maybe-check-for-http-request) + +;;; Local Variables: +;;; eval: (put 'with-temporary-port-encoding 'scheme-indent-function 2) +;;; eval: (put 'with-saved-port-line+column 'scheme-indent-function 1) +;;; End: From 2cecf3b15a55abdbc844db68f7bc2458825f7b57 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 12 Oct 2016 09:37:18 +0200 Subject: [PATCH 747/865] tests: Add REPL server test for CVE-2016-8606. This is a followup to 08c021916dbd3a235a9f9cc33df4c418c0724e03. * test-suite/tests/00-repl-server.test: New file. * test-suite/Makefile.am (SCM_TESTS): Add it. --- test-suite/Makefile.am | 1 + test-suite/tests/00-repl-server.test | 139 +++++++++++++++++++++++++++ 2 files changed, 140 insertions(+) create mode 100644 test-suite/tests/00-repl-server.test diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 98cc5f026..3ce90707e 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -23,6 +23,7 @@ SUBDIRS = standalone vm SCM_TESTS = tests/00-initial-env.test \ + tests/00-repl-server.test \ tests/00-socket.test \ tests/alist.test \ tests/and-let-star.test \ diff --git a/test-suite/tests/00-repl-server.test b/test-suite/tests/00-repl-server.test new file mode 100644 index 000000000..ca389bafb --- /dev/null +++ b/test-suite/tests/00-repl-server.test @@ -0,0 +1,139 @@ +;;;; 00-repl-server.test --- REPL server. -*- mode: scheme; coding: utf-8; -*- +;;;; +;;;; Copyright (C) 2016 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (repl-server) + #:use-module (system repl server) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (web uri) + #:use-module (web request) + #:use-module (test-suite lib)) + +(define (call-with-repl-server proc) + "Set up a REPL server in a separate process and call PROC with a +socket connected to that server." + (let ((sockaddr (make-socket-address AF_UNIX "/tmp/repl-server")) + (client-socket (socket AF_UNIX SOCK_STREAM 0))) + (false-if-exception + (delete-file (sockaddr:path sockaddr))) + + (match (primitive-fork) + (0 + (dynamic-wind + (const #t) + (lambda () + (let ((server-socket (socket AF_UNIX SOCK_STREAM 0))) + (bind server-socket sockaddr) + (set! %load-verbosely #f) + + (close-fdes 2) + + ;; Arrange so that the alarming "possible break-in attempt" + ;; message doesn't show up when running the test suite. + (dup2 (open-fdes "/dev/null" O_WRONLY) 2) + + (run-server server-socket))) + (lambda () + (primitive-exit 0)))) + (pid + (dynamic-wind + (const #t) + (lambda () + ;; XXX: We can't synchronize with the server's 'accept' call + ;; because it's buried inside 'run-server', hence this hack. + (let loop ((tries 0)) + (catch 'system-error + (lambda () + (connect client-socket sockaddr)) + (lambda args + (when (and (memv (system-error-errno args) + (list ENOENT ECONNREFUSED)) + (< tries 3)) + (sleep 1) + (loop (+ tries 1)))))) + + (proc client-socket)) + (lambda () + (false-if-exception (close-port client-socket)) + (false-if-exception (kill pid SIGTERM)))))))) + +(define-syntax-rule (with-repl-server client-socket body ...) + "Evaluate BODY... in a context where CLIENT-SOCKET is bound to a +socket connected to a fresh REPL server." + (call-with-repl-server + (lambda (client-socket) + body ...))) + +(define (read-until-prompt port str) + "Read from PORT until STR has been read or the end-of-file was +reached." + (let loop () + (match (read-line port) + ((? eof-object?) + #t) + (line + (or (string=? line str) (loop)))))) + +(define %last-line-before-prompt + "Enter `,help' for help.") + + +;;; REPL server tests. +;;; +;;; Since we call 'primitive-fork', these tests must run before any +;;; tests that create threads. + +(with-test-prefix "repl-server" + + (pass-if-equal "simple expression" + "scheme@(repl-server)> $1 = 42\n" + (with-repl-server socket + (read-until-prompt socket %last-line-before-prompt) + (display "(+ 40 2)\n(quit)\n" socket) + (read-string socket))) + + (pass-if "HTTP inter-protocol attack" ;CVE-2016-8606 + (with-repl-server socket + ;; Avoid SIGPIPE when the server closes the connection. + (sigaction SIGPIPE SIG_IGN) + + (read-until-prompt socket %last-line-before-prompt) + + ;; Simulate an HTTP inter-protocol attack. + (write-request (build-request (string->uri "http://localhost")) + socket) + + ;; Make sure the server reacts by closing the connection. If it + ;; fails to do that, this test hangs. + (catch 'system-error + (lambda () + (let loop ((n 0)) + (display "(+ 40 2)\n(quit)\n" socket) ;trigger EPIPE + (read-string socket) + (if (> n 5) + #f ;failure + (begin + (sleep 1) + (loop (+ 1 n)))))) + (lambda args + (->bool (memv (system-error-errno args) + (list ECONNRESET EPIPE)))))))) + +;;; Local Variables: +;;; eval: (put 'with-repl-server 'scheme-indent-function 1) +;;; End: From bf58d7bb98f98962ee81447b8553207b00c54481 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 4 Nov 2016 22:44:32 +0100 Subject: [PATCH 748/865] tests: Throw 'unresolved when the REPL server is too slow. * test-suite/tests/00-repl-server.test (call-with-repl-server): Use (usleep 100) instead of (sleep 1). Throw 'unresolved when TRIES is too high. --- test-suite/tests/00-repl-server.test | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/test-suite/tests/00-repl-server.test b/test-suite/tests/00-repl-server.test index ca389bafb..1f570a960 100644 --- a/test-suite/tests/00-repl-server.test +++ b/test-suite/tests/00-repl-server.test @@ -61,10 +61,11 @@ socket connected to that server." (lambda () (connect client-socket sockaddr)) (lambda args - (when (and (memv (system-error-errno args) - (list ENOENT ECONNREFUSED)) - (< tries 3)) - (sleep 1) + (when (memv (system-error-errno args) + (list ENOENT ECONNREFUSED)) + (when (> tries 30) + (throw 'unresolved)) + (usleep 100) (loop (+ tries 1)))))) (proc client-socket)) From c1581fb2a1fe66fa2b3f8ee9408b1ccbcd98c09f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 4 Nov 2016 22:45:51 +0100 Subject: [PATCH 749/865] tests: Avoid race condition in REPL server test. Fixes . Reported by Rob Browning . * test-suite/tests/00-repl-server.test ("simple expression"): Add call to 'select' before 'display'. --- test-suite/tests/00-repl-server.test | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/test-suite/tests/00-repl-server.test b/test-suite/tests/00-repl-server.test index 1f570a960..4b5ec0cb3 100644 --- a/test-suite/tests/00-repl-server.test +++ b/test-suite/tests/00-repl-server.test @@ -105,8 +105,14 @@ reached." "scheme@(repl-server)> $1 = 42\n" (with-repl-server socket (read-until-prompt socket %last-line-before-prompt) - (display "(+ 40 2)\n(quit)\n" socket) - (read-string socket))) + + ;; Wait until 'repl-reader' in boot-9 has written the prompt. + ;; Otherwise, if we write too quickly, 'repl-reader' checks for + ;; 'char-ready?' and doesn't print the prompt. + (match (select (list socket) '() (list socket) 3) + (((_) () ()) + (display "(+ 40 2)\n(quit)\n" socket) + (read-string socket))))) (pass-if "HTTP inter-protocol attack" ;CVE-2016-8606 (with-repl-server socket From 33944f6607cb9d1f37335803aedaa754f1b2eb11 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Mar 2017 12:19:39 +0100 Subject: [PATCH 750/865] Disable REPL server tests if no threads * test-suite/tests/00-repl-server.test (call-with-repl-server): The REPL server needs threads so don't bother testing if we have no threads. Also, prevent SIGPIPE from killing the parent process. --- test-suite/tests/00-repl-server.test | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/00-repl-server.test b/test-suite/tests/00-repl-server.test index 4b5ec0cb3..8570ca380 100644 --- a/test-suite/tests/00-repl-server.test +++ b/test-suite/tests/00-repl-server.test @@ -32,6 +32,10 @@ socket connected to that server." (false-if-exception (delete-file (sockaddr:path sockaddr))) + ;; The REPL server requires threads. + (unless (provided? 'threads) + (throw 'unsupported)) + (match (primitive-fork) (0 (dynamic-wind @@ -51,6 +55,7 @@ socket connected to that server." (lambda () (primitive-exit 0)))) (pid + (sigaction SIGPIPE SIG_IGN) (dynamic-wind (const #t) (lambda () @@ -71,7 +76,8 @@ socket connected to that server." (proc client-socket)) (lambda () (false-if-exception (close-port client-socket)) - (false-if-exception (kill pid SIGTERM)))))))) + (false-if-exception (kill pid SIGTERM)) + (sigaction SIGPIPE SIG_DFL))))))) (define-syntax-rule (with-repl-server client-socket body ...) "Evaluate BODY... in a context where CLIENT-SOCKET is bound to a From 8b834206f99cf0b788c698c525ab7a0d5cae82f8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 12 Oct 2016 12:01:54 +0200 Subject: [PATCH 751/865] build: Check for /gnu/store file names upon "make dist". * Makefile.am (assert-no-store-file-names): New rule, taken from Guix. (dist-hook): Depend on it. --- Makefile.am | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/Makefile.am b/Makefile.am index 070332611..ebbf6d476 100644 --- a/Makefile.am +++ b/Makefile.am @@ -2,7 +2,7 @@ ## ## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2006, 2007, ## 2008, 2009, 2010, 2011, 2012, 2013, -## 2014, 2015 Free Software Foundation, Inc. +## 2014, 2015, 2016 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -91,7 +91,7 @@ DISTCLEANFILES = check-guile.log DISTCHECK_CONFIGURE_FLAGS = --enable-error-on-warning -dist-hook: gen-ChangeLog gen-tarball-version +dist-hook: gen-ChangeLog gen-tarball-version assert-no-store-file-names clean-local: rm -rf cache/ @@ -108,6 +108,16 @@ gen-ChangeLog: mv $(distdir)/cl-t $(distdir)/ChangeLog; \ fi +# Make sure we're not shipping a file that embeds a /gnu/store file +# name, for maintainers who use Guix. +.PHONY: assert-no-store-file-names +assert-no-store-file-names: + if grep -rE "/gnu/store/[a-z0-9]{32}-" $(distdir) ; \ + then \ + echo "error: store file names embedded in the distribution" >&2 ; \ + exit 1 ; \ + fi + BUILT_SOURCES += $(top_srcdir)/.version $(top_srcdir)/.version: echo $(VERSION) > $@-t && mv $@-t $@ From 58c028ebb9284250d72cef9d715f61c9dbd7d35b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 12 Oct 2016 12:03:16 +0200 Subject: [PATCH 752/865] build: Compress with lzip too. * configure.ac: Add 'dist-lzip' Automake option. --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 8c90d3feb..0186514ef 100644 --- a/configure.ac +++ b/configure.ac @@ -39,7 +39,7 @@ dnl Use `serial-tests' so the output `check-guile' is not hidden dnl (`parallel-tests' is the default in Automake 1.13.) dnl `serial-tests' was introduced in Automake 1.12. AM_INIT_AUTOMAKE([1.12 gnu no-define -Wall -Wno-override \ - serial-tests color-tests dist-xz]) + serial-tests color-tests dist-lzip dist-xz]) m4_ifdef([AM_SILENT_RULES], [AM_SILENT_RULES([yes])], [AC_SUBST([AM_DEFAULT_VERBOSITY],1)]) AC_COPYRIGHT(GUILE_CONFIGURE_COPYRIGHT) From 4d3a14924fd0a3f8d282302322131112d1113bcb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 28 Oct 2016 22:14:05 +0200 Subject: [PATCH 753/865] scandir: Avoid 'stat' calls on each entry. * module/ice-9/ftw.scm (scandir): Rewrite in terms of 'readdir'. --- module/ice-9/ftw.scm | 52 ++++++++++++++++++++------------------------ 1 file changed, 23 insertions(+), 29 deletions(-) diff --git a/module/ice-9/ftw.scm b/module/ice-9/ftw.scm index 133e9c9b5..78636286a 100644 --- a/module/ice-9/ftw.scm +++ b/module/ice-9/ftw.scm @@ -1,6 +1,6 @@ ;;;; ftw.scm --- file system tree walk -;;;; Copyright (C) 2002, 2003, 2006, 2011, 2012, 2014 Free Software Foundation, Inc. +;;;; Copyright (C) 2002, 2003, 2006, 2011, 2012, 2014, 2016 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 @@ -535,36 +535,30 @@ when FILE-NAME is not readable." "Return the list of the names of files contained in directory NAME that match predicate SELECT? (by default, all files.) The returned list of file names is sorted according to ENTRY (file-system-fold enter? leaf down up skip error #f name lstat) - (lambda (files) - (sort files entry (opendir* name) + (lambda (stream) + (let loop ((entry (readdir stream)) + (files '())) + (if (eof-object? entry) + (begin + (closedir stream) + (sort files entry Date: Wed, 14 Dec 2016 17:20:00 +0100 Subject: [PATCH 754/865] build: Honor $SOURCE_DATE_EPOCH for the recorded timestamp. Reported by Jan Nieuwenhuizen at . * libguile/Makefile.am (libpath.h): Honor 'SOURCE_DATE_EPOCH'. --- libguile/Makefile.am | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index fa602201c..07466069f 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -740,7 +740,8 @@ libpath.h: $(srcdir)/Makefile.in $(top_builddir)/config.status >> libpath.tmp @echo ' { "LIBS", "@GUILE_LIBS@" }, \' >> libpath.tmp @echo ' { "CFLAGS", "@GUILE_CFLAGS@" }, \' >> libpath.tmp - @echo ' { "buildstamp", "'`date -u +'%Y-%m-%d %T'`'" }, \' >> libpath.tmp + @BUILD_DATE="$${SOURCE_DATE_EPOCH:-`date '+%s'`}" ; \ + echo ' { "buildstamp", "'`date -u +'%Y-%m-%d %T' -d @$$BUILD_DATE`'" }, \' >> libpath.tmp @echo '}' >> libpath.tmp $(AM_V_GEN)mv libpath.tmp libpath.h From 109d22165077fdfb9984ad63347df09129401ac8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 11 Feb 2017 22:00:18 +0100 Subject: [PATCH 755/865] tests: Avoid statprof test failure on systems without 'setitimer'. Partly fixes . Reported by rennes@openmailbox.org. * test-suite/tests/statprof.test ("return values"): Wrap in 'when-implemented'. --- test-suite/tests/statprof.test | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/test-suite/tests/statprof.test b/test-suite/tests/statprof.test index 8965a0374..a597f3198 100644 --- a/test-suite/tests/statprof.test +++ b/test-suite/tests/statprof.test @@ -47,17 +47,18 @@ (pass-if-equal "return values" '(42 77) - (call-with-values - (lambda () - (with-output-to-port (%make-void-port "w") - (lambda () - (statprof - (lambda () - (let loop ((i 10000)) - (if (zero? i) - (values 42 77) - (loop (1- i))))))))) - list)) + (when-implemented + (call-with-values + (lambda () + (with-output-to-port (%make-void-port "w") + (lambda () + (statprof + (lambda () + (let loop ((i 10000)) + (if (zero? i) + (values 42 77) + (loop (1- i))))))))) + list))) (pass-if "statistical sample counts within expected range" (when-implemented From a4fbc5b091b8b804fe30830daacefc64682b0b4e Mon Sep 17 00:00:00 2001 From: Georgi Kirilov Date: Wed, 1 Mar 2017 21:01:26 +0100 Subject: [PATCH 756/865] doc: Fix typo in keywords documentation. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * doc/ref/api-data.texi (Keyword Read Syntax): Fix typo Signed-off-by: Ludovic Courtès --- doc/ref/api-data.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 76a742d36..214c6e2e1 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -5414,7 +5414,7 @@ of the form @code{:NAME} are read as symbols, as required by R5RS. @cindex SRFI-88 keyword syntax -If the @code{keyword} read option is set to @code{'postfix}, Guile +If the @code{keywords} read option is set to @code{'postfix}, Guile recognizes the SRFI-88 read syntax @code{NAME:} (@pxref{SRFI-88}). Otherwise, tokens of this form are read as symbols. From 7c5f38fe6dda9854c3cee7df51ab1031ce23a7e8 Mon Sep 17 00:00:00 2001 From: Georgi Kirilov Date: Wed, 25 Jan 2017 20:21:29 +0200 Subject: [PATCH 757/865] doc: Fix typo in site packages documentation. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * doc/ref/scheme-using.texi (Installing Site Packages): Fix typo Signed-off-by: Ludovic Courtès --- doc/ref/scheme-using.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index b7efcb4a9..ac265fcca 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -793,7 +793,7 @@ packages will be Note that a @code{.go} file will only be loaded in preference to a @code{.scm} file if it is newer. For that reason, you should install -your Scheme files first, and your compiled files second. @code{Load +your Scheme files first, and your compiled files second. @xref{Load Paths}, for more on the loading process. Finally, although this section is only about Scheme, sometimes you need From 92222727f81b2a03cde124b88d7e6224ecb29199 Mon Sep 17 00:00:00 2001 From: John Paul Adrian Glaubitz Date: Sat, 21 Jan 2017 12:49:31 +0100 Subject: [PATCH 758/865] Recognize sh3 as compilation targets MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * module/system/base/target.scm (cpu-endianness, triplet-pointer-size): Add case for "sh3". Signed-off-by: John Paul Adrian Glaubitz Signed-off-by: Ludovic Courtès --- module/system/base/target.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/module/system/base/target.scm b/module/system/base/target.scm index 02febf8e4..e80bf84e4 100644 --- a/module/system/base/target.scm +++ b/module/system/base/target.scm @@ -63,7 +63,7 @@ (cond ((string-match "^i[0-9]86$" cpu) (endianness little)) ((member cpu '("x86_64" "ia64" - "powerpcle" "powerpc64le" "mipsel" "mips64el" "nios2" "sh4" "alpha")) + "powerpcle" "powerpc64le" "mipsel" "mips64el" "nios2" "sh3" "sh4" "alpha")) (endianness little)) ((member cpu '("sparc" "sparc64" "powerpc" "powerpc64" "spu" "mips" "mips64" "m68k" "s390x")) @@ -102,7 +102,7 @@ ((string-match "64$" cpu) 8) ((string-match "64_?[lbe][lbe]$" cpu) 8) - ((member cpu '("sparc" "powerpc" "mips" "mipsel" "nios2" "m68k" "sh4")) 4) + ((member cpu '("sparc" "powerpc" "mips" "mipsel" "nios2" "m68k" "sh3" "sh4")) 4) ((member cpu '("s390x" "alpha")) 8) ((string-match "^arm.*" cpu) 4) (else (error "unknown CPU word size" cpu))))) From 19d274c68063c2799436bbba3cb11b0de9a1f75b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 12 Feb 2017 22:59:17 +0100 Subject: [PATCH 759/865] i18n: Do not represent zero as "-0". Partly fixes . Reported by Martin Michel . * module/ice-9/i18n.scm (monetary-amount->locale-string): Don't negate AMOUNT when it's zero. (number->locale-string): Likewise. * test-suite/tests/i18n.test ("number->locale-string")["positive inexact zero, 1 digit"]: New test. ("monetary-amount->locale-string")["positive inexact zero"]: New test. --- module/ice-9/i18n.scm | 7 ++++--- test-suite/tests/i18n.test | 17 ++++++++++++++--- 2 files changed, 18 insertions(+), 6 deletions(-) diff --git a/module/ice-9/i18n.scm b/module/ice-9/i18n.scm index 1d12dd061..1326a2a02 100644 --- a/module/ice-9/i18n.scm +++ b/module/ice-9/i18n.scm @@ -1,6 +1,7 @@ ;;;; i18n.scm --- internationalization support -*- coding: utf-8 -*- -;;;; Copyright (C) 2006, 2007, 2009, 2010, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 2006, 2007, 2009, 2010, 2012, +;;;; 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 @@ -335,7 +336,7 @@ locale is used." (substring dec 0 fraction-digits) dec))))) - (external-repr (number->string (if (> amount 0) amount (- amount)))) + (external-repr (number->string (if (>= amount 0) amount (- amount)))) (int+dec (string-split external-repr #\.)) (int (car int+dec)) (dec (decimal-part (if (null? (cdr int+dec)) @@ -387,7 +388,7 @@ number of fractional digits to be displayed." (substring dec 0 fraction-digits) dec)))))) - (let* ((external-repr (number->string (if (> number 0) + (let* ((external-repr (number->string (if (>= number 0) number (- number)))) (int+dec (string-split external-repr #\.)) diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index 0078baa17..53ed93232 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -1,7 +1,7 @@ ;;;; i18n.test --- Exercise the i18n API. -*- coding: utf-8; mode: scheme; -*- ;;;; ;;;; Copyright (C) 2006, 2007, 2009, 2010, 2011, 2012, -;;;; 2013, 2014, 2015, 2016 Free Software Foundation, Inc. +;;;; 2013, 2014, 2015, 2016, 2017 Free Software Foundation, Inc. ;;;; Ludovic Courtès ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -506,7 +506,10 @@ (string=? "1234.567" (number->locale-string 1234.567))) (pass-if "fraction, 1 digit" - (string=? "1234.5" (number->locale-string 1234.567 1)))) + (string=? "1234.5" (number->locale-string 1234.567 1))) + + (pass-if "positive inexact zero, 1 digit" + (string=? "0.0" (number->locale-string .0 1)))) (with-test-prefix "French" @@ -572,4 +575,12 @@ (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) (string=? "1 234,56 EUR " - (monetary-amount->locale-string 1234.567 #t fr)))))))) + (monetary-amount->locale-string 1234.567 #t + fr)))))) + + (pass-if "positive inexact zero" + (under-french-locale-or-unresolved + (lambda () + (let ((fr (make-locale LC_ALL %french-locale-name))) + (string=? "0,0 +EUR" + (monetary-amount->locale-string 0. #f fr)))))))) From 47236c2476b72c2b9d20a2dde9d68b4dd8cc7152 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 12 Feb 2017 23:42:09 +0100 Subject: [PATCH 760/865] tests: Use 'pass-if-equal' for (ice-9 i18n) tests. * test-suite/tests/i18n.test ("number->locale-string") ("format ~h", "monetary-amount->locale-string"): Use 'pass-if-equal' instead of 'pass-if'. --- test-suite/tests/i18n.test | 74 ++++++++++++++++++++------------------ 1 file changed, 40 insertions(+), 34 deletions(-) diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index 53ed93232..4eef8743e 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -494,43 +494,50 @@ (with-test-prefix "C" - (pass-if "no thousand separator" + (pass-if-equal "no thousand separator" + "" ;; Unlike in English, the "C" locale has no thousand separator. ;; If this doesn't hold, the following tests will fail. - (string=? "" (locale-thousands-separator))) + (locale-thousands-separator)) - (pass-if "integer" - (string=? "123456" (number->locale-string 123456))) + (pass-if-equal "integer" + "123456" + (number->locale-string 123456)) - (pass-if "fraction" - (string=? "1234.567" (number->locale-string 1234.567))) + (pass-if-equal "fraction" + "1234.567" + (number->locale-string 1234.567)) - (pass-if "fraction, 1 digit" - (string=? "1234.5" (number->locale-string 1234.567 1))) + (pass-if-equal "fraction, 1 digit" + "1234.5" + (number->locale-string 1234.567 1)) - (pass-if "positive inexact zero, 1 digit" - (string=? "0.0" (number->locale-string .0 1)))) + (pass-if-equal "positive inexact zero, 1 digit" + "0.0" + (number->locale-string .0 1))) (with-test-prefix "French" - (pass-if "integer" + (pass-if-equal "integer" + "123 456" (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) - (string=? "123 456" (number->locale-string 123456 #t fr)))))) + (number->locale-string 123456 #t fr))))) - (pass-if "fraction" + (pass-if-equal "fraction" + "1 234,567" (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) - (string=? "1 234,567" (number->locale-string 1234.567 #t fr)))))) + (number->locale-string 1234.567 #t fr))))) - (pass-if "fraction, 1 digit" + (pass-if-equal "fraction, 1 digit" + "1 234,5" (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) - (string=? "1 234,5" - (number->locale-string 1234.567 1 fr)))))))) + (number->locale-string 1234.567 1 fr))))))) (with-test-prefix "format ~h" @@ -540,47 +547,46 @@ (with-test-prefix "French" - (pass-if "12345.5678" + (pass-if-equal "12345.6789" + "12 345,6789" (under-french-locale-or-unresolved (lambda () (if (null? (locale-digit-grouping %french-locale)) (throw 'unresolved) - (string=? "12 345,6789" - (format #f "~:h" 12345.6789 %french-locale))))))) + (format #f "~:h" 12345.6789 %french-locale)))))) (with-test-prefix "English" - (pass-if "12345.5678" + (pass-if-equal "12345.6789" + "12,345.6789" (under-american-english-locale-or-unresolved (lambda () (if (null? (locale-digit-grouping %american-english-locale)) (throw 'unresolved) - (string=? "12,345.6789" - (format #f "~:h" 12345.6789 - %american-english-locale)))))))) + (format #f "~:h" 12345.6789 + %american-english-locale))))))) (with-test-prefix "monetary-amount->locale-string" (with-test-prefix "French" - (pass-if "integer" + (pass-if-equal "integer" + "123 456 +EUR" (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) - (string=? "123 456 +EUR" - (monetary-amount->locale-string 123456 #f fr)))))) + (monetary-amount->locale-string 123456 #f fr))))) - (pass-if "fraction" + (pass-if-equal "fraction" + "1 234,56 EUR " (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) - (string=? "1 234,56 EUR " - (monetary-amount->locale-string 1234.567 #t - fr)))))) + (monetary-amount->locale-string 1234.567 #t fr))))) - (pass-if "positive inexact zero" + (pass-if-equal "positive inexact zero" + "0,0 +EUR" (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) - (string=? "0,0 +EUR" - (monetary-amount->locale-string 0. #f fr)))))))) + (monetary-amount->locale-string 0. #f fr))))))) From 585bf8387109a0c956b15452df6c56024a5de271 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 13 Feb 2017 00:00:22 +0100 Subject: [PATCH 761/865] tests: Choose a more plausible US English locale name. * test-suite/tests/i18n.test (%american-english-locale-name): Change to en_US.utf8". --- test-suite/tests/i18n.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index 4eef8743e..3ce2b15cb 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -113,7 +113,7 @@ "el_GR.utf8")) (define %american-english-locale-name - "en_US") + "en_US.utf8") (define %french-locale (false-if-exception From 4c7d1a64fa970c42f233af84dda49180a9836321 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 13 Feb 2017 00:07:40 +0100 Subject: [PATCH 762/865] i18n: Fix corner cases for monetary and number string conversions. Fixes . Reported by Martin Michel . * module/ice-9/i18n.scm (integer->string, number-decimal-string): New procedures. (monetary-amount->locale-string): Use them instead of 'number->string' followed by 'string-split'. (number->locale-string): Likewise. * test-suite/tests/i18n.test ("number->locale-string")["fraction"]: Add second argument to 'number->locale-string'. ["fraction, 1 digit"]: Round up. ["fraction, 10 digits", "trailing zeros", "negative integer"]: New tests. * test-suite/tests/i18n.test ("format ~h"): Pass the number of decimals for ~h. ("monetary-amount->locale-string")["French"]: Always expect two decimals after the comma. ["one cent", "very little money"]: New tests. * test-suite/tests/format.test ("~h localized number")["1234.5"]: Specify the number of decimals explicitly. ["padding"]: Expect zero decimals. ["padchar"]: Ask for one decimal. ["decimals", "locale"]: Adjust rounding. --- module/ice-9/i18n.scm | 57 +++++++++++++++++++++++++++--------- test-suite/tests/format.test | 12 ++++---- test-suite/tests/i18n.test | 49 ++++++++++++++++++++++++------- 3 files changed, 88 insertions(+), 30 deletions(-) diff --git a/module/ice-9/i18n.scm b/module/ice-9/i18n.scm index 1326a2a02..2363ba350 100644 --- a/module/ice-9/i18n.scm +++ b/module/ice-9/i18n.scm @@ -246,6 +246,36 @@ 'unspecified 'unspecified) +(define (integer->string number) + "Return a string representing NUMBER, an integer, written in base 10." + (define (digit->char digit) + (integer->char (+ digit (char->integer #\0)))) + + (if (zero? number) + "0" + (let loop ((number number) + (digits '())) + (if (zero? number) + (list->string digits) + (loop (quotient number 10) + (cons (digit->char (modulo number 10)) + digits)))))) + +(define (number-decimal-string number digit-count) + "Return a string representing the decimal part of NUMBER, with exactly +DIGIT-COUNT digits" + (if (integer? number) + (make-string digit-count #\0) + + ;; XXX: This is brute-force and could be improved by following one + ;; of the "Printing Floating-Point Numbers Quickly and Accurately" + ;; papers. + (let ((number (* (expt 10 digit-count) + (- number (floor number))))) + (string-pad (integer->string (round (inexact->exact number))) + digit-count + #\0)))) + (define (%number-integer-part int grouping separator) ;; Process INT (a string denoting a number's integer part) and return a new ;; string with digit grouping and separators according to GROUPING (a list, @@ -336,12 +366,11 @@ locale is used." (substring dec 0 fraction-digits) dec))))) - (external-repr (number->string (if (>= amount 0) amount (- amount)))) - (int+dec (string-split external-repr #\.)) - (int (car int+dec)) - (dec (decimal-part (if (null? (cdr int+dec)) - "" - (cadr int+dec)))) + (int (integer->string (inexact->exact + (floor (abs amount))))) + (dec (decimal-part + (number-decimal-string (abs amount) + fraction-digits))) (grouping (locale-monetary-digit-grouping locale)) (separator (locale-monetary-thousands-separator locale))) @@ -388,14 +417,14 @@ number of fractional digits to be displayed." (substring dec 0 fraction-digits) dec)))))) - (let* ((external-repr (number->string (if (>= number 0) - number - (- number)))) - (int+dec (string-split external-repr #\.)) - (int (car int+dec)) - (dec (decimal-part (if (null? (cdr int+dec)) - "" - (cadr int+dec)))) + (let* ((int (integer->string (inexact->exact + (floor (abs number))))) + (dec (decimal-part + (number-decimal-string (abs number) + (if (integer? + fraction-digits) + fraction-digits + 0)))) (grouping (locale-digit-grouping locale)) (separator (locale-thousands-separator locale))) diff --git a/test-suite/tests/format.test b/test-suite/tests/format.test index e7b7afde8..302feac65 100644 --- a/test-suite/tests/format.test +++ b/test-suite/tests/format.test @@ -2,7 +2,7 @@ ;;;; Matthias Koeppe --- June 2001 ;;;; ;;;; Copyright (C) 2001, 2003, 2004, 2006, 2010, 2011, 2012, -;;;; 2014 Free Software Foundation, Inc. +;;;; 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 @@ -133,22 +133,22 @@ (with-test-prefix "~h localized number" (pass-if "1234.5" - (string=? (format #f "~h" 1234.5) "1234.5")) + (string=? (format #f "~,1h" 1234.5) "1234.5")) (pass-if "padding" - (string=? (format #f "~6h" 123.2) " 123.2")) + (string=? (format #f "~6h" 123.2) " 123")) (pass-if "padchar" - (string=? (format #f "~8,,'*h" 123.2) "***123.2")) + (string=? (format #f "~8,1,'*h" 123.2) "***123.2")) (pass-if "decimals" (string=? (format #f "~,2h" 123.4567) - "123.45")) + "123.46")) (pass-if "locale" (string=? (format #f "~,3:h, ~a" 1234.5678 %global-locale "approximately") - "1234.567, approximately"))) + "1234.568, approximately"))) ;;; ;;; ~{ diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index 3ce2b15cb..db7fa65e2 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -506,12 +506,20 @@ (pass-if-equal "fraction" "1234.567" - (number->locale-string 1234.567)) + (number->locale-string 1234.567 3)) (pass-if-equal "fraction, 1 digit" - "1234.5" + "1234.6" (number->locale-string 1234.567 1)) + (pass-if-equal "fraction, 10 digits" + "0.0000300000" + (number->locale-string .00003 10)) + + (pass-if-equal "trailing zeros" + "-10.00000" + (number->locale-string -10.0 5)) + (pass-if-equal "positive inexact zero, 1 digit" "0.0" (number->locale-string .0 1))) @@ -525,15 +533,22 @@ (let ((fr (make-locale LC_ALL %french-locale-name))) (number->locale-string 123456 #t fr))))) + (pass-if-equal "negative integer" + "-1 234 567" + (under-french-locale-or-unresolved + (lambda () + (let ((fr (make-locale LC_ALL %french-locale-name))) + (number->locale-string -1234567 #t fr))))) + (pass-if-equal "fraction" "1 234,567" (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) - (number->locale-string 1234.567 #t fr))))) + (number->locale-string 1234.567 3 fr))))) (pass-if-equal "fraction, 1 digit" - "1 234,5" + "1 234,6" (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) @@ -553,7 +568,7 @@ (lambda () (if (null? (locale-digit-grouping %french-locale)) (throw 'unresolved) - (format #f "~:h" 12345.6789 %french-locale)))))) + (format #f "~,4:h" 12345.6789 %french-locale)))))) (with-test-prefix "English" @@ -563,7 +578,7 @@ (lambda () (if (null? (locale-digit-grouping %american-english-locale)) (throw 'unresolved) - (format #f "~:h" 12345.6789 + (format #f "~,4:h" 12345.6789 %american-english-locale))))))) (with-test-prefix "monetary-amount->locale-string" @@ -571,22 +586,36 @@ (with-test-prefix "French" (pass-if-equal "integer" - "123 456 +EUR" + "123 456,00 +EUR" (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) (monetary-amount->locale-string 123456 #f fr))))) (pass-if-equal "fraction" - "1 234,56 EUR " + "1 234,57 EUR " (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) (monetary-amount->locale-string 1234.567 #t fr))))) (pass-if-equal "positive inexact zero" - "0,0 +EUR" + "0,00 +EUR" (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) - (monetary-amount->locale-string 0. #f fr))))))) + (monetary-amount->locale-string 0. #f fr))))) + + (pass-if-equal "one cent" + "0,01 EUR " + (under-french-locale-or-unresolved + (lambda () + (let ((fr (make-locale LC_ALL %french-locale-name))) + (monetary-amount->locale-string .01 #t fr))))) + + (pass-if-equal "very little money" + "0,00 EUR " + (under-french-locale-or-unresolved + (lambda () + (let ((fr (make-locale LC_ALL %french-locale-name))) + (monetary-amount->locale-string .00003 #t fr))))))) From de5cf50aba1b9fd43c1fbd653c5cd9b7b973d52b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 13 Feb 2017 21:30:51 +0100 Subject: [PATCH 763/865] i18n: 'number->locale-string' guesses the minimum number of decimals. This feature was removed by 4aead68cdb86ca60cc372f0cd558cadda90ddec5. * module/ice-9/i18n.scm (number-decimal-string): Rewrite the case where DIGIT-COUNT is not an integer. (number->locale-string): Always pass FRACTION-DIGITS to 'number-decimal-string'. * test-suite/tests/format.test ("~h localized number")["1234.5"] ["padding", "padchar"]: Remove decimal specifier. * test-suite/tests/i18n.test ("number->locale-string") ["fraction", * test-suite/tests/i18n.test ("format ~h")["12 345,678"]: Remove decimal specifier. Remove one decimal. * doc/ref/api-i18n.texi (Number Input and Output): Update 'number->locale-string' doc to mention the number of decimals. --- doc/ref/api-i18n.texi | 10 ++++++---- module/ice-9/i18n.scm | 38 ++++++++++++++++++++++++------------ test-suite/tests/format.test | 6 +++--- test-suite/tests/i18n.test | 16 +++++++-------- 4 files changed, 43 insertions(+), 27 deletions(-) diff --git a/doc/ref/api-i18n.texi b/doc/ref/api-i18n.texi index fa3fe99d0..0a27285b1 100644 --- a/doc/ref/api-i18n.texi +++ b/doc/ref/api-i18n.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2009, 2010 -@c Free Software Foundation, Inc. +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, +@c 2009, 2010, 2017 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Internationalization @@ -263,8 +263,10 @@ Reference Manual}). @deffn {Scheme Procedure} number->locale-string number [fraction-digits [locale]] Convert @var{number} (an inexact) into a string according to the cultural conventions of either @var{locale} (a locale object) or the -current locale. Optionally, @var{fraction-digits} may be bound to an -integer specifying the number of fractional digits to be displayed. +current locale. By default, print as many fractional digits as +necessary, up to an upper bound. Optionally, @var{fraction-digits} may +be bound to an integer specifying the number of fractional digits to be +displayed. @end deffn @deffn {Scheme Procedure} monetary-amount->locale-string amount intl? [locale] diff --git a/module/ice-9/i18n.scm b/module/ice-9/i18n.scm index 2363ba350..969c0589b 100644 --- a/module/ice-9/i18n.scm +++ b/module/ice-9/i18n.scm @@ -262,19 +262,35 @@ digits)))))) (define (number-decimal-string number digit-count) - "Return a string representing the decimal part of NUMBER, with exactly -DIGIT-COUNT digits" - (if (integer? number) - (make-string digit-count #\0) + "Return a string representing the decimal part of NUMBER. When +DIGIT-COUNT is an integer, return exactly DIGIT-COUNT digits; when +DIGIT-COUNT is #t, return as many decimals as necessary, up to an +arbitrary limit." + (define max-decimals + 5) - ;; XXX: This is brute-force and could be improved by following one - ;; of the "Printing Floating-Point Numbers Quickly and Accurately" - ;; papers. + ;; XXX: This is brute-force and could be improved by following one of + ;; the "Printing Floating-Point Numbers Quickly and Accurately" + ;; papers. + (if (integer? digit-count) (let ((number (* (expt 10 digit-count) (- number (floor number))))) (string-pad (integer->string (round (inexact->exact number))) digit-count - #\0)))) + #\0)) + (let loop ((decimals 0)) + (let ((number' (* number (expt 10 decimals)))) + (if (or (= number' (floor number')) + (>= decimals max-decimals)) + (let* ((fraction (- number' + (* (floor number) + (expt 10 decimals)))) + (str (integer->string + (round (inexact->exact fraction))))) + (if (zero? fraction) + "" + str)) + (loop (+ decimals 1))))))) (define (%number-integer-part int grouping separator) ;; Process INT (a string denoting a number's integer part) and return a new @@ -399,6 +415,7 @@ locale is used." (locale %global-locale)) "Convert @var{number} (an inexact) into a string according to the cultural conventions of either @var{locale} (a locale object) or the current locale. +By default, print as many fractional digits as necessary, up to an upper bound. Optionally, @var{fraction-digits} may be bound to an integer specifying the number of fractional digits to be displayed." @@ -421,10 +438,7 @@ number of fractional digits to be displayed." (floor (abs number))))) (dec (decimal-part (number-decimal-string (abs number) - (if (integer? - fraction-digits) - fraction-digits - 0)))) + fraction-digits))) (grouping (locale-digit-grouping locale)) (separator (locale-thousands-separator locale))) diff --git a/test-suite/tests/format.test b/test-suite/tests/format.test index 302feac65..b9aa7a854 100644 --- a/test-suite/tests/format.test +++ b/test-suite/tests/format.test @@ -133,13 +133,13 @@ (with-test-prefix "~h localized number" (pass-if "1234.5" - (string=? (format #f "~,1h" 1234.5) "1234.5")) + (string=? (format #f "~h" 1234.5) "1234.5")) (pass-if "padding" - (string=? (format #f "~6h" 123.2) " 123")) + (string=? (format #f "~6h" 123.2) " 123.2")) (pass-if "padchar" - (string=? (format #f "~8,1,'*h" 123.2) "***123.2")) + (string=? (format #f "~8,,'*h" 123.2) "***123.2")) (pass-if "decimals" (string=? (format #f "~,2h" 123.4567) diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index db7fa65e2..0475c3be5 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -506,7 +506,7 @@ (pass-if-equal "fraction" "1234.567" - (number->locale-string 1234.567 3)) + (number->locale-string 1234.567)) (pass-if-equal "fraction, 1 digit" "1234.6" @@ -545,7 +545,7 @@ (under-french-locale-or-unresolved (lambda () (let ((fr (make-locale LC_ALL %french-locale-name))) - (number->locale-string 1234.567 3 fr))))) + (number->locale-string 1234.567 #t fr))))) (pass-if-equal "fraction, 1 digit" "1 234,6" @@ -562,23 +562,23 @@ (with-test-prefix "French" - (pass-if-equal "12345.6789" - "12 345,6789" + (pass-if-equal "12345.678" + "12 345,678" (under-french-locale-or-unresolved (lambda () (if (null? (locale-digit-grouping %french-locale)) (throw 'unresolved) - (format #f "~,4:h" 12345.6789 %french-locale)))))) + (format #f "~:h" 12345.678 %french-locale)))))) (with-test-prefix "English" - (pass-if-equal "12345.6789" - "12,345.6789" + (pass-if-equal "12345.678" + "12,345.678" (under-american-english-locale-or-unresolved (lambda () (if (null? (locale-digit-grouping %american-english-locale)) (throw 'unresolved) - (format #f "~,4:h" 12345.6789 + (format #f "~:h" 12345.678 %american-english-locale))))))) (with-test-prefix "monetary-amount->locale-string" From 1026a768306bb11e7bdc3bdeff54e424b73e0c91 Mon Sep 17 00:00:00 2001 From: Arne Babenhauserheide Date: Thu, 29 Sep 2016 17:11:26 +0200 Subject: [PATCH 764/865] doc: Describe -e (module) on equal footing with (@ ...). MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * doc/ref/guile-invoke.texi, doc/ref/scheme-scripts.texi: describe the -e (module) shorthand as on equal footing with (@ ...) Co-authored-by: Ludovic Courtès --- doc/ref/guile-invoke.texi | 12 +++---- doc/ref/scheme-scripts.texi | 68 +++++++++++++++++++++++++++++++++++++ 2 files changed, 72 insertions(+), 8 deletions(-) diff --git a/doc/ref/guile-invoke.texi b/doc/ref/guile-invoke.texi index d0f728e12..a18984f31 100644 --- a/doc/ref/guile-invoke.texi +++ b/doc/ref/guile-invoke.texi @@ -102,14 +102,10 @@ that is defined in the script. It can also be of the form @code{(@@ @var{module-name} @var{symbol})}, and in that case, the symbol is looked up in the module named @var{module-name}. -For compatibility with some versions of Guile 1.4, you can also use the -form @code{(symbol ...)} (that is, a list of only symbols that doesn't -start with @code{@@}), which is equivalent to @code{(@@ (symbol ...) -main)}, or @code{(symbol ...) symbol} (that is, a list of only symbols -followed by a symbol), which is equivalent to @code{(@@ (symbol ...) -symbol)}. We recommend to use the equivalent forms directly since they -correspond to the @code{(@@ ...)} read syntax that can be used in -normal code. See @ref{Using Guile Modules} and @ref{Scripting +As a shorthand you can use the form @code{(symbol ...)}, that is, a list +of only symbols that doesn't start with @code{@@}. It is equivalent to +@code{(@@ @var{module-name} main)}, where @var{module-name} is +@code{(symbol ...)} form. @xref{Using Guile Modules} and @ref{Scripting Examples}. @item -ds diff --git a/doc/ref/scheme-scripts.texi b/doc/ref/scheme-scripts.texi index 296bea772..d845148ba 100644 --- a/doc/ref/scheme-scripts.texi +++ b/doc/ref/scheme-scripts.texi @@ -293,6 +293,11 @@ and exit. Load the file @file{/u/jimb/ex4}, and then call the function @code{main}, passing it the list @code{("/u/jimb/ex4" "foo")}. +@item guile -e '(ex4)' -s /u/jimb/ex4.scm foo +Load the file @file{/u/jimb/ex4.scm}, and then call the function +@code{main} from the module '(ex4)', passing it the list +@code{("/u/jimb/ex4" "foo")}. + @item guile -l first -ds -l last -s script Load the files @file{first}, @file{script}, and @file{last}, in that order. The @code{-ds} switch says when to process the @code{-s} @@ -369,6 +374,7 @@ Suppose that we now want to write a script which computes the @code{(choose @var{n} @var{m})} is the number of distinct subsets containing @var{n} objects each. It's easy to write @code{choose} given @code{fact}, so we might write the script this way: + @example #!/usr/local/bin/guile \ -l fact -e main -s @@ -402,6 +408,68 @@ $ ./choose 50 100 100891344545564193334812497256 @end example +To call a specific procedure from a given module, we can use the special +form @code{(@@ (@var{module}) @var{procedure})}: + +@example +#!/usr/local/bin/guile \ +-l fact -e (@@ (fac) main) -s +!# +(define-module (fac) + #:export (main)) + +(define (choose n m) + (/ (fact m) (* (fact (- m n)) (fact n)))) + +(define (main args) + (let ((n (string->number (cadr args))) + (m (string->number (caddr args)))) + (display (choose n m)) + (newline))) +@end example + +We can use @code{@@@@} to invoke non-exported procedures. For exported +procedures, we can simplify this call with the shorthand +@code{(@var{module})}: + +@example +#!/usr/local/bin/guile \ +-l fact -e (fac) -s +!# +(define-module (fac) + #:export (main)) + +(define (choose n m) + (/ (fact m) (* (fact (- m n)) (fact n)))) + +(define (main args) + (let ((n (string->number (cadr args))) + (m (string->number (caddr args)))) + (display (choose n m)) + (newline))) +@end example + +For maximum portability, we can instead use the shell to execute +@command{guile} with specified command line arguments. Here we need to +take care to quote the command arguments correctly: + +@example +#!/usr/bin/env sh +exec guile -l fact -e '(@@ (fac) main)' -s "$0" "$@" +!# +(define-module (fac) + #:export (main)) + +(define (choose n m) + (/ (fact m) (* (fact (- m n)) (fact n)))) + +(define (main args) + (let ((n (string->number (cadr args))) + (m (string->number (caddr args)))) + (display (choose n m)) + (newline))) +@end example + Finally, seasoned scripters are probably missing a mention of subprocesses. In Bash, for example, most shell scripts run other programs like @code{sed} or the like to do the actual work. From 8f7e75f77278356ad0df150ccdd67f2ab88e630f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Mar 2017 21:27:34 +0100 Subject: [PATCH 765/865] Update NEWS * NEWS: Update 2.0.x NEWS. Fold 2.1.7 NEWS into main 2.2 body. --- NEWS | 178 +++++++++++++++++++++++++++++------------------------------ 1 file changed, 89 insertions(+), 89 deletions(-) diff --git a/NEWS b/NEWS index 5d5221ec8..4d8a56380 100644 --- a/NEWS +++ b/NEWS @@ -6,85 +6,7 @@ Please send Guile bug reports to bug-guile@gnu.org. -Changes in 2.1.7 (changes since the 2.1.6 alpha release): - -* Notable changes - -** Web server now suspendable - -The web server's implementation has been slightly modified in order to -allow coroutines to suspend and resume around it when it would block on -input or output. See "Non-Blocking IO" in the manual for more. - -** Add support for arrays in `truncated-print'. - -See "Pretty Printing" in the manual. Thanks to Daniel Llorens. - -** Gnulib update - -Gnulib has been updated to v0.1-1157-gb03f418. - -* Performance improvements - -** Stringbufs immutable by default - -Stringbufs are backing buffers for strings, and are not user-visible. -Calling "substring" on a base string will result in a new string that -shares state with the base string's stringbuf. A subsequent attempt to -mutate the substring will first copy a fresh stringbuf; that is, Guile's -strings are copy-on-write. There is also "substring/shared" which -allows mutations to be shared between substring and base string; in that -case the stringbuf is modified directly. - -It used to be that mutating a string would have to take a global lock, -to ensure that no one was concurrently taking a copy-on-write substring -of that string. That is, stringbufs were mutable by default and -transitioning to immutable could happen at any time. - -This situation has been reversed: stringbufs are now immutable by -default and attempts to mutate an immutable stringbuf will copy a fresh -stringbuf and mark it as mutable. This way we can avoid the global -lock. This change likely speeds up common "substring" workloads, though -it make make the first in-place mutation on an immutable string take -more time because it has to copy a fresh backing stringbuf. - -** Speed up number->string - -** `accept' now takes optional flags argument - -These flags can include `SOCK_NONBLOCK' and `SOCK_CLOEXEC', indicating -options to apply to the returned socket, potentially removing the need -for additional system calls to set these options. See "Network Sockets -and Communication" in the manual, for more. - -* New deprecations - -** `SCM_FDES_RANDOM_P' - -Instead, use `lseek (fd, 0, SEEK_CUR)' directly. - -* Bug fixes - -** Fix too-broad capture of dynamic stack by delimited continuations - -Guile was using explicit stacks to represent, for example, the chain of -current exception handlers. This means that a delimited continuation -that captured a "catch" expression would capture the whole stack of -exception handlers, not just the exception handler added by the "catch". -This led to strangeness when resuming the continuation in some other -context like other threads; "throw" could see an invalid stack of -exception handlers. This has been fixed by the addition of the new -"fluid-ref*" procedure that can access older values of fluids; in this -way the exception handler stack is now implicit. See "Fluids and -Dynamic States" in the manual, for more on fluid-ref*. - -** Fix bug comparing unboxed floating-point values (#25492) - -Thanks to Daniel Llorens. - -** Fix crasher bugs for multiple threads writing to same port - -** Fix bug resuming partial continuations that contain prompts +Changes in 2.1.8 (changes since the 2.1.7 alpha release): Previous changes in 2.1.x (changes since the 2.0.x series): @@ -339,6 +261,13 @@ See "Custom Ports" in the manual. See "R6RS Transcoders" in the manual. +** `accept' now takes optional flags argument + +These flags can include `SOCK_NONBLOCK' and `SOCK_CLOEXEC', indicating +options to apply to the returned socket, potentially removing the need +for additional system calls to set these options. See "Network Sockets +and Communication" in the manual, for more. + ** Thread-safe atomic boxes (references) See "Atomics" in the manual. @@ -728,6 +657,19 @@ specifies #:duplicates, of course we use that. The `default-duplicate-binding-handlers' parameter now simply accesses the handlers of the current module, instead of some global value. +** Fix too-broad capture of dynamic stack by delimited continuations + +Guile was using explicit stacks to represent, for example, the chain of +current exception handlers. This means that a delimited continuation +that captured a "catch" expression would capture the whole stack of +exception handlers, not just the exception handler added by the "catch". +This led to strangeness when resuming the continuation in some other +context like other threads; "throw" could see an invalid stack of +exception handlers. This has been fixed by the addition of the new +"fluid-ref*" procedure that can access older values of fluids; in this +way the exception handler stack is now implicit. See "Fluids and +Dynamic States" in the manual, for more on fluid-ref*. + ** `dynamic-wind' doesn't check that guards are thunks Checking that the dynamic-wind out-guard procedure was actually a thunk @@ -849,6 +791,10 @@ scm_t_debug_info', `scm_pure_generic_p', `SCM_PUREGENERICP', * New deprecations +** `SCM_FDES_RANDOM_P' + +Instead, use `lseek (fd, 0, SEEK_CUR)' directly. + ** `_IONBF', `_IOLBF', and `_IOFBF' Instead, use the symbol values `none', `line', or `block', respectively, @@ -987,19 +933,60 @@ users, but packagers may be interested. -Changes in 2.0.13 (since 2.0.12): - -* Notable changes -* New interfaces -** mkstemp! takes optional "mode" argument - -See "File System" in the manual, for more. - -** New 'scm_to_uintptr_t' and 'scm_from_uintptr_t' C functions +Changes in 2.0.14 (since 2.0.13): * Bug fixes -** 'mkdir' procedure no longer calls umask(2) () +** Builds of .go files and of Guile itself are now bit-reproducible + () + +** 'number->locale-string' and 'monetary-amount->locale-string' fixes + () + +** (system base target) now recognizes "sh3" as a cross-compilation target + +** Fix race condition in '00-repl-server.test' + () + +** 'scandir' from (ice-9 ftw) no longer calls 'stat' for each entry + +** Several documentation improvements + + +Changes in 2.0.13 (since 2.0.12): + +* Security fixes + +** CVE-2016-8606: REPL server now protects against HTTP inter-protocol + attacks + +Guile 2.x provides a "REPL server" started by the '--listen' +command-line option or equivalent API (see "REPL Servers" in the +manual). + +The REPL server is vulnerable to the HTTP inter-protocol attack as +described at +, notably the +HTML form protocol attack described at +. A "DNS rebinding attack" +can be combined with this attack and allow an attacker to send arbitrary +Guile code to the REPL server through web pages accessed by the +developer, even though the REPL server is listening to a loopback device +("localhost"). This was demonstrated in an article entitled "How to +steal any developer's local database" available at +. + +The REPL server in Guile 2.0.13 now detects attempts to exploit this +vulnerability. It immediately closes the connection when it receives a +line that looks like an HTTP request. + +Nevertheless, we recommend binding the REPL server to a Unix-domain +socket, for instance by running: + + guile --listen=/tmp/guile-socket + +** CVE-2016-8605: 'mkdir' procedure no longer calls umask(2) + () When the second argument to the 'mkdir' procedure was omitted, it would call umask(0) followed by umask(previous_umask) and apply the umask to @@ -1010,9 +997,22 @@ applications: during a small window the process' umask was set to zero, so other threads calling mkdir(2) or open(2) could end up creating world-readable/writable/executable directories or files. +* New interfaces + +** mkstemp! takes optional "mode" argument + +See "File System" in the manual, for more. + +** New 'scm_to_uintptr_t' and 'scm_from_uintptr_t' C functions + +* Bug fixes + ** Fix optimizer bug when compiling fixpoint operator ** Fix build error on MinGW ** Update 'uname' implementation on MinGW +** 'port-encoding' and 'set-port-encoding!' ensure they are passed an + open port +** (system base target) now recognizes Alpha as a cross-compilation target Changes in 2.0.12 (since 2.0.11): From 8ed8b375a7b4fb50f5931648322570a730cb5944 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Mar 2017 21:38:14 +0100 Subject: [PATCH 766/865] Update NEWS for prerelease. * NEWS: Update for next prerelease. --- NEWS | 35 +++++++++++++++++++++++++++++++++++ 1 file changed, 35 insertions(+) diff --git a/NEWS b/NEWS index 4d8a56380..96cc959d9 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,41 @@ Please send Guile bug reports to bug-guile@gnu.org. Changes in 2.1.8 (changes since the 2.1.7 alpha release): +* Notable changes + +** Update to latest 2.0 changes + +Notable this includes the fix for CVE-2016-8606. + +** GUILE_PROGS searches for versioned Guile + +The GUILE_PROGS autoconf macro can take a required version argument. As +a new change, that version argument is additionally searched for as a +suffix. For example, GUILE_PROGS(2.2) would look for guile-2.2, +guile2.2, guile-2, guile2, and then guile. The found prefix is also +applied to guild, guile-config, and the like. Thanks to Freja Nordsiek +for this work. + +* Bug fixes + +** Fix type inference when multiplying flonum with complex +** Fix build errors on macOS +** Fix make-polar signedness of zeros +** Fix backtraces in case-lambda with multiple cases +** Fix generic function dispatch with multiple arities +** Fix guild compile --to=cps +** Fix bogus strength reduction on (* -1 x) +** Relax some constraints for circular module dependencies +** Fix scm_with_guile for threads already known to libgc +** Better errors for keyword arguments missing values (foo #:bar) +** Various manual updates +** Use docstrings instead of comments for many core Guile functions +** Support truncate-file on string ports +** Getting output from R6RS string ports now truncates buffer +** Fix class-allocated GOOPS slots +** Fix tracing/breakpoints (broken in 2.2 since a long time!) +** `select' just returns instead of throwing exception on EINTR + Previous changes in 2.1.x (changes since the 2.0.x series): From c2ab4a3b22e4d995a1365f89e2eb426c559dc64d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Mar 2017 21:44:53 +0100 Subject: [PATCH 767/865] Fix scheme-scripts markup. * doc/ref/scheme-scripts.texi (Scripting Examples): Fix $@ rendering in texinfo. --- doc/ref/scheme-scripts.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/scheme-scripts.texi b/doc/ref/scheme-scripts.texi index d845148ba..221c8ba20 100644 --- a/doc/ref/scheme-scripts.texi +++ b/doc/ref/scheme-scripts.texi @@ -455,7 +455,7 @@ take care to quote the command arguments correctly: @example #!/usr/bin/env sh -exec guile -l fact -e '(@@ (fac) main)' -s "$0" "$@" +exec guile -l fact -e '(@@ (fac) main)' -s "$0" "$@@" !# (define-module (fac) #:export (main)) From c896af55d40164f7a15cdeaf1f39841faeb37874 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Mar 2017 21:45:14 +0100 Subject: [PATCH 768/865] Remove useless subsection from hooks documentation * doc/ref/api-utility.texi (Hook Reference): Remove useless "handling hooks from C" section that was also generating warnings. --- doc/ref/api-utility.texi | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/doc/ref/api-utility.texi b/doc/ref/api-utility.texi index e2b60e2f9..d82d31a48 100644 --- a/doc/ref/api-utility.texi +++ b/doc/ref/api-utility.texi @@ -612,20 +612,6 @@ Return 1 if @var{x} is a Scheme-level hook, 0 otherwise. @end deftypefn -@subsubsection Handling Scheme-level hooks from C code - -Here is an example of how to handle Scheme-level hooks from C code using -the above functions. - -@example -if (scm_is_true (scm_hook_p (obj))) - /* handle Scheme-level hook using C functions */ - scm_reset_hook_x (obj); -else - /* do something else (obj is not a hook) */ -@end example - - @node C Hooks @subsubsection Hooks For C Code. From f2db8fc2f5f6d316710282ce0b663a3ebe8053a1 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 1 Mar 2017 21:49:47 +0100 Subject: [PATCH 769/865] Fix makeinfo warnings * doc/ref/api-languages.texi (Nil): * doc/ref/statprof.texi (Statprof): Use headings instead of sections to avoid makeinfo warnings. --- doc/ref/api-languages.texi | 2 +- doc/ref/statprof.texi | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/ref/api-languages.texi b/doc/ref/api-languages.texi index dd4f223df..839e6eae2 100644 --- a/doc/ref/api-languages.texi +++ b/doc/ref/api-languages.texi @@ -138,7 +138,7 @@ only one bit, and so a test for, for example, @code{#f}-or-@code{nil} may be made very efficiently. See @code{libguile/boolean.h}, for more information. -@subsubsection Equality +@subsubheading Equality Since Scheme's @code{equal?} must be transitive, and @code{'()} is not @code{equal?} to @code{#f}, to Scheme @code{nil} is not diff --git a/doc/ref/statprof.texi b/doc/ref/statprof.texi index 6282811d1..65f0d473b 100644 --- a/doc/ref/statprof.texi +++ b/doc/ref/statprof.texi @@ -89,7 +89,7 @@ because the overhead of call-counting unfairly penalizes calls. Still, this precise mode can be useful at times to do algorithmic optimizations based on the precise call counts. -@section Implementation notes +@heading Implementation notes The profiler works by setting the unix profiling signal @code{ITIMER_PROF} to go off after the interval you define in the call @@ -109,7 +109,7 @@ code has been executing within the profiler. Only run time counts towards the profile, not wall-clock time. For example, sleeping and waiting for input or output do not cause the timer clock to advance. -@section Usage +@heading Usage @deffn {Scheme Procedure} statprof thunk @ [#:loop loop=1] [#:hz hz=100] @ From 6fff84d7d1a9a839509326943a6ad3eb13c5208e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 2 Mar 2017 08:39:42 +0100 Subject: [PATCH 770/865] Revert "build: Compress with lzip too." This reverts commit 89ce9fb31b00f1f243fe6f2450db50372cc0b86d. It was causing the hydra builds to fail. --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 0186514ef..8c90d3feb 100644 --- a/configure.ac +++ b/configure.ac @@ -39,7 +39,7 @@ dnl Use `serial-tests' so the output `check-guile' is not hidden dnl (`parallel-tests' is the default in Automake 1.13.) dnl `serial-tests' was introduced in Automake 1.12. AM_INIT_AUTOMAKE([1.12 gnu no-define -Wall -Wno-override \ - serial-tests color-tests dist-lzip dist-xz]) + serial-tests color-tests dist-xz]) m4_ifdef([AM_SILENT_RULES], [AM_SILENT_RULES([yes])], [AC_SUBST([AM_DEFAULT_VERBOSITY],1)]) AC_COPYRIGHT(GUILE_CONFIGURE_COPYRIGHT) From 24da8084addc311a9213a04590619cc925585a95 Mon Sep 17 00:00:00 2001 From: Mike Gran Date: Fri, 3 Mar 2017 09:44:10 -0800 Subject: [PATCH 771/865] Cygwin: skip tests that require working setrlimits for memory On Cygwin, setrlimits cannot be used to set total memory availabe for a process. * test-suite/standalone/test-out-of-memory: skip for cygwin * test-suite/standalone/test-stack-overflow: skip for cygwin --- test-suite/standalone/test-out-of-memory | 8 ++++++++ test-suite/standalone/test-stack-overflow | 10 +++++++++- 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/test-suite/standalone/test-out-of-memory b/test-suite/standalone/test-out-of-memory index bda42cb44..95692d6ea 100755 --- a/test-suite/standalone/test-out-of-memory +++ b/test-suite/standalone/test-out-of-memory @@ -15,6 +15,14 @@ exec guile -q -s "$0" "$@" ;; See also test-stack-overflow. (exit 77)) ; unresolved +(when (string-contains-ci (vector-ref (uname) 0) "CYGWIN_NT") + ;; attempting to use setrlimits for memory RLIMIT_AS will always + ;; produce an invalid argument error on Cygwin (tested on + ;; CYGWIN_NT-10.0 DLL v2.7.0). Proceeding with the test would fill + ;; all available memory and probably end in a crash. See also + ;; test-stack-overflow. + (exit 77)) ; unresolved + (catch #t ;; Silence GC warnings. (lambda () diff --git a/test-suite/standalone/test-stack-overflow b/test-suite/standalone/test-stack-overflow index 74bc7b874..7229661c9 100755 --- a/test-suite/standalone/test-stack-overflow +++ b/test-suite/standalone/test-stack-overflow @@ -12,9 +12,17 @@ exec guile -q -s "$0" "$@" (when (string-ci= "darwin" (vector-ref (uname) 0)) ;; setrlimits are ignored in OS X (tested on 10.9 and 10.10). Proceeding ;; with the test would fill all available memory and probably end in a crash. - ;; See also test-stack-overflow. + ;; See also test-out-of-memory. (exit 77)) ; uresolved +(when (string-contains-ci (vector-ref (uname) 0) "CYGWIN_NT") + ;; attempting to use setrlimits for memory RLIMIT_AS will always + ;; produce an invalid argument error on Cygwin (tested on + ;; CYGWIN_NT-10.0 DLL v2.7.0). Proceeding with the test would fill + ;; all available memory and probably end in a crash. See also + ;; test-out-of-memory. + (exit 77)) ; unresolved + ;; 100 MB. (define *limit* (* 100 1024 1024)) From 8dc0e8d622cf699885c4b1b4277cd7aab700386d Mon Sep 17 00:00:00 2001 From: Mike Gran Date: Fri, 3 Mar 2017 09:50:27 -0800 Subject: [PATCH 772/865] Fix regression in non-mmap fallback elf loader * libguile/loader.c [!HAVE_SYS_MMAN_H] (map_file_contents): updated variables and function calls to the current names --- libguile/loader.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/libguile/loader.c b/libguile/loader.c index a4c3e884b..558a722ea 100644 --- a/libguile/loader.c +++ b/libguile/loader.c @@ -480,7 +480,7 @@ map_file_contents (int fd, size_t len, int *is_read_only) SCM_SYSERROR; *is_read_only = 1; #else - if (lseek (fd, 0, SEEK_START) < 0) + if (lseek (fd, 0, SEEK_SET) < 0) { int errno_save = errno; (void) close (fd); @@ -491,15 +491,15 @@ map_file_contents (int fd, size_t len, int *is_read_only) /* Given that we are using the read fallback, optimistically assume that the .go files were made with 8-byte alignment. alignment. */ - data = malloc (end); + data = malloc (len); if (!data) { (void) close (fd); scm_misc_error (FUNC_NAME, "failed to allocate ~A bytes", - scm_list_1 (scm_from_size_t (end))); + scm_list_1 (scm_from_size_t (len))); } - if (full_read (fd, data, end) != end) + if (full_read (fd, data, len) != len) { int errno_save = errno; (void) close (fd); @@ -512,11 +512,11 @@ map_file_contents (int fd, size_t len, int *is_read_only) /* If our optimism failed, fall back. */ { - unsigned alignment = sniff_elf_alignment (data, end); + unsigned alignment = elf_alignment (data, len); if (alignment != 8) { - char *copy = copy_and_align_elf_data (data, end, alignment); + char *copy = copy_and_align_elf_data (data, len); free (data); data = copy; } From efd6e3f40c0cd2b9b5b8f947fc1ac2aeefcdf85f Mon Sep 17 00:00:00 2001 From: Mike Gran Date: Sat, 4 Mar 2017 16:42:32 -0800 Subject: [PATCH 773/865] Disable Turkish locale tests on Cygwin Cygwin's support of Turkish casing rules is broken. * test-suite/tests/i18n.test (under-turkish-utf8-locale-or-unresolved): modified --- test-suite/tests/i18n.test | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index 0475c3be5..b48f20fac 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -164,14 +164,15 @@ (under-locale-or-unresolved %french-utf8-locale thunk)) (define (under-turkish-utf8-locale-or-unresolved thunk) - ;; FreeBSD 8.2 and 9.1, Solaris 2.10, Darwin 8.11.0, and MinGW have + ;; FreeBSD 8.2 and 9.1, Solaris 2.10, Darwin 8.11.0, Cygwin, and MinGW have ;; a broken tr_TR locale where `i' is mapped to uppercase `I' ;; instead of `İ', so disable tests on that platform. (if (or (string-contains %host-type "freebsd8") (string-contains %host-type "freebsd9") (string-contains %host-type "solaris2.10") (string-contains %host-type "darwin8") - (string-contains %host-type "mingw32")) + (string-contains %host-type "mingw32") + (string-contains %host-type "cygwin")) (throw 'unresolved) (under-locale-or-unresolved %turkish-utf8-locale thunk))) From 4ce31fd387e89c8f64716866705a5a34651506ea Mon Sep 17 00:00:00 2001 From: Mike Gran Date: Sun, 5 Mar 2017 12:26:57 -0800 Subject: [PATCH 774/865] Can't recursively search DLLs with FFI on Cygwin * doc/ref/api-foreign.text (dynamic-link): document problems with recursive DLLs. * test-suite/standalone/test-ffi (global): with Cygwin, dynamic-link C library explicitly * test-suite/standalone/test-foreign-object-scm (libc-ptr): with Cygwin, link C library explicitly * test-suite/tests/foreign.test (qsort): with Cygwin, link C library explicitly --- doc/ref/api-foreign.texi | 7 ++++++- test-suite/standalone/test-ffi | 12 ++++++++++-- test-suite/standalone/test-foreign-object-scm | 14 ++++++++++++-- test-suite/tests/foreign.test | 14 ++++++++++++-- 4 files changed, 40 insertions(+), 7 deletions(-) diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi index 527902209..2f5375d28 100644 --- a/doc/ref/api-foreign.texi +++ b/doc/ref/api-foreign.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000-2004, 2007-2014, 2016 +@c Copyright (C) 1996, 1997, 2000-2004, 2007-2014, 2016-2017 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -89,6 +89,11 @@ When @var{library} is omitted, a @dfn{global symbol handle} is returned. This handle provides access to the symbols available to the program at run-time, including those exported by the program itself and the shared libraries already loaded. + +Note that on hosts that use dynamic-link libraries (DLLs), the global +symbol handle may not be able to provide access to symbols from +recursively-loaded DLLs. Only exported symbols from those DLLs directly +loaded by the program may be available. @end deffn @deffn {Scheme Procedure} dynamic-object? obj diff --git a/test-suite/standalone/test-ffi b/test-suite/standalone/test-ffi index 0a91f63f9..0e6ab45d1 100755 --- a/test-suite/standalone/test-ffi +++ b/test-suite/standalone/test-ffi @@ -3,7 +3,7 @@ exec guile -q -s "$0" "$@" !# ;;; test-ffi --- Foreign function interface. -*- Scheme -*- ;;; -;;; 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 @@ -263,7 +263,15 @@ exec guile -q -s "$0" "$@" (if (defined? 'setlocale) (setlocale LC_ALL "C")) -(define global (dynamic-link)) +(define global (cond + ((string-contains %host-type "cygwin") + ;; On Cygwin, dynamic-link doesn't search recursively + ;; into linked DLLs. Thus one needs to link to the core + ;; C library DLL explicitly. + (dynamic-link "cygwin1")) + (else + (dynamic-link)))) + (define strerror (pointer->procedure '* (dynamic-func "strerror" global) diff --git a/test-suite/standalone/test-foreign-object-scm b/test-suite/standalone/test-foreign-object-scm index 7e4bd85d8..fd4669aa9 100755 --- a/test-suite/standalone/test-foreign-object-scm +++ b/test-suite/standalone/test-foreign-object-scm @@ -3,7 +3,7 @@ exec guile -q -s "$0" "$@" !# ;;; test-foreign-object-scm --- Foreign object interface. -*- Scheme -*- ;;; -;;; Copyright (C) 2014 Free Software Foundation, Inc. +;;; Copyright (C) 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 @@ -26,7 +26,17 @@ exec guile -q -s "$0" "$@" (define (libc-ptr name) (catch #t - (lambda () (dynamic-pointer name (dynamic-link))) + (lambda () + (dynamic-pointer name + (cond + ((string-contains %host-type "cygwin") + ;; On Cygwin, dynamic-link does not search + ;; recursively into linked DLLs. Thus, one + ;; needs to link to the core C library DLL + ;; explicitly. + (dynamic-link "cygwin1")) + (else + (dynamic-link))))) (lambda (k . args) (print-exception (current-error-port) #f k args) (write "Skipping test.\n" (current-error-port)) diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test index c53c0447b..67b5c3790 100644 --- a/test-suite/tests/foreign.test +++ b/test-suite/tests/foreign.test @@ -1,6 +1,6 @@ ;;;; foreign.test --- FFI. -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 2010, 2011, 2012, 2013, 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 @@ -233,7 +233,17 @@ ;; not visible. (false-if-exception (pointer->procedure void - (dynamic-func "qsort" (dynamic-link)) + (dynamic-func "qsort" + (cond + ((string-contains %host-type "cygwin") + ;; On Cygwin, dynamic-link does + ;; not search recursively into + ;; linked DLLs. Thus, one needs + ;; to link to the core C + ;; library DLL explicitly. + (dynamic-link "cygwin1")) + (else + (dynamic-link)))) (list '* size_t size_t '*)))) (define (dereference-pointer-to-byte ptr) From 70cfabd7e87f93d210bad377feb7ca50fa3bd133 Mon Sep 17 00:00:00 2001 From: Mike Gran Date: Mon, 6 Mar 2017 23:06:12 -0800 Subject: [PATCH 775/865] Check for working profiling and virtual itimers * configure.ac (HAVE_USABLE_GETITIMER_PROF, HAVE_USABLE_GETITIMER_VIRTUAL): new tests * doc/ref/posix.texi (setitimer, getitimer): document provided? 'ITIMER_VIRTUAL and 'ITIMER_PROF * doc/ref/statprof.texi (statprof): document ITIMER_PROF requirements * libguile/scmsigs.c (scm_setitimer, scm_getitimer): document (provided? 'ITIMER_VIRTUAL) and (provided? 'ITIMER_PROF) (scm_init_scmsigs): add features ITIMER_VIRTUAL and ITIMER_PROF * test-suite/tests/asyncs.test ("prevention via sigprof"): throw when unsupported * test-suite/tests/signals.test: throw when not supported * test-suite/tests/statprof.test: throw when not supported --- configure.ac | 53 +++++++++++++++++++++++- doc/ref/posix.texi | 15 +++++-- doc/ref/statprof.texi | 12 ++++-- libguile/scmsigs.c | 27 +++++++++--- test-suite/tests/asyncs.test | 5 ++- test-suite/tests/signals.test | 76 ++++++++++++++++++++-------------- test-suite/tests/statprof.test | 15 +++---- 7 files changed, 148 insertions(+), 55 deletions(-) diff --git a/configure.ac b/configure.ac index 8c90d3feb..24ee878d5 100644 --- a/configure.ac +++ b/configure.ac @@ -5,7 +5,7 @@ dnl define(GUILE_CONFIGURE_COPYRIGHT,[[ Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, - 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 Free Software Foundation, Inc. + 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Free Software Foundation, Inc. This file is part of GUILE @@ -880,6 +880,57 @@ main (void) esac fi +# Cygwin and Hurd (circa 2017) and various prior versions defined stub +# versions of the virtual and profiling itimers that would always fail +# when called. +if test "$ac_cv_func_getitimer" = yes; then + + AC_CACHE_CHECK([whether getitimer(ITIMER_PROF) is usable], + guile_cv_use_getitimer_prof, + [AC_RUN_IFELSE([AC_LANG_SOURCE([[ +#include +int +main (void) +{ + struct itimerval I; + if (getitimer (ITIMER_PROF, &I) == 0) + return 0; /* good */ + else + return 1; /* bad */ +}]])], + [guile_cv_use_getitimer_prof=yes], + [guile_cv_use_getitimer_prof=no], + [guile_cv_use_getitimer_prof="yes, hopefully (cross-compiling)"])]) + case $guile_cv_use_getitimer_prof in + yes*) + AC_DEFINE([HAVE_USABLE_GETITIMER_PROF], 1, [Define to 1 if getitimer(ITIMER_PROF, ...) is functional]) + ;; + esac + + AC_CACHE_CHECK([whether getitimer(ITIMER_VIRTUAL) is usable], + guile_cv_use_getitimer_virtual, + [AC_RUN_IFELSE([AC_LANG_SOURCE([[ +#include +int +main (void) +{ + struct itimerval I; + if (getitimer (ITIMER_VIRTUAL, &I) == 0) + return 0; /* good */ + else + return 1; /* bad */ +}]])], + [guile_cv_use_getitimer_virtual=yes], + [guile_cv_use_getitimer_virtual=no], + [guile_cv_use_getitimer_virtual="yes, hopefully (cross-compiling)"])]) + case $guile_cv_use_getitimer_virtual in + yes*) + AC_DEFINE([HAVE_USABLE_GETITIMER_VIRTUAL], 1, [Define to 1 if getitimer(ITIMER_VIRTUAL, ...) is functional]) + ;; + esac +fi + + AC_CACHE_SAVE dnl GMP tests diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 64e668d17..5cb68a292 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. @c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, -@c 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +@c 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2017 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node POSIX @@ -2162,12 +2162,12 @@ expiry will be signalled. A real-time timer, counting down elapsed real time. At zero it raises @code{SIGALRM}. This is like @code{alarm} above, but with a higher resolution period. -@end defvar +@end defvar @defvar ITIMER_VIRTUAL A virtual-time timer, counting down while the current process is actually using CPU. At zero it raises @code{SIGVTALRM}. -@end defvar +@end defvar @defvar ITIMER_PROF A profiling timer, counting down while the process is running (like @@ -2176,7 +2176,7 @@ process's behalf. At zero it raises a @code{SIGPROF}. This timer is intended for profiling where a program is spending its time (by looking where it is when the timer goes off). -@end defvar +@end defvar @code{getitimer} returns the restart timer value and its current value, as a list containing two pairs. Each pair is a time in seconds and @@ -2196,6 +2196,13 @@ previous setting, in the same form as @code{getitimer} returns. Although the timers are programmed in microseconds, the actual accuracy might not be that high. + +Note that @code{ITIMER_PROF} and @code{ITIMER_VIRTUAL} are not +functional on all platforms and may always error when called. +@code{(provided? 'ITIMER_PROF)} and @code{(provided? 'ITIMER_VIRTUAL)} +can be used to test if the those itimers are supported on the given +host. @code{ITIMER_REAL} is supported on all platforms that support +@code{setitimer}. @end deffn diff --git a/doc/ref/statprof.texi b/doc/ref/statprof.texi index 65f0d473b..850c5bd2e 100644 --- a/doc/ref/statprof.texi +++ b/doc/ref/statprof.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 2013, 2015 Free Software Foundation, Inc. +@c Copyright (C) 2013, 2015, 2017 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Statprof @@ -128,17 +128,21 @@ After the @var{thunk} has been profiled, print out a profile to @var{port}. If @var{display-style} is @code{flat}, the results will be printed as a flat profile. Otherwise if @var{display-style} is @code{tree}, print the results as a tree profile. + +Note that @code{statprof} requires a working profiling timer. Some +platforms do not support profiling timers. @code{(provided? +'ITIMER_PROF)} can be used to check for support of profiling timers. @end deffn Profiling can also be enabled and disabled manually. -@deffn {Scheme Procedure} statprof-active? +@deffn {Scheme Procedure} statprof-active? Returns @code{#t} if @code{statprof-start} has been called more times than @code{statprof-stop}, @code{#f} otherwise. @end deffn -@deffn {Scheme Procedure} statprof-start -@deffnx {Scheme Procedure} statprof-stop +@deffn {Scheme Procedure} statprof-start +@deffnx {Scheme Procedure} statprof-stop Start or stop the profiler. @end deffn diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c index f210380e8..21b2a9529 100644 --- a/libguile/scmsigs.c +++ b/libguile/scmsigs.c @@ -1,5 +1,5 @@ /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, - * 2007, 2008, 2009, 2011, 2013, 2014 Free Software Foundation, Inc. + * 2007, 2008, 2009, 2011, 2013, 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 License @@ -554,7 +554,13 @@ SCM_DEFINE (scm_setitimer, "setitimer", 5, 0, 0, "The return value will be a list of two cons pairs representing the\n" "current state of the given timer. The first pair is the seconds and\n" "microseconds of the timer @code{it_interval}, and the second pair is\n" - "the seconds and microseconds of the timer @code{it_value}.") + "the seconds and microseconds of the timer @code{it_value}." + "\n" + "@code{ITIMER_PROF} or @code{ITIMER_VIRTUAL} are not supported on\n" + "some platforms and will always error. @code{(provided? 'ITIMER_PROF)}\n" + "and @code{(provided? 'ITIMER_VIRTUAL)} report whether those timers\n" + "are supported.\n") + #define FUNC_NAME s_scm_setitimer { int rv; @@ -591,7 +597,12 @@ SCM_DEFINE (scm_getitimer, "getitimer", 1, 0, 0, "The return value will be a list of two cons pairs representing the\n" "current state of the given timer. The first pair is the seconds and\n" "microseconds of the timer @code{it_interval}, and the second pair is\n" - "the seconds and microseconds of the timer @code{it_value}.") + "the seconds and microseconds of the timer @code{it_value}." + "\n" + "@code{ITIMER_PROF} or @code{ITIMER_VIRTUAL} are not supported on\n" + "some platforms and will always error. @code{(provided? 'ITIMER_PROF)}\n" + "and @code{(provided? 'ITIMER_VIRTUAL)} report whether those timers\n" + "are supported.\n") #define FUNC_NAME s_scm_getitimer { int rv; @@ -601,10 +612,10 @@ SCM_DEFINE (scm_getitimer, "getitimer", 1, 0, 0, c_which_timer = SCM_NUM2INT(1, which_timer); SCM_SYSCALL(rv = getitimer(c_which_timer, &old_timer)); - + if(rv != 0) SCM_SYSERROR; - + return scm_list_2 (scm_cons (scm_from_long (old_timer.it_interval.tv_sec), scm_from_long (old_timer.it_interval.tv_usec)), scm_cons (scm_from_long (old_timer.it_value.tv_sec), @@ -726,6 +737,12 @@ scm_init_scmsigs () scm_c_define ("ITIMER_REAL", scm_from_int (ITIMER_REAL)); scm_c_define ("ITIMER_VIRTUAL", scm_from_int (ITIMER_VIRTUAL)); scm_c_define ("ITIMER_PROF", scm_from_int (ITIMER_PROF)); +#ifdef HAVE_USABLE_GETITIMER_PROF + scm_add_feature ("ITIMER_PROF"); +#endif +#ifdef HAVE_USABLE_GETITIMER_VIRTUAL + scm_add_feature ("ITIMER_VIRTUAL"); +#endif #endif /* defined(HAVE_SETITIMER) || defined(HAVE_GETITIMER) */ #include "libguile/scmsigs.x" diff --git a/test-suite/tests/asyncs.test b/test-suite/tests/asyncs.test index 437927a81..4ac9020c4 100644 --- a/test-suite/tests/asyncs.test +++ b/test-suite/tests/asyncs.test @@ -1,6 +1,6 @@ ;;;; asyncs.test -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2016 Free Software Foundation, Inc. +;;;; Copyright (C) 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 @@ -51,7 +51,8 @@ (setitimer ITIMER_PROF 0 0 0 0) (sigaction SIGPROF prev-handler))))) -(when (defined? 'setitimer) +(when (and (defined? 'setitimer) + (provided? 'ITIMER_PROF)) (pass-if "preemption via sigprof" ;; Use an atomic box as a compiler barrier. (let* ((box (make-atomic-box 0)) diff --git a/test-suite/tests/signals.test b/test-suite/tests/signals.test index ef61aaa83..ac730a91e 100644 --- a/test-suite/tests/signals.test +++ b/test-suite/tests/signals.test @@ -1,17 +1,17 @@ ;;;; signals.test --- test suite for Guile's signal functions -*- scheme -*- -;;;; -;;;; Copyright (C) 2009, 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 ;;;; License as published by the Free Software Foundation; either ;;;; version 3 of the License, or (at your option) any later version. -;;;; +;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; Lesser General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free ;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, @@ -41,39 +41,51 @@ (equal? (setitimer ITIMER_REAL 0 0 0 0) '((0 . 0) (0 . 0)))) (pass-if "ITIMER_VIRTUAL" - (equal? (setitimer ITIMER_VIRTUAL 0 0 0 0) - '((0 . 0) (0 . 0)))) + (if (not (provided? 'ITIMER_VIRTUAL)) + (throw 'unsupported) + (equal? (setitimer ITIMER_VIRTUAL 0 0 0 0) + '((0 . 0) (0 . 0))))) (pass-if "ITIMER_PROF" - (equal? (setitimer ITIMER_PROF 0 0 0 0) - '((0 . 0) (0 . 0))))) + (if (not (provided? 'ITIMER_PROF)) + (throw 'unsupported) + (equal? (setitimer ITIMER_PROF 0 0 0 0) + '((0 . 0) (0 . 0)))))) (with-test-prefix "setting values correctly" (pass-if "initial setting" - (equal? (setitimer ITIMER_PROF 1 0 3 0) - '((0 . 0) (0 . 0)))) + (if (not (provided? 'ITIMER_PROF)) + (throw 'unsupported) + (equal? (setitimer ITIMER_PROF 1 0 3 0) + '((0 . 0) (0 . 0))))) (pass-if "reset to zero" - (match (setitimer ITIMER_PROF 0 0 0 0) - ((interval value) - ;; We don't presume that the timer is strictly lower than the - ;; value at which we set it, given its limited internal - ;; precision. Assert instead that the timer is between 2 and - ;; 3.5 seconds. - (and (<= 0.9 (time-pair->secs interval) 1.1) - (<= 2.0 (time-pair->secs value) 3.5)))))) + (if (not (provided? 'ITIMER_PROF)) + (throw 'unsupported) + (match (setitimer ITIMER_PROF 0 0 0 0) + ((interval value) + ;; We don't presume that the timer is strictly lower than the + ;; value at which we set it, given its limited internal + ;; precision. Assert instead that the timer is between 2 and + ;; 3.5 seconds. + (and (<= 0.9 (time-pair->secs interval) 1.1) + (<= 2.0 (time-pair->secs value) 3.5))))))) (with-test-prefix "usecs > 1e6" (pass-if "initial setting" - (equal? (setitimer ITIMER_PROF 1 0 0 #e3e6) - '((0 . 0) (0 . 0)))) + (if (not (provided? 'ITIMER_PROF)) + (throw 'unsupported) + (equal? (setitimer ITIMER_PROF 1 0 0 #e3e6) + '((0 . 0) (0 . 0))))) (pass-if "reset to zero" - (match (setitimer ITIMER_PROF 0 0 0 0) - ((interval value) - ;; We don't presume that the timer is strictly lower than the - ;; value at which we set it, given its limited internal - ;; precision. Assert instead that the timer is between 2 and - ;; 3.5 seconds. - (and (<= 0.9 (time-pair->secs interval) 1.1) - (<= 2.0 (time-pair->secs value) 3.5) - (match value - ((secs . usecs) - (<= 0 usecs 999999)))))))))) + (if (not (provided? 'ITIMER_PROF)) + (throw 'unsupported) + (match (setitimer ITIMER_PROF 0 0 0 0) + ((interval value) + ;; We don't presume that the timer is strictly lower than the + ;; value at which we set it, given its limited internal + ;; precision. Assert instead that the timer is between 2 and + ;; 3.5 seconds. + (and (<= 0.9 (time-pair->secs interval) 1.1) + (<= 2.0 (time-pair->secs value) 3.5) + (match value + ((secs . usecs) + (<= 0 usecs 999999))))))))))) diff --git a/test-suite/tests/statprof.test b/test-suite/tests/statprof.test index a597f3198..994d88269 100644 --- a/test-suite/tests/statprof.test +++ b/test-suite/tests/statprof.test @@ -1,4 +1,5 @@ -;; guile-lib -*- scheme -*- +;;;; statprof.test --- test suite for Guile's profiler -*- scheme -*- +;;;; Copyright (C) 2017 Free Software Foundation, Inc. ;; Copyright (C) 2004, 2009, 2010, 2014 Andy Wingo ;; Copyright (C) 2001 Rob Browning @@ -31,9 +32,9 @@ #:use-module (srfi srfi-1) #:use-module (statprof)) -;; Throw `unresolved' upon ENOSYS. This is used to skip tests on -;; platforms such as GNU/Hurd where `ITIMER_PROF' is is currently -;; unimplemented. +;; Throw `unresolved' upon ENOSYS or EINVAL. This is used to skip tests +;; on platforms such as GNU/Hurd or Cygwin where `ITIMER_PROF' is is +;; currently unimplemented. (define-syntax-rule (when-implemented body ...) (catch 'system-error (lambda () @@ -41,7 +42,7 @@ (lambda args (let ((errno (system-error-errno args))) (false-if-exception (statprof-stop)) - (if (= errno ENOSYS) + (if (or (= errno ENOSYS) (= errno EINVAL)) (throw 'unresolved) (apply throw args)))))) @@ -125,7 +126,7 @@ (define do-nothing (compile '(lambda (n) (simple-format #f "FOO ~A\n" (+ n n))))) - + ;; Run test. (statprof-reset 0 50000 #t #f) (statprof-start) @@ -136,7 +137,7 @@ (loop (- x 1)) #t))) (statprof-stop) - + ;; Check result. (let ((proc-data (statprof-proc-call-data do-nothing))) (and proc-data From 84a740d86a5afd235f1b47ac66c88db010b1d56b Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 12 Feb 2016 11:19:38 -0500 Subject: [PATCH 776/865] psyntax: Generate identifiers in a deterministic fashion. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . * module/ice-9/boot-9.scm (module-generate-unique-id!) (module-gensym): New procedures. (module): Add 'next-unique-id' field. (the-root-module): Inherit 'next-unique-id' value from early stub. (make-module, make-autoload-interface): Adjust calls to module-constructor. * module/ice-9/psyntax.scm (gen-label, new-mark): Generate unique identifiers from the module name and the per-module unique-id. (build-lexical-var, generate-temporaries): Use 'module-gensym' instead of 'gensym'. * module/ice-9/psyntax-pp.scm: Regenerate. * module/language/tree-il/fix-letrec.scm (fix-letrec!): Use 'module-gensym' instead of 'gensym'. * module/system/base/syntax.scm (define-record): Likewise. (transform-record): Likewise. Co-authored-by: Ludovic Courtès --- module/ice-9/boot-9.scm | 41 ++++++++- module/ice-9/psyntax-pp.scm | 123 ++++++++++++++++++------- module/ice-9/psyntax.scm | 15 +-- module/language/tree-il/fix-letrec.scm | 6 +- module/system/base/syntax.scm | 8 +- 5 files changed, 143 insertions(+), 50 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 75906ff4c..27776725b 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 Free Software Foundation, Inc. +;;;; Copyright (C) 1995-2014, 2016 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 @@ -373,6 +373,13 @@ If returning early, return the return value of F." (define (module-ref module sym) (let ((v (module-variable module sym))) (if v (variable-ref v) (error "badness!" (pk module) (pk sym))))) +(define module-generate-unique-id! + (let ((next-id 0)) + (lambda (m) + (let ((i next-id)) + (set! next-id (+ i 1)) + i)))) +(define module-gensym gensym) (define (resolve-module . args) #f) @@ -1982,7 +1989,8 @@ name extensions listed in %load-extensions." submodules submodule-binder public-interface - filename))) + filename + next-unique-id))) ;; make-module &opt size uses binder @@ -2005,7 +2013,7 @@ initial uses list, or binding procedure." (make-hash-table) '() (make-weak-key-hash-table 31) #f - (make-hash-table 7) #f #f #f)) + (make-hash-table 7) #f #f #f 0)) @@ -2542,6 +2550,11 @@ interfaces are added to the inports list." (let ((m (make-module 0))) (set-module-obarray! m (%get-pre-modules-obarray)) (set-module-name! m '(guile)) + + ;; Inherit next-unique-id from preliminary stub of + ;; %module-get-next-unique-id! defined above. + (set-module-next-unique-id! m (module-generate-unique-id! #f)) + m)) ;; The root interface is a module that uses the same obarray as the @@ -2570,6 +2583,11 @@ interfaces are added to the inports list." the-root-module (error "unexpected module to resolve during module boot" name))) +(define (module-generate-unique-id! m) + (let ((i (module-next-unique-id m))) + (set-module-next-unique-id! m (+ i 1)) + i)) + ;; Cheat. These bindings are needed by modules.c, but we don't want ;; to move their real definition here because that would be unnatural. ;; @@ -2600,6 +2618,21 @@ interfaces are added to the inports list." (nested-define-module! (resolve-module '() #f) name mod) (accessor mod)))))) +(define* (module-gensym #:optional (id " mg") (m (current-module))) + "Return a fresh symbol in the context of module M, based on ID (a +string or symbol). As long as M is a valid module, this procedure is +deterministic." + (define (->string number) + (number->string number 16)) + + (if m + (string->symbol + (string-append id "-" + (->string (hash (module-name m) most-positive-fixnum)) + "-" + (->string (module-generate-unique-id! m)))) + (gensym id))) + (define (make-modules-in module name) (or (nested-ref-module module name) (let ((m (make-module 31))) @@ -2891,7 +2924,7 @@ error if selected binding does not exist in the used module." #:warning "Failed to autoload ~a in ~a:\n" sym name)))) (module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f (make-hash-table 0) '() (make-weak-value-hash-table 31) #f - (make-hash-table 0) #f #f #f))) + (make-hash-table 0) #f #f #f 0))) (define (module-autoload! module . args) "Have @var{module} automatically load the module named @var{name} when one diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index d79766595..e410f9f58 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -295,9 +295,7 @@ (syntax-object-expression x) (join-marks (car w) (car (syntax-object-wrap x)))) (values x (car w))))) - (gen-label - (lambda () - (string-append "l-" (session-id) (symbol->string (gensym "-"))))) + (gen-label (lambda () (symbol->string (module-gensym "l")))) (gen-labels (lambda (ls) (if (null? ls) '() (cons (gen-label) (gen-labels (cdr ls)))))) @@ -994,14 +992,15 @@ (source-wrap e w (cdr w) mod) x)) (else (decorate-source x s)))))) - (let* ((t-1 transformer-environment) (t (lambda (k) (k e r w s rib mod)))) + (let* ((t-680b775fb37a463-7fe transformer-environment) + (t-680b775fb37a463-7ff (lambda (k) (k e r w s rib mod)))) (with-fluid* - t-1 - t + t-680b775fb37a463-7fe + t-680b775fb37a463-7ff (lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) - (gensym (string-append "m-" (session-id) "-"))))))))) + (module-gensym "m")))))))) (expand-body (lambda (body outer-form r w mod) (let* ((r (cons '("placeholder" placeholder) r)) @@ -1532,7 +1531,11 @@ s mod get-formals - (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) + (map (lambda (tmp-680b775fb37a463-aef + tmp-680b775fb37a463-aee + tmp-680b775fb37a463-aed) + (cons tmp-680b775fb37a463-aed + (cons tmp-680b775fb37a463-aee tmp-680b775fb37a463-aef))) e2* e1* args*))) @@ -1564,7 +1567,7 @@ (gen-var (lambda (id) (let ((id (if (syntax-object? id) (syntax-object-expression id) id))) - (gensym (string-append (symbol->string id) "-"))))) + (module-gensym (symbol->string id))))) (lambda-var-list (lambda (vars) (let lvl ((vars vars) (ls '()) (w '(()))) @@ -1832,7 +1835,11 @@ (apply (lambda (args e1 e2) (build-it '() - (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) + (map (lambda (tmp-680b775fb37a463-cbc + tmp-680b775fb37a463-cbb + tmp-680b775fb37a463-cba) + (cons tmp-680b775fb37a463-cba + (cons tmp-680b775fb37a463-cbb tmp-680b775fb37a463-cbc))) e2 e1 args))) @@ -1844,7 +1851,11 @@ (apply (lambda (docstring args e1 e2) (build-it (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) + (map (lambda (tmp-680b775fb37a463-cd2 + tmp-680b775fb37a463-cd1 + tmp-680b775fb37a463-cd0) + (cons tmp-680b775fb37a463-cd0 + (cons tmp-680b775fb37a463-cd1 tmp-680b775fb37a463-cd2))) e2 e1 args))) @@ -1867,7 +1878,11 @@ (apply (lambda (args e1 e2) (build-it '() - (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) + (map (lambda (tmp-680b775fb37a463-cf2 + tmp-680b775fb37a463-cf1 + tmp-680b775fb37a463-cf0) + (cons tmp-680b775fb37a463-cf0 + (cons tmp-680b775fb37a463-cf1 tmp-680b775fb37a463-cf2))) e2 e1 args))) @@ -1879,7 +1894,11 @@ (apply (lambda (docstring args e1 e2) (build-it (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2))) + (map (lambda (tmp-680b775fb37a463-d08 + tmp-680b775fb37a463-d07 + tmp-680b775fb37a463-d06) + (cons tmp-680b775fb37a463-d06 + (cons tmp-680b775fb37a463-d07 tmp-680b775fb37a463-d08))) e2 e1 args))) @@ -2387,7 +2406,7 @@ (if (not (list? x)) (syntax-violation 'generate-temporaries "invalid argument" x))) (let ((mod (cons 'hygiene (module-name (current-module))))) - (map (lambda (x) (wrap (gensym "t-") '((top)) mod)) ls)))) + (map (lambda (x) (wrap (module-gensym "t") '((top)) mod)) ls)))) (set! free-identifier=? (lambda (x y) (let ((x x)) @@ -2787,7 +2806,11 @@ #f k '() - (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2)) + (map (lambda (tmp-680b775fb37a463-115b + tmp-680b775fb37a463-115a + tmp-680b775fb37a463) + (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-115a) + tmp-680b775fb37a463-115b)) template pattern keyword))) @@ -2803,7 +2826,9 @@ #f k (list docstring) - (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2)) + (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) + tmp-680b775fb37a463-2)) template pattern keyword))) @@ -2818,7 +2843,11 @@ dots k '() - (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2)) + (map (lambda (tmp-680b775fb37a463-118d + tmp-680b775fb37a463-118c + tmp-680b775fb37a463-118b) + (list (cons tmp-680b775fb37a463-118b tmp-680b775fb37a463-118c) + tmp-680b775fb37a463-118d)) template pattern keyword))) @@ -2834,7 +2863,11 @@ dots k (list docstring) - (map (lambda (tmp-2 tmp-1 tmp) (list (cons tmp tmp-1) tmp-2)) + (map (lambda (tmp-680b775fb37a463-11ac + tmp-680b775fb37a463-11ab + tmp-680b775fb37a463-11aa) + (list (cons tmp-680b775fb37a463-11aa tmp-680b775fb37a463-11ab) + tmp-680b775fb37a463-11ac)) template pattern keyword))) @@ -2974,7 +3007,9 @@ (apply (lambda (p) (if (= lev 0) (quasilist* - (map (lambda (tmp) (list "value" tmp)) p) + (map (lambda (tmp-680b775fb37a463) + (list "value" tmp-680b775fb37a463)) + p) (quasi q lev)) (quasicons (quasicons @@ -2992,7 +3027,9 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp) (list "value" tmp)) p) + (map (lambda (tmp-680b775fb37a463) + (list "value" tmp-680b775fb37a463)) + p) (quasi q lev)) (quasicons (quasicons @@ -3025,7 +3062,11 @@ (if tmp (apply (lambda (p) (if (= lev 0) - (quasilist* (map (lambda (tmp) (list "value" tmp)) p) (vquasi q lev)) + (quasilist* + (map (lambda (tmp-680b775fb37a463-122f) + (list "value" tmp-680b775fb37a463-122f)) + p) + (vquasi q lev)) (quasicons (quasicons '("quote" #(syntax-object unquote ((top)) (hygiene guile))) @@ -3041,7 +3082,8 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp) (list "value" tmp)) p) + (map (lambda (tmp-680b775fb37a463) (list "value" tmp-680b775fb37a463)) + p) (vquasi q lev)) (quasicons (quasicons @@ -3129,7 +3171,9 @@ (let ((tmp-1 ls)) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t) (cons "vector" t)) tmp) + (apply (lambda (t-680b775fb37a463-127d) + (cons "vector" t-680b775fb37a463-127d)) + tmp) (syntax-violation #f "source expression failed to match any pattern" @@ -3137,7 +3181,9 @@ (let ((tmp y)) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (if tmp-1 - (apply (lambda (y) (k (map (lambda (tmp) (list "quote" tmp)) y))) + (apply (lambda (y) + (k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463)) + y))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) (if tmp-1 @@ -3146,7 +3192,9 @@ (if tmp-1 (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (let ((else tmp)) - (let ((tmp x)) (let ((t tmp)) (list "list->vector" t))))))))))))))))) + (let ((tmp x)) + (let ((t-680b775fb37a463 tmp)) + (list "list->vector" t-680b775fb37a463))))))))))))))))) (emit (lambda (x) (let ((tmp x)) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) @@ -3159,7 +3207,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t) (cons '#(syntax-object list ((top)) (hygiene guile)) t)) + (apply (lambda (t-680b775fb37a463-12a7) + (cons '#(syntax-object list ((top)) (hygiene guile)) + t-680b775fb37a463-12a7)) tmp) (syntax-violation #f @@ -3175,8 +3225,10 @@ (let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp ($sc-dispatch tmp-1 '(any any)))) (if tmp - (apply (lambda (t-1 t) - (list '#(syntax-object cons ((top)) (hygiene guile)) t-1 t)) + (apply (lambda (t-680b775fb37a463-12bb t-680b775fb37a463-12ba) + (list '#(syntax-object cons ((top)) (hygiene guile)) + t-680b775fb37a463-12bb + t-680b775fb37a463-12ba)) tmp) (syntax-violation #f @@ -3189,8 +3241,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t) - (cons '#(syntax-object append ((top)) (hygiene guile)) t)) + (apply (lambda (t-680b775fb37a463-12c7) + (cons '#(syntax-object append ((top)) (hygiene guile)) + t-680b775fb37a463-12c7)) tmp) (syntax-violation #f @@ -3203,8 +3256,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t) - (cons '#(syntax-object vector ((top)) (hygiene guile)) t)) + (apply (lambda (t-680b775fb37a463-12d3) + (cons '#(syntax-object vector ((top)) (hygiene guile)) + t-680b775fb37a463-12d3)) tmp) (syntax-violation #f @@ -3215,8 +3269,9 @@ (if tmp-1 (apply (lambda (x) (let ((tmp (emit x))) - (let ((t tmp)) - (list '#(syntax-object list->vector ((top)) (hygiene guile)) t)))) + (let ((t-680b775fb37a463-12df tmp)) + (list '#(syntax-object list->vector ((top)) (hygiene guile)) + t-680b775fb37a463-12df)))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) (if tmp-1 diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 88df4c753..74a008eeb 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -1,7 +1,7 @@ ;;;; -*-scheme-*- ;;;; ;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010, 2011, -;;;; 2012, 2013, 2015 Free Software Foundation, Inc. +;;;; 2012, 2013, 2015, 2016 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 @@ -461,9 +461,10 @@ (make-letrec src in-order? ids vars val-exps body-exp))))) - ;; FIXME: use a faster gensym (define-syntax-rule (build-lexical-var src id) - (gensym (string-append (symbol->string id) "-"))) + ;; Use a per-module counter instead of the global counter of + ;; 'gensym' so that the generated identifier is reproducible. + (module-gensym (symbol->string id))) (define-structure (syntax-object expression wrap module)) @@ -632,7 +633,7 @@ ;; labels must be comparable with "eq?", have read-write invariance, ;; and distinct from symbols. (define (gen-label) - (string-append "l-" (session-id) (symbol->string (gensym "-")))) + (symbol->string (module-gensym "l"))) (define gen-labels (lambda (ls) @@ -661,7 +662,7 @@ (cons 'shift (wrap-subst w))))) (define-syntax-rule (new-mark) - (gensym (string-append "m-" (session-id) "-"))) + (module-gensym "m")) ;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for ;; internal definitions, in which the ribcages are built incrementally @@ -2717,7 +2718,9 @@ (lambda (ls) (arg-check list? ls 'generate-temporaries) (let ((mod (cons 'hygiene (module-name (current-module))))) - (map (lambda (x) (wrap (gensym "t-") top-wrap mod)) ls)))) + (map (lambda (x) + (wrap (module-gensym "t") top-wrap mod)) + ls)))) (set! free-identifier=? (lambda (x y) diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm index d8f127afa..5d6ad91f6 100644 --- a/module/language/tree-il/fix-letrec.scm +++ b/module/language/tree-il/fix-letrec.scm @@ -1,6 +1,6 @@ ;;; transformation of letrec into simpler forms -;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2016 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 @@ -272,7 +272,9 @@ ;; bindings, in a `let' to indicate that order doesn't ;; matter, and bind to their variables. (list - (let ((tmps (map (lambda (x) (gensym)) c))) + (let ((tmps (map (lambda (x) + (module-gensym "fixlr")) + c))) (make-let #f (map cadr c) tmps (map caddr c) (list->seq diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm index fafcce40b..1cabbbcb7 100644 --- a/module/system/base/syntax.scm +++ b/module/system/base/syntax.scm @@ -1,6 +1,6 @@ ;;; Guile VM specific syntaxes and utilities -;; Copyright (C) 2001, 2009 Free Software Foundation, Inc +;; Copyright (C) 2001, 2009, 2016 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 @@ -72,7 +72,7 @@ '() (cons (car slots) (lp (cdr slots)))))) (opts (list-tail slots (length reqs))) - (tail (gensym))) + (tail (module-gensym "defrec"))) `(define (,(symbol-append 'make- stem) ,@reqs . ,tail) (let ,(map (lambda (o) `(,(car o) (cond ((null? ,tail) ,(cadr o)) @@ -215,8 +215,8 @@ ;; code looks good. (define-macro (transform-record type-and-common record . clauses) - (let ((r (gensym)) - (rtd (gensym)) + (let ((r (module-gensym "rec")) + (rtd (module-gensym "rtd")) (type-stem (trim-brackets (car type-and-common)))) (define (make-stem s) (symbol-append type-stem '- s)) From fb8c91a35c0a1c357aab96a6721a8b65c93368b0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 7 Mar 2017 20:57:59 +0100 Subject: [PATCH 777/865] Add thread local fluids * libguile/fluids.h (struct scm_dynamic_state): Add thread_local_values table. Thread locals are flushed to a separate thread-local table. The references are strong references since the table never escapes the thread. (scm_make_thread_local_fluid, scm_fluid_thread_local_p): New functions. * libguile/fluids.c (FLUID_F_THREAD_LOCAL): (SCM_I_FLUID_THREAD_LOCAL_P): New macros. (restore_dynamic_state): Add comment about precondition. (save_dynamic_state): Flush thread locals. (scm_i_fluid_print): Print thread locals nicely. (new_fluid): Add flags arg. (scm_make_fluid, scm_make_fluid_with_default, scm_make_unbound_fluid): Adapt. (scm_make_thread_local_fluid, scm_fluid_thread_local_p): New functions. (fluid_set_x): Special flushing logic for thread-locals. (fluid_ref): Special cache miss logic for thread locals. * libguile/stacks.c (scm_init_stacks): * libguile/throw.c (scm_init_throw): %stacks and %exception-handler are thread-locals. * libguile/threads.c (guilify_self_2): Init thread locals table. * test-suite/tests/fluids.test ("dynamic states"): Add test. * doc/ref/api-control.texi (Fluids and Dynamic States): Add link to Thread-Local Variables. * doc/ref/api-scheduling.texi (Thread Local Variables): Update with real thread-locals. * NEWS: Update. --- NEWS | 7 ++++ doc/ref/api-control.texi | 3 ++ doc/ref/api-scheduling.texi | 54 ++++++++++++++++--------- libguile/fluids.c | 77 +++++++++++++++++++++++++++++++----- libguile/fluids.h | 3 ++ libguile/stacks.c | 2 +- libguile/threads.c | 1 + libguile/throw.c | 2 +- test-suite/tests/fluids.test | 8 +++- 9 files changed, 125 insertions(+), 32 deletions(-) diff --git a/NEWS b/NEWS index 96cc959d9..d70397e97 100644 --- a/NEWS +++ b/NEWS @@ -23,6 +23,13 @@ guile2.2, guile-2, guile2, and then guile. The found prefix is also applied to guild, guile-config, and the like. Thanks to Freja Nordsiek for this work. +** Add thread-local fluids + +Guile now has support for fluids whose values are not captured by +`current-dynamic-state' and not inheritied by child threads, and thus +are local to the kernel thread they run on. See "Thread-Local +Variables" in the manual, for more. + * Bug fixes ** Fix type inference when multiplying flonum with complex diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index 77d98b44e..b0c9e7202 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.texi @@ -1727,6 +1727,9 @@ used for testing whether an object is actually a fluid. The values stored in a fluid can be accessed with @code{fluid-ref} and @code{fluid-set!}. +@xref{Thread-Local Variables}, for further notes on fluids, threads, +parameters, and dynamic states. + @deffn {Scheme Procedure} make-fluid [dflt] @deffnx {C Function} scm_make_fluid () @deffnx {C Function} scm_make_fluid_with_default (dflt) diff --git a/doc/ref/api-scheduling.texi b/doc/ref/api-scheduling.texi index ff8473ae2..7b39a03d6 100644 --- a/doc/ref/api-scheduling.texi +++ b/doc/ref/api-scheduling.texi @@ -9,7 +9,7 @@ @menu * Threads:: Multiple threads of execution. -* Thread Local Variables:: Guile doesn't really have these. +* Thread Local Variables:: Some fluids are thread-local. * Asyncs:: Asynchronous interrupts. * Atomics:: Atomic references. * Mutexes and Condition Variables:: Synchronization primitives. @@ -169,9 +169,7 @@ information. @subsection Thread-Local Variables Sometimes you want to establish a variable binding that is only valid -for a given thread: a ``thread-local variable''. Guile doesn't really -have this facility, but what it does have can work well for most use -cases we know about. +for a given thread: a ``thread-local variable''. You would think that fluids or parameters would be Guile's answer for thread-local variables, since establishing a new fluid binding doesn't @@ -191,26 +189,44 @@ bindings comes from a desire to isolate a binding from its setting in unrelated threads, then fluids and parameters apply nicely. On the other hand, if your use case is to prevent concurrent access to a -value from multiple threads, then using fluids or parameters is not -appropriate. In this case, our current suggestion is to use weak hash -tables or object properties whose keys are thread objects. For example: +value from multiple threads, then using vanilla fluids or parameters is +not appropriate. For this purpose, Guile has @dfn{thread-local fluids}. +A fluid created with @code{make-thread-local-fluid} won't be captured by +@code{current-dynamic-state} and won't be propagated to new threads. + +@deffn {Scheme Procedure} make-thread-local-fluid [dflt] +@deffnx {C Function} scm_make_thread_local_fluid (dflt) +Return a newly created fluid, whose initial value is @var{dflt}, or +@code{#f} if @var{dflt} is not given. Unlike fluids made with +@code{make-fluid}, thread local fluids are not captured by +@code{make-dynamic-state}. Similarly, a newly spawned child thread does +not inherit thread-local fluid values from the parent thread. +@end deffn + +@deffn {Scheme Procedure} fluid-thread-local? fluid +@deffnx {C Function} scm_fluid_thread_local_p (fluid) +Return @code{#t} if the fluid @var{fluid} is is thread-local, or +@code{#f} otherwise. +@end deffn + +For example: @example -(define (get-my-sensitive-data-structure) - ...) +(define %thread-local (make-thread-local-fluid)) -(define %thread-local (make-weak-key-hash-table)) - -(define (current-thread-local) - (or (hashq-ref %thread-local (current-thread)) - (let ((val (get-my-sensitive-data-structure))) - (hashq-set! %thread-local (current-thread) val) - val))) +(with-fluids ((%thread-local (compute-data))) + ... (fluid-ref %thread-local) ...) @end example -It's not a terribly nice facility and perhaps we should have a better -answer, like Racket's ``non-preserved thread cells''. Your input is -very welcome; we look forward to hearing from your experience. +You can also make a thread-local parameter out of a thread-local fluid +using the normal @code{fluid->parameter}: + +@example +(define param (fluid->parameter (make-thread-local-fluid))) + +(parameterize ((param (compute-data))) + ... (param) ...) +@end example @node Asyncs diff --git a/libguile/fluids.c b/libguile/fluids.c index 7daad7781..6bdca7ddf 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -91,6 +91,10 @@ table could share more state, as in an immutable weak array-mapped hash trie or something, but we don't have such a data structure. */ +#define FLUID_F_THREAD_LOCAL 0x100 +#define SCM_I_FLUID_THREAD_LOCAL_P(x) \ + (SCM_CELL_WORD_0 (x) & FLUID_F_THREAD_LOCAL) + static inline int is_dynamic_state (SCM x) { @@ -103,6 +107,8 @@ get_dynamic_state (SCM dynamic_state) return SCM_CELL_OBJECT_1 (dynamic_state); } +/* Precondition: It's OK to throw away any unflushed data in the current + cache. */ static inline void restore_dynamic_state (SCM saved, scm_t_dynamic_state *state) { @@ -133,9 +139,20 @@ save_dynamic_state (scm_t_dynamic_state *state) struct scm_cache_entry *entry = &state->cache.entries[slot]; SCM key = SCM_PACK (entry->key); SCM value = SCM_PACK (entry->value); - if (entry->key && - !scm_is_eq (scm_weak_table_refq (state->values, key, SCM_UNDEFINED), - value)) + + if (!entry->key) + continue; + if (SCM_I_FLUID_THREAD_LOCAL_P (key)) + { + /* Because we don't include unflushed thread-local fluids in + the result, we need to flush them to the table so that + restore_dynamic_state can just throw away the current + cache. */ + scm_hashq_set_x (state->thread_local_values, key, value); + } + else if (!scm_is_eq (scm_weak_table_refq (state->values, key, + SCM_UNDEFINED), + value)) { if (state->has_aliased_values) saved = scm_acons (key, value, saved); @@ -177,7 +194,10 @@ copy_value_table (SCM tab) void scm_i_fluid_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { - scm_puts ("#', port); } @@ -196,15 +216,15 @@ scm_i_dynamic_state_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED #define SCM_I_FLUID_DEFAULT(x) (SCM_CELL_OBJECT_1 (x)) static SCM -new_fluid (SCM init) +new_fluid (SCM init, scm_t_bits flags) { - return scm_cell (scm_tc7_fluid, SCM_UNPACK (init)); + return scm_cell (scm_tc7_fluid | flags, SCM_UNPACK (init)); } SCM scm_make_fluid (void) { - return new_fluid (SCM_BOOL_F); + return new_fluid (SCM_BOOL_F, 0); } SCM_DEFINE (scm_make_fluid_with_default, "make-fluid", 0, 1, 0, @@ -219,7 +239,7 @@ SCM_DEFINE (scm_make_fluid_with_default, "make-fluid", 0, 1, 0, "with its own dynamic state, you can use fluids for thread local storage.") #define FUNC_NAME s_scm_make_fluid_with_default { - return new_fluid (SCM_UNBNDP (dflt) ? SCM_BOOL_F : dflt); + return new_fluid (SCM_UNBNDP (dflt) ? SCM_BOOL_F : dflt, 0); } #undef FUNC_NAME @@ -228,7 +248,22 @@ SCM_DEFINE (scm_make_unbound_fluid, "make-unbound-fluid", 0, 0, 0, "Make a fluid that is initially unbound.") #define FUNC_NAME s_scm_make_unbound_fluid { - return new_fluid (SCM_UNDEFINED); + return new_fluid (SCM_UNDEFINED, 0); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_make_thread_local_fluid, "make-thread-local-fluid", 0, 1, 0, + (SCM dflt), + "Return a newly created fluid, whose initial value is @var{dflt},\n" + "or @code{#f} if @var{dflt} is not given. Unlike fluids made\n" + "with @code{make-fluid}, thread local fluids are not captured\n" + "by @code{make-dynamic-state}. Similarly, a newly spawned\n" + "child thread does not inherit thread-local fluid values from\n" + "the parent thread.") +#define FUNC_NAME s_scm_make_thread_local_fluid +{ + return new_fluid (SCM_UNBNDP (dflt) ? SCM_BOOL_F : dflt, + FLUID_F_THREAD_LOCAL); } #undef FUNC_NAME @@ -242,6 +277,17 @@ SCM_DEFINE (scm_fluid_p, "fluid?", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_fluid_thread_local_p, "fluid-thread-local?", 1, 0, 0, + (SCM fluid), + "Return @code{#t} if the fluid @var{fluid} is is thread local,\n" + "or @code{#f} otherwise.") +#define FUNC_NAME s_scm_fluid_thread_local_p +{ + SCM_VALIDATE_FLUID (1, fluid); + return scm_from_bool (SCM_I_FLUID_THREAD_LOCAL_P (fluid)); +} +#undef FUNC_NAME + int scm_is_fluid (SCM obj) { @@ -268,6 +314,12 @@ fluid_set_x (scm_t_dynamic_state *dynamic_state, SCM fluid, SCM value) fluid = SCM_PACK (evicted.key); value = SCM_PACK (evicted.value); + if (SCM_I_FLUID_THREAD_LOCAL_P (fluid)) + { + scm_hashq_set_x (dynamic_state->thread_local_values, fluid, value); + return; + } + if (dynamic_state->has_aliased_values) { if (scm_is_eq (scm_weak_table_refq (dynamic_state->values, @@ -294,7 +346,12 @@ fluid_ref (scm_t_dynamic_state *dynamic_state, SCM fluid) val = SCM_PACK (entry->value); else { - val = scm_weak_table_refq (dynamic_state->values, fluid, SCM_UNDEFINED); + if (SCM_I_FLUID_THREAD_LOCAL_P (fluid)) + val = scm_hashq_ref (dynamic_state->thread_local_values, fluid, + SCM_UNDEFINED); + else + val = scm_weak_table_refq (dynamic_state->values, fluid, + SCM_UNDEFINED); if (SCM_UNBNDP (val)) val = SCM_I_FLUID_DEFAULT (fluid); diff --git a/libguile/fluids.h b/libguile/fluids.h index 6d7969e15..7997ad4d3 100644 --- a/libguile/fluids.h +++ b/libguile/fluids.h @@ -44,6 +44,7 @@ struct scm_dynamic_state { + SCM thread_local_values; SCM values; uint8_t has_aliased_values; struct scm_cache cache; @@ -53,8 +54,10 @@ struct scm_dynamic_state SCM_API SCM scm_make_fluid (void); SCM_API SCM scm_make_fluid_with_default (SCM dflt); SCM_API SCM scm_make_unbound_fluid (void); +SCM_API SCM scm_make_thread_local_fluid (SCM dflt); SCM_API int scm_is_fluid (SCM obj); SCM_API SCM scm_fluid_p (SCM fl); +SCM_API SCM scm_fluid_thread_local_p (SCM fluid); SCM_API SCM scm_fluid_ref (SCM fluid); SCM_API SCM scm_fluid_ref_star (SCM fluid, SCM depth); SCM_API SCM scm_fluid_set_x (SCM fluid, SCM value); diff --git a/libguile/stacks.c b/libguile/stacks.c index 5679bec42..9bd2db8de 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -459,7 +459,7 @@ SCM_DEFINE (scm_stack_length, "stack-length", 1, 0, 0, void scm_init_stacks () { - scm_sys_stacks = scm_make_fluid (); + scm_sys_stacks = scm_make_thread_local_fluid (SCM_BOOL_F); scm_c_define ("%stacks", scm_sys_stacks); scm_stack_type = scm_make_vtable (scm_from_locale_string (SCM_STACK_LAYOUT), diff --git a/libguile/threads.c b/libguile/threads.c index c999411e1..9ceb5b88a 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -458,6 +458,7 @@ guilify_self_2 (SCM dynamic_state) } t->dynamic_state = scm_gc_typed_calloc (scm_t_dynamic_state); + t->dynamic_state->thread_local_values = scm_c_make_hash_table (0); scm_set_current_dynamic_state (dynamic_state); t->dynstack.base = scm_gc_malloc (16 * sizeof (scm_t_bits), "dynstack"); diff --git a/libguile/throw.c b/libguile/throw.c index 5f6dcfa90..123544e79 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -648,7 +648,7 @@ scm_init_throw () tc16_catch_closure = scm_make_smob_type ("catch-closure", 0); scm_set_smob_apply (tc16_catch_closure, apply_catch_closure, 0, 0, 1); - exception_handler_fluid = scm_make_fluid_with_default (SCM_BOOL_F); + exception_handler_fluid = scm_make_thread_local_fluid (SCM_BOOL_F); /* This binding is later removed when the Scheme definitions of catch, throw, and with-throw-handler are created in boot-9.scm. */ scm_c_define ("%exception-handler", exception_handler_fluid); diff --git a/test-suite/tests/fluids.test b/test-suite/tests/fluids.test index c043d94d3..9eca6f29d 100644 --- a/test-suite/tests/fluids.test +++ b/test-suite/tests/fluids.test @@ -260,4 +260,10 @@ (fluid-ref fluid)))) (lambda (k) k)))) (and (eqv? (fluid-ref fluid) #f) - (eqv? (k) #t)))))) + (eqv? (k) #t))))) + + (pass-if "exception handler not captured" + (let ((state (catch #t (lambda () (current-dynamic-state)) error))) + (catch #t + (lambda () (with-dynamic-state state (/ 1 0))) + (lambda _ #t))))) From 1e51ffa63422c28572aa4ab1a5b3924d54614485 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 7 Mar 2017 21:34:01 +0100 Subject: [PATCH 778/865] Fix documentation build * doc/ref/api-control.texi (Fluids and Dynamic States): Fix link. --- doc/ref/api-control.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/api-control.texi b/doc/ref/api-control.texi index b0c9e7202..2d696ea89 100644 --- a/doc/ref/api-control.texi +++ b/doc/ref/api-control.texi @@ -1727,7 +1727,7 @@ used for testing whether an object is actually a fluid. The values stored in a fluid can be accessed with @code{fluid-ref} and @code{fluid-set!}. -@xref{Thread-Local Variables}, for further notes on fluids, threads, +@xref{Thread Local Variables}, for further notes on fluids, threads, parameters, and dynamic states. @deffn {Scheme Procedure} make-fluid [dflt] From 8157c2a3acc61b561903957f69e7e83163d5a1b5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 7 Mar 2017 21:35:52 +0100 Subject: [PATCH 779/865] Fix new thread-local fluids test * test-suite/tests/fluids.test ("dynamic states"): Fix test. --- test-suite/tests/fluids.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/tests/fluids.test b/test-suite/tests/fluids.test index 9eca6f29d..a5ca8857e 100644 --- a/test-suite/tests/fluids.test +++ b/test-suite/tests/fluids.test @@ -265,5 +265,5 @@ (pass-if "exception handler not captured" (let ((state (catch #t (lambda () (current-dynamic-state)) error))) (catch #t - (lambda () (with-dynamic-state state (/ 1 0))) + (lambda () (with-dynamic-state state (lambda () (/ 1 0)))) (lambda _ #t))))) From c62f0b025649eadc28cb1cb1afd1be183414b9b0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 8 Mar 2017 22:39:29 +0100 Subject: [PATCH 780/865] 64KB segment alignment * module/system/vm/linker.scm (*lcm-page-size*): Rename from *page-size*, change to 64 KB. * libguile/loader.c (load_thunk_from_memory): Only require page size alignment, knowing that although Guile might emit ELF with 64k alignment, it only really needs page alignment. --- libguile/loader.c | 15 ++++++++++++-- module/system/vm/linker.scm | 39 +++++++++++++++++++++++++++++++++++-- 2 files changed, 50 insertions(+), 4 deletions(-) diff --git a/libguile/loader.c b/libguile/loader.c index 558a722ea..7b1adc9c9 100644 --- a/libguile/loader.c +++ b/libguile/loader.c @@ -420,7 +420,18 @@ load_thunk_from_memory (char *data, size_t len, int is_read_only) if (dynamic_segment < 0) ABORT ("no PT_DYNAMIC segment"); - if (!IS_ALIGNED ((scm_t_uintptr) data, alignment)) + /* The ELF images that Guile currently emits have segments that are + aligned on 64 KB boundaries, which might be larger than the actual + page size (usually 4 KB). However Guile doesn't actually use the + absolute addresses at all. All Guile needs is for the loaded image + to be able to make the data section writable (for the mmap path), + and for that the segment just needs to be page-aligned, and a page + is always bigger than Guile's minimum alignment. Since we know + (for the mmap path) that the base _is_ page-aligned, we proceed + ahead even if the image alignment is greater than the page + size. */ + if (!IS_ALIGNED ((scm_t_uintptr) data, alignment) + && !IS_ALIGNED (alignment, page_size)) ABORT ("incorrectly aligned base"); /* Allow writes to writable pages. */ @@ -433,7 +444,7 @@ load_thunk_from_memory (char *data, size_t len, int is_read_only) continue; if (ph[i].p_flags == PF_R) continue; - if (ph[i].p_align != page_size) + if (ph[i].p_align < page_size) continue; if (mprotect (data + ph[i].p_vaddr, diff --git a/module/system/vm/linker.scm b/module/system/vm/linker.scm index 952837737..6ad582a9d 100644 --- a/module/system/vm/linker.scm +++ b/module/system/vm/linker.scm @@ -317,7 +317,42 @@ segment, the order of the linker objects is preserved." #:addralign (elf-section-addralign sec) #:entsize (elf-section-entsize sec))) -(define *page-size* 4096) + +;; We assume that 64K is a multiple of the page size. A +;; least-common-multiple, if you will. +;; +;; It would be possible to choose smaller, target-specific page sizes. +;; This is still a little tricky; on amd64 for example, systems commonly +;; have 4KB pages, but they are allowed by the ABI to have any +;; multiple-of-2 page size up to 64 KB. On Cygwin, pages are 4kB but +;; they can only be allocated 16 at a time. MIPS and ARM64 can use 64K +;; pages too and that's not uncommon. +;; +;; At the current time, in Guile we would like to reduce the number of +;; binaries we ship to the existing 32-or-64-bit and +;; big-or-little-endian variants, if possible. It would seem that with +;; the least-common-multiple of 64 KB pages, we can do that. +;; +;; See https://github.com/golang/go/issues/10180 for a discussion of +;; this issue in the Go context. +;; +;; Using 64KB instead of the more usual 4KB will increase the size of +;; our .go files, but not the prebuilt/ part of the tarball as that part +;; of the file will be zeroes and compress well. Additionally on a +;; system with 4KB pages, the extra padding will never be paged in, nor +;; read from disk (though it causes more seeking etc so on spinning +;; metal it's a bit of a lose). +;; +;; By way of comparison, on many 64-bit platforms, binutils currently +;; defaults to aligning segments on 2MB boundaries. It does so by +;; making the file and the memory images not the same: the pages are all +;; together on disk, but then when loading, the loader will mmap a +;; region "memsz" large which might be greater than the file size, then +;; map segments into that region. We can avoid this complication for +;; now. We can consider adding it in the future in a compatible way in +;; 2.2 if it is important. +;; +(define *lcm-page-size* (ash 1 16)) (define (add-symbols symbols offset symtab) "Add @var{symbols} to the symbol table @var{symtab}, relocating them @@ -631,7 +666,7 @@ relocated headers, and the global symbol table." ;; loadable segments to share pages ;; with PF_R segments. (not (and (not type) (= PF_R prev-flags)))) - *page-size* + *lcm-page-size* 8)) (lp seglists (fold-values cons objs-out objects) From bfa38835923800b5aa69a254b4fe8cf0858dca67 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 9 Mar 2017 10:31:30 +0100 Subject: [PATCH 781/865] statprof: 'with-statprof' honors #:display-style. * module/statprof.scm (with-statprof): Pass #:display-style to 'statprof'. --- module/statprof.scm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/module/statprof.scm b/module/statprof.scm index 03178da11..1efb15dff 100644 --- a/module/statprof.scm +++ b/module/statprof.scm @@ -1,7 +1,7 @@ ;;;; (statprof) -- a statistical profiler for Guile ;;;; -*-scheme-*- ;;;; -;;;; Copyright (C) 2009, 2010, 2011, 2013-2016 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2011, 2013-2017 Free Software Foundation, Inc. ;;;; Copyright (C) 2004, 2009 Andy Wingo ;;;; Copyright (C) 2001 Rob Browning ;;;; @@ -900,6 +900,9 @@ operation is somewhat expensive." Keyword arguments: @table @code +@item #:display-style +Set the display style, either @code{'flat} or @code{'tree}. + @item #:loop Execute the body @var{loop} number of times, or @code{#f} for no looping @@ -927,6 +930,7 @@ default: @code{#f} "`with-statprof' is deprecated. Use `statprof' instead.") `((@ (statprof) statprof) (lambda () ,@(kw-arg-ref #f args #f)) + #:display-style ,(kw-arg-ref #:display-style args ''flat) #:loop ,(kw-arg-ref #:loop args 1) #:hz ,(kw-arg-ref #:hz args 100) #:count-calls? ,(kw-arg-ref #:count-calls? args #f))) From e7d341407950d504e80f92588d08f3a7c81bee37 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 9 Mar 2017 10:42:58 +0100 Subject: [PATCH 782/865] Adapt statprof to new preemptive interrupts * module/statprof.scm (profile-signal-handler): Cut an additional stack frame, corresponding to the handle-interrupts trampoline added recently. --- module/statprof.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/module/statprof.scm b/module/statprof.scm index 1efb15dff..a58fc6da6 100644 --- a/module/statprof.scm +++ b/module/statprof.scm @@ -275,9 +275,11 @@ ;; handler in an inner letrec, so that the compiler sees ;; the inner reference to profile-signal-handler as the ;; same as the procedure, and therefore keeps slot 0 - ;; alive. Nastiness, that. + ;; alive. Nastiness, that. Finally we cut one more + ;; inner frame, corresponding to the handle-interrupts + ;; trampoline. (stack - (or (make-stack #t profile-signal-handler (outer-cut state)) + (or (make-stack #t profile-signal-handler (outer-cut state) 1) (pk 'what! (make-stack #t))))) (sample-stack-procs state stack) From f7909b9516a125bc22ffdc75b889faf5da0cda06 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 9 Mar 2017 10:48:02 +0100 Subject: [PATCH 783/865] Adapt gcprof to preemptive interrupts * module/statprof.scm (gcprof): Remove handle-interrupts trampoline from captured stacks. --- module/statprof.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/module/statprof.scm b/module/statprof.scm index a58fc6da6..fe605e0e8 100644 --- a/module/statprof.scm +++ b/module/statprof.scm @@ -956,10 +956,10 @@ times." (set-inside-profiler?! state #t) (let ((stop-time (get-internal-run-time)) - ;; Cut down to gc-callback, and then one before (the - ;; after-gc async). See the note in profile-signal-handler - ;; also. - (stack (or (make-stack #t gc-callback (outer-cut state) 1) + ;; Cut down to gc-callback, and then two more (the + ;; after-gc async and the handle-interrupts trampoline). + ;; See the note in profile-signal-handler also. + (stack (or (make-stack #t gc-callback (outer-cut state) 2) (pk 'what! (make-stack #t))))) (sample-stack-procs state stack) (accumulate-time state stop-time) From 6d9335ad46e980cdd0785ea96b45d520abd4dc62 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 9 Mar 2017 14:25:37 +0100 Subject: [PATCH 784/865] All clauses of function have same nlocals * module/language/cps/compile-bytecode.scm (compile-function): * module/language/cps/slot-allocation.scm ($allocation) (lookup-nlocals, compute-frame-size, allocate-slots): Adapt to have one frame size per function, for all clauses. --- module/language/cps/compile-bytecode.scm | 3 +- module/language/cps/slot-allocation.scm | 55 +++++++++++------------- 2 files changed, 25 insertions(+), 33 deletions(-) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index a3f8ba4de..0524c1e97 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -84,7 +84,7 @@ (define (compile-function cps asm) (let* ((allocation (allocate-slots cps)) (forwarding-labels (compute-forwarding-labels cps allocation)) - (frame-size #f)) + (frame-size (lookup-nlocals allocation))) (define (forward-label k) (intmap-ref forwarding-labels k (lambda (k) k))) @@ -550,7 +550,6 @@ (unless first? (emit-end-arity asm)) (emit-label asm label) - (set! frame-size (lookup-nlocals label allocation)) (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys? frame-size alt) ;; All arities define a closure binding in slot 0. diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index f3e0dac92..6813a511f 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -45,7 +45,7 @@ (define-record-type $allocation (make-allocation slots representations constant-values call-allocs - shuffles frame-sizes) + shuffles frame-size) allocation? ;; A map of VAR to slot allocation. A slot allocation is an integer, @@ -86,9 +86,12 @@ ;; (shuffles allocation-shuffles) - ;; The number of locals for a $kclause. + ;; The number of local slots needed for this function. Because we can + ;; contify common clause tails, we use one frame size for all clauses + ;; to avoid having to adjust the frame size when continuing to labels + ;; from other clauses. ;; - (frame-sizes allocation-frame-sizes)) + (frame-size allocation-frame-size)) (define-record-type $call-alloc (make-call-alloc proc-slot slot-map) @@ -135,8 +138,8 @@ (or (call-alloc-slot-map (lookup-call-alloc k allocation)) (error "Call has no slot map" k))) -(define (lookup-nlocals k allocation) - (intmap-ref (allocation-frame-sizes allocation) k)) +(define (lookup-nlocals allocation) + (allocation-frame-size allocation)) (define-syntax-rule (persistent-intmap2 exp) (call-with-values (lambda () exp) @@ -648,7 +651,7 @@ are comparable with eqv?. A tmp slot may be used." (persistent-intmap (intmap-fold compute-shuffles cps empty-intmap))) -(define (compute-frame-sizes cps slots call-allocs shuffles) +(define (compute-frame-size cps slots call-allocs shuffles) ;; Minimum frame has one slot: the closure. (define minimum-frame-size 1) (define (get-shuffles label) @@ -671,33 +674,23 @@ are comparable with eqv?. A tmp slot may be used." (define (call-size label nargs size) (shuffle-size (get-shuffles label) (max (+ (get-proc-slot label) nargs) size))) - (define (measure-cont label cont frame-sizes clause size) + (define (measure-cont label cont size) (match cont - (($ $kfun) - (values #f #f #f)) - (($ $kclause) - (let ((frame-sizes (if clause - (intmap-add! frame-sizes clause size) - empty-intmap))) - (values frame-sizes label minimum-frame-size))) (($ $kargs names vars ($ $continue k src exp)) - (values frame-sizes clause - (let ((size (max-size* vars size))) - (match exp - (($ $call proc args) - (call-size label (1+ (length args)) size)) - (($ $callk _ proc args) - (call-size label (1+ (length args)) size)) - (($ $values args) - (shuffle-size (get-shuffles label) size)) - (_ size))))) + (let ((size (max-size* vars size))) + (match exp + (($ $call proc args) + (call-size label (1+ (length args)) size)) + (($ $callk _ proc args) + (call-size label (1+ (length args)) size)) + (($ $values args) + (shuffle-size (get-shuffles label) size)) + (_ size)))) (($ $kreceive) - (values frame-sizes clause - (shuffle-size (get-shuffles label) size))) - (($ $ktail) - (values (intmap-add! frame-sizes clause size) #f #f)))) + (shuffle-size (get-shuffles label) size)) + (_ size))) - (persistent-intmap (intmap-fold measure-cont cps #f #f #f))) + (intmap-fold measure-cont cps minimum-frame-size)) (define (allocate-args cps) (intmap-fold (lambda (label cont slots) @@ -1043,6 +1036,6 @@ are comparable with eqv?. A tmp slot may be used." (lambda (slots calls) (let* ((slots (allocate-lazy-vars cps slots calls live-in lazy)) (shuffles (compute-shuffles cps slots calls live-in)) - (frame-sizes (compute-frame-sizes cps slots calls shuffles))) + (frame-size (compute-frame-size cps slots calls shuffles))) (make-allocation slots representations constants calls - shuffles frame-sizes)))))) + shuffles frame-size)))))) From 7cdfaaada9a9c5a491c393be4cfd475fe61637b8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 9 Mar 2017 14:47:42 +0100 Subject: [PATCH 785/865] Remove contification restriction in case-lambda * module/language/cps/compile-bytecode.scm (compile-function): Check for fallthrough after $kclause too; possible to need to jump if clause tails are contified. * module/language/cps/contification.scm (compute-contification-candidates): Enable inter-clause contification. --- module/language/cps/compile-bytecode.scm | 7 ++++- module/language/cps/contification.scm | 36 ++++-------------------- 2 files changed, 12 insertions(+), 31 deletions(-) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 0524c1e97..98d635466 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -553,7 +553,12 @@ (emit-begin-kw-arity asm req opt rest kw-indices allow-other-keys? frame-size alt) ;; All arities define a closure binding in slot 0. - (emit-definition asm 'closure 0 'scm))) + (emit-definition asm 'closure 0 'scm) + ;; Usually we just fall through, but it could be the body is + ;; contified into another clause. + (let ((body (forward-label body))) + (unless (= body (skip-elided-conts (1+ label))) + (emit-br asm body))))) (($ $kargs names vars ($ $continue k src exp)) (emit-label asm label) (for-each (lambda (name var) diff --git a/module/language/cps/contification.scm b/module/language/cps/contification.scm index c08cfbc2e..f5727f842 100644 --- a/module/language/cps/contification.scm +++ b/module/language/cps/contification.scm @@ -98,24 +98,6 @@ the set." conts empty-intmap))) -(define (compute-multi-clause conts) - "Compute an set containing all labels that are part of a multi-clause -case-lambda. See the note in compute-contification-candidates." - (define (multi-clause? clause) - (and clause - (match (intmap-ref conts clause) - (($ $kclause arity body alt) - alt)))) - (intmap-fold (lambda (label cont multi) - (match cont - (($ $kfun src meta self tail clause) - (if (multi-clause? clause) - (intset-union multi (compute-function-body conts label)) - multi)) - (_ multi))) - conts - empty-intset)) - (define (compute-arities conts functions) "Given the map FUNCTIONS whose keys are $kfun labels, return a map from label to arities." @@ -152,7 +134,6 @@ from label to arities." functions with known uses that are only ever used as the operator of a $call, and are always called with a compatible arity." (let* ((functions (compute-functions conts)) - (multi-clause (compute-multi-clause conts)) (vars (intmap-fold (lambda (label vars out) (intset-fold (lambda (var out) (intmap-add out var label)) @@ -191,23 +172,18 @@ $call, and are always called with a compatible arity." (exclude-vars functions args)) (($ $call proc args) (let ((functions (exclude-vars functions args))) - ;; This contification algorithm is happy to contify the - ;; `lp' in this example into a shared tail between clauses: + ;; Note that this contification algorithm is happy to + ;; contify the `lp' in this example into a shared tail + ;; between clauses: ;; ;; (letrec ((lp (lambda () (lp)))) ;; (case-lambda ;; ((a) (lp)) ;; ((a b) (lp)))) ;; - ;; However because the current compilation pipeline has to - ;; re-nest continuations into old CPS, there would be no - ;; scope in which the tail would be valid. So, until the - ;; old compilation pipeline is completely replaced, - ;; conservatively exclude contifiable fucntions called - ;; from multi-clause procedures. - (if (intset-ref multi-clause label) - (exclude-var functions proc) - (restrict-arity functions proc (length args))))) + ;; This can cause cross-clause jumps. The rest of the + ;; compiler handles this fine though, so we allow it. + (restrict-arity functions proc (length args)))) (($ $callk k proc args) (exclude-vars functions (cons proc args))) (($ $branch kt ($ $primcall name args)) From 7de77bf7d8016446b4fcddb36e588406266ec40a Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Thu, 9 Mar 2017 15:13:19 +0100 Subject: [PATCH 786/865] Fix bug in comparison between real and complex This bug was introduced by 35a90592501ebde7e7ddbf2486ca9d315e317d09. * module/language/cps/specialize-numbers.scm (specialize-operations): Check that both operands are real as a condition for specialize-f64-comparison. * test-suite/tests/numbers.test: Add test. --- module/language/cps/specialize-numbers.scm | 14 ++++++++------ test-suite/tests/numbers.test | 9 +++++++++ 2 files changed, 17 insertions(+), 6 deletions(-) diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm index 808ea6705..d5587037b 100644 --- a/module/language/cps/specialize-numbers.scm +++ b/module/language/cps/specialize-numbers.scm @@ -51,6 +51,7 @@ (define-module (language cps specialize-numbers) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (language cps) #:use-module (language cps intmap) #:use-module (language cps intset) @@ -301,11 +302,12 @@ BITS indicating the significant bits needed for a variable. BITS may be (lambda (type min max) (and (eqv? type &exact-integer) (<= 0 min max #xffffffffffffffff)))))) - (define (f64-operand? var) - (call-with-values (lambda () - (lookup-pre-type types label var)) - (lambda (type min max) - (and (eqv? type &flonum))))) + (define (f64-operands? vara varb) + (let-values (((typea mina maxa) (lookup-pre-type types label vara)) + ((typeb minb maxb) (lookup-pre-type types label varb))) + (and (zero? (logand (logior typea typeb) (lognot &real))) + (or (eqv? typea &flonum) + (eqv? typeb &flonum))))) (match cont (($ $kfun) (let ((types (infer-types cps label))) @@ -411,7 +413,7 @@ BITS indicating the significant bits needed for a variable. BITS may be ($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) (a b))))) (values (cond - ((or (f64-operand? a) (f64-operand? b)) + ((f64-operands? a b) (with-cps cps (let$ body (specialize-f64-comparison k kt src op a b)) (setk label ($kargs names vars ,body)))) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 0adf21637..a0403a118 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -5425,3 +5425,12 @@ (test-ash-variant 'ash ash floor) (test-ash-variant 'round-ash round-ash round)) + +;;; +;;; regressions +;;; + +(with-test-prefix/c&e "bug in unboxing f64 in 2.1.6" + + (pass-if "= real and complex" + (= 1.0 (make-rectangular 1.0 0.0)))) From f71c2c12609abfac9af7d38ea99f89a1f51b6992 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 9 Mar 2017 15:53:47 +0100 Subject: [PATCH 787/865] Micro-optimize update-port-position. * libguile/ports.c (update_port_position): Only fetch line if we need to increment it. --- libguile/ports.c | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 1be4a3778..2a25cd58e 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1678,7 +1678,6 @@ scm_c_read (SCM port, void *buffer, size_t size) static inline void update_port_position (SCM position, scm_t_wchar c) { - long line = scm_to_long (scm_port_position_line (position)); int column = scm_to_int (scm_port_position_column (position)); switch (c) @@ -1691,8 +1690,11 @@ update_port_position (SCM position, scm_t_wchar c) scm_port_position_set_column (position, scm_from_int (column - 1)); break; case '\n': - scm_port_position_set_line (position, scm_from_long (line + 1)); - scm_port_position_set_column (position, SCM_INUM0); + { + long line = scm_to_long (scm_port_position_line (position)); + scm_port_position_set_line (position, scm_from_long (line + 1)); + scm_port_position_set_column (position, SCM_INUM0); + } break; case '\r': scm_port_position_set_column (position, SCM_INUM0); From c525aa6d95a9e19b260d6b99dbf6d73939d76585 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 9 Mar 2017 17:22:08 +0100 Subject: [PATCH 788/865] VM support for string-set!; slimmer read-string * doc/ref/vm.texi (Inlined Scheme Instructions): Add string-set!. * libguile/vm-engine.c (string-set!): New opcode. * module/ice-9/rdelim.scm (read-string): Reimplement in terms of a geometrically growing list of strings, to reduce total heap usage when reading big files. * module/language/cps/compile-bytecode.scm (compile-function): Add string-set! support. * module/language/cps/types.scm (string-set!): Update for &u64 index. * module/language/tree-il/compile-cps.scm (convert): Unbox index to string-set!. * module/system/vm/assembler.scm (system): Export string-set!. --- doc/ref/vm.texi | 6 +++++ libguile/vm-engine.c | 33 ++++++++++++++++++++++-- module/ice-9/rdelim.scm | 19 +++++++++----- module/language/cps/compile-bytecode.scm | 3 +++ module/language/cps/types.scm | 4 +-- module/language/tree-il/compile-cps.scm | 2 +- module/system/vm/assembler.scm | 1 + 7 files changed, 57 insertions(+), 11 deletions(-) diff --git a/doc/ref/vm.texi b/doc/ref/vm.texi index 4e42bb94c..ac3889f41 100644 --- a/doc/ref/vm.texi +++ b/doc/ref/vm.texi @@ -1355,6 +1355,12 @@ and store it in @var{dst}. The @var{idx} value should be an unboxed unsigned 64-bit integer. @end deftypefn +@deftypefn Instruction {} string-set! s8:@var{dst} s8:@var{idx} s8:@var{src} +Store the character @var{src} into the string @var{dst} at index +@var{idx}. The @var{idx} value should be an unboxed unsigned 64-bit +integer. +@end deftypefn + @deftypefn Instruction {} cons s8:@var{dst} s8:@var{car} s8:@var{cdr} Cons @var{car} and @var{cdr}, and store the result in @var{dst}. @end deftypefn diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 9ddda8f2a..89c6bc5f7 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -2263,7 +2263,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, RETURN (SCM_MAKE_CHAR (scm_i_string_ref (str, c_idx))); } - /* No string-set! instruction, as there is no good fast path there. */ + /* string-set! instruction is currently number 192. Probably need to + reorder before releasing. */ /* string->number dst:12 src:12 * @@ -4006,7 +4007,35 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, BR_F64_ARITHMETIC (>=); } - VM_DEFINE_OP (192, unused_192, NULL, NOP) + /* string-set! dst:8 idx:8 src:8 + * + * Store the character SRC into the string DST at index IDX. + */ + VM_DEFINE_OP (192, string_set, "string-set!", OP1 (X8_S8_S8_S8)) + { + scm_t_uint8 dst, idx, src; + SCM str, chr; + scm_t_uint64 c_idx; + + UNPACK_8_8_8 (op, dst, idx, src); + str = SP_REF (dst); + c_idx = SP_REF_U64 (idx); + chr = SP_REF (src); + + VM_VALIDATE_STRING (str, "string-ref"); + VM_VALIDATE_INDEX (c_idx, scm_i_string_length (str), "string-ref"); + + /* If needed we can speed this up and only SYNC_IP + + scm_i_string_writing if the string isn't already a non-shared + stringbuf. */ + SYNC_IP (); + scm_i_string_start_writing (str); + scm_i_string_set_x (str, c_idx, SCM_CHAR (chr)); + scm_i_string_stop_writing (); + + NEXT (1); + } + VM_DEFINE_OP (193, unused_193, NULL, NOP) VM_DEFINE_OP (194, unused_194, NULL, NOP) VM_DEFINE_OP (195, unused_195, NULL, NOP) diff --git a/module/ice-9/rdelim.scm b/module/ice-9/rdelim.scm index a406f4e55..d2cd081d7 100644 --- a/module/ice-9/rdelim.scm +++ b/module/ice-9/rdelim.scm @@ -156,13 +156,20 @@ If the COUNT argument is present, treat it as a limit to the number of characters to read. By default, there is no limit." ((#:optional (port (current-input-port))) ;; Fast path. - ;; This creates more garbage than using 'string-set!' as in - ;; 'read-string!', but currently that is faster nonetheless. - (let loop ((chars '())) + (let loop ((head (make-string 30)) (pos 0) (tail '())) (let ((char (read-char port))) - (if (eof-object? char) - (list->string (reverse! chars)) - (loop (cons char chars)))))) + (cond + ((eof-object? char) + (let ((head (substring head 0 pos))) + (if (null? tail) + (substring head 0 pos) + (string-concatenate-reverse tail head pos)))) + (else + (string-set! head pos char) + (if (< (1+ pos) (string-length head)) + (loop head (1+ pos) tail) + (loop (make-string (* (string-length head) 2)) 0 + (cons head tail)))))))) ((port count) ;; Slower path. (let loop ((chars '()) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 98d635466..c283eb614 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -322,6 +322,9 @@ (($ $primcall 'vector-set!/immediate (vector index value)) (emit-vector-set!/immediate asm (from-sp (slot vector)) (constant index) (from-sp (slot value)))) + (($ $primcall 'string-set! (string index char)) + (emit-string-set! asm (from-sp (slot string)) (from-sp (slot index)) + (from-sp (slot char)))) (($ $primcall 'set-car! (pair value)) (emit-set-car! asm (from-sp (slot pair)) (from-sp (slot value)))) (($ $primcall 'set-cdr! (pair value)) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index a66e4b800..fd592eadc 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -707,12 +707,12 @@ minimum, and maximum." (define-type-checker (string-set! s idx val) (and (check-type s &string 0 *max-size-t*) - (check-type idx &exact-integer 0 *max-size-t*) + (check-type idx &u64 0 *max-size-t*) (check-type val &char 0 *max-codepoint*) (< (&max idx) (&min s)))) (define-type-inferrer (string-set! s idx val) (restrict! s &string (1+ (&min/0 idx)) *max-size-t*) - (restrict! idx &exact-integer 0 (1- (&max/size s))) + (restrict! idx &u64 0 (1- (&max/size s))) (restrict! val &char 0 *max-codepoint*)) (define-simple-type-checker (string-length &string)) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 9e7dc72ca..3e1c1d44c 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -652,7 +652,7 @@ cps idx 'scm->u64 (lambda (cps idx) (have-args cps (list obj idx))))))) - ((vector-set! struct-set!) + ((vector-set! struct-set! string-set!) (match args ((obj idx val) (unbox-arg diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index aa803acaf..9ac3fa62a 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -134,6 +134,7 @@ emit-fluid-set! emit-string-length emit-string-ref + emit-string-set! emit-string->number emit-string->symbol emit-symbol->keyword From ef4a2af8036f245e1329c7d7db0900c75ed19335 Mon Sep 17 00:00:00 2001 From: Vladislav Ivanishin Date: Tue, 18 Oct 2016 18:14:22 +0300 Subject: [PATCH 789/865] Fix a couple of typos in the docs * doc/ref/scheme-ideas.texi: the some way -> the same way * doc/ref/scheme-intro.texi: Use @math inside a texinfo command (turns out $math$ is not processed in this context and thus is not rendered correctly). --- doc/ref/scheme-ideas.texi | 2 +- doc/ref/scheme-intro.texi | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/ref/scheme-ideas.texi b/doc/ref/scheme-ideas.texi index 15cf6640d..d18d1012b 100644 --- a/doc/ref/scheme-ideas.texi +++ b/doc/ref/scheme-ideas.texi @@ -484,7 +484,7 @@ moved to @ref{Curried Definitions} (It could be argued that the alternative @code{define} forms are rather confusing, especially for newcomers to the Scheme language, as they hide both the role of @code{lambda} and the fact that procedures are values -that are stored in variables in the some way as any other kind of value. +that are stored in variables in the same way as any other kind of value. On the other hand, they are very convenient, and they are also a good example of another of Scheme's powerful features: the ability to specify arbitrary syntactic transformations at run time, which can be applied to diff --git a/doc/ref/scheme-intro.texi b/doc/ref/scheme-intro.texi index 57aa18f69..b8a502475 100644 --- a/doc/ref/scheme-intro.texi +++ b/doc/ref/scheme-intro.texi @@ -10,7 +10,7 @@ Guile's core language is Scheme, which is specified and described in the series of reports known as @dfn{RnRS}. @dfn{RnRS} is shorthand for the @iftex -@dfn{Revised$^n$ Report on the Algorithmic Language Scheme}. +@dfn{Revised@math{^n} Report on the Algorithmic Language Scheme}. @end iftex @ifnottex @dfn{Revised^n Report on the Algorithmic Language Scheme}. From 9b4826563104fb5c6d5448b31953f9a126a5d15b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 10 Mar 2017 09:10:50 +0100 Subject: [PATCH 790/865] Fix atomics compilation on clang * libguile/atomics-internal.h (scm_atomic_subtract_uint32): (scm_atomic_compare_and_swap_uint32, scm_atomic_set_pointer): (scm_atomic_ref_pointer, scm_atomic_set_scm): (scm_atomic_ref_scm, scm_atomic_swap_scm): (scm_atomic_compare_and_swap_scm): Use C11 atomic types if we have loaded C11 stdatomic.h. --- libguile/atomics-internal.h | 27 +++++++++++++++++++-------- 1 file changed, 19 insertions(+), 8 deletions(-) diff --git a/libguile/atomics-internal.h b/libguile/atomics-internal.h index f2d17e102..3c4f0cbbd 100644 --- a/libguile/atomics-internal.h +++ b/libguile/atomics-internal.h @@ -31,46 +31,57 @@ #ifdef HAVE_STDATOMIC_H #include + static inline uint32_t scm_atomic_subtract_uint32 (uint32_t *loc, uint32_t arg) { - return atomic_fetch_sub (loc, arg); + atomic_uint_least32_t *a_loc = (atomic_uint_least32_t *) loc; + return atomic_fetch_sub (a_loc, arg); } static inline _Bool scm_atomic_compare_and_swap_uint32 (uint32_t *loc, uint32_t *expected, uint32_t desired) { - return atomic_compare_exchange_weak (loc, expected, desired); + atomic_uint_least32_t *a_loc = (atomic_uint_least32_t *) loc; + return atomic_compare_exchange_weak (a_loc, expected, desired); } static inline void scm_atomic_set_pointer (void **loc, void *val) { - atomic_store (loc, val); + atomic_uintptr_t *a_loc = (atomic_uintptr_t *) loc; + atomic_store (a_loc, (uintptr_t) val); } static inline void * scm_atomic_ref_pointer (void **loc) { - return atomic_load (loc); + atomic_uintptr_t *a_loc = (atomic_uintptr_t *) loc; + return (void *) atomic_load (a_loc); } static inline void scm_atomic_set_scm (SCM *loc, SCM val) { - atomic_store (loc, val); + atomic_uintptr_t *a_loc = (atomic_uintptr_t *) loc; + atomic_store (a_loc, SCM_UNPACK (val)); } static inline SCM scm_atomic_ref_scm (SCM *loc) { - return atomic_load (loc); + atomic_uintptr_t *a_loc = (atomic_uintptr_t *) loc; + return SCM_PACK (atomic_load (a_loc)); } static inline SCM scm_atomic_swap_scm (SCM *loc, SCM val) { - return atomic_exchange (loc, val); + atomic_uintptr_t *a_loc = (atomic_uintptr_t *) loc; + return SCM_PACK (atomic_exchange (a_loc, SCM_UNPACK (val))); } static inline _Bool scm_atomic_compare_and_swap_scm (SCM *loc, SCM *expected, SCM desired) { - return atomic_compare_exchange_weak (loc, expected, desired); + atomic_uintptr_t *a_loc = (atomic_uintptr_t *) loc; + return atomic_compare_exchange_weak (a_loc, + (uintptr_t *) expected, + SCM_UNPACK (desired)); } #else /* HAVE_STDATOMIC_H */ From fe0117ad63a15abff9d9471a61a5850bbf98ceee Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 10 Mar 2017 10:46:10 +0100 Subject: [PATCH 791/865] Update NEWS * NEWS: Update for 2.1.8. --- NEWS | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index d70397e97..0d86be9b3 100644 --- a/NEWS +++ b/NEWS @@ -12,7 +12,8 @@ Changes in 2.1.8 (changes since the 2.1.7 alpha release): ** Update to latest 2.0 changes -Notable this includes the fix for CVE-2016-8606. +Notably this includes the fix for CVE-2016-8606 and the fix to make +Guile's builds reproducible. ** GUILE_PROGS searches for versioned Guile @@ -32,13 +33,20 @@ Variables" in the manual, for more. * Bug fixes -** Fix type inference when multiplying flonum with complex ** Fix build errors on macOS +** Fix build errors on Cygwin +** Fix build errors with clang +** Fix statprof and gcprof stack narrowing +** Fix errors on platforms with 64 KB pages ** Fix make-polar signedness of zeros ** Fix backtraces in case-lambda with multiple cases ** Fix generic function dispatch with multiple arities ** Fix guild compile --to=cps ** Fix bogus strength reduction on (* -1 x) +** Fix type inference when multiplying flonum with complex +** Fix bug comparing real and complex numbers +** Improve memory use of read-string / get-string-all +** Allow contification within case-lambda ** Relax some constraints for circular module dependencies ** Fix scm_with_guile for threads already known to libgc ** Better errors for keyword arguments missing values (foo #:bar) From 6d0091d545160525af12c1d375b0eb51e15cd370 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 10 Mar 2017 12:02:21 +0100 Subject: [PATCH 792/865] Revert "Fix "Scheme Syntax" info rendering" This reverts commit 62f08b8f38990c1849ea61cd622f84b3d2611cd9, which was causing failing texi2dvi runs. --- doc/ref/api-evaluation.texi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index f7ec4afbd..3a3e9e632 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -92,7 +92,7 @@ Note that an application must not attempt to modify literal strings, since they may be in read-only memory. @item (quote @var{data}) -@itemx @verb{|'|}@var{data} +@itemx '@var{data} @findex quote @findex ' Quoting is used to obtain a literal symbol (instead of a variable @@ -114,7 +114,7 @@ vectors obtained from a @code{quote} form, since they may be in read-only memory. @item (quasiquote @var{data}) -@itemx @verb{|`|}@var{data} +@itemx `@var{data} @findex quasiquote @findex ` Backquote quasi-quotation is like @code{quote}, but selected From e3374320415df973a6d8b0e1065b5b74e9e3e5e0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 10 Mar 2017 11:01:04 +0100 Subject: [PATCH 793/865] Guile 2.1.8. * GUILE-VERSION (GUILE_MICRO_VERSION): Bump. --- GUILE-VERSION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index 84848c922..a180ead35 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -3,7 +3,7 @@ # Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'. GUILE_MAJOR_VERSION=2 GUILE_MINOR_VERSION=1 -GUILE_MICRO_VERSION=7 +GUILE_MICRO_VERSION=8 GUILE_EFFECTIVE_VERSION=2.2 From c9910c604279f438728cd268272e1839cbc53835 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 13 Mar 2017 15:47:51 +0100 Subject: [PATCH 794/865] Fix finalizer resuscitation causing excessive GC MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * libguile/finalizers.c (async_gc_finalizer): (scm_i_register_async_gc_callback): Replace "weak gc callback" mechanism with "async gc callback" mechanism. Very similar but the new API is designed to be called a bounded number of times, to avoid running afoul of libgc heuristics. * libguile/weak-list.h: New internal header. * libguile/Makefile.am (noinst_HEADERS): Add weak-list.h. * libguile/weak-set.c (vacuum_all_weak_sets): (scm_c_make_weak_set, scm_init_weak_set): * libguile/weak-table.c (vacuum_all_weak_tables): (scm_c_make_weak_table, scm_init_weak_table): Arrange to vacuum all weak sets from a single async GC callback, and likewise for weak tables. Thanks to Ludovic Courtès for tracking this bug down! --- libguile/Makefile.am | 4 ++- libguile/finalizers.c | 59 ++++++++++++++-------------------- libguile/finalizers.h | 8 ++--- libguile/weak-list.h | 73 +++++++++++++++++++++++++++++++++++++++++++ libguile/weak-set.c | 18 ++++++++++- libguile/weak-table.c | 18 ++++++++++- 6 files changed, 137 insertions(+), 43 deletions(-) create mode 100644 libguile/weak-list.h diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 07466069f..142e739fb 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -507,7 +507,9 @@ noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \ atomics-internal.h \ cache-internal.h \ posix-w32.h \ - private-options.h ports-internal.h + private-options.h \ + ports-internal.h \ + weak-list.h # vm instructions noinst_HEADERS += vm-engine.c diff --git a/libguile/finalizers.c b/libguile/finalizers.c index 9b9075830..c5d69e8e3 100644 --- a/libguile/finalizers.c +++ b/libguile/finalizers.c @@ -296,59 +296,46 @@ scm_i_finalizer_pre_fork (void) -static void* -weak_pointer_ref (void *weak_pointer) -{ - return *(void **) weak_pointer; -} - static void -weak_gc_finalizer (void *ptr, void *data) +async_gc_finalizer (void *ptr, void *data) { - void **weak = ptr; - void *val; - void (*callback) (SCM) = weak[1]; + void **obj = ptr; + void (*callback) (void) = obj[0]; - val = GC_call_with_alloc_lock (weak_pointer_ref, &weak[0]); + callback (); - if (!val) - return; - - callback (SCM_PACK_POINTER (val)); - - scm_i_set_finalizer (ptr, weak_gc_finalizer, data); + scm_i_set_finalizer (ptr, async_gc_finalizer, data); } -/* CALLBACK will be called on OBJ, as long as OBJ is accessible. It - will be called from a finalizer, which may be from an async or from +/* Arrange to call CALLBACK asynchronously after each GC. The callback + will be invoked from a finalizer, which may be from an async or from another thread. - As an implementation detail, the way this works is that we allocate - a fresh pointer-less object holding two words. We know that this + As an implementation detail, the way this works is that we allocate a + fresh object and put the callback in the object. We know that this object should get collected the next time GC is run, so we attach a - finalizer to it so that we get a callback after GC happens. + finalizer to it to trigger the callback. - The first word of the object holds a weak reference to OBJ, and the - second holds the callback pointer. When the callback is called, we - check if the weak reference on OBJ still holds. If it doesn't hold, - then OBJ is no longer accessible, and we're done. Otherwise we call - the callback and re-register a finalizer for our two-word GC object, - effectively resuscitating the object so that we will get a callback - on the next GC. + Once the callback runs, we re-attach a finalizer to that fresh object + to prepare for the next GC, and the process repeats indefinitely. We could use the scm_after_gc_hook, but using a finalizer has the advantage of potentially running in another thread, decreasing pause - time. */ + time. + + Note that libgc currently has a heuristic that adding 500 finalizable + objects will cause GC to collect rather than expand the heap, + drastically reducing performance on workloads that actually need to + expand the heap. Therefore scm_i_register_async_gc_callback is + inappropriate for using on unbounded numbers of callbacks. */ void -scm_i_register_weak_gc_callback (SCM obj, void (*callback) (SCM)) +scm_i_register_async_gc_callback (void (*callback) (void)) { - void **weak = GC_MALLOC_ATOMIC (sizeof (void*) * 2); + void **obj = GC_MALLOC_ATOMIC (sizeof (void*)); - weak[0] = SCM_UNPACK_POINTER (obj); - weak[1] = (void*)callback; - GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak, SCM2PTR (obj)); + obj[0] = (void*)callback; - scm_i_set_finalizer (weak, weak_gc_finalizer, NULL); + scm_i_set_finalizer (obj, async_gc_finalizer, NULL); } diff --git a/libguile/finalizers.h b/libguile/finalizers.h index d01d1b734..27b2cbf82 100644 --- a/libguile/finalizers.h +++ b/libguile/finalizers.h @@ -36,10 +36,10 @@ SCM_INTERNAL void scm_i_add_resuscitator (void *obj, scm_t_finalizer_proc, SCM_INTERNAL void scm_i_finalizer_pre_fork (void); -/* CALLBACK will be called on OBJ after each garbage collection, as long - as OBJ is accessible. It will be called from a finalizer, which may - be from an async or from another thread. */ -SCM_INTERNAL void scm_i_register_weak_gc_callback (SCM obj, void (*callback) (SCM)); +/* CALLBACK will be called after each garbage collection. It will be + called from a finalizer, which may be from an async or from another + thread. */ +SCM_INTERNAL void scm_i_register_async_gc_callback (void (*callback) (void)); SCM_API int scm_set_automatic_finalization_enabled (int enabled_p); SCM_API int scm_run_finalizers (void); diff --git a/libguile/weak-list.h b/libguile/weak-list.h new file mode 100644 index 000000000..989cb7f0a --- /dev/null +++ b/libguile/weak-list.h @@ -0,0 +1,73 @@ +/* classes: h_files */ + +#ifndef SCM_WEAK_LIST_H +#define SCM_WEAK_LIST_H + +/* Copyright (C) 2016 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 License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + + + +#include "libguile/__scm.h" +#include "libguile/weak-vector.h" + + + +static inline SCM +scm_i_weak_cons (SCM car, SCM cdr) +{ + return scm_cons (scm_c_make_weak_vector (1, car), cdr); +} + +static inline SCM +scm_i_weak_car (SCM pair) +{ + return scm_c_weak_vector_ref (scm_car (pair), 0); +} + +static inline void +scm_i_visit_weak_list (SCM *list_loc, void (*visit) (SCM)) +{ + SCM in = *list_loc, out = SCM_EOL; + + while (scm_is_pair (in)) + { + SCM car = scm_i_weak_car (in); + SCM cdr = scm_cdr (in); + + if (!scm_is_eq (car, SCM_BOOL_F)) + { + scm_set_cdr_x (in, out); + out = in; + visit (car); + } + + in = cdr; + } + + *list_loc = out; +} + + +#endif /* SCM_WEAK_LIST_H */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/weak-set.c b/libguile/weak-set.c index d2e4744bf..1576e20b0 100644 --- a/libguile/weak-set.c +++ b/libguile/weak-set.c @@ -31,6 +31,7 @@ #include "libguile/bdw-gc.h" #include "libguile/validate.h" +#include "libguile/weak-list.h" #include "libguile/weak-set.h" @@ -698,6 +699,17 @@ do_vacuum_weak_set (SCM set) scm_i_pthread_mutex_unlock (&s->lock); } +static scm_i_pthread_mutex_t all_weak_sets_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; +static SCM all_weak_sets = SCM_EOL; + +static void +vacuum_all_weak_sets (void) +{ + scm_i_pthread_mutex_lock (&all_weak_sets_lock); + scm_i_visit_weak_list (&all_weak_sets, do_vacuum_weak_set); + scm_i_pthread_mutex_unlock (&all_weak_sets_lock); +} + SCM scm_c_make_weak_set (unsigned long k) { @@ -705,7 +717,9 @@ scm_c_make_weak_set (unsigned long k) ret = make_weak_set (k); - scm_i_register_weak_gc_callback (ret, do_vacuum_weak_set); + scm_i_pthread_mutex_lock (&all_weak_sets_lock); + all_weak_sets = scm_i_weak_cons (ret, all_weak_sets); + scm_i_pthread_mutex_unlock (&all_weak_sets_lock); return ret; } @@ -883,6 +897,8 @@ void scm_init_weak_set () { #include "libguile/weak-set.x" + + scm_i_register_async_gc_callback (vacuum_all_weak_sets); } /* diff --git a/libguile/weak-table.c b/libguile/weak-table.c index 1bb513b17..599c4cf0e 100644 --- a/libguile/weak-table.c +++ b/libguile/weak-table.c @@ -33,6 +33,7 @@ #include "libguile/ports.h" #include "libguile/validate.h" +#include "libguile/weak-list.h" #include "libguile/weak-table.h" @@ -832,6 +833,17 @@ do_vacuum_weak_table (SCM table) return; } +static scm_i_pthread_mutex_t all_weak_tables_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; +static SCM all_weak_tables = SCM_EOL; + +static void +vacuum_all_weak_tables (void) +{ + scm_i_pthread_mutex_lock (&all_weak_tables_lock); + scm_i_visit_weak_list (&all_weak_tables, do_vacuum_weak_table); + scm_i_pthread_mutex_unlock (&all_weak_tables_lock); +} + SCM scm_c_make_weak_table (unsigned long k, scm_t_weak_table_kind kind) { @@ -839,7 +851,9 @@ scm_c_make_weak_table (unsigned long k, scm_t_weak_table_kind kind) ret = make_weak_table (k, kind); - scm_i_register_weak_gc_callback (ret, do_vacuum_weak_table); + scm_i_pthread_mutex_lock (&all_weak_tables_lock); + all_weak_tables = scm_i_weak_cons (ret, all_weak_tables); + scm_i_pthread_mutex_unlock (&all_weak_tables_lock); return ret; } @@ -1155,6 +1169,8 @@ void scm_init_weak_table () { #include "libguile/weak-table.x" + + scm_i_register_async_gc_callback (vacuum_all_weak_tables); } /* From 0543ec96b22001d884fa444f55807825c70fa719 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 13 Mar 2017 22:16:56 +0100 Subject: [PATCH 795/865] Nonlocal prompt returns cause all effects * module/language/cps/effects-analysis.scm (expression-effects): Prompts cause &all-effects. I tried to limit this change to CSE but it was actually LICM that was borked, so better to be conservative * test-suite/tests/control.test ("escape-only continuations"): Add test. --- module/language/cps/effects-analysis.scm | 5 ++++- test-suite/tests/control.test | 12 +++++++++++- 2 files changed, 15 insertions(+), 2 deletions(-) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index f1833bbb5..4eff0d261 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -517,7 +517,10 @@ is or might be a read or a write to the same location as A." ((or ($ $fun) ($ $rec) ($ $closure)) (&allocate &unknown-memory-kinds)) (($ $prompt) - (&write-object &prompt)) + ;; Although the "main" path just writes &prompt, we don't know what + ;; nonlocal predecessors of the handler do, so we conservatively + ;; assume &all-effects. + &all-effects) ((or ($ $call) ($ $callk)) &all-effects) (($ $branch k exp) diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test index 4ca8ed8cd..213917fc1 100644 --- a/test-suite/tests/control.test +++ b/test-suite/tests/control.test @@ -103,7 +103,17 @@ (cons element prefix))) '() lst))))) - (prefix 'a '(0 1 2 a 3 4 5))))) + (prefix 'a '(0 1 2 a 3 4 5)))) + + (pass-if "loop only in handler" + (let ((n #f)) + (let lp () + (or n + (call-with-prompt 'foo + (lambda () + (set! n #t) + (abort-to-prompt 'foo)) + (lambda (k) (lp)))))))) ;;; And the case in which the compiler has to reify the continuation. (with-test-prefix/c&e "reified continuations" From c50c3a47b328c10780f4453b925a3e36d182c2bd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 14 Mar 2017 09:43:50 +0100 Subject: [PATCH 796/865] configure detects which set of prebuilt binaries to use * configure.ac: Use detected endianness and word size to automatically select which set of prebuilt binaries to use. * meta/build-env.in (top_builddir): * meta/uninstalled-env.in (top_builddir): Update to use SCM_PREBUILT_BINARIES for prebuilt entry in GUILE_LOAD_COMPILED_PATH. * prebuilt/32-bit-big-endian: * prebuilt/32-bit-little-endian: * prebuilt/64-bit-little-endian: New links. * prebuilt/x86_64-pc-linux-gnu: Remove this link now that it's unneeded. --- configure.ac | 12 ++++++++++++ meta/build-env.in | 4 ++-- meta/uninstalled-env.in | 4 ++-- prebuilt/32-bit-big-endian | 1 + prebuilt/32-bit-little-endian | 1 + prebuilt/64-bit-little-endian | 1 + prebuilt/x86_64-pc-linux-gnu | 1 - 7 files changed, 19 insertions(+), 5 deletions(-) create mode 120000 prebuilt/32-bit-big-endian create mode 120000 prebuilt/32-bit-little-endian create mode 120000 prebuilt/64-bit-little-endian delete mode 120000 prebuilt/x86_64-pc-linux-gnu diff --git a/configure.ac b/configure.ac index 24ee878d5..217364bbf 100644 --- a/configure.ac +++ b/configure.ac @@ -631,6 +631,18 @@ AC_SUBST([SCM_I_GSC_T_UINTPTR]) AC_SUBST([SCM_I_GSC_NEEDS_STDINT_H]) AC_SUBST([SCM_I_GSC_NEEDS_INTTYPES_H]) +AC_MSG_CHECKING([for which prebuilt binary set to use during bootstrap]) +SCM_PREBUILT_BINARIES= +case "$ac_cv_c_bigendian-$ac_cv_sizeof_void_p" in + yes-8) SCM_PREBUILT_BINARIES=64-bit-big-endian;; + yes-4) SCM_PREBUILT_BINARIES=32-bit-big-endian;; + no-8) SCM_PREBUILT_BINARIES=64-bit-little-endian;; + no-4) SCM_PREBUILT_BINARIES=32-bit-little-endian;; + *) AC_MSG_ERROR([Unexpected endianness+pointer size combination.]) +esac +AC_MSG_RESULT($SCM_PREBUILT_BINARIES) +AC_SUBST([SCM_PREBUILT_BINARIES]) + AC_HEADER_STDC AC_HEADER_TIME AC_HEADER_SYS_WAIT diff --git a/meta/build-env.in b/meta/build-env.in index b271d0bc8..27e604366 100644 --- a/meta/build-env.in +++ b/meta/build-env.in @@ -1,6 +1,6 @@ #!/bin/sh -# Copyright (C) 2003, 2006, 2008-2012, 2016 Free Software Foundation +# Copyright (C) 2003, 2006, 2008-2012, 2016, 2017 Free Software Foundation # # This file is part of GNU Guile. # @@ -54,7 +54,7 @@ then GUILE_LOAD_PATH="$GUILE_LOAD_PATH:${top_builddir}/module:${top_builddir}/guile-readline" fi export GUILE_LOAD_PATH - GUILE_LOAD_COMPILED_PATH="${top_builddir}/module:${top_builddir}/bootstrap:${top_srcdir}/prebuilt/@host@:${top_builddir}/guile-readline" + GUILE_LOAD_COMPILED_PATH="${top_builddir}/module:${top_builddir}/bootstrap:${top_srcdir}/prebuilt/@SCM_PREBUILT_BINARIES@:${top_builddir}/guile-readline" export GUILE_LOAD_COMPILED_PATH # Don't look in installed dirs for guile modules diff --git a/meta/uninstalled-env.in b/meta/uninstalled-env.in index ff32902d0..ed932d0cb 100644 --- a/meta/uninstalled-env.in +++ b/meta/uninstalled-env.in @@ -1,6 +1,6 @@ #!/bin/sh -# Copyright (C) 2003, 2006, 2008, 2009, 2010, 2011, 2012, 2015 Free Software Foundation +# Copyright (C) 2003, 2006, 2008, 2009, 2010, 2011, 2012, 2015, 2017 Free Software Foundation # # This file is part of GUILE. # @@ -80,7 +80,7 @@ then fi export GUILE_LOAD_PATH - for d in "/prebuilt/@host@" "/bootstrap" "/module" "/guile-readline" + for d in "/prebuilt/@SCM_PREBUILT_BINARIES@" "/bootstrap" "/module" "/guile-readline" do # This hair prevents double inclusion. # The ":" prevents prefix aliasing. diff --git a/prebuilt/32-bit-big-endian b/prebuilt/32-bit-big-endian new file mode 120000 index 000000000..3b619a6a1 --- /dev/null +++ b/prebuilt/32-bit-big-endian @@ -0,0 +1 @@ +mips-unknown-linux-gnu \ No newline at end of file diff --git a/prebuilt/32-bit-little-endian b/prebuilt/32-bit-little-endian new file mode 120000 index 000000000..63f12a0b3 --- /dev/null +++ b/prebuilt/32-bit-little-endian @@ -0,0 +1 @@ +i686-pc-linux-gnu \ No newline at end of file diff --git a/prebuilt/64-bit-little-endian b/prebuilt/64-bit-little-endian new file mode 120000 index 000000000..8dd176f8b --- /dev/null +++ b/prebuilt/64-bit-little-endian @@ -0,0 +1 @@ +x86_64-unknown-linux-gnu \ No newline at end of file diff --git a/prebuilt/x86_64-pc-linux-gnu b/prebuilt/x86_64-pc-linux-gnu deleted file mode 120000 index 7ef2cbd31..000000000 --- a/prebuilt/x86_64-pc-linux-gnu +++ /dev/null @@ -1 +0,0 @@ -./x86_64-unknown-linux-gnu \ No newline at end of file From bbc93ed9103f6cd533e32edbc2d35837879946e1 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 14 Mar 2017 11:26:49 +0100 Subject: [PATCH 797/865] Update NEWS * NEWS: Update for 2.2.0. --- NEWS | 127 ++++++++++++++++++++--------------------------------------- 1 file changed, 42 insertions(+), 85 deletions(-) diff --git a/NEWS b/NEWS index 0d86be9b3..50eccca47 100644 --- a/NEWS +++ b/NEWS @@ -6,60 +6,7 @@ Please send Guile bug reports to bug-guile@gnu.org. -Changes in 2.1.8 (changes since the 2.1.7 alpha release): - -* Notable changes - -** Update to latest 2.0 changes - -Notably this includes the fix for CVE-2016-8606 and the fix to make -Guile's builds reproducible. - -** GUILE_PROGS searches for versioned Guile - -The GUILE_PROGS autoconf macro can take a required version argument. As -a new change, that version argument is additionally searched for as a -suffix. For example, GUILE_PROGS(2.2) would look for guile-2.2, -guile2.2, guile-2, guile2, and then guile. The found prefix is also -applied to guild, guile-config, and the like. Thanks to Freja Nordsiek -for this work. - -** Add thread-local fluids - -Guile now has support for fluids whose values are not captured by -`current-dynamic-state' and not inheritied by child threads, and thus -are local to the kernel thread they run on. See "Thread-Local -Variables" in the manual, for more. - -* Bug fixes - -** Fix build errors on macOS -** Fix build errors on Cygwin -** Fix build errors with clang -** Fix statprof and gcprof stack narrowing -** Fix errors on platforms with 64 KB pages -** Fix make-polar signedness of zeros -** Fix backtraces in case-lambda with multiple cases -** Fix generic function dispatch with multiple arities -** Fix guild compile --to=cps -** Fix bogus strength reduction on (* -1 x) -** Fix type inference when multiplying flonum with complex -** Fix bug comparing real and complex numbers -** Improve memory use of read-string / get-string-all -** Allow contification within case-lambda -** Relax some constraints for circular module dependencies -** Fix scm_with_guile for threads already known to libgc -** Better errors for keyword arguments missing values (foo #:bar) -** Various manual updates -** Use docstrings instead of comments for many core Guile functions -** Support truncate-file on string ports -** Getting output from R6RS string ports now truncates buffer -** Fix class-allocated GOOPS slots -** Fix tracing/breakpoints (broken in 2.2 since a long time!) -** `select' just returns instead of throwing exception on EINTR - - -Previous changes in 2.1.x (changes since the 2.0.x series): +Changes in 2.2.0 (changes since the 2.0.x stable release series): * Notable changes @@ -75,6 +22,8 @@ better memory usage, and faster execution of user code. See the This new release series takes the ABI-break opportunity to fix some interfaces that were difficult to use correctly from multiple threads. Notably, weak hash tables and ports are now transparently thread-safe. +See "Scheduling" in the manual, for updated documentation on threads and +communications primitives. ** Better space-safety @@ -106,14 +55,14 @@ hash-bang line (e.g. "#!/usr/bin/guile"), it now installs the current locale via a call to `(setlocale LC_ALL "")'. For users with a unicode locale, this makes all ports unicode-capable by default, without the need to call `setlocale' in your program. This behavior may be -controlled via the GUILE_INSTALL_LOCALE environment variable; see the -manual for more. +controlled via the GUILE_INSTALL_LOCALE environment variable; see +"Environment Variables" in the manual, for more. ** Complete Emacs-compatible Elisp implementation -Thanks to the work of BT Templeton, Guile's Elisp implementation is now -fully Emacs-compatible, implementing all of Elisp's features and quirks -in the same way as the editor we know and love. +Thanks to the work of Robin Templeton, Guile's Elisp implementation is +now fully Emacs-compatible, implementing all of Elisp's features and +quirks in the same way as the editor we know and love. ** Dynamically expandable stacks @@ -169,14 +118,14 @@ interface, at least for `stdint' support. ** Lightweight pre-emptive threading primitives The compiler now inserts special "handle-interrupts" opcodes before each -call, return, and loop back-edge. This allows the user to interrupt any -computation and to accurately profile code using interrupts. It used to -be that interrupts were run by calling a C function from the VM; now -interrupt thunks are run directly from the VM. This allows interrupts -to save a delimited continuation and, if the continuation was -established from the same VM invocation (the usual restriction), that -continuation can then be resumed. In this way users can implement -lightweight pre-emptive threading facilities. +call, return, and backwards jump target. This allows the user to +interrupt any computation and to accurately profile code using +interrupts. It used to be that interrupts were run by calling a C +function from the VM; now interrupt thunks are run directly from the VM. +This allows interrupts to save a delimited continuation and, if the +continuation was established from the same VM invocation (the usual +restriction), that continuation can then be resumed. In this way users +can implement lightweight pre-emptive threading facilities. ** with-dynamic-state in VM @@ -184,11 +133,7 @@ Similarly, `with-dynamic-state' no longer recurses out of the VM, allowing captured delimited continuations that include a `with-dynamic-state' invocation to be resumed. This is a precondition to allow lightweight threading libraries to establish a dynamic state -per thread. - -** cancel-thread uses asynchronous interrupts, not pthread_cancel - -See "Asyncs" in the manual, for more on asynchronous interrupts. +per lightweight fiber. * Performance improvements @@ -289,11 +234,6 @@ Since the compiler was rewritten, there are new modules for the back-end of the compiler and the low-level loader and introspection interfaces. See the "Guile Implementation" chapter in the manual for all details. -** New functions: `scm_to_intptr_t', `scm_from_intptr_t' -** New functions: `scm_to_uintptr_t', `scm_from_uintptr_t' - -See "Integers" in the manual, for more. - ** Add "tree" display mode for statprof. See the newly updated "Statprof" section of the manual, for more. @@ -322,6 +262,13 @@ and Communication" in the manual, for more. See "Atomics" in the manual. +** Thread-local fluids + +Guile now has support for fluids whose values are not captured by +`current-dynamic-state' and not inheritied by child threads, and thus +are local to the kernel thread they run on. See "Thread-Local +Variables" in the manual, for more. + ** suspendable-continuation? This predicate returns true if the delimited continuation captured by @@ -331,7 +278,7 @@ Primitives" in the manual for more. ** scm_c_prepare_to_wait_on_fd, scm_c_prepare_to_wait_on_cond, ** scm_c_wait_finished -See "Interrupts" in the manual for more. +See "Asyncs" in the manual for more. ** File descriptor finalizers @@ -361,12 +308,13 @@ section of the manual, for more. ** , standard-vtable-fields -See "Structures" in the manual for more on these +See "Structures" in the manual for more on these. ** Convenience utilities for ports and strings. -See XXX for more on `scm_from_port_string', `scm_from_port_stringn', -`scm_to_port_string', and `scm_to_port_stringn'. +See "Conversion to/from C" for more on `scm_from_port_string', +`scm_from_port_stringn', `scm_to_port_string', and +`scm_to_port_stringn'. ** New expressive PEG parser @@ -520,6 +468,10 @@ break, however; we used the deprecation facility to signal a warning message while also providing these bindings in the root environment for the duration of the 2.2 series. +** cancel-thread uses asynchronous interrupts, not pthread_cancel + +See "Asyncs" in the manual, for more on asynchronous interrupts. + ** SRFI-18 threads, mutexes, cond vars disjoint from Guile When we added support for the SRFI-18 threading library in Guile 2.0, we @@ -962,10 +914,6 @@ that Guile can bootstrap itself from its minimal bootstrap C interpreter. If you do not want to depend on these pre-built binaries, you can "make -C prebuilt clean" before building. -If Guile doesn't pre-build binaries for your architecture and you would -like support for your architecture, see prebuilt/Makefile.am for more -information on how to add support. - ** New minor version The "effective version" of Guile is now 2.2, which allows parallel @@ -975,6 +923,15 @@ Notably, the `pkg-config' file is now `guile-2.2'. ** Bump required libgc version to 7.2, released March 2012. +** GUILE_PROGS searches for versioned Guile + +The GUILE_PROGS autoconf macro can take a required version argument. As +a new change, that version argument is additionally searched for as a +suffix. For example, GUILE_PROGS(2.2) would look for guile-2.2, +guile2.2, guile-2, guile2, and then guile. The found prefix is also +applied to guild, guile-config, and the like. Thanks to Freja Nordsiek +for this work. + ** The readline extension is now installed in the extensionsdir The shared library that implements Guile's readline extension is no From 036cc149e6e52722f16ef25f4203e82abae9bc79 Mon Sep 17 00:00:00 2001 From: Freja Nordsiek Date: Tue, 14 Mar 2017 15:14:47 +0100 Subject: [PATCH 798/865] Fixed reversed version order bug in GUILE_PROGS Autoconf macro. * meta/guile.m4 (GUILE_PROGS): Build version in correct order. --- meta/guile.m4 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/meta/guile.m4 b/meta/guile.m4 index 2e4f3dc3d..b0ef9bece 100644 --- a/meta/guile.m4 +++ b/meta/guile.m4 @@ -211,8 +211,8 @@ AC_DEFUN([GUILE_PROGS], _guile_candidates=guile _tmp= for v in `echo "$_guile_required_version" | tr . ' '`; do - if test -n "$_tmp"; then _tmp=.$_tmp; fi - _tmp=$v$_tmp + if test -n "$_tmp"; then _tmp=$_tmp.; fi + _tmp=$_tmp$v _guile_candidates="guile-$_tmp guile$_tmp $_guile_candidates" done From 9098c216e1032cf5053deffed3b0384a8b664a0b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 12 Oct 2016 12:03:16 +0200 Subject: [PATCH 799/865] build: Compress with lzip too. * configure.ac: Add 'dist-lzip' Automake option. --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 217364bbf..0bde77e89 100644 --- a/configure.ac +++ b/configure.ac @@ -39,7 +39,7 @@ dnl Use `serial-tests' so the output `check-guile' is not hidden dnl (`parallel-tests' is the default in Automake 1.13.) dnl `serial-tests' was introduced in Automake 1.12. AM_INIT_AUTOMAKE([1.12 gnu no-define -Wall -Wno-override \ - serial-tests color-tests dist-xz]) + serial-tests color-tests dist-lzip dist-xz]) m4_ifdef([AM_SILENT_RULES], [AM_SILENT_RULES([yes])], [AC_SUBST([AM_DEFAULT_VERBOSITY],1)]) AC_COPYRIGHT(GUILE_CONFIGURE_COPYRIGHT) From cbc469f8a4dceeb782e8ab6f5f0fe4fb454532c9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 14 Mar 2017 15:18:41 +0100 Subject: [PATCH 800/865] Resolve unresolved alist test cases * test-suite/tests/alist.test: Update unresolved cases to match current behavior. Bogus but stable :/ --- test-suite/tests/alist.test | 87 +++++++++++++------------------------ 1 file changed, 29 insertions(+), 58 deletions(-) diff --git a/test-suite/tests/alist.test b/test-suite/tests/alist.test index 0ed5d22c8..1e10864d0 100644 --- a/test-suite/tests/alist.test +++ b/test-suite/tests/alist.test @@ -1,5 +1,5 @@ ;;;; alist.test --- tests guile's alists -*- scheme -*- -;;;; Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001, 2006, 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 @@ -15,22 +15,11 @@ ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -(use-modules (test-suite lib)) +(define-module (test-suite alist) + #:use-module (test-suite lib)) -;;; (gbh) some of these are duplicated in r4rs. This is probably a bit -;;; more thorough, though (maybe overkill? I need it, anyway). -;;; -;;; -;;; Also: it will fail on the ass*-ref & remove functions. -;;; Sloppy versions should be added with the current behaviour -;;; (it's the only set of 'ref functions that won't cause an -;;; error on an incorrect arg); they aren't actually used anywhere -;;; so changing's not a big deal. - -;;; Misc - -(define-macro (pass-if-not str form) - `(pass-if ,str (not ,form))) +(define-syntax-rule (pass-if-not str form) + (pass-if str (not form))) (define (safe-assq-ref alist elt) (let ((x (assq elt alist))) @@ -130,22 +119,14 @@ (pass-if-not "assoc-ref not" (assoc-ref a 'testing)) - (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref))) + (pass-if-not "assv-ref deformed" + (assv-ref deformed 'sloppy)) - (pass-if-exception "assv-ref deformed" - exception:wrong-type-arg - (if (not have-sloppy-assv-ref?) (throw 'unsupported)) - (assv-ref deformed 'sloppy)) + (pass-if-not "assoc-ref deformed" + (assoc-ref deformed 'sloppy)) - (pass-if-exception "assoc-ref deformed" - exception:wrong-type-arg - (if (not have-sloppy-assv-ref?) (throw 'unsupported)) - (assoc-ref deformed 'sloppy)) - - (pass-if-exception "assq-ref deformed" - exception:wrong-type-arg - (if (not have-sloppy-assv-ref?) (throw 'unsupported)) - (assq-ref deformed 'sloppy)))) + (pass-if-not "assq-ref deformed" + (assq-ref deformed 'sloppy))) ;;; Setters @@ -191,22 +172,17 @@ (and x (string? x) (string=? x "horn"))))) - (let* ((have-sloppy-assv-ref? (defined? 'sloppy-assv-ref))) + (pass-if-equal "assq-set! deformed" + (assq-set! deformed 'cold '(very cold)) + '((cold very cold) canada is a cold nation)) - (pass-if-exception "assq-set! deformed" - exception:wrong-type-arg - (if (not have-sloppy-assv-ref?) (throw 'unsupported)) - (assq-set! deformed 'cold '(very cold))) + (pass-if-equal "assv-set! deformed" + (assv-set! deformed 'canada 'Canada) + '((canada . Canada) canada is a cold nation)) - (pass-if-exception "assv-set! deformed" - exception:wrong-type-arg - (if (not have-sloppy-assv-ref?) (throw 'unsupported)) - (assv-set! deformed 'canada 'Canada)) - - (pass-if-exception "assoc-set! deformed" - exception:wrong-type-arg - (if (not have-sloppy-assv-ref?) (throw 'unsupported)) - (assoc-set! deformed 'canada '(Iceland hence the name))))) + (pass-if-equal "assoc-set! deformed" + (assoc-set! deformed 'canada '(Iceland hence the name)) + '((canada Iceland hence the name) canada is a cold nation))) ;;; Removers @@ -226,19 +202,14 @@ (set! b (assoc-remove! b "what")) (equal? b '(("could" . "I") ("say" . "here"))))) - (let* ((have-sloppy-assq-remove? (defined? 'sloppy-assq-remove))) + (pass-if-equal "assq-remove! deformed" + (assq-remove! deformed 'puddle) + 1) - (pass-if-exception "assq-remove! deformed" - exception:wrong-type-arg - (if (not have-sloppy-assq-remove?) (throw 'unsupported)) - (assq-remove! deformed 'puddle)) + (pass-if-equal "assv-remove! deformed" + (assv-remove! deformed 'splashing) + 1) - (pass-if-exception "assv-remove! deformed" - exception:wrong-type-arg - (if (not have-sloppy-assq-remove?) (throw 'unsupported)) - (assv-remove! deformed 'splashing)) - - (pass-if-exception "assoc-remove! deformed" - exception:wrong-type-arg - (if (not have-sloppy-assq-remove?) (throw 'unsupported)) - (assoc-remove! deformed 'fun)))) + (pass-if-equal "assoc-remove! deformed" + (assoc-remove! deformed 'fun) + 1)) From 1d326a511b55f367cb1f9bb8fe0c238d7205a58b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 14 Mar 2017 15:35:38 +0100 Subject: [PATCH 801/865] Better eval+promise+gc test * test-suite/tests/eval.test ("promises"): Increase clear pass rate on this test. --- test-suite/tests/eval.test | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/eval.test b/test-suite/tests/eval.test index 26917d762..8a52e11f2 100644 --- a/test-suite/tests/eval.test +++ b/test-suite/tests/eval.test @@ -306,8 +306,13 @@ (g x) (set! p (delay (car x)))) (force p) + (gc) + ;; Though this test works reliably when running just eval.test, + ;; it often does the unresolved case when running the full + ;; suite. Adding this extra gc makes the full-suite behavior + ;; pass more reliably. (gc) - (if (not (equal? (g) (cons #f #f))) + (if (not (equal? (g) (cons #f #f))) (throw 'unresolved) #t)))) From 30814fc64bc82980b337d71c9c705d17529f83c3 Mon Sep 17 00:00:00 2001 From: Freja Nordsiek Date: Tue, 14 Mar 2017 17:05:09 +0100 Subject: [PATCH 802/865] GUILE_SITE_DIR: Update to find compiled site directories * meta/guile.m4 (GUILE_SITE_DIR): Update to find compiled site directories. * meta/guile-2.2.pc.in: Add entry for site-ccache directory. --- meta/guile-2.2.pc.in | 1 + meta/guile.m4 | 44 ++++++++++++++++++++++++++++++++++++++------ 2 files changed, 39 insertions(+), 6 deletions(-) diff --git a/meta/guile-2.2.pc.in b/meta/guile-2.2.pc.in index c8f485bc1..c6d12b589 100644 --- a/meta/guile-2.2.pc.in +++ b/meta/guile-2.2.pc.in @@ -10,6 +10,7 @@ pkgincludedir=@includedir@/guile sitedir=@sitedir@ extensiondir=@libdir@/guile/@GUILE_EFFECTIVE_VERSION@/extensions +siteccachedir=@libdir@/guile/@GUILE_EFFECTIVE_VERSION@/site-ccache libguileinterface=@LIBGUILE_INTERFACE@ # Actual name of the 'guile' and 'guild' programs. This is diff --git a/meta/guile.m4 b/meta/guile.m4 index b0ef9bece..23c2c63bc 100644 --- a/meta/guile.m4 +++ b/meta/guile.m4 @@ -25,7 +25,7 @@ ## GUILE_PKG -- find Guile development files ## GUILE_PROGS -- set paths to Guile interpreter, config and tool programs ## GUILE_FLAGS -- set flags for compiling and linking with Guile -## GUILE_SITE_DIR -- find path to Guile "site" directory +## GUILE_SITE_DIR -- find path to Guile "site" directories ## GUILE_CHECK -- evaluate Guile Scheme code and capture the return value ## GUILE_MODULE_CHECK -- check feature of a Guile Scheme module ## GUILE_MODULE_AVAILABLE -- check availability of a Guile Scheme module @@ -154,18 +154,28 @@ AC_DEFUN([GUILE_FLAGS], AC_SUBST([GUILE_LTLIBS]) ]) -# GUILE_SITE_DIR -- find path to Guile "site" directory +# GUILE_SITE_DIR -- find path to Guile site directories # # Usage: GUILE_SITE_DIR # -# This looks for Guile's "site" directory, usually something like -# PREFIX/share/guile/site, and sets var @var{GUILE_SITE} to the path. -# Note that the var name is different from the macro name. +# This looks for Guile's "site" directories. The variable @var{GUILE_SITE} will +# be set to Guile's "site" directory for Scheme source files (usually something +# like PREFIX/share/guile/site). @var{GUILE_SITE_CCACHE} will be set to the +# directory for compiled Scheme files also known as @code{.go} files +# (usually something like +# PREFIX/lib/guile/@var{GUILE_EFFECTIVE_VERSION}/site-ccache). +# @var{GUILE_EXTENSION} will be set to the directory for compiled C extensions +# (usually something like +# PREFIX/lib/guile/@var{GUILE_EFFECTIVE_VERSION}/extensions). The latter two +# are set to blank if the particular version of Guile does not support +# them. Note that this macro will run the macros @code{GUILE_PKG} and +# @code{GUILE_PROGS} if they have not already been run. # -# The variable is marked for substitution, as by @code{AC_SUBST}. +# The variables are marked for substitution, as by @code{AC_SUBST}. # AC_DEFUN([GUILE_SITE_DIR], [AC_REQUIRE([GUILE_PKG]) + AC_REQUIRE([GUILE_PROGS]) AC_MSG_CHECKING(for Guile site directory) GUILE_SITE=`$PKG_CONFIG --print-errors --variable=sitedir guile-$GUILE_EFFECTIVE_VERSION` AC_MSG_RESULT($GUILE_SITE) @@ -173,6 +183,28 @@ AC_DEFUN([GUILE_SITE_DIR], AC_MSG_FAILURE(sitedir not found) fi AC_SUBST(GUILE_SITE) + AC_MSG_CHECKING([for Guile site-ccache directory using pkgconfig]) + GUILE_SITE_CCACHE=`$PKG_CONFIG --variable=siteccachedir guile-$GUILE_EFFECTIVE_VERSION` + if test "$GUILE_SITE_CCACHE" = ""; then + AC_MSG_RESULT(no) + AC_MSG_CHECKING([for Guile site-ccache directory using interpreter]) + GUILE_SITE_CCACHE=`$GUILE -c "(display (if (defined? '%site-ccache-dir) (%site-ccache-dir) \"\"))"` + if test $? != "0" -o "$GUILE_SITE_CCACHE" = ""; then + AC_MSG_RESULT(no) + GUILE_SITE_CCACHE="" + AC_MSG_WARN([siteccachedir not found]) + fi + fi + AC_MSG_RESULT($GUILE_SITE_CCACHE) + AC_SUBST([GUILE_SITE_CCACHE]) + AC_MSG_CHECKING(for Guile extensions directory) + GUILE_EXTENSION=`$PKG_CONFIG --print-errors --variable=extensiondir guile-$GUILE_EFFECTIVE_VERSION` + AC_MSG_RESULT($GUILE_EXTENSION) + if test "$GUILE_EXTENSION" = ""; then + GUILE_EXTENSION="" + AC_MSG_WARN(extensiondir not found) + fi + AC_SUBST(GUILE_EXTENSION) ]) # GUILE_PROGS -- set paths to Guile interpreter, config and tool programs From e6b890028cbfae6945080669f1598b4e4917ae63 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 15 Mar 2017 09:02:52 +0100 Subject: [PATCH 803/865] GNU Guile 2.2.0. * GUILE-VERSION (GUILE_MINOR_VERSION, GUILE_MICRO_VERSION): Bump. (LIBGUILE_INTERFACE_CURRENT): Incrememt to indicate that we now have a defined libtool ABI "interface" of 1, that we support no other interface (yet), and that this is the 0th revision of that interface. --- GUILE-VERSION | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index a180ead35..1b5f90d96 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -2,8 +2,8 @@ # Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'. GUILE_MAJOR_VERSION=2 -GUILE_MINOR_VERSION=1 -GUILE_MICRO_VERSION=8 +GUILE_MINOR_VERSION=2 +GUILE_MICRO_VERSION=0 GUILE_EFFECTIVE_VERSION=2.2 @@ -16,7 +16,7 @@ GUILE_EFFECTIVE_VERSION=2.2 # See libtool info pages for more information on how and when to # change these. -LIBGUILE_INTERFACE_CURRENT=0 +LIBGUILE_INTERFACE_CURRENT=1 LIBGUILE_INTERFACE_REVISION=0 LIBGUILE_INTERFACE_AGE=0 LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}" From db19853b0668fbd76dd9fc07b451102e32e8a36d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 15 Mar 2017 09:12:55 +0100 Subject: [PATCH 804/865] Update --version and REPL copyright years * module/ice-9/command-line.scm (version-etc): * module/system/repl/common.scm (*version*): Update release year. --- module/ice-9/command-line.scm | 4 ++-- module/system/repl/common.scm | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm index 98d385569..c4aa35ab2 100644 --- a/module/ice-9/command-line.scm +++ b/module/ice-9/command-line.scm @@ -1,6 +1,6 @@ ;;; Parsing Guile's command-line -;;; Copyright (C) 1994-1998, 2000-2016 Free Software Foundation, Inc. +;;; Copyright (C) 1994-1998, 2000-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 @@ -66,7 +66,7 @@ There is NO WARRANTY, to the extent permitted by law.")) (define* (version-etc package version #:key (port (current-output-port)) ;; FIXME: authors - (copyright-year 2016) + (copyright-year 2017) (copyright-holder "Free Software Foundation, Inc.") (copyright (format #f "Copyright (C) ~a ~a" copyright-year copyright-holder)) diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm index 3bd049159..42d5c24ae 100644 --- a/module/system/repl/common.scm +++ b/module/system/repl/common.scm @@ -40,7 +40,7 @@ (define *version* (format #f "GNU Guile ~A -Copyright (C) 1995-2016 Free Software Foundation, Inc. +Copyright (C) 1995-2017 Free Software Foundation, Inc. Guile comes with ABSOLUTELY NO WARRANTY; for details type `,show w'. This program is free software, and you are welcome to redistribute it From da9dee098f97fe3fc825024e202f99c70eb53915 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 15 Mar 2017 10:02:01 +0100 Subject: [PATCH 805/865] Add generic prebuilt links to dist. * prebuilt/Makefile.am (EXTRA_DIST): Add generic prebuilt links. --- prebuilt/Makefile.am | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/prebuilt/Makefile.am b/prebuilt/Makefile.am index b0a24d023..5753e09f4 100644 --- a/prebuilt/Makefile.am +++ b/prebuilt/Makefile.am @@ -54,3 +54,8 @@ SUBDIRS = \ x86_64-unknown-linux-gnu \ i686-pc-linux-gnu \ mips-unknown-linux-gnu + +EXTRA_DIST = \ + 32-bit-big-endian \ + 32-bit-little-endian \ + 64-bit-little-endian From 011669af3b428e5626f7bbf66b11d57d9768c047 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 17 Mar 2017 23:35:24 +0100 Subject: [PATCH 806/865] web: Remove export of nonexistent 'open-connection-for-uri'. * module/web/client.scm: Don't export 'open-connection-for-uri', which doesn't exist. --- module/web/client.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/module/web/client.scm b/module/web/client.scm index 042468c54..ab635c478 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -1,6 +1,6 @@ ;;; Web client -;; Copyright (C) 2011, 2012, 2013, 2014, 2015, 2016 Free Software Foundation, Inc. +;; Copyright (C) 2011, 2012, 2013, 2014, 2015, 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 @@ -47,7 +47,6 @@ #:prefix rnrs-ports:) #:export (current-http-proxy open-socket-for-uri - open-connection-for-uri http-get http-get* http-head From aa86fcb7d92857ddbd9c0cde40f3d730d4606d62 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 17 Mar 2017 23:37:57 +0100 Subject: [PATCH 807/865] web: Avoid deprecated '_IOFBF'. * module/web/client.scm (open-socket-for-uri): Use 'block instead of _IOFBF. --- module/web/client.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/web/client.scm b/module/web/client.scm index ab635c478..0c055abe9 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -218,7 +218,7 @@ host name without trailing dot." (with-https-proxy (let ((s (open-socket))) ;; Buffer input and output on this port. - (setvbuf s _IOFBF %http-receive-buffer-size) + (setvbuf s 'block %http-receive-buffer-size) (if https? (tls-wrap s (uri-host uri)) From 7e218d35ac96b6a9056aa06f983b3e254b0b9653 Mon Sep 17 00:00:00 2001 From: Mike Gran Date: Mon, 20 Mar 2017 07:29:47 -0700 Subject: [PATCH 808/865] i18n: rename locale-monetary-digit-grouping to locale-monetary-grouping * module/ice-9/i18n.scm (locale-monetary-digit-grouping): renamed to locale-monetary grouping (monetary-amount->locale-string): use renamed procedure * test-suite/tests/i18n.test (%french-locale): add LC_MONETARY (%french-utf8-locale): add LC_MONETARY ("nl-langinfo et al."): tests for locale-monetary-grouping --- module/ice-9/i18n.scm | 4 ++-- test-suite/tests/i18n.test | 27 ++++++++++++++++++++++++--- 2 files changed, 26 insertions(+), 5 deletions(-) diff --git a/module/ice-9/i18n.scm b/module/ice-9/i18n.scm index 969c0589b..162049c2d 100644 --- a/module/ice-9/i18n.scm +++ b/module/ice-9/i18n.scm @@ -212,7 +212,7 @@ MON_DECIMAL_POINT "") (define-simple-langinfo-mapping locale-monetary-thousands-separator MON_THOUSANDS_SEP "") -(define-simple-langinfo-mapping locale-monetary-digit-grouping +(define-simple-langinfo-mapping locale-monetary-grouping MON_GROUPING '()) (define-monetary-langinfo-mapping locale-currency-symbol-precedes-positive? @@ -387,7 +387,7 @@ locale is used." (dec (decimal-part (number-decimal-string (abs amount) fraction-digits))) - (grouping (locale-monetary-digit-grouping locale)) + (grouping (locale-monetary-grouping locale)) (separator (locale-monetary-thousands-separator locale))) (add-monetary-sign+currency amount diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index b48f20fac..e7447ebd2 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -117,12 +117,12 @@ (define %french-locale (false-if-exception - (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME) + (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME LC_MONETARY) %french-locale-name))) (define %french-utf8-locale (false-if-exception - (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME) + (make-locale (list LC_CTYPE LC_COLLATE LC_NUMERIC LC_TIME LC_MONETARY) %french-utf8-locale-name))) (define %german-utf8-locale @@ -482,7 +482,28 @@ (and (string? result) (string-ci=? result "Tuesday")))) (lambda () - (setlocale LC_ALL "C"))))))) + (setlocale LC_ALL "C")))))) + + (pass-if "locale-monetary-grouping" + ;; In the C locale, there is no rule for grouping of digits + ;; of monetary values. + (null? (locale-monetary-grouping))) + + (pass-if "locale-monetary-grouping (French)" + (under-french-utf8-locale-or-unresolved + (lambda () + ;; All systems that have a MON_GROUPING nl_item should know + ;; that French monetary values are grouped in 3 digit chunks. + ;; Those systems that have no MON_GROUPING nl_item may use the + ;; hard-coded default of no grouping. + (let ((result (locale-monetary-grouping %french-utf8-locale))) + (cond + ((null? result) + (throw 'unresolved)) + ((eqv? 3 (false-if-exception (car result))) + #t) + (else + #f))))))) ;;; From 7c7cc11810f26e8f08dab8f57120881e5dac961e Mon Sep 17 00:00:00 2001 From: Mike Gran Date: Mon, 20 Mar 2017 07:37:32 -0700 Subject: [PATCH 809/865] i18n: add tests for locale AM/PM * test-suite/tests/i18n.test ("nl-langinfo et al."): new tests --- test-suite/tests/i18n.test | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index e7447ebd2..4be2ec518 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -484,6 +484,26 @@ (lambda () (setlocale LC_ALL "C")))))) + (pass-if "locale-am-string" + (not (not (member (locale-am-string) + '("AM" "am" "A.M." "a.m."))))) + + (pass-if "locale-am-string (greek)" + (under-greek-utf8-locale-or-unresolved + (lambda () + (not (not (member (locale-am-string %greek-utf8-locale) + '("ΠΜ" "πμ" "Π.Μ." "π.μ."))))))) + + (pass-if "locale-pm-string" + (not (not (member (locale-pm-string) + '("PM" "pm" "P.M." "p.m."))))) + + (pass-if "locale-pm-string (Greek)" + (under-greek-utf8-locale-or-unresolved + (lambda () + (not (not (member (locale-pm-string %greek-utf8-locale) + '("ΜΜ" "μμ" "Μ.Μ." "μ.μ."))))))) + (pass-if "locale-monetary-grouping" ;; In the C locale, there is no rule for grouping of digits ;; of monetary values. From 726804874f1d502d04c258d8203b1d8edfc832a0 Mon Sep 17 00:00:00 2001 From: Mike Gran Date: Mon, 20 Mar 2017 07:38:12 -0700 Subject: [PATCH 810/865] i18n: add tests for locale-digit-grouping * test-suite/tests/i18n.test ("nl-langinfo et al."): new tests --- test-suite/tests/i18n.test | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index 4be2ec518..478a0c3c7 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -504,6 +504,26 @@ (not (not (member (locale-pm-string %greek-utf8-locale) '("ΜΜ" "μμ" "Μ.Μ." "μ.μ."))))))) + (pass-if "locale-digit-grouping" + ;; In the C locale, there is no rule for grouping. + (null? (locale-digit-grouping))) + + (pass-if "locale-digit-grouping (French)" + (under-french-locale-or-unresolved + (lambda () + ;; All systems that have a GROUPING nl_item should know + ;; that French numbers are grouped in 3 digit chunks. + ;; Those systems that have no GROUPING nl_item may use + ;; the hard-coded default of no grouping. + (let ((result (locale-digit-grouping %french-locale))) + (cond + ((null? result) + (throw 'unresolved)) + ((eqv? 3 (false-if-exception (car result))) + #t) + (else + #f)))))) + (pass-if "locale-monetary-grouping" ;; In the C locale, there is no rule for grouping of digits ;; of monetary values. From c81868425280fd3e4a6718aa9d1aa71eeae57dbb Mon Sep 17 00:00:00 2001 From: Mike Gran Date: Mon, 20 Mar 2017 20:20:29 -0700 Subject: [PATCH 811/865] i18n: add debugging helper procedure for locales * module/ice-9/i18n.scm (%locale-dump): new procedure --- module/ice-9/i18n.scm | 68 ++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 67 insertions(+), 1 deletion(-) diff --git a/module/ice-9/i18n.scm b/module/ice-9/i18n.scm index 162049c2d..f77fa6950 100644 --- a/module/ice-9/i18n.scm +++ b/module/ice-9/i18n.scm @@ -81,7 +81,10 @@ number->locale-string ;; miscellaneous - locale-yes-regexp locale-no-regexp)) + locale-yes-regexp locale-no-regexp + + ;; debugging + %locale-dump)) (eval-when (expand load eval) @@ -458,4 +461,67 @@ number of fractional digits to be displayed." ;; `YESSTR' and `NOSTR' are considered deprecated so we don't provide them. + +;;; +;;; Debugging +;;; + +(define (%locale-dump loc) + "Given a locale, display an association list containing all the locale +information. + +This procedure is intended for debugging locale problems, and should +not be used in production code." + (when (locale? loc) + (list + (cons 'encoding (locale-encoding loc)) + (cons 'day-short + (map (lambda (n) (locale-day-short (1+ n) loc)) (iota 7))) + (cons 'day + (map (lambda (n) (locale-day (1+ n) loc)) (iota 7))) + (cons 'month-short + (map (lambda (n) (locale-month-short (1+ n) loc)) (iota 12))) + (cons 'month + (map (lambda (n) (locale-month (1+ n) loc)) (iota 12))) + (cons 'am-string (locale-am-string loc)) + (cons 'pm-string (locale-pm-string loc)) + (cons 'date+time-format (locale-date+time-format loc)) + (cons 'date-format (locale-date-format loc)) + (cons 'time-format (locale-time-format loc)) + (cons 'time+am/pm-format (locale-time+am/pm-format loc)) + (cons 'era (locale-era loc)) + (cons 'era-year (locale-era-year loc)) + (cons 'era-date-format (locale-era-date-format loc)) + (cons 'era-date+time-format (locale-era-date+time-format loc)) + (cons 'era-time-format (locale-era-time-format loc)) + (cons 'currency-symbol + (list (locale-currency-symbol #t loc) + (locale-currency-symbol #f loc))) + (cons 'monetary-decimal-point (locale-monetary-decimal-point loc)) + (cons 'monetary-thousands-separator (locale-monetary-thousands-separator loc)) + (cons 'monetary-grouping (locale-monetary-grouping loc)) + (cons 'monetary-fractional-digits + (list (locale-monetary-fractional-digits #t loc) + (locale-monetary-fractional-digits #f loc))) + (cons 'currency-symbol-precedes-positive? + (list (locale-currency-symbol-precedes-positive? #t loc) + (locale-currency-symbol-precedes-positive? #f loc))) + (cons 'currency-symbol-precedes-negative? + (list (locale-currency-symbol-precedes-negative? #t loc) + (locale-currency-symbol-precedes-negative? #f loc))) + (cons 'positive-separated-by-space? + (list (locale-positive-separated-by-space? #t loc) + (locale-positive-separated-by-space? #f loc))) + (cons 'negative-separated-by-space? + (list (locale-negative-separated-by-space? #t loc) + (locale-negative-separated-by-space? #f loc))) + (cons 'monetary-positive-sign (locale-monetary-positive-sign loc)) + (cons 'monetary-negative-sign (locale-monetary-negative-sign loc)) + (cons 'positive-sign-position (locale-positive-sign-position loc)) + (cons 'negative-sign-position (locale-negative-sign-position loc)) + (cons 'digit-grouping (locale-digit-grouping loc)) + (cons 'decimal-point (locale-decimal-point loc)) + (cons 'thousands-separator (locale-thousands-separator loc)) + (cons 'locale-yes-regexp (locale-yes-regexp loc)) + (cons 'no-regexp (locale-no-regexp loc))))) ;;; i18n.scm ends here From dc9d1474aa03e73a093f3c9447006549d6576c2f Mon Sep 17 00:00:00 2001 From: Mike Gran Date: Mon, 20 Mar 2017 20:29:21 -0700 Subject: [PATCH 812/865] i18n: locale-positive-separated-by-space? should return bool, not string * libguile/i18n.c (scm_nl_langinfo): unpack INT_P_SEP_BY_SPACE as bool * test-suite/tests/i18n.test (nl-langinfo et al.): new tests --- libguile/i18n.c | 13 +++++++++---- test-suite/tests/i18n.test | 12 ++++++++++++ 2 files changed, 21 insertions(+), 4 deletions(-) diff --git a/libguile/i18n.c b/libguile/i18n.c index 6f75966a1..47179d178 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2006-2014 Free Software Foundation, Inc. +/* Copyright (C) 2006-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 License @@ -1567,7 +1567,8 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, #if defined P_CS_PRECEDES || defined N_CS_PRECEDES || \ defined INT_P_CS_PRECEDES || defined INT_N_CS_PRECEDES || \ - defined P_SEP_BY_SPACE || defined N_SEP_BY_SPACE + defined P_SEP_BY_SPACE || defined N_SEP_BY_SPACE || \ + defined INT_P_SEP_BY_SPACE || defined INT_N_SEP_BY_SPACE #ifdef P_CS_PRECEDES case P_CS_PRECEDES: case N_CS_PRECEDES: @@ -1580,8 +1581,12 @@ SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0, case P_SEP_BY_SPACE: case N_SEP_BY_SPACE: #endif - /* This is to be interpreted as a boolean. */ - result = scm_from_bool (*c_result); +#ifdef INT_P_SEP_BY_SPACE + case INT_P_SEP_BY_SPACE: + case INT_N_SEP_BY_SPACE: +#endif + /* This is to be interpreted as a boolean. */ + result = scm_from_bool (*c_result); free (c_result); break; diff --git a/test-suite/tests/i18n.test b/test-suite/tests/i18n.test index 478a0c3c7..a20651120 100644 --- a/test-suite/tests/i18n.test +++ b/test-suite/tests/i18n.test @@ -524,6 +524,18 @@ (else #f)))))) + (pass-if "locale-positive-separated-by-space?" + ;; In any locale, this must be a boolean. + (let ((result (locale-positive-separated-by-space? #f))) + (or (eqv? #t result) + (eqv? #f result)))) + + (pass-if "locale-positive-separated-by-space? (international)" + ;; In any locale, this must be a boolean. + (let ((result (locale-positive-separated-by-space? #t))) + (or (eqv? #t result) + (eqv? #f result)))) + (pass-if "locale-monetary-grouping" ;; In the C locale, there is no rule for grouping of digits ;; of monetary values. From 5d2aa5f1adacf4ee605a536d7bca06bd1d0d48fb Mon Sep 17 00:00:00 2001 From: Mike Gran Date: Mon, 20 Mar 2017 22:35:49 -0700 Subject: [PATCH 813/865] i18n: add international sign positions to %locale-dump * module/ice-9/i18n.scm (%locale-dump): modified --- module/ice-9/i18n.scm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/module/ice-9/i18n.scm b/module/ice-9/i18n.scm index f77fa6950..6b9ead532 100644 --- a/module/ice-9/i18n.scm +++ b/module/ice-9/i18n.scm @@ -517,8 +517,12 @@ not be used in production code." (locale-negative-separated-by-space? #f loc))) (cons 'monetary-positive-sign (locale-monetary-positive-sign loc)) (cons 'monetary-negative-sign (locale-monetary-negative-sign loc)) - (cons 'positive-sign-position (locale-positive-sign-position loc)) - (cons 'negative-sign-position (locale-negative-sign-position loc)) + (cons 'positive-sign-position + (list (locale-positive-sign-position #t loc) + (locale-negative-sign-position #f loc))) + (cons 'negative-sign-position + (list (locale-negative-sign-position #t loc) + (locale-negative-sign-position #f loc))) (cons 'digit-grouping (locale-digit-grouping loc)) (cons 'decimal-point (locale-decimal-point loc)) (cons 'thousands-separator (locale-thousands-separator loc)) From bcfc3f2e090038c3f3bb835370ce28693ddd07b1 Mon Sep 17 00:00:00 2001 From: Mike Gran Date: Thu, 23 Mar 2017 07:38:09 -0700 Subject: [PATCH 814/865] Git ignore .exe files * .gitignore: add *.exe --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index fb9e53b1f..36f897261 100644 --- a/.gitignore +++ b/.gitignore @@ -16,6 +16,7 @@ config.h *.x *.lo *.la +*.exe aclocal.m4 libtool ltmain.sh From 6ba3f35f261293492206892c40b4cd7d29e372f8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Mar 2017 11:00:48 +0100 Subject: [PATCH 815/865] Plumbing changes to rename "syntax-module" * module/ice-9/psyntax.scm (%syntax-module): Rename from syntax-module in order to make room for a new syntax-module primitive binding. * module/ice-9/psyntax-pp.scm: Regenerate. * module/ice-9/boot-9.scm: Push syntax bindings into an internal module. * module/system/syntax.scm: New file. * module/Makefile.am (SOURCES): Add system/syntax.scm. --- module/Makefile.am | 2 ++ module/ice-9/boot-9.scm | 6 +++--- module/ice-9/psyntax-pp.scm | 4 ++-- module/ice-9/psyntax.scm | 4 ++-- module/system/syntax.scm | 26 ++++++++++++++++++++++++++ 5 files changed, 35 insertions(+), 7 deletions(-) create mode 100644 module/system/syntax.scm diff --git a/module/Makefile.am b/module/Makefile.am index 67f041d20..ef7c20827 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -336,6 +336,8 @@ SOURCES = \ system/vm/traps.scm \ system/vm/vm.scm \ \ + system/syntax.scm \ + \ system/xref.scm \ \ sxml/apply-templates.scm \ diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 27776725b..07d357dde 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -4074,7 +4074,7 @@ when none is available, reading FILE-NAME with READER." ;;; modules, removing them from the (guile) module. ;;; -(define-module (system syntax)) +(define-module (system syntax internal)) (let () (define (steal-bindings! from to ids) @@ -4086,9 +4086,9 @@ when none is available, reading FILE-NAME with READER." ids) (module-export! to ids)) - (steal-bindings! the-root-module (resolve-module '(system syntax)) + (steal-bindings! the-root-module (resolve-module '(system syntax internal)) '(syntax-local-binding - syntax-module + %syntax-module syntax-locally-bound-identifiers syntax-session-id))) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index e410f9f58..7749e3cd6 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -2440,7 +2440,7 @@ (strip form '(())) (and subform (strip subform '(())))))) (letrec* - ((syntax-module + ((%syntax-module (lambda (id) (let ((x id)) (if (not (nonsymbol-id? x)) @@ -2502,7 +2502,7 @@ (locally-bound-identifiers (syntax-object-wrap id) (syntax-object-module id))))) - (define! 'syntax-module syntax-module) + (define! '%syntax-module %syntax-module) (define! 'syntax-local-binding syntax-local-binding) (define! 'syntax-locally-bound-identifiers diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 74a008eeb..567f6065b 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -2746,7 +2746,7 @@ (and subform (strip subform empty-wrap))))) (let () - (define (syntax-module id) + (define (%syntax-module id) (arg-check nonsymbol-id? id 'syntax-module) (let ((mod (syntax-object-module id))) (and (not (equal? mod '(primitive))) @@ -2797,7 +2797,7 @@ ;; compile-time, after the variables are stolen away into (system ;; syntax). See the end of boot-9.scm. ;; - (define! 'syntax-module syntax-module) + (define! '%syntax-module %syntax-module) (define! 'syntax-local-binding syntax-local-binding) (define! 'syntax-locally-bound-identifiers syntax-locally-bound-identifiers)) diff --git a/module/system/syntax.scm b/module/system/syntax.scm new file mode 100644 index 000000000..9d6bc571f --- /dev/null +++ b/module/system/syntax.scm @@ -0,0 +1,26 @@ +;;; Syntax utilities + +;;; Copyright (C) 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Code: + +(define-module (system syntax) + #:use-module (system syntax internal) + #:re-export (syntax-local-binding + (%syntax-module . syntax-module) + syntax-locally-bound-identifiers + syntax-session-id)) From 64c5cc58fced3092f17639bbbddb46c1bae974c8 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 24 Mar 2017 11:17:26 +0100 Subject: [PATCH 816/865] Add disjoint syntax object type * libguile/Makefile.am (libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES): (DOT_X_FILES, DOT_DOC_FILES, noinst_HEADERS): Add syntax.c and syntax.h. * libguile/evalext.c (scm_self_evaluating_p): * libguile/goops.c (class_syntax, scm_class_of, scm_goops_early_init): * libguile/init.c (scm_init_guile): * libguile/print.c (iprin1): * libguile/tags.h (scm_tc7_syntax): * module/oop/goops.scm (): * module/system/base/types.scm (%tc7-syntax, cell->object): * module/system/vm/disassembler.scm (code-annotation): Wire up the new data type. * libguile/syntax.c: * libguile/syntax.h: New files. * module/ice-9/boot-9.scm: Move new definitions to (system syntax internal). * module/system/syntax.scm (print-syntax): New helper. * module/system/vm/assembler.scm (statically-allocatable?) (intern-constant, link-data): Arrange to be able to write syntax objects into images. * module/language/cps/types.scm (&syntax): New type. Remove &hash-table; it was never detected, an internal binding, and we need the bit to avoid going into bignum territory. --- libguile/Makefile.am | 4 + libguile/evalext.c | 1 + libguile/goops.c | 4 + libguile/init.c | 2 + libguile/print.c | 4 + libguile/syntax.c | 120 ++++++++++++++++++++++++++++++ libguile/syntax.h | 34 +++++++++ libguile/tags.h | 2 +- module/ice-9/boot-9.scm | 9 ++- module/language/cps/types.scm | 6 +- module/oop/goops.scm | 3 +- module/system/base/types.scm | 6 ++ module/system/syntax.scm | 9 ++- module/system/vm/assembler.scm | 24 +++++- module/system/vm/disassembler.scm | 1 + 15 files changed, 221 insertions(+), 8 deletions(-) create mode 100644 libguile/syntax.c create mode 100644 libguile/syntax.h diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 142e739fb..2214a4aa3 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -212,6 +212,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ strports.c \ struct.c \ symbols.c \ + syntax.c \ threads.c \ throw.c \ trees.c \ @@ -316,6 +317,7 @@ DOT_X_FILES = \ strports.x \ struct.x \ symbols.x \ + syntax.x \ threads.x \ throw.x \ trees.x \ @@ -418,6 +420,7 @@ DOT_DOC_FILES = \ strports.doc \ struct.doc \ symbols.doc \ + syntax.doc \ threads.doc \ throw.doc \ trees.doc \ @@ -509,6 +512,7 @@ noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \ posix-w32.h \ private-options.h \ ports-internal.h \ + syntax.h \ weak-list.h # vm instructions diff --git a/libguile/evalext.c b/libguile/evalext.c index 48d9a1718..33205a2ca 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -82,6 +82,7 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0, case scm_tc7_dynamic_state: case scm_tc7_frame: case scm_tc7_keyword: + case scm_tc7_syntax: case scm_tc7_vm_cont: case scm_tc7_number: case scm_tc7_string: diff --git a/libguile/goops.c b/libguile/goops.c index 8ed0f60ea..a158a1cab 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -110,6 +110,7 @@ static SCM class_applicable_struct_class; static SCM class_applicable_struct_with_setter_class; static SCM class_number, class_list; static SCM class_keyword; +static SCM class_syntax; static SCM class_atomic_box; static SCM class_port, class_input_output_port; static SCM class_input_port, class_output_port; @@ -227,6 +228,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, return class_frame; case scm_tc7_keyword: return class_keyword; + case scm_tc7_syntax: + return class_syntax; case scm_tc7_atomic_box: return class_atomic_box; case scm_tc7_vm_cont: @@ -1002,6 +1005,7 @@ SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0, class_dynamic_state = scm_variable_ref (scm_c_lookup ("")); class_frame = scm_variable_ref (scm_c_lookup ("")); class_keyword = scm_variable_ref (scm_c_lookup ("")); + class_syntax = scm_variable_ref (scm_c_lookup ("")); class_atomic_box = scm_variable_ref (scm_c_lookup ("")); class_vm_cont = scm_variable_ref (scm_c_lookup ("")); class_bytevector = scm_variable_ref (scm_c_lookup ("")); diff --git a/libguile/init.c b/libguile/init.c index 1a6f599fa..b046685d4 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -124,6 +124,7 @@ #include "libguile/strports.h" #include "libguile/struct.h" #include "libguile/symbols.h" +#include "libguile/syntax.h" #include "libguile/throw.h" #include "libguile/arrays.h" #include "libguile/trees.h" @@ -507,6 +508,7 @@ scm_i_init_guile (void *base) scm_init_evalext (); scm_init_debug (); /* Requires macro smobs */ scm_init_simpos (); + scm_init_syntax (); #if HAVE_MODULES scm_init_dynamic_linking (); /* Requires smob_prehistory */ #endif diff --git a/libguile/print.c b/libguile/print.c index 9669dcf06..7667d24bb 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -46,6 +46,7 @@ #include "libguile/ports-internal.h" #include "libguile/strings.h" #include "libguile/strports.h" +#include "libguile/syntax.h" #include "libguile/vectors.h" #include "libguile/numbers.h" #include "libguile/vm.h" @@ -716,6 +717,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) scm_puts ("#:", port); scm_iprin1 (scm_keyword_to_symbol (exp), port, pstate); break; + case scm_tc7_syntax: + scm_i_syntax_print (exp, port, pstate); + break; case scm_tc7_atomic_box: scm_i_atomic_box_print (exp, port, pstate); break; diff --git a/libguile/syntax.c b/libguile/syntax.c new file mode 100644 index 000000000..df12c69c4 --- /dev/null +++ b/libguile/syntax.c @@ -0,0 +1,120 @@ +/* Copyright (C) 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 License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + + + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include "libguile/_scm.h" +#include "libguile/keywords.h" +#include "libguile/ports.h" +#include "libguile/syntax.h" +#include "libguile/validate.h" + + + +static int +scm_is_syntax (SCM x) +{ + return SCM_HAS_TYP7 (x, scm_tc7_syntax); +} + +#define SCM_VALIDATE_SYNTAX(pos, scm) \ + SCM_I_MAKE_VALIDATE_MSG2 (pos, scm, scm_is_syntax, "syntax object") + +SCM_DEFINE (scm_syntax_p, "syntax?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if the argument @var{obj} is a syntax object,\n" + "else @code{#f}.") +#define FUNC_NAME s_scm_syntax_p +{ + return scm_from_bool (scm_is_syntax (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_make_syntax, "make-syntax", 3, 0, 0, + (SCM exp, SCM wrap, SCM module), + "Make a new syntax object.") +#define FUNC_NAME s_scm_make_syntax +{ + return scm_double_cell (scm_tc7_syntax, SCM_UNPACK (exp), + SCM_UNPACK (wrap), SCM_UNPACK (module)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_syntax_expression, "syntax-expression", 1, 0, 0, + (SCM obj), + "Return the expression contained in the syntax object @var{obj}.") +#define FUNC_NAME s_scm_syntax_expression +{ + SCM_VALIDATE_SYNTAX (1, obj); + return SCM_CELL_OBJECT_1 (obj); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_syntax_wrap, "syntax-wrap", 1, 0, 0, + (SCM obj), + "Return the wrap contained in the syntax object @var{obj}.") +#define FUNC_NAME s_scm_syntax_wrap +{ + SCM_VALIDATE_SYNTAX (1, obj); + return SCM_CELL_OBJECT_2 (obj); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_syntax_module, "syntax-module", 1, 0, 0, + (SCM obj), + "Return the module info contained in the syntax object @var{obj}.") +#define FUNC_NAME s_scm_syntax_module +{ + SCM_VALIDATE_SYNTAX (1, obj); + return SCM_CELL_OBJECT_3 (obj); +} +#undef FUNC_NAME + +static SCM print_syntax_var; + +static void +init_print_syntax_var (void) +{ + print_syntax_var = + scm_c_private_variable ("system syntax", "print-syntax"); +} + +void +scm_i_syntax_print (SCM obj, SCM port, scm_print_state *pstate) +{ + static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; + scm_i_pthread_once (&once, init_print_syntax_var); + scm_call_2 (scm_variable_ref (print_syntax_var), obj, port); +} + +void +scm_init_syntax () +{ +#include "libguile/syntax.x" +} + + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/syntax.h b/libguile/syntax.h new file mode 100644 index 000000000..7fdfd2891 --- /dev/null +++ b/libguile/syntax.h @@ -0,0 +1,34 @@ +#ifndef SCM_SYNTAX_H +#define SCM_SYNTAX_H + +/* Copyright (C) 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 License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA + */ + +#include "libguile/__scm.h" + +SCM_INTERNAL SCM scm_syntax_p (SCM obj); +SCM_INTERNAL SCM scm_make_syntax (SCM exp, SCM wrap, SCM module); +SCM_INTERNAL SCM scm_syntax_expression (SCM obj); +SCM_INTERNAL SCM scm_syntax_wrap (SCM obj); +SCM_INTERNAL SCM scm_syntax_module (SCM obj); + +SCM_INTERNAL void scm_i_syntax_print (SCM obj, SCM port, + scm_print_state *pstate); +SCM_INTERNAL void scm_init_syntax (void); + +#endif /* SCM_SYNTAX_H */ diff --git a/libguile/tags.h b/libguile/tags.h index 8f44d96b2..3a01a1587 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -416,7 +416,7 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM; #define scm_tc7_frame 0x2f #define scm_tc7_keyword 0x35 #define scm_tc7_atomic_box 0x37 -#define scm_tc7_unused_3d 0x3d +#define scm_tc7_syntax 0x3d #define scm_tc7_unused_3f 0x3f #define scm_tc7_program 0x45 #define scm_tc7_vm_cont 0x47 diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 07d357dde..be890fa45 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -4087,10 +4087,15 @@ when none is available, reading FILE-NAME with READER." (module-export! to ids)) (steal-bindings! the-root-module (resolve-module '(system syntax internal)) - '(syntax-local-binding + '(syntax? + syntax-local-binding %syntax-module syntax-locally-bound-identifiers - syntax-session-id))) + syntax-session-id + make-syntax + syntax-expression + syntax-wrap + syntax-module))) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index fd592eadc..8464a6502 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -84,6 +84,7 @@ #:use-module (language cps intset) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-11) + #:use-module ((system syntax internal) #:select (syntax?)) #:export (;; Specific types. &exact-integer &flonum @@ -112,7 +113,7 @@ &bytevector &bitvector &array - &hash-table + &syntax ;; Union types. &number &real @@ -169,7 +170,7 @@ &bytevector &bitvector &array - &hash-table + &syntax &f64 &u64 @@ -348,6 +349,7 @@ minimum, and maximum." ((bytevector? val) (return &bytevector (bytevector-length val))) ((bitvector? val) (return &bitvector (bitvector-length val))) ((array? val) (return &array (array-rank val))) + ((syntax? val) (return &syntax 0)) ((not (variable-bound? (make-variable val))) (return &unbound #f)) (else (error "unhandled constant" val)))) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index b7d980dce..a46918062 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -62,7 +62,7 @@ - + ;; Numbers. @@ -1009,6 +1009,7 @@ slots as we go." (define-standard-class ()) (define-standard-class ()) (define-standard-class ()) +(define-standard-class ()) (define-standard-class ()) (define-standard-class ()) (define-standard-class () diff --git a/module/system/base/types.scm b/module/system/base/types.scm index 652c9223f..53a3dbe93 100644 --- a/module/system/base/types.scm +++ b/module/system/base/types.scm @@ -23,6 +23,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-60) + #:use-module (system syntax internal) #:use-module (ice-9 match) #:use-module (ice-9 iconv) #:use-module (ice-9 format) @@ -254,6 +255,7 @@ the matching bits, possibly with bitwise operations to extract it from BITS." (define %tc7-dynamic-state #x2d) (define %tc7-frame #x2f) (define %tc7-keyword #x35) +(define %tc7-syntax #x3d) (define %tc7-program #x45) (define %tc7-vm-continuation #x47) (define %tc7-bytevector #x4d) @@ -464,6 +466,10 @@ using BACKEND." (make-pointer address)) (((_ & #x7f = %tc7-keyword) symbol) (symbol->keyword (cell->object symbol backend))) + (((_ & #x7f = %tc7-syntax) expression wrap module) + (make-syntax (cell->object expression backend) + (cell->object wrap backend) + (cell->object module backend))) (((_ & #x7f = %tc7-vm-continuation)) (inferior-object 'vm-continuation address)) (((_ & #x7f = %tc7-weak-set)) diff --git a/module/system/syntax.scm b/module/system/syntax.scm index 9d6bc571f..34fadb39f 100644 --- a/module/system/syntax.scm +++ b/module/system/syntax.scm @@ -20,7 +20,14 @@ (define-module (system syntax) #:use-module (system syntax internal) - #:re-export (syntax-local-binding + #:re-export (syntax? + syntax-local-binding (%syntax-module . syntax-module) syntax-locally-bound-identifiers syntax-session-id)) + +;; Used by syntax.c. +(define (print-syntax obj port) + ;; FIXME: Use syntax->datum instad of syntax-expression, when + ;; syntax->datum can operate on new syntax objects. + (format port "#" (syntax-expression obj))) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 9ac3fa62a..56c33be81 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -47,6 +47,7 @@ #:use-module (system vm dwarf) #:use-module (system vm elf) #:use-module (system vm linker) + #:use-module (system syntax internal) #:use-module (language bytecode) #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) @@ -1017,7 +1018,8 @@ immediate, and @code{#f} otherwise." "Return @code{#t} if a non-immediate constant can be allocated statically, and @code{#f} if it would need some kind of runtime allocation." - (or (pair? x) (string? x) (stringbuf? x) (static-procedure? x) (array? x))) + (or (pair? x) (string? x) (stringbuf? x) (static-procedure? x) + (array? x) (syntax? x))) (define (intern-constant asm obj) "Add an object to the constant table, and return a label that can be @@ -1045,6 +1047,10 @@ table, its existing label is used directly." (append-reverse (field label (1+ i) (vector-ref obj i)) inits)) (reverse inits)))) + ((syntax? obj) + (append (field label 1 (syntax-expression obj)) + (field label 2 (syntax-wrap obj)) + (field label 3 (syntax-module obj)))) ((stringbuf? obj) '()) ((static-procedure? obj) `((static-patch! ,label 1 ,(static-procedure-code obj)))) @@ -1181,6 +1187,7 @@ returned instead." ;(define-tc7-macro-assembler br-if-dynamic-state 45) ;(define-tc7-macro-assembler br-if-frame 47) (define-tc7-macro-assembler br-if-keyword #x35) +;(define-tc7-macro-assembler br-if-syntax #x3d) ;(define-tc7-macro-assembler br-if-vm 55) ;(define-tc7-macro-assembler br-if-vm-cont 71) ;(define-tc7-macro-assembler br-if-rtl-program 69) @@ -1391,6 +1398,7 @@ should be .data or .rodata), and return the resulting linker object. (define tc7-narrow-stringbuf tc7-stringbuf) (define tc7-wide-stringbuf (+ tc7-stringbuf stringbuf-wide-flag)) (define tc7-ro-string (+ 21 #x200)) + (define tc7-syntax #x3d) (define tc7-program 69) (define tc7-bytevector 77) (define tc7-bitvector 95) @@ -1415,6 +1423,8 @@ should be .data or .rodata), and return the resulting linker object. (* 2 word-size)) ((simple-vector? x) (* (1+ (vector-length x)) word-size)) + ((syntax? x) + (* 4 word-size)) ((simple-uniform-vector? x) (* 4 word-size)) ((uniform-vector-backing-store? x) @@ -1519,6 +1529,18 @@ should be .data or .rodata), and return the resulting linker object. ((keyword? obj) (write-placeholder asm buf pos)) + ((syntax? obj) + (case word-size + ((4) (bytevector-u32-set! buf pos tc7-syntax endianness)) + ((8) (bytevector-u64-set! buf pos tc7-syntax endianness)) + (else (error "bad word size"))) + (write-constant-reference buf (+ pos (* 1 word-size)) + (syntax-expression obj)) + (write-constant-reference buf (+ pos (* 2 word-size)) + (syntax-wrap obj)) + (write-constant-reference buf (+ pos (* 3 word-size)) + (syntax-module obj))) + ((number? obj) (write-placeholder asm buf pos)) diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm index b6f4f7804..4db4a033d 100644 --- a/module/system/vm/disassembler.scm +++ b/module/system/vm/disassembler.scm @@ -210,6 +210,7 @@ address of that offset." ((13) "vector?") ((15) "string?") ((53) "keyword?") + ((#x3d) "syntax?") ((77) "bytevector?") ((95) "bitvector?") (else (number->string tc7))))) From eb84c2f2da83cf04214bbacf4b33528ce09a5b1a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 27 Mar 2017 20:38:55 +0200 Subject: [PATCH 817/865] Beginnings of psyntax switch to new syntax objects * module/ice-9/psyntax.scm: Baby steps towards support of a new representation of syntax objects. * module/ice-9/psyntax-pp.scm: Regenerate. --- module/ice-9/psyntax-pp.scm | 5262 ++++++++++++++++++----------------- module/ice-9/psyntax.scm | 27 +- 2 files changed, 2659 insertions(+), 2630 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 7749e3cd6..a26545aa6 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -1,2639 +1,2647 @@ (eval-when (compile) (set-current-module (resolve-module (quote (guile))))) (if #f #f) -(letrec* - ((make-void - (lambda (src) (make-struct (vector-ref %expanded-vtables 0) 0 src))) - (make-const - (lambda (src exp) - (make-struct (vector-ref %expanded-vtables 1) 0 src exp))) - (make-primitive-ref - (lambda (src name) - (make-struct (vector-ref %expanded-vtables 2) 0 src name))) - (make-lexical-ref - (lambda (src name gensym) - (make-struct (vector-ref %expanded-vtables 3) 0 src name gensym))) - (make-lexical-set - (lambda (src name gensym exp) - (make-struct (vector-ref %expanded-vtables 4) 0 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-module-set - (lambda (src mod name public? exp) - (make-struct - (vector-ref %expanded-vtables 6) - 0 - src - mod - name - public? - exp))) - (make-toplevel-ref - (lambda (src name) - (make-struct (vector-ref %expanded-vtables 7) 0 src name))) - (make-toplevel-set - (lambda (src name exp) - (make-struct (vector-ref %expanded-vtables 8) 0 src name exp))) - (make-toplevel-define - (lambda (src name exp) - (make-struct (vector-ref %expanded-vtables 9) 0 src name exp))) - (make-conditional - (lambda (src test consequent alternate) - (make-struct - (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-primcall - (lambda (src name args) - (make-struct (vector-ref %expanded-vtables 12) 0 src name args))) - (make-seq - (lambda (src head tail) - (make-struct (vector-ref %expanded-vtables 13) 0 src head tail))) - (make-lambda - (lambda (src meta body) - (make-struct (vector-ref %expanded-vtables 14) 0 src meta body))) - (make-lambda-case - (lambda (src req opt rest kw inits gensyms body alternate) - (make-struct - (vector-ref %expanded-vtables 15) - 0 - src - req - opt - rest - kw - inits - gensyms - body - alternate))) - (make-let - (lambda (src names gensyms vals body) - (make-struct - (vector-ref %expanded-vtables 16) - 0 - src - names - gensyms - vals - body))) - (make-letrec - (lambda (src in-order? names gensyms vals body) - (make-struct - (vector-ref %expanded-vtables 17) - 0 - src - in-order? - names - gensyms - vals - body))) - (lambda? - (lambda (x) - (and (struct? x) - (eq? (struct-vtable x) (vector-ref %expanded-vtables 14))))) - (lambda-meta (lambda (x) (struct-ref x 1))) - (set-lambda-meta! (lambda (x v) (struct-set! x 1 v))) - (top-level-eval-hook (lambda (x mod) (primitive-eval x))) - (local-eval-hook (lambda (x mod) (primitive-eval x))) - (session-id - (let ((v (module-variable (current-module) 'syntax-session-id))) - (lambda () ((variable-ref v))))) - (put-global-definition-hook - (lambda (symbol type val) - (module-define! - (current-module) - symbol - (make-syntax-transformer symbol type val)))) - (get-global-definition-hook - (lambda (symbol module) - (if (and (not module) (current-module)) - (warn "module system is booted, we should have a module" symbol)) - (and (not (equal? module '(primitive))) - (let ((v (module-variable - (if module (resolve-module (cdr module)) (current-module)) - symbol))) - (and v - (variable-bound? v) - (let ((val (variable-ref v))) - (and (macro? val) - (macro-type val) - (cons (macro-type val) (macro-binding val))))))))) - (decorate-source - (lambda (e s) - (if (and s (supports-source-properties? e)) - (set-source-properties! e s)) - e)) - (maybe-name-value! - (lambda (name val) - (if (lambda? val) - (let ((meta (lambda-meta val))) - (if (not (assq 'name meta)) - (set-lambda-meta! val (acons 'name name meta))))))) - (build-void (lambda (source) (make-void source))) - (build-call - (lambda (source fun-exp arg-exps) - (make-call source fun-exp arg-exps))) - (build-conditional - (lambda (source test-exp then-exp else-exp) - (make-conditional source test-exp then-exp else-exp))) - (build-lexical-reference - (lambda (type source name var) (make-lexical-ref source name var))) - (build-lexical-assignment - (lambda (source name var exp) - (maybe-name-value! name exp) - (make-lexical-set source name var exp))) - (analyze-variable - (lambda (mod var modref-cont bare-cont) - (if (not mod) - (bare-cont var) - (let ((kind (car mod)) (mod (cdr mod))) - (let ((key kind)) - (cond ((memv key '(public)) (modref-cont mod var #t)) - ((memv key '(private)) - (if (not (equal? mod (module-name (current-module)))) - (modref-cont mod var #f) - (bare-cont var))) - ((memv key '(bare)) (bare-cont var)) - ((memv key '(hygiene)) - (if (and (not (equal? mod (module-name (current-module)))) - (module-variable (resolve-module mod) var)) - (modref-cont mod var #f) - (bare-cont var))) - ((memv key '(primitive)) - (syntax-violation #f "primitive not in operator position" var)) - (else (syntax-violation #f "bad module kind" var mod)))))))) - (build-global-reference - (lambda (source var mod) - (analyze-variable - mod - var - (lambda (mod var public?) (make-module-ref source mod var public?)) - (lambda (var) (make-toplevel-ref source var))))) - (build-global-assignment - (lambda (source var exp mod) - (maybe-name-value! var exp) - (analyze-variable - mod - var - (lambda (mod var public?) - (make-module-set source mod var public? exp)) - (lambda (var) (make-toplevel-set source var exp))))) - (build-global-definition - (lambda (source var exp) - (maybe-name-value! var exp) - (make-toplevel-define source var exp))) - (build-simple-lambda - (lambda (src req rest vars meta exp) - (make-lambda - src - meta - (make-lambda-case src req #f rest #f '() vars exp #f)))) - (build-case-lambda - (lambda (src meta body) (make-lambda src meta body))) - (build-lambda-case - (lambda (src req opt rest kw inits vars body else-case) - (make-lambda-case src req opt rest kw inits vars body else-case))) - (build-primcall - (lambda (src name args) (make-primcall src name args))) - (build-primref (lambda (src name) (make-primitive-ref src name))) - (build-data (lambda (src exp) (make-const src exp))) - (build-sequence - (lambda (src exps) - (if (null? (cdr exps)) - (car exps) - (make-seq src (car exps) (build-sequence #f (cdr exps)))))) - (build-let - (lambda (src ids vars val-exps body-exp) - (for-each maybe-name-value! ids val-exps) - (if (null? vars) body-exp (make-let src ids vars val-exps body-exp)))) - (build-named-let - (lambda (src ids vars val-exps body-exp) - (let ((f (car vars)) (f-name (car ids)) (vars (cdr vars)) (ids (cdr ids))) - (let ((proc (build-simple-lambda src ids #f vars '() body-exp))) - (maybe-name-value! f-name proc) - (for-each maybe-name-value! ids val-exps) - (make-letrec - src - #f - (list f-name) - (list f) - (list proc) - (build-call src (build-lexical-reference 'fun src f-name f) val-exps)))))) - (build-letrec - (lambda (src in-order? ids vars val-exps body-exp) - (if (null? vars) - body-exp - (begin - (for-each maybe-name-value! ids val-exps) - (make-letrec src in-order? ids vars val-exps body-exp))))) - (make-syntax-object - (lambda (expression wrap module) - (vector 'syntax-object expression wrap module))) - (syntax-object? - (lambda (x) - (and (vector? x) - (= (vector-length x) 4) - (eq? (vector-ref x 0) 'syntax-object)))) - (syntax-object-expression (lambda (x) (vector-ref x 1))) - (syntax-object-wrap (lambda (x) (vector-ref x 2))) - (syntax-object-module (lambda (x) (vector-ref x 3))) - (set-syntax-object-expression! - (lambda (x update) (vector-set! x 1 update))) - (set-syntax-object-wrap! - (lambda (x update) (vector-set! x 2 update))) - (set-syntax-object-module! - (lambda (x update) (vector-set! x 3 update))) - (source-annotation - (lambda (x) - (let ((props (source-properties - (if (syntax-object? x) (syntax-object-expression x) x)))) - (and (pair? props) props)))) - (extend-env - (lambda (labels bindings r) - (if (null? labels) - r - (extend-env - (cdr labels) - (cdr bindings) - (cons (cons (car labels) (car bindings)) r))))) - (extend-var-env - (lambda (labels vars r) - (if (null? labels) - r - (extend-var-env - (cdr labels) - (cdr vars) - (cons (cons (car labels) (cons 'lexical (car vars))) r))))) - (macros-only-env - (lambda (r) - (if (null? r) - '() - (let ((a (car r))) - (if (memq (cadr a) '(macro syntax-parameter ellipsis)) - (cons a (macros-only-env (cdr r))) - (macros-only-env (cdr r))))))) - (global-extend - (lambda (type sym val) (put-global-definition-hook sym type val))) - (nonsymbol-id? - (lambda (x) - (and (syntax-object? x) (symbol? (syntax-object-expression x))))) - (id? (lambda (x) - (if (symbol? x) - #t - (and (syntax-object? x) (symbol? (syntax-object-expression x)))))) - (id-sym-name&marks - (lambda (x w) - (if (syntax-object? x) - (values - (syntax-object-expression x) - (join-marks (car w) (car (syntax-object-wrap x)))) - (values x (car w))))) - (gen-label (lambda () (symbol->string (module-gensym "l")))) - (gen-labels - (lambda (ls) - (if (null? ls) '() (cons (gen-label) (gen-labels (cdr ls)))))) - (make-ribcage - (lambda (symnames marks labels) - (vector 'ribcage symnames marks labels))) - (ribcage? - (lambda (x) - (and (vector? x) - (= (vector-length x) 4) - (eq? (vector-ref x 0) 'ribcage)))) - (ribcage-symnames (lambda (x) (vector-ref x 1))) - (ribcage-marks (lambda (x) (vector-ref x 2))) - (ribcage-labels (lambda (x) (vector-ref x 3))) - (set-ribcage-symnames! (lambda (x update) (vector-set! x 1 update))) - (set-ribcage-marks! (lambda (x update) (vector-set! x 2 update))) - (set-ribcage-labels! (lambda (x update) (vector-set! x 3 update))) - (anti-mark - (lambda (w) (cons (cons #f (car w)) (cons 'shift (cdr w))))) - (extend-ribcage! - (lambda (ribcage id label) - (set-ribcage-symnames! - ribcage - (cons (syntax-object-expression id) (ribcage-symnames ribcage))) - (set-ribcage-marks! - ribcage - (cons (car (syntax-object-wrap id)) (ribcage-marks ribcage))) - (set-ribcage-labels! ribcage (cons label (ribcage-labels ribcage))))) - (make-binding-wrap - (lambda (ids labels w) - (if (null? ids) - w - (cons (car w) - (cons (let* ((labelvec (list->vector labels)) (n (vector-length labelvec))) - (let ((symnamevec (make-vector n)) (marksvec (make-vector n))) - (let f ((ids ids) (i 0)) - (if (not (null? ids)) - (call-with-values - (lambda () (id-sym-name&marks (car ids) w)) - (lambda (symname marks) - (vector-set! symnamevec i symname) - (vector-set! marksvec i marks) - (f (cdr ids) (+ i 1)))))) - (make-ribcage symnamevec marksvec labelvec))) - (cdr w)))))) - (smart-append (lambda (m1 m2) (if (null? m2) m1 (append m1 m2)))) - (join-wraps - (lambda (w1 w2) - (let ((m1 (car w1)) (s1 (cdr w1))) - (if (null? m1) - (if (null? s1) w2 (cons (car w2) (smart-append s1 (cdr w2)))) - (cons (smart-append m1 (car w2)) (smart-append s1 (cdr w2))))))) - (join-marks (lambda (m1 m2) (smart-append m1 m2))) - (same-marks? - (lambda (x y) - (or (eq? x y) - (and (not (null? x)) - (not (null? y)) - (eq? (car x) (car y)) - (same-marks? (cdr x) (cdr y)))))) - (id-var-name - (lambda (id w mod) - (letrec* - ((search - (lambda (sym subst marks mod) - (if (null? subst) - (values #f marks) - (let ((fst (car subst))) - (if (eq? fst 'shift) - (search sym (cdr subst) (cdr marks) mod) - (let ((symnames (ribcage-symnames fst))) - (if (vector? symnames) - (search-vector-rib sym subst marks symnames fst mod) - (search-list-rib sym subst marks symnames fst mod)))))))) - (search-list-rib - (lambda (sym subst marks symnames ribcage mod) - (let f ((symnames symnames) (i 0)) - (cond ((null? symnames) (search sym (cdr subst) marks mod)) - ((and (eq? (car symnames) sym) - (same-marks? marks (list-ref (ribcage-marks ribcage) i))) - (let ((n (list-ref (ribcage-labels ribcage) i))) - (if (pair? n) - (if (equal? mod (car n)) - (values (cdr n) marks) - (f (cdr symnames) (+ i 1))) - (values n marks)))) - (else (f (cdr symnames) (+ i 1))))))) - (search-vector-rib - (lambda (sym subst marks symnames ribcage mod) - (let ((n (vector-length symnames))) - (let f ((i 0)) - (cond ((= i n) (search sym (cdr subst) marks mod)) - ((and (eq? (vector-ref symnames i) sym) - (same-marks? marks (vector-ref (ribcage-marks ribcage) i))) - (let ((n (vector-ref (ribcage-labels ribcage) i))) +(let ((syntax? (module-ref (current-module) 'syntax?)) + (make-syntax (module-ref (current-module) 'make-syntax)) + (syntax-expression (module-ref (current-module) 'syntax-expression)) + (syntax-wrap (module-ref (current-module) 'syntax-wrap)) + (syntax-module (module-ref (current-module) 'syntax-module))) + (letrec* + ((make-void + (lambda (src) (make-struct (vector-ref %expanded-vtables 0) 0 src))) + (make-const + (lambda (src exp) + (make-struct (vector-ref %expanded-vtables 1) 0 src exp))) + (make-primitive-ref + (lambda (src name) + (make-struct (vector-ref %expanded-vtables 2) 0 src name))) + (make-lexical-ref + (lambda (src name gensym) + (make-struct (vector-ref %expanded-vtables 3) 0 src name gensym))) + (make-lexical-set + (lambda (src name gensym exp) + (make-struct (vector-ref %expanded-vtables 4) 0 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-module-set + (lambda (src mod name public? exp) + (make-struct + (vector-ref %expanded-vtables 6) + 0 + src + mod + name + public? + exp))) + (make-toplevel-ref + (lambda (src name) + (make-struct (vector-ref %expanded-vtables 7) 0 src name))) + (make-toplevel-set + (lambda (src name exp) + (make-struct (vector-ref %expanded-vtables 8) 0 src name exp))) + (make-toplevel-define + (lambda (src name exp) + (make-struct (vector-ref %expanded-vtables 9) 0 src name exp))) + (make-conditional + (lambda (src test consequent alternate) + (make-struct + (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-primcall + (lambda (src name args) + (make-struct (vector-ref %expanded-vtables 12) 0 src name args))) + (make-seq + (lambda (src head tail) + (make-struct (vector-ref %expanded-vtables 13) 0 src head tail))) + (make-lambda + (lambda (src meta body) + (make-struct (vector-ref %expanded-vtables 14) 0 src meta body))) + (make-lambda-case + (lambda (src req opt rest kw inits gensyms body alternate) + (make-struct + (vector-ref %expanded-vtables 15) + 0 + src + req + opt + rest + kw + inits + gensyms + body + alternate))) + (make-let + (lambda (src names gensyms vals body) + (make-struct + (vector-ref %expanded-vtables 16) + 0 + src + names + gensyms + vals + body))) + (make-letrec + (lambda (src in-order? names gensyms vals body) + (make-struct + (vector-ref %expanded-vtables 17) + 0 + src + in-order? + names + gensyms + vals + body))) + (lambda? + (lambda (x) + (and (struct? x) + (eq? (struct-vtable x) (vector-ref %expanded-vtables 14))))) + (lambda-meta (lambda (x) (struct-ref x 1))) + (set-lambda-meta! (lambda (x v) (struct-set! x 1 v))) + (top-level-eval-hook (lambda (x mod) (primitive-eval x))) + (local-eval-hook (lambda (x mod) (primitive-eval x))) + (session-id + (let ((v (module-variable (current-module) 'syntax-session-id))) + (lambda () ((variable-ref v))))) + (put-global-definition-hook + (lambda (symbol type val) + (module-define! + (current-module) + symbol + (make-syntax-transformer symbol type val)))) + (get-global-definition-hook + (lambda (symbol module) + (if (and (not module) (current-module)) + (warn "module system is booted, we should have a module" symbol)) + (and (not (equal? module '(primitive))) + (let ((v (module-variable + (if module (resolve-module (cdr module)) (current-module)) + symbol))) + (and v + (variable-bound? v) + (let ((val (variable-ref v))) + (and (macro? val) + (macro-type val) + (cons (macro-type val) (macro-binding val))))))))) + (decorate-source + (lambda (e s) + (if (and s (supports-source-properties? e)) + (set-source-properties! e s)) + e)) + (maybe-name-value! + (lambda (name val) + (if (lambda? val) + (let ((meta (lambda-meta val))) + (if (not (assq 'name meta)) + (set-lambda-meta! val (acons 'name name meta))))))) + (build-void (lambda (source) (make-void source))) + (build-call + (lambda (source fun-exp arg-exps) + (make-call source fun-exp arg-exps))) + (build-conditional + (lambda (source test-exp then-exp else-exp) + (make-conditional source test-exp then-exp else-exp))) + (build-lexical-reference + (lambda (type source name var) (make-lexical-ref source name var))) + (build-lexical-assignment + (lambda (source name var exp) + (maybe-name-value! name exp) + (make-lexical-set source name var exp))) + (analyze-variable + (lambda (mod var modref-cont bare-cont) + (if (not mod) + (bare-cont var) + (let ((kind (car mod)) (mod (cdr mod))) + (let ((key kind)) + (cond ((memv key '(public)) (modref-cont mod var #t)) + ((memv key '(private)) + (if (not (equal? mod (module-name (current-module)))) + (modref-cont mod var #f) + (bare-cont var))) + ((memv key '(bare)) (bare-cont var)) + ((memv key '(hygiene)) + (if (and (not (equal? mod (module-name (current-module)))) + (module-variable (resolve-module mod) var)) + (modref-cont mod var #f) + (bare-cont var))) + ((memv key '(primitive)) + (syntax-violation #f "primitive not in operator position" var)) + (else (syntax-violation #f "bad module kind" var mod)))))))) + (build-global-reference + (lambda (source var mod) + (analyze-variable + mod + var + (lambda (mod var public?) (make-module-ref source mod var public?)) + (lambda (var) (make-toplevel-ref source var))))) + (build-global-assignment + (lambda (source var exp mod) + (maybe-name-value! var exp) + (analyze-variable + mod + var + (lambda (mod var public?) + (make-module-set source mod var public? exp)) + (lambda (var) (make-toplevel-set source var exp))))) + (build-global-definition + (lambda (source var exp) + (maybe-name-value! var exp) + (make-toplevel-define source var exp))) + (build-simple-lambda + (lambda (src req rest vars meta exp) + (make-lambda + src + meta + (make-lambda-case src req #f rest #f '() vars exp #f)))) + (build-case-lambda + (lambda (src meta body) (make-lambda src meta body))) + (build-lambda-case + (lambda (src req opt rest kw inits vars body else-case) + (make-lambda-case src req opt rest kw inits vars body else-case))) + (build-primcall + (lambda (src name args) (make-primcall src name args))) + (build-primref (lambda (src name) (make-primitive-ref src name))) + (build-data (lambda (src exp) (make-const src exp))) + (build-sequence + (lambda (src exps) + (if (null? (cdr exps)) + (car exps) + (make-seq src (car exps) (build-sequence #f (cdr exps)))))) + (build-let + (lambda (src ids vars val-exps body-exp) + (for-each maybe-name-value! ids val-exps) + (if (null? vars) body-exp (make-let src ids vars val-exps body-exp)))) + (build-named-let + (lambda (src ids vars val-exps body-exp) + (let ((f (car vars)) (f-name (car ids)) (vars (cdr vars)) (ids (cdr ids))) + (let ((proc (build-simple-lambda src ids #f vars '() body-exp))) + (maybe-name-value! f-name proc) + (for-each maybe-name-value! ids val-exps) + (make-letrec + src + #f + (list f-name) + (list f) + (list proc) + (build-call src (build-lexical-reference 'fun src f-name f) val-exps)))))) + (build-letrec + (lambda (src in-order? ids vars val-exps body-exp) + (if (null? vars) + body-exp + (begin + (for-each maybe-name-value! ids val-exps) + (make-letrec src in-order? ids vars val-exps body-exp))))) + (syntax-object? + (lambda (x) + (or (syntax? x) + (and (vector? x) + (= (vector-length x) 4) + (eqv? (vector-ref x 0) 'syntax-object))))) + (make-syntax-object + (lambda (expression wrap module) + (vector 'syntax-object expression wrap module))) + (syntax-object-expression + (lambda (obj) + (if (syntax? obj) (syntax-expression obj) (vector-ref obj 1)))) + (syntax-object-wrap + (lambda (obj) + (if (syntax? obj) (syntax-wrap obj) (vector-ref obj 2)))) + (syntax-object-module + (lambda (obj) + (if (syntax? obj) (syntax-module obj) (vector-ref obj 3)))) + (source-annotation + (lambda (x) + (let ((props (source-properties + (if (syntax-object? x) (syntax-object-expression x) x)))) + (and (pair? props) props)))) + (extend-env + (lambda (labels bindings r) + (if (null? labels) + r + (extend-env + (cdr labels) + (cdr bindings) + (cons (cons (car labels) (car bindings)) r))))) + (extend-var-env + (lambda (labels vars r) + (if (null? labels) + r + (extend-var-env + (cdr labels) + (cdr vars) + (cons (cons (car labels) (cons 'lexical (car vars))) r))))) + (macros-only-env + (lambda (r) + (if (null? r) + '() + (let ((a (car r))) + (if (memq (cadr a) '(macro syntax-parameter ellipsis)) + (cons a (macros-only-env (cdr r))) + (macros-only-env (cdr r))))))) + (global-extend + (lambda (type sym val) (put-global-definition-hook sym type val))) + (nonsymbol-id? + (lambda (x) + (and (syntax-object? x) (symbol? (syntax-object-expression x))))) + (id? (lambda (x) + (if (symbol? x) + #t + (and (syntax-object? x) (symbol? (syntax-object-expression x)))))) + (id-sym-name&marks + (lambda (x w) + (if (syntax-object? x) + (values + (syntax-object-expression x) + (join-marks (car w) (car (syntax-object-wrap x)))) + (values x (car w))))) + (gen-label (lambda () (symbol->string (module-gensym "l")))) + (gen-labels + (lambda (ls) + (if (null? ls) '() (cons (gen-label) (gen-labels (cdr ls)))))) + (make-ribcage + (lambda (symnames marks labels) + (vector 'ribcage symnames marks labels))) + (ribcage? + (lambda (x) + (and (vector? x) + (= (vector-length x) 4) + (eq? (vector-ref x 0) 'ribcage)))) + (ribcage-symnames (lambda (x) (vector-ref x 1))) + (ribcage-marks (lambda (x) (vector-ref x 2))) + (ribcage-labels (lambda (x) (vector-ref x 3))) + (set-ribcage-symnames! (lambda (x update) (vector-set! x 1 update))) + (set-ribcage-marks! (lambda (x update) (vector-set! x 2 update))) + (set-ribcage-labels! (lambda (x update) (vector-set! x 3 update))) + (anti-mark + (lambda (w) (cons (cons #f (car w)) (cons 'shift (cdr w))))) + (extend-ribcage! + (lambda (ribcage id label) + (set-ribcage-symnames! + ribcage + (cons (syntax-object-expression id) (ribcage-symnames ribcage))) + (set-ribcage-marks! + ribcage + (cons (car (syntax-object-wrap id)) (ribcage-marks ribcage))) + (set-ribcage-labels! ribcage (cons label (ribcage-labels ribcage))))) + (make-binding-wrap + (lambda (ids labels w) + (if (null? ids) + w + (cons (car w) + (cons (let* ((labelvec (list->vector labels)) (n (vector-length labelvec))) + (let ((symnamevec (make-vector n)) (marksvec (make-vector n))) + (let f ((ids ids) (i 0)) + (if (not (null? ids)) + (call-with-values + (lambda () (id-sym-name&marks (car ids) w)) + (lambda (symname marks) + (vector-set! symnamevec i symname) + (vector-set! marksvec i marks) + (f (cdr ids) (+ i 1)))))) + (make-ribcage symnamevec marksvec labelvec))) + (cdr w)))))) + (smart-append (lambda (m1 m2) (if (null? m2) m1 (append m1 m2)))) + (join-wraps + (lambda (w1 w2) + (let ((m1 (car w1)) (s1 (cdr w1))) + (if (null? m1) + (if (null? s1) w2 (cons (car w2) (smart-append s1 (cdr w2)))) + (cons (smart-append m1 (car w2)) (smart-append s1 (cdr w2))))))) + (join-marks (lambda (m1 m2) (smart-append m1 m2))) + (same-marks? + (lambda (x y) + (or (eq? x y) + (and (not (null? x)) + (not (null? y)) + (eq? (car x) (car y)) + (same-marks? (cdr x) (cdr y)))))) + (id-var-name + (lambda (id w mod) + (letrec* + ((search + (lambda (sym subst marks mod) + (if (null? subst) + (values #f marks) + (let ((fst (car subst))) + (if (eq? fst 'shift) + (search sym (cdr subst) (cdr marks) mod) + (let ((symnames (ribcage-symnames fst))) + (if (vector? symnames) + (search-vector-rib sym subst marks symnames fst mod) + (search-list-rib sym subst marks symnames fst mod)))))))) + (search-list-rib + (lambda (sym subst marks symnames ribcage mod) + (let f ((symnames symnames) (i 0)) + (cond ((null? symnames) (search sym (cdr subst) marks mod)) + ((and (eq? (car symnames) sym) + (same-marks? marks (list-ref (ribcage-marks ribcage) i))) + (let ((n (list-ref (ribcage-labels ribcage) i))) (if (pair? n) - (if (equal? mod (car n)) (values (cdr n) marks) (f (+ i 1))) + (if (equal? mod (car n)) + (values (cdr n) marks) + (f (cdr symnames) (+ i 1))) (values n marks)))) - (else (f (+ i 1))))))))) - (cond ((symbol? id) (or (search id (cdr w) (car w) mod) id)) - ((syntax-object? id) - (let ((id (syntax-object-expression id)) - (w1 (syntax-object-wrap id)) - (mod (syntax-object-module id))) - (let ((marks (join-marks (car w) (car w1)))) - (call-with-values - (lambda () (search id (cdr w) marks mod)) - (lambda (new-id marks) (or new-id (search id (cdr w1) marks mod) id)))))) - (else (syntax-violation 'id-var-name "invalid id" id)))))) - (locally-bound-identifiers - (lambda (w mod) - (letrec* - ((scan (lambda (subst results) - (if (null? subst) - results - (let ((fst (car subst))) - (if (eq? fst 'shift) - (scan (cdr subst) results) - (let ((symnames (ribcage-symnames fst)) (marks (ribcage-marks fst))) - (if (vector? symnames) - (scan-vector-rib subst symnames marks results) - (scan-list-rib subst symnames marks results)))))))) - (scan-list-rib - (lambda (subst symnames marks results) - (let f ((symnames symnames) (marks marks) (results results)) - (if (null? symnames) - (scan (cdr subst) results) - (f (cdr symnames) - (cdr marks) - (cons (wrap (car symnames) (anti-mark (cons (car marks) subst)) mod) - results)))))) - (scan-vector-rib - (lambda (subst symnames marks results) - (let ((n (vector-length symnames))) - (let f ((i 0) (results results)) - (if (= i n) + (else (f (cdr symnames) (+ i 1))))))) + (search-vector-rib + (lambda (sym subst marks symnames ribcage mod) + (let ((n (vector-length symnames))) + (let f ((i 0)) + (cond ((= i n) (search sym (cdr subst) marks mod)) + ((and (eq? (vector-ref symnames i) sym) + (same-marks? marks (vector-ref (ribcage-marks ribcage) i))) + (let ((n (vector-ref (ribcage-labels ribcage) i))) + (if (pair? n) + (if (equal? mod (car n)) (values (cdr n) marks) (f (+ i 1))) + (values n marks)))) + (else (f (+ i 1))))))))) + (cond ((symbol? id) (or (search id (cdr w) (car w) mod) id)) + ((syntax-object? id) + (let ((id (syntax-object-expression id)) + (w1 (syntax-object-wrap id)) + (mod (syntax-object-module id))) + (let ((marks (join-marks (car w) (car w1)))) + (call-with-values + (lambda () (search id (cdr w) marks mod)) + (lambda (new-id marks) (or new-id (search id (cdr w1) marks mod) id)))))) + (else (syntax-violation 'id-var-name "invalid id" id)))))) + (locally-bound-identifiers + (lambda (w mod) + (letrec* + ((scan (lambda (subst results) + (if (null? subst) + results + (let ((fst (car subst))) + (if (eq? fst 'shift) + (scan (cdr subst) results) + (let ((symnames (ribcage-symnames fst)) (marks (ribcage-marks fst))) + (if (vector? symnames) + (scan-vector-rib subst symnames marks results) + (scan-list-rib subst symnames marks results)))))))) + (scan-list-rib + (lambda (subst symnames marks results) + (let f ((symnames symnames) (marks marks) (results results)) + (if (null? symnames) (scan (cdr subst) results) - (f (+ i 1) - (cons (wrap (vector-ref symnames i) - (anti-mark (cons (vector-ref marks i) subst)) - mod) - results)))))))) - (scan (cdr w) '())))) - (resolve-identifier - (lambda (id w r mod resolve-syntax-parameters?) - (letrec* - ((resolve-syntax-parameters - (lambda (b) - (if (and resolve-syntax-parameters? (eq? (car b) 'syntax-parameter)) - (or (assq-ref r (cdr b)) (cons 'macro (car (cdr b)))) - b))) - (resolve-global - (lambda (var mod) - (let ((b (resolve-syntax-parameters - (or (get-global-definition-hook var mod) '(global))))) - (if (eq? (car b) 'global) - (values 'global var mod) + (f (cdr symnames) + (cdr marks) + (cons (wrap (car symnames) (anti-mark (cons (car marks) subst)) mod) + results)))))) + (scan-vector-rib + (lambda (subst symnames marks results) + (let ((n (vector-length symnames))) + (let f ((i 0) (results results)) + (if (= i n) + (scan (cdr subst) results) + (f (+ i 1) + (cons (wrap (vector-ref symnames i) + (anti-mark (cons (vector-ref marks i) subst)) + mod) + results)))))))) + (scan (cdr w) '())))) + (resolve-identifier + (lambda (id w r mod resolve-syntax-parameters?) + (letrec* + ((resolve-syntax-parameters + (lambda (b) + (if (and resolve-syntax-parameters? (eq? (car b) 'syntax-parameter)) + (or (assq-ref r (cdr b)) (cons 'macro (car (cdr b)))) + b))) + (resolve-global + (lambda (var mod) + (let ((b (resolve-syntax-parameters + (or (get-global-definition-hook var mod) '(global))))) + (if (eq? (car b) 'global) + (values 'global var mod) + (values (car b) (cdr b) mod))))) + (resolve-lexical + (lambda (label mod) + (let ((b (resolve-syntax-parameters + (or (assq-ref r label) '(displaced-lexical))))) (values (car b) (cdr b) mod))))) - (resolve-lexical - (lambda (label mod) - (let ((b (resolve-syntax-parameters - (or (assq-ref r label) '(displaced-lexical))))) - (values (car b) (cdr b) mod))))) - (let ((n (id-var-name id w mod))) - (cond ((syntax-object? n) - (if (not (eq? n id)) - (resolve-identifier n w r mod resolve-syntax-parameters?) - (resolve-identifier - (syntax-object-expression n) - (syntax-object-wrap n) - r - (syntax-object-module n) - resolve-syntax-parameters?))) - ((symbol? n) - (resolve-global - n - (if (syntax-object? id) (syntax-object-module id) mod))) - ((string? n) - (resolve-lexical - n - (if (syntax-object? id) (syntax-object-module id) mod))) - (else (error "unexpected id-var-name" id w n))))))) - (transformer-environment - (make-fluid - (lambda (k) - (error "called outside the dynamic extent of a syntax transformer")))) - (with-transformer-environment - (lambda (k) ((fluid-ref transformer-environment) k))) - (free-id=? - (lambda (i j) - (let* ((mi (and (syntax-object? i) (syntax-object-module i))) - (mj (and (syntax-object? j) (syntax-object-module j))) - (ni (id-var-name i '(()) mi)) - (nj (id-var-name j '(()) mj))) - (letrec* - ((id-module-binding - (lambda (id mod) - (module-variable - (if mod (resolve-module (cdr mod)) (current-module)) - (let ((x id)) (if (syntax-object? x) (syntax-object-expression x) x)))))) - (cond ((syntax-object? ni) (free-id=? ni j)) - ((syntax-object? nj) (free-id=? i nj)) - ((symbol? ni) - (and (eq? nj - (let ((x j)) (if (syntax-object? x) (syntax-object-expression x) x))) - (let ((bi (id-module-binding i mi))) - (if bi - (eq? bi (id-module-binding j mj)) - (and (not (id-module-binding j mj)) (eq? ni nj)))) - (eq? (id-module-binding i mi) (id-module-binding j mj)))) - (else (equal? ni nj))))))) - (bound-id=? - (lambda (i j) - (if (and (syntax-object? i) (syntax-object? j)) - (and (eq? (syntax-object-expression i) (syntax-object-expression j)) - (same-marks? - (car (syntax-object-wrap i)) - (car (syntax-object-wrap j)))) - (eq? i j)))) - (valid-bound-ids? - (lambda (ids) - (and (let all-ids? ((ids ids)) - (or (null? ids) (and (id? (car ids)) (all-ids? (cdr ids))))) - (distinct-bound-ids? ids)))) - (distinct-bound-ids? - (lambda (ids) - (let distinct? ((ids ids)) - (or (null? ids) - (and (not (bound-id-member? (car ids) (cdr ids))) - (distinct? (cdr ids))))))) - (bound-id-member? - (lambda (x list) - (and (not (null? list)) - (or (bound-id=? x (car list)) (bound-id-member? x (cdr list)))))) - (wrap (lambda (x w defmod) - (cond ((and (null? (car w)) (null? (cdr w))) x) - ((syntax-object? x) - (make-syntax-object - (syntax-object-expression x) - (join-wraps w (syntax-object-wrap x)) - (syntax-object-module x))) - ((null? x) x) - (else (make-syntax-object x w defmod))))) - (source-wrap - (lambda (x w s defmod) (wrap (decorate-source x s) w defmod))) - (expand-sequence - (lambda (body r w s mod) - (build-sequence - s - (let dobody ((body body) (r r) (w w) (mod mod)) - (if (null? body) - '() - (let ((first (expand (car body) r w mod))) - (cons first (dobody (cdr body) r w mod)))))))) - (expand-top-sequence - (lambda (body r w s m esew mod) - (let* ((r (cons '("placeholder" placeholder) r)) - (ribcage (make-ribcage '() '() '())) - (w (cons (car w) (cons ribcage (cdr w))))) - (letrec* - ((record-definition! - (lambda (id var) - (let ((mod (cons 'hygiene (module-name (current-module))))) - (extend-ribcage! - ribcage - id - (cons (syntax-object-module id) (wrap var '((top)) mod)))))) - (macro-introduced-identifier? - (lambda (id) (not (equal? (car (syntax-object-wrap id)) '(top))))) - (fresh-derived-name - (lambda (id orig-form) - (symbol-append - (syntax-object-expression id) - '- - (string->symbol - (number->string - (hash (syntax->datum orig-form) most-positive-fixnum) - 16))))) - (parse (lambda (body r w s m esew mod) - (let lp ((body body) (exps '())) - (if (null? body) - exps - (lp (cdr body) (append (parse1 (car body) r w s m esew mod) exps)))))) - (parse1 - (lambda (x r w s m esew mod) - (letrec* - ((current-module-for-expansion - (lambda (mod) - (let ((key (car mod))) - (if (memv key '(hygiene)) - (cons 'hygiene (module-name (current-module))) - mod))))) - (call-with-values - (lambda () - (let ((mod (current-module-for-expansion mod))) - (syntax-type x r w (source-annotation x) ribcage mod #f))) - (lambda (type value form e w s mod) - (let ((key type)) - (cond ((memv key '(define-form)) - (let* ((id (wrap value w mod)) - (label (gen-label)) - (var (if (macro-introduced-identifier? id) - (fresh-derived-name id x) - (syntax-object-expression id)))) - (record-definition! id var) + (let ((n (id-var-name id w mod))) + (cond ((syntax-object? n) + (if (not (eq? n id)) + (resolve-identifier n w r mod resolve-syntax-parameters?) + (resolve-identifier + (syntax-object-expression n) + (syntax-object-wrap n) + r + (syntax-object-module n) + resolve-syntax-parameters?))) + ((symbol? n) + (resolve-global + n + (if (syntax-object? id) (syntax-object-module id) mod))) + ((string? n) + (resolve-lexical + n + (if (syntax-object? id) (syntax-object-module id) mod))) + (else (error "unexpected id-var-name" id w n))))))) + (transformer-environment + (make-fluid + (lambda (k) + (error "called outside the dynamic extent of a syntax transformer")))) + (with-transformer-environment + (lambda (k) ((fluid-ref transformer-environment) k))) + (free-id=? + (lambda (i j) + (let* ((mi (and (syntax-object? i) (syntax-object-module i))) + (mj (and (syntax-object? j) (syntax-object-module j))) + (ni (id-var-name i '(()) mi)) + (nj (id-var-name j '(()) mj))) + (letrec* + ((id-module-binding + (lambda (id mod) + (module-variable + (if mod (resolve-module (cdr mod)) (current-module)) + (let ((x id)) (if (syntax-object? x) (syntax-object-expression x) x)))))) + (cond ((syntax-object? ni) (free-id=? ni j)) + ((syntax-object? nj) (free-id=? i nj)) + ((symbol? ni) + (and (eq? nj + (let ((x j)) (if (syntax-object? x) (syntax-object-expression x) x))) + (let ((bi (id-module-binding i mi))) + (if bi + (eq? bi (id-module-binding j mj)) + (and (not (id-module-binding j mj)) (eq? ni nj)))) + (eq? (id-module-binding i mi) (id-module-binding j mj)))) + (else (equal? ni nj))))))) + (bound-id=? + (lambda (i j) + (if (and (syntax-object? i) (syntax-object? j)) + (and (eq? (syntax-object-expression i) (syntax-object-expression j)) + (same-marks? + (car (syntax-object-wrap i)) + (car (syntax-object-wrap j)))) + (eq? i j)))) + (valid-bound-ids? + (lambda (ids) + (and (let all-ids? ((ids ids)) + (or (null? ids) (and (id? (car ids)) (all-ids? (cdr ids))))) + (distinct-bound-ids? ids)))) + (distinct-bound-ids? + (lambda (ids) + (let distinct? ((ids ids)) + (or (null? ids) + (and (not (bound-id-member? (car ids) (cdr ids))) + (distinct? (cdr ids))))))) + (bound-id-member? + (lambda (x list) + (and (not (null? list)) + (or (bound-id=? x (car list)) (bound-id-member? x (cdr list)))))) + (wrap (lambda (x w defmod) + (cond ((and (null? (car w)) (null? (cdr w))) x) + ((syntax-object? x) + (make-syntax-object + (syntax-object-expression x) + (join-wraps w (syntax-object-wrap x)) + (syntax-object-module x))) + ((null? x) x) + (else (make-syntax-object x w defmod))))) + (source-wrap + (lambda (x w s defmod) (wrap (decorate-source x s) w defmod))) + (expand-sequence + (lambda (body r w s mod) + (build-sequence + s + (let dobody ((body body) (r r) (w w) (mod mod)) + (if (null? body) + '() + (let ((first (expand (car body) r w mod))) + (cons first (dobody (cdr body) r w mod)))))))) + (expand-top-sequence + (lambda (body r w s m esew mod) + (let* ((r (cons '("placeholder" placeholder) r)) + (ribcage (make-ribcage '() '() '())) + (w (cons (car w) (cons ribcage (cdr w))))) + (letrec* + ((record-definition! + (lambda (id var) + (let ((mod (cons 'hygiene (module-name (current-module))))) + (extend-ribcage! + ribcage + id + (cons (syntax-object-module id) (wrap var '((top)) mod)))))) + (macro-introduced-identifier? + (lambda (id) (not (equal? (car (syntax-object-wrap id)) '(top))))) + (fresh-derived-name + (lambda (id orig-form) + (symbol-append + (syntax-object-expression id) + '- + (string->symbol + (number->string + (hash (syntax->datum orig-form) most-positive-fixnum) + 16))))) + (parse (lambda (body r w s m esew mod) + (let lp ((body body) (exps '())) + (if (null? body) + exps + (lp (cdr body) (append (parse1 (car body) r w s m esew mod) exps)))))) + (parse1 + (lambda (x r w s m esew mod) + (letrec* + ((current-module-for-expansion + (lambda (mod) + (let ((key (car mod))) + (if (memv key '(hygiene)) + (cons 'hygiene (module-name (current-module))) + mod))))) + (call-with-values + (lambda () + (let ((mod (current-module-for-expansion mod))) + (syntax-type x r w (source-annotation x) ribcage mod #f))) + (lambda (type value form e w s mod) + (let ((key type)) + (cond ((memv key '(define-form)) + (let* ((id (wrap value w mod)) + (label (gen-label)) + (var (if (macro-introduced-identifier? id) + (fresh-derived-name id x) + (syntax-object-expression id)))) + (record-definition! id var) + (list (if (eq? m 'c&e) + (let ((x (build-global-definition s var (expand e r w mod)))) + (top-level-eval-hook x mod) + (lambda () x)) + (call-with-values + (lambda () (resolve-identifier id '(()) r mod #t)) + (lambda (type* value* mod*) + (if (eq? type* 'macro) + (top-level-eval-hook + (build-global-definition s var (build-void s)) + mod)) + (lambda () (build-global-definition s var (expand e r w mod))))))))) + ((memv key '(define-syntax-form define-syntax-parameter-form)) + (let* ((id (wrap value w mod)) + (label (gen-label)) + (var (if (macro-introduced-identifier? id) + (fresh-derived-name id x) + (syntax-object-expression id)))) + (record-definition! id var) + (let ((key m)) + (cond ((memv key '(c)) + (cond ((memq 'compile esew) + (let ((e (expand-install-global var type (expand e r w mod)))) + (top-level-eval-hook e mod) + (if (memq 'load esew) (list (lambda () e)) '()))) + ((memq 'load esew) + (list (lambda () + (expand-install-global var type (expand e r w mod))))) + (else '()))) + ((memv key '(c&e)) + (let ((e (expand-install-global var type (expand e r w mod)))) + (top-level-eval-hook e mod) + (list (lambda () e)))) + (else + (if (memq 'eval esew) + (top-level-eval-hook + (expand-install-global var type (expand e r w mod)) + mod)) + '()))))) + ((memv key '(begin-form)) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any)))) + (if tmp + (apply (lambda (e1) (parse e1 r w s m esew mod)) tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))) + ((memv key '(local-syntax-form)) + (expand-local-syntax + value + e + r + w + s + mod + (lambda (forms r w s mod) (parse forms r w s m esew mod)))) + ((memv key '(eval-when-form)) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any)))) + (if tmp + (apply (lambda (x e1 e2) + (let ((when-list (parse-when-list e x)) (body (cons e1 e2))) + (letrec* + ((recurse (lambda (m esew) (parse body r w s m esew mod)))) + (cond ((eq? m 'e) + (if (memq 'eval when-list) + (recurse (if (memq 'expand when-list) 'c&e 'e) '(eval)) + (begin + (if (memq 'expand when-list) + (top-level-eval-hook + (expand-top-sequence body r w s 'e '(eval) mod) + mod)) + '()))) + ((memq 'load when-list) + (cond ((or (memq 'compile when-list) + (memq 'expand when-list) + (and (eq? m 'c&e) (memq 'eval when-list))) + (recurse 'c&e '(compile load))) + ((memq m '(c c&e)) (recurse 'c '(load))) + (else '()))) + ((or (memq 'compile when-list) + (memq 'expand when-list) + (and (eq? m 'c&e) (memq 'eval when-list))) + (top-level-eval-hook + (expand-top-sequence body r w s 'e '(eval) mod) + mod) + '()) + (else '()))))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))) + (else (list (if (eq? m 'c&e) - (let ((x (build-global-definition s var (expand e r w mod)))) + (let ((x (expand-expr type value form e r w s mod))) (top-level-eval-hook x mod) (lambda () x)) - (call-with-values - (lambda () (resolve-identifier id '(()) r mod #t)) - (lambda (type* value* mod*) - (if (eq? type* 'macro) - (top-level-eval-hook - (build-global-definition s var (build-void s)) - mod)) - (lambda () (build-global-definition s var (expand e r w mod))))))))) - ((memv key '(define-syntax-form define-syntax-parameter-form)) - (let* ((id (wrap value w mod)) - (label (gen-label)) - (var (if (macro-introduced-identifier? id) - (fresh-derived-name id x) - (syntax-object-expression id)))) - (record-definition! id var) - (let ((key m)) - (cond ((memv key '(c)) - (cond ((memq 'compile esew) - (let ((e (expand-install-global var type (expand e r w mod)))) - (top-level-eval-hook e mod) - (if (memq 'load esew) (list (lambda () e)) '()))) - ((memq 'load esew) - (list (lambda () (expand-install-global var type (expand e r w mod))))) - (else '()))) - ((memv key '(c&e)) - (let ((e (expand-install-global var type (expand e r w mod)))) - (top-level-eval-hook e mod) - (list (lambda () e)))) - (else - (if (memq 'eval esew) - (top-level-eval-hook - (expand-install-global var type (expand e r w mod)) - mod)) - '()))))) - ((memv key '(begin-form)) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any)))) - (if tmp - (apply (lambda (e1) (parse e1 r w s m esew mod)) tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))) - ((memv key '(local-syntax-form)) - (expand-local-syntax - value - e + (lambda () (expand-expr type value form e r w s mod))))))))))))) + (let ((exps (map (lambda (x) (x)) (reverse (parse body r w s m esew mod))))) + (if (null? exps) (build-void s) (build-sequence s exps))))))) + (expand-install-global + (lambda (name type e) + (build-global-definition + #f + name + (build-primcall + #f + 'make-syntax-transformer + (if (eq? type 'define-syntax-parameter-form) + (list (build-data #f name) + (build-data #f 'syntax-parameter) + (build-primcall #f 'list (list e))) + (list (build-data #f name) (build-data #f 'macro) e)))))) + (parse-when-list + (lambda (e when-list) + (let ((result (strip when-list '(())))) + (let lp ((l result)) + (cond ((null? l) result) + ((memq (car l) '(compile load eval expand)) (lp (cdr l))) + (else (syntax-violation 'eval-when "invalid situation" e (car l)))))))) + (syntax-type + (lambda (e r w s rib mod for-car?) + (cond ((symbol? e) + (call-with-values + (lambda () (resolve-identifier e w r mod #t)) + (lambda (type value mod*) + (let ((key type)) + (cond ((memv key '(macro)) + (if for-car? + (values type value e e w s mod) + (syntax-type + (expand-macro value e r w s rib mod) r - w + '(()) s + rib mod - (lambda (forms r w s mod) (parse forms r w s m esew mod)))) - ((memv key '(eval-when-form)) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any)))) - (if tmp - (apply (lambda (x e1 e2) - (let ((when-list (parse-when-list e x)) (body (cons e1 e2))) - (letrec* - ((recurse (lambda (m esew) (parse body r w s m esew mod)))) - (cond ((eq? m 'e) - (if (memq 'eval when-list) - (recurse (if (memq 'expand when-list) 'c&e 'e) '(eval)) - (begin - (if (memq 'expand when-list) - (top-level-eval-hook - (expand-top-sequence body r w s 'e '(eval) mod) - mod)) - '()))) - ((memq 'load when-list) - (cond ((or (memq 'compile when-list) - (memq 'expand when-list) - (and (eq? m 'c&e) (memq 'eval when-list))) - (recurse 'c&e '(compile load))) - ((memq m '(c c&e)) (recurse 'c '(load))) - (else '()))) - ((or (memq 'compile when-list) - (memq 'expand when-list) - (and (eq? m 'c&e) (memq 'eval when-list))) - (top-level-eval-hook - (expand-top-sequence body r w s 'e '(eval) mod) - mod) - '()) - (else '()))))) + #f))) + ((memv key '(global)) (values type value e value w s mod*)) + (else (values type value e e w s mod))))))) + ((pair? e) + (let ((first (car e))) + (call-with-values + (lambda () (syntax-type first r w s rib mod #t)) + (lambda (ftype fval fform fe fw fs fmod) + (let ((key ftype)) + (cond ((memv key '(lexical)) (values 'lexical-call fval e e w s mod)) + ((memv key '(global)) + (if (equal? fmod '(primitive)) + (values 'primitive-call fval e e w s mod) + (values 'global-call (make-syntax-object fval w fmod) e e w s mod))) + ((memv key '(macro)) + (syntax-type + (expand-macro fval e r w s rib mod) + r + '(()) + s + rib + mod + for-car?)) + ((memv key '(module-ref)) + (call-with-values + (lambda () (fval e r w mod)) + (lambda (e r w s mod) (syntax-type e r w s rib mod for-car?)))) + ((memv key '(core)) (values 'core-form fval e e w s mod)) + ((memv key '(local-syntax)) + (values 'local-syntax-form fval e e w s mod)) + ((memv key '(begin)) (values 'begin-form #f e e w s mod)) + ((memv key '(eval-when)) (values 'eval-when-form #f e e w s mod)) + ((memv key '(define)) + (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any)))) + (if (and tmp-1 (apply (lambda (name val) (id? name)) tmp-1)) + (apply (lambda (name val) (values 'define-form name e val w s mod)) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(_ (any . any) any . each-any)))) + (if (and tmp-1 + (apply (lambda (name args e1 e2) + (and (id? name) (valid-bound-ids? (lambda-var-list args)))) + tmp-1)) + (apply (lambda (name args e1 e2) + (values + 'define-form + (wrap name w mod) + (wrap e w mod) + (decorate-source + (cons '#(syntax-object lambda ((top)) (hygiene guile)) + (wrap (cons args (cons e1 e2)) w mod)) + s) + '(()) + s + mod)) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(_ any)))) + (if (and tmp-1 (apply (lambda (name) (id? name)) tmp-1)) + (apply (lambda (name) + (values + 'define-form + (wrap name w mod) + (wrap e w mod) + '(#(syntax-object if ((top)) (hygiene guile)) #f #f) + '(()) + s + mod)) + tmp-1) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp)))))))) + ((memv key '(define-syntax)) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any)))) + (if (and tmp (apply (lambda (name val) (id? name)) tmp)) + (apply (lambda (name val) (values 'define-syntax-form name e val w s mod)) tmp) (syntax-violation #f "source expression failed to match any pattern" tmp-1)))) - (else - (list (if (eq? m 'c&e) - (let ((x (expand-expr type value form e r w s mod))) - (top-level-eval-hook x mod) - (lambda () x)) - (lambda () (expand-expr type value form e r w s mod))))))))))))) - (let ((exps (map (lambda (x) (x)) (reverse (parse body r w s m esew mod))))) - (if (null? exps) (build-void s) (build-sequence s exps))))))) - (expand-install-global - (lambda (name type e) - (build-global-definition - #f - name - (build-primcall - #f - 'make-syntax-transformer - (if (eq? type 'define-syntax-parameter-form) - (list (build-data #f name) - (build-data #f 'syntax-parameter) - (build-primcall #f 'list (list e))) - (list (build-data #f name) (build-data #f 'macro) e)))))) - (parse-when-list - (lambda (e when-list) - (let ((result (strip when-list '(())))) - (let lp ((l result)) - (cond ((null? l) result) - ((memq (car l) '(compile load eval expand)) (lp (cdr l))) - (else (syntax-violation 'eval-when "invalid situation" e (car l)))))))) - (syntax-type - (lambda (e r w s rib mod for-car?) - (cond ((symbol? e) - (call-with-values - (lambda () (resolve-identifier e w r mod #t)) - (lambda (type value mod*) - (let ((key type)) - (cond ((memv key '(macro)) - (if for-car? - (values type value e e w s mod) - (syntax-type - (expand-macro value e r w s rib mod) - r - '(()) - s - rib - mod - #f))) - ((memv key '(global)) (values type value e value w s mod*)) - (else (values type value e e w s mod))))))) - ((pair? e) - (let ((first (car e))) - (call-with-values - (lambda () (syntax-type first r w s rib mod #t)) - (lambda (ftype fval fform fe fw fs fmod) - (let ((key ftype)) - (cond ((memv key '(lexical)) (values 'lexical-call fval e e w s mod)) - ((memv key '(global)) - (if (equal? fmod '(primitive)) - (values 'primitive-call fval e e w s mod) - (values 'global-call (make-syntax-object fval w fmod) e e w s mod))) - ((memv key '(macro)) - (syntax-type - (expand-macro fval e r w s rib mod) - r - '(()) - s - rib - mod - for-car?)) - ((memv key '(module-ref)) - (call-with-values - (lambda () (fval e r w mod)) - (lambda (e r w s mod) (syntax-type e r w s rib mod for-car?)))) - ((memv key '(core)) (values 'core-form fval e e w s mod)) - ((memv key '(local-syntax)) - (values 'local-syntax-form fval e e w s mod)) - ((memv key '(begin)) (values 'begin-form #f e e w s mod)) - ((memv key '(eval-when)) (values 'eval-when-form #f e e w s mod)) - ((memv key '(define)) - (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any)))) - (if (and tmp-1 (apply (lambda (name val) (id? name)) tmp-1)) - (apply (lambda (name val) (values 'define-form name e val w s mod)) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(_ (any . any) any . each-any)))) - (if (and tmp-1 - (apply (lambda (name args e1 e2) - (and (id? name) (valid-bound-ids? (lambda-var-list args)))) - tmp-1)) - (apply (lambda (name args e1 e2) - (values - 'define-form - (wrap name w mod) - (wrap e w mod) - (decorate-source - (cons '#(syntax-object lambda ((top)) (hygiene guile)) - (wrap (cons args (cons e1 e2)) w mod)) - s) - '(()) - s - mod)) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(_ any)))) - (if (and tmp-1 (apply (lambda (name) (id? name)) tmp-1)) - (apply (lambda (name) - (values - 'define-form - (wrap name w mod) - (wrap e w mod) - '(#(syntax-object if ((top)) (hygiene guile)) #f #f) - '(()) - s - mod)) - tmp-1) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp)))))))) - ((memv key '(define-syntax)) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any)))) - (if (and tmp (apply (lambda (name val) (id? name)) tmp)) - (apply (lambda (name val) (values 'define-syntax-form name e val w s mod)) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))) - ((memv key '(define-syntax-parameter)) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any)))) - (if (and tmp (apply (lambda (name val) (id? name)) tmp)) - (apply (lambda (name val) - (values 'define-syntax-parameter-form name e val w s mod)) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))) - (else (values 'call #f e e w s mod)))))))) - ((syntax-object? e) - (syntax-type - (syntax-object-expression e) - r - (join-wraps w (syntax-object-wrap e)) - (or (source-annotation e) s) - rib - (or (syntax-object-module e) mod) - for-car?)) - ((self-evaluating? e) (values 'constant #f e e w s mod)) - (else (values 'other #f e e w s mod))))) - (expand - (lambda (e r w mod) - (call-with-values - (lambda () (syntax-type e r w (source-annotation e) #f mod #f)) - (lambda (type value form e w s mod) - (expand-expr type value form e r w s mod))))) - (expand-expr - (lambda (type value form e r w s mod) - (let ((key type)) - (cond ((memv key '(lexical)) (build-lexical-reference 'value s e value)) - ((memv key '(core core-form)) (value e r w s mod)) - ((memv key '(module-ref)) - (call-with-values - (lambda () (value e r w mod)) - (lambda (e r w s mod) (expand e r w mod)))) - ((memv key '(lexical-call)) - (expand-call - (let ((id (car e))) - (build-lexical-reference - 'fun - (source-annotation id) - (if (syntax-object? id) (syntax->datum id) id) - value)) - e + ((memv key '(define-syntax-parameter)) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any)))) + (if (and tmp (apply (lambda (name val) (id? name)) tmp)) + (apply (lambda (name val) + (values 'define-syntax-parameter-form name e val w s mod)) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))) + (else (values 'call #f e e w s mod)))))))) + ((syntax-object? e) + (syntax-type + (syntax-object-expression e) r - w - s - mod)) - ((memv key '(global-call)) - (expand-call - (build-global-reference - (source-annotation (car e)) - (if (syntax-object? value) (syntax-object-expression value) value) - (if (syntax-object? value) (syntax-object-module value) mod)) - e - r - w - s - mod)) - ((memv key '(primitive-call)) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any)))) - (if tmp - (apply (lambda (e) - (build-primcall s value (map (lambda (e) (expand e r w mod)) e))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))) - ((memv key '(constant)) - (build-data s (strip (source-wrap e w s mod) '(())))) - ((memv key '(global)) (build-global-reference s value mod)) - ((memv key '(call)) - (expand-call (expand (car e) r w mod) e r w s mod)) - ((memv key '(begin-form)) - (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any . each-any)))) - (if tmp-1 - (apply (lambda (e1 e2) (expand-sequence (cons e1 e2) r w s mod)) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(_)))) - (if tmp-1 - (apply (lambda () - (syntax-violation - #f - "sequence of zero expressions" - (source-wrap e w s mod))) - tmp-1) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp)))))) - ((memv key '(local-syntax-form)) - (expand-local-syntax value e r w s mod expand-sequence)) - ((memv key '(eval-when-form)) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any)))) - (if tmp - (apply (lambda (x e1 e2) - (let ((when-list (parse-when-list e x))) - (if (memq 'eval when-list) - (expand-sequence (cons e1 e2) r w s mod) - (expand-void)))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))) - ((memv key - '(define-form define-syntax-form define-syntax-parameter-form)) - (syntax-violation - #f - "definition in expression context, where definitions are not allowed," - (source-wrap form w s mod))) - ((memv key '(syntax)) - (syntax-violation - #f - "reference to pattern variable outside syntax form" - (source-wrap e w s mod))) - ((memv key '(displaced-lexical)) - (syntax-violation - #f - "reference to identifier outside its scope" - (source-wrap e w s mod))) - (else - (syntax-violation #f "unexpected syntax" (source-wrap e w s mod))))))) - (expand-call - (lambda (x e r w s mod) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(any . each-any)))) - (if tmp - (apply (lambda (e0 e1) - (build-call s x (map (lambda (e) (expand e r w mod)) e1))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))))) - (expand-macro - (lambda (p e r w s rib mod) - (letrec* - ((rebuild-macro-output - (lambda (x m) - (cond ((pair? x) - (decorate-source - (cons (rebuild-macro-output (car x) m) - (rebuild-macro-output (cdr x) m)) - s)) - ((syntax-object? x) - (let ((w (syntax-object-wrap x))) - (let ((ms (car w)) (ss (cdr w))) - (if (and (pair? ms) (eq? (car ms) #f)) - (make-syntax-object - (syntax-object-expression x) - (cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss))) - (syntax-object-module x)) - (make-syntax-object - (decorate-source (syntax-object-expression x) s) - (cons (cons m ms) - (if rib (cons rib (cons 'shift ss)) (cons 'shift ss))) - (syntax-object-module x)))))) - ((vector? x) - (let* ((n (vector-length x)) (v (decorate-source (make-vector n) s))) - (let loop ((i 0)) - (if (= i n) - (begin (if #f #f) v) - (begin - (vector-set! v i (rebuild-macro-output (vector-ref x i) m)) - (loop (+ i 1))))))) - ((symbol? x) - (syntax-violation - #f - "encountered raw symbol in macro output" - (source-wrap e w (cdr w) mod) - x)) - (else (decorate-source x s)))))) - (let* ((t-680b775fb37a463-7fe transformer-environment) - (t-680b775fb37a463-7ff (lambda (k) (k e r w s rib mod)))) - (with-fluid* - t-680b775fb37a463-7fe - t-680b775fb37a463-7ff - (lambda () - (rebuild-macro-output - (p (source-wrap e (anti-mark w) s mod)) - (module-gensym "m")))))))) - (expand-body - (lambda (body outer-form r w mod) - (let* ((r (cons '("placeholder" placeholder) r)) - (ribcage (make-ribcage '() '() '())) - (w (cons (car w) (cons ribcage (cdr w))))) - (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body)) - (ids '()) - (labels '()) - (var-ids '()) - (vars '()) - (vals '()) - (bindings '())) - (if (null? body) - (syntax-violation #f "no expressions in body" outer-form) - (let ((e (cdar body)) (er (caar body))) - (call-with-values - (lambda () - (syntax-type e er '(()) (source-annotation e) ribcage mod #f)) - (lambda (type value form e w s mod) - (let ((key type)) - (cond ((memv key '(define-form)) - (let ((id (wrap value w mod)) (label (gen-label))) - (let ((var (gen-var id))) - (extend-ribcage! ribcage id label) - (parse (cdr body) - (cons id ids) - (cons label labels) - (cons id var-ids) - (cons var vars) - (cons (cons er (wrap e w mod)) vals) - (cons (cons 'lexical var) bindings))))) - ((memv key '(define-syntax-form)) - (let ((id (wrap value w mod)) - (label (gen-label)) - (trans-r (macros-only-env er))) - (extend-ribcage! ribcage id label) - (set-cdr! - r - (extend-env - (list label) - (list (cons 'macro (eval-local-transformer (expand e trans-r w mod) mod))) - (cdr r))) - (parse (cdr body) (cons id ids) labels var-ids vars vals bindings))) - ((memv key '(define-syntax-parameter-form)) - (let ((id (wrap value w mod)) - (label (gen-label)) - (trans-r (macros-only-env er))) - (extend-ribcage! ribcage id label) - (set-cdr! - r - (extend-env - (list label) - (list (cons 'syntax-parameter - (list (eval-local-transformer (expand e trans-r w mod) mod)))) - (cdr r))) - (parse (cdr body) (cons id ids) labels var-ids vars vals bindings))) - ((memv key '(begin-form)) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any)))) - (if tmp - (apply (lambda (e1) - (parse (let f ((forms e1)) - (if (null? forms) - (cdr body) - (cons (cons er (wrap (car forms) w mod)) (f (cdr forms))))) - ids - labels - var-ids - vars - vals - bindings)) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))) - ((memv key '(local-syntax-form)) - (expand-local-syntax - value - e - er - w - s - mod - (lambda (forms er w s mod) - (parse (let f ((forms forms)) - (if (null? forms) - (cdr body) - (cons (cons er (wrap (car forms) w mod)) (f (cdr forms))))) - ids - labels - var-ids - vars - vals - bindings)))) - ((null? ids) - (build-sequence - #f - (map (lambda (x) (expand (cdr x) (car x) '(()) mod)) - (cons (cons er (source-wrap e w s mod)) (cdr body))))) - (else - (if (not (valid-bound-ids? ids)) - (syntax-violation - #f - "invalid or duplicate identifier in definition" - outer-form)) - (set-cdr! r (extend-env labels bindings (cdr r))) - (build-letrec - #f - #t - (reverse (map syntax->datum var-ids)) - (reverse vars) - (map (lambda (x) (expand (cdr x) (car x) '(()) mod)) (reverse vals)) - (build-sequence - #f - (map (lambda (x) (expand (cdr x) (car x) '(()) mod)) - (cons (cons er (source-wrap e w s mod)) (cdr body)))))))))))))))) - (expand-local-syntax - (lambda (rec? e r w s mod k) - (let* ((tmp e) - (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) - (if tmp - (apply (lambda (id val e1 e2) - (let ((ids id)) - (if (not (valid-bound-ids? ids)) - (syntax-violation #f "duplicate bound keyword" e) - (let* ((labels (gen-labels ids)) (new-w (make-binding-wrap ids labels w))) - (k (cons e1 e2) - (extend-env - labels - (let ((w (if rec? new-w w)) (trans-r (macros-only-env r))) - (map (lambda (x) - (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod))) - val)) - r) - new-w - s - mod))))) - tmp) - (syntax-violation - #f - "bad local syntax definition" - (source-wrap e w s mod)))))) - (eval-local-transformer - (lambda (expanded mod) - (let ((p (local-eval-hook expanded mod))) - (if (procedure? p) - p - (syntax-violation #f "nonprocedure transformer" p))))) - (expand-void (lambda () (build-void #f))) - (ellipsis? - (lambda (e r mod) - (and (nonsymbol-id? e) - (call-with-values - (lambda () - (resolve-identifier - (make-syntax-object - '#{ $sc-ellipsis }# - (syntax-object-wrap e) - (syntax-object-module e)) - '(()) - r - mod - #f)) - (lambda (type value mod) - (if (eq? type 'ellipsis) - (bound-id=? e value) - (free-id=? e '#(syntax-object ... ((top)) (hygiene guile))))))))) - (lambda-formals - (lambda (orig-args) - (letrec* - ((req (lambda (args rreq) - (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '()))) - (if tmp-1 - (apply (lambda () (check (reverse rreq) #f)) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1)) - (apply (lambda (a b) (req b (cons a rreq))) tmp-1) - (let ((tmp-1 (list tmp))) - (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1)) - (apply (lambda (r) (check (reverse rreq) r)) tmp-1) - (let ((else tmp)) - (syntax-violation 'lambda "invalid argument list" orig-args args)))))))))) - (check (lambda (req rest) - (if (distinct-bound-ids? (if rest (cons rest req) req)) - (values req #f rest #f) - (syntax-violation - 'lambda - "duplicate identifier in argument list" - orig-args))))) - (req orig-args '())))) - (expand-simple-lambda - (lambda (e r w s mod req rest meta body) - (let* ((ids (if rest (append req (list rest)) req)) - (vars (map gen-var ids)) - (labels (gen-labels ids))) - (build-simple-lambda - s - (map syntax->datum req) - (and rest (syntax->datum rest)) - vars - meta - (expand-body - body - (source-wrap e w s mod) - (extend-var-env labels vars r) - (make-binding-wrap ids labels w) - mod))))) - (lambda*-formals - (lambda (orig-args) - (letrec* - ((req (lambda (args rreq) - (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '()))) - (if tmp-1 - (apply (lambda () (check (reverse rreq) '() #f '())) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1)) - (apply (lambda (a b) (req b (cons a rreq))) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if (and tmp-1 - (apply (lambda (a b) (eq? (syntax->datum a) #:optional)) tmp-1)) - (apply (lambda (a b) (opt b (reverse rreq) '())) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if (and tmp-1 - (apply (lambda (a b) (eq? (syntax->datum a) #:key)) tmp-1)) - (apply (lambda (a b) (key b (reverse rreq) '() '())) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any any)))) - (if (and tmp-1 - (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1)) - (apply (lambda (a b) (rest b (reverse rreq) '() '())) tmp-1) - (let ((tmp-1 (list tmp))) - (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1)) - (apply (lambda (r) (rest r (reverse rreq) '() '())) tmp-1) - (let ((else tmp)) - (syntax-violation - 'lambda* - "invalid argument list" - orig-args - args)))))))))))))))) - (opt (lambda (args req ropt) - (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '()))) - (if tmp-1 - (apply (lambda () (check req (reverse ropt) #f '())) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1)) - (apply (lambda (a b) (opt b req (cons (cons a '(#f)) ropt))) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '((any any) . any)))) - (if (and tmp-1 (apply (lambda (a init b) (id? a)) tmp-1)) - (apply (lambda (a init b) (opt b req (cons (list a init) ropt))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if (and tmp-1 - (apply (lambda (a b) (eq? (syntax->datum a) #:key)) tmp-1)) - (apply (lambda (a b) (key b req (reverse ropt) '())) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any any)))) - (if (and tmp-1 - (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1)) - (apply (lambda (a b) (rest b req (reverse ropt) '())) tmp-1) - (let ((tmp-1 (list tmp))) - (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1)) - (apply (lambda (r) (rest r req (reverse ropt) '())) tmp-1) - (let ((else tmp)) - (syntax-violation - 'lambda* - "invalid optional argument list" - orig-args - args)))))))))))))))) - (key (lambda (args req opt rkey) - (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '()))) - (if tmp-1 - (apply (lambda () (check req opt #f (cons #f (reverse rkey)))) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1)) - (apply (lambda (a b) - (let* ((tmp (symbol->keyword (syntax->datum a))) (k tmp)) - (key b req opt (cons (cons k (cons a '(#f))) rkey)))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '((any any) . any)))) - (if (and tmp-1 (apply (lambda (a init b) (id? a)) tmp-1)) - (apply (lambda (a init b) - (let* ((tmp (symbol->keyword (syntax->datum a))) (k tmp)) - (key b req opt (cons (list k a init) rkey)))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '((any any any) . any)))) - (if (and tmp-1 - (apply (lambda (a init k b) (and (id? a) (keyword? (syntax->datum k)))) - tmp-1)) - (apply (lambda (a init k b) (key b req opt (cons (list k a init) rkey))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any)))) - (if (and tmp-1 - (apply (lambda (aok) (eq? (syntax->datum aok) #:allow-other-keys)) - tmp-1)) - (apply (lambda (aok) (check req opt #f (cons #t (reverse rkey)))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any any any)))) - (if (and tmp-1 - (apply (lambda (aok a b) - (and (eq? (syntax->datum aok) #:allow-other-keys) - (eq? (syntax->datum a) #:rest))) - tmp-1)) - (apply (lambda (aok a b) (rest b req opt (cons #t (reverse rkey)))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if (and tmp-1 - (apply (lambda (aok r) - (and (eq? (syntax->datum aok) #:allow-other-keys) (id? r))) - tmp-1)) - (apply (lambda (aok r) (rest r req opt (cons #t (reverse rkey)))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any any)))) - (if (and tmp-1 - (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1)) - (apply (lambda (a b) (rest b req opt (cons #f (reverse rkey)))) - tmp-1) - (let ((tmp-1 (list tmp))) - (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1)) - (apply (lambda (r) (rest r req opt (cons #f (reverse rkey)))) - tmp-1) - (let ((else tmp)) - (syntax-violation - 'lambda* - "invalid keyword argument list" - orig-args - args)))))))))))))))))))))) - (rest (lambda (args req opt kw) - (let* ((tmp-1 args) (tmp (list tmp-1))) - (if (and tmp (apply (lambda (r) (id? r)) tmp)) - (apply (lambda (r) (check req opt r kw)) tmp) - (let ((else tmp-1)) - (syntax-violation 'lambda* "invalid rest argument" orig-args args)))))) - (check (lambda (req opt rest kw) - (if (distinct-bound-ids? - (append - req - (map car opt) - (if rest (list rest) '()) - (if (pair? kw) (map cadr (cdr kw)) '()))) - (values req opt rest kw) - (syntax-violation - 'lambda* - "duplicate identifier in argument list" - orig-args))))) - (req orig-args '())))) - (expand-lambda-case - (lambda (e r w s mod get-formals clauses) - (letrec* - ((parse-req - (lambda (req opt rest kw body) - (let ((vars (map gen-var req)) (labels (gen-labels req))) - (let ((r* (extend-var-env labels vars r)) - (w* (make-binding-wrap req labels w))) - (parse-opt - (map syntax->datum req) - opt - rest - kw - body - (reverse vars) - r* - w* - '() - '()))))) - (parse-opt - (lambda (req opt rest kw body vars r* w* out inits) - (cond ((pair? opt) - (let* ((tmp-1 (car opt)) (tmp ($sc-dispatch tmp-1 '(any any)))) - (if tmp - (apply (lambda (id i) - (let* ((v (gen-var id)) - (l (gen-labels (list v))) - (r** (extend-var-env l (list v) r*)) - (w** (make-binding-wrap (list id) l w*))) - (parse-opt - req - (cdr opt) - rest - kw - body - (cons v vars) - r** - w** - (cons (syntax->datum id) out) - (cons (expand i r* w* mod) inits)))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))) - (rest - (let* ((v (gen-var rest)) - (l (gen-labels (list v))) - (r* (extend-var-env l (list v) r*)) - (w* (make-binding-wrap (list rest) l w*))) - (parse-kw - req - (and (pair? out) (reverse out)) - (syntax->datum rest) - (if (pair? kw) (cdr kw) kw) - body - (cons v vars) - r* - w* - (and (pair? kw) (car kw)) - '() - inits))) - (else - (parse-kw - req - (and (pair? out) (reverse out)) - #f - (if (pair? kw) (cdr kw) kw) - body - vars - r* - w* - (and (pair? kw) (car kw)) - '() - inits))))) - (parse-kw - (lambda (req opt rest kw body vars r* w* aok out inits) - (if (pair? kw) - (let* ((tmp-1 (car kw)) (tmp ($sc-dispatch tmp-1 '(any any any)))) - (if tmp - (apply (lambda (k id i) - (let* ((v (gen-var id)) - (l (gen-labels (list v))) - (r** (extend-var-env l (list v) r*)) - (w** (make-binding-wrap (list id) l w*))) - (parse-kw - req - opt - rest - (cdr kw) - body - (cons v vars) - r** - w** - aok - (cons (list (syntax->datum k) (syntax->datum id) v) out) - (cons (expand i r* w* mod) inits)))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))) - (parse-body - req - opt - rest - (and (or aok (pair? out)) (cons aok (reverse out))) - body - (reverse vars) - r* - w* - (reverse inits) - '())))) - (parse-body - (lambda (req opt rest kw body vars r* w* inits meta) - (let* ((tmp body) (tmp-1 ($sc-dispatch tmp '(any any . each-any)))) - (if (and tmp-1 - (apply (lambda (docstring e1 e2) (string? (syntax->datum docstring))) - tmp-1)) - (apply (lambda (docstring e1 e2) - (parse-body - req - opt - rest - kw - (cons e1 e2) - vars - r* - w* - inits - (append meta (list (cons 'documentation (syntax->datum docstring)))))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(#(vector #(each (any . any))) any . each-any)))) + (join-wraps w (syntax-object-wrap e)) + (or (source-annotation e) s) + rib + (or (syntax-object-module e) mod) + for-car?)) + ((self-evaluating? e) (values 'constant #f e e w s mod)) + (else (values 'other #f e e w s mod))))) + (expand + (lambda (e r w mod) + (call-with-values + (lambda () (syntax-type e r w (source-annotation e) #f mod #f)) + (lambda (type value form e w s mod) + (expand-expr type value form e r w s mod))))) + (expand-expr + (lambda (type value form e r w s mod) + (let ((key type)) + (cond ((memv key '(lexical)) (build-lexical-reference 'value s e value)) + ((memv key '(core core-form)) (value e r w s mod)) + ((memv key '(module-ref)) + (call-with-values + (lambda () (value e r w mod)) + (lambda (e r w s mod) (expand e r w mod)))) + ((memv key '(lexical-call)) + (expand-call + (let ((id (car e))) + (build-lexical-reference + 'fun + (source-annotation id) + (if (syntax-object? id) (syntax->datum id) id) + value)) + e + r + w + s + mod)) + ((memv key '(global-call)) + (expand-call + (build-global-reference + (source-annotation (car e)) + (if (syntax-object? value) (syntax-object-expression value) value) + (if (syntax-object? value) (syntax-object-module value) mod)) + e + r + w + s + mod)) + ((memv key '(primitive-call)) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any)))) + (if tmp + (apply (lambda (e) + (build-primcall s value (map (lambda (e) (expand e r w mod)) e))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))) + ((memv key '(constant)) + (build-data s (strip (source-wrap e w s mod) '(())))) + ((memv key '(global)) (build-global-reference s value mod)) + ((memv key '(call)) + (expand-call (expand (car e) r w mod) e r w s mod)) + ((memv key '(begin-form)) + (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any . each-any)))) (if tmp-1 - (apply (lambda (k v e1 e2) - (parse-body - req - opt - rest - kw - (cons e1 e2) - vars - r* - w* - inits - (append meta (syntax->datum (map cons k v))))) + (apply (lambda (e1 e2) (expand-sequence (cons e1 e2) r w s mod)) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . each-any)))) + (let ((tmp-1 ($sc-dispatch tmp '(_)))) (if tmp-1 - (apply (lambda (e1 e2) - (values - meta - req - opt - rest - kw - inits - vars - (expand-body (cons e1 e2) (source-wrap e w s mod) r* w* mod))) + (apply (lambda () + (syntax-violation + #f + "sequence of zero expressions" + (source-wrap e w s mod))) tmp-1) (syntax-violation #f "source expression failed to match any pattern" - tmp)))))))))) - (let* ((tmp clauses) (tmp-1 ($sc-dispatch tmp '()))) - (if tmp-1 - (apply (lambda () (values '() #f)) tmp-1) - (let ((tmp-1 ($sc-dispatch - tmp - '((any any . each-any) . #(each (any any . each-any)))))) - (if tmp-1 - (apply (lambda (args e1 e2 args* e1* e2*) - (call-with-values - (lambda () (get-formals args)) - (lambda (req opt rest kw) - (call-with-values - (lambda () (parse-req req opt rest kw (cons e1 e2))) - (lambda (meta req opt rest kw inits vars body) - (call-with-values - (lambda () - (expand-lambda-case - e - r - w - s - mod - get-formals - (map (lambda (tmp-680b775fb37a463-aef - tmp-680b775fb37a463-aee - tmp-680b775fb37a463-aed) - (cons tmp-680b775fb37a463-aed - (cons tmp-680b775fb37a463-aee tmp-680b775fb37a463-aef))) - e2* - e1* - args*))) - (lambda (meta* else*) - (values - (append meta meta*) - (build-lambda-case s req opt rest kw inits vars body else*))))))))) - tmp-1) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp)))))))) - (strip (lambda (x w) - (if (memq 'top (car w)) - x - (let f ((x x)) - (cond ((syntax-object? x) - (strip (syntax-object-expression x) (syntax-object-wrap x))) - ((pair? x) - (let ((a (f (car x))) (d (f (cdr x)))) - (if (and (eq? a (car x)) (eq? d (cdr x))) x (cons a d)))) - ((vector? x) - (let* ((old (vector->list x)) (new (map f old))) - (let lp ((l1 old) (l2 new)) - (cond ((null? l1) x) - ((eq? (car l1) (car l2)) (lp (cdr l1) (cdr l2))) - (else (list->vector new)))))) - (else x)))))) - (gen-var - (lambda (id) - (let ((id (if (syntax-object? id) (syntax-object-expression id) id))) - (module-gensym (symbol->string id))))) - (lambda-var-list - (lambda (vars) - (let lvl ((vars vars) (ls '()) (w '(()))) - (cond ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w)) - ((id? vars) (cons (wrap vars w #f) ls)) - ((null? vars) ls) - ((syntax-object? vars) - (lvl (syntax-object-expression vars) - ls - (join-wraps w (syntax-object-wrap vars)))) - (else (cons vars ls))))))) - (global-extend 'local-syntax 'letrec-syntax #t) - (global-extend 'local-syntax 'let-syntax #f) - (global-extend - 'core - 'syntax-parameterize - (lambda (e r w s mod) - (let* ((tmp e) - (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) - (if (and tmp (apply (lambda (var val e1 e2) (valid-bound-ids? var)) tmp)) - (apply (lambda (var val e1 e2) - (let ((names (map (lambda (x) - (call-with-values - (lambda () (resolve-identifier x w r mod #f)) - (lambda (type value mod) - (let ((key type)) - (cond ((memv key '(displaced-lexical)) - (syntax-violation - 'syntax-parameterize - "identifier out of context" - e - (source-wrap x w s mod))) - ((memv key '(syntax-parameter)) value) - (else - (syntax-violation - 'syntax-parameterize - "invalid syntax parameter" - e - (source-wrap x w s mod)))))))) - var)) - (bindings - (let ((trans-r (macros-only-env r))) - (map (lambda (x) - (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod))) - val)))) - (expand-body - (cons e1 e2) - (source-wrap e w s mod) - (extend-env names bindings r) - w - mod))) - tmp) - (syntax-violation - 'syntax-parameterize - "bad syntax" - (source-wrap e w s mod)))))) - (global-extend - 'core - 'quote - (lambda (e r w s mod) - (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any)))) - (if tmp - (apply (lambda (e) (build-data s (strip e w))) tmp) - (syntax-violation 'quote "bad syntax" (source-wrap e w s mod)))))) - (global-extend - 'core - 'syntax - (letrec* - ((gen-syntax - (lambda (src e r maps ellipsis? mod) - (if (id? e) - (call-with-values - (lambda () (resolve-identifier e '(()) r mod #f)) - (lambda (type value mod) - (let ((key type)) - (cond ((memv key '(syntax)) - (call-with-values - (lambda () (gen-ref src (car value) (cdr value) maps)) - (lambda (var maps) (values (list 'ref var) maps)))) - ((ellipsis? e r mod) - (syntax-violation 'syntax "misplaced ellipsis" src)) - (else (values (list 'quote e) maps)))))) - (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any)))) - (if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots r mod)) tmp-1)) - (apply (lambda (dots e) (gen-syntax src e r maps (lambda (e r mod) #f) mod)) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any any . any)))) - (if (and tmp-1 (apply (lambda (x dots y) (ellipsis? dots r mod)) tmp-1)) - (apply (lambda (x dots y) - (let f ((y y) - (k (lambda (maps) - (call-with-values - (lambda () (gen-syntax src x r (cons '() maps) ellipsis? mod)) - (lambda (x maps) - (if (null? (car maps)) - (syntax-violation 'syntax "extra ellipsis" src) - (values (gen-map x (car maps)) (cdr maps)))))))) - (let* ((tmp y) (tmp ($sc-dispatch tmp '(any . any)))) - (if (and tmp (apply (lambda (dots y) (ellipsis? dots r mod)) tmp)) - (apply (lambda (dots y) - (f y - (lambda (maps) - (call-with-values - (lambda () (k (cons '() maps))) - (lambda (x maps) - (if (null? (car maps)) - (syntax-violation 'syntax "extra ellipsis" src) - (values (gen-mappend x (car maps)) (cdr maps)))))))) - tmp) - (call-with-values - (lambda () (gen-syntax src y r maps ellipsis? mod)) - (lambda (y maps) - (call-with-values - (lambda () (k maps)) - (lambda (x maps) (values (gen-append x y) maps))))))))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if tmp-1 - (apply (lambda (x y) - (call-with-values - (lambda () (gen-syntax src x r maps ellipsis? mod)) - (lambda (x maps) - (call-with-values - (lambda () (gen-syntax src y r maps ellipsis? mod)) - (lambda (y maps) (values (gen-cons x y) maps)))))) - tmp-1) - (let ((tmp ($sc-dispatch tmp '#(vector (any . each-any))))) - (if tmp - (apply (lambda (e1 e2) - (call-with-values - (lambda () (gen-syntax src (cons e1 e2) r maps ellipsis? mod)) - (lambda (e maps) (values (gen-vector e) maps)))) - tmp) - (values (list 'quote e) maps)))))))))))) - (gen-ref - (lambda (src var level maps) - (cond ((= level 0) (values var maps)) - ((null? maps) (syntax-violation 'syntax "missing ellipsis" src)) + tmp)))))) + ((memv key '(local-syntax-form)) + (expand-local-syntax value e r w s mod expand-sequence)) + ((memv key '(eval-when-form)) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any)))) + (if tmp + (apply (lambda (x e1 e2) + (let ((when-list (parse-when-list e x))) + (if (memq 'eval when-list) + (expand-sequence (cons e1 e2) r w s mod) + (expand-void)))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))) + ((memv key + '(define-form define-syntax-form define-syntax-parameter-form)) + (syntax-violation + #f + "definition in expression context, where definitions are not allowed," + (source-wrap form w s mod))) + ((memv key '(syntax)) + (syntax-violation + #f + "reference to pattern variable outside syntax form" + (source-wrap e w s mod))) + ((memv key '(displaced-lexical)) + (syntax-violation + #f + "reference to identifier outside its scope" + (source-wrap e w s mod))) (else - (call-with-values - (lambda () (gen-ref src var (- level 1) (cdr maps))) - (lambda (outer-var outer-maps) - (let ((b (assq outer-var (car maps)))) - (if b - (values (cdr b) maps) - (let ((inner-var (gen-var 'tmp))) - (values - inner-var - (cons (cons (cons outer-var inner-var) (car maps)) outer-maps))))))))))) - (gen-mappend - (lambda (e map-env) - (list 'apply '(primitive append) (gen-map e map-env)))) - (gen-map - (lambda (e map-env) - (let ((formals (map cdr map-env)) - (actuals (map (lambda (x) (list 'ref (car x))) map-env))) - (cond ((eq? (car e) 'ref) (car actuals)) - ((and-map - (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals))) - (cdr e)) - (cons 'map - (cons (list 'primitive (car e)) - (map (let ((r (map cons formals actuals))) - (lambda (x) (cdr (assq (cadr x) r)))) - (cdr e))))) - (else (cons 'map (cons (list 'lambda formals e) actuals))))))) - (gen-cons - (lambda (x y) - (let ((key (car y))) - (cond ((memv key '(quote)) - (cond ((eq? (car x) 'quote) (list 'quote (cons (cadr x) (cadr y)))) - ((eq? (cadr y) '()) (list 'list x)) - (else (list 'cons x y)))) - ((memv key '(list)) (cons 'list (cons x (cdr y)))) - (else (list 'cons x y)))))) - (gen-append (lambda (x y) (if (equal? y ''()) x (list 'append x y)))) - (gen-vector - (lambda (x) - (cond ((eq? (car x) 'list) (cons 'vector (cdr x))) - ((eq? (car x) 'quote) (list 'quote (list->vector (cadr x)))) - (else (list 'list->vector x))))) - (regen (lambda (x) - (let ((key (car x))) - (cond ((memv key '(ref)) - (build-lexical-reference 'value #f (cadr x) (cadr x))) - ((memv key '(primitive)) (build-primref #f (cadr x))) - ((memv key '(quote)) (build-data #f (cadr x))) - ((memv key '(lambda)) - (if (list? (cadr x)) - (build-simple-lambda #f (cadr x) #f (cadr x) '() (regen (caddr x))) - (error "how did we get here" x))) - (else (build-primcall #f (car x) (map regen (cdr x))))))))) - (lambda (e r w s mod) - (let* ((e (source-wrap e w s mod)) - (tmp e) - (tmp ($sc-dispatch tmp '(_ any)))) - (if tmp - (apply (lambda (x) - (call-with-values - (lambda () (gen-syntax e x r '() ellipsis? mod)) - (lambda (e maps) (regen e)))) - tmp) - (syntax-violation 'syntax "bad `syntax' form" e)))))) - (global-extend - 'core - 'lambda - (lambda (e r w s mod) - (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any)))) - (if tmp - (apply (lambda (args e1 e2) - (call-with-values - (lambda () (lambda-formals args)) - (lambda (req opt rest kw) - (let lp ((body (cons e1 e2)) (meta '())) - (let* ((tmp-1 body) (tmp ($sc-dispatch tmp-1 '(any any . each-any)))) - (if (and tmp - (apply (lambda (docstring e1 e2) (string? (syntax->datum docstring))) - tmp)) - (apply (lambda (docstring e1 e2) - (lp (cons e1 e2) - (append meta (list (cons 'documentation (syntax->datum docstring)))))) - tmp) - (let ((tmp ($sc-dispatch tmp-1 '(#(vector #(each (any . any))) any . each-any)))) - (if tmp - (apply (lambda (k v e1 e2) - (lp (cons e1 e2) (append meta (syntax->datum (map cons k v))))) - tmp) - (expand-simple-lambda e r w s mod req rest meta body))))))))) - tmp) - (syntax-violation 'lambda "bad lambda" e))))) - (global-extend - 'core - 'lambda* - (lambda (e r w s mod) - (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any)))) - (if tmp - (apply (lambda (args e1 e2) - (call-with-values - (lambda () - (expand-lambda-case - e - r - w - s - mod - lambda*-formals - (list (cons args (cons e1 e2))))) - (lambda (meta lcase) (build-case-lambda s meta lcase)))) - tmp) - (syntax-violation 'lambda "bad lambda*" e))))) - (global-extend - 'core - 'case-lambda - (lambda (e r w s mod) - (letrec* - ((build-it - (lambda (meta clauses) - (call-with-values - (lambda () (expand-lambda-case e r w s mod lambda-formals clauses)) - (lambda (meta* lcase) - (build-case-lambda s (append meta meta*) lcase)))))) - (let* ((tmp-1 e) - (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any)))))) - (if tmp - (apply (lambda (args e1 e2) - (build-it - '() - (map (lambda (tmp-680b775fb37a463-cbc - tmp-680b775fb37a463-cbb - tmp-680b775fb37a463-cba) - (cons tmp-680b775fb37a463-cba - (cons tmp-680b775fb37a463-cbb tmp-680b775fb37a463-cbc))) - e2 - e1 - args))) - tmp) - (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any)))))) - (if (and tmp - (apply (lambda (docstring args e1 e2) (string? (syntax->datum docstring))) - tmp)) - (apply (lambda (docstring args e1 e2) - (build-it - (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-680b775fb37a463-cd2 - tmp-680b775fb37a463-cd1 - tmp-680b775fb37a463-cd0) - (cons tmp-680b775fb37a463-cd0 - (cons tmp-680b775fb37a463-cd1 tmp-680b775fb37a463-cd2))) - e2 - e1 - args))) - tmp) - (syntax-violation 'case-lambda "bad case-lambda" e)))))))) - (global-extend - 'core - 'case-lambda* - (lambda (e r w s mod) - (letrec* - ((build-it - (lambda (meta clauses) - (call-with-values - (lambda () (expand-lambda-case e r w s mod lambda*-formals clauses)) - (lambda (meta* lcase) - (build-case-lambda s (append meta meta*) lcase)))))) - (let* ((tmp-1 e) - (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any)))))) - (if tmp - (apply (lambda (args e1 e2) - (build-it - '() - (map (lambda (tmp-680b775fb37a463-cf2 - tmp-680b775fb37a463-cf1 - tmp-680b775fb37a463-cf0) - (cons tmp-680b775fb37a463-cf0 - (cons tmp-680b775fb37a463-cf1 tmp-680b775fb37a463-cf2))) - e2 - e1 - args))) - tmp) - (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any)))))) - (if (and tmp - (apply (lambda (docstring args e1 e2) (string? (syntax->datum docstring))) - tmp)) - (apply (lambda (docstring args e1 e2) - (build-it - (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-680b775fb37a463-d08 - tmp-680b775fb37a463-d07 - tmp-680b775fb37a463-d06) - (cons tmp-680b775fb37a463-d06 - (cons tmp-680b775fb37a463-d07 tmp-680b775fb37a463-d08))) - e2 - e1 - args))) - tmp) - (syntax-violation 'case-lambda "bad case-lambda*" e)))))))) - (global-extend - 'core - 'with-ellipsis - (lambda (e r w s mod) - (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any)))) - (if (and tmp (apply (lambda (dots e1 e2) (id? dots)) tmp)) - (apply (lambda (dots e1 e2) - (let ((id (if (symbol? dots) - '#{ $sc-ellipsis }# - (make-syntax-object - '#{ $sc-ellipsis }# - (syntax-object-wrap dots) - (syntax-object-module dots))))) - (let ((ids (list id)) - (labels (list (gen-label))) - (bindings (list (cons 'ellipsis (source-wrap dots w s mod))))) - (let ((nw (make-binding-wrap ids labels w)) - (nr (extend-env labels bindings r))) - (expand-body (cons e1 e2) (source-wrap e nw s mod) nr nw mod))))) - tmp) - (syntax-violation - 'with-ellipsis - "bad syntax" - (source-wrap e w s mod)))))) - (global-extend - 'core - 'let - (letrec* - ((expand-let - (lambda (e r w s mod constructor ids vals exps) - (if (not (valid-bound-ids? ids)) - (syntax-violation 'let "duplicate bound variable" e) - (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) - (let ((nw (make-binding-wrap ids labels w)) - (nr (extend-var-env labels new-vars r))) - (constructor - s - (map syntax->datum ids) - new-vars - (map (lambda (x) (expand x r w mod)) vals) - (expand-body exps (source-wrap e nw s mod) nr nw mod)))))))) - (lambda (e r w s mod) - (let* ((tmp-1 e) - (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any)))) - (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp)) - (apply (lambda (id val e1 e2) - (expand-let e r w s mod build-let id val (cons e1 e2))) - tmp) - (let ((tmp ($sc-dispatch tmp-1 '(_ any #(each (any any)) any . each-any)))) - (if (and tmp - (apply (lambda (f id val e1 e2) (and (id? f) (and-map id? id))) tmp)) - (apply (lambda (f id val e1 e2) - (expand-let e r w s mod build-named-let (cons f id) val (cons e1 e2))) - tmp) - (syntax-violation 'let "bad let" (source-wrap e w s mod))))))))) - (global-extend - 'core - 'letrec - (lambda (e r w s mod) - (let* ((tmp e) - (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) - (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp)) - (apply (lambda (id val e1 e2) - (let ((ids id)) - (if (not (valid-bound-ids? ids)) - (syntax-violation 'letrec "duplicate bound variable" e) - (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) - (let ((w (make-binding-wrap ids labels w)) - (r (extend-var-env labels new-vars r))) - (build-letrec - s - #f - (map syntax->datum ids) - new-vars - (map (lambda (x) (expand x r w mod)) val) - (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod))))))) - tmp) - (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod)))))) - (global-extend - 'core - 'letrec* - (lambda (e r w s mod) - (let* ((tmp e) - (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) - (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp)) - (apply (lambda (id val e1 e2) - (let ((ids id)) - (if (not (valid-bound-ids? ids)) - (syntax-violation 'letrec* "duplicate bound variable" e) - (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) - (let ((w (make-binding-wrap ids labels w)) - (r (extend-var-env labels new-vars r))) - (build-letrec - s - #t - (map syntax->datum ids) - new-vars - (map (lambda (x) (expand x r w mod)) val) - (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod))))))) - tmp) - (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod)))))) - (global-extend - 'core - 'set! - (lambda (e r w s mod) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any)))) - (if (and tmp (apply (lambda (id val) (id? id)) tmp)) - (apply (lambda (id val) - (call-with-values - (lambda () (resolve-identifier id w r mod #t)) - (lambda (type value id-mod) - (let ((key type)) - (cond ((memv key '(lexical)) - (build-lexical-assignment - s - (syntax->datum id) - value - (expand val r w mod))) - ((memv key '(global)) - (build-global-assignment s value (expand val r w mod) id-mod)) - ((memv key '(macro)) - (if (procedure-property value 'variable-transformer) - (expand (expand-macro value e r w s #f mod) r '(()) mod) + (syntax-violation #f "unexpected syntax" (source-wrap e w s mod))))))) + (expand-call + (lambda (x e r w s mod) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(any . each-any)))) + (if tmp + (apply (lambda (e0 e1) + (build-call s x (map (lambda (e) (expand e r w mod)) e1))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1))))) + (expand-macro + (lambda (p e r w s rib mod) + (letrec* + ((rebuild-macro-output + (lambda (x m) + (cond ((pair? x) + (decorate-source + (cons (rebuild-macro-output (car x) m) + (rebuild-macro-output (cdr x) m)) + s)) + ((syntax-object? x) + (let ((w (syntax-object-wrap x))) + (let ((ms (car w)) (ss (cdr w))) + (if (and (pair? ms) (eq? (car ms) #f)) + (make-syntax-object + (syntax-object-expression x) + (cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss))) + (syntax-object-module x)) + (make-syntax-object + (decorate-source (syntax-object-expression x) s) + (cons (cons m ms) + (if rib (cons rib (cons 'shift ss)) (cons 'shift ss))) + (syntax-object-module x)))))) + ((vector? x) + (let* ((n (vector-length x)) (v (decorate-source (make-vector n) s))) + (let loop ((i 0)) + (if (= i n) + (begin (if #f #f) v) + (begin + (vector-set! v i (rebuild-macro-output (vector-ref x i) m)) + (loop (+ i 1))))))) + ((symbol? x) + (syntax-violation + #f + "encountered raw symbol in macro output" + (source-wrap e w (cdr w) mod) + x)) + (else (decorate-source x s)))))) + (let* ((t-680b775fb37a463-7f9 transformer-environment) + (t-680b775fb37a463-7fa (lambda (k) (k e r w s rib mod)))) + (with-fluid* + t-680b775fb37a463-7f9 + t-680b775fb37a463-7fa + (lambda () + (rebuild-macro-output + (p (source-wrap e (anti-mark w) s mod)) + (module-gensym "m")))))))) + (expand-body + (lambda (body outer-form r w mod) + (let* ((r (cons '("placeholder" placeholder) r)) + (ribcage (make-ribcage '() '() '())) + (w (cons (car w) (cons ribcage (cdr w))))) + (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body)) + (ids '()) + (labels '()) + (var-ids '()) + (vars '()) + (vals '()) + (bindings '())) + (if (null? body) + (syntax-violation #f "no expressions in body" outer-form) + (let ((e (cdar body)) (er (caar body))) + (call-with-values + (lambda () + (syntax-type e er '(()) (source-annotation e) ribcage mod #f)) + (lambda (type value form e w s mod) + (let ((key type)) + (cond ((memv key '(define-form)) + (let ((id (wrap value w mod)) (label (gen-label))) + (let ((var (gen-var id))) + (extend-ribcage! ribcage id label) + (parse (cdr body) + (cons id ids) + (cons label labels) + (cons id var-ids) + (cons var vars) + (cons (cons er (wrap e w mod)) vals) + (cons (cons 'lexical var) bindings))))) + ((memv key '(define-syntax-form)) + (let ((id (wrap value w mod)) + (label (gen-label)) + (trans-r (macros-only-env er))) + (extend-ribcage! ribcage id label) + (set-cdr! + r + (extend-env + (list label) + (list (cons 'macro (eval-local-transformer (expand e trans-r w mod) mod))) + (cdr r))) + (parse (cdr body) (cons id ids) labels var-ids vars vals bindings))) + ((memv key '(define-syntax-parameter-form)) + (let ((id (wrap value w mod)) + (label (gen-label)) + (trans-r (macros-only-env er))) + (extend-ribcage! ribcage id label) + (set-cdr! + r + (extend-env + (list label) + (list (cons 'syntax-parameter + (list (eval-local-transformer (expand e trans-r w mod) mod)))) + (cdr r))) + (parse (cdr body) (cons id ids) labels var-ids vars vals bindings))) + ((memv key '(begin-form)) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any)))) + (if tmp + (apply (lambda (e1) + (parse (let f ((forms e1)) + (if (null? forms) + (cdr body) + (cons (cons er (wrap (car forms) w mod)) (f (cdr forms))))) + ids + labels + var-ids + vars + vals + bindings)) + tmp) (syntax-violation - 'set! - "not a variable transformer" - (wrap e w mod) - (wrap id w id-mod)))) - ((memv key '(displaced-lexical)) - (syntax-violation 'set! "identifier out of context" (wrap id w mod))) - (else (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))))) - tmp) - (let ((tmp ($sc-dispatch tmp-1 '(_ (any . each-any) any)))) - (if tmp - (apply (lambda (head tail val) - (call-with-values - (lambda () (syntax-type head r '(()) #f #f mod #t)) - (lambda (type value ee* ee ww ss modmod) - (let ((key type)) - (if (memv key '(module-ref)) - (let ((val (expand val r w mod))) - (call-with-values - (lambda () (value (cons head tail) r w mod)) - (lambda (e r w s* mod) - (let* ((tmp-1 e) (tmp (list tmp-1))) - (if (and tmp (apply (lambda (e) (id? e)) tmp)) - (apply (lambda (e) (build-global-assignment s (syntax->datum e) val mod)) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))))) - (build-call - s - (expand - (list '#(syntax-object setter ((top)) (hygiene guile)) head) - r - w - mod) - (map (lambda (e) (expand e r w mod)) (append tail (list val))))))))) - tmp) - (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))))) - (global-extend - 'module-ref - '@ - (lambda (e r w mod) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any)))) - (if (and tmp - (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp)) - (apply (lambda (mod id) - (values - (syntax->datum id) - r - '((top)) - #f - (syntax->datum - (cons '#(syntax-object public ((top)) (hygiene guile)) mod)))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))))) - (global-extend - 'module-ref - '@@ - (lambda (e r w mod) - (letrec* - ((remodulate - (lambda (x mod) - (cond ((pair? x) (cons (remodulate (car x) mod) (remodulate (cdr x) mod))) - ((syntax-object? x) + #f + "source expression failed to match any pattern" + tmp-1)))) + ((memv key '(local-syntax-form)) + (expand-local-syntax + value + e + er + w + s + mod + (lambda (forms er w s mod) + (parse (let f ((forms forms)) + (if (null? forms) + (cdr body) + (cons (cons er (wrap (car forms) w mod)) (f (cdr forms))))) + ids + labels + var-ids + vars + vals + bindings)))) + ((null? ids) + (build-sequence + #f + (map (lambda (x) (expand (cdr x) (car x) '(()) mod)) + (cons (cons er (source-wrap e w s mod)) (cdr body))))) + (else + (if (not (valid-bound-ids? ids)) + (syntax-violation + #f + "invalid or duplicate identifier in definition" + outer-form)) + (set-cdr! r (extend-env labels bindings (cdr r))) + (build-letrec + #f + #t + (reverse (map syntax->datum var-ids)) + (reverse vars) + (map (lambda (x) (expand (cdr x) (car x) '(()) mod)) (reverse vals)) + (build-sequence + #f + (map (lambda (x) (expand (cdr x) (car x) '(()) mod)) + (cons (cons er (source-wrap e w s mod)) (cdr body)))))))))))))))) + (expand-local-syntax + (lambda (rec? e r w s mod k) + (let* ((tmp e) + (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) + (if tmp + (apply (lambda (id val e1 e2) + (let ((ids id)) + (if (not (valid-bound-ids? ids)) + (syntax-violation #f "duplicate bound keyword" e) + (let* ((labels (gen-labels ids)) (new-w (make-binding-wrap ids labels w))) + (k (cons e1 e2) + (extend-env + labels + (let ((w (if rec? new-w w)) (trans-r (macros-only-env r))) + (map (lambda (x) + (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod))) + val)) + r) + new-w + s + mod))))) + tmp) + (syntax-violation + #f + "bad local syntax definition" + (source-wrap e w s mod)))))) + (eval-local-transformer + (lambda (expanded mod) + (let ((p (local-eval-hook expanded mod))) + (if (procedure? p) + p + (syntax-violation #f "nonprocedure transformer" p))))) + (expand-void (lambda () (build-void #f))) + (ellipsis? + (lambda (e r mod) + (and (nonsymbol-id? e) + (call-with-values + (lambda () + (resolve-identifier (make-syntax-object - (remodulate (syntax-object-expression x) mod) - (syntax-object-wrap x) - mod)) - ((vector? x) - (let* ((n (vector-length x)) (v (make-vector n))) - (let loop ((i 0)) - (if (= i n) - (begin (if #f #f) v) - (begin - (vector-set! v i (remodulate (vector-ref x i) mod)) - (loop (+ i 1))))))) - (else x))))) - (let* ((tmp e) - (tmp-1 ($sc-dispatch - tmp - '(_ #(free-id #(syntax-object primitive ((top)) (hygiene guile))) any)))) - (if (and tmp-1 - (apply (lambda (id) - (and (id? id) - (equal? - (cdr (if (syntax-object? id) (syntax-object-module id) mod)) - '(guile)))) - tmp-1)) - (apply (lambda (id) (values (syntax->datum id) r '((top)) #f '(primitive))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(_ each-any any)))) - (if (and tmp-1 - (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp-1)) - (apply (lambda (mod id) - (values - (syntax->datum id) - r - '((top)) - #f - (syntax->datum - (cons '#(syntax-object private ((top)) (hygiene guile)) mod)))) - tmp-1) - (let ((tmp-1 ($sc-dispatch - tmp - '(_ #(free-id #(syntax-object @@ ((top)) (hygiene guile))) - each-any - any)))) - (if (and tmp-1 (apply (lambda (mod exp) (and-map id? mod)) tmp-1)) - (apply (lambda (mod exp) - (let ((mod (syntax->datum - (cons '#(syntax-object private ((top)) (hygiene guile)) mod)))) - (values (remodulate exp mod) r w (source-annotation exp) mod))) - tmp-1) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp)))))))))) - (global-extend - 'core - 'if - (lambda (e r w s mod) - (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any)))) - (if tmp-1 - (apply (lambda (test then) - (build-conditional - s - (expand test r w mod) - (expand then r w mod) - (build-void #f))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(_ any any any)))) - (if tmp-1 - (apply (lambda (test then else) - (build-conditional - s - (expand test r w mod) - (expand then r w mod) - (expand else r w mod))) - tmp-1) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp))))))) - (global-extend 'begin 'begin '()) - (global-extend 'define 'define '()) - (global-extend 'define-syntax 'define-syntax '()) - (global-extend 'define-syntax-parameter 'define-syntax-parameter '()) - (global-extend 'eval-when 'eval-when '()) - (global-extend - 'core - 'syntax-case - (letrec* - ((convert-pattern - (lambda (pattern keys ellipsis?) - (letrec* - ((cvt* (lambda (p* n ids) - (let* ((tmp p*) (tmp ($sc-dispatch tmp '(any . any)))) - (if tmp - (apply (lambda (x y) - (call-with-values - (lambda () (cvt* y n ids)) - (lambda (y ids) - (call-with-values - (lambda () (cvt x n ids)) - (lambda (x ids) (values (cons x y) ids)))))) - tmp) - (cvt p* n ids))))) - (v-reverse - (lambda (x) - (let loop ((r '()) (x x)) - (if (not (pair? x)) (values r x) (loop (cons (car x) r) (cdr x)))))) - (cvt (lambda (p n ids) - (if (id? p) - (cond ((bound-id-member? p keys) (values (vector 'free-id p) ids)) - ((free-id=? p '#(syntax-object _ ((top)) (hygiene guile))) - (values '_ ids)) - (else (values 'any (cons (cons p n) ids)))) - (let* ((tmp p) (tmp-1 ($sc-dispatch tmp '(any any)))) - (if (and tmp-1 (apply (lambda (x dots) (ellipsis? dots)) tmp-1)) - (apply (lambda (x dots) - (call-with-values - (lambda () (cvt x (+ n 1) ids)) - (lambda (p ids) - (values (if (eq? p 'any) 'each-any (vector 'each p)) ids)))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any any . any)))) - (if (and tmp-1 (apply (lambda (x dots ys) (ellipsis? dots)) tmp-1)) - (apply (lambda (x dots ys) - (call-with-values - (lambda () (cvt* ys n ids)) - (lambda (ys ids) - (call-with-values - (lambda () (cvt x (+ n 1) ids)) - (lambda (x ids) - (call-with-values - (lambda () (v-reverse ys)) - (lambda (ys e) (values (vector 'each+ x ys e) ids)))))))) + '#{ $sc-ellipsis }# + (syntax-object-wrap e) + (syntax-object-module e)) + '(()) + r + mod + #f)) + (lambda (type value mod) + (if (eq? type 'ellipsis) + (bound-id=? e value) + (free-id=? e '#(syntax-object ... ((top)) (hygiene guile))))))))) + (lambda-formals + (lambda (orig-args) + (letrec* + ((req (lambda (args rreq) + (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '()))) + (if tmp-1 + (apply (lambda () (check (reverse rreq) #f)) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1)) + (apply (lambda (a b) (req b (cons a rreq))) tmp-1) + (let ((tmp-1 (list tmp))) + (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1)) + (apply (lambda (r) (check (reverse rreq) r)) tmp-1) + (let ((else tmp)) + (syntax-violation 'lambda "invalid argument list" orig-args args)))))))))) + (check (lambda (req rest) + (if (distinct-bound-ids? (if rest (cons rest req) req)) + (values req #f rest #f) + (syntax-violation + 'lambda + "duplicate identifier in argument list" + orig-args))))) + (req orig-args '())))) + (expand-simple-lambda + (lambda (e r w s mod req rest meta body) + (let* ((ids (if rest (append req (list rest)) req)) + (vars (map gen-var ids)) + (labels (gen-labels ids))) + (build-simple-lambda + s + (map syntax->datum req) + (and rest (syntax->datum rest)) + vars + meta + (expand-body + body + (source-wrap e w s mod) + (extend-var-env labels vars r) + (make-binding-wrap ids labels w) + mod))))) + (lambda*-formals + (lambda (orig-args) + (letrec* + ((req (lambda (args rreq) + (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '()))) + (if tmp-1 + (apply (lambda () (check (reverse rreq) '() #f '())) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1)) + (apply (lambda (a b) (req b (cons a rreq))) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if (and tmp-1 + (apply (lambda (a b) (eq? (syntax->datum a) #:optional)) tmp-1)) + (apply (lambda (a b) (opt b (reverse rreq) '())) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if (and tmp-1 + (apply (lambda (a b) (eq? (syntax->datum a) #:key)) tmp-1)) + (apply (lambda (a b) (key b (reverse rreq) '() '())) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any any)))) + (if (and tmp-1 + (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1)) + (apply (lambda (a b) (rest b (reverse rreq) '() '())) tmp-1) + (let ((tmp-1 (list tmp))) + (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1)) + (apply (lambda (r) (rest r (reverse rreq) '() '())) tmp-1) + (let ((else tmp)) + (syntax-violation + 'lambda* + "invalid argument list" + orig-args + args)))))))))))))))) + (opt (lambda (args req ropt) + (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '()))) + (if tmp-1 + (apply (lambda () (check req (reverse ropt) #f '())) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1)) + (apply (lambda (a b) (opt b req (cons (cons a '(#f)) ropt))) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '((any any) . any)))) + (if (and tmp-1 (apply (lambda (a init b) (id? a)) tmp-1)) + (apply (lambda (a init b) (opt b req (cons (list a init) ropt))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if tmp-1 - (apply (lambda (x y) - (call-with-values - (lambda () (cvt y n ids)) - (lambda (y ids) - (call-with-values - (lambda () (cvt x n ids)) - (lambda (x ids) (values (cons x y) ids)))))) + (if (and tmp-1 + (apply (lambda (a b) (eq? (syntax->datum a) #:key)) tmp-1)) + (apply (lambda (a b) (key b req (reverse ropt) '())) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any any)))) + (if (and tmp-1 + (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1)) + (apply (lambda (a b) (rest b req (reverse ropt) '())) tmp-1) + (let ((tmp-1 (list tmp))) + (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1)) + (apply (lambda (r) (rest r req (reverse ropt) '())) tmp-1) + (let ((else tmp)) + (syntax-violation + 'lambda* + "invalid optional argument list" + orig-args + args)))))))))))))))) + (key (lambda (args req opt rkey) + (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '()))) + (if tmp-1 + (apply (lambda () (check req opt #f (cons #f (reverse rkey)))) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1)) + (apply (lambda (a b) + (let* ((tmp (symbol->keyword (syntax->datum a))) (k tmp)) + (key b req opt (cons (cons k (cons a '(#f))) rkey)))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '((any any) . any)))) + (if (and tmp-1 (apply (lambda (a init b) (id? a)) tmp-1)) + (apply (lambda (a init b) + (let* ((tmp (symbol->keyword (syntax->datum a))) (k tmp)) + (key b req opt (cons (list k a init) rkey)))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '((any any any) . any)))) + (if (and tmp-1 + (apply (lambda (a init k b) (and (id? a) (keyword? (syntax->datum k)))) + tmp-1)) + (apply (lambda (a init k b) (key b req opt (cons (list k a init) rkey))) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '()))) - (if tmp-1 - (apply (lambda () (values '() ids)) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '#(vector each-any)))) - (if tmp-1 - (apply (lambda (x) - (call-with-values - (lambda () (cvt x n ids)) - (lambda (p ids) (values (vector 'vector p) ids)))) + (let ((tmp-1 ($sc-dispatch tmp '(any)))) + (if (and tmp-1 + (apply (lambda (aok) (eq? (syntax->datum aok) #:allow-other-keys)) + tmp-1)) + (apply (lambda (aok) (check req opt #f (cons #t (reverse rkey)))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any any any)))) + (if (and tmp-1 + (apply (lambda (aok a b) + (and (eq? (syntax->datum aok) #:allow-other-keys) + (eq? (syntax->datum a) #:rest))) + tmp-1)) + (apply (lambda (aok a b) (rest b req opt (cons #t (reverse rkey)))) tmp-1) - (let ((x tmp)) (values (vector 'atom (strip p '(()))) ids)))))))))))))))) - (cvt pattern 0 '())))) - (build-dispatch-call - (lambda (pvars exp y r mod) - (let ((ids (map car pvars)) (levels (map cdr pvars))) - (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) - (build-primcall - #f - 'apply - (list (build-simple-lambda + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if (and tmp-1 + (apply (lambda (aok r) + (and (eq? (syntax->datum aok) #:allow-other-keys) + (id? r))) + tmp-1)) + (apply (lambda (aok r) (rest r req opt (cons #t (reverse rkey)))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any any)))) + (if (and tmp-1 + (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1)) + (apply (lambda (a b) (rest b req opt (cons #f (reverse rkey)))) + tmp-1) + (let ((tmp-1 (list tmp))) + (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1)) + (apply (lambda (r) (rest r req opt (cons #f (reverse rkey)))) + tmp-1) + (let ((else tmp)) + (syntax-violation + 'lambda* + "invalid keyword argument list" + orig-args + args)))))))))))))))))))))) + (rest (lambda (args req opt kw) + (let* ((tmp-1 args) (tmp (list tmp-1))) + (if (and tmp (apply (lambda (r) (id? r)) tmp)) + (apply (lambda (r) (check req opt r kw)) tmp) + (let ((else tmp-1)) + (syntax-violation 'lambda* "invalid rest argument" orig-args args)))))) + (check (lambda (req opt rest kw) + (if (distinct-bound-ids? + (append + req + (map car opt) + (if rest (list rest) '()) + (if (pair? kw) (map cadr (cdr kw)) '()))) + (values req opt rest kw) + (syntax-violation + 'lambda* + "duplicate identifier in argument list" + orig-args))))) + (req orig-args '())))) + (expand-lambda-case + (lambda (e r w s mod get-formals clauses) + (letrec* + ((parse-req + (lambda (req opt rest kw body) + (let ((vars (map gen-var req)) (labels (gen-labels req))) + (let ((r* (extend-var-env labels vars r)) + (w* (make-binding-wrap req labels w))) + (parse-opt + (map syntax->datum req) + opt + rest + kw + body + (reverse vars) + r* + w* + '() + '()))))) + (parse-opt + (lambda (req opt rest kw body vars r* w* out inits) + (cond ((pair? opt) + (let* ((tmp-1 (car opt)) (tmp ($sc-dispatch tmp-1 '(any any)))) + (if tmp + (apply (lambda (id i) + (let* ((v (gen-var id)) + (l (gen-labels (list v))) + (r** (extend-var-env l (list v) r*)) + (w** (make-binding-wrap (list id) l w*))) + (parse-opt + req + (cdr opt) + rest + kw + body + (cons v vars) + r** + w** + (cons (syntax->datum id) out) + (cons (expand i r* w* mod) inits)))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))) + (rest + (let* ((v (gen-var rest)) + (l (gen-labels (list v))) + (r* (extend-var-env l (list v) r*)) + (w* (make-binding-wrap (list rest) l w*))) + (parse-kw + req + (and (pair? out) (reverse out)) + (syntax->datum rest) + (if (pair? kw) (cdr kw) kw) + body + (cons v vars) + r* + w* + (and (pair? kw) (car kw)) + '() + inits))) + (else + (parse-kw + req + (and (pair? out) (reverse out)) #f - (map syntax->datum ids) - #f - new-vars + (if (pair? kw) (cdr kw) kw) + body + vars + r* + w* + (and (pair? kw) (car kw)) '() - (expand - exp - (extend-env - labels - (map (lambda (var level) (cons 'syntax (cons var level))) - new-vars - (map cdr pvars)) - r) - (make-binding-wrap ids labels '(())) - mod)) - y)))))) - (gen-clause - (lambda (x keys clauses r pat fender exp mod) - (call-with-values - (lambda () - (convert-pattern pat keys (lambda (e) (ellipsis? e r mod)))) - (lambda (p pvars) - (cond ((not (and-map (lambda (x) (not (ellipsis? (car x) r mod))) pvars)) - (syntax-violation 'syntax-case "misplaced ellipsis" pat)) - ((not (distinct-bound-ids? (map car pvars))) - (syntax-violation 'syntax-case "duplicate pattern variable" pat)) - (else - (let ((y (gen-var 'tmp))) - (build-call - #f - (build-simple-lambda - #f - (list 'tmp) - #f - (list y) - '() - (let ((y (build-lexical-reference 'value #f 'tmp y))) - (build-conditional - #f - (let* ((tmp fender) (tmp ($sc-dispatch tmp '#(atom #t)))) - (if tmp - (apply (lambda () y) tmp) - (build-conditional - #f - y - (build-dispatch-call pvars fender y r mod) - (build-data #f #f)))) - (build-dispatch-call pvars exp y r mod) - (gen-syntax-case x keys clauses r mod)))) - (list (if (eq? p 'any) - (build-primcall #f 'list (list x)) - (build-primcall #f '$sc-dispatch (list x (build-data #f p))))))))))))) - (gen-syntax-case - (lambda (x keys clauses r mod) - (if (null? clauses) - (build-primcall - #f - 'syntax-violation - (list (build-data #f #f) - (build-data #f "source expression failed to match any pattern") - x)) - (let* ((tmp-1 (car clauses)) (tmp ($sc-dispatch tmp-1 '(any any)))) - (if tmp - (apply (lambda (pat exp) - (if (and (id? pat) - (and-map - (lambda (x) (not (free-id=? pat x))) - (cons '#(syntax-object ... ((top)) (hygiene guile)) keys))) - (if (free-id=? pat '#(syntax-object _ ((top)) (hygiene guile))) - (expand exp r '(()) mod) - (let ((labels (list (gen-label))) (var (gen-var pat))) - (build-call - #f - (build-simple-lambda - #f - (list (syntax->datum pat)) - #f - (list var) - '() - (expand - exp - (extend-env labels (list (cons 'syntax (cons var 0))) r) - (make-binding-wrap (list pat) labels '(())) - mod)) - (list x)))) - (gen-clause x keys (cdr clauses) r pat #t exp mod))) - tmp) - (let ((tmp ($sc-dispatch tmp-1 '(any any any)))) - (if tmp - (apply (lambda (pat fender exp) - (gen-clause x keys (cdr clauses) r pat fender exp mod)) - tmp) - (syntax-violation 'syntax-case "invalid clause" (car clauses)))))))))) + inits))))) + (parse-kw + (lambda (req opt rest kw body vars r* w* aok out inits) + (if (pair? kw) + (let* ((tmp-1 (car kw)) (tmp ($sc-dispatch tmp-1 '(any any any)))) + (if tmp + (apply (lambda (k id i) + (let* ((v (gen-var id)) + (l (gen-labels (list v))) + (r** (extend-var-env l (list v) r*)) + (w** (make-binding-wrap (list id) l w*))) + (parse-kw + req + opt + rest + (cdr kw) + body + (cons v vars) + r** + w** + aok + (cons (list (syntax->datum k) (syntax->datum id) v) out) + (cons (expand i r* w* mod) inits)))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1))) + (parse-body + req + opt + rest + (and (or aok (pair? out)) (cons aok (reverse out))) + body + (reverse vars) + r* + w* + (reverse inits) + '())))) + (parse-body + (lambda (req opt rest kw body vars r* w* inits meta) + (let* ((tmp body) (tmp-1 ($sc-dispatch tmp '(any any . each-any)))) + (if (and tmp-1 + (apply (lambda (docstring e1 e2) (string? (syntax->datum docstring))) + tmp-1)) + (apply (lambda (docstring e1 e2) + (parse-body + req + opt + rest + kw + (cons e1 e2) + vars + r* + w* + inits + (append meta (list (cons 'documentation (syntax->datum docstring)))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(#(vector #(each (any . any))) any . each-any)))) + (if tmp-1 + (apply (lambda (k v e1 e2) + (parse-body + req + opt + rest + kw + (cons e1 e2) + vars + r* + w* + inits + (append meta (syntax->datum (map cons k v))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . each-any)))) + (if tmp-1 + (apply (lambda (e1 e2) + (values + meta + req + opt + rest + kw + inits + vars + (expand-body (cons e1 e2) (source-wrap e w s mod) r* w* mod))) + tmp-1) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp)))))))))) + (let* ((tmp clauses) (tmp-1 ($sc-dispatch tmp '()))) + (if tmp-1 + (apply (lambda () (values '() #f)) tmp-1) + (let ((tmp-1 ($sc-dispatch + tmp + '((any any . each-any) . #(each (any any . each-any)))))) + (if tmp-1 + (apply (lambda (args e1 e2 args* e1* e2*) + (call-with-values + (lambda () (get-formals args)) + (lambda (req opt rest kw) + (call-with-values + (lambda () (parse-req req opt rest kw (cons e1 e2))) + (lambda (meta req opt rest kw inits vars body) + (call-with-values + (lambda () + (expand-lambda-case + e + r + w + s + mod + get-formals + (map (lambda (tmp-680b775fb37a463-aea + tmp-680b775fb37a463-ae9 + tmp-680b775fb37a463-ae8) + (cons tmp-680b775fb37a463-ae8 + (cons tmp-680b775fb37a463-ae9 tmp-680b775fb37a463-aea))) + e2* + e1* + args*))) + (lambda (meta* else*) + (values + (append meta meta*) + (build-lambda-case s req opt rest kw inits vars body else*))))))))) + tmp-1) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp)))))))) + (strip (lambda (x w) + (if (memq 'top (car w)) + x + (let f ((x x)) + (cond ((syntax-object? x) + (strip (syntax-object-expression x) (syntax-object-wrap x))) + ((pair? x) + (let ((a (f (car x))) (d (f (cdr x)))) + (if (and (eq? a (car x)) (eq? d (cdr x))) x (cons a d)))) + ((vector? x) + (let* ((old (vector->list x)) (new (map f old))) + (let lp ((l1 old) (l2 new)) + (cond ((null? l1) x) + ((eq? (car l1) (car l2)) (lp (cdr l1) (cdr l2))) + (else (list->vector new)))))) + (else x)))))) + (gen-var + (lambda (id) + (let ((id (if (syntax-object? id) (syntax-object-expression id) id))) + (module-gensym (symbol->string id))))) + (lambda-var-list + (lambda (vars) + (let lvl ((vars vars) (ls '()) (w '(()))) + (cond ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w)) + ((id? vars) (cons (wrap vars w #f) ls)) + ((null? vars) ls) + ((syntax-object? vars) + (lvl (syntax-object-expression vars) + ls + (join-wraps w (syntax-object-wrap vars)))) + (else (cons vars ls))))))) + (global-extend 'local-syntax 'letrec-syntax #t) + (global-extend 'local-syntax 'let-syntax #f) + (global-extend + 'core + 'syntax-parameterize (lambda (e r w s mod) - (let* ((e (source-wrap e w s mod)) - (tmp-1 e) - (tmp ($sc-dispatch tmp-1 '(_ any each-any . each-any)))) + (let* ((tmp e) + (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) + (if (and tmp (apply (lambda (var val e1 e2) (valid-bound-ids? var)) tmp)) + (apply (lambda (var val e1 e2) + (let ((names (map (lambda (x) + (call-with-values + (lambda () (resolve-identifier x w r mod #f)) + (lambda (type value mod) + (let ((key type)) + (cond ((memv key '(displaced-lexical)) + (syntax-violation + 'syntax-parameterize + "identifier out of context" + e + (source-wrap x w s mod))) + ((memv key '(syntax-parameter)) value) + (else + (syntax-violation + 'syntax-parameterize + "invalid syntax parameter" + e + (source-wrap x w s mod)))))))) + var)) + (bindings + (let ((trans-r (macros-only-env r))) + (map (lambda (x) + (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod))) + val)))) + (expand-body + (cons e1 e2) + (source-wrap e w s mod) + (extend-env names bindings r) + w + mod))) + tmp) + (syntax-violation + 'syntax-parameterize + "bad syntax" + (source-wrap e w s mod)))))) + (global-extend + 'core + 'quote + (lambda (e r w s mod) + (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any)))) (if tmp - (apply (lambda (val key m) - (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod)))) key) - (let ((x (gen-var 'tmp))) - (build-call + (apply (lambda (e) (build-data s (strip e w))) tmp) + (syntax-violation 'quote "bad syntax" (source-wrap e w s mod)))))) + (global-extend + 'core + 'syntax + (letrec* + ((gen-syntax + (lambda (src e r maps ellipsis? mod) + (if (id? e) + (call-with-values + (lambda () (resolve-identifier e '(()) r mod #f)) + (lambda (type value mod) + (let ((key type)) + (cond ((memv key '(syntax)) + (call-with-values + (lambda () (gen-ref src (car value) (cdr value) maps)) + (lambda (var maps) (values (list 'ref var) maps)))) + ((ellipsis? e r mod) + (syntax-violation 'syntax "misplaced ellipsis" src)) + (else (values (list 'quote e) maps)))))) + (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any)))) + (if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots r mod)) tmp-1)) + (apply (lambda (dots e) (gen-syntax src e r maps (lambda (e r mod) #f) mod)) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any any . any)))) + (if (and tmp-1 (apply (lambda (x dots y) (ellipsis? dots r mod)) tmp-1)) + (apply (lambda (x dots y) + (let f ((y y) + (k (lambda (maps) + (call-with-values + (lambda () (gen-syntax src x r (cons '() maps) ellipsis? mod)) + (lambda (x maps) + (if (null? (car maps)) + (syntax-violation 'syntax "extra ellipsis" src) + (values (gen-map x (car maps)) (cdr maps)))))))) + (let* ((tmp y) (tmp ($sc-dispatch tmp '(any . any)))) + (if (and tmp (apply (lambda (dots y) (ellipsis? dots r mod)) tmp)) + (apply (lambda (dots y) + (f y + (lambda (maps) + (call-with-values + (lambda () (k (cons '() maps))) + (lambda (x maps) + (if (null? (car maps)) + (syntax-violation 'syntax "extra ellipsis" src) + (values (gen-mappend x (car maps)) (cdr maps)))))))) + tmp) + (call-with-values + (lambda () (gen-syntax src y r maps ellipsis? mod)) + (lambda (y maps) + (call-with-values + (lambda () (k maps)) + (lambda (x maps) (values (gen-append x y) maps))))))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if tmp-1 + (apply (lambda (x y) + (call-with-values + (lambda () (gen-syntax src x r maps ellipsis? mod)) + (lambda (x maps) + (call-with-values + (lambda () (gen-syntax src y r maps ellipsis? mod)) + (lambda (y maps) (values (gen-cons x y) maps)))))) + tmp-1) + (let ((tmp ($sc-dispatch tmp '#(vector (any . each-any))))) + (if tmp + (apply (lambda (e1 e2) + (call-with-values + (lambda () (gen-syntax src (cons e1 e2) r maps ellipsis? mod)) + (lambda (e maps) (values (gen-vector e) maps)))) + tmp) + (values (list 'quote e) maps)))))))))))) + (gen-ref + (lambda (src var level maps) + (cond ((= level 0) (values var maps)) + ((null? maps) (syntax-violation 'syntax "missing ellipsis" src)) + (else + (call-with-values + (lambda () (gen-ref src var (- level 1) (cdr maps))) + (lambda (outer-var outer-maps) + (let ((b (assq outer-var (car maps)))) + (if b + (values (cdr b) maps) + (let ((inner-var (gen-var 'tmp))) + (values + inner-var + (cons (cons (cons outer-var inner-var) (car maps)) outer-maps))))))))))) + (gen-mappend + (lambda (e map-env) + (list 'apply '(primitive append) (gen-map e map-env)))) + (gen-map + (lambda (e map-env) + (let ((formals (map cdr map-env)) + (actuals (map (lambda (x) (list 'ref (car x))) map-env))) + (cond ((eq? (car e) 'ref) (car actuals)) + ((and-map + (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals))) + (cdr e)) + (cons 'map + (cons (list 'primitive (car e)) + (map (let ((r (map cons formals actuals))) + (lambda (x) (cdr (assq (cadr x) r)))) + (cdr e))))) + (else (cons 'map (cons (list 'lambda formals e) actuals))))))) + (gen-cons + (lambda (x y) + (let ((key (car y))) + (cond ((memv key '(quote)) + (cond ((eq? (car x) 'quote) (list 'quote (cons (cadr x) (cadr y)))) + ((eq? (cadr y) '()) (list 'list x)) + (else (list 'cons x y)))) + ((memv key '(list)) (cons 'list (cons x (cdr y)))) + (else (list 'cons x y)))))) + (gen-append (lambda (x y) (if (equal? y ''()) x (list 'append x y)))) + (gen-vector + (lambda (x) + (cond ((eq? (car x) 'list) (cons 'vector (cdr x))) + ((eq? (car x) 'quote) (list 'quote (list->vector (cadr x)))) + (else (list 'list->vector x))))) + (regen (lambda (x) + (let ((key (car x))) + (cond ((memv key '(ref)) + (build-lexical-reference 'value #f (cadr x) (cadr x))) + ((memv key '(primitive)) (build-primref #f (cadr x))) + ((memv key '(quote)) (build-data #f (cadr x))) + ((memv key '(lambda)) + (if (list? (cadr x)) + (build-simple-lambda #f (cadr x) #f (cadr x) '() (regen (caddr x))) + (error "how did we get here" x))) + (else (build-primcall #f (car x) (map regen (cdr x))))))))) + (lambda (e r w s mod) + (let* ((e (source-wrap e w s mod)) + (tmp e) + (tmp ($sc-dispatch tmp '(_ any)))) + (if tmp + (apply (lambda (x) + (call-with-values + (lambda () (gen-syntax e x r '() ellipsis? mod)) + (lambda (e maps) (regen e)))) + tmp) + (syntax-violation 'syntax "bad `syntax' form" e)))))) + (global-extend + 'core + 'lambda + (lambda (e r w s mod) + (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any)))) + (if tmp + (apply (lambda (args e1 e2) + (call-with-values + (lambda () (lambda-formals args)) + (lambda (req opt rest kw) + (let lp ((body (cons e1 e2)) (meta '())) + (let* ((tmp-1 body) (tmp ($sc-dispatch tmp-1 '(any any . each-any)))) + (if (and tmp + (apply (lambda (docstring e1 e2) (string? (syntax->datum docstring))) + tmp)) + (apply (lambda (docstring e1 e2) + (lp (cons e1 e2) + (append meta (list (cons 'documentation (syntax->datum docstring)))))) + tmp) + (let ((tmp ($sc-dispatch tmp-1 '(#(vector #(each (any . any))) any . each-any)))) + (if tmp + (apply (lambda (k v e1 e2) + (lp (cons e1 e2) (append meta (syntax->datum (map cons k v))))) + tmp) + (expand-simple-lambda e r w s mod req rest meta body))))))))) + tmp) + (syntax-violation 'lambda "bad lambda" e))))) + (global-extend + 'core + 'lambda* + (lambda (e r w s mod) + (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any)))) + (if tmp + (apply (lambda (args e1 e2) + (call-with-values + (lambda () + (expand-lambda-case + e + r + w s - (build-simple-lambda - #f - (list 'tmp) - #f - (list x) - '() - (gen-syntax-case - (build-lexical-reference 'value #f 'tmp x) - key - m - r - mod)) - (list (expand val r '(()) mod)))) - (syntax-violation 'syntax-case "invalid literals list" e))) + mod + lambda*-formals + (list (cons args (cons e1 e2))))) + (lambda (meta lcase) (build-case-lambda s meta lcase)))) + tmp) + (syntax-violation 'lambda "bad lambda*" e))))) + (global-extend + 'core + 'case-lambda + (lambda (e r w s mod) + (letrec* + ((build-it + (lambda (meta clauses) + (call-with-values + (lambda () (expand-lambda-case e r w s mod lambda-formals clauses)) + (lambda (meta* lcase) + (build-case-lambda s (append meta meta*) lcase)))))) + (let* ((tmp-1 e) + (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any)))))) + (if tmp + (apply (lambda (args e1 e2) + (build-it + '() + (map (lambda (tmp-680b775fb37a463-cb7 + tmp-680b775fb37a463-cb6 + tmp-680b775fb37a463-cb5) + (cons tmp-680b775fb37a463-cb5 + (cons tmp-680b775fb37a463-cb6 tmp-680b775fb37a463-cb7))) + e2 + e1 + args))) + tmp) + (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any)))))) + (if (and tmp + (apply (lambda (docstring args e1 e2) (string? (syntax->datum docstring))) + tmp)) + (apply (lambda (docstring args e1 e2) + (build-it + (list (cons 'documentation (syntax->datum docstring))) + (map (lambda (tmp-680b775fb37a463-ccd + tmp-680b775fb37a463-ccc + tmp-680b775fb37a463-ccb) + (cons tmp-680b775fb37a463-ccb + (cons tmp-680b775fb37a463-ccc tmp-680b775fb37a463-ccd))) + e2 + e1 + args))) + tmp) + (syntax-violation 'case-lambda "bad case-lambda" e)))))))) + (global-extend + 'core + 'case-lambda* + (lambda (e r w s mod) + (letrec* + ((build-it + (lambda (meta clauses) + (call-with-values + (lambda () (expand-lambda-case e r w s mod lambda*-formals clauses)) + (lambda (meta* lcase) + (build-case-lambda s (append meta meta*) lcase)))))) + (let* ((tmp-1 e) + (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any)))))) + (if tmp + (apply (lambda (args e1 e2) + (build-it + '() + (map (lambda (tmp-680b775fb37a463-ced + tmp-680b775fb37a463-cec + tmp-680b775fb37a463-ceb) + (cons tmp-680b775fb37a463-ceb + (cons tmp-680b775fb37a463-cec tmp-680b775fb37a463-ced))) + e2 + e1 + args))) + tmp) + (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any)))))) + (if (and tmp + (apply (lambda (docstring args e1 e2) (string? (syntax->datum docstring))) + tmp)) + (apply (lambda (docstring args e1 e2) + (build-it + (list (cons 'documentation (syntax->datum docstring))) + (map (lambda (tmp-680b775fb37a463-d03 + tmp-680b775fb37a463-d02 + tmp-680b775fb37a463-d01) + (cons tmp-680b775fb37a463-d01 + (cons tmp-680b775fb37a463-d02 tmp-680b775fb37a463-d03))) + e2 + e1 + args))) + tmp) + (syntax-violation 'case-lambda "bad case-lambda*" e)))))))) + (global-extend + 'core + 'with-ellipsis + (lambda (e r w s mod) + (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any)))) + (if (and tmp (apply (lambda (dots e1 e2) (id? dots)) tmp)) + (apply (lambda (dots e1 e2) + (let ((id (if (symbol? dots) + '#{ $sc-ellipsis }# + (make-syntax-object + '#{ $sc-ellipsis }# + (syntax-object-wrap dots) + (syntax-object-module dots))))) + (let ((ids (list id)) + (labels (list (gen-label))) + (bindings (list (cons 'ellipsis (source-wrap dots w s mod))))) + (let ((nw (make-binding-wrap ids labels w)) + (nr (extend-env labels bindings r))) + (expand-body (cons e1 e2) (source-wrap e nw s mod) nr nw mod))))) + tmp) + (syntax-violation + 'with-ellipsis + "bad syntax" + (source-wrap e w s mod)))))) + (global-extend + 'core + 'let + (letrec* + ((expand-let + (lambda (e r w s mod constructor ids vals exps) + (if (not (valid-bound-ids? ids)) + (syntax-violation 'let "duplicate bound variable" e) + (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) + (let ((nw (make-binding-wrap ids labels w)) + (nr (extend-var-env labels new-vars r))) + (constructor + s + (map syntax->datum ids) + new-vars + (map (lambda (x) (expand x r w mod)) vals) + (expand-body exps (source-wrap e nw s mod) nr nw mod)))))))) + (lambda (e r w s mod) + (let* ((tmp-1 e) + (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any)))) + (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp)) + (apply (lambda (id val e1 e2) + (expand-let e r w s mod build-let id val (cons e1 e2))) + tmp) + (let ((tmp ($sc-dispatch tmp-1 '(_ any #(each (any any)) any . each-any)))) + (if (and tmp + (apply (lambda (f id val e1 e2) (and (id? f) (and-map id? id))) tmp)) + (apply (lambda (f id val e1 e2) + (expand-let e r w s mod build-named-let (cons f id) val (cons e1 e2))) + tmp) + (syntax-violation 'let "bad let" (source-wrap e w s mod))))))))) + (global-extend + 'core + 'letrec + (lambda (e r w s mod) + (let* ((tmp e) + (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) + (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp)) + (apply (lambda (id val e1 e2) + (let ((ids id)) + (if (not (valid-bound-ids? ids)) + (syntax-violation 'letrec "duplicate bound variable" e) + (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) + (let ((w (make-binding-wrap ids labels w)) + (r (extend-var-env labels new-vars r))) + (build-letrec + s + #f + (map syntax->datum ids) + new-vars + (map (lambda (x) (expand x r w mod)) val) + (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod))))))) + tmp) + (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod)))))) + (global-extend + 'core + 'letrec* + (lambda (e r w s mod) + (let* ((tmp e) + (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) + (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp)) + (apply (lambda (id val e1 e2) + (let ((ids id)) + (if (not (valid-bound-ids? ids)) + (syntax-violation 'letrec* "duplicate bound variable" e) + (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) + (let ((w (make-binding-wrap ids labels w)) + (r (extend-var-env labels new-vars r))) + (build-letrec + s + #t + (map syntax->datum ids) + new-vars + (map (lambda (x) (expand x r w mod)) val) + (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod))))))) + tmp) + (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod)))))) + (global-extend + 'core + 'set! + (lambda (e r w s mod) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any)))) + (if (and tmp (apply (lambda (id val) (id? id)) tmp)) + (apply (lambda (id val) + (call-with-values + (lambda () (resolve-identifier id w r mod #t)) + (lambda (type value id-mod) + (let ((key type)) + (cond ((memv key '(lexical)) + (build-lexical-assignment + s + (syntax->datum id) + value + (expand val r w mod))) + ((memv key '(global)) + (build-global-assignment s value (expand val r w mod) id-mod)) + ((memv key '(macro)) + (if (procedure-property value 'variable-transformer) + (expand (expand-macro value e r w s #f mod) r '(()) mod) + (syntax-violation + 'set! + "not a variable transformer" + (wrap e w mod) + (wrap id w id-mod)))) + ((memv key '(displaced-lexical)) + (syntax-violation 'set! "identifier out of context" (wrap id w mod))) + (else (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))))) + tmp) + (let ((tmp ($sc-dispatch tmp-1 '(_ (any . each-any) any)))) + (if tmp + (apply (lambda (head tail val) + (call-with-values + (lambda () (syntax-type head r '(()) #f #f mod #t)) + (lambda (type value ee* ee ww ss modmod) + (let ((key type)) + (if (memv key '(module-ref)) + (let ((val (expand val r w mod))) + (call-with-values + (lambda () (value (cons head tail) r w mod)) + (lambda (e r w s* mod) + (let* ((tmp-1 e) (tmp (list tmp-1))) + (if (and tmp (apply (lambda (e) (id? e)) tmp)) + (apply (lambda (e) (build-global-assignment s (syntax->datum e) val mod)) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))))) + (build-call + s + (expand + (list '#(syntax-object setter ((top)) (hygiene guile)) head) + r + w + mod) + (map (lambda (e) (expand e r w mod)) (append tail (list val))))))))) + tmp) + (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))))) + (global-extend + 'module-ref + '@ + (lambda (e r w mod) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any)))) + (if (and tmp + (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp)) + (apply (lambda (mod id) + (values + (syntax->datum id) + r + '((top)) + #f + (syntax->datum + (cons '#(syntax-object public ((top)) (hygiene guile)) mod)))) tmp) (syntax-violation #f "source expression failed to match any pattern" - tmp-1)))))) - (set! macroexpand - (lambda* (x #:optional (m 'e) (esew '(eval))) - (expand-top-sequence - (list x) - '() - '((top)) - #f - m - esew - (cons 'hygiene (module-name (current-module)))))) - (set! identifier? (lambda (x) (nonsymbol-id? x))) - (set! datum->syntax - (lambda (id datum) - (make-syntax-object - datum - (syntax-object-wrap id) - (syntax-object-module id)))) - (set! syntax->datum (lambda (x) (strip x '(())))) - (set! syntax-source (lambda (x) (source-annotation x))) - (set! generate-temporaries - (lambda (ls) - (let ((x ls)) - (if (not (list? x)) - (syntax-violation 'generate-temporaries "invalid argument" x))) - (let ((mod (cons 'hygiene (module-name (current-module))))) - (map (lambda (x) (wrap (module-gensym "t") '((top)) mod)) ls)))) - (set! free-identifier=? - (lambda (x y) - (let ((x x)) - (if (not (nonsymbol-id? x)) - (syntax-violation 'free-identifier=? "invalid argument" x))) - (let ((x y)) - (if (not (nonsymbol-id? x)) - (syntax-violation 'free-identifier=? "invalid argument" x))) - (free-id=? x y))) - (set! bound-identifier=? - (lambda (x y) - (let ((x x)) - (if (not (nonsymbol-id? x)) - (syntax-violation 'bound-identifier=? "invalid argument" x))) - (let ((x y)) - (if (not (nonsymbol-id? x)) - (syntax-violation 'bound-identifier=? "invalid argument" x))) - (bound-id=? x y))) - (set! syntax-violation - (lambda* (who message form #:optional (subform #f)) - (let ((x who)) - (if (not (let ((x x)) (or (not x) (string? x) (symbol? x)))) - (syntax-violation 'syntax-violation "invalid argument" x))) - (let ((x message)) - (if (not (string? x)) - (syntax-violation 'syntax-violation "invalid argument" x))) - (throw 'syntax-error - who - message - (or (source-annotation subform) (source-annotation form)) - (strip form '(())) - (and subform (strip subform '(())))))) - (letrec* - ((%syntax-module - (lambda (id) - (let ((x id)) - (if (not (nonsymbol-id? x)) - (syntax-violation 'syntax-module "invalid argument" x))) - (let ((mod (syntax-object-module id))) - (and (not (equal? mod '(primitive))) (cdr mod))))) - (syntax-local-binding - (lambda* (id - #:key - (resolve-syntax-parameters? #t #:resolve-syntax-parameters?)) - (let ((x id)) - (if (not (nonsymbol-id? x)) - (syntax-violation 'syntax-local-binding "invalid argument" x))) - (with-transformer-environment - (lambda (e r w s rib mod) + tmp-1))))) + (global-extend + 'module-ref + '@@ + (lambda (e r w mod) + (letrec* + ((remodulate + (lambda (x mod) + (cond ((pair? x) (cons (remodulate (car x) mod) (remodulate (cdr x) mod))) + ((syntax-object? x) + (make-syntax-object + (remodulate (syntax-object-expression x) mod) + (syntax-object-wrap x) + mod)) + ((vector? x) + (let* ((n (vector-length x)) (v (make-vector n))) + (let loop ((i 0)) + (if (= i n) + (begin (if #f #f) v) + (begin + (vector-set! v i (remodulate (vector-ref x i) mod)) + (loop (+ i 1))))))) + (else x))))) + (let* ((tmp e) + (tmp-1 ($sc-dispatch + tmp + '(_ #(free-id #(syntax-object primitive ((top)) (hygiene guile))) any)))) + (if (and tmp-1 + (apply (lambda (id) + (and (id? id) + (equal? + (cdr (if (syntax-object? id) (syntax-object-module id) mod)) + '(guile)))) + tmp-1)) + (apply (lambda (id) (values (syntax->datum id) r '((top)) #f '(primitive))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(_ each-any any)))) + (if (and tmp-1 + (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp-1)) + (apply (lambda (mod id) + (values + (syntax->datum id) + r + '((top)) + #f + (syntax->datum + (cons '#(syntax-object private ((top)) (hygiene guile)) mod)))) + tmp-1) + (let ((tmp-1 ($sc-dispatch + tmp + '(_ #(free-id #(syntax-object @@ ((top)) (hygiene guile))) + each-any + any)))) + (if (and tmp-1 (apply (lambda (mod exp) (and-map id? mod)) tmp-1)) + (apply (lambda (mod exp) + (let ((mod (syntax->datum + (cons '#(syntax-object private ((top)) (hygiene guile)) mod)))) + (values (remodulate exp mod) r w (source-annotation exp) mod))) + tmp-1) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp)))))))))) + (global-extend + 'core + 'if + (lambda (e r w s mod) + (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any)))) + (if tmp-1 + (apply (lambda (test then) + (build-conditional + s + (expand test r w mod) + (expand then r w mod) + (build-void #f))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(_ any any any)))) + (if tmp-1 + (apply (lambda (test then else) + (build-conditional + s + (expand test r w mod) + (expand then r w mod) + (expand else r w mod))) + tmp-1) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp))))))) + (global-extend 'begin 'begin '()) + (global-extend 'define 'define '()) + (global-extend 'define-syntax 'define-syntax '()) + (global-extend 'define-syntax-parameter 'define-syntax-parameter '()) + (global-extend 'eval-when 'eval-when '()) + (global-extend + 'core + 'syntax-case + (letrec* + ((convert-pattern + (lambda (pattern keys ellipsis?) (letrec* - ((strip-anti-mark - (lambda (w) - (let ((ms (car w)) (s (cdr w))) - (if (and (pair? ms) (eq? (car ms) #f)) - (cons (cdr ms) (if rib (cons rib (cdr s)) (cdr s))) - (cons ms (if rib (cons rib s) s))))))) - (call-with-values - (lambda () - (resolve-identifier - (syntax-object-expression id) - (strip-anti-mark (syntax-object-wrap id)) - r - (syntax-object-module id) - resolve-syntax-parameters?)) - (lambda (type value mod) - (let ((key type)) - (cond ((memv key '(lexical)) (values 'lexical value)) - ((memv key '(macro)) (values 'macro value)) - ((memv key '(syntax-parameter)) - (values 'syntax-parameter (car value))) - ((memv key '(syntax)) (values 'pattern-variable value)) - ((memv key '(displaced-lexical)) (values 'displaced-lexical #f)) - ((memv key '(global)) - (if (equal? mod '(primitive)) - (values 'primitive value) - (values 'global (cons value (cdr mod))))) - ((memv key '(ellipsis)) - (values - 'ellipsis - (make-syntax-object - (syntax-object-expression value) - (anti-mark (syntax-object-wrap value)) - (syntax-object-module value)))) - (else (values 'other #f))))))))))) - (syntax-locally-bound-identifiers - (lambda (id) - (let ((x id)) - (if (not (nonsymbol-id? x)) - (syntax-violation - 'syntax-locally-bound-identifiers - "invalid argument" - x))) - (locally-bound-identifiers - (syntax-object-wrap id) - (syntax-object-module id))))) - (define! '%syntax-module %syntax-module) - (define! 'syntax-local-binding syntax-local-binding) - (define! - 'syntax-locally-bound-identifiers - syntax-locally-bound-identifiers)) - (letrec* - ((match-each - (lambda (e p w mod) - (cond ((pair? e) - (let ((first (match (car e) p w '() mod))) - (and first - (let ((rest (match-each (cdr e) p w mod))) - (and rest (cons first rest)))))) - ((null? e) '()) - ((syntax-object? e) - (match-each - (syntax-object-expression e) - p - (join-wraps w (syntax-object-wrap e)) - (syntax-object-module e))) - (else #f)))) - (match-each+ - (lambda (e x-pat y-pat z-pat w r mod) - (let f ((e e) (w w)) - (cond ((pair? e) - (call-with-values - (lambda () (f (cdr e) w)) - (lambda (xr* y-pat r) - (if r - (if (null? y-pat) - (let ((xr (match (car e) x-pat w '() mod))) - (if xr (values (cons xr xr*) y-pat r) (values #f #f #f))) - (values '() (cdr y-pat) (match (car e) (car y-pat) w r mod))) - (values #f #f #f))))) - ((syntax-object? e) - (f (syntax-object-expression e) - (join-wraps w (syntax-object-wrap e)))) - (else (values '() y-pat (match e z-pat w r mod))))))) - (match-each-any - (lambda (e w mod) - (cond ((pair? e) - (let ((l (match-each-any (cdr e) w mod))) - (and l (cons (wrap (car e) w mod) l)))) - ((null? e) '()) - ((syntax-object? e) - (match-each-any - (syntax-object-expression e) - (join-wraps w (syntax-object-wrap e)) - mod)) - (else #f)))) - (match-empty - (lambda (p r) - (cond ((null? p) r) - ((eq? p '_) r) - ((eq? p 'any) (cons '() r)) - ((pair? p) (match-empty (car p) (match-empty (cdr p) r))) - ((eq? p 'each-any) (cons '() r)) - (else - (let ((key (vector-ref p 0))) - (cond ((memv key '(each)) (match-empty (vector-ref p 1) r)) - ((memv key '(each+)) - (match-empty - (vector-ref p 1) - (match-empty - (reverse (vector-ref p 2)) - (match-empty (vector-ref p 3) r)))) - ((memv key '(free-id atom)) r) - ((memv key '(vector)) (match-empty (vector-ref p 1) r)))))))) - (combine - (lambda (r* r) - (if (null? (car r*)) r (cons (map car r*) (combine (map cdr r*) r))))) - (match* - (lambda (e p w r mod) - (cond ((null? p) (and (null? e) r)) - ((pair? p) - (and (pair? e) - (match (car e) (car p) w (match (cdr e) (cdr p) w r mod) mod))) - ((eq? p 'each-any) - (let ((l (match-each-any e w mod))) (and l (cons l r)))) - (else - (let ((key (vector-ref p 0))) - (cond ((memv key '(each)) - (if (null? e) - (match-empty (vector-ref p 1) r) - (let ((l (match-each e (vector-ref p 1) w mod))) - (and l - (let collect ((l l)) - (if (null? (car l)) r (cons (map car l) (collect (map cdr l))))))))) - ((memv key '(each+)) - (call-with-values - (lambda () - (match-each+ - e - (vector-ref p 1) - (vector-ref p 2) - (vector-ref p 3) - w - r - mod)) - (lambda (xr* y-pat r) - (and r - (null? y-pat) - (if (null? xr*) (match-empty (vector-ref p 1) r) (combine xr* r)))))) - ((memv key '(free-id)) - (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r)) - ((memv key '(atom)) (and (equal? (vector-ref p 1) (strip e w)) r)) - ((memv key '(vector)) - (and (vector? e) (match (vector->list e) (vector-ref p 1) w r mod))))))))) - (match (lambda (e p w r mod) - (cond ((not r) #f) - ((eq? p '_) r) - ((eq? p 'any) (cons (wrap e w mod) r)) - ((syntax-object? e) - (match* - (syntax-object-expression e) - p - (join-wraps w (syntax-object-wrap e)) + ((cvt* (lambda (p* n ids) + (let* ((tmp p*) (tmp ($sc-dispatch tmp '(any . any)))) + (if tmp + (apply (lambda (x y) + (call-with-values + (lambda () (cvt* y n ids)) + (lambda (y ids) + (call-with-values + (lambda () (cvt x n ids)) + (lambda (x ids) (values (cons x y) ids)))))) + tmp) + (cvt p* n ids))))) + (v-reverse + (lambda (x) + (let loop ((r '()) (x x)) + (if (not (pair? x)) (values r x) (loop (cons (car x) r) (cdr x)))))) + (cvt (lambda (p n ids) + (if (id? p) + (cond ((bound-id-member? p keys) (values (vector 'free-id p) ids)) + ((free-id=? p '#(syntax-object _ ((top)) (hygiene guile))) + (values '_ ids)) + (else (values 'any (cons (cons p n) ids)))) + (let* ((tmp p) (tmp-1 ($sc-dispatch tmp '(any any)))) + (if (and tmp-1 (apply (lambda (x dots) (ellipsis? dots)) tmp-1)) + (apply (lambda (x dots) + (call-with-values + (lambda () (cvt x (+ n 1) ids)) + (lambda (p ids) + (values (if (eq? p 'any) 'each-any (vector 'each p)) ids)))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any any . any)))) + (if (and tmp-1 (apply (lambda (x dots ys) (ellipsis? dots)) tmp-1)) + (apply (lambda (x dots ys) + (call-with-values + (lambda () (cvt* ys n ids)) + (lambda (ys ids) + (call-with-values + (lambda () (cvt x (+ n 1) ids)) + (lambda (x ids) + (call-with-values + (lambda () (v-reverse ys)) + (lambda (ys e) (values (vector 'each+ x ys e) ids)))))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if tmp-1 + (apply (lambda (x y) + (call-with-values + (lambda () (cvt y n ids)) + (lambda (y ids) + (call-with-values + (lambda () (cvt x n ids)) + (lambda (x ids) (values (cons x y) ids)))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '()))) + (if tmp-1 + (apply (lambda () (values '() ids)) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '#(vector each-any)))) + (if tmp-1 + (apply (lambda (x) + (call-with-values + (lambda () (cvt x n ids)) + (lambda (p ids) (values (vector 'vector p) ids)))) + tmp-1) + (let ((x tmp)) (values (vector 'atom (strip p '(()))) ids)))))))))))))))) + (cvt pattern 0 '())))) + (build-dispatch-call + (lambda (pvars exp y r mod) + (let ((ids (map car pvars)) (levels (map cdr pvars))) + (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) + (build-primcall + #f + 'apply + (list (build-simple-lambda + #f + (map syntax->datum ids) + #f + new-vars + '() + (expand + exp + (extend-env + labels + (map (lambda (var level) (cons 'syntax (cons var level))) + new-vars + (map cdr pvars)) + r) + (make-binding-wrap ids labels '(())) + mod)) + y)))))) + (gen-clause + (lambda (x keys clauses r pat fender exp mod) + (call-with-values + (lambda () + (convert-pattern pat keys (lambda (e) (ellipsis? e r mod)))) + (lambda (p pvars) + (cond ((not (and-map (lambda (x) (not (ellipsis? (car x) r mod))) pvars)) + (syntax-violation 'syntax-case "misplaced ellipsis" pat)) + ((not (distinct-bound-ids? (map car pvars))) + (syntax-violation 'syntax-case "duplicate pattern variable" pat)) + (else + (let ((y (gen-var 'tmp))) + (build-call + #f + (build-simple-lambda + #f + (list 'tmp) + #f + (list y) + '() + (let ((y (build-lexical-reference 'value #f 'tmp y))) + (build-conditional + #f + (let* ((tmp fender) (tmp ($sc-dispatch tmp '#(atom #t)))) + (if tmp + (apply (lambda () y) tmp) + (build-conditional + #f + y + (build-dispatch-call pvars fender y r mod) + (build-data #f #f)))) + (build-dispatch-call pvars exp y r mod) + (gen-syntax-case x keys clauses r mod)))) + (list (if (eq? p 'any) + (build-primcall #f 'list (list x)) + (build-primcall #f '$sc-dispatch (list x (build-data #f p))))))))))))) + (gen-syntax-case + (lambda (x keys clauses r mod) + (if (null? clauses) + (build-primcall + #f + 'syntax-violation + (list (build-data #f #f) + (build-data #f "source expression failed to match any pattern") + x)) + (let* ((tmp-1 (car clauses)) (tmp ($sc-dispatch tmp-1 '(any any)))) + (if tmp + (apply (lambda (pat exp) + (if (and (id? pat) + (and-map + (lambda (x) (not (free-id=? pat x))) + (cons '#(syntax-object ... ((top)) (hygiene guile)) keys))) + (if (free-id=? pat '#(syntax-object _ ((top)) (hygiene guile))) + (expand exp r '(()) mod) + (let ((labels (list (gen-label))) (var (gen-var pat))) + (build-call + #f + (build-simple-lambda + #f + (list (syntax->datum pat)) + #f + (list var) + '() + (expand + exp + (extend-env labels (list (cons 'syntax (cons var 0))) r) + (make-binding-wrap (list pat) labels '(())) + mod)) + (list x)))) + (gen-clause x keys (cdr clauses) r pat #t exp mod))) + tmp) + (let ((tmp ($sc-dispatch tmp-1 '(any any any)))) + (if tmp + (apply (lambda (pat fender exp) + (gen-clause x keys (cdr clauses) r pat fender exp mod)) + tmp) + (syntax-violation 'syntax-case "invalid clause" (car clauses)))))))))) + (lambda (e r w s mod) + (let* ((e (source-wrap e w s mod)) + (tmp-1 e) + (tmp ($sc-dispatch tmp-1 '(_ any each-any . each-any)))) + (if tmp + (apply (lambda (val key m) + (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod)))) key) + (let ((x (gen-var 'tmp))) + (build-call + s + (build-simple-lambda + #f + (list 'tmp) + #f + (list x) + '() + (gen-syntax-case + (build-lexical-reference 'value #f 'tmp x) + key + m + r + mod)) + (list (expand val r '(()) mod)))) + (syntax-violation 'syntax-case "invalid literals list" e))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))))) + (set! macroexpand + (lambda* (x #:optional (m 'e) (esew '(eval))) + (expand-top-sequence + (list x) + '() + '((top)) + #f + m + esew + (cons 'hygiene (module-name (current-module)))))) + (set! identifier? (lambda (x) (nonsymbol-id? x))) + (set! datum->syntax + (lambda (id datum) + (make-syntax-object + datum + (syntax-object-wrap id) + (syntax-object-module id)))) + (set! syntax->datum (lambda (x) (strip x '(())))) + (set! syntax-source (lambda (x) (source-annotation x))) + (set! generate-temporaries + (lambda (ls) + (let ((x ls)) + (if (not (list? x)) + (syntax-violation 'generate-temporaries "invalid argument" x))) + (let ((mod (cons 'hygiene (module-name (current-module))))) + (map (lambda (x) (wrap (module-gensym "t") '((top)) mod)) ls)))) + (set! free-identifier=? + (lambda (x y) + (let ((x x)) + (if (not (nonsymbol-id? x)) + (syntax-violation 'free-identifier=? "invalid argument" x))) + (let ((x y)) + (if (not (nonsymbol-id? x)) + (syntax-violation 'free-identifier=? "invalid argument" x))) + (free-id=? x y))) + (set! bound-identifier=? + (lambda (x y) + (let ((x x)) + (if (not (nonsymbol-id? x)) + (syntax-violation 'bound-identifier=? "invalid argument" x))) + (let ((x y)) + (if (not (nonsymbol-id? x)) + (syntax-violation 'bound-identifier=? "invalid argument" x))) + (bound-id=? x y))) + (set! syntax-violation + (lambda* (who message form #:optional (subform #f)) + (let ((x who)) + (if (not (let ((x x)) (or (not x) (string? x) (symbol? x)))) + (syntax-violation 'syntax-violation "invalid argument" x))) + (let ((x message)) + (if (not (string? x)) + (syntax-violation 'syntax-violation "invalid argument" x))) + (throw 'syntax-error + who + message + (or (source-annotation subform) (source-annotation form)) + (strip form '(())) + (and subform (strip subform '(())))))) + (letrec* + ((%syntax-module + (lambda (id) + (let ((x id)) + (if (not (nonsymbol-id? x)) + (syntax-violation 'syntax-module "invalid argument" x))) + (let ((mod (syntax-object-module id))) + (and (not (equal? mod '(primitive))) (cdr mod))))) + (syntax-local-binding + (lambda* (id + #:key + (resolve-syntax-parameters? #t #:resolve-syntax-parameters?)) + (let ((x id)) + (if (not (nonsymbol-id? x)) + (syntax-violation 'syntax-local-binding "invalid argument" x))) + (with-transformer-environment + (lambda (e r w s rib mod) + (letrec* + ((strip-anti-mark + (lambda (w) + (let ((ms (car w)) (s (cdr w))) + (if (and (pair? ms) (eq? (car ms) #f)) + (cons (cdr ms) (if rib (cons rib (cdr s)) (cdr s))) + (cons ms (if rib (cons rib s) s))))))) + (call-with-values + (lambda () + (resolve-identifier + (syntax-object-expression id) + (strip-anti-mark (syntax-object-wrap id)) r - (syntax-object-module e))) - (else (match* e p w r mod)))))) - (set! $sc-dispatch - (lambda (e p) - (cond ((eq? p 'any) (list e)) - ((eq? p '_) '()) - ((syntax-object? e) - (match* - (syntax-object-expression e) - p - (syntax-object-wrap e) - '() - (syntax-object-module e))) - (else (match* e p '(()) '() #f))))))) + (syntax-object-module id) + resolve-syntax-parameters?)) + (lambda (type value mod) + (let ((key type)) + (cond ((memv key '(lexical)) (values 'lexical value)) + ((memv key '(macro)) (values 'macro value)) + ((memv key '(syntax-parameter)) + (values 'syntax-parameter (car value))) + ((memv key '(syntax)) (values 'pattern-variable value)) + ((memv key '(displaced-lexical)) (values 'displaced-lexical #f)) + ((memv key '(global)) + (if (equal? mod '(primitive)) + (values 'primitive value) + (values 'global (cons value (cdr mod))))) + ((memv key '(ellipsis)) + (values + 'ellipsis + (make-syntax-object + (syntax-object-expression value) + (anti-mark (syntax-object-wrap value)) + (syntax-object-module value)))) + (else (values 'other #f))))))))))) + (syntax-locally-bound-identifiers + (lambda (id) + (let ((x id)) + (if (not (nonsymbol-id? x)) + (syntax-violation + 'syntax-locally-bound-identifiers + "invalid argument" + x))) + (locally-bound-identifiers + (syntax-object-wrap id) + (syntax-object-module id))))) + (define! '%syntax-module %syntax-module) + (define! 'syntax-local-binding syntax-local-binding) + (define! + 'syntax-locally-bound-identifiers + syntax-locally-bound-identifiers)) + (letrec* + ((match-each + (lambda (e p w mod) + (cond ((pair? e) + (let ((first (match (car e) p w '() mod))) + (and first + (let ((rest (match-each (cdr e) p w mod))) + (and rest (cons first rest)))))) + ((null? e) '()) + ((syntax-object? e) + (match-each + (syntax-object-expression e) + p + (join-wraps w (syntax-object-wrap e)) + (syntax-object-module e))) + (else #f)))) + (match-each+ + (lambda (e x-pat y-pat z-pat w r mod) + (let f ((e e) (w w)) + (cond ((pair? e) + (call-with-values + (lambda () (f (cdr e) w)) + (lambda (xr* y-pat r) + (if r + (if (null? y-pat) + (let ((xr (match (car e) x-pat w '() mod))) + (if xr (values (cons xr xr*) y-pat r) (values #f #f #f))) + (values '() (cdr y-pat) (match (car e) (car y-pat) w r mod))) + (values #f #f #f))))) + ((syntax-object? e) + (f (syntax-object-expression e) + (join-wraps w (syntax-object-wrap e)))) + (else (values '() y-pat (match e z-pat w r mod))))))) + (match-each-any + (lambda (e w mod) + (cond ((pair? e) + (let ((l (match-each-any (cdr e) w mod))) + (and l (cons (wrap (car e) w mod) l)))) + ((null? e) '()) + ((syntax-object? e) + (match-each-any + (syntax-object-expression e) + (join-wraps w (syntax-object-wrap e)) + mod)) + (else #f)))) + (match-empty + (lambda (p r) + (cond ((null? p) r) + ((eq? p '_) r) + ((eq? p 'any) (cons '() r)) + ((pair? p) (match-empty (car p) (match-empty (cdr p) r))) + ((eq? p 'each-any) (cons '() r)) + (else + (let ((key (vector-ref p 0))) + (cond ((memv key '(each)) (match-empty (vector-ref p 1) r)) + ((memv key '(each+)) + (match-empty + (vector-ref p 1) + (match-empty + (reverse (vector-ref p 2)) + (match-empty (vector-ref p 3) r)))) + ((memv key '(free-id atom)) r) + ((memv key '(vector)) (match-empty (vector-ref p 1) r)))))))) + (combine + (lambda (r* r) + (if (null? (car r*)) r (cons (map car r*) (combine (map cdr r*) r))))) + (match* + (lambda (e p w r mod) + (cond ((null? p) (and (null? e) r)) + ((pair? p) + (and (pair? e) + (match (car e) (car p) w (match (cdr e) (cdr p) w r mod) mod))) + ((eq? p 'each-any) + (let ((l (match-each-any e w mod))) (and l (cons l r)))) + (else + (let ((key (vector-ref p 0))) + (cond ((memv key '(each)) + (if (null? e) + (match-empty (vector-ref p 1) r) + (let ((l (match-each e (vector-ref p 1) w mod))) + (and l + (let collect ((l l)) + (if (null? (car l)) r (cons (map car l) (collect (map cdr l))))))))) + ((memv key '(each+)) + (call-with-values + (lambda () + (match-each+ + e + (vector-ref p 1) + (vector-ref p 2) + (vector-ref p 3) + w + r + mod)) + (lambda (xr* y-pat r) + (and r + (null? y-pat) + (if (null? xr*) (match-empty (vector-ref p 1) r) (combine xr* r)))))) + ((memv key '(free-id)) + (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r)) + ((memv key '(atom)) (and (equal? (vector-ref p 1) (strip e w)) r)) + ((memv key '(vector)) + (and (vector? e) (match (vector->list e) (vector-ref p 1) w r mod))))))))) + (match (lambda (e p w r mod) + (cond ((not r) #f) + ((eq? p '_) r) + ((eq? p 'any) (cons (wrap e w mod) r)) + ((syntax-object? e) + (match* + (syntax-object-expression e) + p + (join-wraps w (syntax-object-wrap e)) + r + (syntax-object-module e))) + (else (match* e p w r mod)))))) + (set! $sc-dispatch + (lambda (e p) + (cond ((eq? p 'any) (list e)) + ((eq? p '_) '()) + ((syntax-object? e) + (match* + (syntax-object-expression e) + p + (syntax-object-wrap e) + '() + (syntax-object-module e))) + (else (match* e p '(()) '() #f)))))))) (define with-syntax (make-syntax-transformer @@ -2806,11 +2814,9 @@ #f k '() - (map (lambda (tmp-680b775fb37a463-115b - tmp-680b775fb37a463-115a - tmp-680b775fb37a463) - (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-115a) - tmp-680b775fb37a463-115b)) + (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) + tmp-680b775fb37a463-2)) template pattern keyword))) @@ -2826,9 +2832,11 @@ #f k (list docstring) - (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) - (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) - tmp-680b775fb37a463-2)) + (map (lambda (tmp-680b775fb37a463-116f + tmp-680b775fb37a463-116e + tmp-680b775fb37a463-116d) + (list (cons tmp-680b775fb37a463-116d tmp-680b775fb37a463-116e) + tmp-680b775fb37a463-116f)) template pattern keyword))) @@ -2843,11 +2851,9 @@ dots k '() - (map (lambda (tmp-680b775fb37a463-118d - tmp-680b775fb37a463-118c - tmp-680b775fb37a463-118b) - (list (cons tmp-680b775fb37a463-118b tmp-680b775fb37a463-118c) - tmp-680b775fb37a463-118d)) + (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) + tmp-680b775fb37a463-2)) template pattern keyword))) @@ -2863,11 +2869,11 @@ dots k (list docstring) - (map (lambda (tmp-680b775fb37a463-11ac - tmp-680b775fb37a463-11ab - tmp-680b775fb37a463-11aa) - (list (cons tmp-680b775fb37a463-11aa tmp-680b775fb37a463-11ab) - tmp-680b775fb37a463-11ac)) + (map (lambda (tmp-680b775fb37a463-11a7 + tmp-680b775fb37a463-11a6 + tmp-680b775fb37a463-11a5) + (list (cons tmp-680b775fb37a463-11a5 tmp-680b775fb37a463-11a6) + tmp-680b775fb37a463-11a7)) template pattern keyword))) @@ -3007,8 +3013,8 @@ (apply (lambda (p) (if (= lev 0) (quasilist* - (map (lambda (tmp-680b775fb37a463) - (list "value" tmp-680b775fb37a463)) + (map (lambda (tmp-680b775fb37a463-120f) + (list "value" tmp-680b775fb37a463-120f)) p) (quasi q lev)) (quasicons @@ -3063,8 +3069,8 @@ (apply (lambda (p) (if (= lev 0) (quasilist* - (map (lambda (tmp-680b775fb37a463-122f) - (list "value" tmp-680b775fb37a463-122f)) + (map (lambda (tmp-680b775fb37a463-122a) + (list "value" tmp-680b775fb37a463-122a)) p) (vquasi q lev)) (quasicons @@ -3082,7 +3088,8 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp-680b775fb37a463) (list "value" tmp-680b775fb37a463)) + (map (lambda (tmp-680b775fb37a463-122f) + (list "value" tmp-680b775fb37a463-122f)) p) (vquasi q lev)) (quasicons @@ -3171,8 +3178,7 @@ (let ((tmp-1 ls)) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-127d) - (cons "vector" t-680b775fb37a463-127d)) + (apply (lambda (t-680b775fb37a463) (cons "vector" t-680b775fb37a463)) tmp) (syntax-violation #f @@ -3207,9 +3213,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-12a7) + (apply (lambda (t-680b775fb37a463-12a2) (cons '#(syntax-object list ((top)) (hygiene guile)) - t-680b775fb37a463-12a7)) + t-680b775fb37a463-12a2)) tmp) (syntax-violation #f @@ -3225,10 +3231,10 @@ (let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp ($sc-dispatch tmp-1 '(any any)))) (if tmp - (apply (lambda (t-680b775fb37a463-12bb t-680b775fb37a463-12ba) + (apply (lambda (t-680b775fb37a463-12b6 t-680b775fb37a463-12b5) (list '#(syntax-object cons ((top)) (hygiene guile)) - t-680b775fb37a463-12bb - t-680b775fb37a463-12ba)) + t-680b775fb37a463-12b6 + t-680b775fb37a463-12b5)) tmp) (syntax-violation #f @@ -3241,9 +3247,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-12c7) + (apply (lambda (t-680b775fb37a463-12c2) (cons '#(syntax-object append ((top)) (hygiene guile)) - t-680b775fb37a463-12c7)) + t-680b775fb37a463-12c2)) tmp) (syntax-violation #f @@ -3256,9 +3262,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-12d3) + (apply (lambda (t-680b775fb37a463-12ce) (cons '#(syntax-object vector ((top)) (hygiene guile)) - t-680b775fb37a463-12d3)) + t-680b775fb37a463-12ce)) tmp) (syntax-violation #f @@ -3269,9 +3275,9 @@ (if tmp-1 (apply (lambda (x) (let ((tmp (emit x))) - (let ((t-680b775fb37a463-12df tmp)) + (let ((t-680b775fb37a463-12da tmp)) (list '#(syntax-object list->vector ((top)) (hygiene guile)) - t-680b775fb37a463-12df)))) + t-680b775fb37a463-12da)))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) (if tmp-1 diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 567f6065b..678d08b97 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -165,7 +165,12 @@ (eval-when (compile) (set-current-module (resolve-module '(guile)))) -(let () +(let ((syntax? (module-ref (current-module) 'syntax?)) + (make-syntax (module-ref (current-module) 'make-syntax)) + (syntax-expression (module-ref (current-module) 'syntax-expression)) + (syntax-wrap (module-ref (current-module) 'syntax-wrap)) + (syntax-module (module-ref (current-module) 'syntax-module))) + (define-syntax define-expansion-constructors (lambda (x) (syntax-case x () @@ -466,7 +471,25 @@ ;; 'gensym' so that the generated identifier is reproducible. (module-gensym (symbol->string id))) - (define-structure (syntax-object expression wrap module)) + (define (syntax-object? x) + (or (syntax? x) + (and (vector? x) + (= (vector-length x) 4) + (eqv? (vector-ref x 0) 'syntax-object)))) + (define (make-syntax-object expression wrap module) + (vector 'syntax-object expression wrap module)) + (define (syntax-object-expression obj) + (if (syntax? obj) + (syntax-expression obj) + (vector-ref obj 1))) + (define (syntax-object-wrap obj) + (if (syntax? obj) + (syntax-wrap obj) + (vector-ref obj 2))) + (define (syntax-object-module obj) + (if (syntax? obj) + (syntax-module obj) + (vector-ref obj 3))) (define-syntax no-source (identifier-syntax #f)) From a42bfae65f445178d3608433356ce132d1e7369e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 27 Mar 2017 22:22:19 +0200 Subject: [PATCH 818/865] Psyntax generates new syntax objects * module/ice-9/psyntax.scm (make-syntax-object): Change to make new-style syntax objects. * module/ice-9/psyntax-pp.scm: Regenerate. * module/ice-9/compile-psyntax.scm (squeeze-syntax-object): Change to be functional. (squeeze-constant): Likewise. (squeeze-tree-il): Likewise. (translate-literal-syntax-objects): New pass. The compiler can embed literal syntax objects into compiled objects, but syntax can no longer be read/written; otherwise users could forge syntax objects. So for the bootstrap phase, rewrite literal constants to calls to make-syntax. --- module/ice-9/compile-psyntax.scm | 136 ++- module/ice-9/psyntax-pp.scm | 1669 +++++++++++++++--------------- module/ice-9/psyntax.scm | 2 +- 3 files changed, 950 insertions(+), 857 deletions(-) diff --git a/module/ice-9/compile-psyntax.scm b/module/ice-9/compile-psyntax.scm index 21d639fa1..44cdbbe9b 100644 --- a/module/ice-9/compile-psyntax.scm +++ b/module/ice-9/compile-psyntax.scm @@ -20,67 +20,132 @@ (language tree-il primitives) (language tree-il canonicalize) (srfi srfi-1) + (ice-9 control) (ice-9 pretty-print) - (system syntax)) + (system syntax internal)) ;; Minimize a syntax-object such that it can no longer be used as the ;; first argument to 'datum->syntax', but is otherwise equivalent. -(define (squeeze-syntax-object! syn) +(define (squeeze-syntax-object syn) (define (ensure-list x) (if (vector? x) (vector->list x) x)) - (let ((x (vector-ref syn 1)) - (wrap (vector-ref syn 2)) - (mod (vector-ref syn 3))) + (let ((x (syntax-expression syn)) + (wrap (syntax-wrap syn)) + (mod (syntax-module syn))) (let ((marks (car wrap)) (subst (cdr wrap))) - (define (set-wrap! marks subst) - (vector-set! syn 2 (cons marks subst))) + (define (squeeze-wrap marks subst) + (make-syntax x (cons marks subst) mod)) (cond ((symbol? x) (let loop ((marks marks) (subst subst)) (cond - ((null? subst) (set-wrap! marks subst) syn) + ((null? subst) (squeeze-wrap marks subst)) ((eq? 'shift (car subst)) (loop (cdr marks) (cdr subst))) ((find (lambda (entry) (and (eq? x (car entry)) (equal? marks (cadr entry)))) (apply map list (map ensure-list (cdr (vector->list (car subst)))))) => (lambda (entry) - (set-wrap! marks - (list (list->vector - (cons 'ribcage - (map vector entry))))) - syn)) + (squeeze-wrap marks + (list (list->vector + (cons 'ribcage + (map vector entry))))))) (else (loop marks (cdr subst)))))) - ((or (pair? x) (vector? x)) - syn) + ((or (pair? x) (vector? x)) syn) (else x))))) -(define (squeeze-constant! x) - (define (syntax-object? x) - (and (vector? x) - (= 4 (vector-length x)) - (eq? 'syntax-object (vector-ref x 0)))) - (cond ((syntax-object? x) - (squeeze-syntax-object! x)) +(define (squeeze-constant x) + (cond ((syntax? x) (squeeze-syntax-object x)) ((pair? x) - (set-car! x (squeeze-constant! (car x))) - (set-cdr! x (squeeze-constant! (cdr x))) - x) + (cons (squeeze-constant (car x)) + (squeeze-constant (cdr x)))) ((vector? x) - (for-each (lambda (i) - (vector-set! x i (squeeze-constant! (vector-ref x i)))) - (iota (vector-length x))) - x) + (list->vector (squeeze-constant (vector->list x)))) (else x))) (define (squeeze-tree-il x) (post-order (lambda (x) (if (const? x) (make-const (const-src x) - (squeeze-constant! (const-exp x))) + (squeeze-constant (const-exp x))) x)) x)) +(define (translate-literal-syntax-objects x) + (define (find-make-syntax-lexical-binding x) + (let/ec return + (pre-order (lambda (x) + (when (let? x) + (for-each (lambda (name sym) + (when (eq? name 'make-syntax) + (return sym))) + (let-names x) (let-gensyms x))) + x) + x) + #f)) + (let ((make-syntax-gensym (find-make-syntax-lexical-binding x)) + (retry-tag (make-prompt-tag))) + (define (translate-constant x) + (let ((src (const-src x)) + (exp (const-exp x))) + (cond + ((list? exp) + (let ((exp (map (lambda (x) + (translate-constant (make-const src x))) + exp))) + (if (and-map const? exp) + x + (make-primcall src 'list exp)))) + ((pair? exp) + (let ((car (translate-constant (make-const src (car exp)))) + (cdr (translate-constant (make-const src (cdr exp))))) + (if (and (const? car) (const? cdr)) + x + (make-primcall src 'cons (list car cdr))))) + ((vector? exp) + (let ((exp (map (lambda (x) + (translate-constant (make-const src x))) + (vector->list exp)))) + (if (and-map const? exp) + x + (make-primcall src 'vector exp)))) + ((syntax? exp) + (make-call src + (if make-syntax-gensym + (make-lexical-ref src 'make-syntax + make-syntax-gensym) + (abort-to-prompt retry-tag)) + (list + (translate-constant + (make-const src (syntax-expression exp))) + (translate-constant + (make-const src (syntax-wrap exp))) + (translate-constant + (make-const src (syntax-module exp)))))) + (else x)))) + (call-with-prompt retry-tag + (lambda () + (post-order (lambda (x) + (if (const? x) + (translate-constant x) + x)) + x)) + (lambda (k) + ;; OK, we have a syntax object embedded in this code, but + ;; make-syntax isn't lexically bound. This is the case for the + ;; top-level macro definitions in psyntax that follow the main + ;; let blob. Attach a lexical binding and retry. + (unless (toplevel-define? x) (error "unexpected")) + (translate-literal-syntax-objects + (make-toplevel-define + (toplevel-define-src x) + (toplevel-define-name x) + (make-let (toplevel-define-src x) + (list 'make-syntax) + (list (module-gensym)) + (list (make-toplevel-ref #f 'make-syntax)) + (toplevel-define-exp x)))))))) + ;; Avoid gratuitous churn in psyntax-pp.scm due to the marks and labels ;; changing session identifiers. (set! syntax-session-id (lambda () "*")) @@ -99,11 +164,12 @@ (close-port in)) (begin (pretty-print (tree-il->scheme - (squeeze-tree-il - (canonicalize - (resolve-primitives - (macroexpand x 'c '(compile load eval)) - (current-module)))) + (translate-literal-syntax-objects + (squeeze-tree-il + (canonicalize + (resolve-primitives + (macroexpand x 'c '(compile load eval)) + (current-module))))) (current-module) (list #:avoid-lambda? #f #:use-case? #f diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index a26545aa6..d2c5a26d3 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -246,7 +246,7 @@ (eqv? (vector-ref x 0) 'syntax-object))))) (make-syntax-object (lambda (expression wrap module) - (vector 'syntax-object expression wrap module))) + (make-syntax expression wrap module))) (syntax-object-expression (lambda (obj) (if (syntax? obj) (syntax-expression obj) (vector-ref obj 1)))) @@ -792,7 +792,7 @@ (wrap name w mod) (wrap e w mod) (decorate-source - (cons '#(syntax-object lambda ((top)) (hygiene guile)) + (cons (make-syntax 'lambda '((top)) '(hygiene guile)) (wrap (cons args (cons e1 e2)) w mod)) s) '(()) @@ -806,7 +806,7 @@ 'define-form (wrap name w mod) (wrap e w mod) - '(#(syntax-object if ((top)) (hygiene guile)) #f #f) + (list (make-syntax 'if '((top)) '(hygiene guile)) #f #f) '(()) s mod)) @@ -1174,7 +1174,7 @@ (lambda (type value mod) (if (eq? type 'ellipsis) (bound-id=? e value) - (free-id=? e '#(syntax-object ... ((top)) (hygiene guile))))))))) + (free-id=? e (make-syntax '... '((top)) '(hygiene guile))))))))) (lambda-formals (lambda (orig-args) (letrec* @@ -2067,7 +2067,7 @@ (build-call s (expand - (list '#(syntax-object setter ((top)) (hygiene guile)) head) + (list (make-syntax 'setter '((top)) '(hygiene guile)) head) r w mod) @@ -2088,7 +2088,7 @@ '((top)) #f (syntax->datum - (cons '#(syntax-object public ((top)) (hygiene guile)) mod)))) + (cons (make-syntax 'public '((top)) '(hygiene guile)) mod)))) tmp) (syntax-violation #f @@ -2119,7 +2119,9 @@ (let* ((tmp e) (tmp-1 ($sc-dispatch tmp - '(_ #(free-id #(syntax-object primitive ((top)) (hygiene guile))) any)))) + (list '_ + (vector 'free-id (make-syntax 'primitive '((top)) '(hygiene guile))) + 'any)))) (if (and tmp-1 (apply (lambda (id) (and (id? id) @@ -2139,17 +2141,18 @@ '((top)) #f (syntax->datum - (cons '#(syntax-object private ((top)) (hygiene guile)) mod)))) + (cons (make-syntax 'private '((top)) '(hygiene guile)) mod)))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp - '(_ #(free-id #(syntax-object @@ ((top)) (hygiene guile))) - each-any - any)))) + (list '_ + (vector 'free-id (make-syntax '@@ '((top)) '(hygiene guile))) + 'each-any + 'any)))) (if (and tmp-1 (apply (lambda (mod exp) (and-map id? mod)) tmp-1)) (apply (lambda (mod exp) (let ((mod (syntax->datum - (cons '#(syntax-object private ((top)) (hygiene guile)) mod)))) + (cons (make-syntax 'private '((top)) '(hygiene guile)) mod)))) (values (remodulate exp mod) r w (source-annotation exp) mod))) tmp-1) (syntax-violation @@ -2213,7 +2216,7 @@ (cvt (lambda (p n ids) (if (id? p) (cond ((bound-id-member? p keys) (values (vector 'free-id p) ids)) - ((free-id=? p '#(syntax-object _ ((top)) (hygiene guile))) + ((free-id=? p (make-syntax '_ '((top)) '(hygiene guile))) (values '_ ids)) (else (values 'any (cons (cons p n) ids)))) (let* ((tmp p) (tmp-1 ($sc-dispatch tmp '(any any)))) @@ -2334,8 +2337,8 @@ (if (and (id? pat) (and-map (lambda (x) (not (free-id=? pat x))) - (cons '#(syntax-object ... ((top)) (hygiene guile)) keys))) - (if (free-id=? pat '#(syntax-object _ ((top)) (hygiene guile))) + (cons (make-syntax '... '((top)) '(hygiene guile)) keys))) + (if (free-id=? pat (make-syntax '_ '((top)) '(hygiene guile))) (expand exp r '(()) mod) (let ((labels (list (gen-label))) (var (gen-var pat))) (build-call @@ -2644,733 +2647,751 @@ (else (match* e p '(()) '() #f)))))))) (define with-syntax - (make-syntax-transformer - 'with-syntax - 'macro - (lambda (x) - (let ((tmp x)) - (let ((tmp-1 ($sc-dispatch tmp '(_ () any . each-any)))) - (if tmp-1 - (apply (lambda (e1 e2) - (cons '#(syntax-object let ((top)) (hygiene guile)) - (cons '() (cons e1 e2)))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(_ ((any any)) any . each-any)))) - (if tmp-1 - (apply (lambda (out in e1 e2) - (list '#(syntax-object syntax-case ((top)) (hygiene guile)) - in - '() - (list out - (cons '#(syntax-object let ((top)) (hygiene guile)) - (cons '() (cons e1 e2)))))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) - (if tmp-1 - (apply (lambda (out in e1 e2) - (list '#(syntax-object syntax-case ((top)) (hygiene guile)) - (cons '#(syntax-object list ((top)) (hygiene guile)) in) - '() - (list out - (cons '#(syntax-object let ((top)) (hygiene guile)) - (cons '() (cons e1 e2)))))) - tmp-1) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp))))))))))) + (let ((make-syntax make-syntax)) + (make-syntax-transformer + 'with-syntax + 'macro + (lambda (x) + (let ((tmp x)) + (let ((tmp-1 ($sc-dispatch tmp '(_ () any . each-any)))) + (if tmp-1 + (apply (lambda (e1 e2) + (cons (make-syntax 'let '((top)) '(hygiene guile)) + (cons '() (cons e1 e2)))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(_ ((any any)) any . each-any)))) + (if tmp-1 + (apply (lambda (out in e1 e2) + (list (make-syntax 'syntax-case '((top)) '(hygiene guile)) + in + '() + (list out + (cons (make-syntax 'let '((top)) '(hygiene guile)) + (cons '() (cons e1 e2)))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) + (if tmp-1 + (apply (lambda (out in e1 e2) + (list (make-syntax 'syntax-case '((top)) '(hygiene guile)) + (cons (make-syntax 'list '((top)) '(hygiene guile)) in) + '() + (list out + (cons (make-syntax 'let '((top)) '(hygiene guile)) + (cons '() (cons e1 e2)))))) + tmp-1) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp)))))))))))) (define syntax-error - (make-syntax-transformer - 'syntax-error - 'macro - (lambda (x) - (let ((tmp-1 x)) - (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any)))) - (if (if tmp - (apply (lambda (keyword operands message arg) - (string? (syntax->datum message))) - tmp) - #f) - (apply (lambda (keyword operands message arg) - (syntax-violation - (syntax->datum keyword) - (string-join - (cons (syntax->datum message) - (map (lambda (x) (object->string (syntax->datum x))) arg))) - (if (syntax->datum keyword) (cons keyword operands) #f))) - tmp) - (let ((tmp ($sc-dispatch tmp-1 '(_ any . each-any)))) - (if (if tmp - (apply (lambda (message arg) (string? (syntax->datum message))) tmp) - #f) - (apply (lambda (message arg) - (cons '#(syntax-object - syntax-error - ((top) - #(ribcage - #(syntax-error) - #((top)) - #(((hygiene guile) - . - #(syntax-object syntax-error ((top)) (hygiene guile)))))) - (hygiene guile)) - (cons '(#f) (cons message arg)))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))))))))) + (let ((make-syntax make-syntax)) + (make-syntax-transformer + 'syntax-error + 'macro + (lambda (x) + (let ((tmp-1 x)) + (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any)))) + (if (if tmp + (apply (lambda (keyword operands message arg) + (string? (syntax->datum message))) + tmp) + #f) + (apply (lambda (keyword operands message arg) + (syntax-violation + (syntax->datum keyword) + (string-join + (cons (syntax->datum message) + (map (lambda (x) (object->string (syntax->datum x))) arg))) + (if (syntax->datum keyword) (cons keyword operands) #f))) + tmp) + (let ((tmp ($sc-dispatch tmp-1 '(_ any . each-any)))) + (if (if tmp + (apply (lambda (message arg) (string? (syntax->datum message))) tmp) + #f) + (apply (lambda (message arg) + (cons (make-syntax + 'syntax-error + (list '(top) + (vector + 'ribcage + '#(syntax-error) + '#((top)) + (vector + (cons '(hygiene guile) + (make-syntax 'syntax-error '((top)) '(hygiene guile)))))) + '(hygiene guile)) + (cons '(#f) (cons message arg)))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))))))))) (define syntax-rules - (make-syntax-transformer - 'syntax-rules - 'macro - (lambda (xx) - (letrec* - ((expand-clause - (lambda (clause) - (let ((tmp-1 clause)) - (let ((tmp ($sc-dispatch - tmp-1 - '((any . any) - (#(free-id #(syntax-object syntax-error ((top)) (hygiene guile))) - any - . - each-any))))) - (if (if tmp - (apply (lambda (keyword pattern message arg) - (string? (syntax->datum message))) - tmp) - #f) - (apply (lambda (keyword pattern message arg) - (list (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern) - (list '#(syntax-object syntax ((top)) (hygiene guile)) - (cons '#(syntax-object syntax-error ((top)) (hygiene guile)) - (cons (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern) - (cons message arg)))))) - tmp) - (let ((tmp ($sc-dispatch tmp-1 '((any . any) any)))) - (if tmp - (apply (lambda (keyword pattern template) - (list (cons '#(syntax-object dummy ((top)) (hygiene guile)) pattern) - (list '#(syntax-object syntax ((top)) (hygiene guile)) template))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))))))) - (expand-syntax-rules - (lambda (dots keys docstrings clauses) - (let ((tmp-1 (list keys docstrings clauses (map expand-clause clauses)))) - (let ((tmp ($sc-dispatch - tmp-1 - '(each-any each-any #(each ((any . any) any)) each-any)))) - (if tmp - (apply (lambda (k docstring keyword pattern template clause) - (let ((tmp (cons '#(syntax-object lambda ((top)) (hygiene guile)) - (cons '(#(syntax-object x ((top)) (hygiene guile))) - (append - docstring - (list (vector - '(#(syntax-object macro-type ((top)) (hygiene guile)) - . - #(syntax-object - syntax-rules - ((top) - #(ribcage - #(syntax-rules) - #((top)) - #(((hygiene guile) - . - #(syntax-object - syntax-rules - ((top)) - (hygiene guile)))))) - (hygiene guile))) - (cons '#(syntax-object patterns ((top)) (hygiene guile)) - pattern)) - (cons '#(syntax-object syntax-case ((top)) (hygiene guile)) - (cons '#(syntax-object x ((top)) (hygiene guile)) - (cons k clause))))))))) - (let ((form tmp)) - (if dots - (let ((tmp dots)) - (let ((dots tmp)) - (list '#(syntax-object with-ellipsis ((top)) (hygiene guile)) - dots - form))) - form)))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))))))) - (let ((tmp xx)) - (let ((tmp-1 ($sc-dispatch tmp '(_ each-any . #(each ((any . any) any)))))) - (if tmp-1 - (apply (lambda (k keyword pattern template) - (expand-syntax-rules - #f - k - '() - (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) - (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) - tmp-680b775fb37a463-2)) - template - pattern - keyword))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(_ each-any any . #(each ((any . any) any)))))) - (if (if tmp-1 - (apply (lambda (k docstring keyword pattern template) - (string? (syntax->datum docstring))) - tmp-1) - #f) - (apply (lambda (k docstring keyword pattern template) - (expand-syntax-rules - #f - k - (list docstring) - (map (lambda (tmp-680b775fb37a463-116f - tmp-680b775fb37a463-116e - tmp-680b775fb37a463-116d) - (list (cons tmp-680b775fb37a463-116d tmp-680b775fb37a463-116e) - tmp-680b775fb37a463-116f)) - template - pattern - keyword))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(_ any each-any . #(each ((any . any) any)))))) - (if (if tmp-1 - (apply (lambda (dots k keyword pattern template) (identifier? dots)) - tmp-1) - #f) - (apply (lambda (dots k keyword pattern template) - (expand-syntax-rules - dots - k - '() - (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) - (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) - tmp-680b775fb37a463-2)) - template - pattern - keyword))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(_ any each-any any . #(each ((any . any) any)))))) - (if (if tmp-1 - (apply (lambda (dots k docstring keyword pattern template) - (if (identifier? dots) (string? (syntax->datum docstring)) #f)) - tmp-1) - #f) - (apply (lambda (dots k docstring keyword pattern template) - (expand-syntax-rules - dots - k - (list docstring) - (map (lambda (tmp-680b775fb37a463-11a7 - tmp-680b775fb37a463-11a6 - tmp-680b775fb37a463-11a5) - (list (cons tmp-680b775fb37a463-11a5 tmp-680b775fb37a463-11a6) - tmp-680b775fb37a463-11a7)) - template - pattern - keyword))) - tmp-1) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp)))))))))))))) - -(define define-syntax-rule - (make-syntax-transformer - 'define-syntax-rule - 'macro - (lambda (x) - (let ((tmp-1 x)) - (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any)))) - (if tmp - (apply (lambda (name pattern template) - (list '#(syntax-object define-syntax ((top)) (hygiene guile)) - name - (list '#(syntax-object syntax-rules ((top)) (hygiene guile)) - '() - (list (cons '#(syntax-object _ ((top)) (hygiene guile)) pattern) - template)))) - tmp) - (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any any)))) - (if (if tmp - (apply (lambda (name pattern docstring template) - (string? (syntax->datum docstring))) - tmp) - #f) - (apply (lambda (name pattern docstring template) - (list '#(syntax-object define-syntax ((top)) (hygiene guile)) - name - (list '#(syntax-object syntax-rules ((top)) (hygiene guile)) - '() - docstring - (list (cons '#(syntax-object _ ((top)) (hygiene guile)) pattern) - template)))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))))))))) - -(define let* - (make-syntax-transformer - 'let* - 'macro - (lambda (x) - (let ((tmp-1 x)) - (let ((tmp ($sc-dispatch tmp-1 '(any #(each (any any)) any . each-any)))) - (if (if tmp - (apply (lambda (let* x v e1 e2) (and-map identifier? x)) tmp) - #f) - (apply (lambda (let* x v e1 e2) - (let f ((bindings (map list x v))) - (if (null? bindings) - (cons '#(syntax-object let ((top)) (hygiene guile)) - (cons '() (cons e1 e2))) - (let ((tmp-1 (list (f (cdr bindings)) (car bindings)))) - (let ((tmp ($sc-dispatch tmp-1 '(any any)))) - (if tmp - (apply (lambda (body binding) - (list '#(syntax-object let ((top)) (hygiene guile)) - (list binding) - body)) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))))))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))))))) - -(define quasiquote - (make-syntax-transformer - 'quasiquote - 'macro - (letrec* - ((quasi (lambda (p lev) - (let ((tmp p)) - (let ((tmp-1 ($sc-dispatch - tmp - '(#(free-id #(syntax-object unquote ((top)) (hygiene guile))) any)))) - (if tmp-1 - (apply (lambda (p) - (if (= lev 0) - (list "value" p) - (quasicons - '("quote" #(syntax-object unquote ((top)) (hygiene guile))) - (quasi (list p) (- lev 1))))) - tmp-1) - (let ((tmp-1 ($sc-dispatch - tmp - '(#(free-id - #(syntax-object - quasiquote - ((top) - #(ribcage - #(quasiquote) - #((top)) - #(((hygiene guile) - . - #(syntax-object quasiquote ((top)) (hygiene guile)))))) - (hygiene guile))) - any)))) - (if tmp-1 - (apply (lambda (p) - (quasicons - '("quote" - #(syntax-object - quasiquote - ((top) - #(ribcage - #(quasiquote) - #((top)) - #(((hygiene guile) - . - #(syntax-object quasiquote ((top)) (hygiene guile)))))) - (hygiene guile))) - (quasi (list p) (+ lev 1)))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if tmp-1 - (apply (lambda (p q) - (let ((tmp-1 p)) - (let ((tmp ($sc-dispatch - tmp-1 - '(#(free-id #(syntax-object unquote ((top)) (hygiene guile))) - . - each-any)))) - (if tmp - (apply (lambda (p) - (if (= lev 0) - (quasilist* - (map (lambda (tmp-680b775fb37a463-120f) - (list "value" tmp-680b775fb37a463-120f)) - p) - (quasi q lev)) - (quasicons - (quasicons - '("quote" #(syntax-object unquote ((top)) (hygiene guile))) - (quasi p (- lev 1))) - (quasi q lev)))) - tmp) - (let ((tmp ($sc-dispatch - tmp-1 - '(#(free-id - #(syntax-object unquote-splicing ((top)) (hygiene guile))) - . - each-any)))) - (if tmp - (apply (lambda (p) - (if (= lev 0) - (quasiappend - (map (lambda (tmp-680b775fb37a463) - (list "value" tmp-680b775fb37a463)) - p) - (quasi q lev)) - (quasicons - (quasicons - '("quote" - #(syntax-object - unquote-splicing - ((top)) - (hygiene guile))) - (quasi p (- lev 1))) - (quasi q lev)))) - tmp) - (quasicons (quasi p lev) (quasi q lev)))))))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '#(vector each-any)))) - (if tmp-1 - (apply (lambda (x) (quasivector (vquasi x lev))) tmp-1) - (let ((p tmp)) (list "quote" p))))))))))))) - (vquasi - (lambda (p lev) - (let ((tmp p)) - (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) - (if tmp-1 - (apply (lambda (p q) - (let ((tmp-1 p)) - (let ((tmp ($sc-dispatch - tmp-1 - '(#(free-id #(syntax-object unquote ((top)) (hygiene guile))) - . - each-any)))) - (if tmp - (apply (lambda (p) - (if (= lev 0) - (quasilist* - (map (lambda (tmp-680b775fb37a463-122a) - (list "value" tmp-680b775fb37a463-122a)) - p) - (vquasi q lev)) - (quasicons - (quasicons - '("quote" #(syntax-object unquote ((top)) (hygiene guile))) - (quasi p (- lev 1))) - (vquasi q lev)))) - tmp) - (let ((tmp ($sc-dispatch - tmp-1 - '(#(free-id #(syntax-object unquote-splicing ((top)) (hygiene guile))) - . - each-any)))) - (if tmp - (apply (lambda (p) - (if (= lev 0) - (quasiappend - (map (lambda (tmp-680b775fb37a463-122f) - (list "value" tmp-680b775fb37a463-122f)) - p) - (vquasi q lev)) - (quasicons - (quasicons - '("quote" #(syntax-object unquote-splicing ((top)) (hygiene guile))) - (quasi p (- lev 1))) - (vquasi q lev)))) - tmp) - (quasicons (quasi p lev) (vquasi q lev)))))))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '()))) - (if tmp-1 - (apply (lambda () '("quote" ())) tmp-1) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp)))))))) - (quasicons - (lambda (x y) - (let ((tmp-1 (list x y))) - (let ((tmp ($sc-dispatch tmp-1 '(any any)))) - (if tmp - (apply (lambda (x y) - (let ((tmp y)) - (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) - (if tmp-1 - (apply (lambda (dy) - (let ((tmp x)) - (let ((tmp ($sc-dispatch tmp '(#(atom "quote") any)))) - (if tmp - (apply (lambda (dx) (list "quote" (cons dx dy))) tmp) - (if (null? dy) (list "list" x) (list "list*" x y)))))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . any)))) - (if tmp-1 - (apply (lambda (stuff) (cons "list" (cons x stuff))) tmp-1) - (let ((tmp ($sc-dispatch tmp '(#(atom "list*") . any)))) - (if tmp - (apply (lambda (stuff) (cons "list*" (cons x stuff))) tmp) - (list "list*" x y))))))))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))))) - (quasiappend - (lambda (x y) - (let ((tmp y)) - (let ((tmp ($sc-dispatch tmp '(#(atom "quote") ())))) - (if tmp - (apply (lambda () - (if (null? x) - '("quote" ()) - (if (null? (cdr x)) - (car x) - (let ((tmp-1 x)) - (let ((tmp ($sc-dispatch tmp-1 'each-any))) - (if tmp - (apply (lambda (p) (cons "append" p)) tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))))))) - tmp) - (if (null? x) - y - (let ((tmp-1 (list x y))) - (let ((tmp ($sc-dispatch tmp-1 '(each-any any)))) + (let ((make-syntax make-syntax)) + (make-syntax-transformer + 'syntax-rules + 'macro + (lambda (xx) + (letrec* + ((expand-clause + (lambda (clause) + (let ((tmp-1 clause)) + (let ((tmp ($sc-dispatch + tmp-1 + (list '(any . any) + (cons (vector + 'free-id + (make-syntax 'syntax-error '((top)) '(hygiene guile))) + '(any . each-any)))))) + (if (if tmp + (apply (lambda (keyword pattern message arg) + (string? (syntax->datum message))) + tmp) + #f) + (apply (lambda (keyword pattern message arg) + (list (cons (make-syntax 'dummy '((top)) '(hygiene guile)) pattern) + (list (make-syntax 'syntax '((top)) '(hygiene guile)) + (cons (make-syntax 'syntax-error '((top)) '(hygiene guile)) + (cons (cons (make-syntax 'dummy '((top)) '(hygiene guile)) pattern) + (cons message arg)))))) + tmp) + (let ((tmp ($sc-dispatch tmp-1 '((any . any) any)))) (if tmp - (apply (lambda (p y) (cons "append" (append p (list y)))) tmp) + (apply (lambda (keyword pattern template) + (list (cons (make-syntax 'dummy '((top)) '(hygiene guile)) pattern) + (list (make-syntax 'syntax '((top)) '(hygiene guile)) template))) + tmp) (syntax-violation #f "source expression failed to match any pattern" - tmp-1)))))))))) - (quasilist* - (lambda (x y) - (let f ((x x)) (if (null? x) y (quasicons (car x) (f (cdr x))))))) - (quasivector - (lambda (x) - (let ((tmp x)) - (let ((tmp ($sc-dispatch tmp '(#(atom "quote") each-any)))) - (if tmp - (apply (lambda (x) (list "quote" (list->vector x))) tmp) - (let f ((y x) - (k (lambda (ls) - (let ((tmp-1 ls)) - (let ((tmp ($sc-dispatch tmp-1 'each-any))) - (if tmp - (apply (lambda (t-680b775fb37a463) (cons "vector" t-680b775fb37a463)) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))))))) - (let ((tmp y)) - (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) - (if tmp-1 - (apply (lambda (y) - (k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463)) - y))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) - (if tmp-1 - (apply (lambda (y) (k y)) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list*") . #(each+ any (any) ()))))) - (if tmp-1 - (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) - (let ((else tmp)) - (let ((tmp x)) - (let ((t-680b775fb37a463 tmp)) - (list "list->vector" t-680b775fb37a463))))))))))))))))) - (emit (lambda (x) - (let ((tmp x)) - (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) - (if tmp-1 - (apply (lambda (x) (list '#(syntax-object quote ((top)) (hygiene guile)) x)) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) - (if tmp-1 - (apply (lambda (x) - (let ((tmp-1 (map emit x))) - (let ((tmp ($sc-dispatch tmp-1 'each-any))) - (if tmp - (apply (lambda (t-680b775fb37a463-12a2) - (cons '#(syntax-object list ((top)) (hygiene guile)) - t-680b775fb37a463-12a2)) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list*") . #(each+ any (any) ()))))) - (if tmp-1 - (apply (lambda (x y) - (let f ((x* x)) - (if (null? x*) - (emit y) - (let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) - (let ((tmp ($sc-dispatch tmp-1 '(any any)))) - (if tmp - (apply (lambda (t-680b775fb37a463-12b6 t-680b775fb37a463-12b5) - (list '#(syntax-object cons ((top)) (hygiene guile)) - t-680b775fb37a463-12b6 - t-680b775fb37a463-12b5)) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))))))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(#(atom "append") . each-any)))) - (if tmp-1 - (apply (lambda (x) - (let ((tmp-1 (map emit x))) - (let ((tmp ($sc-dispatch tmp-1 'each-any))) - (if tmp - (apply (lambda (t-680b775fb37a463-12c2) - (cons '#(syntax-object append ((top)) (hygiene guile)) - t-680b775fb37a463-12c2)) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(#(atom "vector") . each-any)))) - (if tmp-1 - (apply (lambda (x) - (let ((tmp-1 (map emit x))) - (let ((tmp ($sc-dispatch tmp-1 'each-any))) - (if tmp - (apply (lambda (t-680b775fb37a463-12ce) - (cons '#(syntax-object vector ((top)) (hygiene guile)) - t-680b775fb37a463-12ce)) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list->vector") any)))) - (if tmp-1 - (apply (lambda (x) - (let ((tmp (emit x))) - (let ((t-680b775fb37a463-12da tmp)) - (list '#(syntax-object list->vector ((top)) (hygiene guile)) - t-680b775fb37a463-12da)))) - tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) - (if tmp-1 - (apply (lambda (x) x) tmp-1) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp))))))))))))))))))) + tmp-1)))))))) + (expand-syntax-rules + (lambda (dots keys docstrings clauses) + (let ((tmp-1 (list keys docstrings clauses (map expand-clause clauses)))) + (let ((tmp ($sc-dispatch + tmp-1 + '(each-any each-any #(each ((any . any) any)) each-any)))) + (if tmp + (apply (lambda (k docstring keyword pattern template clause) + (let ((tmp (cons (make-syntax 'lambda '((top)) '(hygiene guile)) + (cons (list (make-syntax 'x '((top)) '(hygiene guile))) + (append + docstring + (list (vector + (cons (make-syntax 'macro-type '((top)) '(hygiene guile)) + (make-syntax + 'syntax-rules + (list '(top) + (vector + 'ribcage + '#(syntax-rules) + '#((top)) + (vector + (cons '(hygiene guile) + (make-syntax + 'syntax-rules + '((top)) + '(hygiene guile)))))) + '(hygiene guile))) + (cons (make-syntax 'patterns '((top)) '(hygiene guile)) + pattern)) + (cons (make-syntax 'syntax-case '((top)) '(hygiene guile)) + (cons (make-syntax 'x '((top)) '(hygiene guile)) + (cons k clause))))))))) + (let ((form tmp)) + (if dots + (let ((tmp dots)) + (let ((dots tmp)) + (list (make-syntax 'with-ellipsis '((top)) '(hygiene guile)) + dots + form))) + form)))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1))))))) + (let ((tmp xx)) + (let ((tmp-1 ($sc-dispatch tmp '(_ each-any . #(each ((any . any) any)))))) + (if tmp-1 + (apply (lambda (k keyword pattern template) + (expand-syntax-rules + #f + k + '() + (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) + tmp-680b775fb37a463-2)) + template + pattern + keyword))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(_ each-any any . #(each ((any . any) any)))))) + (if (if tmp-1 + (apply (lambda (k docstring keyword pattern template) + (string? (syntax->datum docstring))) + tmp-1) + #f) + (apply (lambda (k docstring keyword pattern template) + (expand-syntax-rules + #f + k + (list docstring) + (map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-116f) + (list (cons tmp-680b775fb37a463-116f tmp-680b775fb37a463) + tmp-680b775fb37a463-1)) + template + pattern + keyword))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(_ any each-any . #(each ((any . any) any)))))) + (if (if tmp-1 + (apply (lambda (dots k keyword pattern template) (identifier? dots)) + tmp-1) + #f) + (apply (lambda (dots k keyword pattern template) + (expand-syntax-rules + dots + k + '() + (map (lambda (tmp-680b775fb37a463-118a tmp-680b775fb37a463-1 tmp-680b775fb37a463) + (list (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1) + tmp-680b775fb37a463-118a)) + template + pattern + keyword))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(_ any each-any any . #(each ((any . any) any)))))) + (if (if tmp-1 + (apply (lambda (dots k docstring keyword pattern template) + (if (identifier? dots) (string? (syntax->datum docstring)) #f)) + tmp-1) + #f) + (apply (lambda (dots k docstring keyword pattern template) + (expand-syntax-rules + dots + k + (list docstring) + (map (lambda (tmp-680b775fb37a463-11a9 + tmp-680b775fb37a463-11a8 + tmp-680b775fb37a463-11a7) + (list (cons tmp-680b775fb37a463-11a7 tmp-680b775fb37a463-11a8) + tmp-680b775fb37a463-11a9)) + template + pattern + keyword))) + tmp-1) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp))))))))))))))) + +(define define-syntax-rule + (let ((make-syntax make-syntax)) + (make-syntax-transformer + 'define-syntax-rule + 'macro (lambda (x) (let ((tmp-1 x)) - (let ((tmp ($sc-dispatch tmp-1 '(_ any)))) + (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any)))) (if tmp - (apply (lambda (e) (emit (quasi e 0))) tmp) + (apply (lambda (name pattern template) + (list (make-syntax 'define-syntax '((top)) '(hygiene guile)) + name + (list (make-syntax 'syntax-rules '((top)) '(hygiene guile)) + '() + (list (cons (make-syntax '_ '((top)) '(hygiene guile)) pattern) + template)))) + tmp) + (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any any)))) + (if (if tmp + (apply (lambda (name pattern docstring template) + (string? (syntax->datum docstring))) + tmp) + #f) + (apply (lambda (name pattern docstring template) + (list (make-syntax 'define-syntax '((top)) '(hygiene guile)) + name + (list (make-syntax 'syntax-rules '((top)) '(hygiene guile)) + '() + docstring + (list (cons (make-syntax '_ '((top)) '(hygiene guile)) pattern) + template)))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))))))))) + +(define let* + (let ((make-syntax make-syntax)) + (make-syntax-transformer + 'let* + 'macro + (lambda (x) + (let ((tmp-1 x)) + (let ((tmp ($sc-dispatch tmp-1 '(any #(each (any any)) any . each-any)))) + (if (if tmp + (apply (lambda (let* x v e1 e2) (and-map identifier? x)) tmp) + #f) + (apply (lambda (let* x v e1 e2) + (let f ((bindings (map list x v))) + (if (null? bindings) + (cons (make-syntax 'let '((top)) '(hygiene guile)) + (cons '() (cons e1 e2))) + (let ((tmp-1 (list (f (cdr bindings)) (car bindings)))) + (let ((tmp ($sc-dispatch tmp-1 '(any any)))) + (if tmp + (apply (lambda (body binding) + (list (make-syntax 'let '((top)) '(hygiene guile)) + (list binding) + body)) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1))))))) + tmp) (syntax-violation #f "source expression failed to match any pattern" tmp-1)))))))) -(define include - (make-syntax-transformer - 'include - 'macro - (lambda (x) +(define quasiquote + (let ((make-syntax make-syntax)) + (make-syntax-transformer + 'quasiquote + 'macro (letrec* - ((read-file - (lambda (fn dir k) - (let ((p (open-input-file - (if (absolute-file-name? fn) - fn - (if dir - (in-vicinity dir fn) - (syntax-violation - 'include - "relative file name only allowed when the include form is in a file" - x)))))) - (let ((enc (file-encoding p))) - (set-port-encoding! p (let ((t enc)) (if t t "UTF-8"))) - (let f ((x (read p)) (result '())) - (if (eof-object? x) - (begin (close-port p) (reverse result)) - (f (read p) (cons (datum->syntax k x) result))))))))) - (let ((src (syntax-source x))) - (let ((file (if src (assq-ref src 'filename) #f))) - (let ((dir (if (string? file) (dirname file) #f))) - (let ((tmp-1 x)) - (let ((tmp ($sc-dispatch tmp-1 '(any any)))) - (if tmp - (apply (lambda (k filename) - (let ((fn (syntax->datum filename))) - (let ((tmp-1 (read-file fn dir filename))) - (let ((tmp ($sc-dispatch tmp-1 'each-any))) - (if tmp - (apply (lambda (exp) - (cons '#(syntax-object begin ((top)) (hygiene guile)) exp)) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))))))))))) + ((quasi (lambda (p lev) + (let ((tmp p)) + (let ((tmp-1 ($sc-dispatch + tmp + (list (vector 'free-id (make-syntax 'unquote '((top)) '(hygiene guile))) + 'any)))) + (if tmp-1 + (apply (lambda (p) + (if (= lev 0) + (list "value" p) + (quasicons + (list "quote" (make-syntax 'unquote '((top)) '(hygiene guile))) + (quasi (list p) (- lev 1))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch + tmp + (list (vector + 'free-id + (make-syntax + 'quasiquote + (list '(top) + (vector + 'ribcage + '#(quasiquote) + '#((top)) + (vector + (cons '(hygiene guile) + (make-syntax 'quasiquote '((top)) '(hygiene guile)))))) + '(hygiene guile))) + 'any)))) + (if tmp-1 + (apply (lambda (p) + (quasicons + (list "quote" + (make-syntax + 'quasiquote + (list '(top) + (vector + 'ribcage + '#(quasiquote) + '#((top)) + (vector + (cons '(hygiene guile) + (make-syntax 'quasiquote '((top)) '(hygiene guile)))))) + '(hygiene guile))) + (quasi (list p) (+ lev 1)))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if tmp-1 + (apply (lambda (p q) + (let ((tmp-1 p)) + (let ((tmp ($sc-dispatch + tmp-1 + (cons (vector + 'free-id + (make-syntax 'unquote '((top)) '(hygiene guile))) + 'each-any)))) + (if tmp + (apply (lambda (p) + (if (= lev 0) + (quasilist* + (map (lambda (tmp-680b775fb37a463) + (list "value" tmp-680b775fb37a463)) + p) + (quasi q lev)) + (quasicons + (quasicons + (list "quote" + (make-syntax 'unquote '((top)) '(hygiene guile))) + (quasi p (- lev 1))) + (quasi q lev)))) + tmp) + (let ((tmp ($sc-dispatch + tmp-1 + (cons (vector + 'free-id + (make-syntax + 'unquote-splicing + '((top)) + '(hygiene guile))) + 'each-any)))) + (if tmp + (apply (lambda (p) + (if (= lev 0) + (quasiappend + (map (lambda (tmp-680b775fb37a463) + (list "value" tmp-680b775fb37a463)) + p) + (quasi q lev)) + (quasicons + (quasicons + (list "quote" + (make-syntax + 'unquote-splicing + '((top)) + '(hygiene guile))) + (quasi p (- lev 1))) + (quasi q lev)))) + tmp) + (quasicons (quasi p lev) (quasi q lev)))))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '#(vector each-any)))) + (if tmp-1 + (apply (lambda (x) (quasivector (vquasi x lev))) tmp-1) + (let ((p tmp)) (list "quote" p))))))))))))) + (vquasi + (lambda (p lev) + (let ((tmp p)) + (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) + (if tmp-1 + (apply (lambda (p q) + (let ((tmp-1 p)) + (let ((tmp ($sc-dispatch + tmp-1 + (cons (vector 'free-id (make-syntax 'unquote '((top)) '(hygiene guile))) + 'each-any)))) + (if tmp + (apply (lambda (p) + (if (= lev 0) + (quasilist* + (map (lambda (tmp-680b775fb37a463-122f) + (list "value" tmp-680b775fb37a463-122f)) + p) + (vquasi q lev)) + (quasicons + (quasicons + (list "quote" (make-syntax 'unquote '((top)) '(hygiene guile))) + (quasi p (- lev 1))) + (vquasi q lev)))) + tmp) + (let ((tmp ($sc-dispatch + tmp-1 + (cons (vector + 'free-id + (make-syntax 'unquote-splicing '((top)) '(hygiene guile))) + 'each-any)))) + (if tmp + (apply (lambda (p) + (if (= lev 0) + (quasiappend + (map (lambda (tmp-680b775fb37a463) + (list "value" tmp-680b775fb37a463)) + p) + (vquasi q lev)) + (quasicons + (quasicons + (list "quote" + (make-syntax 'unquote-splicing '((top)) '(hygiene guile))) + (quasi p (- lev 1))) + (vquasi q lev)))) + tmp) + (quasicons (quasi p lev) (vquasi q lev)))))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '()))) + (if tmp-1 + (apply (lambda () '("quote" ())) tmp-1) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp)))))))) + (quasicons + (lambda (x y) + (let ((tmp-1 (list x y))) + (let ((tmp ($sc-dispatch tmp-1 '(any any)))) + (if tmp + (apply (lambda (x y) + (let ((tmp y)) + (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) + (if tmp-1 + (apply (lambda (dy) + (let ((tmp x)) + (let ((tmp ($sc-dispatch tmp '(#(atom "quote") any)))) + (if tmp + (apply (lambda (dx) (list "quote" (cons dx dy))) tmp) + (if (null? dy) (list "list" x) (list "list*" x y)))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . any)))) + (if tmp-1 + (apply (lambda (stuff) (cons "list" (cons x stuff))) tmp-1) + (let ((tmp ($sc-dispatch tmp '(#(atom "list*") . any)))) + (if tmp + (apply (lambda (stuff) (cons "list*" (cons x stuff))) tmp) + (list "list*" x y))))))))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))))) + (quasiappend + (lambda (x y) + (let ((tmp y)) + (let ((tmp ($sc-dispatch tmp '(#(atom "quote") ())))) + (if tmp + (apply (lambda () + (if (null? x) + '("quote" ()) + (if (null? (cdr x)) + (car x) + (let ((tmp-1 x)) + (let ((tmp ($sc-dispatch tmp-1 'each-any))) + (if tmp + (apply (lambda (p) (cons "append" p)) tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1))))))) + tmp) + (if (null? x) + y + (let ((tmp-1 (list x y))) + (let ((tmp ($sc-dispatch tmp-1 '(each-any any)))) + (if tmp + (apply (lambda (p y) (cons "append" (append p (list y)))) tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))))))))) + (quasilist* + (lambda (x y) + (let f ((x x)) (if (null? x) y (quasicons (car x) (f (cdr x))))))) + (quasivector + (lambda (x) + (let ((tmp x)) + (let ((tmp ($sc-dispatch tmp '(#(atom "quote") each-any)))) + (if tmp + (apply (lambda (x) (list "quote" (list->vector x))) tmp) + (let f ((y x) + (k (lambda (ls) + (let ((tmp-1 ls)) + (let ((tmp ($sc-dispatch tmp-1 'each-any))) + (if tmp + (apply (lambda (t-680b775fb37a463-127d) + (cons "vector" t-680b775fb37a463-127d)) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1))))))) + (let ((tmp y)) + (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) + (if tmp-1 + (apply (lambda (y) + (k (map (lambda (tmp-680b775fb37a463) (list "quote" tmp-680b775fb37a463)) + y))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) + (if tmp-1 + (apply (lambda (y) (k y)) tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list*") . #(each+ any (any) ()))))) + (if tmp-1 + (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) + (let ((else tmp)) + (let ((tmp x)) + (let ((t-680b775fb37a463 tmp)) + (list "list->vector" t-680b775fb37a463))))))))))))))))) + (emit (lambda (x) + (let ((tmp x)) + (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) + (if tmp-1 + (apply (lambda (x) (list (make-syntax 'quote '((top)) '(hygiene guile)) x)) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) + (if tmp-1 + (apply (lambda (x) + (let ((tmp-1 (map emit x))) + (let ((tmp ($sc-dispatch tmp-1 'each-any))) + (if tmp + (apply (lambda (t-680b775fb37a463-12a7) + (cons (make-syntax 'list '((top)) '(hygiene guile)) + t-680b775fb37a463-12a7)) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list*") . #(each+ any (any) ()))))) + (if tmp-1 + (apply (lambda (x y) + (let f ((x* x)) + (if (null? x*) + (emit y) + (let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) + (let ((tmp ($sc-dispatch tmp-1 '(any any)))) + (if tmp + (apply (lambda (t-680b775fb37a463-12bb t-680b775fb37a463-12ba) + (list (make-syntax 'cons '((top)) '(hygiene guile)) + t-680b775fb37a463-12bb + t-680b775fb37a463-12ba)) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1))))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(#(atom "append") . each-any)))) + (if tmp-1 + (apply (lambda (x) + (let ((tmp-1 (map emit x))) + (let ((tmp ($sc-dispatch tmp-1 'each-any))) + (if tmp + (apply (lambda (t-680b775fb37a463-12c7) + (cons (make-syntax 'append '((top)) '(hygiene guile)) + t-680b775fb37a463-12c7)) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(#(atom "vector") . each-any)))) + (if tmp-1 + (apply (lambda (x) + (let ((tmp-1 (map emit x))) + (let ((tmp ($sc-dispatch tmp-1 'each-any))) + (if tmp + (apply (lambda (t-680b775fb37a463-12d3) + (cons (make-syntax 'vector '((top)) '(hygiene guile)) + t-680b775fb37a463-12d3)) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1))))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list->vector") any)))) + (if tmp-1 + (apply (lambda (x) + (let ((tmp (emit x))) + (let ((t-680b775fb37a463-12df tmp)) + (list (make-syntax 'list->vector '((top)) '(hygiene guile)) + t-680b775fb37a463-12df)))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any)))) + (if tmp-1 + (apply (lambda (x) x) tmp-1) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp))))))))))))))))))) + (lambda (x) + (let ((tmp-1 x)) + (let ((tmp ($sc-dispatch tmp-1 '(_ any)))) + (if tmp + (apply (lambda (e) (emit (quasi e 0))) tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1))))))))) + +(define include + (let ((make-syntax make-syntax)) + (make-syntax-transformer + 'include + 'macro + (lambda (x) + (letrec* + ((read-file + (lambda (fn dir k) + (let ((p (open-input-file + (if (absolute-file-name? fn) + fn + (if dir + (in-vicinity dir fn) + (syntax-violation + 'include + "relative file name only allowed when the include form is in a file" + x)))))) + (let ((enc (file-encoding p))) + (set-port-encoding! p (let ((t enc)) (if t t "UTF-8"))) + (let f ((x (read p)) (result '())) + (if (eof-object? x) + (begin (close-port p) (reverse result)) + (f (read p) (cons (datum->syntax k x) result))))))))) + (let ((src (syntax-source x))) + (let ((file (if src (assq-ref src 'filename) #f))) + (let ((dir (if (string? file) (dirname file) #f))) + (let ((tmp-1 x)) + (let ((tmp ($sc-dispatch tmp-1 '(any any)))) + (if tmp + (apply (lambda (k filename) + (let ((fn (syntax->datum filename))) + (let ((tmp-1 (read-file fn dir filename))) + (let ((tmp ($sc-dispatch tmp-1 'each-any))) + (if tmp + (apply (lambda (exp) + (cons (make-syntax 'begin '((top)) '(hygiene guile)) exp)) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))))))))))) (define include-from-path - (make-syntax-transformer - 'include-from-path - 'macro - (lambda (x) - (let ((tmp-1 x)) - (let ((tmp ($sc-dispatch tmp-1 '(any any)))) - (if tmp - (apply (lambda (k filename) - (let ((fn (syntax->datum filename))) - (let ((tmp (datum->syntax - filename - (canonicalize-path - (let ((t (%search-load-path fn))) - (if t - t - (syntax-violation - 'include-from-path - "file not found in path" - x - filename))))))) - (let ((fn tmp)) - (list '#(syntax-object include ((top)) (hygiene guile)) fn))))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))))))) + (let ((make-syntax make-syntax)) + (make-syntax-transformer + 'include-from-path + 'macro + (lambda (x) + (let ((tmp-1 x)) + (let ((tmp ($sc-dispatch tmp-1 '(any any)))) + (if tmp + (apply (lambda (k filename) + (let ((fn (syntax->datum filename))) + (let ((tmp (datum->syntax + filename + (canonicalize-path + (let ((t (%search-load-path fn))) + (if t + t + (syntax-violation + 'include-from-path + "file not found in path" + x + filename))))))) + (let ((fn tmp)) + (list (make-syntax 'include '((top)) '(hygiene guile)) fn))))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))))))) (define unquote (make-syntax-transformer @@ -3401,104 +3422,110 @@ (error "variable transformer not a procedure" proc)))) (define identifier-syntax - (make-syntax-transformer - 'identifier-syntax - 'macro - (lambda (xx) - (let ((tmp-1 xx)) - (let ((tmp ($sc-dispatch tmp-1 '(_ any)))) - (if tmp - (apply (lambda (e) - (list '#(syntax-object lambda ((top)) (hygiene guile)) - '(#(syntax-object x ((top)) (hygiene guile))) - '#((#(syntax-object macro-type ((top)) (hygiene guile)) - . - #(syntax-object - identifier-syntax - ((top) - #(ribcage - #(identifier-syntax) - #((top)) - #(((hygiene guile) - . - #(syntax-object identifier-syntax ((top)) (hygiene guile)))))) - (hygiene guile)))) - (list '#(syntax-object syntax-case ((top)) (hygiene guile)) - '#(syntax-object x ((top)) (hygiene guile)) - '() - (list '#(syntax-object id ((top)) (hygiene guile)) - '(#(syntax-object identifier? ((top)) (hygiene guile)) - (#(syntax-object syntax ((top)) (hygiene guile)) - #(syntax-object id ((top)) (hygiene guile)))) - (list '#(syntax-object syntax ((top)) (hygiene guile)) e)) - (list '(#(syntax-object _ ((top)) (hygiene guile)) - #(syntax-object x ((top)) (hygiene guile)) - #(syntax-object ... ((top)) (hygiene guile))) - (list '#(syntax-object syntax ((top)) (hygiene guile)) - (cons e - '(#(syntax-object x ((top)) (hygiene guile)) - #(syntax-object ... ((top)) (hygiene guile))))))))) - tmp) - (let ((tmp ($sc-dispatch - tmp-1 - '(_ (any any) - ((#(free-id #(syntax-object set! ((top)) (hygiene guile))) any any) - any))))) - (if (if tmp - (apply (lambda (id exp1 var val exp2) - (if (identifier? id) (identifier? var) #f)) - tmp) - #f) - (apply (lambda (id exp1 var val exp2) - (list '#(syntax-object make-variable-transformer ((top)) (hygiene guile)) - (list '#(syntax-object lambda ((top)) (hygiene guile)) - '(#(syntax-object x ((top)) (hygiene guile))) - '#((#(syntax-object macro-type ((top)) (hygiene guile)) - . - #(syntax-object variable-transformer ((top)) (hygiene guile)))) - (list '#(syntax-object syntax-case ((top)) (hygiene guile)) - '#(syntax-object x ((top)) (hygiene guile)) - '(#(syntax-object set! ((top)) (hygiene guile))) - (list (list '#(syntax-object set! ((top)) (hygiene guile)) var val) - (list '#(syntax-object syntax ((top)) (hygiene guile)) exp2)) - (list (cons id - '(#(syntax-object x ((top)) (hygiene guile)) - #(syntax-object ... ((top)) (hygiene guile)))) - (list '#(syntax-object syntax ((top)) (hygiene guile)) - (cons exp1 - '(#(syntax-object x ((top)) (hygiene guile)) - #(syntax-object ... ((top)) (hygiene guile)))))) - (list id - (list '#(syntax-object identifier? ((top)) (hygiene guile)) - (list '#(syntax-object syntax ((top)) (hygiene guile)) id)) - (list '#(syntax-object syntax ((top)) (hygiene guile)) exp1)))))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))))))))) + (let ((make-syntax make-syntax)) + (make-syntax-transformer + 'identifier-syntax + 'macro + (lambda (xx) + (let ((tmp-1 xx)) + (let ((tmp ($sc-dispatch tmp-1 '(_ any)))) + (if tmp + (apply (lambda (e) + (list (make-syntax 'lambda '((top)) '(hygiene guile)) + (list (make-syntax 'x '((top)) '(hygiene guile))) + (vector + (cons (make-syntax 'macro-type '((top)) '(hygiene guile)) + (make-syntax + 'identifier-syntax + (list '(top) + (vector + 'ribcage + '#(identifier-syntax) + '#((top)) + (vector + (cons '(hygiene guile) + (make-syntax 'identifier-syntax '((top)) '(hygiene guile)))))) + '(hygiene guile)))) + (list (make-syntax 'syntax-case '((top)) '(hygiene guile)) + (make-syntax 'x '((top)) '(hygiene guile)) + '() + (list (make-syntax 'id '((top)) '(hygiene guile)) + (list (make-syntax 'identifier? '((top)) '(hygiene guile)) + (list (make-syntax 'syntax '((top)) '(hygiene guile)) + (make-syntax 'id '((top)) '(hygiene guile)))) + (list (make-syntax 'syntax '((top)) '(hygiene guile)) e)) + (list (list (make-syntax '_ '((top)) '(hygiene guile)) + (make-syntax 'x '((top)) '(hygiene guile)) + (make-syntax '... '((top)) '(hygiene guile))) + (list (make-syntax 'syntax '((top)) '(hygiene guile)) + (cons e + (list (make-syntax 'x '((top)) '(hygiene guile)) + (make-syntax '... '((top)) '(hygiene guile))))))))) + tmp) + (let ((tmp ($sc-dispatch + tmp-1 + (list '_ + '(any any) + (list (list (vector 'free-id (make-syntax 'set! '((top)) '(hygiene guile))) + 'any + 'any) + 'any))))) + (if (if tmp + (apply (lambda (id exp1 var val exp2) + (if (identifier? id) (identifier? var) #f)) + tmp) + #f) + (apply (lambda (id exp1 var val exp2) + (list (make-syntax 'make-variable-transformer '((top)) '(hygiene guile)) + (list (make-syntax 'lambda '((top)) '(hygiene guile)) + (list (make-syntax 'x '((top)) '(hygiene guile))) + (vector + (cons (make-syntax 'macro-type '((top)) '(hygiene guile)) + (make-syntax 'variable-transformer '((top)) '(hygiene guile)))) + (list (make-syntax 'syntax-case '((top)) '(hygiene guile)) + (make-syntax 'x '((top)) '(hygiene guile)) + (list (make-syntax 'set! '((top)) '(hygiene guile))) + (list (list (make-syntax 'set! '((top)) '(hygiene guile)) var val) + (list (make-syntax 'syntax '((top)) '(hygiene guile)) exp2)) + (list (cons id + (list (make-syntax 'x '((top)) '(hygiene guile)) + (make-syntax '... '((top)) '(hygiene guile)))) + (list (make-syntax 'syntax '((top)) '(hygiene guile)) + (cons exp1 + (list (make-syntax 'x '((top)) '(hygiene guile)) + (make-syntax '... '((top)) '(hygiene guile)))))) + (list id + (list (make-syntax 'identifier? '((top)) '(hygiene guile)) + (list (make-syntax 'syntax '((top)) '(hygiene guile)) id)) + (list (make-syntax 'syntax '((top)) '(hygiene guile)) exp1)))))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))))))))) (define define* - (make-syntax-transformer - 'define* - 'macro - (lambda (x) - (let ((tmp-1 x)) - (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any)))) - (if tmp - (apply (lambda (id args b0 b1) - (list '#(syntax-object define ((top)) (hygiene guile)) - id - (cons '#(syntax-object lambda* ((top)) (hygiene guile)) - (cons args (cons b0 b1))))) - tmp) - (let ((tmp ($sc-dispatch tmp-1 '(_ any any)))) - (if (if tmp (apply (lambda (id val) (identifier? id)) tmp) #f) - (apply (lambda (id val) - (list '#(syntax-object define ((top)) (hygiene guile)) id val)) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))))))))) + (let ((make-syntax make-syntax)) + (make-syntax-transformer + 'define* + 'macro + (lambda (x) + (let ((tmp-1 x)) + (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any)))) + (if tmp + (apply (lambda (id args b0 b1) + (list (make-syntax 'define '((top)) '(hygiene guile)) + id + (cons (make-syntax 'lambda* '((top)) '(hygiene guile)) + (cons args (cons b0 b1))))) + tmp) + (let ((tmp ($sc-dispatch tmp-1 '(_ any any)))) + (if (if tmp (apply (lambda (id val) (identifier? id)) tmp) #f) + (apply (lambda (id val) + (list (make-syntax 'define '((top)) '(hygiene guile)) id val)) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))))))))) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 678d08b97..a45e2a6cc 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -477,7 +477,7 @@ (= (vector-length x) 4) (eqv? (vector-ref x 0) 'syntax-object)))) (define (make-syntax-object expression wrap module) - (vector 'syntax-object expression wrap module)) + (make-syntax expression wrap module)) (define (syntax-object-expression obj) (if (syntax? obj) (syntax-expression obj) From ce934bcd43654d7370767d8d399625d1d066f8b3 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 28 Mar 2017 21:27:11 +0200 Subject: [PATCH 819/865] Add allow-legacy-syntax-objects? parameter * module/ice-9/psyntax.scm (syntax?): Only recognize legacy syntax objects if the new allow-legacy-syntax-objects? parameter is true. * module/ice-9/boot-9.scm (allow-legacy-syntax-objects?): New parameter. * doc/ref/api-macros.texi (Syntax Transformer Helpers): Document the horrible situation with legacy syntax objects. * NEWS: Add entry. --- NEWS | 20 ++++++++++++++++++++ doc/ref/api-macros.texi | 38 ++++++++++++++++++++++++++++++++++++++ module/ice-9/boot-9.scm | 9 ++++++++- module/ice-9/psyntax.scm | 3 ++- 4 files changed, 68 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index 50eccca47..3163f395c 100644 --- a/NEWS +++ b/NEWS @@ -5,6 +5,26 @@ See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. + +Changes in 2.2.1 (since 2.2.0): + +* Notable changes + +** Syntax objects are now a distinct type + +It used to be that syntax objects were represented as a tagged vector. +These values could be forged by users to break scoping abstractions, +preventing the implementation of sandboxing facilities in Guile. We are +as embarrassed about the previous situation as we pleased are about the +fact that we've fixed it. + +Unfortunately, during the 2.2 stable series (or at least during part of +it), we need to support files compiled with Guile 2.2.0. These files +may contain macros that contain legacy syntax object constants. See the +discussion of "allow-legacy-syntax-objects?" in "Syntax Transformer +Helpers" in the manual for full details. + + Changes in 2.2.0 (changes since the 2.0.x stable release series): diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi index ef0621415..7fa62e3d6 100644 --- a/doc/ref/api-macros.texi +++ b/doc/ref/api-macros.texi @@ -791,6 +791,44 @@ Return the source properties that correspond to the syntax object @var{x}. @xref{Source Properties}, for more information. @end deffn +And now, a bit of confession time. Guile's syntax expander originates +in code from Chez Scheme: a version of the expander in Chez Scheme that +was made portable to other Scheme systems. Way back in the mid-1990s, +some Scheme systems didn't even have the ability to define new abstract +data types. For this reason, the portable expander from Chez Scheme +that Guile inherited used tagged vectors as syntax objects: vectors +whose first element was the symbol, @code{syntax-object}. + +At the time of this writing it is 2017 and Guile still has support for +this strategy. It worked for this long because no one ever puts a +literal vector in the operator position: + +@example +(#(syntax-object ...) 1 2 3) +@end example + +But this state of affairs was an error. Because syntax objects are just +vectors, this makes it possible for any Scheme code to forge a syntax +object which might cause it to violate abstraction boundaries. You +can't build a sandboxing facility that limits the set of bindings in +scope when one can always escape that limit just by evaluating a special +vector. To fix this problem, Guile 2.2.1 finally migrated to represent +syntax objects as a distinct type with a distinct constructor that is +unavailable to user code. + +However, Guile still has to support ``legacy'' syntax objects, because +it could be that a file compiled with Guile 2.2.0 embeds syntax objects +of the vector kind. Whether the expander treats the special tagged +vectors as syntax objects is now controllable by the +@code{allow-legacy-syntax-objects?} parameter: + +@deffn {Scheme Procedure} allow-legacy-syntax-objects? +A parameter that indicates whether the expander should support legacy +syntax objects, as described above. For ABI stability reasons, the +default is @code{#t}. Use @code{parameterize} to bind it to @code{#f}. +@xref{Parameters}. +@end deffn + Guile also offers some more experimental interfaces in a separate module. As was the case with the Large Hadron Collider, it is unclear to our senior macrologists whether adding these interfaces will result diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index be890fa45..a70cd11ef 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -299,6 +299,9 @@ This is handy for tracing function calls, e.g.: (define (absolute-file-name? file-name) #t) (define (open-input-file str) (open-file str "r")) +;; Temporary definition; replaced by a parameter later. +(define (allow-legacy-syntax-objects?) #f) + ;;; {and-map and or-map} ;;; ;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...) @@ -1423,11 +1426,15 @@ CONV is not applied to the initial value." ;;; Once parameters have booted, define the default prompt tag as being -;;; a parameter. +;;; a parameter, and make allow-legacy-syntax-objects? a parameter. ;;; (set! default-prompt-tag (make-parameter (default-prompt-tag))) +;; Because code compiled with Guile 2.2.0 embeds legacy syntax objects +;; into its compiled macros, we have to default to true, sadly. +(set! allow-legacy-syntax-objects? (make-parameter #t)) + ;;; {Languages} diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index a45e2a6cc..5696c4642 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -473,7 +473,8 @@ (define (syntax-object? x) (or (syntax? x) - (and (vector? x) + (and (allow-legacy-syntax-objects?) + (vector? x) (= (vector-length x) 4) (eqv? (vector-ref x 0) 'syntax-object)))) (define (make-syntax-object expression wrap module) From cee0e3f966aad6d6275dc248d6028ecebdb2dae9 Mon Sep 17 00:00:00 2001 From: Mike Gran Date: Fri, 31 Mar 2017 21:38:08 -0700 Subject: [PATCH 820/865] fix repl server test to allow for ECONNABORTED For some systems, ECONNABORTED is a failure condition for reading from closed sockets. * test-suite/tests/00-repl-server.test (HTTP inter-protocol attack): modified --- test-suite/tests/00-repl-server.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test-suite/tests/00-repl-server.test b/test-suite/tests/00-repl-server.test index 8570ca380..c4c38258e 100644 --- a/test-suite/tests/00-repl-server.test +++ b/test-suite/tests/00-repl-server.test @@ -1,6 +1,6 @@ ;;;; 00-repl-server.test --- REPL server. -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2016 Free Software Foundation, Inc. +;;;; Copyright (C) 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 @@ -145,7 +145,7 @@ reached." (loop (+ 1 n)))))) (lambda args (->bool (memv (system-error-errno args) - (list ECONNRESET EPIPE)))))))) + (list ECONNRESET EPIPE ECONNABORTED)))))))) ;;; Local Variables: ;;; eval: (put 'with-repl-server 'scheme-indent-function 1) From 39339c9fb93e73483cb2dce0098aeb4fc3fc5643 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 3 Apr 2017 17:46:30 +0200 Subject: [PATCH 821/865] Speed up procedure-minimum-arity for fixed arity * libguile/programs.c (try_parse_arity): Add a case for assert-nargs-ee/locals. --- libguile/programs.c | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/libguile/programs.c b/libguile/programs.c index ba8e8546b..237d282ec 100644 --- a/libguile/programs.c +++ b/libguile/programs.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013, 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 License @@ -251,6 +251,12 @@ try_parse_arity (SCM program, int *req, int *opt, int *rest) *opt = 0; *rest = 0; return 1; + case scm_op_assert_nargs_ee_locals: + slots = (code[0] >> 8) & 0xfff; + *req = slots - 1; + *opt = 0; + *rest = 0; + return 1; case scm_op_assert_nargs_le: slots = code[0] >> 8; *req = 0; From 685ca33e2e21ee5fd8917d36772f60a85639fd9b Mon Sep 17 00:00:00 2001 From: Michael Gran Date: Tue, 4 Apr 2017 07:33:41 -0700 Subject: [PATCH 822/865] Only run tests that require fork if it is provided * test-suite/tests/00-repl-server.test (call-with-repl-server): throw if no fork provided * test-suite/tests/00-socket.test (primitive-fork-if-available): new help procedure (bind/sockaddr, AF_UNIX/SOCK_STREAM): use helper func * test-suite/tests/ports.test ("pipe, fdopen, and line buffering"): throw if no fork provided --- test-suite/tests/00-repl-server.test | 4 ++-- test-suite/tests/00-socket.test | 12 ++++++++---- test-suite/tests/ports.test | 4 +++- 3 files changed, 13 insertions(+), 7 deletions(-) diff --git a/test-suite/tests/00-repl-server.test b/test-suite/tests/00-repl-server.test index c4c38258e..54f518a66 100644 --- a/test-suite/tests/00-repl-server.test +++ b/test-suite/tests/00-repl-server.test @@ -32,8 +32,8 @@ socket connected to that server." (false-if-exception (delete-file (sockaddr:path sockaddr))) - ;; The REPL server requires threads. - (unless (provided? 'threads) + ;; The REPL server requires thread. The test requires fork. + (unless (and (provided? 'threads) (provided? 'fork)) (throw 'unsupported)) (match (primitive-fork) diff --git a/test-suite/tests/00-socket.test b/test-suite/tests/00-socket.test index 211aaaf20..7f55adea1 100644 --- a/test-suite/tests/00-socket.test +++ b/test-suite/tests/00-socket.test @@ -1,7 +1,7 @@ ;;;; 00-socket.test --- test socket functions -*- scheme -*- ;;;; ;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, -;;;; 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +;;;; 2011, 2012, 2013, 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 @@ -161,6 +161,10 @@ (number->string (current-time)) "-" (number->string (random 100000)))) +(define (primitive-fork-if-available) + (if (not (provided? 'fork)) + -1 + (primitive-fork))) (if (defined? 'AF_UNIX) (with-test-prefix "AF_UNIX/SOCK_DGRAM" @@ -261,7 +265,7 @@ (force-output (current-output-port)) (force-output (current-error-port)) (if server-listening? - (let ((pid (primitive-fork))) + (let ((pid (primitive-fork-if-available))) ;; Spawn a server process. (case pid ((-1) (throw 'unresolved)) @@ -341,7 +345,7 @@ (force-output (current-output-port)) (force-output (current-error-port)) (if server-listening? - (let ((pid (primitive-fork))) + (let ((pid (primitive-fork-if-available))) ;; Spawn a server process. (case pid ((-1) (throw 'unresolved)) @@ -439,7 +443,7 @@ (force-output (current-output-port)) (force-output (current-error-port)) (if server-listening? - (let ((pid (primitive-fork))) + (let ((pid (primitive-fork-if-available))) ;; Spawn a server process. (case pid ((-1) (throw 'unresolved)) diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index 207c0cfa7..007f56605 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -2,7 +2,7 @@ ;;;; Jim Blandy --- May 1999 ;;;; ;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009, 2010, -;;;; 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc. +;;;; 2011, 2012, 2013, 2014, 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 @@ -638,6 +638,8 @@ (pass-if-equal "pipe, fdopen, and line buffering" "foo\nbar\n" + (unless (provided? 'fork) + (throw 'unresolved)) (let ((in+out (pipe)) (pid (primitive-fork))) (if (zero? pid) From d7778b3d6a5f11ef4744c80e70457193d672aeda Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 14 Apr 2017 23:26:10 +0200 Subject: [PATCH 823/865] types: Hide one of the 'bytevector->string' procedures. * module/system/base/types.scm: Hide 'bytevector->string' from (rnrs io ports). --- module/system/base/types.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/module/system/base/types.scm b/module/system/base/types.scm index 53a3dbe93..49aea27ba 100644 --- a/module/system/base/types.scm +++ b/module/system/base/types.scm @@ -1,5 +1,5 @@ ;;; 'SCM' type tag decoding. -;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc. +;;; Copyright (C) 2014, 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 License as published by @@ -16,7 +16,7 @@ (define-module (system base types) #:use-module (rnrs bytevectors) - #:use-module (rnrs io ports) + #:use-module ((rnrs io ports) #:hide (bytevector->string)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) From 6e573a0885d24d9ed36141ddf561c8b8b2e288e9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 17 Apr 2017 11:26:17 +0200 Subject: [PATCH 824/865] Attempt to mutate residualized literal pair throws exception * libguile/validate.h (SCM_VALIDATE_MUTABLE_PAIR): * libguile/pairs.h (scm_is_mutable_pair): New internal definitions. * libguile/pairs.c (scm_set_car_x, scm_set_cdr_x): Validate mutable pairs. * libguile/alist.c (scm_assq_set_x, scm_assv_set_x, scm_assoc_set_x): * libguile/list.c (scm_reverse_x, scm_list_set_x, scm_list_cdr_set_x): * libguile/srcprop.c (scm_make_srcprops): * libguile/srfi-1.c (scm_srfi1_append_reverse_x) (scm_srfi1_delete_duplicates_x): * libguile/symbols.c (scm_symbol_fset_x, scm_symbol_pset_x): * libguile/sort.c (scm_merge_list_x): Use scm_set_car_x / scm_set_cdr_x instead of the macros, so as to check for mutable pairs. (SCM_VALIDATE_MUTABLE_LIST): New internal helper macro. (scm_sort_x, scm_stable_sort_x, scm_sort_list_x): Use SCM_VALIDATE_MUTABLE_LIST. * libguile/vm-engine.c (VM_VALIDATE_MUTABLE_PAIR): New definition. (set-car!, set-cdr!): Use VM_VALIDATE_MUTABLE_PAIR. Fix error message for set-cdr!. --- libguile/alist.c | 6 +++--- libguile/list.c | 8 ++++---- libguile/pairs.c | 4 ++-- libguile/pairs.h | 16 ++++++++++++++++ libguile/sort.c | 20 ++++++++++++++++---- libguile/srcprop.c | 2 +- libguile/srfi-1.c | 6 +++--- libguile/symbols.c | 4 ++-- libguile/validate.h | 5 +++++ libguile/vm-engine.c | 6 ++++-- libguile/vm.c | 7 +++++++ 11 files changed, 63 insertions(+), 21 deletions(-) diff --git a/libguile/alist.c b/libguile/alist.c index 1e607f10b..b29186020 100644 --- a/libguile/alist.c +++ b/libguile/alist.c @@ -290,7 +290,7 @@ SCM_DEFINE (scm_assq_set_x, "assq-set!", 3, 0, 0, handle = scm_sloppy_assq (key, alist); if (scm_is_pair (handle)) { - SCM_SETCDR (handle, val); + scm_set_cdr_x (handle, val); return alist; } else @@ -308,7 +308,7 @@ SCM_DEFINE (scm_assv_set_x, "assv-set!", 3, 0, 0, handle = scm_sloppy_assv (key, alist); if (scm_is_pair (handle)) { - SCM_SETCDR (handle, val); + scm_set_cdr_x (handle, val); return alist; } else @@ -326,7 +326,7 @@ SCM_DEFINE (scm_assoc_set_x, "assoc-set!", 3, 0, 0, handle = scm_sloppy_assoc (key, alist); if (scm_is_pair (handle)) { - SCM_SETCDR (handle, val); + scm_set_cdr_x (handle, val); return alist; } else diff --git a/libguile/list.c b/libguile/list.c index e5036ed8d..939631531 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -391,14 +391,14 @@ SCM_DEFINE (scm_reverse_x, "reverse!", 1, 1, 0, while (scm_is_pair (lst)) { SCM old_tail = SCM_CDR (lst); - SCM_SETCDR (lst, tail); + scm_set_cdr_x (lst, tail); tail = lst; lst = old_tail; } if (SCM_LIKELY (SCM_NULL_OR_NIL_P (lst))) { - SCM_SETCDR (old_lst, new_tail); + scm_set_cdr_x (old_lst, new_tail); return tail; } @@ -454,7 +454,7 @@ SCM_DEFINE (scm_list_set_x, "list-set!", 3, 0, 0, unsigned long int i = scm_to_ulong (k); while (scm_is_pair (lst)) { if (i == 0) { - SCM_SETCAR (lst, val); + scm_set_car_x (lst, val); return val; } else { --i; @@ -500,7 +500,7 @@ SCM_DEFINE (scm_list_cdr_set_x, "list-cdr-set!", 3, 0, 0, size_t i = scm_to_size_t (k); while (scm_is_pair (lst)) { if (i == 0) { - SCM_SETCDR (lst, val); + scm_set_cdr_x (lst, val); return val; } else { --i; diff --git a/libguile/pairs.c b/libguile/pairs.c index 764458e36..cea545236 100644 --- a/libguile/pairs.c +++ b/libguile/pairs.c @@ -91,7 +91,7 @@ SCM_DEFINE (scm_set_car_x, "set-car!", 2, 0, 0, "by @code{set-car!} is unspecified.") #define FUNC_NAME s_scm_set_car_x { - SCM_VALIDATE_CONS (1, pair); + SCM_VALIDATE_MUTABLE_PAIR (1, pair); SCM_SETCAR (pair, value); return SCM_UNSPECIFIED; } @@ -104,7 +104,7 @@ SCM_DEFINE (scm_set_cdr_x, "set-cdr!", 2, 0, 0, "by @code{set-cdr!} is unspecified.") #define FUNC_NAME s_scm_set_cdr_x { - SCM_VALIDATE_CONS (1, pair); + SCM_VALIDATE_MUTABLE_PAIR (1, pair); SCM_SETCDR (pair, value); return SCM_UNSPECIFIED; } diff --git a/libguile/pairs.h b/libguile/pairs.h index 130bf28a6..08d6ad92c 100644 --- a/libguile/pairs.h +++ b/libguile/pairs.h @@ -176,6 +176,22 @@ scm_cdr (SCM x) } #endif +#ifdef BUILDING_LIBGUILE +static inline int +scm_is_mutable_pair (SCM x) +{ + /* Guile embeds literal pairs into compiled object files. It's not + valid Scheme to mutate literal values. Two practical reasons to + enforce this restriction are to allow literals to share share + structure (pairs) with other literals in the compilation unit, and + to allow literals containing immediates to be allocated in the + read-only, shareable section of the file. Attempting to mutate a + pair in the read-only section would cause a segmentation fault, so + to avoid that, we really do need to enforce the restriction. */ + return scm_is_pair (x) && GC_is_heap_ptr (SCM2PTR (x)); +} +#endif /* BUILDING_LIBGUILE */ + SCM_API SCM scm_cons2 (SCM w, SCM x, SCM y); SCM_API SCM scm_pair_p (SCM x); SCM_API SCM scm_set_car_x (SCM pair, SCM value); diff --git a/libguile/sort.c b/libguile/sort.c index 8c20d3453..81ef3ff27 100644 --- a/libguile/sort.c +++ b/libguile/sort.c @@ -306,22 +306,22 @@ scm_merge_list_x (SCM alist, SCM blist, SCM_TICK; if (scm_is_true (scm_call_2 (less, SCM_CAR (blist), SCM_CAR (alist)))) { - SCM_SETCDR (last, blist); + scm_set_cdr_x (last, blist); blist = SCM_CDR (blist); blen--; } else { - SCM_SETCDR (last, alist); + scm_set_cdr_x (last, alist); alist = SCM_CDR (alist); alen--; } last = SCM_CDR (last); } if ((alen > 0) && (blen == 0)) - SCM_SETCDR (last, alist); + scm_set_cdr_x (last, alist); else if ((alen == 0) && (blen > 0)) - SCM_SETCDR (last, blist); + scm_set_cdr_x (last, blist); } return build; } /* scm_merge_list_x */ @@ -398,6 +398,14 @@ scm_merge_list_step (SCM * seq, SCM less, long n) } /* scm_merge_list_step */ +#define SCM_VALIDATE_MUTABLE_LIST(pos, lst) \ + do { \ + SCM walk; \ + for (walk = lst; !scm_is_null_or_nil (walk); walk = SCM_CDR (walk)) \ + SCM_VALIDATE_MUTABLE_PAIR (pos, walk); \ + } while (0) + + SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0, (SCM items, SCM less), "Sort the sequence @var{items}, which may be a list or a\n" @@ -414,6 +422,7 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0, if (scm_is_pair (items)) { SCM_VALIDATE_LIST_COPYLEN (1, items, len); + SCM_VALIDATE_MUTABLE_LIST (1, items); return scm_merge_list_step (&items, less, len); } else if (scm_is_array (items) && scm_c_array_rank (items) == 1) @@ -533,6 +542,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0, if (scm_is_pair (items)) { SCM_VALIDATE_LIST_COPYLEN (1, items, len); + SCM_VALIDATE_MUTABLE_LIST (1, items); return scm_merge_list_step (&items, less, len); } else if (scm_is_array (items) && 1 == scm_c_array_rank (items)) @@ -596,6 +606,8 @@ SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0, long len; SCM_VALIDATE_LIST_COPYLEN (1, items, len); + SCM_VALIDATE_MUTABLE_LIST (1, items); + return scm_merge_list_step (&items, less, len); } #undef FUNC_NAME diff --git a/libguile/srcprop.c b/libguile/srcprop.c index 9544f6857..14e56bd1c 100644 --- a/libguile/srcprop.c +++ b/libguile/srcprop.c @@ -143,7 +143,7 @@ scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM alist) { alist = scm_acons (scm_sym_filename, filename, alist); if (scm_is_null (old_alist)) - SCM_SETCDR (scm_last_alist_filename, alist); + scm_set_cdr_x (scm_last_alist_filename, alist); } } diff --git a/libguile/srfi-1.c b/libguile/srfi-1.c index 353a746f5..08a4b22e2 100644 --- a/libguile/srfi-1.c +++ b/libguile/srfi-1.c @@ -119,7 +119,7 @@ SCM_DEFINE (scm_srfi1_append_reverse_x, "append-reverse!", 2, 0, 0, { SCM newtail; - while (scm_is_pair (revhead)) + while (scm_is_mutable_pair (revhead)) { /* take the first cons cell from revhead */ newtail = revhead; @@ -548,7 +548,7 @@ SCM_DEFINE (scm_srfi1_delete_duplicates_x, "delete-duplicates!", 1, 1, 0, if (scm_is_eq (l, endret)) { /* not equal to any, so append this pair */ - SCM_SETCDR (endret, lst); + scm_set_cdr_x (endret, lst); endret = lst; break; } @@ -557,7 +557,7 @@ SCM_DEFINE (scm_srfi1_delete_duplicates_x, "delete-duplicates!", 1, 1, 0, } /* terminate, in case last element was deleted */ - SCM_SETCDR (endret, SCM_EOL); + scm_set_cdr_x (endret, SCM_EOL); } /* demand that lst was a proper list */ diff --git a/libguile/symbols.c b/libguile/symbols.c index 71d982730..ab4b2cdd1 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -449,7 +449,7 @@ SCM_DEFINE (scm_symbol_fset_x, "symbol-fset!", 2, 0, 0, #define FUNC_NAME s_scm_symbol_fset_x { SCM_VALIDATE_SYMBOL (1, s); - SCM_SETCAR (SCM_CELL_OBJECT_3 (s), val); + scm_set_car_x (SCM_CELL_OBJECT_3 (s), val); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -461,7 +461,7 @@ SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0, #define FUNC_NAME s_scm_symbol_pset_x { SCM_VALIDATE_SYMBOL (1, s); - SCM_SETCDR (SCM_CELL_OBJECT_3 (s), val); + scm_set_cdr_x (SCM_CELL_OBJECT_3 (s), val); return SCM_UNSPECIFIED; } #undef FUNC_NAME diff --git a/libguile/validate.h b/libguile/validate.h index 7c0ce9bbd..a1b1b553a 100644 --- a/libguile/validate.h +++ b/libguile/validate.h @@ -240,6 +240,11 @@ #define SCM_VALIDATE_CONS(pos, scm) \ SCM_I_MAKE_VALIDATE_MSG2 (pos, scm, scm_is_pair, "pair") +#ifdef BUILDING_LIBGUILE +#define SCM_VALIDATE_MUTABLE_PAIR(pos, scm) \ + SCM_I_MAKE_VALIDATE_MSG2 (pos, scm, scm_is_mutable_pair, "mutable pair") +#endif /* BUILDING_LIBGUILE */ + #define SCM_VALIDATE_LIST(pos, lst) \ do { \ SCM_ASSERT (scm_ilength (lst) >= 0, lst, pos, FUNC_NAME); \ diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 89c6bc5f7..cb7d4aa12 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -424,6 +424,8 @@ VM_VALIDATE (x, SCM_CHARP, proc, char) #define VM_VALIDATE_PAIR(x, proc) \ VM_VALIDATE (x, scm_is_pair, proc, pair) +#define VM_VALIDATE_MUTABLE_PAIR(x, proc) \ + VM_VALIDATE (x, scm_is_mutable_pair, proc, mutable_pair) #define VM_VALIDATE_STRING(obj, proc) \ VM_VALIDATE (obj, scm_is_string, proc, string) #define VM_VALIDATE_STRUCT(obj, proc) \ @@ -2359,7 +2361,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_12_12 (op, a, b); x = SP_REF (a); y = SP_REF (b); - VM_VALIDATE_PAIR (x, "set-car!"); + VM_VALIDATE_MUTABLE_PAIR (x, "set-car!"); SCM_SETCAR (x, y); NEXT (1); } @@ -2375,7 +2377,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, UNPACK_12_12 (op, a, b); x = SP_REF (a); y = SP_REF (b); - VM_VALIDATE_PAIR (x, "set-car!"); + VM_VALIDATE_MUTABLE_PAIR (x, "set-cdr!"); SCM_SETCDR (x, y); NEXT (1); } diff --git a/libguile/vm.c b/libguile/vm.c index e8f75b14f..ea2bfbd0c 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -429,6 +429,7 @@ static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN SCM_NOINLINE; static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_char (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_pair (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; +static void vm_error_not_a_mutable_pair (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_string (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_atomic_box (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; @@ -527,6 +528,12 @@ vm_error_not_a_pair (const char *subr, SCM x) scm_wrong_type_arg_msg (subr, 1, x, "pair"); } +static void +vm_error_not_a_mutable_pair (const char *subr, SCM x) +{ + scm_wrong_type_arg_msg (subr, 1, x, "mutable pair"); +} + static void vm_error_not_a_string (const char *subr, SCM x) { From 7ed54fd36d2e381aa46ef8a7d2fc13a6776b573a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 18 Apr 2017 14:56:48 +0200 Subject: [PATCH 825/865] All literal constants are read-only * libguile/array-handle.c (initialize_vector_handle): Add mutable_p argument. Unless the vector handle is mutable, null out its writable_elements member. (scm_array_get_handle): Adapt to determine mutability of the various arrays. (scm_array_handle_elements, scm_array_handle_writable_elements): Reverse the sense: instead of implementing read-only in terms of read-write, go the other way around, adding an assertion in the read-write case that the array handle is mutable. * libguile/array-map.c (racp): Assert that the destination is mutable. * libguile/bitvectors.c (SCM_F_BITVECTOR_IMMUTABLE, IS_BITVECTOR): (IS_MUTABLE_BITVECTOR): Add a flag to indicate immutability. (scm_i_bitvector_bits): Fix indentation. (scm_i_is_mutable_bitvector): New helper. (scm_array_handle_bit_elements) ((scm_array_handle_bit_writable_elements): Build writable_elements in terms of elements. (scm_bitvector_elements, scm_bitvector_writable_elements): Likewise. (scm_c_bitvector_set_x): Require a mutable bitvector for the fast-path. (scm_bitvector_to_list, scm_bit_count): Use read-only elements() function. * libguile/bitvectors.h (scm_i_is_mutable_bitvector): New decl. * libguile/bytevectors.c (INTEGER_ACCESSOR_PROLOGUE): (INTEGER_GETTER_PROLOGUE, INTEGER_SETTER_PROLOGUE): (INTEGER_REF, INTEGER_NATIVE_REF, INTEGER_SET, INTEGER_NATIVE_SET): (GENERIC_INTEGER_ACCESSOR_PROLOGUE): (GENERIC_INTEGER_GETTER_PROLOGUE, GENERIC_INTEGER_SETTER_PROLOGUE): (LARGE_INTEGER_NATIVE_REF, LARGE_INTEGER_NATIVE_SET): (IEEE754_GETTER_PROLOGUE, IEEE754_SETTER_PROLOGUE): (IEEE754_REF, IEEE754_NATIVE_REF, IEEE754_SET, IEEE754_NATIVE_SET): Setters require a mutable bytevector. (SCM_BYTEVECTOR_SET_FLAG): New helper. (SCM_BYTEVECTOR_SET_CONTIGUOUS_P, SCM_BYTEVECTOR_SET_ELEMENT_TYPE): Remove helpers. (SCM_VALIDATE_MUTABLE_BYTEVECTOR): New helper. (make_bytevector, make_bytevector_from_buffer): Use SCM_SET_BYTEVECTOR_FLAGS. (scm_c_bytevector_set_x, scm_bytevector_fill_x) (scm_bytevector_copy_x): Require a mutable bytevector. * libguile/bytevectors.h (SCM_F_BYTEVECTOR_CONTIGUOUS) (SCM_F_BYTEVECTOR_IMMUTABLE, SCM_MUTABLE_BYTEVECTOR_P): New definitions. * libguile/bytevectors.h (SCM_BYTEVECTOR_CONTIGUOUS_P): Just access one bit. * libguile/srfi-4.c (DEFINE_SRFI_4_C_FUNCS): Implement writable_elements() in terms of elements(). * libguile/strings.c (scm_i_string_is_mutable): New helper. * libguile/uniform.c (scm_array_handle_uniform_elements): (scm_array_handle_uniform_writable_elements): Implement writable_elements in terms of elements. * libguile/vectors.c (SCM_VALIDATE_MUTABLE_VECTOR): New helper. (scm_vector_elements, scm_vector_writable_elements): Implement writable_elements in terms of elements. (scm_c_vector_set_x): Require a mutable vector. * libguile/vectors.h (SCM_F_VECTOR_IMMUTABLE, SCM_I_IS_MUTABLE_VECTOR): New definitions. * libguile/vm-engine.c (VM_VALIDATE_MUTABLE_BYTEVECTOR): (VM_VALIDATE_MUTABLE_VECTOR, vector-set!, vector-set!/immediate) (BV_BOUNDED_SET, BV_SET): Require mutable bytevector/vector. * libguile/vm.c (vm_error_not_a_mutable_bytevector): (vm_error_not_a_mutable_vector): New definitions. * module/system/vm/assembler.scm (link-data): Mark residualized vectors, bytevectors, and bitvectors as being read-only. --- libguile/array-handle.c | 29 +++++++---- libguile/array-map.c | 2 + libguile/bitvectors.c | 69 ++++++++++++++++---------- libguile/bitvectors.h | 1 + libguile/bytevectors.c | 91 ++++++++++++++++++---------------- libguile/bytevectors.h | 10 +++- libguile/srfi-4.c | 25 ++++++---- libguile/strings.c | 6 +++ libguile/strings.h | 2 +- libguile/uniform.c | 15 +++--- libguile/vectors.c | 30 +++++++---- libguile/vectors.h | 8 +++ libguile/vm-engine.c | 12 +++-- libguile/vm.c | 14 ++++++ module/system/vm/assembler.scm | 54 +++++++++++++------- 15 files changed, 237 insertions(+), 131 deletions(-) diff --git a/libguile/array-handle.c b/libguile/array-handle.c index 89277d9d6..3d81efc04 100644 --- a/libguile/array-handle.c +++ b/libguile/array-handle.c @@ -140,7 +140,7 @@ static void initialize_vector_handle (scm_t_array_handle *h, size_t len, scm_t_array_element_type element_type, scm_t_vector_ref vref, scm_t_vector_set vset, - void *writable_elements) + const void *elements, int mutable_p) { h->base = 0; h->ndims = 1; @@ -149,7 +149,8 @@ initialize_vector_handle (scm_t_array_handle *h, size_t len, h->dim0.ubnd = (ssize_t) (len - 1U); h->dim0.inc = 1; h->element_type = element_type; - h->elements = h->writable_elements = writable_elements; + h->elements = elements; + h->writable_elements = mutable_p ? ((void *) elements) : NULL; h->vector = h->array; h->vref = vref; h->vset = vset; @@ -169,19 +170,22 @@ scm_array_get_handle (SCM array, scm_t_array_handle *h) initialize_vector_handle (h, scm_c_string_length (array), SCM_ARRAY_ELEMENT_TYPE_CHAR, scm_c_string_ref, scm_c_string_set_x, - NULL); + NULL, + scm_i_string_is_mutable (array)); break; case scm_tc7_vector: initialize_vector_handle (h, scm_c_vector_length (array), SCM_ARRAY_ELEMENT_TYPE_SCM, scm_c_vector_ref, scm_c_vector_set_x, - SCM_I_VECTOR_WELTS (array)); + SCM_I_VECTOR_WELTS (array), + SCM_I_IS_MUTABLE_VECTOR (array)); break; case scm_tc7_bitvector: initialize_vector_handle (h, scm_c_bitvector_length (array), SCM_ARRAY_ELEMENT_TYPE_BIT, scm_c_bitvector_ref, scm_c_bitvector_set_x, - scm_i_bitvector_bits (array)); + scm_i_bitvector_bits (array), + scm_i_is_mutable_bitvector (array)); break; case scm_tc7_bytevector: { @@ -225,7 +229,8 @@ scm_array_get_handle (SCM array, scm_t_array_handle *h) } initialize_vector_handle (h, length, element_type, vref, vset, - SCM_BYTEVECTOR_CONTENTS (array)); + SCM_BYTEVECTOR_CONTENTS (array), + SCM_MUTABLE_BYTEVECTOR_P (array)); } break; case scm_tc7_array: @@ -320,15 +325,19 @@ scm_array_handle_release (scm_t_array_handle *h) const SCM * scm_array_handle_elements (scm_t_array_handle *h) { - return scm_array_handle_writable_elements (h); + if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM) + scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array"); + + return ((const SCM *) h->elements) + h->base; } SCM * scm_array_handle_writable_elements (scm_t_array_handle *h) { - if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM) - scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array"); - return ((SCM*)h->elements) + h->base; + if (h->writable_elements != h->elements) + scm_wrong_type_arg_msg (NULL, 0, h->array, "mutable array"); + + return (SCM *) scm_array_handle_elements (h); } void diff --git a/libguile/array-map.c b/libguile/array-map.c index c2825bc42..79383969d 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -263,6 +263,8 @@ racp (SCM src, SCM dst) { SCM const * el_s = h_s.elements; SCM * el_d = h_d.writable_elements; + if (!el_d) + scm_wrong_type_arg_msg ("array-copy!", SCM_ARG2, dst, "mutable array"); for (; n-- > 0; i_s += inc_s, i_d += inc_d) el_d[i_d] = el_s[i_s]; } diff --git a/libguile/bitvectors.c b/libguile/bitvectors.c index 7a4ed9bf9..cfca4ab6c 100644 --- a/libguile/bitvectors.c +++ b/libguile/bitvectors.c @@ -38,17 +38,30 @@ * but alack, all we have is this crufty C. */ -#define IS_BITVECTOR(obj) SCM_TYP16_PREDICATE(scm_tc7_bitvector,(obj)) +#define SCM_F_BITVECTOR_IMMUTABLE (0x80) + +#define IS_BITVECTOR(obj) SCM_HAS_TYP7 ((obj), scm_tc7_bitvector) +#define IS_MUTABLE_BITVECTOR(x) \ + (SCM_NIMP (x) && \ + ((SCM_CELL_TYPE (x) & (0x7f | SCM_F_BITVECTOR_IMMUTABLE)) \ + == scm_tc7_bitvector)) #define BITVECTOR_LENGTH(obj) ((size_t)SCM_CELL_WORD_1(obj)) #define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_CELL_WORD_2(obj)) -scm_t_uint32 *scm_i_bitvector_bits (SCM vec) +scm_t_uint32 * +scm_i_bitvector_bits (SCM vec) { if (!IS_BITVECTOR (vec)) abort (); return BITVECTOR_BITS (vec); } +int +scm_i_is_mutable_bitvector (SCM vec) +{ + return IS_MUTABLE_BITVECTOR (vec); +} + int scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate) { @@ -166,18 +179,17 @@ SCM_DEFINE (scm_bitvector_length, "bitvector-length", 1, 0, 0, const scm_t_uint32 * scm_array_handle_bit_elements (scm_t_array_handle *h) { - return scm_array_handle_bit_writable_elements (h); + if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_BIT) + scm_wrong_type_arg_msg (NULL, 0, h->array, "bit array"); + return ((const scm_t_uint32 *) h->elements) + h->base/32; } scm_t_uint32 * scm_array_handle_bit_writable_elements (scm_t_array_handle *h) { - SCM vec = h->array; - if (SCM_I_ARRAYP (vec)) - vec = SCM_I_ARRAY_V (vec); - if (IS_BITVECTOR (vec)) - return BITVECTOR_BITS (vec) + h->base/32; - scm_wrong_type_arg_msg (NULL, 0, h->array, "bit array"); + if (h->writable_elements != h->elements) + scm_wrong_type_arg_msg (NULL, 0, h->array, "mutable bit array"); + return (scm_t_uint32 *) scm_array_handle_bit_elements (h); } size_t @@ -193,7 +205,15 @@ scm_bitvector_elements (SCM vec, size_t *lenp, ssize_t *incp) { - return scm_bitvector_writable_elements (vec, h, offp, lenp, incp); + scm_generalized_vector_get_handle (vec, h); + if (offp) + { + scm_t_array_dim *dim = scm_array_handle_dims (h); + *offp = scm_array_handle_bit_elements_offset (h); + *lenp = dim->ubnd - dim->lbnd + 1; + *incp = dim->inc; + } + return scm_array_handle_bit_elements (h); } @@ -204,15 +224,12 @@ scm_bitvector_writable_elements (SCM vec, size_t *lenp, ssize_t *incp) { - scm_generalized_vector_get_handle (vec, h); - if (offp) - { - scm_t_array_dim *dim = scm_array_handle_dims (h); - *offp = scm_array_handle_bit_elements_offset (h); - *lenp = dim->ubnd - dim->lbnd + 1; - *incp = dim->inc; - } - return scm_array_handle_bit_writable_elements (h); + const scm_t_uint32 *ret = scm_bitvector_elements (vec, h, offp, lenp, incp); + + if (h->writable_elements != h->elements) + scm_wrong_type_arg_msg (NULL, 0, h->array, "mutable bit array"); + + return (scm_t_uint32 *) ret; } SCM @@ -260,7 +277,7 @@ scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val) scm_t_array_handle handle; scm_t_uint32 *bits, mask; - if (IS_BITVECTOR (vec)) + if (IS_MUTABLE_BITVECTOR (vec)) { if (idx >= BITVECTOR_LENGTH (vec)) scm_out_of_range (NULL, scm_from_size_t (idx)); @@ -283,7 +300,7 @@ scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val) else bits[idx/32] &= ~mask; - if (!IS_BITVECTOR (vec)) + if (!IS_MUTABLE_BITVECTOR (vec)) scm_array_handle_release (&handle); } @@ -382,11 +399,10 @@ SCM_DEFINE (scm_bitvector_to_list, "bitvector->list", 1, 0, 0, scm_t_array_handle handle; size_t off, len; ssize_t inc; - scm_t_uint32 *bits; + const scm_t_uint32 *bits; SCM res = SCM_EOL; - bits = scm_bitvector_writable_elements (vec, &handle, - &off, &len, &inc); + bits = scm_bitvector_elements (vec, &handle, &off, &len, &inc); if (off == 0 && inc == 1) { @@ -446,12 +462,11 @@ SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0, scm_t_array_handle handle; size_t off, len; ssize_t inc; - scm_t_uint32 *bits; + const scm_t_uint32 *bits; int bit = scm_to_bool (b); size_t count = 0; - bits = scm_bitvector_writable_elements (bitvector, &handle, - &off, &len, &inc); + bits = scm_bitvector_elements (bitvector, &handle, &off, &len, &inc); if (off == 0 && inc == 1 && len > 0) { diff --git a/libguile/bitvectors.h b/libguile/bitvectors.h index 6b2cb1e5c..57ae52fc8 100644 --- a/libguile/bitvectors.h +++ b/libguile/bitvectors.h @@ -71,6 +71,7 @@ SCM_API scm_t_uint32 *scm_bitvector_writable_elements (SCM vec, ssize_t *incp); SCM_INTERNAL scm_t_uint32 *scm_i_bitvector_bits (SCM vec); +SCM_INTERNAL int scm_i_is_mutable_bitvector (SCM vec); SCM_INTERNAL int scm_i_print_bitvector (SCM vec, SCM port, scm_print_state *pstate); SCM_INTERNAL SCM scm_i_bitvector_equal_p (SCM vec1, SCM vec2); SCM_INTERNAL void scm_init_bitvectors (void); diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index 7b4585d1f..7cd753009 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -74,11 +74,11 @@ #define SIGNEDNESS(_sign) SIGNEDNESS_ ## _sign -#define INTEGER_ACCESSOR_PROLOGUE(_len, _sign) \ +#define INTEGER_ACCESSOR_PROLOGUE(validate, _len, _sign) \ size_t c_len, c_index; \ _sign char *c_bv; \ \ - SCM_VALIDATE_BYTEVECTOR (1, bv); \ + SCM_VALIDATE_##validate (1, bv); \ c_index = scm_to_uint (index); \ \ c_len = SCM_BYTEVECTOR_LENGTH (bv); \ @@ -87,11 +87,17 @@ if (SCM_UNLIKELY (c_index + ((_len) >> 3UL) - 1 >= c_len)) \ scm_out_of_range (FUNC_NAME, index); +#define INTEGER_GETTER_PROLOGUE(_len, _sign) \ + INTEGER_ACCESSOR_PROLOGUE (BYTEVECTOR, _len, _sign) + +#define INTEGER_SETTER_PROLOGUE(_len, _sign) \ + INTEGER_ACCESSOR_PROLOGUE (MUTABLE_BYTEVECTOR, _len, _sign) + /* Template for fixed-size integer access (only 8, 16 or 32-bit). */ #define INTEGER_REF(_len, _sign) \ SCM result; \ \ - INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + INTEGER_GETTER_PROLOGUE (_len, _sign); \ SCM_VALIDATE_SYMBOL (3, endianness); \ \ { \ @@ -110,7 +116,7 @@ #define INTEGER_NATIVE_REF(_len, _sign) \ SCM result; \ \ - INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + INTEGER_GETTER_PROLOGUE (_len, _sign); \ \ { \ INT_TYPE (_len, _sign) c_result; \ @@ -123,7 +129,7 @@ /* Template for fixed-size integer modification (only 8, 16 or 32-bit). */ #define INTEGER_SET(_len, _sign) \ - INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + INTEGER_SETTER_PROLOGUE (_len, _sign); \ SCM_VALIDATE_SYMBOL (3, endianness); \ \ { \ @@ -149,7 +155,7 @@ /* Template for fixed-size integer modification using the native endianness. */ #define INTEGER_NATIVE_SET(_len, _sign) \ - INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + INTEGER_SETTER_PROLOGUE (_len, _sign); \ \ { \ scm_t_signed_bits c_value; \ @@ -176,22 +182,19 @@ #define SCM_BYTEVECTOR_HEADER_BYTES \ (SCM_BYTEVECTOR_HEADER_SIZE * sizeof (scm_t_bits)) +#define SCM_BYTEVECTOR_SET_FLAG(bv, flag) \ + SCM_SET_BYTEVECTOR_FLAGS ((bv), SCM_BYTEVECTOR_FLAGS (bv) | flag) #define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \ SCM_SET_CELL_WORD_1 ((_bv), (scm_t_bits) (_len)) #define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _contents) \ SCM_SET_CELL_WORD_2 ((_bv), (scm_t_bits) (_contents)) -#define SCM_BYTEVECTOR_SET_CONTIGUOUS_P(bv, contiguous_p) \ - SCM_SET_BYTEVECTOR_FLAGS ((bv), \ - SCM_BYTEVECTOR_ELEMENT_TYPE (bv) \ - | ((contiguous_p) << 8UL)) - -#define SCM_BYTEVECTOR_SET_ELEMENT_TYPE(bv, hint) \ - SCM_SET_BYTEVECTOR_FLAGS ((bv), \ - (hint) \ - | (SCM_BYTEVECTOR_CONTIGUOUS_P (bv) << 8UL)) #define SCM_BYTEVECTOR_SET_PARENT(_bv, _parent) \ SCM_SET_CELL_OBJECT_3 ((_bv), (_parent)) +#define SCM_VALIDATE_MUTABLE_BYTEVECTOR(pos, v) \ + SCM_MAKE_VALIDATE_MSG (pos, v, MUTABLE_BYTEVECTOR_P, "mutable bytevector") + + /* The empty bytevector. */ SCM scm_null_bytevector = SCM_UNSPECIFIED; @@ -223,10 +226,10 @@ make_bytevector (size_t len, scm_t_array_element_type element_type) ret = SCM_PACK_POINTER (contents); contents += SCM_BYTEVECTOR_HEADER_BYTES; + SCM_SET_BYTEVECTOR_FLAGS (ret, + element_type | SCM_F_BYTEVECTOR_CONTIGUOUS); SCM_BYTEVECTOR_SET_LENGTH (ret, c_len); SCM_BYTEVECTOR_SET_CONTENTS (ret, contents); - SCM_BYTEVECTOR_SET_CONTIGUOUS_P (ret, 1); - SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret, element_type); SCM_BYTEVECTOR_SET_PARENT (ret, SCM_BOOL_F); } @@ -253,10 +256,9 @@ make_bytevector_from_buffer (size_t len, void *contents, c_len = len * (scm_i_array_element_type_sizes[element_type] / 8); + SCM_SET_BYTEVECTOR_FLAGS (ret, element_type); SCM_BYTEVECTOR_SET_LENGTH (ret, c_len); SCM_BYTEVECTOR_SET_CONTENTS (ret, contents); - SCM_BYTEVECTOR_SET_CONTIGUOUS_P (ret, 0); - SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret, element_type); SCM_BYTEVECTOR_SET_PARENT (ret, SCM_BOOL_F); } @@ -390,7 +392,7 @@ scm_c_bytevector_set_x (SCM bv, size_t index, scm_t_uint8 value) size_t c_len; scm_t_uint8 *c_bv; - SCM_VALIDATE_BYTEVECTOR (1, bv); + SCM_VALIDATE_MUTABLE_BYTEVECTOR (1, bv); c_len = SCM_BYTEVECTOR_LENGTH (bv); c_bv = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bv); @@ -551,7 +553,7 @@ SCM_DEFINE (scm_bytevector_fill_x, "bytevector-fill!", 2, 0, 0, scm_t_uint8 *c_bv, c_fill; int value; - SCM_VALIDATE_BYTEVECTOR (1, bv); + SCM_VALIDATE_MUTABLE_BYTEVECTOR (1, bv); value = scm_to_int (fill); if (SCM_UNLIKELY ((value < -128) || (value > 255))) @@ -582,7 +584,7 @@ SCM_DEFINE (scm_bytevector_copy_x, "bytevector-copy!", 5, 0, 0, signed char *c_source, *c_target; SCM_VALIDATE_BYTEVECTOR (1, source); - SCM_VALIDATE_BYTEVECTOR (3, target); + SCM_VALIDATE_MUTABLE_BYTEVECTOR (3, target); c_len = scm_to_size_t (len); c_source_start = scm_to_size_t (source_start); @@ -707,8 +709,6 @@ SCM_DEFINE (scm_bytevector_s8_set_x, "bytevector-s8-set!", 3, 0, 0, } #undef FUNC_NAME -#undef OCTET_ACCESSOR_PROLOGUE - SCM_DEFINE (scm_bytevector_to_u8_list, "bytevector->u8-list", 1, 0, 0, (SCM bv), @@ -895,11 +895,11 @@ bytevector_large_set (char *c_bv, size_t c_size, int signed_p, return err; } -#define GENERIC_INTEGER_ACCESSOR_PROLOGUE(_sign) \ +#define GENERIC_INTEGER_ACCESSOR_PROLOGUE(validate, _sign) \ size_t c_len, c_index, c_size; \ char *c_bv; \ \ - SCM_VALIDATE_BYTEVECTOR (1, bv); \ + SCM_VALIDATE_##validate (1, bv); \ c_index = scm_to_size_t (index); \ c_size = scm_to_size_t (size); \ \ @@ -914,6 +914,10 @@ bytevector_large_set (char *c_bv, size_t c_size, int signed_p, if (SCM_UNLIKELY (c_index + c_size > c_len)) \ scm_out_of_range (FUNC_NAME, index); +#define GENERIC_INTEGER_GETTER_PROLOGUE(_sign) \ + GENERIC_INTEGER_ACCESSOR_PROLOGUE (BYTEVECTOR, _sign) +#define GENERIC_INTEGER_SETTER_PROLOGUE(_sign) \ + GENERIC_INTEGER_ACCESSOR_PROLOGUE (MUTABLE_BYTEVECTOR, _sign) /* Template of an integer reference function. */ #define GENERIC_INTEGER_REF(_sign) \ @@ -1063,7 +1067,7 @@ SCM_DEFINE (scm_bytevector_uint_ref, "bytevector-uint-ref", 4, 0, 0, "@var{index} in @var{bv}.") #define FUNC_NAME s_scm_bytevector_uint_ref { - GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned); + GENERIC_INTEGER_GETTER_PROLOGUE (unsigned); return (bytevector_unsigned_ref (&c_bv[c_index], c_size, endianness)); } @@ -1075,7 +1079,7 @@ SCM_DEFINE (scm_bytevector_sint_ref, "bytevector-sint-ref", 4, 0, 0, "@var{index} in @var{bv}.") #define FUNC_NAME s_scm_bytevector_sint_ref { - GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed); + GENERIC_INTEGER_GETTER_PROLOGUE (signed); return (bytevector_signed_ref (&c_bv[c_index], c_size, endianness)); } @@ -1087,7 +1091,7 @@ SCM_DEFINE (scm_bytevector_uint_set_x, "bytevector-uint-set!", 5, 0, 0, "to @var{value}.") #define FUNC_NAME s_scm_bytevector_uint_set_x { - GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned); + GENERIC_INTEGER_SETTER_PROLOGUE (unsigned); bytevector_unsigned_set (&c_bv[c_index], c_size, value, endianness, FUNC_NAME); @@ -1102,7 +1106,7 @@ SCM_DEFINE (scm_bytevector_sint_set_x, "bytevector-sint-set!", 5, 0, 0, "to @var{value}.") #define FUNC_NAME s_scm_bytevector_sint_set_x { - GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed); + GENERIC_INTEGER_SETTER_PROLOGUE (signed); bytevector_signed_set (&c_bv[c_index], c_size, value, endianness, FUNC_NAME); @@ -1330,7 +1334,7 @@ SCM_DEFINE (scm_bytevector_s16_native_set_x, "bytevector-s16-native-set!", `large_{ref,set}' variants on 32-bit machines. */ #define LARGE_INTEGER_REF(_len, _sign) \ - INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \ + INTEGER_GETTER_PROLOGUE(_len, _sign); \ SCM_VALIDATE_SYMBOL (3, endianness); \ \ return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \ @@ -1338,7 +1342,7 @@ SCM_DEFINE (scm_bytevector_s16_native_set_x, "bytevector-s16-native-set!", #define LARGE_INTEGER_SET(_len, _sign) \ int err; \ - INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + INTEGER_SETTER_PROLOGUE (_len, _sign); \ SCM_VALIDATE_SYMBOL (4, endianness); \ \ err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \ @@ -1348,14 +1352,14 @@ SCM_DEFINE (scm_bytevector_s16_native_set_x, "bytevector-s16-native-set!", \ return SCM_UNSPECIFIED; -#define LARGE_INTEGER_NATIVE_REF(_len, _sign) \ - INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \ - return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \ +#define LARGE_INTEGER_NATIVE_REF(_len, _sign) \ + INTEGER_GETTER_PROLOGUE(_len, _sign); \ + return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \ SIGNEDNESS (_sign), scm_i_native_endianness)); #define LARGE_INTEGER_NATIVE_SET(_len, _sign) \ int err; \ - INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \ + INTEGER_SETTER_PROLOGUE (_len, _sign); \ \ err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \ SIGNEDNESS (_sign), value, \ @@ -1665,13 +1669,16 @@ double_from_foreign_endianness (const union scm_ieee754_double *source) /* Templace getters and setters. */ -#define IEEE754_ACCESSOR_PROLOGUE(_type) \ - INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed); +#define IEEE754_GETTER_PROLOGUE(_type) \ + INTEGER_GETTER_PROLOGUE (sizeof (_type) << 3UL, signed); + +#define IEEE754_SETTER_PROLOGUE(_type) \ + INTEGER_SETTER_PROLOGUE (sizeof (_type) << 3UL, signed); #define IEEE754_REF(_type) \ _type c_result; \ \ - IEEE754_ACCESSOR_PROLOGUE (_type); \ + IEEE754_GETTER_PROLOGUE (_type); \ SCM_VALIDATE_SYMBOL (3, endianness); \ \ if (scm_is_eq (endianness, scm_i_native_endianness)) \ @@ -1690,7 +1697,7 @@ double_from_foreign_endianness (const union scm_ieee754_double *source) #define IEEE754_NATIVE_REF(_type) \ _type c_result; \ \ - IEEE754_ACCESSOR_PROLOGUE (_type); \ + IEEE754_GETTER_PROLOGUE (_type); \ \ memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \ return (IEEE754_TO_SCM (_type) (c_result)); @@ -1698,7 +1705,7 @@ double_from_foreign_endianness (const union scm_ieee754_double *source) #define IEEE754_SET(_type) \ _type c_value; \ \ - IEEE754_ACCESSOR_PROLOGUE (_type); \ + IEEE754_SETTER_PROLOGUE (_type); \ VALIDATE_REAL (3, value); \ SCM_VALIDATE_SYMBOL (4, endianness); \ c_value = IEEE754_FROM_SCM (_type) (value); \ @@ -1718,7 +1725,7 @@ double_from_foreign_endianness (const union scm_ieee754_double *source) #define IEEE754_NATIVE_SET(_type) \ _type c_value; \ \ - IEEE754_ACCESSOR_PROLOGUE (_type); \ + IEEE754_SETTER_PROLOGUE (_type); \ VALIDATE_REAL (3, value); \ c_value = IEEE754_FROM_SCM (_type) (value); \ \ diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h index af4ac1c34..77f0006a4 100644 --- a/libguile/bytevectors.h +++ b/libguile/bytevectors.h @@ -124,10 +124,18 @@ SCM_API SCM scm_utf32_to_string (SCM, SCM); SCM_SET_CELL_TYPE ((_bv), \ scm_tc7_bytevector | ((scm_t_bits)(_f) << 7UL)) +#define SCM_F_BYTEVECTOR_CONTIGUOUS 0x100UL +#define SCM_F_BYTEVECTOR_IMMUTABLE 0x200UL + +#define SCM_MUTABLE_BYTEVECTOR_P(x) \ + (SCM_NIMP (x) && \ + ((SCM_CELL_TYPE (x) & (0x7fUL | (SCM_F_BYTEVECTOR_IMMUTABLE << 7UL))) \ + == scm_tc7_bytevector)) + #define SCM_BYTEVECTOR_ELEMENT_TYPE(_bv) \ (SCM_BYTEVECTOR_FLAGS (_bv) & 0xffUL) #define SCM_BYTEVECTOR_CONTIGUOUS_P(_bv) \ - (SCM_BYTEVECTOR_FLAGS (_bv) >> 8UL) + (SCM_BYTEVECTOR_FLAGS (_bv) & SCM_F_BYTEVECTOR_CONTIGUOUS) #define SCM_BYTEVECTOR_TYPE_SIZE(var) \ (scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8) diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c index 057664c58..b0ed0ce17 100644 --- a/libguile/srfi-4.c +++ b/libguile/srfi-4.c @@ -119,23 +119,17 @@ { \ if (h->element_type != ETYPE (TAG)) \ scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector"); \ - return ((const ctype*) h->elements) + h->base*width; \ + return ((const ctype *) h->elements) + h->base*width; \ } \ ctype* scm_array_handle_##tag##_writable_elements (scm_t_array_handle *h) \ { \ - if (h->element_type != ETYPE (TAG)) \ - scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector"); \ - return ((ctype*) h->writable_elements) + h->base*width; \ + if (h->writable_elements != h->elements) \ + scm_wrong_type_arg_msg (NULL, 0, h->array, "mutable " #tag "vector"); \ + return (ctype *) scm_array_handle_##tag##_elements (h); \ } \ const ctype *scm_##tag##vector_elements (SCM uvec, \ scm_t_array_handle *h, \ size_t *lenp, ssize_t *incp) \ - { \ - return scm_##tag##vector_writable_elements (uvec, h, lenp, incp); \ - } \ - ctype *scm_##tag##vector_writable_elements (SCM uvec, \ - scm_t_array_handle *h, \ - size_t *lenp, ssize_t *incp) \ { \ size_t byte_width = width * sizeof (ctype); \ if (!scm_is_bytevector (uvec) \ @@ -146,7 +140,16 @@ *lenp = scm_c_bytevector_length (uvec) / byte_width; \ if (incp) \ *incp = 1; \ - return ((ctype *)h->writable_elements); \ + return ((const ctype *) h->elements); \ + } \ + ctype *scm_##tag##vector_writable_elements (SCM uvec, \ + scm_t_array_handle *h, \ + size_t *lenp, ssize_t *incp) \ + { \ + const ctype *ret = scm_##tag##vector_elements (uvec, h, lenp, incp);\ + if (h->writable_elements != h->elements) \ + scm_wrong_type_arg_msg (NULL, 0, h->array, "mutable " #tag "vector"); \ + return (ctype *) ret; \ } diff --git a/libguile/strings.c b/libguile/strings.c index 8d0aa453f..5c49e33d8 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -507,6 +507,12 @@ scm_i_string_length (SCM str) return STRING_LENGTH (str); } +int +scm_i_string_is_mutable (SCM str) +{ + return !IS_RO_STRING (str); +} + /* True if the string is 'narrow', meaning it has a 8-bit Latin-1 encoding. False if it is 'wide', having a 32-bit UCS-4 encoding. */ diff --git a/libguile/strings.h b/libguile/strings.h index 77690ce67..5b3e7805f 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -194,12 +194,12 @@ SCM_INTERNAL SCM scm_i_make_string (size_t len, char **datap, int read_only_p); SCM_INTERNAL SCM scm_i_make_wide_string (size_t len, scm_t_wchar **datap, int read_only_p); -SCM_INTERNAL SCM scm_i_set_string_read_only_x (SCM str); SCM_INTERNAL SCM scm_i_substring (SCM str, size_t start, size_t end); SCM_INTERNAL SCM scm_i_substring_read_only (SCM str, size_t start, size_t end); SCM_INTERNAL SCM scm_i_substring_shared (SCM str, size_t start, size_t end); SCM_INTERNAL SCM scm_i_substring_copy (SCM str, size_t start, size_t end); SCM_INTERNAL size_t scm_i_string_length (SCM str); +SCM_INTERNAL int scm_i_string_is_mutable (SCM str); SCM_API /* FIXME: not internal */ const char *scm_i_string_chars (SCM str); SCM_API /* FIXME: not internal */ char *scm_i_string_writable_chars (SCM str); SCM_INTERNAL const scm_t_wchar *scm_i_string_wide_chars (SCM str); diff --git a/libguile/uniform.c b/libguile/uniform.c index f7ca7bce9..13ee18a0c 100644 --- a/libguile/uniform.c +++ b/libguile/uniform.c @@ -67,18 +67,21 @@ scm_array_handle_uniform_element_bit_size (scm_t_array_handle *h) const void * scm_array_handle_uniform_elements (scm_t_array_handle *h) { - return scm_array_handle_uniform_writable_elements (h); + size_t esize; + const scm_t_uint8 *ret; + + esize = scm_array_handle_uniform_element_size (h); + ret = ((const scm_t_uint8 *) h->elements) + h->base * esize; + return ret; } void * scm_array_handle_uniform_writable_elements (scm_t_array_handle *h) { - size_t esize; - scm_t_uint8 *ret; + if (h->writable_elements != h->elements) + scm_wrong_type_arg_msg (NULL, 0, h->array, "mutable array"); - esize = scm_array_handle_uniform_element_size (h); - ret = ((scm_t_uint8*) h->writable_elements) + h->base * esize; - return ret; + return (void *) scm_array_handle_uniform_elements (h); } void diff --git a/libguile/vectors.c b/libguile/vectors.c index b9613c50f..328cf6f5f 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -42,6 +42,12 @@ #define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8) +#define SCM_VALIDATE_MUTABLE_VECTOR(pos, v) \ + do { \ + SCM_ASSERT (SCM_I_IS_MUTABLE_VECTOR (v), v, pos, FUNC_NAME); \ + } while (0) + + int scm_is_vector (SCM obj) { @@ -57,14 +63,6 @@ scm_is_simple_vector (SCM obj) const SCM * scm_vector_elements (SCM vec, scm_t_array_handle *h, size_t *lenp, ssize_t *incp) -{ - /* guard against weak vectors in the next call */ - return scm_vector_writable_elements (vec, h, lenp, incp); -} - -SCM * -scm_vector_writable_elements (SCM vec, scm_t_array_handle *h, - size_t *lenp, ssize_t *incp) { /* it's unsafe to access the memory of a weak vector */ if (SCM_I_WVECTP (vec)) @@ -77,7 +75,19 @@ scm_vector_writable_elements (SCM vec, scm_t_array_handle *h, *lenp = dim->ubnd - dim->lbnd + 1; *incp = dim->inc; } - return scm_array_handle_writable_elements (h); + return scm_array_handle_elements (h); +} + +SCM * +scm_vector_writable_elements (SCM vec, scm_t_array_handle *h, + size_t *lenp, ssize_t *incp) +{ + const SCM *ret = scm_vector_elements (vec, h, lenp, incp); + + if (h->writable_elements != h->elements) + scm_wrong_type_arg_msg (NULL, 0, vec, "mutable vector"); + + return (SCM *) ret; } SCM_DEFINE (scm_vector_p, "vector?", 1, 0, 0, @@ -203,7 +213,7 @@ void scm_c_vector_set_x (SCM v, size_t k, SCM obj) #define FUNC_NAME s_scm_vector_set_x { - SCM_VALIDATE_VECTOR (1, v); + SCM_VALIDATE_MUTABLE_VECTOR (1, v); if (k >= SCM_I_VECTOR_LENGTH (v)) scm_out_of_range (NULL, scm_from_size_t (k)); diff --git a/libguile/vectors.h b/libguile/vectors.h index 995f64f4e..d279787c8 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -63,6 +63,14 @@ SCM_API SCM *scm_vector_writable_elements (SCM vec, /* Internals */ +/* Vectors residualized into compiled objects have scm_tc7_vector in the + low 7 bits, but also an additional bit set to indicate + immutability. */ +#define SCM_F_VECTOR_IMMUTABLE 0x80UL +#define SCM_I_IS_MUTABLE_VECTOR(x) \ + (SCM_NIMP (x) && \ + ((SCM_CELL_TYPE (x) & (0x7f | SCM_F_VECTOR_IMMUTABLE)) \ + == scm_tc7_vector)) #define SCM_I_IS_VECTOR(x) (SCM_HAS_TYP7 (x, scm_tc7_vector)) #define SCM_I_VECTOR_ELTS(x) ((const SCM *) SCM_I_VECTOR_WELTS (x)) #define SCM_I_VECTOR_WELTS(x) (SCM_CELL_OBJECT_LOC (x, 1)) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index cb7d4aa12..6c88ebf11 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -420,6 +420,8 @@ VM_VALIDATE (x, scm_is_atomic_box, proc, atomic_box) #define VM_VALIDATE_BYTEVECTOR(x, proc) \ VM_VALIDATE (x, SCM_BYTEVECTOR_P, proc, bytevector) +#define VM_VALIDATE_MUTABLE_BYTEVECTOR(obj, proc) \ + VM_VALIDATE (obj, SCM_MUTABLE_BYTEVECTOR_P, proc, mutable_bytevector) #define VM_VALIDATE_CHAR(x, proc) \ VM_VALIDATE (x, SCM_CHARP, proc, char) #define VM_VALIDATE_PAIR(x, proc) \ @@ -434,6 +436,8 @@ VM_VALIDATE (obj, SCM_VARIABLEP, proc, variable) #define VM_VALIDATE_VECTOR(obj, proc) \ VM_VALIDATE (obj, SCM_I_IS_VECTOR, proc, vector) +#define VM_VALIDATE_MUTABLE_VECTOR(obj, proc) \ + VM_VALIDATE (obj, SCM_I_IS_MUTABLE_VECTOR, proc, mutable_vector) #define VM_VALIDATE_INDEX(u64, size, proc) \ VM_ASSERT (u64 < size, vm_error_out_of_range_uint64 (proc, u64)) @@ -2690,7 +2694,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, c_idx = SP_REF_U64 (idx); val = SP_REF (src); - VM_VALIDATE_VECTOR (vect, "vector-set!"); + VM_VALIDATE_MUTABLE_VECTOR (vect, "vector-set!"); VM_VALIDATE_INDEX (c_idx, SCM_I_VECTOR_LENGTH (vect), "vector-set!"); SCM_I_VECTOR_WELTS (vect)[c_idx] = val; NEXT (1); @@ -2710,7 +2714,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, vect = SP_REF (dst); val = SP_REF (src); - VM_VALIDATE_VECTOR (vect, "vector-set!"); + VM_VALIDATE_MUTABLE_VECTOR (vect, "vector-set!"); VM_VALIDATE_INDEX (idx, SCM_I_VECTOR_LENGTH (vect), "vector-set!"); SCM_I_VECTOR_WELTS (vect)[idx] = val; NEXT (1); @@ -3044,7 +3048,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, c_idx = SP_REF_U64 (idx); \ slot_val = SP_REF_ ## slot (src); \ \ - VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ + VM_VALIDATE_MUTABLE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ \ VM_ASSERT (SCM_BYTEVECTOR_LENGTH (bv) >= size \ && SCM_BYTEVECTOR_LENGTH (bv) - size >= c_idx, \ @@ -3070,7 +3074,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, c_idx = SP_REF_U64 (idx); \ val = SP_REF_ ## slot (src); \ \ - VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ + VM_VALIDATE_MUTABLE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ \ VM_ASSERT (SCM_BYTEVECTOR_LENGTH (bv) >= size \ && SCM_BYTEVECTOR_LENGTH (bv) - size >= c_idx, \ diff --git a/libguile/vm.c b/libguile/vm.c index ea2bfbd0c..18f219249 100644 --- a/libguile/vm.c +++ b/libguile/vm.c @@ -433,8 +433,10 @@ static void vm_error_not_a_mutable_pair (const char *subr, SCM x) SCM_NORETURN S static void vm_error_not_a_string (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_atomic_box (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_bytevector (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; +static void vm_error_not_a_mutable_bytevector (const char *subr, SCM v) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_struct (const char *subr, SCM x) SCM_NORETURN SCM_NOINLINE; static void vm_error_not_a_vector (const char *subr, SCM v) SCM_NORETURN SCM_NOINLINE; +static void vm_error_not_a_mutable_vector (const char *subr, SCM v) SCM_NORETURN SCM_NOINLINE; static void vm_error_out_of_range_uint64 (const char *subr, scm_t_uint64 idx) SCM_NORETURN SCM_NOINLINE; static void vm_error_out_of_range_int64 (const char *subr, scm_t_int64 idx) SCM_NORETURN SCM_NOINLINE; static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE; @@ -552,6 +554,12 @@ vm_error_not_a_bytevector (const char *subr, SCM x) scm_wrong_type_arg_msg (subr, 1, x, "bytevector"); } +static void +vm_error_not_a_mutable_bytevector (const char *subr, SCM x) +{ + scm_wrong_type_arg_msg (subr, 1, x, "mutable bytevector"); +} + static void vm_error_not_a_struct (const char *subr, SCM x) { @@ -564,6 +572,12 @@ vm_error_not_a_vector (const char *subr, SCM x) scm_wrong_type_arg_msg (subr, 1, x, "vector"); } +static void +vm_error_not_a_mutable_vector (const char *subr, SCM x) +{ + scm_wrong_type_arg_msg (subr, 1, x, "mutable vector"); +} + static void vm_error_out_of_range_uint64 (const char *subr, scm_t_uint64 idx) { diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 56c33be81..cfccd5b66 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -1392,17 +1392,27 @@ should be .data or .rodata), and return the resulting linker object. (+ address (modulo (- alignment (modulo address alignment)) alignment))) - (define tc7-vector 13) + (define tc7-vector #x0d) + (define vector-immutable-flag #x80) + + (define tc7-string #x15) + (define string-read-only-flag #x200) + + (define tc7-stringbuf #x27) (define stringbuf-wide-flag #x400) - (define tc7-stringbuf 39) - (define tc7-narrow-stringbuf tc7-stringbuf) - (define tc7-wide-stringbuf (+ tc7-stringbuf stringbuf-wide-flag)) - (define tc7-ro-string (+ 21 #x200)) + (define tc7-syntax #x3d) - (define tc7-program 69) - (define tc7-bytevector 77) - (define tc7-bitvector 95) - (define tc7-array 93) + + (define tc7-program #x45) + + (define tc7-bytevector #x4d) + ;; This flag is intended to be left-shifted by 7 bits. + (define bytevector-immutable-flag #x200) + + (define tc7-array #x5d) + + (define tc7-bitvector #x5f) + (define bitvector-immutable-flag #x80) (let ((word-size (asm-word-size asm)) (endianness (asm-endianness asm))) @@ -1447,9 +1457,10 @@ should be .data or .rodata), and return the resulting linker object. ((stringbuf? obj) (let* ((x (stringbuf-string obj)) (len (string-length x)) - (tag (if (= (string-bytes-per-char x) 1) - tc7-narrow-stringbuf - tc7-wide-stringbuf))) + (tag (logior tc7-stringbuf + (if (= (string-bytes-per-char x) 1) + 0 + stringbuf-wide-flag)))) (case word-size ((4) (bytevector-u32-set! buf pos tag endianness) @@ -1491,15 +1502,15 @@ should be .data or .rodata), and return the resulting linker object. (write-placeholder asm buf pos)) ((string? obj) - (let ((tag (logior tc7-ro-string (ash (string-length obj) 8)))) ; FIXME: unused? + (let ((tag (logior tc7-string string-read-only-flag))) (case word-size ((4) - (bytevector-u32-set! buf pos tc7-ro-string endianness) + (bytevector-u32-set! buf pos tag endianness) (write-placeholder asm buf (+ pos 4)) ; stringbuf (bytevector-u32-set! buf (+ pos 8) 0 endianness) (bytevector-u32-set! buf (+ pos 12) (string-length obj) endianness)) ((8) - (bytevector-u64-set! buf pos tc7-ro-string endianness) + (bytevector-u64-set! buf pos tag endianness) (write-placeholder asm buf (+ pos 8)) ; stringbuf (bytevector-u64-set! buf (+ pos 16) 0 endianness) (bytevector-u64-set! buf (+ pos 24) (string-length obj) endianness)) @@ -1511,7 +1522,7 @@ should be .data or .rodata), and return the resulting linker object. ((simple-vector? obj) (let* ((len (vector-length obj)) - (tag (logior tc7-vector (ash len 8)))) + (tag (logior tc7-vector vector-immutable-flag (ash len 8)))) (case word-size ((4) (bytevector-u32-set! buf pos tag endianness)) ((8) (bytevector-u64-set! buf pos tag endianness)) @@ -1546,9 +1557,14 @@ should be .data or .rodata), and return the resulting linker object. ((simple-uniform-vector? obj) (let ((tag (if (bitvector? obj) - tc7-bitvector - (let ((type-code (array-type-code obj))) - (logior tc7-bytevector (ash type-code 7)))))) + (logior tc7-bitvector + bitvector-immutable-flag) + (logior tc7-bytevector + ;; Bytevector immutable flag also shifted + ;; left. + (ash (logior bytevector-immutable-flag + (array-type-code obj)) + 7))))) (case word-size ((4) (bytevector-u32-set! buf pos tag endianness) From 622abec1d2006af2ae0fc35b1b2c4fa99d43b090 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 18 Apr 2017 15:33:09 +0200 Subject: [PATCH 826/865] Update NEWS * NEWS: Add note about constants and mutation. --- NEWS | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) diff --git a/NEWS b/NEWS index 3163f395c..f8c82561d 100644 --- a/NEWS +++ b/NEWS @@ -10,6 +10,40 @@ Changes in 2.2.1 (since 2.2.0): * Notable changes +** All literal constants are read-only + +According to the Scheme language definition, it is an error to attempt +to mutate a "constant literal". A constant literal is data that is a +literal quoted part of a program. For example, all of these are errors: + + (set-car! '(1 . 2) 42) + (append! '(1 2 3) '(4 5 6)) + (vector-set! '#(a b c) 1 'B) + +Guile takes advantage of this provision of Scheme to deduplicate shared +structure in constant literals within a compilation unit, and to +allocate constant data directly in the compiled object file. If the +data needs no relocation at run-time, as is the case for pairs or +vectors that only contain immediate values, then the data can actually +be shared between different Guile processes, using the operating +system's virtual memory facilities. + +However, in Guile 2.2.0, constants that needed relocation were actually +mutable -- though (vector-set! '#(a b c) 1 'B) was an error, Guile +wouldn't actually cause an exception to be raised, silently allowing the +mutation. This could affect future users of this constant, or indeed of +any constant in the compilation unit that shared structure with the +original vector. + +Additionally, attempting to mutate constant literals mapped in the +read-only section of files would actually cause a segmentation fault, as +the operating system prohibits writes to read-only memory. "Don't do +that" isn't a very nice solution :) + +Both of these problems have been fixed. Any attempt to mutate a +constant literal will now raise an exception, whether the constant needs +relocation or not. + ** Syntax objects are now a distinct type It used to be that syntax objects were represented as a tagged vector. From 7c71be0c7e8c533b221dbd71e29e94ea213787cf Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 18 Apr 2017 20:39:40 +0200 Subject: [PATCH 827/865] Add sandboxed evaluation facility * module/ice-9/sandbox.scm: New file. * module/Makefile.am (SOURCES): Add new file. * doc/ref/api-evaluation.texi (Sandboxed Evaluation): New section. * NEWS: Update. * test-suite/tests/sandbox.test: New file. * test-suite/Makefile.am: Add new file. --- NEWS | 7 + doc/ref/api-evaluation.texi | 265 +++++++ module/Makefile.am | 1 + module/ice-9/sandbox.scm | 1399 +++++++++++++++++++++++++++++++++ test-suite/Makefile.am | 1 + test-suite/tests/sandbox.test | 95 +++ 6 files changed, 1768 insertions(+) create mode 100644 module/ice-9/sandbox.scm create mode 100644 test-suite/tests/sandbox.test diff --git a/NEWS b/NEWS index f8c82561d..91d37202f 100644 --- a/NEWS +++ b/NEWS @@ -10,6 +10,13 @@ Changes in 2.2.1 (since 2.2.0): * Notable changes +** New sandboxed evaluation facility + +Guile now has a way to execute untrusted code in a safe way. See +"Sandboxed Evaluation" in the manual for full details, including some +important notes on limitations on the sandbox's ability to prevent +resource exhaustion. + ** All literal constants are read-only According to the Scheme language definition, it is an error to attempt diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index 3a3e9e632..7a4c8c975 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -22,6 +22,7 @@ loading, evaluating, and compiling Scheme code at run time. * Delayed Evaluation:: Postponing evaluation until it is needed. * Local Evaluation:: Evaluation in a local lexical environment. * Local Inclusion:: Compile-time inclusion of one file in another. +* Sandboxed Evaluation:: Evaluation with limited capabilities. * REPL Servers:: Serving a REPL over a socket. * Cooperative REPL Servers:: REPL server for single-threaded applications. @end menu @@ -1227,6 +1228,270 @@ the source files for a package (as you should!). It makes it possible to evaluate an installed file from source, instead of relying on the @code{.go} file being up to date. +@node Sandboxed Evaluation +@subsection Sandboxed Evaluation + +Sometimes you would like to evaluate code that comes from an untrusted +party. The safest way to do this is to buy a new computer, evaluate the +code on that computer, then throw the machine away. However if you are +unwilling to take this simple approach, Guile does include a limited +``sandbox'' facility that can allow untrusted code to be evaluated with +some confidence. + +To use the sandboxed evaluator, load its module: + +@example +(use-modules (ice-9 sandbox)) +@end example + +Guile's sandboxing facility starts with the ability to restrict the time +and space used by a piece of code. + +@deffn {Scheme Procedure} call-with-time-limit limit thunk limit-reached +Call @var{thunk}, but cancel it if @var{limit} seconds of wall-clock +time have elapsed. If the computation is cancelled, call +@var{limit-reached} in tail position. @var{thunk} must not disable +interrupts or prevent an abort via a @code{dynamic-wind} unwind handler. +@end deffn + +@deffn {Scheme Procedure} call-with-allocation-limit limit thunk limit-reached +Call @var{thunk}, but cancel it if @var{limit} bytes have been +allocated. If the computation is cancelled, call @var{limit-reached} in +tail position. @var{thunk} must not disable interrupts or prevent an +abort via a @code{dynamic-wind} unwind handler. + +This limit applies to both stack and heap allocation. The computation +will not be aborted before @var{limit} bytes have been allocated, but +for the heap allocation limit, the check may be postponed until the next garbage collection. + +Note that as a current shortcoming, the heap size limit applies to all +threads; concurrent allocation by other unrelated threads counts towards +the allocation limit. +@end deffn + +@deffn {Scheme Procedure} call-with-time-and-allocation-limits time-limit allocation-limit thunk +Invoke @var{thunk} in a dynamic extent in which its execution is limited +to @var{time-limit} seconds of wall-clock time, and its allocation to +@var{allocation-limit} bytes. @var{thunk} must not disable interrupts +or prevent an abort via a @code{dynamic-wind} unwind handler. + +If successful, return all values produced by invoking @var{thunk}. Any +uncaught exception thrown by the thunk will propagate out. If the time +or allocation limit is exceeded, an exception will be thrown to the +@code{limit-exceeded} key. +@end deffn + +The time limit and stack limit are both very precise, but the heap limit +only gets checked asynchronously, after a garbage collection. In +particular, if the heap is already very large, the number of allocated +bytes between garbage collections will be large, and therefore the +precision of the check is reduced. + +Additionally, due to the mechanism used by the allocation limit (the +@code{after-gc-hook}), large single allocations like @code{(make-vector +#e1e7)} are only detected after the allocation completes, even if the +allocation itself causes garbage collection. It's possible therefore +for user code to not only exceed the allocation limit set, but also to +exhaust all available memory, causing out-of-memory conditions at any +allocation site. Failure to allocate memory in Guile itself should be +safe and cause an exception to be thrown, but most systems are not +designed to handle @code{malloc} failures. An allocation failure may +therefore exercise unexpected code paths in your system, so it is a +weakness of the sandbox (and therefore an interesting point of attack). + +The main sandbox interface is @code{eval-in-sandbox}. + +@deffn {Scheme Procedure} eval-in-sandbox exp [#:time-limit 0.1] @ + [#:allocation-limit #e10e6] @ + [#:bindings all-pure-bindings] @ + [#:module (make-sandbox-module bindings)] @ + [#:sever-module? #t] +Evaluate the Scheme expression @var{exp} within an isolated +"sandbox". Limit its execution to @var{time-limit} seconds of +wall-clock time, and limit its allocation to @var{allocation-limit} +bytes. + +The evaluation will occur in @var{module}, which defaults to the result +of calling @code{make-sandbox-module} on @var{bindings}, which itself +defaults to @code{all-pure-bindings}. This is the core of the +sandbox: creating a scope for the expression that is @dfn{safe}. + +A safe sandbox module has two characteristics. Firstly, it will not +allow the expression being evaluated to avoid being cancelled due to +time or allocation limits. This ensures that the expression terminates +in a timely fashion. + +Secondly, a safe sandbox module will prevent the evaluation from +receiving information from previous evaluations, or from affecting +future evaluations. All combinations of binding sets exported by +@code{(ice-9 sandbox)} form safe sandbox modules. + +The @var{bindings} should be given as a list of import sets. One import +set is a list whose car names an interface, like @code{(ice-9 q)}, and +whose cdr is a list of imports. An import is either a bare symbol or a +pair of @code{(@var{out} . @var{in})}, where @var{out} and @var{in} are +both symbols and denote the name under which a binding is exported from +the module, and the name under which to make the binding available, +respectively. Note that @var{bindings} is only used as an input to the +default initializer for the @var{module} argument; if you pass +@code{#:module}, @var{bindings} is unused. If @var{sever-module?} is +true (the default), the module will be unlinked from the global module +tree after the evaluation returns, to allow @var{mod} to be +garbage-collected. + +If successful, return all values produced by @var{exp}. Any uncaught +exception thrown by the expression will propagate out. If the time or +allocation limit is exceeded, an exception will be thrown to the +@code{limit-exceeded} key. +@end deffn + +Constructing a safe sandbox module is tricky in general. Guile defines +an easy way to construct safe modules from predefined sets of bindings. +Before getting to that interface, here are some general notes on safety. + +@enumerate +@item The time and allocation limits rely on the ability to interrupt +and cancel a computation. For this reason, no binding included in a +sandbox module should be able to indefinitely postpone interrupt +handling, nor should a binding be able to prevent an abort. In practice +this second consideration means that @code{dynamic-wind} should not be +included in any binding set. +@item The time and allocation limits apply only to the +@code{eval-in-sandbox} call. If the call returns a procedure which is +later called, no limit is ``automatically'' in place. Users of +@code{eval-in-sandbox} have to be very careful to reimpose limits when +calling procedures that escape from sandboxes. +@item Similarly, the dynamic environment of the @code{eval-in-sandbox} +call is not necessarily in place when any procedure that escapes from +the sandbox is later called. + +This detail prevents us from exposing @code{primitive-eval} to the +sandbox, for two reasons. The first is that it's possible for legacy +code to forge references to any binding, if the +@code{allow-legacy-syntax-objects?} parameter is true. The default for +this parameter is true; @pxref{Syntax Transformer Helpers} for the +details. The parameter is bound to @code{#f} for the duration of the +@code{eval-in-sandbox} call itself, but that will not be in place during +calls to escaped procedures. + +The second reason we don't expose @code{primitive-eval} is that +@code{primitive-eval} implicitly works in the current module, which for +an escaped procedure will probably be different than the module that is +current for the @code{eval-in-sandbox} call itself. + +The common denominator here is that if an interface exposed to the +sandbox relies on dynamic environments, it is easy to mistakenly grant +the sandboxed procedure additional capabilities in the form of bindings +that it should not have access to. For this reason, the default sets of +predefined bindings do not depend on any dynamically scoped value. +@item Mutation may allow a sandboxed evaluation to break some invariant +in users of data supplied to it. A lot of code culturally doesn't +expect mutation, but if you hand mutable data to a sandboxed evaluation +and you also grant mutating capabilities to that evaluation, then the +sandboxed code may indeed mutate that data. The default set of bindings +to the sandbox do not include any mutating primitives. + +Relatedly, @code{set!} may allow a sandbox to mutate a primitive, +invalidating many system-wide invariants. Guile is currently quite +permissive when it comes to imported bindings and mutability. Although +@code{set!} to a module-local or lexically bound variable would be fine, +we don't currently have an easy way to disallow @code{set!} to an +imported binding, so currently no binding set includes @code{set!}. +@item Mutation may allow a sandboxed evaluation to keep state, or +make a communication mechanism with other code. On the one hand this +sounds cool, but on the other hand maybe this is part of your threat +model. Again, the default set of bindings doesn't include mutating +primitives, preventing sandboxed evaluations from keeping state. +@item The sandbox should probably not be able to open a network +connection, or write to a file, or open a file from disk. The default +binding set includes no interaction with the operating system. +@end enumerate + +If you, dear reader, find the above discussion interesting, you will +enjoy Jonathan Rees' dissertation, ``A Security Kernel Based on the +Lambda Calculus''. + +@defvr {Scheme Variable} all-pure-bindings +All ``pure'' bindings that together form a safe subset of those bindings +available by default to Guile user code. +@end defvr + +@defvr {Scheme Variable} all-pure-and-impure-bindings +Like @code{all-pure-bindings}, but additionally including mutating +primitives like @code{vector-set!}. This set is still safe in the sense +mentioned above, with the caveats about mutation. +@end defvr + +The components of these composite sets are as follows: +@defvr {Scheme Variable} alist-bindings +@defvrx {Scheme Variable} array-bindings +@defvrx {Scheme Variable} bit-bindings +@defvrx {Scheme Variable} bitvector-bindings +@defvrx {Scheme Variable} char-bindings +@defvrx {Scheme Variable} char-set-bindings +@defvrx {Scheme Variable} clock-bindings +@defvrx {Scheme Variable} core-bindings +@defvrx {Scheme Variable} error-bindings +@defvrx {Scheme Variable} fluid-bindings +@defvrx {Scheme Variable} hash-bindings +@defvrx {Scheme Variable} iteration-bindings +@defvrx {Scheme Variable} keyword-bindings +@defvrx {Scheme Variable} list-bindings +@defvrx {Scheme Variable} macro-bindings +@defvrx {Scheme Variable} nil-bindings +@defvrx {Scheme Variable} number-bindings +@defvrx {Scheme Variable} pair-bindings +@defvrx {Scheme Variable} predicate-bindings +@defvrx {Scheme Variable} procedure-bindings +@defvrx {Scheme Variable} promise-bindings +@defvrx {Scheme Variable} prompt-bindings +@defvrx {Scheme Variable} regexp-bindings +@defvrx {Scheme Variable} sort-bindings +@defvrx {Scheme Variable} srfi-4-bindings +@defvrx {Scheme Variable} string-bindings +@defvrx {Scheme Variable} symbol-bindings +@defvrx {Scheme Variable} unspecified-bindings +@defvrx {Scheme Variable} variable-bindings +@defvrx {Scheme Variable} vector-bindings +@defvrx {Scheme Variable} version-bindings +The components of @code{all-pure-bindings}. +@end defvr + +@defvr {Scheme Variable} mutating-alist-bindings +@defvrx {Scheme Variable} mutating-array-bindings +@defvrx {Scheme Variable} mutating-bitvector-bindings +@defvrx {Scheme Variable} mutating-fluid-bindings +@defvrx {Scheme Variable} mutating-hash-bindings +@defvrx {Scheme Variable} mutating-list-bindings +@defvrx {Scheme Variable} mutating-pair-bindings +@defvrx {Scheme Variable} mutating-sort-bindings +@defvrx {Scheme Variable} mutating-srfi-4-bindings +@defvrx {Scheme Variable} mutating-string-bindings +@defvrx {Scheme Variable} mutating-variable-bindings +@defvrx {Scheme Variable} mutating-vector-bindings +The additional components of @code{all-pure-and-impure-bindings}. +@end defvr + +Finally, what do you do with a binding set? What is a binding set +anyway? @code{make-sandbox-module} is here for you. + +@deffn {Scheme Procedure} make-sandbox-module bindings +Return a fresh module that only contains @var{bindings}. + +The @var{bindings} should be given as a list of import sets. One import +set is a list whose car names an interface, like @code{(ice-9 q)}, and +whose cdr is a list of imports. An import is either a bare symbol or a +pair of @code{(@var{out} . @var{in})}, where @var{out} and @var{in} are +both symbols and denote the name under which a binding is exported from +the module, and the name under which to make the binding available, +respectively. +@end deffn + +So you see that binding sets are just lists, and +@code{all-pure-and-impure-bindings} is really just the result of +appending all of the component binding sets. + + @node REPL Servers @subsection REPL Servers diff --git a/module/Makefile.am b/module/Makefile.am index ef7c20827..d5896bdd8 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -103,6 +103,7 @@ SOURCES = \ ice-9/rw.scm \ ice-9/safe-r5rs.scm \ ice-9/safe.scm \ + ice-9/sandbox.scm \ ice-9/save-stack.scm \ ice-9/scm-style-repl.scm \ ice-9/serialize.scm \ diff --git a/module/ice-9/sandbox.scm b/module/ice-9/sandbox.scm new file mode 100644 index 000000000..d25dc2d66 --- /dev/null +++ b/module/ice-9/sandbox.scm @@ -0,0 +1,1399 @@ +;;; Sandboxed evaluation of Scheme code + +;;; Copyright (C) 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: +;;; +;;; Code: + +(define-module (ice-9 sandbox) + #:use-module (ice-9 control) + #:use-module (ice-9 match) + #:use-module ((ice-9 threads) #:select (current-thread)) + #:use-module (system vm vm) + #:export (call-with-time-limit + call-with-allocation-limit + call-with-time-and-allocation-limits + + eval-in-sandbox + make-sandbox-module + + alist-bindings + array-bindings + bit-bindings + bitvector-bindings + char-bindings + char-set-bindings + clock-bindings + core-bindings + error-bindings + fluid-bindings + hash-bindings + iteration-bindings + keyword-bindings + list-bindings + macro-bindings + nil-bindings + number-bindings + pair-bindings + predicate-bindings + procedure-bindings + promise-bindings + prompt-bindings + regexp-bindings + sort-bindings + srfi-4-bindings + string-bindings + symbol-bindings + unspecified-bindings + variable-bindings + vector-bindings + version-bindings + + mutating-alist-bindings + mutating-array-bindings + mutating-bitvector-bindings + mutating-fluid-bindings + mutating-hash-bindings + mutating-list-bindings + mutating-pair-bindings + mutating-sort-bindings + mutating-srfi-4-bindings + mutating-string-bindings + mutating-variable-bindings + mutating-vector-bindings + + all-pure-bindings + all-pure-and-impure-bindings)) + + +(define (call-with-time-limit limit thunk limit-reached) + "Call @var{thunk}, but cancel it if @var{limit} seconds of wall-clock +time have elapsed. If the computation is cancelled, call +@var{limit-reached} in tail position. @var{thunk} must not disable +interrupts or prevent an abort via a @code{dynamic-wind} unwind +handler." + ;; FIXME: use separate thread instead of sigalrm. If rounded limit is + ;; <= 0, make it 1 usec to signal immediately. + (let ((limit-usecs (max (inexact->exact (round (* limit 1e6))) 1)) + (prev-sigalarm-handler #f) + (tag (make-prompt-tag))) + (call-with-prompt tag + (lambda () + (dynamic-wind + (lambda () + (set! prev-sigalarm-handler + (sigaction SIGALRM (lambda (sig) + ;; If signal handling is delayed + ;; until after prompt, no worries; + ;; the success path won the race. + (false-if-exception + (abort-to-prompt tag))))) + (setitimer ITIMER_REAL 0 0 0 limit-usecs)) + thunk + (lambda () + (setitimer ITIMER_REAL 0 0 0 0) + (match prev-sigalarm-handler + ((handler . flags) + (sigaction SIGALRM handler flags)))))) + (lambda (k) + (limit-reached))))) + +(define (call-with-allocation-limit limit thunk limit-reached) + "Call @var{thunk}, but cancel it if @var{limit} bytes have been +allocated. If the computation is cancelled, call @var{limit-reached} in +tail position. @var{thunk} must not disable interrupts or prevent an +abort via a @code{dynamic-wind} unwind handler. + +This limit applies to both stack and heap allocation. The computation +will not be aborted before @var{limit} bytes have been allocated, but +for the heap allocation limit, the check may be postponed until the next +garbage collection. + +Note that as a current shortcoming, the heap size limit applies to all +threads; concurrent allocation by other unrelated threads counts towards +the allocation limit." + (define (bytes-allocated) (assq-ref (gc-stats) 'heap-total-allocated)) + (let ((zero (bytes-allocated)) + (tag (make-prompt-tag)) + (thread (current-thread))) + (define (check-allocation) + (when (< limit (- (bytes-allocated) zero)) + (system-async-mark (lambda () + (false-if-exception (abort-to-prompt tag))) + thread))) + (call-with-prompt tag + (lambda () + (dynamic-wind + (lambda () + (add-hook! after-gc-hook check-allocation)) + (lambda () + (call-with-stack-overflow-handler + ;; The limit is in "words", which used to be 4 or 8 but now + ;; is always 8 bytes. + (max (floor/ limit 8) 1) + thunk + (lambda () (abort-to-prompt tag)))) + (lambda () + (remove-hook! after-gc-hook check-allocation)))) + (lambda (k) + (limit-reached))))) + +(define (call-with-time-and-allocation-limits time-limit allocation-limit + thunk) + "Invoke @var{thunk} in a dynamic extent in which its execution is +limited to @var{time-limit} seconds of wall-clock time, and its +allocation to @var{allocation-limit} bytes. @var{thunk} must not +disable interrupts or prevent an abort via a @code{dynamic-wind} unwind +handler. + +If successful, return all values produced by invoking @var{thunk}. Any +uncaught exception thrown by the thunk will propagate out. If the time +or allocation limit is exceeded, an exception will be thrown to the +@code{limit-exceeded} key." + (call-with-time-limit + time-limit + (lambda () + (call-with-allocation-limit + allocation-limit + thunk + (lambda () + (scm-error 'limit-exceeded "with-resource-limits" + "Allocation limit exceeded" '() #f)))) + (lambda () + (scm-error 'limit-exceeded "with-resource-limits" + "Time limit exceeded" '() #f)))) + +(define (sever-module! m) + "Remove @var{m} from its container module." + (match (module-name m) + ((head ... tail) + (let ((parent (resolve-module head #f))) + (unless (eq? m (module-ref-submodule parent tail)) + (error "can't sever module?")) + (hashq-remove! (module-submodules parent) tail))))) + +;; bindings := module-binding-list ... +;; module-binding-list := interface-name import ... +;; import := name | (exported-name . imported-name) +;; name := symbol +(define (make-sandbox-module bindings) + "Return a fresh module that only contains @var{bindings}. + +The @var{bindings} should be given as a list of import sets. One import +set is a list whose car names an interface, like @code{(ice-9 q)}, and +whose cdr is a list of imports. An import is either a bare symbol or a +pair of @code{(@var{out} . @var{in})}, where @var{out} and @var{in} are +both symbols and denote the name under which a binding is exported from +the module, and the name under which to make the binding available, +respectively." + (let ((m (make-fresh-user-module))) + (purify-module! m) + (module-use-interfaces! m + (map (match-lambda + ((mod-name . bindings) + (resolve-interface mod-name + #:select bindings))) + bindings)) + m)) + +(define* (eval-in-sandbox exp #:key + (time-limit 0.1) + (allocation-limit #e10e6) + (bindings all-pure-bindings) + (module (make-sandbox-module bindings)) + (sever-module? #t)) + "Evaluate the Scheme expression @var{exp} within an isolated +\"sandbox\". Limit its execution to @var{time-limit} seconds of +wall-clock time, and limit its allocation to @var{allocation-limit} +bytes. + +The evaluation will occur in @var{module}, which defaults to the result +of calling @code{make-sandbox-module} on @var{bindings}, which itself +defaults to @code{all-pure-bindings}. This is the core of the +sandbox: creating a scope for the expression that is @dfn{safe}. + +A safe sandbox module has two characteristics. Firstly, it will not +allow the expression being evaluated to avoid being cancelled due to +time or allocation limits. This ensures that the expression terminates +in a timely fashion. + +Secondly, a safe sandbox module will prevent the evaluation from +receiving information from previous evaluations, or from affecting +future evaluations. All combinations of binding sets exported by +@code{(ice-9 sandbox)} form safe sandbox modules. + +The @var{bindings} should be given as a list of import sets. One import +set is a list whose car names an interface, like @code{(ice-9 q)}, and +whose cdr is a list of imports. An import is either a bare symbol or a +pair of @code{(@var{out} . @var{in})}, where @var{out} and @var{in} are +both symbols and denote the name under which a binding is exported from +the module, and the name under which to make the binding available, +respectively. Note that @var{bindings} is only used as an input to the +default initializer for the @var{module} argument; if you pass +@code{#:module}, @var{bindings} is unused. If @var{sever-module?} is +true (the default), the module will be unlinked from the global module +tree after the evaluation returns, to allow @var{mod} to be +garbage-collected. + +If successful, return all values produced by @var{exp}. Any uncaught +exception thrown by the expression will propagate out. If the time or +allocation limit is exceeded, an exception will be thrown to the +@code{limit-exceeded} key." + (dynamic-wind + (lambda () #t) + (lambda () + (call-with-time-and-allocation-limits + time-limit allocation-limit + (lambda () + ;; Prevent the expression from forging syntax objects. See "Syntax + ;; Transformer Helpers" in the manual. + (parameterize ((allow-legacy-syntax-objects? #f)) + (eval exp module))))) + (lambda () (when sever-module? (sever-module! module))))) + + +;; An evaluation-sandboxing facility is safe if: +;; +;; (1) every evaluation will terminate in a timely manner +;; +;; (2) no evaluation can affect future evaluations +;; +;; For (1), we impose a user-controllable time limit on the evaluation, +;; in wall-clock time. When that limit is reached, Guile schedules an +;; asynchronous interrupt in the sandbox that aborts the computation. +;; For this to work, the sandboxed evaluation must not disable +;; interrupts, and it must not prevent timely aborts via malicious "out" +;; guards in dynamic-wind thunks. +;; +;; The sandbox also has an allocation limit that uses a similar cancel +;; mechanism, but this limit is less precise as it only runs at +;; garbage-collection time. +;; +;; The sandbox sets the allocation limit as the stack limit as well. +;; +;; For (2), the only way an evaluation can affect future evaluations is +;; if it causes a side-effect outside its sandbox. That side effect +;; could change the way the host or future sandboxed evaluations +;; operate, or it could leak information to future evaluations. +;; +;; One means of information leakage would be the file system. Although +;; one can imagine "safe" ways to access a file system, in practice we +;; just prevent all access to this and other operating system facilities +;; by not exposing the Guile primitives that access the file system, +;; connect to networking hosts, etc. If we chose our set of bindings +;; correctly and it is impossible to access host values other than those +;; given to the evaluation, then we have succeeded in granting only a +;; limited set of capabilities to the guest. +;; +;; To prevent information leakage we also limit other information about +;; the host, like its hostname or the Guile build information. +;; +;; The guest must also not have the capability to mutate a location used +;; by the host or by future sandboxed evaluations. Either you expose no +;; primitives to the evaluation that can mutate locations, or you expose +;; no mutable locations. In this sandbox we opt for a combination of +;; the two, though the selection of bindings is up to the user. "set!" +;; is always excluded, as Guile doesn't have a nice way to prevent set! +;; on imported bindings. But variable-set! is included, as no set of +;; bindings from this module includes a variable or a capability to a +;; variable. It's possible though to build sandbox modules with no +;; mutating primitives. As far as we know, all possible combinations of +;; the binding sets listed below are safe. +;; +(define core-bindings + '(((guile) + and + begin + apply + call-with-values + values + case + case-lambda + case-lambda* + cond + define + define* + define-values + do + if + lambda + lambda* + let + let* + letrec + letrec* + or + quasiquote + quote + ;; Can't allow mutation to globals. + ;; set! + unless + unquote + unquote-splicing + when + while + λ))) + +(define macro-bindings + '(((guile) + bound-identifier=? + ;; Although these have "current" in their name, they are lexically + ;; scoped, not dynamically scoped. + current-filename + current-source-location + datum->syntax + define-macro + define-syntax + define-syntax-parameter + define-syntax-rule + defmacro + free-identifier=? + generate-temporaries + gensym + identifier-syntax + identifier? + let-syntax + letrec-syntax + macroexpand + macroexpanded? + quasisyntax + start-stack + syntax + syntax->datum + syntax-case + syntax-error + syntax-parameterize + syntax-rules + syntax-source + syntax-violation + unsyntax + unsyntax-splicing + with-ellipsis + with-syntax + make-variable-transformer))) + +(define iteration-bindings + '(((guile) + compose + for-each + identity + iota + map + map-in-order + const + noop))) + +(define clock-bindings + '(((guile) + get-internal-real-time + internal-time-units-per-second + sleep + usleep))) + +(define procedure-bindings + '(((guile) + procedure-documentation + procedure-minimum-arity + procedure-name + procedure? + thunk?))) + +(define version-bindings + '(((guile) + effective-version + major-version + micro-version + minor-version + version + version-matches?))) + +(define nil-bindings + '(((guile) + nil?))) + +(define unspecified-bindings + '(((guile) + unspecified? + *unspecified*))) + +(define predicate-bindings + '(((guile) + ->bool + and-map + and=> + boolean? + eq? + equal? + eqv? + negate + not + or-map))) + +;; The current ports (current-input-port et al) are dynamically scoped, +;; which is a footgun from a sandboxing perspective. It's too easy for +;; a procedure that is the result of a sandboxed evaluation to be later +;; invoked in a different context and thereby be implicitly granted +;; capabilities to whatever port is then current. This is compounded by +;; the fact that most Scheme i/o primitives allow the port to be omitted +;; and thereby default to whatever's current. For now, sadly, we avoid +;; exposing any i/o primitive to the sandbox. +#; +(define i/o-bindings + '(((guile) + display + eof-object? + force-output + format + make-soft-port + newline + read + simple-format + write + write-char) + ((ice-9 ports) + %make-void-port + char-ready? + ;; Note that these are mutable parameters. + current-error-port + current-input-port + current-output-port + current-warning-port + drain-input + eof-object? + file-position + force-output + ftell + input-port? + output-port? + peek-char + port-closed? + port-column + port-conversion-strategy + port-encoding + port-filename + port-line + port-mode + port? + read-char + the-eof-object + ;; We don't provide open-output-string because it needs + ;; get-output-string, and get-output-string provides a generic + ;; capability on any output string port. For consistency then we + ;; don't provide open-input-string either; call-with-input-string + ;; is sufficient. + call-with-input-string + call-with-output-string + with-error-to-port + with-error-to-string + with-input-from-port + with-input-from-string + with-output-to-port + with-output-to-string))) + +;; If two evaluations are called with the same input port, unread-char +;; and unread-string can use a port as a mutable channel to pass +;; information from one to the other. +#; +(define mutating-i/o-bindings + '(((guile) + set-port-encoding!) + ((ice-9 ports) + close-input-port + close-output-port + close-port + file-set-position + seek + set-port-column! + set-port-conversion-strategy! + set-port-encoding! + set-port-filename! + set-port-line! + setvbuf + unread-char + unread-string))) + +(define error-bindings + '(((guile) + error + throw + with-throw-handler + catch + ;; false-if-exception can cause i/o if the #:warning arg is passed. + ;; false-if-exception + + ;; See notes on i/o-bindings. + ;; peek + ;; pk + ;; print-exception + ;; warn + strerror + scm-error + ))) + +;; FIXME: Currently we can't expose anything that works on the current +;; module to the sandbox. It could be that the sandboxed evaluation +;; returns a procedure, and that procedure may later be invoked in a +;; different context with a different current-module and it is unlikely +;; that the later caller will consider themselves as granting a +;; capability on whatever module is then current. Likewise export (and +;; by extension, define-public and the like) also operate on the current +;; module. +;; +;; It could be that we could expose a statically scoped eval to the +;; sandbox. +#; +(define eval-bindings + '(((guile) + current-module + module-name + module? + define-once + define-private + define-public + defined? + export + defmacro-public + ;; FIXME: single-arg eval? + eval + primitive-eval + eval-string + self-evaluating? + ;; Can we? + set-current-module))) + +(define sort-bindings + '(((guile) + sort + sorted? + stable-sort + sort-list))) + +;; These can only form part of a safe binding set if no mutable pair or +;; vector is exposed to the sandbox. +(define mutating-sort-bindings + '(((guile) + sort! + stable-sort! + sort-list! + restricted-vector-sort!))) + +(define regexp-bindings + '(((guile) + make-regexp + regexp-exec + regexp/basic + regexp/extended + regexp/icase + regexp/newline + regexp/notbol + regexp/noteol + regexp?))) + +(define alist-bindings + '(((guile) + acons + assoc + assoc-ref + assq + assq-ref + assv + assv-ref + sloppy-assoc + sloppy-assq + sloppy-assv))) + +;; These can only form part of a safe binding set if no mutable pair +;; is exposed to the sandbox. Unfortunately all charsets in Guile are +;; mutable, currently, including the built-in charsets, so we can't +;; expose these primitives. +(define mutating-alist-bindings + '(((guile) + assoc-remove! + assoc-set! + assq-remove! + assq-set! + assv-remove! + assv-set!))) + +(define number-bindings + '(((guile) + * + + + - + / + 1+ + 1- + < + <= + = + > + >= + abs + acos + acosh + angle + asin + asinh + atan + atanh + ceiling + ceiling-quotient + ceiling-remainder + ceiling/ + centered-quotient + centered-remainder + centered/ + complex? + cos + cosh + denominator + euclidean-quotient + euclidean-remainder + euclidean/ + even? + exact->inexact + exact-integer-sqrt + exact-integer? + exact? + exp + expt + finite? + floor + floor-quotient + floor-remainder + floor/ + gcd + imag-part + inf + inf? + integer-expt + integer-length + integer? + lcm + log + log10 + magnitude + make-polar + make-rectangular + max + min + modulo + modulo-expt + most-negative-fixnum + most-positive-fixnum + nan + nan? + negative? + numerator + odd? + positive? + quotient + rational? + rationalize + real-part + real? + remainder + round + round-quotient + round-remainder + round/ + sin + sinh + sqrt + tan + tanh + truncate + truncate-quotient + truncate-remainder + truncate/ + zero? + number? + number->string + string->number))) + +(define char-set-bindings + '(((guile) + ->char-set + char-set + char-set->list + char-set->string + char-set-adjoin + char-set-any + char-set-complement + char-set-contains? + char-set-copy + char-set-count + char-set-cursor + char-set-cursor-next + char-set-delete + char-set-diff+intersection + char-set-difference + char-set-every + char-set-filter + char-set-fold + char-set-for-each + char-set-hash + char-set-intersection + char-set-map + char-set-ref + char-set-size + char-set-unfold + char-set-union + char-set-xor + char-set:ascii + char-set:blank + char-set:designated + char-set:digit + char-set:empty + char-set:full + char-set:graphic + char-set:hex-digit + char-set:iso-control + char-set:letter + char-set:letter+digit + char-set:lower-case + char-set:printing + char-set:punctuation + char-set:symbol + char-set:title-case + char-set:upper-case + char-set:whitespace + char-set<= + char-set= + char-set? + end-of-char-set? + list->char-set + string->char-set + ucs-range->char-set))) + +;; These can only form part of a safe binding set if no mutable char-set +;; is exposed to the sandbox. Unfortunately all charsets in Guile are +;; mutable, currently, including the built-in charsets, so we can't +;; expose these primitives. +#; +(define mutating-char-set-bindings + '(((guile) + char-set-adjoin! + char-set-complement! + char-set-delete! + char-set-diff+intersection! + char-set-difference! + char-set-filter! + char-set-intersection! + char-set-unfold! + char-set-union! + char-set-xor! + list->char-set! + string->char-set! + ucs-range->char-set!))) + +(define array-bindings + '(((guile) + array->list + array-cell-ref + array-contents + array-dimensions + array-equal? + array-for-each + array-in-bounds? + array-length + array-rank + array-ref + array-shape + array-slice + array-slice-for-each + array-slice-for-each-in-order + array-type + array-type-code + array? + list->array + list->typed-array + make-array + make-shared-array + make-typed-array + shared-array-increments + shared-array-offset + shared-array-root + transpose-array + typed-array?))) + +;; These can only form part of a safe binding set if no mutable vector, +;; bitvector, bytevector, srfi-4 vector, or array is exposed to the +;; sandbox. +(define mutating-array-bindings + '(((guile) + array-cell-set! + array-copy! + array-copy-in-order! + array-fill! + array-index-map! + array-map! + array-map-in-order! + array-set!))) + +(define hash-bindings + '(((guile) + doubly-weak-hash-table? + hash + hash-count + hash-fold + hash-for-each + hash-for-each-handle + hash-get-handle + hash-map->list + hash-ref + hash-table? + hashq + hashq-get-handle + hashq-ref + hashv + hashv-get-handle + hashv-ref + hashx-get-handle + hashx-ref + make-doubly-weak-hash-table + make-hash-table + make-weak-key-hash-table + make-weak-value-hash-table + weak-key-hash-table? + weak-value-hash-table?))) + +;; These can only form part of a safe binding set if no hash table is +;; exposed to the sandbox. +(define mutating-hash-bindings + '(((guile) + hash-clear! + hash-create-handle! + hash-remove! + hash-set! + hashq-create-handle! + hashq-remove! + hashq-set! + hashv-create-handle! + hashv-remove! + hashv-set! + hashx-create-handle! + hashx-remove! + hashx-set!))) + +(define variable-bindings + '(((guile) + make-undefined-variable + make-variable + variable-bound? + variable-ref + variable?))) + +;; These can only form part of a safe binding set if no mutable variable +;; is exposed to the sandbox; this applies particularly to variables +;; that are module bindings. +(define mutating-variable-bindings + '(((guile) + variable-set! + variable-unset!))) + +(define string-bindings + '(((guile) + absolute-file-name? + file-name-separator-string + file-name-separator? + in-vicinity + basename + dirname + + list->string + make-string + object->string + reverse-list->string + string + string->list + string-any + string-any-c-code + string-append + string-append/shared + string-capitalize + string-ci< + string-ci<= + string-ci<=? + string-ci<> + string-ci + string-ci>= + string-ci>=? + string-ci>? + string-compare + string-compare-ci + string-concatenate + string-concatenate-reverse + string-concatenate-reverse/shared + string-concatenate/shared + string-contains + string-contains-ci + string-copy + string-count + string-delete + string-downcase + string-drop + string-drop-right + string-every + string-every-c-code + string-filter + string-fold + string-fold-right + string-for-each + string-for-each-index + string-hash + string-hash-ci + string-index + string-index-right + string-join + string-length + string-map + string-normalize-nfc + string-normalize-nfd + string-normalize-nfkc + string-normalize-nfkd + string-null? + string-pad + string-pad-right + string-prefix-ci? + string-prefix-length + string-prefix-length-ci + string-prefix? + string-ref + string-replace + string-reverse + string-rindex + string-skip + string-skip-right + string-split + string-suffix-ci? + string-suffix-length + string-suffix-length-ci + string-suffix? + string-tabulate + string-take + string-take-right + string-titlecase + string-tokenize + string-trim + string-trim-both + string-trim-right + string-unfold + string-unfold-right + string-upcase + string-utf8-length + string< + string<= + string<=? + string<> + string + string>= + string>=? + string>? + string? + substring + substring/copy + substring/read-only + substring/shared + xsubstring))) + +;; These can only form part of a safe binding set if no mutable string +;; is exposed to the sandbox. +(define mutating-string-bindings + '(((guile) + string-capitalize! + string-copy! + string-downcase! + string-fill! + string-map! + string-reverse! + string-set! + string-titlecase! + string-upcase! + string-xcopy! + substring-fill! + substring-move!))) + +(define symbol-bindings + '(((guile) + string->symbol + string-ci->symbol + symbol->string + list->symbol + make-symbol + symbol + symbol-append + symbol-hash + symbol-interned? + symbol?))) + +(define keyword-bindings + '(((guile) + keyword? + keyword->symbol + symbol->keyword))) + +;; These can only form part of a safe binding set if no valid prompt tag +;; is ever exposed to the sandbox, or can be constructed by the sandbox. +(define prompt-bindings + '(((guile) + abort-to-prompt + abort-to-prompt* + call-with-prompt + make-prompt-tag))) + +(define bit-bindings + '(((guile) + ash + round-ash + logand + logcount + logior + lognot + logtest + logxor + logbit?))) + +(define bitvector-bindings + '(((guile) + bit-count + bit-count* + bit-extract + bit-position + bitvector + bitvector->list + bitvector-length + bitvector-ref + bitvector? + list->bitvector + make-bitvector))) + +;; These can only form part of a safe binding set if no mutable +;; bitvector is exposed to the sandbox. +(define mutating-bitvector-bindings + '(((guile) + bit-invert! + bit-set*! + bitvector-fill! + bitvector-set!))) + +(define fluid-bindings + '(((guile) + fluid-bound? + fluid-ref + ;; fluid-ref* could escape the sandbox and is not allowed. + fluid-thread-local? + fluid? + make-fluid + make-thread-local-fluid + make-unbound-fluid + with-fluid* + with-fluids + with-fluids* + make-parameter + parameter? + parameterize))) + +;; These can only form part of a safe binding set if no fluid is +;; directly exposed to the sandbox. +(define mutating-fluid-bindings + '(((guile) + fluid-set! + fluid-unset! + fluid->parameter))) + +(define char-bindings + '(((guile) + char-alphabetic? + char-ci<=? + char-ci=? + char-ci>? + char-downcase + char-general-category + char-is-both? + char-lower-case? + char-numeric? + char-titlecase + char-upcase + char-upper-case? + char-whitespace? + char<=? + char=? + char>? + char? + char->integer + integer->char))) + +(define list-bindings + '(((guile) + list + list-cdr-ref + list-copy + list-head + list-index + list-ref + list-tail + list? + null? + make-list + append + delete + delq + delv + filter + length + member + memq + memv + merge + reverse))) + +;; These can only form part of a safe binding set if no mutable +;; pair is exposed to the sandbox. +(define mutating-list-bindings + '(((guile) + list-cdr-set! + list-set! + append! + delete! + delete1! + delq! + delq1! + delv! + delv1! + filter! + merge! + reverse!))) + +(define pair-bindings + '(((guile) + last-pair + pair? + caaaar + caaadr + caaar + caadar + caaddr + caadr + caar + cadaar + cadadr + cadar + caddar + cadddr + caddr + cadr + car + cdaaar + cdaadr + cdaar + cdadar + cdaddr + cdadr + cdar + cddaar + cddadr + cddar + cdddar + cddddr + cdddr + cddr + cdr + cons + cons*))) + +;; These can only form part of a safe binding set if no mutable +;; pair is exposed to the sandbox. +(define mutating-pair-bindings + '(((guile) + set-car! + set-cdr!))) + +(define vector-bindings + '(((guile) + list->vector + make-vector + vector + vector->list + vector-copy + vector-length + vector-ref + vector?))) + +;; These can only form part of a safe binding set if no mutable +;; vector is exposed to the sandbox. +(define mutating-vector-bindings + '(((guile) + vector-fill! + vector-move-left! + vector-move-right! + vector-set!))) + +(define promise-bindings + '(((guile) + force + delay + make-promise + promise?))) + +(define srfi-4-bindings + '(((srfi srfi-4) + f32vector + f32vector->list + f32vector-length + f32vector-ref + f32vector? + f64vector + f64vector->list + f64vector-length + f64vector-ref + f64vector? + list->f32vector + list->f64vector + list->s16vector + list->s32vector + list->s64vector + list->s8vector + list->u16vector + list->u32vector + list->u64vector + list->u8vector + make-f32vector + make-f64vector + make-s16vector + make-s32vector + make-s64vector + make-s8vector + make-u16vector + make-u32vector + make-u64vector + make-u8vector + s16vector + s16vector->list + s16vector-length + s16vector-ref + s16vector? + s32vector + s32vector->list + s32vector-length + s32vector-ref + s32vector? + s64vector + s64vector->list + s64vector-length + s64vector-ref + s64vector? + s8vector + s8vector->list + s8vector-length + s8vector-ref + s8vector? + u16vector + u16vector->list + u16vector-length + u16vector-ref + u16vector? + u32vector + u32vector->list + u32vector-length + u32vector-ref + u32vector? + u64vector + u64vector->list + u64vector-length + u64vector-ref + u64vector? + u8vector + u8vector->list + u8vector-length + u8vector-ref + u8vector?))) + +;; These can only form part of a safe binding set if no mutable +;; bytevector is exposed to the sandbox. +(define mutating-srfi-4-bindings + '(((srfi srfi-4) + f32vector-set! + f64vector-set! + s16vector-set! + s32vector-set! + s64vector-set! + s8vector-set! + u16vector-set! + u32vector-set! + u64vector-set! + u8vector-set!))) + +(define all-pure-bindings + (append alist-bindings + array-bindings + bit-bindings + bitvector-bindings + char-bindings + char-set-bindings + clock-bindings + core-bindings + error-bindings + fluid-bindings + hash-bindings + iteration-bindings + keyword-bindings + list-bindings + macro-bindings + nil-bindings + number-bindings + pair-bindings + predicate-bindings + procedure-bindings + promise-bindings + prompt-bindings + regexp-bindings + sort-bindings + srfi-4-bindings + string-bindings + symbol-bindings + unspecified-bindings + variable-bindings + vector-bindings + version-bindings)) + + +(define all-pure-and-impure-bindings + (append all-pure-bindings + mutating-alist-bindings + mutating-array-bindings + mutating-bitvector-bindings + mutating-fluid-bindings + mutating-hash-bindings + mutating-list-bindings + mutating-pair-bindings + mutating-sort-bindings + mutating-srfi-4-bindings + mutating-string-bindings + mutating-variable-bindings + mutating-vector-bindings)) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 3ce90707e..bbf41b673 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -125,6 +125,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/regexp.test \ tests/rtl.test \ tests/rtl-compilation.test \ + tests/sandbox.test \ tests/session.test \ tests/signals.test \ tests/sort.test \ diff --git a/test-suite/tests/sandbox.test b/test-suite/tests/sandbox.test new file mode 100644 index 000000000..3a1653a97 --- /dev/null +++ b/test-suite/tests/sandbox.test @@ -0,0 +1,95 @@ +;;;; sandbox.test --- tests guile's evaluator -*- scheme -*- +;;;; Copyright (C) 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-suite sandbox) + #:use-module (test-suite lib) + #:use-module (ice-9 sandbox)) + + +(define exception:bad-expression + (cons 'syntax-error "Bad expression")) + +(define exception:failed-match + (cons 'syntax-error "failed to match any pattern")) + +(define exception:not-a-list + (cons 'wrong-type-arg "Not a list")) + +(define exception:wrong-length + (cons 'wrong-type-arg "wrong length")) + +(define (usleep-loop usecs) + (unless (zero? usecs) + (usleep-loop (usleep usecs)))) +(define (busy-loop) + (busy-loop)) + +(with-test-prefix "time limit" + (pass-if "0 busy loop" + (call-with-time-limit 0 busy-loop (lambda () #t))) + (pass-if "0.001 busy loop" + (call-with-time-limit 0.001 busy-loop (lambda () #t))) + (pass-if "0 sleep" + (call-with-time-limit 0 (lambda () (usleep-loop #e1e6) #f) + (lambda () #t))) + (pass-if "0.001 sleep" + (call-with-time-limit 0.001 (lambda () (usleep-loop #e1e6) #f) + (lambda () #t)))) + +(define (alloc-loop) + (let lp ((ret #t)) + (and ret + (lp (cons #t #t))))) +(define (recur-loop) + (1+ (recur-loop))) + +(with-test-prefix "allocation limit" + (pass-if "0 alloc loop" + (call-with-allocation-limit 0 alloc-loop (lambda () #t))) + (pass-if "1e6 alloc loop" + (call-with-allocation-limit #e1e6 alloc-loop (lambda () #t))) + (pass-if "0 recurse" + (call-with-allocation-limit 0 recur-loop (lambda () #t))) + (pass-if "1e6 recurse" + (call-with-allocation-limit #e1e6 recur-loop (lambda () #t)))) + +(define-syntax-rule (pass-if-unbound foo) + (pass-if-exception (format #f "~a unavailable" 'foo) + exception:unbound-var (eval-in-sandbox 'foo)) + ) + +(with-test-prefix "eval-in-sandbox" + (pass-if-equal 42 + (eval-in-sandbox 42)) + (pass-if-equal 'foo + (eval-in-sandbox ''foo)) + (pass-if-equal '(1 . 2) + (eval-in-sandbox '(cons 1 2))) + (pass-if-unbound @@) + (pass-if-unbound foo) + (pass-if-unbound set!) + (pass-if-unbound open-file) + (pass-if-unbound current-input-port) + (pass-if-unbound call-with-output-file) + (pass-if-unbound vector-set!) + (pass-if-equal vector-set! + (eval-in-sandbox 'vector-set! + #:bindings all-pure-and-impure-bindings)) + (pass-if-exception "limit exceeded" + '(limit-exceeded . "") + (eval-in-sandbox '(let lp () (lp))))) + From e0502f3c7711e2f505126297e66cafa43d232685 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 18 Apr 2017 21:37:36 +0200 Subject: [PATCH 828/865] Bump objcode version in a compatible way * libguile/_scm.h (SCM_OBJCODE_MINIMUM_MINOR_VERSION): New definition, indicating the oldest objcode version that we support. (SCM_OBJCODE_MINOR_VERSION): Bump. * libguile/loader.c (process_dynamic_segment): Support a range of versions. * module/system/vm/assembler.scm (*bytecode-minor-version*): Bump. --- libguile/_scm.h | 3 ++- libguile/loader.c | 10 ++++------ module/system/vm/assembler.scm | 2 +- 3 files changed, 7 insertions(+), 8 deletions(-) diff --git a/libguile/_scm.h b/libguile/_scm.h index e482b7e31..093815d98 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -248,7 +248,8 @@ void scm_ia64_longjmp (scm_i_jmp_buf *, int); /* Major and minor versions must be single characters. */ #define SCM_OBJCODE_MAJOR_VERSION 3 -#define SCM_OBJCODE_MINOR_VERSION 9 +#define SCM_OBJCODE_MINIMUM_MINOR_VERSION 9 +#define SCM_OBJCODE_MINOR_VERSION A #define SCM_OBJCODE_MAJOR_VERSION_STRING \ SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION) #define SCM_OBJCODE_MINOR_VERSION_STRING \ diff --git a/libguile/loader.c b/libguile/loader.c index 7b1adc9c9..54bf1bff5 100644 --- a/libguile/loader.c +++ b/libguile/loader.c @@ -296,12 +296,10 @@ process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr, { case 0x0202: bytecode_kind = BYTECODE_KIND_GUILE_2_2; - /* As we get closer to 2.2, we will allow for backwards - compatibility and we can change this test to ">" - instead of "!=". However until then, to deal with VM - churn it's best to keep these things in - lock-step. */ - if (minor != SCM_OBJCODE_MINOR_VERSION) + if (minor < SCM_OBJCODE_MINIMUM_MINOR_VERSION) + return "incompatible bytecode version"; + /* FIXME for 3.0: Go back to integers. */ + if (minor > SCM_OBJCODE_MINOR_VERSION_STRING[0]) return "incompatible bytecode version"; break; default: diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index cfccd5b66..8d71dc551 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -1807,7 +1807,7 @@ needed." ;; FIXME: Define these somewhere central, shared with C. (define *bytecode-major-version* #x0202) -(define *bytecode-minor-version* 9) +(define *bytecode-minor-version* (char->integer #\A)) (define (link-dynamic-section asm text rw rw-init frame-maps) "Link the dynamic section for an ELF image with bytecode @var{text}, From 5c6b3c5169d15f99676b16a2e619560ea18f59d6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 19 Apr 2017 09:26:11 +0200 Subject: [PATCH 829/865] Fix test suite for constant literals change * test-suite/tests/elisp-compiler.test ("List Built-Ins"): Avoid mutating a literal pair. If this turns out to be necessary for elisp, the compiler will have to compile literals to calls to run-time heap allocations rather than constants. --- test-suite/tests/elisp-compiler.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/tests/elisp-compiler.test b/test-suite/tests/elisp-compiler.test index ddfa80a9a..1157afbb9 100644 --- a/test-suite/tests/elisp-compiler.test +++ b/test-suite/tests/elisp-compiler.test @@ -621,7 +621,7 @@ (and (equal (reverse '(5 4 3 2 1)) '(1 2 3 4 5)) (equal (reverse '()) '()))) (pass-if "setcar and setcdr" - (progn (setq pair '(1 . 2)) + (progn (setq pair (cons 1 2)) (setq copy pair) (setq a (setcar copy 3)) (setq b (setcdr copy 4)) From 601079278747659efd1a1f1b6099e98564530ce2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 19 Apr 2017 14:48:44 +0200 Subject: [PATCH 830/865] Avoid causing GC when lookup up exception handler * libguile/fluids.c (scm_fluid_ref_star): Avoid causing GC. Possibly fixes some crashes during out-of-memory conditions (#26351). --- libguile/fluids.c | 29 +++++++++++++++++++++++++++-- 1 file changed, 27 insertions(+), 2 deletions(-) diff --git a/libguile/fluids.c b/libguile/fluids.c index 6bdca7ddf..c3dd1c9ea 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -1,5 +1,5 @@ /* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009, 2010, - * 2011, 2012, 2013 Free Software Foundation, Inc. + * 2011, 2012, 2013, 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 License @@ -393,8 +393,33 @@ SCM_DEFINE (scm_fluid_ref_star, "fluid-ref*", 2, 0, 0, SCM_VALIDATE_FLUID (1, fluid); c_depth = SCM_NUM2SIZE (2, depth); + /* Because this function is called to look up the current exception + handler and this can happen in an out-of-memory situation, we avoid + cache flushes to the weak table which might cause allocation of a + disappearing link. */ if (c_depth == 0) - ret = fluid_ref (SCM_I_CURRENT_THREAD->dynamic_state, fluid); + { + scm_t_dynamic_state *dynamic_state = SCM_I_CURRENT_THREAD->dynamic_state; + struct scm_cache_entry *entry; + + entry = scm_cache_lookup (&dynamic_state->cache, fluid); + if (scm_is_eq (SCM_PACK (entry->key), fluid)) + ret = SCM_PACK (entry->value); + else + { + if (SCM_I_FLUID_THREAD_LOCAL_P (fluid)) + ret = scm_hashq_ref (dynamic_state->thread_local_values, fluid, + SCM_UNDEFINED); + else + ret = scm_weak_table_refq (dynamic_state->values, fluid, + SCM_UNDEFINED); + + if (SCM_UNBNDP (ret)) + ret = SCM_I_FLUID_DEFAULT (fluid); + + /* Don't cache the lookup. */ + } + } else ret = scm_dynstack_find_old_fluid_value (&SCM_I_CURRENT_THREAD->dynstack, fluid, c_depth - 1, From b11e2922c36c4105797c269c7e616535b702698a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 19 Apr 2017 15:08:46 +0200 Subject: [PATCH 831/865] SRFI-19 current-time-monotonic returns time of right type * module/srfi/srfi-19.scm (current-time-monotonic): Actually return a time with the correct type. Fixes #26329. --- module/srfi/srfi-19.scm | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm index 658ccd915..795ad50a9 100644 --- a/module/srfi/srfi-19.scm +++ b/module/srfi/srfi-19.scm @@ -1,6 +1,6 @@ ;;; srfi-19.scm --- Time/Date Library -;; Copyright (C) 2001-2003, 2005-2011, 2014, 2016 +;; Copyright (C) 2001-2003, 2005-2011, 2014, 2016-2017 ;; Free Software Foundation, Inc. ;; ;; This library is free software; you can redistribute it and/or @@ -333,8 +333,11 @@ ;; of course. (define (current-time-monotonic) - ;; Resolution is microseconds. - (current-time-tai)) + ;; Guile monotonic and TAI times are the same. + (let ((tai (current-time-tai))) + (make-time time-monotonic + (time-second tai) + (time-nanosecond tai)))) (define (current-time-thread) (time-error 'current-time 'unsupported-clock-type 'time-thread)) From 1978085b2208e71de5e7ba28582295c17c8053d5 Mon Sep 17 00:00:00 2001 From: Andrew Moss Date: Mon, 27 Mar 2017 11:58:29 -0400 Subject: [PATCH 832/865] Fixed bug: ~N mishandles small nanoseconds value Fixes . Reported by Zefram . * module/srfi/srfi-19.scm ("define directives"): N padding increased from 7 to 9 * test-suite/tests/srfi-19.test ("date->string"): New test. --- module/srfi/srfi-19.scm | 2 +- test-suite/tests/srfi-19.test | 5 +++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm index 795ad50a9..1b795f380 100644 --- a/module/srfi/srfi-19.scm +++ b/module/srfi/srfi-19.scm @@ -1063,7 +1063,7 @@ (newline port))) (cons #\N (lambda (date pad-with port) (display (padding (date-nanosecond date) - pad-with 7) + pad-with 9) port))) (cons #\p (lambda (date pad-with port) (display (locale-am-string/pm (date-hour date)) port))) diff --git a/test-suite/tests/srfi-19.test b/test-suite/tests/srfi-19.test index d63e62222..534cd7ca0 100644 --- a/test-suite/tests/srfi-19.test +++ b/test-suite/tests/srfi-19.test @@ -175,6 +175,11 @@ incomplete numerical tower implementation.)" (equal? "Sun Jun 05 18:33:00+0200 2005" (date->string date)))) + (pass-if "date->string pads small nanoseconds values correctly" + (let* ((date (make-date 99999999 5 34 12 26 3 2017 0))) + (equal? "099999999" + (date->string date "~N")))) + ;; check time comparison procedures (let* ((time1 (make-time time-monotonic 0 0)) (time2 (make-time time-monotonic 0 0)) From 4b39c1a9e53c63df8e19151f6e82040c6f734b89 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 19 Apr 2017 15:42:03 +0200 Subject: [PATCH 833/865] Fix date->string ~f operator to not emit leading zeros * module/srfi/srfi-19.scm (directives): Format ~f without leading zeroes. Fixes https://bugs.gnu.org/26260. * test-suite/tests/srfi-19.test ("SRFI date/time library"): Add test. --- module/srfi/srfi-19.scm | 26 ++++++++------------------ test-suite/tests/srfi-19.test | 6 +++++- 2 files changed, 13 insertions(+), 19 deletions(-) diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm index 1b795f380..c6a55a253 100644 --- a/module/srfi/srfi-19.scm +++ b/module/srfi/srfi-19.scm @@ -1005,24 +1005,14 @@ #\Space 2) port))) (cons #\f (lambda (date pad-with port) - (if (> (date-nanosecond date) - nano) - (display (padding (+ (date-second date) 1) - pad-with 2) - port) - (display (padding (date-second date) - pad-with 2) - port)) - (receive (i f) - (split-real (/ - (date-nanosecond date) - nano 1.0)) - (let* ((ns (number->string f)) - (le (string-length ns))) - (if (> le 2) - (begin - (display (locale-decimal-point) port) - (display (substring ns 2 le) port))))))) + (receive (s ns) (floor/ (+ (* (date-second date) nano) + (date-nanosecond date)) + nano) + (display (number->string s) port) + (display (locale-decimal-point) port) + (let ((str (padding ns #\0 9))) + (display (substring str 0 1) port) + (display (string-trim-right str #\0 1) port))))) (cons #\h (lambda (date pad-with port) (display (date->string date "~b") port))) (cons #\H (lambda (date pad-with port) diff --git a/test-suite/tests/srfi-19.test b/test-suite/tests/srfi-19.test index 534cd7ca0..717047bb5 100644 --- a/test-suite/tests/srfi-19.test +++ b/test-suite/tests/srfi-19.test @@ -2,7 +2,7 @@ ;;;; Matthias Koeppe --- June 2001 ;;;; ;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2007, 2008, -;;;; 2011, 2014 Free Software Foundation, Inc. +;;;; 2011, 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 @@ -180,6 +180,10 @@ incomplete numerical tower implementation.)" (equal? "099999999" (date->string date "~N")))) + (pass-if "date->string correct ~f" + (let ((date (make-date 200000000 5 34 12 26 3 2017 0))) + (equal? "5.2" (date->string date "~f")))) + ;; check time comparison procedures (let* ((time1 (make-time time-monotonic 0 0)) (time2 (make-time time-monotonic 0 0)) From e264860718bfde6c578a64c5bd3d0907640d1b3e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 19 Apr 2017 15:49:06 +0200 Subject: [PATCH 834/865] Add srfi-19 ~f regression test * test-suite/tests/srfi-19.test ("SRFI date/time library"): Add test for https://bugs.gnu.org/26259. --- test-suite/tests/srfi-19.test | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/srfi-19.test b/test-suite/tests/srfi-19.test index 717047bb5..c963f15c9 100644 --- a/test-suite/tests/srfi-19.test +++ b/test-suite/tests/srfi-19.test @@ -180,10 +180,14 @@ incomplete numerical tower implementation.)" (equal? "099999999" (date->string date "~N")))) - (pass-if "date->string correct ~f" + (pass-if "date->string ~f without leading zeroes" (let ((date (make-date 200000000 5 34 12 26 3 2017 0))) (equal? "5.2" (date->string date "~f")))) + (pass-if "date->string ~f proper fractional part" + (let ((date (make-date 550000 56 34 12 26 3 2017 0))) + (equal? "56.00055" (date->string date "~f")))) + ;; check time comparison procedures (let* ((time1 (make-time time-monotonic 0 0)) (time2 (make-time time-monotonic 0 0)) From 0aa02819793426130f45ae0793476b1e28ab5a8d Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 19 Apr 2017 15:56:47 +0200 Subject: [PATCH 835/865] Fix typo in fold-layout documentation * doc/ref/sxml.texi (SXML Tree Fold): Fix minor typo. Fixes https://bugs.gnu.org/26188. --- doc/ref/sxml.texi | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/ref/sxml.texi b/doc/ref/sxml.texi index 3b940bd3e..19125091c 100644 --- a/doc/ref/sxml.texi +++ b/doc/ref/sxml.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 2013 Free Software Foundation, Inc. +@c Copyright (C) 2013, 2017 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @c SXPath documentation based on SXPath.scm by Oleg Kiselyov, @@ -580,7 +580,7 @@ A traversal combinator in the spirit of @code{pre-post-order}. @example bindings := (...) -binding := ( ...) +binding := ( ...) | (*default* . ) | (*text* . ) tag := From 18cac76be8f4dabdd290518fd551a71652efe500 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 19 Apr 2017 16:15:09 +0200 Subject: [PATCH 836/865] Add --with-bdw-gc and update README * README: Update to 2.2. Add instructions for FreeBSD based on notes from Matt Wette. * configure.ac: Add --with-bdw-gc argument. --- README | 21 +++++++++++++++++---- configure.ac | 6 +++++- 2 files changed, 22 insertions(+), 5 deletions(-) diff --git a/README b/README index 92d786c06..cffee2253 100644 --- a/README +++ b/README @@ -1,4 +1,4 @@ -This is version 2.0 of Guile, Project GNU's extension language library. +This is version 2.2 of Guile, Project GNU's extension language library. Guile is an implementation of the Scheme programming language, packaged as a library that can be linked into applications to give them their own extension language. Guile supports other languages as well, giving @@ -78,7 +78,7 @@ Guile requires the following external packages: `utf*->string' procedures. It is available from http://www.gnu.org/software/libunistring/ . - - libgc, at least version 7.0 + - libgc, at least version 7.2 libgc (aka. the Boehm-Demers-Weiser garbage collector) is the conservative garbage collector used by Guile. It is available @@ -124,7 +124,20 @@ instructions above, but it seems that a few systems still need special treatment. If you can send us fixes for these problems, we'd be grateful. - +FreeBSD 11.0: + For a build supporting threads, please `pkg install' the following + - pkgconf : provides pkg-config + - gmake : /usr/bin/make does not work + - boehm-gc-threaded : needed for threaded support + + Configure as: + + ./configure --with-bdw-gc=bdw-gc-threaded + + Alternately if you want a Guile without threads, then install boehm-gc + and configure as: + + ./configure --without-threads Guile specific flags Accepted by Configure ================================= @@ -244,7 +257,7 @@ switches specific to Guile you may find useful in some circumstances. Cross building Guile ===================================================== -As of Guile 2.0.x, the build process produces a library, libguile-2.0, +As of Guile 2.2.x, the build process produces a library, libguile-2.2, along with Guile "object files" containing bytecode to be interpreted by Guile's virtual machine. The bytecode format depends on the endianness and word size of the host CPU. diff --git a/configure.ac b/configure.ac index 0bde77e89..1338540c6 100644 --- a/configure.ac +++ b/configure.ac @@ -1332,7 +1332,11 @@ main (int argc, char **argv) # Boehm's GC library # #-------------------------------------------------------------------- -PKG_CHECK_MODULES([BDW_GC], [bdw-gc >= 7.2]) +AC_MSG_CHECKING(for which bdw-gc pkg-config file to use) +AC_ARG_WITH(bdw_gc, [ --with-bdw-gc=PKG name of BDW-GC pkg-config file], + [bdw_gc="$withval"], [bdw_gc=bdw-gc]) +AC_MSG_RESULT($bdw_gc) +PKG_CHECK_MODULES([BDW_GC], [$bdw_gc >= 7.2]) save_LIBS="$LIBS" LIBS="$BDW_GC_LIBS $LIBS" From 93b2bfd822bf4dd7eacb4ff907a504c71d172b6c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 19 Apr 2017 16:23:14 +0200 Subject: [PATCH 837/865] Document guile-2.2 cond-expand feature. * doc/ref/srfi-modules.texi (SRFI-0): Mention guile-2.2 feature. --- doc/ref/srfi-modules.texi | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index f71294436..95509b278 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014 +@c Copyright (C) 1996, 1997, 2000-2004, 2006, 2007-2014, 2017 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -150,6 +150,7 @@ The Guile core has the following features, @example guile guile-2 ;; starting from Guile 2.x +guile-2.2 ;; starting from Guile 2.2 r5rs srfi-0 srfi-4 From a7428a3172445f1265199ae3a1dc94cbb7d0551e Mon Sep 17 00:00:00 2001 From: Freja Nordsiek Date: Sun, 19 Mar 2017 16:15:24 +0100 Subject: [PATCH 838/865] Fixed bug: statprof flat display wasn't writing summary lines to port * module/statprof.scm (statprof-display/flat): fixed bug where summary lines were written to (current-output-port) instead of the provided port. --- module/statprof.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/module/statprof.scm b/module/statprof.scm index fe605e0e8..59a2f12d0 100644 --- a/module/statprof.scm +++ b/module/statprof.scm @@ -652,8 +652,8 @@ optional @var{port} argument is passed, uses the current output port." (for-each display-stats-line sorted-stats) (display "---\n" port) - (format #t "Sample count: ~A\n" (statprof-sample-count state)) - (format #t "Total time: ~A seconds (~A seconds in GC)\n" + (format port "Sample count: ~A\n" (statprof-sample-count state)) + (format port "Total time: ~A seconds (~A seconds in GC)\n" (statprof-accumulated-time state) (/ (gc-time-taken state) 1.0 internal-time-units-per-second)))))) From 5d5d3d75d071f1f97977705b10651b356cedaa8c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 19 Apr 2017 16:48:56 +0200 Subject: [PATCH 839/865] Fix spurious warnings in net_db.c * libguile/guile-func-name-check (/^SCM_DEFINE /): Fix pattern to not produce spurious warnings. Thanks to Dale Smith for the suggestion. Fixes https://bugs.gnu.org/26123. --- libguile/guile-func-name-check | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/guile-func-name-check b/libguile/guile-func-name-check index 8b4924e91..24038acad 100644 --- a/libguile/guile-func-name-check +++ b/libguile/guile-func-name-check @@ -1,6 +1,6 @@ #!/usr/bin/awk -f # -# Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc. +# Copyright (C) 2000, 2001, 2006, 2017 Free Software Foundation, Inc. # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU Lesser General Public License as @@ -25,7 +25,7 @@ BEGIN { in_a_func = 0; } -/^SCM_DEFINE/ { +/^SCM_DEFINE / { func_name = $0; sub(/^[^\(\n]*\([ \t]*/,"", func_name); sub(/[ \t]*,.*/,"", func_name); From 410bb56d23bbedda8ccbaffd2b7cc3188be778de Mon Sep 17 00:00:00 2001 From: Sergei Trofimovich Date: Sun, 19 Feb 2017 23:02:44 +0000 Subject: [PATCH 840/865] Documentation typo tweak * doc/ref/api-data.texi: Tweak 'u+0007' to 'U+0007' (as in the rest of the table). Signed-off-by: Sergei Trofimovich --- doc/ref/api-data.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 214c6e2e1..7b10d34f4 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -2004,7 +2004,7 @@ names, described in the table below. @multitable {@code{#\backspace}} {Preferred} @item Character Name @tab Codepoint @item @code{#\nul} @tab U+0000 -@item @code{#\alarm} @tab u+0007 +@item @code{#\alarm} @tab U+0007 @item @code{#\backspace} @tab U+0008 @item @code{#\tab} @tab U+0009 @item @code{#\linefeed} @tab U+000A From e0933b5636219973bf4c0262b82d604756f7c1bc Mon Sep 17 00:00:00 2001 From: Sergei Trofimovich Date: Sun, 19 Feb 2017 23:02:37 +0000 Subject: [PATCH 841/865] api-procedures.texi: typo: 'an' -> 'on' * doc/ref/api-procedures.texi: Fix typo. Signed-off-by: Sergei Trofimovich --- doc/ref/api-procedures.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/api-procedures.texi b/doc/ref/api-procedures.texi index 02bf6822a..df24178f9 100644 --- a/doc/ref/api-procedures.texi +++ b/doc/ref/api-procedures.texi @@ -836,7 +836,7 @@ Let us call this new procedure @code{foo}. (define foo (make-procedure-with-setter foo-ref foo-set!)) @end lisp -@code{foo} can from now an be used to either read from the data +@code{foo} can from now on be used to either read from the data structure stored in @code{f}, or to write into the structure. @lisp From f775ab3654357fcaad294b95efb0b1c16de1eda8 Mon Sep 17 00:00:00 2001 From: Sergei Trofimovich Date: Sun, 19 Feb 2017 22:58:40 +0000 Subject: [PATCH 842/865] guile-snarf: skip -g* arguments to avoid build failure * libguile/guile-snarf.in: skip -g* arguments to avoid failure on -ggdb3. Bug: https://bugs.gentoo.org/608190 Bug: http://debbugs.gnu.org/cgi/bugreport.cgi?bug=25803 Signed-off-by: Sergei Trofimovich --- libguile/guile-snarf.in | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/libguile/guile-snarf.in b/libguile/guile-snarf.in index 47bbc0422..22dc1d389 100644 --- a/libguile/guile-snarf.in +++ b/libguile/guile-snarf.in @@ -95,10 +95,22 @@ if [ x"$CPP" = x ] ; then cpp="@CPP@" ; else cpp="$CPP" ; fi trap "rm -rf $tempdir" 0 1 2 15 +# filter out -g* flags from commandline +# as some flags like -ggdb3 cause CPP + +cpp_args="" +for arg in "$@" +do + case "$arg" in + -g*) ;; # skip debug flag + *) cpp_args="$cpp_args $arg" ;; + esac +done + if [ ! "$outfile" = "-" ] ; then - modern_snarf "$@" > $outfile + modern_snarf $cpp_args > $outfile else - modern_snarf "$@" + modern_snarf $cpp_args fi # zonk outfile if errors occurred From 0065945cbff8bdf38e394ab597058152d138e248 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 19 Apr 2017 18:03:37 +0200 Subject: [PATCH 843/865] Update NEWS * NEWS: Update. --- NEWS | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 91d37202f..1103fcb67 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,5 @@ Guile NEWS --- history of user-visible changes. -Copyright (C) 1996-2016 Free Software Foundation, Inc. +Copyright (C) 1996-2017 Free Software Foundation, Inc. See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. @@ -65,6 +65,24 @@ may contain macros that contain legacy syntax object constants. See the discussion of "allow-legacy-syntax-objects?" in "Syntax Transformer Helpers" in the manual for full details. +* Bug fixes + +*** Fix snarfing with -ggdb3 (#25803) +*** Fix spurious snarf warnings for net_db.c +*** Output statprof flat display to correct port +*** Document guile-2.2 cond-expand feature +*** Add --with-bdw-gc for BSDs that use bdw-gc-threaded (see README) +*** Documentation typo fixes (#26188) +*** Fix SRFI-9 date->string bugs with ~N and ~F (#26261, #26260, #26259) +*** SRFI-19 current-time-monotonic returns time of right type (#26329) +*** Avoid causing GC when looking up exception handler +*** Increment objcode version, in a compatible way +*** Fix compile warning in (system base types) +*** Only run tests that require fork if it is provided +*** Speed up procedure-minimum-arity for fixed arity +*** REPL server tests catch ECONNABORTED +*** Avoid deprecated argument to setvbuf in (web client) +*** Remove non-existent 'open-connection-for-uri' export from (web client) Changes in 2.2.0 (changes since the 2.0.x stable release series): From 70292439d9b5605ae3b87746f60991a04764749b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 19 Apr 2017 18:12:18 +0200 Subject: [PATCH 844/865] Update release docs * doc/release.org: Update for 2.2. --- doc/release.org | 33 ++++++++++++++++----------------- 1 file changed, 16 insertions(+), 17 deletions(-) diff --git a/doc/release.org b/doc/release.org index 875ec27ff..9a38445a1 100644 --- a/doc/release.org +++ b/doc/release.org @@ -1,9 +1,9 @@ -#+TITLE: Release Process for GNU Guile 2.0 +#+TITLE: Release Process for GNU Guile 2.2 #+AUTHOR: Ludovic Courtès #+STARTUP: content #+EMAIL: ludo@gnu.org -This document describes the typical release process for Guile 2.0. +This document describes the typical release process for Guile 2.2. * Preparing & uploading the tarball @@ -69,17 +69,16 @@ if in doubt. `libguile/libguile.map' should also be updated as new public symbols are added. Ideally, new symbols should get under a new version -symbol---e.g., `GUILE_2.0.3' for symbols introduced in Guile 2.0.3. -However, this has not been done for Guile <= 2.0.2. +symbol---e.g., `GUILE_2.2.3' for symbols introduced in Guile 2.2.3. -** Tag v2.0.x +** Tag v2.2.x Create a signed Git tag, like this: - $ git tag -s -u MY-KEY -m "GNU Guile 2.0.X." v2.0.X + $ git tag -s -u MY-KEY -m "GNU Guile 2.2.X." v2.2.X -The tag *must* be `v2.0.X'. For the sake of consistency, always use -"GNU Guile 2.0.X." as the tag comment. +The tag *must* be `v2.2.X'. For the sake of consistency, always use +"GNU Guile 2.2.X." as the tag comment. ** Push the tag and changes @@ -98,7 +97,7 @@ reports the new version number. ** Upload - $ ./build-aux/gnupload --to ftp.gnu.org:guile guile-2.0.X.tar.gz + $ ./build-aux/gnupload --to ftp.gnu.org:guile guile-2.2.X.tar.gz You'll get an email soon after when the upload is complete. @@ -115,10 +114,10 @@ Make sure the file was uploaded and is available for download as expected: $ mkdir t && cd t && \ - wget ftp.gnu.org/gnu/guile/guile-2.0.X.tar.gz && \ - wget ftp.gnu.org/gnu/guile/guile-2.0.X.tar.xz - $ diff guile-2.0.X.tar.gz ../guile-2.0.X.tar.gz - $ diff guile-2.0.X.tar.xz ../guile-2.0.X.tar.xz + wget ftp.gnu.org/gnu/guile/guile-2.2.X.tar.gz && \ + wget ftp.gnu.org/gnu/guile/guile-2.2.X.tar.xz + $ diff guile-2.2.X.tar.gz ../guile-2.2.X.tar.gz + $ diff guile-2.2.X.tar.xz ../guile-2.2.X.tar.xz You're almost done! @@ -138,17 +137,17 @@ Announcements"). Use `build-aux/gendocs', add to the manual/ directory of the web site. $ cd doc/ref - $ ../../build-aux/gendocs.sh guile "GNU Guile 2.0.X Reference Manual" + $ ../../build-aux/gendocs.sh guile "GNU Guile 2.2.X Reference Manual" ** Prepare the email announcement $ build-aux/announce-gen --release-type=stable --package-name=guile \ - --previous-version=2.0.1 --current-version=2.0.2 \ + --previous-version=2.2.1 --current-version=2.2.2 \ --gpg-key-id=MY-KEY --url-directory=ftp://ftp.gnu.org/gnu/guile \ --bootstrap-tools=autoconf,automake,libtool,gnulib,makeinfo \ --gnulib-version=$( cd ~/src/gnulib ; git describe ) -The subject must be "GNU Guile 2.0.X released". The text should remain +The subject must be "GNU Guile 2.2.X released". The text should remain formal and impersonal (it is sent on behalf of the Guile and GNU projects.) It must include a description of what Guile is (not everyone reading info-gnu may know about it.) Use the text of previous @@ -173,7 +172,7 @@ more informal, with a link to the email announcement for details. -Copyright © 2011, 2012, 2013 Free Software Foundation, Inc. +Copyright © 2011, 2012, 2013, 2017 Free Software Foundation, Inc. Copying and distribution of this file, with or without modification, are permitted in any medium without royalty provided the copyright From 3db21f5eb9d966e65760db5683775c76e0a6c5b1 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 19 Apr 2017 18:14:32 +0200 Subject: [PATCH 845/865] GNU Guile 2.2.1. * GUILE-VERSION (GUILE_MICRO_VERSION, LIBGUILE_INTERFACE_CURRENT): (LIBGUILE_INTERFACE_AGE): Increment version. --- GUILE-VERSION | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index 1b5f90d96..98618c60b 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -3,7 +3,7 @@ # Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'. GUILE_MAJOR_VERSION=2 GUILE_MINOR_VERSION=2 -GUILE_MICRO_VERSION=0 +GUILE_MICRO_VERSION=1 GUILE_EFFECTIVE_VERSION=2.2 @@ -16,7 +16,7 @@ GUILE_EFFECTIVE_VERSION=2.2 # See libtool info pages for more information on how and when to # change these. -LIBGUILE_INTERFACE_CURRENT=1 +LIBGUILE_INTERFACE_CURRENT=2 LIBGUILE_INTERFACE_REVISION=0 -LIBGUILE_INTERFACE_AGE=0 +LIBGUILE_INTERFACE_AGE=1 LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}" From 40df57a8a2b706bab0b2bda84dd2ce98f1be8e3b Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 20 Apr 2017 10:40:07 +0200 Subject: [PATCH 846/865] Restore libgc 7.2 compatibility * configure.ac: Check for GC_is_heap_ptr, added after libgc 7.2. * libguile/pairs.h (GC_is_heap_ptr): Define a shim for GC_is_heap_ptr, inside BUILDING_LIBGUILE so as not to expose it to users. --- configure.ac | 2 +- libguile/pairs.h | 8 ++++++++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 1338540c6..374b4297a 100644 --- a/configure.ac +++ b/configure.ac @@ -1346,7 +1346,7 @@ CFLAGS="$BDW_GC_CFLAGS $CFLAGS" AC_CHECK_FUNCS([GC_pthread_exit GC_pthread_cancel GC_pthread_sigmask]) # Functions from GC 7.3. -AC_CHECK_FUNCS([GC_move_disappearing_link]) +AC_CHECK_FUNCS([GC_move_disappearing_link GC_is_heap_ptr]) LIBS="$save_LIBS" diff --git a/libguile/pairs.h b/libguile/pairs.h index 08d6ad92c..121a76518 100644 --- a/libguile/pairs.h +++ b/libguile/pairs.h @@ -177,6 +177,14 @@ scm_cdr (SCM x) #endif #ifdef BUILDING_LIBGUILE +#ifndef HAVE_GC_IS_HEAP_PTR +static int +GC_is_heap_ptr (void *ptr) +{ + return GC_base (ptr) != NULL; +} +#endif + static inline int scm_is_mutable_pair (SCM x) { From 02cf38514d85182ee5b1f89968d5052b1e3b40ca Mon Sep 17 00:00:00 2001 From: Thomas Danckaert Date: Wed, 19 Apr 2017 18:14:38 +0200 Subject: [PATCH 847/865] SRFI-37: Account for zero-length arguments. * module/srfi/srfi-37.scm (args-fold): When checking if an argument is an option (starts with #\-), first check if the length is non-zero. --- module/srfi/srfi-37.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/module/srfi/srfi-37.scm b/module/srfi/srfi-37.scm index 3f654af2c..c34b0d083 100644 --- a/module/srfi/srfi-37.scm +++ b/module/srfi/srfi-37.scm @@ -217,7 +217,8 @@ program-arguments in ARGS, as decided by the OPTIONS' (if (null? args) (apply values seeds) (let ((arg (car args))) - (cond ((or (not (char=? #\- (string-ref arg 0))) + (cond ((or (string-null? arg) + (not (char=? #\- (string-ref arg 0))) (= 1 (string-length arg))) ;"-" (mutate-seeds! operand-proc arg) (set! args (cdr args))) From 2e5f7d8f6d8e0e66a964ec69ccdca4f737b0b018 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 21 Apr 2017 11:04:08 +0200 Subject: [PATCH 848/865] Syntax objects are comparable with equal? * libguile/eq.c (scm_equal_p, scm_raw_ihash): Add cases for syntax objects, which should be comparable with equal?. * test-suite/tests/syntax.test ("syntax objects"): Add tests. --- libguile/eq.c | 11 +++++++++++ libguile/hash.c | 9 +++++++++ test-suite/tests/syntax.test | 33 +++++++++++++++++++++++++++++++++ 3 files changed, 53 insertions(+) diff --git a/libguile/eq.c b/libguile/eq.c index bbb061655..4680de7d8 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -33,6 +33,7 @@ #include "libguile/vectors.h" #include "libguile/hashtab.h" #include "libguile/bytevectors.h" +#include "libguile/syntax.h" #include "libguile/struct.h" #include "libguile/goops.h" @@ -362,6 +363,16 @@ scm_equal_p (SCM x, SCM y) case scm_tc7_vector: case scm_tc7_wvect: return scm_i_vector_equal_p (x, y); + case scm_tc7_syntax: + if (scm_is_false (scm_equal_p (scm_syntax_wrap (x), + scm_syntax_wrap (y)))) + return SCM_BOOL_F; + if (scm_is_false (scm_equal_p (scm_syntax_module (x), + scm_syntax_module (y)))) + return SCM_BOOL_F; + x = scm_syntax_expression (x); + y = scm_syntax_expression (y); + goto tailrecurse; } /* Otherwise just return false. Dispatching to the generic is the wrong thing diff --git a/libguile/hash.c b/libguile/hash.c index d6ddb6b3b..604708438 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -35,6 +35,7 @@ #include "libguile/ports.h" #include "libguile/strings.h" #include "libguile/symbols.h" +#include "libguile/syntax.h" #include "libguile/vectors.h" #include "libguile/validate.h" @@ -333,6 +334,14 @@ scm_raw_ihash (SCM obj, size_t depth) h ^= scm_raw_ihash (scm_c_vector_ref (obj, h % len), i); return h; } + case scm_tc7_syntax: + { + unsigned long h; + h = scm_raw_ihash (scm_syntax_expression (obj), depth); + h ^= scm_raw_ihash (scm_syntax_wrap (obj), depth); + h ^= scm_raw_ihash (scm_syntax_module (obj), depth); + return h; + } case scm_tcs_cons_imcar: case scm_tcs_cons_nimcar: if (depth) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index ffe8099b1..883004a27 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -20,6 +20,7 @@ (define-module (test-suite test-syntax) #:use-module (ice-9 regex) #:use-module (ice-9 local-eval) + #:use-module ((system syntax) #:select (syntax?)) #:use-module (test-suite lib)) @@ -1617,6 +1618,38 @@ (length #'(x …)))) env)))) +(with-test-prefix "syntax objects" + (let ((interpreted (eval '#'(foo bar baz) (current-module))) + (interpreted-bis (eval '#'(foo bar baz) (current-module))) + (compiled ((@ (system base compile) compile) '#'(foo bar baz) + #:env (current-module)))) + ;; Guile's expander doesn't wrap lists. + (pass-if "interpreted syntax object?" + (and (list? interpreted) + (and-map syntax? interpreted))) + (pass-if "compiled syntax object?" + (and (list? compiled) + (and-map syntax? compiled))) + + (pass-if "interpreted syntax objects are not vectors" + (not (vector? interpreted))) + (pass-if "compiled syntax objects are not vectors" + (not (vector? compiled))) + + (pass-if-equal "syntax objects comparable with equal? (eval/eval)" + interpreted interpreted-bis) + (pass-if-equal "syntax objects comparable with equal? (eval/compile)" + interpreted compiled) + + (pass-if-equal "syntax objects hash the same (eval/eval)" + (hash interpreted most-positive-fixnum) + (hash interpreted-bis most-positive-fixnum)) + + (pass-if-equal "syntax objects hash the same (eval/compile)" + (hash interpreted most-positive-fixnum) + (hash compiled most-positive-fixnum)))) + + ;;; Local Variables: ;;; eval: (put 'pass-if-syntax-error 'scheme-indent-function 1) ;;; eval: (put 'with-ellipsis 'scheme-indent-function 1) From 7e1d830698950e373454a07dd514bce78c9bea33 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 21 Apr 2017 11:20:35 +0200 Subject: [PATCH 849/865] Update NEWS. * NEWS: Update. --- NEWS | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/NEWS b/NEWS index 1103fcb67..663ba9f48 100644 --- a/NEWS +++ b/NEWS @@ -5,6 +5,24 @@ See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. + +Changes in 2.2.2 (since 2.2.1): + +* Bug fixes + +** Syntax objects are once more comparable with 'equal?' + +The syntax object change in 2.2.1 had the unintended effect of making +syntax objects no longer comparable with equal?. This release restores +the previous behavior. + +** Restore libgc dependency + +The change to throw exceptions when mutating literal constants partly +relied on an interface that was added to our garbage collector (BDW-GC) +after its 7.2 release. Guile 2.2.2 adds a workaround to allow Guile to +continue be used with libgc as old as 7.2. + Changes in 2.2.1 (since 2.2.0): From fbaf8e98ff02503c077bc3bf55b48028c53cbeff Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 21 Apr 2017 15:41:25 +0200 Subject: [PATCH 850/865] Update NEWS some more * NEWS: More updates. --- NEWS | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/NEWS b/NEWS index 663ba9f48..d2c619785 100644 --- a/NEWS +++ b/NEWS @@ -23,6 +23,11 @@ relied on an interface that was added to our garbage collector (BDW-GC) after its 7.2 release. Guile 2.2.2 adds a workaround to allow Guile to continue be used with libgc as old as 7.2. +** SRFI-37 bug fix to not error on empty-string arguments. + +Thanks to Thomas Danckaert for fixing this long-standing bug. + + Changes in 2.2.1 (since 2.2.0): From f344ad631d5c76c76e5e7aa0f3e355b968ab7273 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 21 Apr 2017 15:41:58 +0200 Subject: [PATCH 851/865] Bump version to 2.2.2. * GUILE-VERSION: Bump to 2.2.2. --- GUILE-VERSION | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index 98618c60b..223a2935f 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -3,7 +3,7 @@ # Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'. GUILE_MAJOR_VERSION=2 GUILE_MINOR_VERSION=2 -GUILE_MICRO_VERSION=1 +GUILE_MICRO_VERSION=2 GUILE_EFFECTIVE_VERSION=2.2 @@ -16,7 +16,7 @@ GUILE_EFFECTIVE_VERSION=2.2 # See libtool info pages for more information on how and when to # change these. -LIBGUILE_INTERFACE_CURRENT=2 +LIBGUILE_INTERFACE_CURRENT=3 LIBGUILE_INTERFACE_REVISION=0 -LIBGUILE_INTERFACE_AGE=1 +LIBGUILE_INTERFACE_AGE=2 LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}" From 886ac3e2abce89bd3f47f957c36bcec16613c509 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 22 Apr 2017 00:58:10 +0200 Subject: [PATCH 852/865] SRFI-19: Swap seconds and nanoseconds in 'current-time-monotonic'. * module/srfi/srfi-19.scm (current-time-monotonic): Swap the 2nd and 3rd arguments. Fixes a regression introduced in commit b11e2922c36c4105797c269c7e616535b702698a. --- module/srfi/srfi-19.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm index c6a55a253..9cf9a2eb5 100644 --- a/module/srfi/srfi-19.scm +++ b/module/srfi/srfi-19.scm @@ -336,8 +336,8 @@ ;; Guile monotonic and TAI times are the same. (let ((tai (current-time-tai))) (make-time time-monotonic - (time-second tai) - (time-nanosecond tai)))) + (time-nanosecond tai) + (time-second tai)))) (define (current-time-thread) (time-error 'current-time 'unsupported-clock-type 'time-thread)) From fc84f4f13dde92a9de61bb137cd1cc2c90e853d3 Mon Sep 17 00:00:00 2001 From: Zefram Date: Wed, 19 Apr 2017 17:08:30 +0100 Subject: [PATCH 853/865] Correct note about Gregorian reform in SRFI-19 * doc/ref/srfi-modules.texi (SRFI-19): SRFI-19 specifies proleptic use of the Gregorian calendar, so it was incorrect of the documentation to describe the code as erroneous in doing so. Rewrite the caution more neutrally, and move it to the section about the "date" structure, where it seems most relevant. --- doc/ref/srfi-modules.texi | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 95509b278..3d4415629 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -2383,17 +2383,6 @@ functions and variables described here are provided by (use-modules (srfi srfi-19)) @end example -@strong{Caution}: The current code in this module incorrectly extends -the Gregorian calendar leap year rule back prior to the introduction -of those reforms in 1582 (or the appropriate year in various -countries). The Julian calendar was used prior to 1582, and there -were 10 days skipped for the reform, but the code doesn't implement -that. - -This will be fixed some time. Until then calculations for 1583 -onwards are correct, but prior to that any day/month/year and day of -the week calculations are wrong. - @menu * SRFI-19 Introduction:: * SRFI-19 Time:: @@ -2593,6 +2582,16 @@ The fields are year, month, day, hour, minute, second, nanoseconds and timezone. A date object is immutable, its fields can be read but they cannot be modified once the object is created. +Historically, the Gregorian calendar was only used from the latter part +of the year 1582 onwards, and not until even later in many countries. +Prior to that most countries used the Julian calendar. SRFI-19 does +not deal with the Julian calendar at all, and so does not reflect this +historical calendar reform. Instead it projects the Gregorian calendar +back proleptically as far as necessary. When dealing with historical +data, especially prior to the British Empire's adoption of the Gregorian +calendar in 1752, one should be mindful of which calendar is used in +each context, and apply non-SRFI-19 facilities to convert where necessary. + @defun date? obj Return @code{#t} if @var{obj} is a date object, or @code{#f} if not. @end defun From 0c102b56e98da39b5a3213bdc567a31ad8ef3e73 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 28 Apr 2017 13:38:41 +0200 Subject: [PATCH 854/865] Fix reading of HTTPS responses that are smaller than port buffer * module/web/client.scm (tls-wrap): Use get-bytevector-some instead of get-bytevector-n, to prevent Guile from attempting to read more bytes than are available. Normally trying to read data on a shut-down socket is fine, but but gnutls issues an error if you attempt to read data from a shut-down socket, and that appears to be a security property. Fixes HTTPS requests whose responses are smaller than the port buffer. --- module/web/client.scm | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/module/web/client.scm b/module/web/client.scm index 0c055abe9..c30fa99eb 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -130,16 +130,25 @@ host name without trailing dot." ;;(set-log-procedure! log) (handshake session) + ;; FIXME: It appears that session-record-port is entirely + ;; sufficient; it's already a port. The only value of this code is + ;; to keep a reference on "port", to keep it alive! To fix this we + ;; need to arrange to either hand GnuTLS its own fd to close, or to + ;; arrange a reference from the session-record-port to the + ;; underlying socket. (let ((record (session-record-port session))) (define (read! bv start count) - (define read-bv (get-bytevector-n record count)) + (define read-bv (get-bytevector-some record)) (if (eof-object? read-bv) 0 ; read! returns 0 on eof-object (let ((read-bv-len (bytevector-length read-bv))) - (bytevector-copy! read-bv 0 bv start read-bv-len) + (bytevector-copy! read-bv 0 bv start (min read-bv-len count)) + (when (< count read-bv-len) + (unget-bytevector record bv count (- read-bv-len count))) read-bv-len))) (define (write! bv start count) (put-bytevector record bv start count) + (force-output record) count) (define (get-position) (rnrs-ports:port-position record)) @@ -150,6 +159,7 @@ host name without trailing dot." (close-port port)) (unless (port-closed? record) (close-port record))) + (setvbuf record 'block) (make-custom-binary-input/output-port "gnutls wrapped port" read! write! get-position set-position! close)))) From 7ac3d17ceaffc5f068e500c30b1728eae12ae0f0 Mon Sep 17 00:00:00 2001 From: Manolis Ragkousis Date: Tue, 16 May 2017 12:35:00 +0300 Subject: [PATCH 855/865] On Hurd, skip tests that require working setrlimits for memory On Hurd, setrlimits are not yet implemented. See . * test-suite/standalone/test-out-of-memory: skip for Hurd. * test-suite/standalone/test-stack-overflow: skip for Hurd. --- test-suite/standalone/test-out-of-memory | 6 ++++++ test-suite/standalone/test-stack-overflow | 6 ++++++ 2 files changed, 12 insertions(+) diff --git a/test-suite/standalone/test-out-of-memory b/test-suite/standalone/test-out-of-memory index 95692d6ea..221651270 100755 --- a/test-suite/standalone/test-out-of-memory +++ b/test-suite/standalone/test-out-of-memory @@ -15,6 +15,12 @@ exec guile -q -s "$0" "$@" ;; See also test-stack-overflow. (exit 77)) ; unresolved +(when (string-ci= "GNU" (vector-ref (uname) 0)) + ;; setrlimits are not yet implemented on GNU/Hurd systems. Proceeding + ;; with the test would end in a crash. See + ;; + (exit 77)) ; unresolved + (when (string-contains-ci (vector-ref (uname) 0) "CYGWIN_NT") ;; attempting to use setrlimits for memory RLIMIT_AS will always ;; produce an invalid argument error on Cygwin (tested on diff --git a/test-suite/standalone/test-stack-overflow b/test-suite/standalone/test-stack-overflow index 7229661c9..dd54249d8 100755 --- a/test-suite/standalone/test-stack-overflow +++ b/test-suite/standalone/test-stack-overflow @@ -15,6 +15,12 @@ exec guile -q -s "$0" "$@" ;; See also test-out-of-memory. (exit 77)) ; uresolved +(when (string-ci= "GNU" (vector-ref (uname) 0)) + ;; setrlimits are not yet implemented on GNU/Hurd systems. Proceeding + ;; with the test would end in a crash. See + ;; + (exit 77)) ; unresolved + (when (string-contains-ci (vector-ref (uname) 0) "CYGWIN_NT") ;; attempting to use setrlimits for memory RLIMIT_AS will always ;; produce an invalid argument error on Cygwin (tested on From 96c9af4ab1490766fb1e2229ff3cf565cf7f10d1 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 17 May 2017 22:09:26 +0200 Subject: [PATCH 856/865] readline: Avoid interpreting control characters in pastes. * NEWS: Update. * doc/ref/repl-modules.texi (Readline Options): Update for bracketed-paste. * guile-readline/readline.h (SCM_READLINE_BRACKETED_PASTE): Add bracketed-paste option. * guile-readline/readline.c (scm_readline_opts): Add bracketed-paste. (scm_init_readline): Wire up the logic. --- NEWS | 17 +++++++++++++++++ doc/ref/repl-modules.texi | 2 ++ guile-readline/readline.c | 7 ++++++- guile-readline/readline.h | 3 ++- 4 files changed, 27 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index d2c619785..6d7e58e8e 100644 --- a/NEWS +++ b/NEWS @@ -5,6 +5,23 @@ See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. + +Changes in 2.2.3 (since 2.2.2): + +* Bug fixes + +** Enable GNU Readline 7.0's support for "bracketed paste". + +Before, when pasting an expression that contained TAB characters into +Guile's REPL with GNU Readline support enabled, the pasted TAB +characters would trigger autocompletion in Readline. This was never +what you wanted. Guile now sets the new "bracketed-paste" option in GNU +Readline 7.0 to on by default, making readline treat pastes into the +terminal as atomic units without control characters. See "Readline +Options" in the manual for full details. + +** Fix time-monotonic from SRFI-19; broken in 2.2.1. + Changes in 2.2.2 (since 2.2.1): diff --git a/doc/ref/repl-modules.texi b/doc/ref/repl-modules.texi index 700867272..e20393ba2 100644 --- a/doc/ref/repl-modules.texi +++ b/doc/ref/repl-modules.texi @@ -108,6 +108,8 @@ history-file yes Use history file. history-length 200 History length. bounce-parens 500 Time (ms) to show matching opening parenthesis (0 = off). +bracketed-paste yes Disable interpretation of control characters + in pastes. @end smalllisp The readline options interface can only be used @emph{after} loading diff --git a/guile-readline/readline.c b/guile-readline/readline.c index a3e890346..c15275dd3 100644 --- a/guile-readline/readline.c +++ b/guile-readline/readline.c @@ -47,6 +47,8 @@ scm_t_option scm_readline_opts[] = { "History length." }, { SCM_OPTION_INTEGER, "bounce-parens", 500, "Time (ms) to show matching opening parenthesis (0 = off)."}, + { SCM_OPTION_BOOLEAN, "bracketed-paste", 1, + "Disable interpretation of control characters in pastes." }, { 0 } }; @@ -545,7 +547,10 @@ scm_init_readline () reentry_barrier_mutex = scm_make_mutex (); scm_init_opts (scm_readline_options, - scm_readline_opts); + scm_readline_opts); + rl_variable_bind ("enable-bracketed-paste", + SCM_READLINE_BRACKETED_PASTE ? "on" : "off"); + #if HAVE_RL_GET_KEYMAP init_bouncing_parens(); #endif diff --git a/guile-readline/readline.h b/guile-readline/readline.h index 2bf5f8000..3c935e2aa 100644 --- a/guile-readline/readline.h +++ b/guile-readline/readline.h @@ -39,7 +39,8 @@ SCM_RL_API scm_t_option scm_readline_opts[]; #define SCM_HISTORY_FILE_P scm_readline_opts[0].val #define SCM_HISTORY_LENGTH scm_readline_opts[1].val #define SCM_READLINE_BOUNCE_PARENS scm_readline_opts[2].val -#define SCM_N_READLINE_OPTIONS 3 +#define SCM_READLINE_BRACKETED_PASTE scm_readline_opts[3].val +#define SCM_N_READLINE_OPTIONS 4 SCM_RL_API SCM scm_readline_options (SCM setting); SCM_RL_API void scm_readline_init_ports (SCM inp, SCM outp); From 7095a536f32d08efbd6578cb26fc2a4367ad16bb Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 21 May 2017 11:56:59 +0200 Subject: [PATCH 857/865] web: add support for URI-reference Based on a patch by Daniel Hartwig . * NEWS: Update. * doc/ref/web.texi (URIs): Fragments are properly part of a URI, so remove the incorrect note. Add documentation on URI subtypes. * module/web/uri.scm (uri-reference?): New base type predicate. (uri?, relative-ref?): Specific predicates. (validate-uri-reference): Strict validation. (validate-uri, validate-relative-ref): Specific validators. (build-uri-reference, build-relative-ref): New constructors. (string->uri-reference): Rename from string->uri. (string->uri, string->relative-ref): Specific constructors. (uri->string): Add #:include-fragment? keyword argument. * module/web/http.scm (parse-request-uri): Use `build-uri-reference', and result is a URI-reference, not URI, object. No longer infer an absent `uri-scheme' is `http'. (write-uri): Just use `uri->string'. (declare-uri-header!): Remove unused function. (declare-uri-reference-header!): Update. Rename from `declare-relative-uri-header!'. * test-suite/tests/web-uri.test ("build-uri-reference"): ("string->uri-reference"): Add. ("uri->string"): Also tests for relative-refs. * test-suite/tests/web-http.test ("read-request-line"): ("write-request-line"): Update for no scheme in some URIs. ("entity headers", "request headers"): Content-location, Referer, and Location should also parse relative-URIs. * test-suite/tests/web-request.test ("example-1"): Expect URI-reference with no scheme. --- NEWS | 18 ++++ doc/ref/web.texi | 138 +++++++++++++++++---------- module/web/client.scm | 12 +-- module/web/http.scm | 48 ++-------- module/web/request.scm | 2 +- module/web/uri.scm | 152 ++++++++++++++++++++++++------ test-suite/tests/web-http.test | 51 ++++++---- test-suite/tests/web-request.test | 5 +- test-suite/tests/web-uri.test | 62 +++++++++++- 9 files changed, 340 insertions(+), 148 deletions(-) diff --git a/NEWS b/NEWS index 6d7e58e8e..7ce583b9b 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,24 @@ Please send Guile bug reports to bug-guile@gnu.org. Changes in 2.2.3 (since 2.2.2): +* New interfaces + +** (web uri) module has better support for RFC 3986 + +The URI standard, RFC 3986, defines additional "relative-ref" and +"URI-reference" data types. Thanks to Daniel Hartwig, Guile's support +for these URI subtypes has been improved. See "Universal Resource +Identifiers" in the manual, for more. + +* New deprecations + +** Using `uri?' as a predicate on relative-refs deprecated + +If you don't care whether the URI is a relative-ref or not, use +`uri-reference?'. If you do, use `uri-reference?' and `relative-ref?'. +In the future `uri?' will return a true value only for URIs that specify +a scheme. + * Bug fixes ** Enable GNU Readline 7.0's support for "bracketed paste". diff --git a/doc/ref/web.texi b/doc/ref/web.texi index c0a7bdda6..7c6a9545e 100644 --- a/doc/ref/web.texi +++ b/doc/ref/web.texi @@ -173,23 +173,13 @@ Guile provides a standard data type for Universal Resource Identifiers The generic URI syntax is as follows: @example -URI := scheme ":" ["//" [userinfo "@@"] host [":" port]] path \ - [ "?" query ] [ "#" fragment ] +URI-reference := [scheme ":"] ["//" [userinfo "@@"] host [":" port]] path \ + [ "?" query ] [ "#" fragment ] @end example For example, in the URI, @indicateurl{http://www.gnu.org/help/}, the scheme is @code{http}, the host is @code{www.gnu.org}, the path is -@code{/help/}, and there is no userinfo, port, query, or fragment. All -URIs have a scheme and a path (though the path might be empty). Some -URIs have a host, and some of those have ports and userinfo. Any URI -might have a query part or a fragment. - -There is also a ``URI-reference'' data type, which is the same as a URI -but where the scheme is optional. In this case, the scheme is taken to -be relative to some other related URI. A common use of URI references -is when you want to be vague regarding the choice of HTTP or HTTPS -- -serving a web page referring to @code{/foo.css} will use HTTPS if loaded -over HTTPS, or HTTP otherwise. +@code{/help/}, and there is no userinfo, port, query, or fragment. Userinfo is something of an abstraction, as some legacy URI schemes allowed userinfo of the form @code{@var{username}:@var{passwd}}. But @@ -197,14 +187,6 @@ since passwords do not belong in URIs, the RFC does not want to condone this practice, so it calls anything before the @code{@@} sign @dfn{userinfo}. -Properly speaking, a fragment is not part of a URI. For example, when a -web browser follows a link to @indicateurl{http://example.com/#foo}, it -sends a request for @indicateurl{http://example.com/}, then looks in the -resulting page for the fragment identified @code{foo} reference. A -fragment identifies a part of a resource, not the resource itself. But -it is useful to have a fragment field in the URI record itself, so we -hope you will forgive the inconsistency. - @example (use-modules (web uri)) @end example @@ -213,40 +195,36 @@ The following procedures can be found in the @code{(web uri)} module. Load it into your Guile, using a form like the above, to have access to them. +The most common way to build a URI from Scheme is with the +@code{build-uri} function. + @deffn {Scheme Procedure} build-uri scheme @ [#:userinfo=@code{#f}] [#:host=@code{#f}] [#:port=@code{#f}] @ [#:path=@code{""}] [#:query=@code{#f}] [#:fragment=@code{#f}] @ [#:validate?=@code{#t}] -Construct a URI object. @var{scheme} should be a symbol, @var{port} -either a positive, exact integer or @code{#f}, and the rest of the -fields are either strings or @code{#f}. If @var{validate?} is true, -also run some consistency checks to make sure that the constructed URI -is valid. +Construct a URI. @var{scheme} should be a symbol, @var{port} either a +positive, exact integer or @code{#f}, and the rest of the fields are +either strings or @code{#f}. If @var{validate?} is true, also run some +consistency checks to make sure that the constructed URI is valid. @end deffn - -@deffn {Scheme Procedure} build-uri-reference [#:scheme=@code{#f}]@ - [#:userinfo=@code{#f}] [#:host=@code{#f}] [#:port=@code{#f}] @ - [#:path=@code{""}] [#:query=@code{#f}] [#:fragment=@code{#f}] @ - [#:validate?=@code{#t}] -Like @code{build-uri}, but with an optional scheme. -@end deffn - -In Guile, both URI and URI reference data types are represented in the -same way, as URI objects. - @deffn {Scheme Procedure} uri? obj -@deffnx {Scheme Procedure} uri-scheme uri +Return @code{#t} if @var{obj} is a URI. +@end deffn + +Guile, URIs are represented as URI records, with a number of associated +accessors. + +@deffn {Scheme Procedure} uri-scheme uri @deffnx {Scheme Procedure} uri-userinfo uri @deffnx {Scheme Procedure} uri-host uri @deffnx {Scheme Procedure} uri-port uri @deffnx {Scheme Procedure} uri-path uri @deffnx {Scheme Procedure} uri-query uri @deffnx {Scheme Procedure} uri-fragment uri -A predicate and field accessors for the URI record type. The URI scheme -will be a symbol, or @code{#f} if the object is a URI reference but not -a URI. The port will be either a positive, exact integer or @code{#f}, -and the rest of the fields will be either strings or @code{#f} if not -present. +Field accessors for the URI record type. The URI scheme will be a +symbol, or @code{#f} if the object is a relative-ref (see below). The +port will be either a positive, exact integer or @code{#f}, and the rest +of the fields will be either strings or @code{#f} if not present. @end deffn @deffn {Scheme Procedure} string->uri string @@ -254,15 +232,11 @@ Parse @var{string} into a URI object. Return @code{#f} if the string could not be parsed. @end deffn -@deffn {Scheme Procedure} string->uri-reference string -Parse @var{string} into a URI object, while not requiring a scheme. -Return @code{#f} if the string could not be parsed. -@end deffn - -@deffn {Scheme Procedure} uri->string uri +@deffn {Scheme Procedure} uri->string uri [#:include-fragment?=@code{#t}] Serialize @var{uri} to a string. If the URI has a port that is the default port for its scheme, the port is not included in the -serialization. +serialization. If @var{include-fragment?} is given as false, the +resulting string will omit the fragment (if any). @end deffn @deffn {Scheme Procedure} declare-default-port! scheme port @@ -323,6 +297,70 @@ For example, the list @code{("scrambled eggs" "biscuits&gravy")} encodes as @code{"scrambled%20eggs/biscuits%26gravy"}. @end deffn +@subsubheading Subtypes of URI + +As we noted above, not all URI objects have a scheme. You might have +noted in the ``generic URI syntax'' example that the left-hand side of +that grammar definition was URI-reference, not URI. A +@dfn{URI-reference} is a generalization of a URI where the scheme is +optional. If no scheme is specified, it is taken to be relative to some +other related URI. A common use of URI references is when you want to +be vague regarding the choice of HTTP or HTTPS -- serving a web page +referring to @code{/foo.css} will use HTTPS if loaded over HTTPS, or +HTTP otherwise. + +@deffn {Scheme Procedure} build-uri-reference [#:scheme=@code{#f}]@ + [#:userinfo=@code{#f}] [#:host=@code{#f}] [#:port=@code{#f}] @ + [#:path=@code{""}] [#:query=@code{#f}] [#:fragment=@code{#f}] @ + [#:validate?=@code{#t}] +Like @code{build-uri}, but with an optional scheme. +@end deffn +@deffn {Scheme Procedure} uri-reference? obj +Return @code{#t} if @var{obj} is a URI-reference. This is the most +general URI predicate, as it includes not only full URIs that have +schemes (those that match @code{uri?}) but also URIs without schemes. +@end deffn + +It's also possible to build a @dfn{relative-ref}: a URI-reference that +explicitly lacks a scheme. + +@deffn {Scheme Procedure} build-relative-ref @ + [#:userinfo=@code{#f}] [#:host=@code{#f}] [#:port=@code{#f}] @ + [#:path=@code{""}] [#:query=@code{#f}] [#:fragment=@code{#f}] @ + [#:validate?=@code{#t}] +Like @code{build-uri}, but with no scheme. +@end deffn +@deffn {Scheme Procedure} relative-ref? obj +Return @code{#t} if @var{obj} is a ``relative-ref'': a URI-reference +that has no scheme. Every URI-reference will either match @code{uri?} +or @code{relative-ref?} (but not both). +@end deffn + +In case it's not clear from the above, the most general of these URI +types is the URI-reference, with @code{build-uri-reference} as the most +general constructor. @code{build-uri} and @code{build-relative-ref} +enforce enforce specific restrictions on the URI-reference. The most +generic URI parser is then @code{string->uri-reference}, and there is +also a parser for when you know that you want a relative-ref. + +@deffn {Scheme Procedure} string->uri-reference string +Parse @var{string} into a URI object, while not requiring a scheme. +Return @code{#f} if the string could not be parsed. +@end deffn + +@deffn {Scheme Procedure} string->relative-ref string +Parse @var{string} into a URI object, while asserting that no scheme is +present. Return @code{#f} if the string could not be parsed. +@end deffn + +For compatibility reasons, note that @code{uri?} will return @code{#t} +for all URI objects, even relative-refs. In contrast, @code{build-uri} +and @code{string->uri} require that the resulting URI not be a +relative-ref. As a predicate to distinguish relative-refs from proper +URIs (in the language of RFC 3986), use something like @code{(and +(uri-reference? @var{x}) (not (relative-ref? @var{x})))}. + + @node HTTP @subsection The Hyper-Text Transfer Protocol diff --git a/module/web/client.scm b/module/web/client.scm index c30fa99eb..3b7ea5156 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -164,16 +164,16 @@ host name without trailing dot." get-position set-position! close)))) -(define (ensure-uri uri-or-string) +(define (ensure-uri-reference uri-or-string) (cond - ((string? uri-or-string) (string->uri uri-or-string)) - ((uri? uri-or-string) uri-or-string) - (else (error "Invalid URI" uri-or-string)))) + ((string? uri-or-string) (string->uri-reference uri-or-string)) + ((uri-reference? uri-or-string) uri-or-string) + (else (error "Invalid URI-reference" uri-or-string)))) (define (open-socket-for-uri uri-or-string) "Return an open input/output port for a connection to URI." (define http-proxy (current-http-proxy)) - (define uri (ensure-uri (or http-proxy uri-or-string))) + (define uri (ensure-uri-reference (or http-proxy uri-or-string))) (define addresses (let ((port (uri-port uri))) (delete-duplicates @@ -344,7 +344,7 @@ as is the case by default with a request returned by `build-request'." (streaming? #f) (request (build-request - (ensure-uri uri) + (ensure-uri-reference uri) #:method method #:version version #:headers (if keep-alive? diff --git a/module/web/http.scm b/module/web/http.scm index 1f208f44e..993b50ef4 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -1112,7 +1112,8 @@ symbol, like ‘GET’." (define* (parse-request-uri str #:optional (start 0) (end (string-length str))) "Parse a URI from an HTTP request line. Note that URIs in requests do -not have to have a scheme or host name. The result is a URI object." +not have to have a scheme or host name. The result is a URI-reference +object." (cond ((= start end) (bad-request "Missing Request-URI")) @@ -1122,10 +1123,10 @@ not have to have a scheme or host name. The result is a URI object." (let* ((q (string-index str #\? start end)) (f (string-index str #\# start end)) (q (and q (or (not f) (< q f)) q))) - (build-uri 'http - #:path (substring str start (or q f end)) - #:query (and q (substring str (1+ q) (or f end))) - #:fragment (and f (substring str (1+ f) end))))) + (build-uri-reference + #:path (substring str start (or q f end)) + #:query (and q (substring str (1+ q) (or f end))) + #:fragment (and f (substring str (1+ f) end))))) (else (or (string->uri (substring str start end)) (bad-request "Invalid URI: ~a" (substring str start end)))))) @@ -1143,31 +1144,7 @@ three values: the method, the URI, and the version." (parse-http-version line (1+ d1) (string-length line))))) (define (write-uri uri port) - (when (uri-host uri) - (when (uri-scheme uri) - (put-symbol port (uri-scheme uri)) - (put-char port #\:)) - (put-string port "//") - (when (uri-userinfo uri) - (put-string port (uri-userinfo uri)) - (put-char port #\@)) - (put-string port (uri-host uri)) - (let ((p (uri-port uri))) - (when (and p (not (eqv? p 80))) - (put-char port #\:) - (put-non-negative-integer port p)))) - (let* ((path (uri-path uri)) - (len (string-length path))) - (cond - ((and (> len 0) (not (eqv? (string-ref path 0) #\/))) - (bad-request "Non-absolute URI path: ~s" path)) - ((and (zero? len) (not (uri-host uri))) - (bad-request "Empty path and no host for URI: ~s" uri)) - (else - (put-string port path)))) - (when (uri-query uri) - (put-char port #\?) - (put-string port (uri-query uri)))) + (put-string port (uri->string uri #:include-fragment? #f))) (define (write-request-line method uri version port) "Write the first line of an HTTP request to PORT." @@ -1272,20 +1249,13 @@ treated specially, and is just returned as a plain string." parse-non-negative-integer non-negative-integer? (lambda (val port) (put-non-negative-integer port val)))) -;; emacs: (put 'declare-uri-header! 'scheme-indent-function 1) -(define (declare-uri-header! name) - (declare-header! name - (lambda (str) (or (string->uri str) (bad-header-component 'uri str))) - (@@ (web uri) absolute-uri?) - write-uri)) - ;; emacs: (put 'declare-uri-reference-header! 'scheme-indent-function 1) (define (declare-uri-reference-header! name) (declare-header! name (lambda (str) (or (string->uri-reference str) - (bad-header-component 'uri str))) - uri? + (bad-header-component 'uri-reference str))) + uri-reference? write-uri)) ;; emacs: (put 'declare-quality-list-header! 'scheme-indent-function 1) diff --git a/module/web/request.scm b/module/web/request.scm index c9f1dc1ac..eea32e9ce 100644 --- a/module/web/request.scm +++ b/module/web/request.scm @@ -170,7 +170,7 @@ the headers are each run through their respective validators." (non-negative-integer? (car version)) (non-negative-integer? (cdr version)))) (bad-request "Bad version: ~a" version)) - ((not (uri? uri)) + ((not (uri-reference? uri)) (bad-request "Bad uri: ~a" uri)) ((and (not port) (memq method '(POST PUT))) (bad-request "Missing port for message ~a" method)) diff --git a/module/web/uri.scm b/module/web/uri.scm index 848d5009b..5b01aa41f 100644 --- a/module/web/uri.scm +++ b/module/web/uri.scm @@ -42,11 +42,15 @@ uri->string uri-decode uri-encode split-and-decode-uri-path - encode-and-join-uri-path)) + encode-and-join-uri-path + + uri-reference? relative-ref? + build-uri-reference build-relative-ref + string->uri-reference string->relative-ref)) (define-record-type (make-uri scheme userinfo host port path query fragment) - uri? + uri-reference? (scheme uri-scheme) (userinfo uri-userinfo) (host uri-host) @@ -55,8 +59,49 @@ (query uri-query) (fragment uri-fragment)) -(define (absolute-uri? obj) - (and (uri? obj) (uri-scheme obj) #t)) +;;; +;;; Predicates. +;;; +;;; These are quick, and assume rigid validation at construction time. + +;;; RFC 3986, #3. +;;; +;;; URI = scheme ":" hier-part [ "?" query ] [ "#" fragment ] +;;; +;;; hier-part = "//" authority path-abempty +;;; / path-absolute +;;; / path-rootless +;;; / path-empty + +(define (uri? obj) + (and (uri-reference? obj) + (if (include-deprecated-features) + (begin + (unless (uri-scheme obj) + (issue-deprecation-warning + "Use uri-reference? instead of uri?; in the future, uri? +will require that the object not be a relative-ref.")) + #t) + (uri-scheme obj)) + #t)) + +;;; RFC 3986, #4.2. +;;; +;;; relative-ref = relative-part [ "?" query ] [ "#" fragment ] +;;; +;;; relative-part = "//" authority path-abempty +;;; / path-absolute +;;; / path-noscheme +;;; / path-empty + +(define (relative-ref? obj) + (and (uri-reference? obj) + (not (uri-scheme obj)))) + + +;;; +;;; Constructors. +;;; (define (uri-error message . args) (throw 'uri-error message args)) @@ -64,10 +109,9 @@ (define (positive-exact-integer? port) (and (number? port) (exact? port) (integer? port) (positive? port))) -(define* (validate-uri scheme userinfo host port path query fragment - #:key reference?) +(define (validate-uri-reference scheme userinfo host port path query fragment) (cond - ((and (not reference?) (not (symbol? scheme))) + ((and scheme (not (symbol? scheme))) (uri-error "Expected a symbol for the URI scheme: ~s" scheme)) ((and (or userinfo port) (not host)) (uri-error "Expected a host, given userinfo or port")) @@ -79,32 +123,65 @@ (uri-error "Expected string for userinfo: ~s" userinfo)) ((not (string? path)) (uri-error "Expected string for path: ~s" path)) - ((and host (not (string-null? path)) - (not (eqv? (string-ref path 0) #\/))) - (uri-error "Expected path of absolute URI to start with a /: ~a" path)))) + ((and query (not (string? query))) + (uri-error "Expected string for query: ~s" query)) + ((and fragment (not (string? fragment))) + (uri-error "Expected string for fragment: ~s" fragment)) + ;; Strict validation of allowed paths, based on other components. + ;; Refer to RFC 3986 for the details. + ((not (string-null? path)) + (if host + (cond + ((not (eqv? (string-ref path 0) #\/)) + (uri-error + "Expected absolute path starting with \"/\": ~a" path))) + (cond + ((string-prefix? "//" path) + (uri-error + "Expected path not starting with \"//\" (no host): ~a" path)) + ((and (not scheme) + (not (eqv? (string-ref path 0) #\/)) + (let ((colon (string-index path #\:))) + (and colon (not (string-index path #\/ 0 colon))))) + (uri-error + "Expected relative path's first segment without \":\": ~a" + path))))))) (define* (build-uri scheme #:key userinfo host port (path "") query fragment (validate? #t)) "Construct a URI object. SCHEME should be a symbol, PORT either a positive, exact integer or ‘#f’, and the rest of the fields are either strings or ‘#f’. If VALIDATE? is true, also run some consistency checks -to make sure that the constructed object is a valid absolute URI." - (if validate? - (validate-uri scheme userinfo host port path query fragment)) +to make sure that the constructed object is a valid URI." + (when validate? + (unless scheme (uri-error "Missing URI scheme")) + (validate-uri-reference scheme userinfo host port path query fragment)) (make-uri scheme userinfo host port path query fragment)) (define* (build-uri-reference #:key scheme userinfo host port (path "") query fragment (validate? #t)) - "Construct a URI object. SCHEME should be a symbol or ‘#f’, PORT -either a positive, exact integer or ‘#f’, and the rest of the fields -are either strings or ‘#f’. If VALIDATE? is true, also run some + "Construct a URI-reference object. SCHEME should be a symbol or ‘#f’, +PORT either a positive, exact integer or ‘#f’, and the rest of the +fields are either strings or ‘#f’. If VALIDATE? is true, also run some consistency checks to make sure that the constructed URI is a valid URI -reference (either an absolute URI or a relative reference)." - (if validate? - (validate-uri scheme userinfo host port path query fragment - #:reference? #t)) +reference." + (when validate? + (validate-uri-reference scheme userinfo host port path query fragment)) (make-uri scheme userinfo host port path query fragment)) +(define* (build-relative-ref #:key userinfo host port (path "") query fragment + (validate? #t)) + "Construct a relative-ref URI object. The arguments are the same as +for ‘build-uri’ except there is no scheme." + (when validate? + (validate-uri-reference #f userinfo host port path query fragment)) + (make-uri #f userinfo host port path query fragment)) + + +;;; +;;; Converters. +;;; + ;; See RFC 3986 #3.2.2 for comments on percent-encodings, IDNA (RFC ;; 3490), and non-ASCII host names. ;; @@ -192,16 +269,24 @@ reference (either an absolute URI or a relative reference)." (make-regexp uri-pat)) (define (string->uri-reference string) - "Parse the URI reference written as STRING into a URI object. Return -‘#f’ if the string could not be parsed." + "Parse STRING into a URI-reference object. Return ‘#f’ if the string +could not be parsed." (% (let ((m (regexp-exec uri-regexp string))) - (if (not m) (abort)) + (unless m (abort)) (let ((scheme (let ((str (match:substring m 2))) (and str (string->symbol (string-downcase str))))) (authority (match:substring m 3)) (path (match:substring m 4)) (query (match:substring m 6)) (fragment (match:substring m 8))) + ;; The regular expression already ensures all of the validation + ;; requirements for URI-references, except the one that the + ;; first component of a relative-ref's path can't contain a + ;; colon. + (unless scheme + (let ((colon (string-index path #\:))) + (when (and colon (not (string-index path #\/ 0 colon))) + (abort)))) (call-with-values (lambda () (if authority @@ -213,10 +298,19 @@ reference (either an absolute URI or a relative reference)." #f))) (define (string->uri string) - "Parse STRING into an absolute URI object. Return ‘#f’ if the string -could not be parsed." - (let ((uri (string->uri-reference string))) - (and uri (uri-scheme uri) uri))) + "Parse STRING into a URI object. Return ‘#f’ if the string could not +be parsed. Note that this procedure will require that the URI have a +scheme." + (let ((uri-reference (string->uri-reference string))) + (and (not (relative-ref? uri-reference)) + uri-reference))) + +(define (string->relative-ref string) + "Parse STRING into a relative-ref URI object. Return ‘#f’ if the +string could not be parsed." + (let ((uri-reference (string->uri-reference string))) + (and (relative-ref? uri-reference) + uri-reference))) (define *default-ports* (make-hash-table)) @@ -231,7 +325,7 @@ could not be parsed." (declare-default-port! 'http 80) (declare-default-port! 'https 443) -(define (uri->string uri) +(define* (uri->string uri #:key (include-fragment? #t)) "Serialize URI to a string. If the URI has a port that is the default port for its scheme, the port is not included in the serialization." @@ -261,7 +355,7 @@ serialization." (if query (string-append "?" query) "") - (if fragment + (if (and fragment include-fragment?) (string-append "#" fragment) "")))) diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test index da00ec316..63377349c 100644 --- a/test-suite/tests/web-http.test +++ b/test-suite/tests/web-http.test @@ -1,6 +1,6 @@ ;;;; web-http.test --- HTTP library -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010-2011, 2014-2016 Free Software Foundation, Inc. +;;;; Copyright (C) 2010-2011, 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 @@ -150,32 +150,33 @@ (with-test-prefix "read-request-line" (pass-if-read-request-line "GET / HTTP/1.1" GET - (build-uri 'http - #:path "/") + (build-uri-reference + #:path "/") (1 . 1)) (pass-if-read-request-line "GET http://www.w3.org/pub/WWW/TheProject.html HTTP/1.1" GET - (build-uri 'http - #:host "www.w3.org" - #:path "/pub/WWW/TheProject.html") + (build-uri-reference + #:scheme 'http + #:host "www.w3.org" + #:path "/pub/WWW/TheProject.html") (1 . 1)) (pass-if-read-request-line "GET /pub/WWW/TheProject.html HTTP/1.1" GET - (build-uri 'http - #:path "/pub/WWW/TheProject.html") + (build-uri-reference + #:path "/pub/WWW/TheProject.html") (1 . 1)) (pass-if-read-request-line "HEAD /etc/hosts?foo=bar HTTP/1.1" HEAD - (build-uri 'http - #:path "/etc/hosts" - #:query "foo=bar") + (build-uri-reference + #:path "/etc/hosts" + #:query "foo=bar") (1 . 1))) (with-test-prefix "write-request-line" (pass-if-write-request-line "GET / HTTP/1.1" GET - (build-uri 'http - #:path "/") + (build-uri-reference + #:path "/") (1 . 1)) ;;; FIXME: Test fails due to scheme, host always being removed. ;;; However, it should be supported to request these be present, and @@ -188,8 +189,8 @@ ;; (1 . 1)) (pass-if-write-request-line "GET /pub/WWW/TheProject.html HTTP/1.1" GET - (build-uri 'http - #:path "/pub/WWW/TheProject.html") + (build-uri-reference + #:path "/pub/WWW/TheProject.html") (1 . 1)) (pass-if-write-request-line "GET /?foo HTTP/1.1" GET @@ -197,9 +198,9 @@ (1 . 1)) (pass-if-write-request-line "HEAD /etc/hosts?foo=bar HTTP/1.1" HEAD - (build-uri 'http - #:path "/etc/hosts" - #:query "foo=bar") + (build-uri-reference + #:path "/etc/hosts" + #:query "foo=bar") (1 . 1))) (with-test-prefix "read-response-line" @@ -298,6 +299,12 @@ (pass-if-parse content-length "010" 10) (pass-if-parse content-location "http://foo/" (build-uri 'http #:host "foo" #:path "/")) + (pass-if-parse content-location "//foo/" + (build-uri-reference #:host "foo" #:path "/")) + (pass-if-parse content-location "/etc/foo" + (build-uri-reference #:path "/etc/foo")) + (pass-if-parse content-location "foo" + (build-uri-reference #:path "foo")) (pass-if-parse content-range "bytes 10-20/*" '(bytes (10 . 20) *)) (pass-if-parse content-range "bytes */*" '(bytes * *)) (pass-if-parse content-range "bytes */30" '(bytes * 30)) @@ -370,6 +377,14 @@ (pass-if-parse range "bytes=-20,-30" '(bytes (#f . 20) (#f . 30))) (pass-if-parse referer "http://foo/bar?baz" (build-uri 'http #:host "foo" #:path "/bar" #:query "baz")) + (pass-if-parse referer "//foo/bar?baz" + (build-uri-reference #:host "foo" + #:path "/bar" + #:query "baz")) + (pass-if-parse referer "/etc/foo" + (build-uri-reference #:path "/etc/foo")) + (pass-if-parse referer "foo" + (build-uri-reference #:path "foo")) (pass-if-parse te "trailers" '((trailers))) (pass-if-parse te "trailers,foo" '((trailers) (foo))) (pass-if-parse user-agent "guile" "guile")) diff --git a/test-suite/tests/web-request.test b/test-suite/tests/web-request.test index 8cf1c2e87..68721d3ab 100644 --- a/test-suite/tests/web-request.test +++ b/test-suite/tests/web-request.test @@ -1,6 +1,6 @@ ;;;; web-request.test --- HTTP requests -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; 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 @@ -53,7 +53,8 @@ Accept-Language: en-gb, en;q=0.9\r (pass-if (equal? (request-method r) 'GET)) - (pass-if (equal? (request-uri r) (build-uri 'http #:path "/qux"))) + (pass-if (equal? (request-uri r) + (build-uri-reference #:path "/qux"))) (pass-if (equal? (read-request-body r) #f)) diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test index ad56f6f2d..73391898c 100644 --- a/test-suite/tests/web-uri.test +++ b/test-suite/tests/web-uri.test @@ -1,6 +1,6 @@ ;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010, 2011, 2012, 2014 Free Software Foundation, Inc. +;;;; Copyright (C) 2010-2012, 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 @@ -27,7 +27,7 @@ (define* (uri=? uri #:key scheme userinfo host port path query fragment) - (and (uri? uri) + (and (uri-reference? uri) (equal? (uri-scheme uri) scheme) (equal? (uri-userinfo uri) userinfo) (equal? (uri-host uri) host) @@ -123,6 +123,22 @@ "Expected.*host" (build-uri 'http #:userinfo "foo"))) +(with-test-prefix "build-uri-reference" + (pass-if "//host/etc/foo" + (uri=? (build-uri-reference #:host "host" + #:path "/etc/foo") + #:host "host" + #:path "/etc/foo")) + + (pass-if "/path/to/some/foo?query" + (uri=? (build-uri-reference #:path "/path/to/some/foo" + #:query "query") + #:path "/path/to/some/foo" + #:query "query")) + + (pass-if "nextdoc/foo" + (uri=? (build-uri-reference #:path "nextdoc/foo") + #:path "nextdoc/foo"))) (with-test-prefix "string->uri" (pass-if "ftp:" @@ -503,6 +519,30 @@ #:query "q" #:fragment "bar"))) +(with-test-prefix "string->uri-reference" + (pass-if "/" + (uri=? (string->uri-reference "/") + #:path "/")) + + (pass-if "/path/to/foo" + (uri=? (string->uri-reference "/path/to/foo") + #:path "/path/to/foo")) + + (pass-if "//example.org" + (uri=? (string->uri-reference "//example.org") + #:host "example.org" + #:path "")) + + (pass-if "//bar@example.org/path/to/foo" + (uri=? (string->uri-reference "//bar@example.org/path/to/foo") + #:userinfo "bar" + #:host "example.org" + #:path "/path/to/foo")) + + (pass-if "nextdoc/foo" + (uri=? (string->uri-reference "nextdoc/foo") + #:path "nextdoc/foo"))) + (with-test-prefix "uri->string" (pass-if "ftp:" (equal? "ftp:" @@ -587,7 +627,23 @@ (pass-if "foo/?bar#baz" (equal? "foo/?bar#baz" - (uri->string (string->uri-reference "foo/?bar#baz"))))) + (uri->string (string->uri-reference "foo/?bar#baz")))) + + (pass-if "/path/to/foo" + (equal? "/path/to/foo" + (uri->string (string->uri-reference "/path/to/foo")))) + + (pass-if "//example.org" + (equal? "//example.org" + (uri->string (string->uri-reference "//example.org")))) + + (pass-if "//bar@example.org/path/to/foo" + (equal? "//bar@example.org/path/to/foo" + (uri->string (string->uri-reference "//bar@example.org/path/to/foo")))) + + (pass-if "nextdoc/foo" + (equal? "nextdoc/foo" + (uri->string (string->uri-reference "nextdoc/foo"))))) (with-test-prefix "decode" (pass-if "foo%20bar" From f7b70c1435222ef2a4362f88ca5b232686613395 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 22 May 2017 12:55:04 +0200 Subject: [PATCH 858/865] Remove outdated README.guile-vm. * README.guile-vm: Remove. --- README.guile-vm | 117 ------------------------------------------------ 1 file changed, 117 deletions(-) delete mode 100644 README.guile-vm diff --git a/README.guile-vm b/README.guile-vm deleted file mode 100644 index 72ab6c914..000000000 --- a/README.guile-vm +++ /dev/null @@ -1,117 +0,0 @@ -This is an attempt to revive the Guile-VM project by Keisuke Nishida -written back in the years 2000 and 2001. Below are a few pointers to -relevant threads on Guile's development mailing list. - -Enjoy! - -Ludovic Courts , Apr. 2005. - - -Pointers --------- - -Status of the last release, 0.5 - http://lists.gnu.org/archive/html/guile-devel/2001-04/msg00266.html - -The very first release, 0.0 - http://sources.redhat.com/ml/guile/2000-07/msg00418.html - -Simple benchmark - http://sources.redhat.com/ml/guile/2000-07/msg00425.html - -Performance, portability, GNU Lightning - http://lists.gnu.org/archive/html/guile-devel/2001-03/msg00132.html - -Playing with GNU Lightning - http://lists.gnu.org/archive/html/guile-devel/2001-03/msg00185.html - -On things left to be done - http://lists.gnu.org/archive/html/guile-devel/2001-03/msg00146.html - - ----8<--- Original README below. ----------------------------------------- - -Installation ------------- - -1. Install the latest Guile from CVS. - -2. Install Guile VM: - - % configure - % make install - % ln -s module/{guile,system,language} /usr/local/share/guile/ - -3. Add the following lines to your ~/.guile: - - (use-modules (system vm core) - - (cond ((string=? (car (command-line)) "guile-vm") - (use-modules (system repl repl)) - (start-repl 'scheme) - (quit))) - -Example Session ---------------- - - % guile-vm - Guile Scheme interpreter 0.5 on Guile 1.4.1 - Copyright (C) 2001 Free Software Foundation, Inc. - - Enter `,help' for help. - scheme@guile-user> (+ 1 2) - 3 - scheme@guile-user> ,c -c (+ 1 2) ;; Compile into GLIL - (@asm (0 1 0 0) - (module-ref #f +) - (const 1) - (const 2) - (tail-call 2)) - scheme@guile-user> ,c (+ 1 2) ;; Compile into object code - Disassembly of #: - - nlocs = 0 nexts = 0 - - 0 link "+" ;; (+ . ???) - 3 variable-ref - 4 make-int8:1 ;; 1 - 5 make-int8 2 ;; 2 - 7 tail-call 2 - - scheme@guile-user> (define (add x y) (+ x y)) - scheme@guile-user> (add 1 2) - 3 - scheme@guile-user> ,x add ;; Disassemble - Disassembly of #: - - nargs = 2 nrest = 0 nlocs = 0 nexts = 0 - - Bytecode: - - 0 object-ref 0 ;; (+ . #) - 2 variable-ref - 3 local-ref 0 - 5 local-ref 1 - 7 tail-call 2 - - Objects: - - 0 (+ . #) - - scheme@guile-user> - -Compile Modules ---------------- - -Use `guilec' to compile your modules: - - % cat fib.scm - (define-module (fib) :export (fib)) - (define (fib n) (if (< n 2) 1 (+ (fib (- n 1)) (fib (- n 2))))) - - % guilec fib.scm - Wrote fib.go - % guile - guile> (use-modules (fib)) - guile> (fib 8) - 34 From a05e710b4d6b5f60e6038c49da600c7810f3f276 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 22 May 2017 12:55:28 +0200 Subject: [PATCH 859/865] Remove outdated ANNOUNCE. * ANNOUNCE: Remove outdated file. --- ANNOUNCE | 60 -------------------------------------------------------- 1 file changed, 60 deletions(-) delete mode 100644 ANNOUNCE diff --git a/ANNOUNCE b/ANNOUNCE deleted file mode 100644 index bfbda7316..000000000 --- a/ANNOUNCE +++ /dev/null @@ -1,60 +0,0 @@ -We are pleased to announce the release of Guile 1.8.0. It can be -found here: - - ftp://ftp.gnu.org/gnu/guile/guile-1.8.0.tar.gz - -Its SHA1 checksum is - - 22462680feeda1e5400195c01dee666162503d66 guile-1.8.0.tar.gz - -We already know about some issues with 1.8.0, please check the mailing -lists: - - http://www.gnu.org/software/guile/mail/mail.html - -The NEWS file is quite long. Here are the most interesting entries: - - Changes since 1.6: - - * Guile is now licensed with the GNU Lesser General Public License. - - * The manual is now licensed with the GNU Free Documentation License. - - * We now use GNU MP for bignums. - - * We now have exact rationals, such as 1/3. - - * We now use native POSIX threads for real concurrent threads. - - * There is a new way to initalize Guile that allows one to use Guile - from threads that have not been created by Guile. - - * Mutexes and condition variables are now always fair. A recursive - mutex must be requested explicitly. - - * The low-level thread API has been removed. - - * There is now support for copy-on-write substrings and - mutation-sharing substrings. - - * A new family of functions for converting between C values and - Scheme values has been added that is future-proof and thread-safe. - - * The INUM macros like SCM_MAKINUM have been deprecated. - - * The macros SCM_STRINGP, SCM_STRING_CHARS, SCM_STRING_LENGTH, - SCM_SYMBOL_CHARS, and SCM_SYMBOL_LENGTH have been deprecated. - - * There is a new way to deal with non-local exits and re-entries in - C code, which is nicer than scm_internal_dynamic_wind. - - * There are new malloc-like functions that work better than - scm_must_malloc, etc. - - * There is a new way to access all kinds of vectors and arrays from - C that is efficient and thread-safe. - - * The concept of dynamic roots has been factored into continuation - barriers and dynamic states. - -See NEWS and the manual for more details. From d4aa914907a411e3a889eb77d395ba0c538723e0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 22 May 2017 13:12:29 +0200 Subject: [PATCH 860/865] Minor updates to HACKING. * HACKING: Minor updates. --- HACKING | 120 ++++++-------------------------------------------------- 1 file changed, 13 insertions(+), 107 deletions(-) diff --git a/HACKING b/HACKING index f3011d932..181530fd4 100644 --- a/HACKING +++ b/HACKING @@ -1,7 +1,6 @@ -*-text-*- Guile Hacking Guide -Copyright (c) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2008, 2012, - 2015 Free software Foundation, Inc. +Copyright (c) 1996-2002,2008,2012,2015,2017 Free Software Foundation, Inc. Permission is granted to anyone to make or distribute verbatim copies of this document as received, in any medium, provided that the @@ -21,13 +20,8 @@ What to Hack ========================================================= You can hack whatever you want, thank GNU. -However, to see what others have indicated as their interest (and avoid -potential wasteful duplication of effort), see file TODO. Note that -the version you find may be out of date; a CVS checkout is recommended: -see below for details (see also the files ANON-CVS and SNAPSHOTS). - -It's also a good idea to join the guile-devel@gnu.org mailing list. -See http://www.gnu.org/software/guile/mail/mail.html for more info. +It's a good idea to join the guile-devel@gnu.org mailing list. See +http://www.gnu.org/software/guile/mail/mail.html for more info. Hacking It Yourself ================================================== @@ -78,67 +72,11 @@ generated files, all different. Here is the authoritative list of tool/version/platform tuples that have been known to cause problems, and a short description of the problem. -- automake 1.4 adds extraneous rules to the top-level Makefile if - you specify specific Makefiles to rebuild on the command line. - -- automake 1.4-p4 (debian "1:1.4-p4-1.1") all platforms - automake "include" facility does not recognize filenames w/ "-". - -- libtool 1.4 uses acconfig.h, which is deprecated by newest autoconf - (which constructs the equivalent through 3rd arg of AC_DEFINE forms). - -- autoreconf from autoconf prior to 2.59 will run gettextize, which - will mess up the Guile tree. - -- libtool 1.5.26 does not know that it should remove the -R options - that the Gnulib libunistring and havelib modules generate (because - gcc doesn't actually support -R). - -- (add here.) - Sample GDB Initialization File========================================= -Here is a sample .gdbinit posted by Bill Schottstaedt (modified to -use `set' instead of `call' in some places): - - define gp - set gdb_print($arg0) - print gdb_output - end - document gp - Executes (object->string arg) - end - - define ge - call gdb_read($arg0) - call gdb_eval(gdb_result) - set gdb_print(gdb_result) - print gdb_output - end - document ge - Executes (print (eval (read arg))): ge "(+ 1 2)" => 3 - end - - define gh - call g_help(scm_str2symbol($arg0), 20) - set gdb_print($1) - print gdb_output - end - document gh - Prints help string for arg: gh "enved-target" - end - -Bill further writes: - - so in gdb if you see something useless like: - - #32 0x081ae8f4 in scm_primitive_load (filename=1112137128) at load.c:129 - - You can get the file name with gp: - - (gdb) gp 1112137128 - $1 = 0x40853fac "\"/home/bil/test/share/guile/1.5.0/ice-9/session.scm\"" +In GDB, you probably want to load the gdbinit file included with Guile, +which defines a number of GDB helpers to inspect Scheme values. Contributing Your Changes ============================================ @@ -179,19 +117,15 @@ To make sure of this, you can use the --enable-error-on-warning option to configure. This option will make GCC fail if it hits a warning. Note that the warnings generated vary from one version of GCC to the -next, and from one architecture to the next (apparently). To provide -a concrete common standard, Guile should compile without warnings from -GCC 2.7.2.3 in a Red Hat 5.2 i386 Linux machine. Furthermore, each -developer should pursue any additional warnings noted by on their -compiler. This means that people using more stringent compilers will -have more work to do, and assures that everyone won't switch to the -most lenient compiler they can find. :) +next, and from one architecture to the next. For this reason, +--enable-error-on-warning is not enabled by default. - If you add code which uses functions or other features that are not entirely portable, please make sure the rest of Guile will still function properly on systems where they are missing. This usually entails adding a test to configure.in, and then adding #ifdefs to your -code to disable it if the system's features are missing. +code to disable it if the system's features are missing. Do check first +if the function has a Gnulib wrapper, though. - The normal way of removing a function, macro or variable is to mark it as "deprecated", keep it for a while, and remove it in a later @@ -225,10 +159,6 @@ When deprecating a definition, always follow this procedure: 4. Add an entry that the definition has been deprecated in NEWS and explain what to do instead. -5. In file TODO, there is a list of releases with reminders about what - to do at each release. Add a reminder about the removal of the - deprecated defintion at the appropriate release. - - Write commit messages for functions written in C using the functions' C names, and write entries for functions written in Scheme using the functions' Scheme names. For example, @@ -266,12 +196,12 @@ Maintainers of GNU Software": has signed copyright papers, and that the Free Software Foundation has received them. -If you receive contributions you want to use from someone, let me know -and I'll take care of the administrivia. Put the contributions aside -until we have the necessary papers. +If you receive contributions you want to use from someone, let a +maintainer know and they will take care of the administrivia. Put the +contributions aside until we have the necessary papers. Once you accept a contribution, be sure to keep the files AUTHORS and -THANKS uptodate. +THANKS up-to-date. - When you make substantial changes to a file, add the current year to the list of years in the copyright notice at the top of the file. @@ -325,27 +255,3 @@ The follwing syllables also have a technical meaning: str - this denotes a zero terminated C string mem - a C string with an explicit count - - -See also the file `devel/names.text'. - - -Helpful hints ======================================================== - -- [From Mikael Djurfeldt] When working on the Guile internals, it is -quite often practical to implement a scheme-level procedure which -helps you examine the feature you're working on. - -Examples of such procedures are: pt-size, debug-hand and -current-pstate. - -I've now put #ifdef GUILE_DEBUG around all such procedures, so that -they are not compiled into the "normal" Guile library. Please do the -same when you add new procedures/C functions for debugging purpose. - -You can define the GUILE_DEBUG flag by passing --enable-guile-debug to -the configure script. - - -Jim Blandy, and others - From 9210506c4536243a46ef29bd5a6cc6a41233b8d6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 22 May 2017 13:16:06 +0200 Subject: [PATCH 861/865] Remove legacy NEWS.guile-vm. * NEWS.guile-vm: Remove. --- NEWS.guile-vm | 57 --------------------------------------------------- 1 file changed, 57 deletions(-) delete mode 100644 NEWS.guile-vm diff --git a/NEWS.guile-vm b/NEWS.guile-vm deleted file mode 100644 index c82942f4f..000000000 --- a/NEWS.guile-vm +++ /dev/null @@ -1,57 +0,0 @@ -Guile-VM NEWS - - -Guile-VM is a bytecode compiler and virtual machine for Guile. - - -guile-vm 0.7 -- 2008-05-20 -========================== - -* Initial release with NEWS. - -* Revived from Keisuke Nishida's Guile-VM project from 2000-2001, with - the help of Ludovic Courtès. - -* Meta-level changes -** Updated to compile with Guile 1.8. -** Documentation updated, including documentation on the instructions. -** Added benchmarking and a test harness. - -* Changes to the inventory -** Renamed the library from libguilevm to libguile-vm. -** Added new executable script, guile-disasm. - -* New features -** Add support for compiling macros, both defmacros and syncase macros. -Primitive macros produced with the procedure->macro family of procedures -are not supported, however. -** Improvements to the REPL -Multiple values support, readline integration, ice-9 history integration -** Add support for eval-case -The compiler recognizes compile-toplevel in addition to load-toplevel -** Completely self-compiling -Almost, anyway: not (system repl describe), because it uses GOOPS - -* Internal cleanups -** Internal objects are now based on Guile records. -** Guile-VM's code doesn't use the dot-syntax any more. -** Changed (ice-9 match) for Kiselyov's pmatch.scm -** New instructions: define, link-later, link-now, late-variable-{ref,set} -** Object code now represented as u8vectors instead of strings. -** Remove local import of an old version of slib - -* Bugfixes -** The `optimize' procedure is coming out of bitrot -** The Scheme compiler is now more strict about placement of internal - defines -** set! is now compiled differently from define -** Module-level variables are now bound at first use instead of in the - program prolog -** Bugfix to load-program (stack misinterpretation) - - -Copyright (C) 2008 Free Software Foundation, Inc. - -Copying and distribution of this file, with or without modification, are -permitted in any medium without royalty provided the copyright notice -and this notice are preserved. From 8f4597d1da371c23e19721c2fdb3177c3ae73f14 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 22 May 2017 13:16:23 +0200 Subject: [PATCH 862/865] Minor updates of README. * README: Minor updates. --- README | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/README b/README index cffee2253..575ea5c3b 100644 --- a/README +++ b/README @@ -414,8 +414,6 @@ Documentation in Info format, in ${prefix}/info: guile --- Guile reference manual. - guile-tut --- Guile tutorial. - GOOPS --- GOOPS reference manual. r5rs --- Revised(5) Report on the Algorithmic Language Scheme. @@ -426,9 +424,7 @@ The Guile source tree is laid out as follows: libguile: The Guile Scheme interpreter --- both the object library for you to link with your programs, and the executable you can run. -ice-9: Guile's module system, initialization code, and other infrastructure. -guile-config: - Source for the guile-config script. +module: Scheme libraries included with Guile. guile-readline: The glue code for using GNU readline with Guile. This will be build when configure can find a recent enough readline From 96bb1b50e1eeb49ddf31369f3f5a077027a7cca5 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 31 May 2017 21:50:09 +0200 Subject: [PATCH 863/865] guile.m4 fix for 3.0 prereleases * meta/guile.m4 (GUILE_PROGS): Allow prereleases of Guile with a new major version. --- meta/guile.m4 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/meta/guile.m4 b/meta/guile.m4 index 23c2c63bc..4978880a3 100644 --- a/meta/guile.m4 +++ b/meta/guile.m4 @@ -287,6 +287,9 @@ AC_DEFUN([GUILE_PROGS], else as_fn_error $? "Guile $_guile_required_version required, but $_guile_prog_version found" "$LINENO" 5 fi + elif test "$GUILE_EFFECTIVE_VERSION" = "$_major_version.$_minor_version" -a -z "$_micro_version"; then + # Allow prereleases that have the right effective version. + true else AC_MSG_ERROR([Guile $_guile_required_version required, but $_guile_prog_version found]) fi From 9846178c69445142ef0b9432417453d2d4de6635 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 31 May 2017 21:52:15 +0200 Subject: [PATCH 864/865] Update guile.m4 to check for 2.2 by default * meta/guile.m4 (GUILE_PKG): Update default Guile versions to 2.2. --- meta/guile.m4 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/meta/guile.m4 b/meta/guile.m4 index 4978880a3..89823e9c3 100644 --- a/meta/guile.m4 +++ b/meta/guile.m4 @@ -61,7 +61,7 @@ # AC_DEFUN([GUILE_PKG], [PKG_PROG_PKG_CONFIG - _guile_versions_to_search="m4_default([$1], [2.0 1.8])" + _guile_versions_to_search="m4_default([$1], [2.2 2.0 1.8])" if test -n "$GUILE_EFFECTIVE_VERSION"; then _guile_tmp="" for v in $_guile_versions_to_search; do @@ -221,7 +221,7 @@ AC_DEFUN([GUILE_SITE_DIR], # as well. # # By default, this macro will search for the latest stable version of -# Guile (e.g. 2.0). x.y or x.y.z versions can be specified. If an older +# Guile (e.g. 2.2). x.y or x.y.z versions can be specified. If an older # version is found, the macro will signal an error. # # The effective version of the found @code{guile} is set to @@ -237,7 +237,7 @@ AC_DEFUN([GUILE_SITE_DIR], AC_DEFUN([GUILE_PROGS], [_guile_required_version="m4_default([$1], [$GUILE_EFFECTIVE_VERSION])" if test -z "$_guile_required_version"; then - _guile_required_version=2.0 + _guile_required_version=2.2 fi _guile_candidates=guile From d3fcefc3d5312d1499de0352f8f6e4c9838e0307 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sun, 11 Jun 2017 22:02:26 -0400 Subject: [PATCH 865/865] doc: Document 'short' and 'unsigned-short' foreign types. This is a followup to commit 42f7c01e0a1d1c139ec8b835429a80ab15ac4007. Reported by Adriano Peluso . * doc/ref/api-foreign.texi (Foreign Types): Add missing entries for 'short' and 'unsigned-short'. --- doc/ref/api-foreign.texi | 2 ++ 1 file changed, 2 insertions(+) diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi index 2f5375d28..bb93d6d1f 100644 --- a/doc/ref/api-foreign.texi +++ b/doc/ref/api-foreign.texi @@ -493,6 +493,8 @@ platform-dependent size: @defvrx {Scheme Variable} unsigned-int @defvrx {Scheme Variable} long @defvrx {Scheme Variable} unsigned-long +@defvrx {Scheme Variable} short +@defvrx {Scheme Variable} unsigned-short @defvrx {Scheme Variable} size_t @defvrx {Scheme Variable} ssize_t @defvrx {Scheme Variable} ptrdiff_t